lisp/vc-mcvs.el

   1 ;;; vc-mcvs.el --- VC backend for the Meta-CVS version-control system
   2
   3 ;; Copyright (C) 1995,98,99,2000,01,02,2003  Free Software Foundation, Inc.
   4
   5 ;; Author:      FSF (see vc.el for full credits)
   6 ;; Maintainer:  Stefan Monnier <monnier@gnu.org>
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; The home page of the Meta-CVS version control system is at
  28 ;;
  29 ;;      http://users.footprints.net/~kaz/mcvs.html
  30 ;;
  31 ;; This is derived from vc-cvs.el as follows:
  32 ;; - cp vc-cvs.el vc-mcvs.el
  33 ;; - Replace CVS/ with MCVS/CVS/
  34 ;; - Replace 'CVS with 'MCVS
  35 ;; - Replace -cvs- with -mcvs-
  36 ;; - Replace most of the rest of CVS to Meta-CVS
  37 ;;
  38 ;; Then of course started the hacking.  Only a small part of the code
  39 ;; has been touched and not much more than that was tested, so if
  40 ;; you bump into a bug, don't be surprised: just report it to me.
  41 ;;
  42 ;; What has been partly tested:
  43 ;; - C-x v v to start editing a file that was checked out with CVSREAD on.
  44 ;; - C-x v v to commit a file
  45 ;; - C-x v =
  46 ;; - C-x v l
  47 ;; - C-x v i
  48 ;; - C-x v g
  49
  50 ;;; Bugs:
  51
  52 ;; - VC-dired doesn't work.
  53
  54 ;;; Code:
  55
  56 (eval-when-compile (require 'vc))
  57 (require 'vc-cvs)
  58
  59 ;;;
  60 ;;; Customization options
  61 ;;;
  62
  63 (defcustom vc-mcvs-global-switches nil
  64   "*Global switches to pass to any Meta-CVS command."
  65   :type '(choice (const :tag "None" nil)
  66                  (string :tag "Argument String")
  67                  (repeat :tag "Argument List"
  68                          :value ("")
  69                          string))
  70   :version "21.4"
  71   :group 'vc)
  72
  73 (defcustom vc-mcvs-register-switches nil
  74   "*Extra switches for registering a file into Meta-CVS.
  75 A string or list of strings passed to the checkin program by
  76 \\[vc-register]."
  77   :type '(choice (const :tag "None" nil)
  78                  (string :tag "Argument String")
  79                  (repeat :tag "Argument List"
  80                          :value ("")
  81                          string))
  82   :version "21.4"
  83   :group 'vc)
  84
  85 (defcustom vc-mcvs-diff-switches nil
  86   "*A string or list of strings specifying extra switches for cvs diff under VC."
  87     :type '(choice (const :tag "None" nil)
  88                  (string :tag "Argument String")
  89                  (repeat :tag "Argument List"
  90                          :value ("")
  91                          string))
  92   :version "21.4"
  93   :group 'vc)
  94
  95 (defcustom vc-mcvs-header (or (cdr (assoc 'MCVS vc-header-alist))
  96                               vc-cvs-header)
  97   "*Header keywords to be inserted by `vc-insert-headers'."
  98   :version "21.4"
  99   :type '(repeat string)
 100   :group 'vc)
 101
 102 (defcustom vc-mcvs-use-edit vc-cvs-use-edit
 103   "*Non-nil means to use `cvs edit' to \"check out\" a file.
 104 This is only meaningful if you don't use the implicit checkout model
 105 \(i.e. if you have $CVSREAD set)."
 106   :type 'boolean
 107   :version "21.4"
 108   :group 'vc)
 109
 110 (defcustom vc-mcvs-stay-local vc-cvs-stay-local
 111   "*Non-nil means use local operations when possible for remote repositories.
 112 This avoids slow queries over the network and instead uses heuristics
 113 and past information to determine the current status of a file.
 114 The value can also be a regular expression to match against the host name
 115 of a repository; then VC only stays local for hosts that match it."
 116   :type '(choice (const :tag "Always stay local" t)
 117                  (string :tag "Host regexp")
 118                  (const :tag "Don't stay local" nil))
 119   :version "21.4"
 120   :group 'vc)
 121
 122 ;;;
 123 ;;; State-querying functions
 124 ;;;
 125
 126 ;;;###autoload (defun vc-mcvs-registered (file)
 127 ;;;###autoload   (let ((dir file))
 128 ;;;###autoload     (while (and (stringp dir)
 129 ;;;###autoload          (not (equal dir (setq dir (file-name-directory dir)))))
 130 ;;;###autoload       (setq dir (if (file-directory-p
 131 ;;;###autoload               (expand-file-name "MCVS/CVS" dir))
 132 ;;;###autoload              t (directory-file-name dir))))
 133 ;;;###autoload     (if (eq dir t)
 134 ;;;###autoload  (progn
 135 ;;;###autoload    (load "vc-mcvs")
 136 ;;;###autoload    (vc-mcvs-registered file)))))
 137
 138 (defun vc-mcvs-root (file)
 139   "Return the root directory of a Meta-CVS project, if any."
 140   (or (vc-file-getprop file 'mcvs-root)
 141       (vc-file-setprop
 142        file 'mcvs-root
 143        (let ((root nil))
 144          (while (not (or root
 145                          (equal file (setq file (file-name-directory file)))))
 146            (if (file-directory-p (expand-file-name "MCVS/CVS" file))
 147                (setq root file)
 148              (setq file (directory-file-name file))))
 149          root))))
 150
 151 (defun vc-mcvs-read (file)
 152   (with-temp-buffer
 153     (insert-file-contents file)
 154     (goto-char (point-min))
 155     (read (current-buffer))))
 156
 157 (defun vc-mcvs-map-file (dir file)
 158   (let ((map (vc-mcvs-read (expand-file-name "MCVS/MAP" dir)))
 159         inode)
 160     (dolist (x map inode)
 161       (if (equal (nth 2 x) file) (setq inode (nth 1 x))))))
 162
 163 (defun vc-mcvs-registered (file)
 164   (let (root inode cvsfile)
 165     (when (and (setq root (vc-mcvs-root file))
 166                (setq inode (vc-mcvs-map-file
 167                             root (file-relative-name file root))))
 168       (vc-file-setprop file 'mcvs-inode inode)
 169       ;; Avoid calling `mcvs diff' in vc-workfile-unchanged-p.
 170       (vc-file-setprop file 'vc-checkout-time
 171                        (if (vc-cvs-registered
 172                             (setq cvsfile (expand-file-name inode root)))
 173                            (vc-file-getprop cvsfile 'vc-checkout-time)
 174                          ;; The file might not be registered yet because
 175                          ;; of lazy-adding.
 176                          0))
 177       t)))
 178
 179 (defmacro vc-mcvs-cvs (op file &rest args)
 180   (declare (debug t))
 181   `(,(intern (concat "vc-cvs-" (symbol-name op)))
 182     (expand-file-name (vc-file-getprop ,file 'mcvs-inode)
 183                       (vc-file-getprop ,file 'mcvs-root))
 184     ,@args))
 185
 186 (defun vc-mcvs-state (file)
 187   ;; This would assume the Meta-CVS sandbox is synchronized.
 188   ;; (vc-mcvs-cvs state file))
 189   "Meta-CVS-specific version of `vc-state'."
 190   (if (vc-mcvs-stay-local-p file)
 191       (let ((state (vc-file-getprop file 'vc-state)))
 192         ;; If we should stay local, use the heuristic but only if
 193         ;; we don't have a more precise state already available.
 194         (if (memq state '(up-to-date edited))
 195             (vc-mcvs-state-heuristic file)
 196           state))
 197     (with-temp-buffer
 198       (cd (file-name-directory file))
 199       (vc-mcvs-command t 0 file "status")
 200       (vc-cvs-parse-status t))))
 201
 202
 203 (defalias 'vc-mcvs-state-heuristic 'vc-cvs-state-heuristic)
 204
 205 (defun vc-mcvs-dir-state (dir)
 206   "Find the Meta-CVS state of all files in DIR."
 207   ;; if DIR is not under Meta-CVS control, don't do anything.
 208   (when (file-readable-p (expand-file-name "MCVS/CVS/Entries" dir))
 209     (if (vc-mcvs-stay-local-p dir)
 210         (vc-mcvs-dir-state-heuristic dir)
 211       (let ((default-directory dir))
 212         ;; Don't specify DIR in this command, the default-directory is
 213         ;; enough.  Otherwise it might fail with remote repositories.
 214         (with-temp-buffer
 215           (vc-mcvs-command t 0 nil "status" "-l")
 216           (goto-char (point-min))
 217           (while (re-search-forward "^=+\n\\([^=\n].*\n\\|\n\\)+" nil t)
 218             (narrow-to-region (match-beginning 0) (match-end 0))
 219             (vc-cvs-parse-status)
 220             (goto-char (point-max))
 221             (widen)))))))
 222
 223 (defun vc-mcvs-workfile-version (file) (vc-mcvs-cvs workfile-version file))
 224
 225 (defalias 'vc-mcvs-checkout-model 'vc-cvs-checkout-model)
 226
 227 (defun vc-mcvs-mode-line-string (file) (vc-mcvs-cvs mode-line-string file))
 228
 229 ;;;
 230 ;;; State-changing functions
 231 ;;;
 232
 233 (defun vc-mcvs-register (file &optional rev comment)
 234   "Register FILE into the Meta-CVS version-control system.
 235 COMMENT can be used to provide an initial description of FILE.
 236
 237 `vc-register-switches' and `vc-mcvs-register-switches' are passed to
 238 the Meta-CVS command (in that order)."
 239   (let* ((filename (file-name-nondirectory file))
 240          (extpos (string-match "\\." filename))
 241          (ext (if extpos (substring filename (1+ extpos))))
 242          (root (vc-mcvs-root file))
 243          (types-file (expand-file-name "MCVS/TYPES" root))
 244          (map-file (expand-file-name "MCVS/MAP" root))
 245          (types (vc-mcvs-read types-file)))
 246     ;; Make sure meta files like MCVS/MAP are not read-only (happens with
 247     ;; CVSREAD) since Meta-CVS doesn't pay attention to it at all and goes
 248     ;; belly-up.
 249     (unless (file-writable-p map-file)
 250       (vc-checkout map-file t))
 251     (unless (or (file-writable-p types-file) (not (file-exists-p types-file)))
 252       (vc-checkout types-file t))
 253     ;; Make sure the `mcvs add' will not fire up the CVSEDITOR
 254     ;; to add a rule for the given file's extension.
 255     (when (and ext (not (assoc ext types)))
 256       (let ((type (completing-read "Type to use [default]: "
 257                                    '("default" "name-only" "keep-old"
 258                                      "binary" "value-only")
 259                                    nil t nil nil "default")))
 260         (push (list ext (make-symbol (upcase (concat ":" type)))) types)
 261         (setq types (sort types (lambda (x y) (string< (car x) (car y)))))
 262         (with-current-buffer (find-file-noselect types-file)
 263           (erase-buffer)
 264           (pp types (current-buffer))
 265           (save-buffer)
 266           (unless (get-buffer-window (current-buffer) t)
 267             (kill-buffer (current-buffer)))))))
 268   ;; Now do the ADD.
 269   (let ((switches (append
 270                    (if (stringp vc-register-switches)
 271                        (list vc-register-switches)
 272                      vc-register-switches)
 273                    (if (stringp vc-mcvs-register-switches)
 274                        (list vc-mcvs-register-switches)
 275                      vc-mcvs-register-switches))))
 276     (prog1 (apply 'vc-mcvs-command nil 0 file
 277                   "add"
 278                   (and comment (string-match "[^\t\n ]" comment)
 279                        (concat "-m" comment))
 280                   switches)
 281       ;; I'm not sure exactly why, but if we don't setup the inode and root
 282       ;; prop of the file, things break later on in vc-mode-line that
 283       ;; ends up calling vc-mcvs-workfile-version.
 284       ;; We also need to set vc-checkout-time so that vc-workfile-unchanged-p
 285       ;; doesn't try to call `mcvs diff' on the file.
 286       (vc-mcvs-registered file))))
 287
 288 (defalias 'vc-mcvs-responsible-p 'vc-mcvs-root
 289   "Return non-nil if CVS thinks it is responsible for FILE.")
 290
 291 (defalias 'vc-cvs-could-register 'vc-cvs-responsible-p
 292   "Return non-nil if FILE could be registered in Meta-CVS.
 293 This is only possible if Meta-CVS is responsible for FILE's directory.")
 294
 295 (defun vc-mcvs-checkin (file rev comment)
 296   "Meta-CVS-specific version of `vc-backend-checkin'."
 297   (let ((switches (if (stringp vc-checkin-switches)
 298                       (list vc-checkin-switches)
 299                     vc-checkin-switches))
 300         status)
 301     (if (or (not rev) (vc-mcvs-valid-version-number-p rev))
 302         (setq status (apply 'vc-mcvs-command nil 1 file
 303                             "ci" (if rev (concat "-r" rev))
 304                             "-m" comment
 305                             switches))
 306       (if (not (vc-mcvs-valid-symbolic-tag-name-p rev))
 307           (error "%s is not a valid symbolic tag name" rev)
 308         ;; If the input revison is a valid symbolic tag name, we create it
 309         ;; as a branch, commit and switch to it.
 310         (apply 'vc-mcvs-command nil 0 file "tag" "-b" (list rev))
 311         (apply 'vc-mcvs-command nil 0 file "update" "-r" (list rev))
 312         (setq status (apply 'vc-mcvs-command nil 1 file
 313                             "ci"
 314                             "-m" comment
 315                             switches))
 316         (vc-file-setprop file 'vc-mcvs-sticky-tag rev)))
 317     (set-buffer "*vc*")
 318     (goto-char (point-min))
 319     (when (not (zerop status))
 320       ;; Check checkin problem.
 321       (cond
 322        ((re-search-forward "Up-to-date check failed" nil t)
 323         (vc-file-setprop file 'vc-state 'needs-merge)
 324         (error (substitute-command-keys
 325                 (concat "Up-to-date check failed: "
 326                         "type \\[vc-next-action] to merge in changes"))))
 327        (t
 328         (pop-to-buffer (current-buffer))
 329         (goto-char (point-min))
 330         (shrink-window-if-larger-than-buffer)
 331         (error "Check-in failed"))))
 332     ;; Update file properties
 333     (vc-file-setprop
 334      file 'vc-workfile-version
 335      (vc-parse-buffer "^\\(new\\|initial\\) revision: \\([0-9.]+\\)" 2))
 336     ;; Forget the checkout model of the file, because we might have
 337     ;; guessed wrong when we found the file.  After commit, we can
 338     ;; tell it from the permissions of the file (see
 339     ;; vc-mcvs-checkout-model).
 340     (vc-file-setprop file 'vc-checkout-model nil)
 341
 342     ;; if this was an explicit check-in (does not include creation of
 343     ;; a branch), remove the sticky tag.
 344     (if (and rev (not (vc-mcvs-valid-symbolic-tag-name-p rev)))
 345         (vc-mcvs-command nil 0 file "update" "-A"))))
 346
 347 (defun vc-mcvs-find-version (file rev buffer)
 348   (apply 'vc-mcvs-command
 349          buffer 0 file
 350          "-Q"                           ; suppress diagnostic output
 351          "update"
 352          (and rev (not (string= rev ""))
 353               (concat "-r" rev))
 354          "-p"
 355          (if (stringp vc-checkout-switches)
 356              (list vc-checkout-switches)
 357            vc-checkout-switches)))
 358
 359 (defun vc-mcvs-checkout (file &optional editable rev)
 360   (message "Checking out %s..." file)
 361   (with-current-buffer (or (get-file-buffer file) (current-buffer))
 362     (let ((switches (if (stringp vc-checkout-switches)
 363                         (list vc-checkout-switches)
 364                       vc-checkout-switches)))
 365       (vc-call update file editable rev switches)))
 366   (vc-mode-line file)
 367   (message "Checking out %s...done" file))
 368
 369 (defun vc-mcvs-update (file editable rev switches)
 370   (if (and (file-exists-p file) (not rev))
 371       ;; If no revision was specified, just make the file writable
 372       ;; if necessary (using `cvs-edit' if requested).
 373       (and editable (not (eq (vc-mcvs-checkout-model file) 'implicit))
 374            (if vc-mcvs-use-edit
 375                (vc-mcvs-command nil 0 file "edit")
 376              (set-file-modes file (logior (file-modes file) 128))
 377              (if (equal file buffer-file-name) (toggle-read-only -1))))
 378     ;; Check out a particular version (or recreate the file).
 379     (vc-file-setprop file 'vc-workfile-version nil)
 380     (apply 'vc-mcvs-command nil 0 file
 381            (if editable "-w")
 382            "update"
 383            ;; default for verbose checkout: clear the sticky tag so
 384            ;; that the actual update will get the head of the trunk
 385            (if (or (not rev) (string= rev ""))
 386                "-A"
 387              (concat "-r" rev))
 388            switches)))
 389
 390 (defun vc-mcvs-revert (file &optional contents-done)
 391   "Revert FILE to the version it was based on."
 392   (vc-default-revert file contents-done)
 393   (unless (eq (vc-checkout-model file) 'implicit)
 394     (if vc-mcvs-use-edit
 395         (vc-mcvs-command nil 0 file "unedit")
 396       ;; Make the file read-only by switching off all w-bits
 397       (set-file-modes file (logand (file-modes file) 3950)))))
 398
 399 (defun vc-mcvs-merge (file first-version &optional second-version)
 400   "Merge changes into current working copy of FILE.
 401 The changes are between FIRST-VERSION and SECOND-VERSION."
 402   (vc-mcvs-command nil 0 file
 403                    "update" "-kk"
 404                    (concat "-j" first-version)
 405                    (concat "-j" second-version))
 406   (vc-file-setprop file 'vc-state 'edited)
 407   (with-current-buffer (get-buffer "*vc*")
 408     (goto-char (point-min))
 409     (if (re-search-forward "conflicts during merge" nil t)
 410         1                               ; signal error
 411       0)))                              ; signal success
 412
 413 (defun vc-mcvs-merge-news (file)
 414   "Merge in any new changes made to FILE."
 415   (message "Merging changes into %s..." file)
 416   ;; (vc-file-setprop file 'vc-workfile-version nil)
 417   (vc-file-setprop file 'vc-checkout-time 0)
 418   (vc-mcvs-command nil 0 file "update")
 419   ;; Analyze the merge result reported by Meta-CVS, and set
 420   ;; file properties accordingly.
 421   (with-current-buffer (get-buffer "*vc*")
 422     (goto-char (point-min))
 423     ;; get new workfile version
 424     (if (re-search-forward
 425          "^Merging differences between [0-9.]* and \\([0-9.]*\\) into" nil t)
 426         (vc-file-setprop file 'vc-workfile-version (match-string 1))
 427       (vc-file-setprop file 'vc-workfile-version nil))
 428     ;; get file status
 429     (prog1
 430         (if (eq (buffer-size) 0)
 431             0 ;; there were no news; indicate success
 432           (if (re-search-forward
 433                (concat "^\\([CMUP] \\)?"
 434                        ".*"
 435                        "\\( already contains the differences between \\)?")
 436                nil t)
 437               (cond
 438                ;; Merge successful, we are in sync with repository now
 439                ((or (match-string 2)
 440                     (string= (match-string 1) "U ")
 441                     (string= (match-string 1) "P "))
 442                 (vc-file-setprop file 'vc-state 'up-to-date)
 443                 (vc-file-setprop file 'vc-checkout-time
 444                                  (nth 5 (file-attributes file)))
 445                 0);; indicate success to the caller
 446                ;; Merge successful, but our own changes are still in the file
 447                ((string= (match-string 1) "M ")
 448                 (vc-file-setprop file 'vc-state 'edited)
 449                 0);; indicate success to the caller
 450                ;; Conflicts detected!
 451                (t
 452                 (vc-file-setprop file 'vc-state 'edited)
 453                 1);; signal the error to the caller
 454                )
 455             (pop-to-buffer "*vc*")
 456             (error "Couldn't analyze mcvs update result")))
 457       (message "Merging changes into %s...done" file))))
 458
 459 ;;;
 460 ;;; History functions
 461 ;;;
 462
 463 (defun vc-mcvs-print-log (file)
 464   "Get change log associated with FILE."
 465   (vc-mcvs-command
 466    nil
 467    (if (and (vc-mcvs-stay-local-p file) (fboundp 'start-process)) 'async 0)
 468    file "log"))
 469
 470 (defun vc-mcvs-diff (file &optional oldvers newvers)
 471   "Get a difference report using Meta-CVS between two versions of FILE."
 472   (let (status (diff-switches-list (vc-diff-switches-list 'MCVS)))
 473     (if (string= (vc-workfile-version file) "0")
 474         ;; This file is added but not yet committed; there is no master file.
 475         (if (or oldvers newvers)
 476             (error "No revisions of %s exist" file)
 477           ;; We regard this as "changed".
 478           ;; Diff it against /dev/null.
 479           ;; Note: this is NOT a "mcvs diff".
 480           (apply 'vc-do-command "*vc-diff*"
 481                  1 "diff" file
 482                  (append diff-switches-list '("/dev/null"))))
 483       (setq status
 484             (apply 'vc-mcvs-command "*vc-diff*"
 485                    (if (and (vc-mcvs-stay-local-p file)
 486                             (fboundp 'start-process))
 487                        'async
 488                      1)
 489                    file "diff"
 490                    (and oldvers (concat "-r" oldvers))
 491                    (and newvers (concat "-r" newvers))
 492                    diff-switches-list))
 493       (if (vc-mcvs-stay-local-p file)
 494           1 ;; async diff, pessimistic assumption
 495         status))))
 496
 497 (defun vc-mcvs-diff-tree (dir &optional rev1 rev2)
 498   "Diff all files at and below DIR."
 499   (with-current-buffer "*vc-diff*"
 500     (setq default-directory dir)
 501     (if (vc-mcvs-stay-local-p dir)
 502         ;; local diff: do it filewise, and only for files that are modified
 503         (vc-file-tree-walk
 504          dir
 505          (lambda (f)
 506            (vc-exec-after
 507             `(let ((coding-system-for-read (vc-coding-system-for-diff ',f)))
 508                ;; possible optimization: fetch the state of all files
 509                ;; in the tree via vc-mcvs-dir-state-heuristic
 510                (unless (vc-up-to-date-p ',f)
 511                  (message "Looking at %s" ',f)
 512                  (vc-diff-internal ',f ',rev1 ',rev2))))))
 513       ;; cvs diff: use a single call for the entire tree
 514       (let ((coding-system-for-read
 515              (or coding-system-for-read 'undecided)))
 516         (apply 'vc-mcvs-command "*vc-diff*" 1 nil "diff"
 517                (and rev1 (concat "-r" rev1))
 518                (and rev2 (concat "-r" rev2))
 519                (vc-diff-switches-list 'MCVS))))))
 520
 521 (defun vc-mcvs-annotate-command (file buffer &optional version)
 522   "Execute \"mcvs annotate\" on FILE, inserting the contents in BUFFER.
 523 Optional arg VERSION is a version to annotate from."
 524   (vc-mcvs-command
 525    buffer
 526    (if (and (vc-mcvs-stay-local-p file) (fboundp 'start-process)) 'async 0)
 527    file "annotate" (if version (concat "-r" version))))
 528
 529 (defalias 'vc-mcvs-annotate-current-time 'vc-cvs-annotate-current-time)
 530 (defalias 'vc-mcvs-annotate-time 'vc-cvs-annotate-time)
 531
 532 ;;;
 533 ;;; Snapshot system
 534 ;;;
 535
 536 (defun vc-mcvs-create-snapshot (dir name branchp)
 537   "Assign to DIR's current version a given NAME.
 538 If BRANCHP is non-nil, the name is created as a branch (and the current
 539 workspace is immediately moved to that new branch)."
 540   (vc-mcvs-command nil 0 dir "tag" "-c" (if branchp "-b") name)
 541   (when branchp (vc-mcvs-command nil 0 dir "update" "-r" name)))
 542
 543 (defun vc-mcvs-retrieve-snapshot (dir name update)
 544   "Retrieve a snapshot at and below DIR.
 545 NAME is the name of the snapshot; if it is empty, do a `cvs update'.
 546 If UPDATE is non-nil, then update (resynch) any affected buffers."
 547   (with-current-buffer (get-buffer-create "*vc*")
 548     (let ((default-directory dir)
 549           (sticky-tag))
 550       (erase-buffer)
 551       (if (or (not name) (string= name ""))
 552           (vc-mcvs-command t 0 nil "update")
 553         (vc-mcvs-command t 0 nil "update" "-r" name)
 554         (setq sticky-tag name))
 555       (when update
 556         (goto-char (point-min))
 557         (while (not (eobp))
 558           (if (looking-at "\\([CMUP]\\) \\(.*\\)")
 559               (let* ((file (expand-file-name (match-string 2) dir))
 560                      (state (match-string 1))
 561                      (buffer (find-buffer-visiting file)))
 562                 (when buffer
 563                   (cond
 564                    ((or (string= state "U")
 565                         (string= state "P"))
 566                     (vc-file-setprop file 'vc-state 'up-to-date)
 567                     (vc-file-setprop file 'vc-workfile-version nil)
 568                     (vc-file-setprop file 'vc-checkout-time
 569                                      (nth 5 (file-attributes file))))
 570                    ((or (string= state "M")
 571                         (string= state "C"))
 572                     (vc-file-setprop file 'vc-state 'edited)
 573                     (vc-file-setprop file 'vc-workfile-version nil)
 574                     (vc-file-setprop file 'vc-checkout-time 0)))
 575                   (vc-file-setprop file 'vc-mcvs-sticky-tag sticky-tag)
 576                   (vc-resynch-buffer file t t))))
 577           (forward-line 1))))))
 578
 579
 580 ;;;
 581 ;;; Miscellaneous
 582 ;;;
 583
 584 (defalias 'vc-mcvs-make-version-backups-p 'vc-mcvs-stay-local-p
 585   "Return non-nil if version backups should be made for FILE.")
 586 (defalias 'vc-mcvs-check-headers 'vc-cvs-check-headers)
 587
 588
 589 ;;;
 590 ;;; Internal functions
 591 ;;;
 592
 593 (defun vc-mcvs-command (buffer okstatus file &rest flags)
 594   "A wrapper around `vc-do-command' for use in vc-mcvs.el.
 595 The difference to vc-do-command is that this function always invokes `mcvs',
 596 and that it passes `vc-mcvs-global-switches' to it before FLAGS."
 597   (let ((args (append '("--error-continue")
 598                       (if (stringp vc-mcvs-global-switches)
 599                           (cons vc-mcvs-global-switches flags)
 600                         (append vc-mcvs-global-switches
 601                                 flags)))))
 602     (if (member (car flags) '("diff" "log"))
 603         ;; We need to filter the output.
 604         (vc-do-command buffer okstatus "sh" nil "-c"
 605                        (concat "mcvs "
 606                                (mapconcat
 607                                 'shell-quote-argument
 608                                 (append (remq nil args)
 609                                         (if file (list (file-relative-name file))))
 610                                 " ")
 611                                " | mcvs filt"))
 612       (apply 'vc-do-command buffer okstatus "mcvs" file args))))
 613
 614 (defun vc-mcvs-stay-local-p (file) (vc-mcvs-cvs stay-local-p file))
 615
 616 (defun vc-mcvs-dir-state-heuristic (dir)
 617   "Find the Meta-CVS state of all files in DIR, using only local information."
 618   (with-temp-buffer
 619     (vc-cvs-get-entries dir)
 620     (goto-char (point-min))
 621     (while (not (eobp))
 622       ;; Meta-MCVS-removed files are not taken under VC control.
 623       (when (looking-at "/\\([^/]*\\)/[^/-]")
 624         (let ((file (expand-file-name (match-string 1) dir)))
 625           (unless (vc-file-getprop file 'vc-state)
 626             (vc-cvs-parse-entry file t))))
 627       (forward-line 1))))
 628
 629 (defalias 'vc-mcvs-valid-symbolic-tag-name-p 'vc-cvs-valid-symbolic-tag-name-p)
 630 (defalias 'vc-mcvs-valid-version-number-p 'vc-cvs-valid-version-number-p)
 631
 632 (provide 'vc-mcvs)
 633 ;;; vc-mcvs.el ends here