Source

emacs / lisp / vc-rcs.el

   1
   2
   3
   4
   5
   6
   7
   8
   9
  10
  11
  12
  13
  14
  15
  16
  17
  18
  19
  20
  21
  22
  23
  24
  25
  26
  27
  28
  29
  30
  31
  32
  33
  34
  35
  36
  37
  38
  39
  40
  41
  42
  43
  44
  45
  46
  47
  48
  49
  50
  51
  52
  53
  54
  55
  56
  57
  58
  59
  60
  61
  62
  63
  64
  65
  66
  67
  68
  69
  70
  71
  72
  73
  74
  75
  76
  77
  78
  79
  80
  81
  82
  83
  84
  85
  86
  87
  88
  89
  90
  91
  92
  93
  94
  95
  96
  97
  98
  99
 100
 101
 102
 103
 104
 105
 106
 107
 108
 109
 110
 111
 112
 113
 114
 115
 116
 117
 118
 119
 120
 121
 122
 123
 124
 125
 126
 127
 128
 129
 130
 131
 132
 133
 134
 135
 136
 137
 138
 139
 140
 141
 142
 143
 144
 145
 146
 147
 148
 149
 150
 151
 152
 153
 154
 155
 156
 157
 158
 159
 160
 161
 162
 163
 164
 165
 166
 167
 168
 169
 170
 171
 172
 173
 174
 175
 176
 177
 178
 179
 180
 181
 182
 183
 184
 185
 186
 187
 188
 189
 190
 191
 192
 193
 194
 195
 196
 197
 198
 199
 200
 201
 202
 203
 204
 205
 206
 207
 208
 209
 210
 211
 212
 213
 214
 215
 216
 217
 218
 219
 220
 221
 222
 223
 224
 225
 226
 227
 228
 229
 230
 231
 232
 233
 234
 235
 236
 237
 238
 239
 240
 241
 242
 243
 244
 245
 246
 247
 248
 249
 250
 251
 252
 253
 254
 255
 256
 257
 258
 259
 260
 261
 262
 263
 264
 265
 266
 267
 268
 269
 270
 271
 272
 273
 274
 275
 276
 277
 278
 279
 280
 281
 282
 283
 284
 285
 286
 287
 288
 289
 290
 291
 292
 293
 294
 295
 296
 297
 298
 299
 300
 301
 302
 303
 304
 305
 306
 307
 308
 309
 310
 311
 312
 313
 314
 315
 316
 317
 318
 319
 320
 321
 322
 323
 324
 325
 326
 327
 328
 329
 330
 331
 332
 333
 334
 335
 336
 337
 338
 339
 340
 341
 342
 343
 344
 345
 346
 347
 348
 349
 350
 351
 352
 353
 354
 355
 356
 357
 358
 359
 360
 361
 362
 363
 364
 365
 366
 367
 368
 369
 370
 371
 372
 373
 374
 375
 376
 377
 378
 379
 380
 381
 382
 383
 384
 385
 386
 387
 388
 389
 390
 391
 392
 393
 394
 395
 396
 397
 398
 399
 400
 401
 402
 403
 404
 405
 406
 407
 408
 409
 410
 411
 412
 413
 414
 415
 416
 417
 418
 419
 420
 421
 422
 423
 424
 425
 426
 427
 428
 429
 430
 431
 432
 433
 434
 435
 436
 437
 438
 439
 440
 441
 442
 443
 444
 445
 446
 447
 448
 449
 450
 451
 452
 453
 454
 455
 456
 457
 458
 459
 460
 461
 462
 463
 464
 465
 466
 467
 468
 469
 470
 471
 472
 473
 474
 475
 476
 477
 478
 479
 480
 481
 482
 483
 484
 485
 486
 487
 488
 489
 490
 491
 492
 493
 494
 495
 496
 497
 498
 499
 500
 501
 502
 503
 504
 505
 506
 507
 508
 509
 510
 511
 512
 513
 514
 515
 516
 517
 518
 519
 520
 521
 522
 523
 524
 525
 526
 527
 528
 529
 530
 531
 532
 533
 534
 535
 536
 537
 538
 539
 540
 541
 542
 543
 544
 545
 546
 547
 548
 549
 550
 551
 552
 553
 554
 555
 556
 557
 558
 559
 560
 561
 562
 563
 564
 565
 566
 567
 568
 569
 570
 571
 572
 573
 574
 575
 576
 577
 578
 579
 580
 581
 582
 583
 584
 585
 586
 587
 588
 589
 590
 591
 592
 593
 594
 595
 596
 597
 598
 599
 600
 601
 602
 603
 604
 605
 606
 607
 608
 609
 610
 611
 612
 613
 614
 615
 616
 617
 618
 619
 620
 621
 622
 623
 624
 625
 626
 627
 628
 629
 630
 631
 632
 633
 634
 635
 636
 637
 638
 639
 640
 641
 642
 643
 644
 645
 646
 647
 648
 649
 650
 651
 652
 653
 654
 655
 656
 657
 658
 659
 660
 661
 662
 663
 664
 665
 666
 667
 668
 669
 670
 671
 672
 673
 674
 675
 676
 677
 678
 679
 680
 681
 682
 683
 684
 685
 686
 687
 688
 689
 690
 691
 692
 693
 694
 695
 696
 697
 698
 699
 700
 701
 702
 703
 704
 705
 706
 707
 708
 709
 710
 711
 712
 713
 714
 715
 716
 717
 718
 719
 720
 721
 722
 723
 724
 725
 726
 727
 728
 729
 730
 731
 732
 733
 734
 735
 736
 737
 738
 739
 740
 741
 742
 743
 744
 745
 746
 747
 748
 749
 750
 751
 752
 753
 754
 755
 756
 757
 758
 759
 760
 761
 762
 763
 764
 765
 766
 767
 768
 769
 770
 771
 772
 773
 774
 775
 776
 777
 778
 779
 780
 781
 782
 783
 784
 785
 786
 787
 788
 789
 790
 791
 792
 793
 794
 795
 796
 797
 798
 799
 800
 801
 802
 803
 804
 805
 806
 807
 808
 809
 810
 811
 812
 813
 814
 815
 816
 817
 818
 819
 820
 821
 822
 823
 824
 825
 826
 827
 828
 829
 830
 831
 832
 833
 834
 835
 836
 837
 838
 839
 840
 841
 842
 843
 844
 845
 846
 847
 848
 849
 850
 851
 852
 853
 854
 855
 856
 857
 858
 859
 860
 861
 862
 863
 864
 865
 866
 867
 868
 869
 870
 871
 872
 873
 874
 875
 876
 877
 878
 879
 880
 881
 882
 883
 884
 885
 886
 887
 888
 889
 890
 891
 892
 893
 894
 895
 896
 897
 898
 899
 900
 901
 902
 903
 904
 905
 906
 907
 908
 909
 910
 911
 912
 913
 914
 915
 916
 917
 918
 919
 920
 921
 922
 923
 924
 925
 926
 927
 928
 929
 930
 931
 932
 933
 934
 935
 936
 937
 938
 939
 940
 941
 942
 943
 944
 945
 946
 947
 948
 949
 950
 951
 952
 953
 954
 955
 956
 957
 958
 959
 960
 961
 962
 963
 964
 965
 966
 967
 968
 969
 970
 971
 972
 973
 974
 975
 976
 977
 978
 979
 980
 981
 982
 983
 984
 985
 986
 987
 988
 989
 990
 991
 992
 993
 994
 995
 996
 997
 998
 999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
;;; vc-rcs.el --- support for RCS version-control

;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
;;   2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.

;; Author:     FSF (see vc.el for full credits)
;; Maintainer: Andre Spiegel <spiegel@gnu.org>

;; $Id$

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; See vc.el

;;; Code:

;;;
;;; Customization options
;;;

(eval-when-compile
  (require 'cl)
  (require 'vc))

(defcustom vc-rcs-release nil
  "*The release number of your RCS installation, as a string.
If nil, VC itself computes this value when it is first needed."
  :type '(choice (const :tag "Auto" nil)
		 (string :tag "Specified")
		 (const :tag "Unknown" unknown))
  :group 'vc)

(defcustom vc-rcs-register-switches nil
  "*Extra switches for registering a file in RCS.
A string or list of strings.  These are passed to the checkin program
by \\[vc-rcs-register]."
  :type '(choice (const :tag "None" nil)
		 (string :tag "Argument String")
		 (repeat :tag "Argument List"
			 :value ("")
			 string))
  :version "21.1"
  :group 'vc)

(defcustom vc-rcs-diff-switches nil
  "*A string or list of strings specifying extra switches for rcsdiff under VC."
  :type '(choice (const :tag "None" nil)
		 (string :tag "Argument String")
		 (repeat :tag "Argument List"
			 :value ("")
			 string))
  :version "21.1"
  :group 'vc)

(defcustom vc-rcs-header (or (cdr (assoc 'RCS vc-header-alist)) '("\$Id\$"))
  "*Header keywords to be inserted by `vc-insert-headers'."
  :type '(repeat string)
  :version "21.1"
  :group 'vc)

(defcustom vc-rcsdiff-knows-brief nil
  "*Indicates whether rcsdiff understands the --brief option.
The value is either `yes', `no', or nil.  If it is nil, VC tries
to use --brief and sets this variable to remember whether it worked."
  :type '(choice (const :tag "Work out" nil) (const yes) (const no))
  :group 'vc)

;;;###autoload
(defcustom vc-rcs-master-templates
  '("%sRCS/%s,v" "%s%s,v" "%sRCS/%s")
  "*Where to look for RCS master files.
For a description of possible values, see `vc-check-master-templates'."
  :type '(choice (const :tag "Use standard RCS file names"
			'("%sRCS/%s,v" "%s%s,v" "%sRCS/%s"))
		 (repeat :tag "User-specified"
			 (choice string
				 function)))
  :version "21.1"
  :group 'vc)


;;;
;;; State-querying functions
;;;

;;; The autoload cookie below places vc-rcs-registered directly into
;;; loaddefs.el, so that vc-rcs.el does not need to be loaded for
;;; every file that is visited.  The definition is repeated below
;;; so that Help and etags can find it.

;;;###autoload (defun vc-rcs-registered (f) (vc-default-registered 'RCS f))
(defun vc-rcs-registered (f) (vc-default-registered 'RCS f))

(defun vc-rcs-state (file)
  "Implementation of `vc-state' for RCS."
  (or (boundp 'vc-rcs-headers-result)
      (and vc-consult-headers
           (vc-rcs-consult-headers file)))
  (let ((state
         ;; vc-workfile-version might not be known; in that case the
         ;; property is nil.  vc-rcs-fetch-master-state knows how to
         ;; handle that.
         (vc-rcs-fetch-master-state file
                                    (vc-file-getprop file
                                                     'vc-workfile-version))))
    (if (not (eq state 'up-to-date))
        state
      (if (vc-workfile-unchanged-p file)
          'up-to-date
        (if (eq (vc-checkout-model file) 'locking)
            'unlocked-changes
          'edited)))))

(defun vc-rcs-state-heuristic (file)
  "State heuristic for RCS."
  (let (vc-rcs-headers-result)
    (if (and vc-consult-headers
             (setq vc-rcs-headers-result
                   (vc-rcs-consult-headers file))
             (eq vc-rcs-headers-result 'rev-and-lock))
        (let ((state (vc-file-getprop file 'vc-state)))
          ;; If the headers say that the file is not locked, the
          ;; permissions can tell us whether locking is used for
          ;; the file or not.
          (if (and (eq state 'up-to-date)
                   (not (vc-mistrust-permissions file)))
              (cond
               ((string-match ".rw..-..-." (nth 8 (file-attributes file)))
                (vc-file-setprop file 'vc-checkout-model 'implicit)
		(setq state
		      (if (vc-rcs-workfile-is-newer file)
			  'edited
			'up-to-date)))
               ((string-match ".r-..-..-." (nth 8 (file-attributes file)))
                (vc-file-setprop file 'vc-checkout-model 'locking))))
          state)
      (if (not (vc-mistrust-permissions file))
          (let* ((attributes  (file-attributes file 'string))
                 (owner-name  (nth 2 attributes))
                 (permissions (nth 8 attributes)))
            (cond ((string-match ".r-..-..-." permissions)
                   (vc-file-setprop file 'vc-checkout-model 'locking)
                   'up-to-date)
                  ((string-match ".rw..-..-." permissions)
		   (if (eq (vc-checkout-model file) 'locking)
		       (if (file-ownership-preserved-p file)
			   'edited
			 owner-name)
		     (if (vc-rcs-workfile-is-newer file)
			 'edited
		       'up-to-date)))
                  (t
                   ;; Strange permissions.  Fall through to
                   ;; expensive state computation.
                   (vc-rcs-state file))))
        (vc-rcs-state file)))))

(defun vc-rcs-workfile-version (file)
  "RCS-specific version of `vc-workfile-version'."
  (or (and vc-consult-headers
           (vc-rcs-consult-headers file)
           (vc-file-getprop file 'vc-workfile-version))
      (progn
        (vc-rcs-fetch-master-state file)
        (vc-file-getprop file 'vc-workfile-version))))

(defun vc-rcs-latest-on-branch-p (file &optional version)
  "Return non-nil if workfile version of FILE is the latest on its branch.
When VERSION is given, perform check for that version."
  (unless version (setq version (vc-workfile-version file)))
  (with-temp-buffer
    (string= version
	     (if (vc-trunk-p version)
		 (progn
		   ;; Compare VERSION to the head version number.
		   (vc-insert-file (vc-name file) "^[0-9]")
		   (vc-parse-buffer "^head[ \t\n]+\\([^;]+\\);" 1))
	       ;; If we are not on the trunk, we need to examine the
	       ;; whole current branch.
	       (vc-insert-file (vc-name file) "^desc")
	       (vc-rcs-find-most-recent-rev (vc-branch-part version))))))

(defun vc-rcs-checkout-model (file)
  "RCS-specific version of `vc-checkout-model'."
  (let (result)
    (when vc-consult-headers
      (vc-file-setprop file 'vc-checkout-model nil)
      (vc-rcs-consult-headers file)
      (setq result (vc-file-getprop file 'vc-checkout-model)))
    (or result
        (progn (vc-rcs-fetch-master-state file)
               (vc-file-getprop file 'vc-checkout-model)))))

(defun vc-rcs-workfile-unchanged-p (file)
  "RCS-specific implementation of `vc-workfile-unchanged-p'."
  ;; Try to use rcsdiff --brief.  If rcsdiff does not understand that,
  ;; do a double take and remember the fact for the future
  (let* ((version (concat "-r" (vc-workfile-version file)))
         (status (if (eq vc-rcsdiff-knows-brief 'no)
                     (vc-do-command nil 1 "rcsdiff" file version)
                   (vc-do-command nil 2 "rcsdiff" file "--brief" version))))
    (if (eq status 2)
        (if (not vc-rcsdiff-knows-brief)
            (setq vc-rcsdiff-knows-brief 'no
                  status (vc-do-command nil 1 "rcsdiff" file version))
          (error "rcsdiff failed"))
      (if (not vc-rcsdiff-knows-brief) (setq vc-rcsdiff-knows-brief 'yes)))
    ;; The workfile is unchanged if rcsdiff found no differences.
    (zerop status)))


;;;
;;; State-changing functions
;;;

(defun vc-rcs-register (file &optional rev comment)
  "Register FILE into the RCS version-control system.
REV is the optional revision number for the file.  COMMENT can be used
to provide an initial description of FILE.

`vc-register-switches' and `vc-rcs-register-switches' are passed to
the RCS command (in that order).

Automatically retrieve a read-only version of the file with keywords
expanded if `vc-keep-workfiles' is non-nil, otherwise, delete the workfile."
    (let ((subdir (expand-file-name "RCS" (file-name-directory file))))
      (and (not (file-exists-p subdir))
	   (not (directory-files (file-name-directory file)
				 nil ".*,v$" t))
	   (yes-or-no-p "Create RCS subdirectory? ")
	   (make-directory subdir))
      (apply 'vc-do-command nil 0 "ci" file
	     ;; if available, use the secure registering option
	     (and (vc-rcs-release-p "5.6.4") "-i")
	     (concat (if vc-keep-workfiles "-u" "-r") rev)
	     (and comment (concat "-t-" comment))
	     (vc-switches 'RCS 'register))
      ;; parse output to find master file name and workfile version
      (with-current-buffer "*vc*"
        (goto-char (point-min))
        (let ((name (if (looking-at (concat "^\\(.*\\)  <--  "
                                            (file-name-nondirectory file)))
                        (match-string 1))))
          (if (not name)
              ;; if we couldn't find the master name,
              ;; run vc-rcs-registered to get it
              ;; (will be stored into the vc-name property)
              (vc-rcs-registered file)
            (vc-file-setprop file 'vc-name
                             (if (file-name-absolute-p name)
                                 name
                               (expand-file-name
                                name
                                (file-name-directory file))))))
        (vc-file-setprop file 'vc-workfile-version
                         (if (re-search-forward
                              "^initial revision: \\([0-9.]+\\).*\n"
                              nil t)
                             (match-string 1))))))

(defun vc-rcs-responsible-p (file)
  "Return non-nil if RCS thinks it would be responsible for registering FILE."
  ;; TODO: check for all the patterns in vc-rcs-master-templates
  (file-directory-p (expand-file-name "RCS" (file-name-directory file))))

(defun vc-rcs-receive-file (file rev)
  "Implementation of receive-file for RCS."
  (let ((checkout-model (vc-checkout-model file)))
    (vc-rcs-register file rev "")
    (when (eq checkout-model 'implicit)
      (vc-rcs-set-non-strict-locking file))
    (vc-rcs-set-default-branch file (concat rev ".1"))))

(defun vc-rcs-unregister (file)
  "Unregister FILE from RCS.
If this leaves the RCS subdirectory empty, ask the user
whether to remove it."
  (let* ((master (vc-name file))
	 (dir (file-name-directory master))
	 (backup-info (find-backup-file-name master)))
    (if (not backup-info)
	(delete-file master)
      (rename-file master (car backup-info) 'ok-if-already-exists)
      (dolist (f (cdr backup-info)) (ignore-errors (delete-file f))))
    (and (string= (file-name-nondirectory (directory-file-name dir)) "RCS")
	 ;; check whether RCS dir is empty, i.e. it does not
	 ;; contain any files except "." and ".."
	 (not (directory-files dir nil
			       "^\\([^.]\\|\\.[^.]\\|\\.\\.[^.]\\).*"))
	 (yes-or-no-p (format "Directory %s is empty; remove it? " dir))
	 (delete-directory dir))))

(defun vc-rcs-checkin (file rev comment)
  "RCS-specific version of `vc-backend-checkin'."
  (let ((switches (vc-switches 'RCS 'checkin)))
    (let ((old-version (vc-workfile-version file)) new-version
	  (default-branch (vc-file-getprop file 'vc-rcs-default-branch)))
      ;; Force branch creation if an appropriate
      ;; default branch has been set.
      (and (not rev)
	   default-branch
	   (string-match (concat "^" (regexp-quote old-version) "\\.")
			 default-branch)
	   (setq rev default-branch)
	   (setq switches (cons "-f" switches)))
      (if (and (not rev) old-version)
          (setq rev (vc-branch-part old-version)))
      (apply 'vc-do-command nil 0 "ci" (vc-name file)
	     ;; if available, use the secure check-in option
	     (and (vc-rcs-release-p "5.6.4") "-j")
	     (concat (if vc-keep-workfiles "-u" "-r") rev)
	     (concat "-m" comment)
	     switches)
      (vc-file-setprop file 'vc-workfile-version nil)

      ;; determine the new workfile version
      (set-buffer "*vc*")
      (goto-char (point-min))
      (when (or (re-search-forward
		 "new revision: \\([0-9.]+\\);" nil t)
		(re-search-forward
		 "reverting to previous revision \\([0-9.]+\\)" nil t))
	(setq new-version (match-string 1))
	(vc-file-setprop file 'vc-workfile-version new-version))

      ;; if we got to a different branch, adjust the default
      ;; branch accordingly
      (cond
       ((and old-version new-version
	     (not (string= (vc-branch-part old-version)
			   (vc-branch-part new-version))))
	(vc-rcs-set-default-branch file
				   (if (vc-trunk-p new-version) nil
				     (vc-branch-part new-version)))
	;; If this is an old RCS release, we might have
	;; to remove a remaining lock.
	(if (not (vc-rcs-release-p "5.6.2"))
	    ;; exit status of 1 is also accepted.
	    ;; It means that the lock was removed before.
	    (vc-do-command nil 1 "rcs" (vc-name file)
			   (concat "-u" old-version))))))))

(defun vc-rcs-find-version (file rev buffer)
  (apply 'vc-do-command
	 buffer 0 "co" (vc-name file)
	 "-q" ;; suppress diagnostic output
	 (concat "-p" rev)
	 (vc-switches 'RCS 'checkout)))

(defun vc-rcs-checkout (file &optional editable rev)
  "Retrieve a copy of a saved version of FILE."
  (let ((file-buffer (get-file-buffer file))
	switches)
    (message "Checking out %s..." file)
    (save-excursion
      ;; Change buffers to get local value of vc-checkout-switches.
      (if file-buffer (set-buffer file-buffer))
      (setq switches (vc-switches 'RCS 'checkout))
      ;; Save this buffer's default-directory
      ;; and use save-excursion to make sure it is restored
      ;; in the same buffer it was saved in.
      (let ((default-directory default-directory))
	(save-excursion
	  ;; Adjust the default-directory so that the check-out creates
	  ;; the file in the right place.
	  (setq default-directory (file-name-directory file))
	  (let (new-version)
	    ;; if we should go to the head of the trunk,
	    ;; clear the default branch first
	    (and rev (string= rev "")
		 (vc-rcs-set-default-branch file nil))
	    ;; now do the checkout
	    (apply 'vc-do-command
		   nil 0 "co" (vc-name file)
		   ;; If locking is not strict, force to overwrite
		   ;; the writable workfile.
		   (if (eq (vc-checkout-model file) 'implicit) "-f")
		   (if editable "-l")
                   (if (stringp rev)
                       ;; a literal revision was specified
                       (concat "-r" rev)
                     (let ((workrev (vc-workfile-version file)))
                       (if workrev
                           (concat "-r"
                                   (if (not rev)
                                       ;; no revision specified:
                                       ;; use current workfile version
                                       workrev
                                     ;; REV is t ...
                                     (if (not (vc-trunk-p workrev))
                                         ;; ... go to head of current branch
                                         (vc-branch-part workrev)
                                       ;; ... go to head of trunk
                                       (vc-rcs-set-default-branch file
                                                                  nil)
                                       ""))))))
		   switches)
	    ;; determine the new workfile version
	    (with-current-buffer "*vc*"
	      (setq new-version
		    (vc-parse-buffer "^revision \\([0-9.]+\\).*\n" 1)))
	    (vc-file-setprop file 'vc-workfile-version new-version)
	    ;; if necessary, adjust the default branch
	    (and rev (not (string= rev ""))
		 (vc-rcs-set-default-branch
		  file
		  (if (vc-rcs-latest-on-branch-p file new-version)
		      (if (vc-trunk-p new-version) nil
			(vc-branch-part new-version))
		    new-version)))))
	(message "Checking out %s...done" file)))))

(defun vc-rcs-revert (file &optional contents-done)
  "Revert FILE to the version it was based on."
  (vc-do-command nil 0 "co" (vc-name file) "-f"
                 (concat (if (eq (vc-state file) 'edited) "-u" "-r")
                         (vc-workfile-version file))))

(defun vc-rcs-cancel-version (file editable)
  "Undo the most recent checkin of FILE.
EDITABLE non-nil means previous version should be locked."
  (let* ((target (vc-workfile-version file))
	 (previous (if (vc-trunk-p target) "" (vc-branch-part target)))
	 (config (current-window-configuration))
	 (done nil))
    (vc-do-command nil 0 "rcs" (vc-name file) (concat "-o" target))
    ;; Check out the most recent remaining version.  If it fails, because
    ;; the whole branch got deleted, do a double-take and check out the
    ;; version where the branch started.
    (while (not done)
      (condition-case err
	  (progn
	    (vc-do-command nil 0 "co" (vc-name file) "-f"
			   (concat (if editable "-l" "-u") previous))
	    (setq done t))
	(error (set-buffer "*vc*")
	       (goto-char (point-min))
	       (if (search-forward "no side branches present for" nil t)
		   (progn (setq previous (vc-branch-part previous))
			  (vc-rcs-set-default-branch file previous)
			  ;; vc-do-command popped up a window with
			  ;; the error message.  Get rid of it, by
			  ;; restoring the old window configuration.
			  (set-window-configuration config))
		 ;; No, it was some other error: re-signal it.
		 (signal (car err) (cdr err))))))))

(defun vc-rcs-merge (file first-version &optional second-version)
  "Merge changes into current working copy of FILE.
The changes are between FIRST-VERSION and SECOND-VERSION."
  (vc-do-command nil 1 "rcsmerge" (vc-name file)
		 "-kk"			; ignore keyword conflicts
		 (concat "-r" first-version)
		 (if second-version (concat "-r" second-version))))

(defun vc-rcs-steal-lock (file &optional rev)
  "Steal the lock on the current workfile for FILE and revision REV.
Needs RCS 5.6.2 or later for -M."
  (vc-do-command nil 0 "rcs" (vc-name file) "-M" (concat "-u" rev))
  ;; Do a real checkout after stealing the lock, so that we see
  ;; expanded headers.
  (vc-do-command nil 0 "co" (vc-name file) "-f" (concat "-l" rev)))



;;;
;;; History functions
;;;

(defun vc-rcs-print-log (file &optional buffer)
  "Get change log associated with FILE."
  (vc-do-command buffer 0 "rlog" (vc-name file)))

(defun vc-rcs-diff (file &optional oldvers newvers buffer)
  "Get a difference report using RCS between two versions of FILE."
  (if (not oldvers) (setq oldvers (vc-workfile-version file)))
  (apply 'vc-do-command (or buffer "*vc-diff*") 1 "rcsdiff" file
         (append (list "-q"
                       (concat "-r" oldvers)
                       (and newvers (concat "-r" newvers)))
                 (vc-switches 'RCS 'diff))))

(defun vc-rcs-annotate-command (file buffer &optional revision)
  "Annotate FILE, inserting the results in BUFFER.
Optional arg REVISION is a revision to annotate from."
  (vc-setup-buffer buffer)
  ;; Aside from the "head revision on the trunk", the instructions for
  ;; each revision on the trunk are an ordered list of kill and insert
  ;; commands necessary to go from the chronologically-following
  ;; revision to this one.  That is, associated with revision N are
  ;; edits that applied to revision N+1 would result in revision N.
  ;;
  ;; On a branch, however, (some) things are inverted: the commands
  ;; listed are those necessary to go from the chronologically-preceding
  ;; revision to this one.  That is, associated with revision N are
  ;; edits that applied to revision N-1 would result in revision N.
  ;;
  ;; So, to get per-line history info, we apply reverse-chronological
  ;; edits, starting with the head revision on the trunk, all the way
  ;; back through the initial revision (typically "1.1" or similar),
  ;; then apply forward-chronological edits -- keeping track of which
  ;; revision is associated with each inserted line -- until we reach
  ;; the desired revision for display (which may be either on the trunk
  ;; or on a branch).
  (let* ((tree (with-temp-buffer
                 (insert-file-contents (vc-rcs-registered file))
                 (vc-rcs-parse)))
         (revisions (cdr (assq 'revisions tree)))
         ;; The revision N whose instructions we currently are processing.
         (cur (cdr (assq 'head (cdr (assq 'headers tree)))))
         ;; Alist from the parse tree for N.
         (meta (cdr (assoc cur revisions)))
         ;; Point and temporary string, respectively.
         p s
         ;; "Next-branch list".  Nil means the desired revision to
         ;; display lives on the trunk.  Non-nil means it lives on a
         ;; branch, in which case the value is a list of revision pairs
         ;; (PARENT . CHILD), the first PARENT being on the trunk, that
         ;; links each series of revisions in the path from the initial
         ;; revision to the desired revision to display.
         nbls
         ;; "Path-accumulate-predicate plus revision/date/author".
         ;; Until set, forward-chronological edits are not accumulated.
         ;; Once set, its value (updated every revision) is used for
         ;; the text property `:vc-rcs-r/d/a' for inserts during
         ;; processing of forward-chronological instructions for N.
         ;; See internal func `r/d/a'.
         prda
         ;; List of forward-chronological instructions, each of the
         ;; form: (POS . ACTION), where POS is a buffer position.  If
         ;; ACTION is a string, it is inserted, otherwise it is taken as
         ;; the number of characters to be deleted.
         path
         ;; N+1.  When `cur' is "", this is the initial revision.
         pre)
    (unless revision
      (setq revision cur))
    (unless (assoc revision revisions)
      (error "No such revision: %s" revision))
    ;; Find which branches (if any) must be included in the edits.
    (let ((par revision)
          bpt kids)
      (while (setq bpt (vc-branch-part par)
                   par (vc-branch-part bpt))
        (setq kids (cdr (assq 'branches (cdr (assoc par revisions)))))
        ;; A branchpoint may have multiple children.  Find the right one.
        (while (not (string= bpt (vc-branch-part (car kids))))
          (setq kids (cdr kids)))
        (push (cons par (car kids)) nbls)))
    ;; Start with the full text.
    (set-buffer buffer)
    (insert (cdr (assq 'text meta)))
    ;; Apply reverse-chronological edits on the trunk, computing and
    ;; accumulating forward-chronological edits after some point, for
    ;; later.
    (flet ((r/d/a () (vector pre
                             (cdr (assq 'date meta))
                             (cdr (assq 'author meta)))))
      (while (when (setq pre cur cur (cdr (assq 'next meta)))
               (not (string= "" cur)))
        (setq
         ;; Start accumulating the forward-chronological edits when N+1
         ;; on the trunk is either the desired revision to display, or
         ;; the appropriate branchpoint for it.  Do this before
         ;; updating `meta' since `r/d/a' uses N+1's `meta' value.
         prda (when (or prda (string= (if nbls (caar nbls) revision) pre))
                (r/d/a))
         meta (cdr (assoc cur revisions)))
        ;; Edits in the parse tree specify a line number (in the buffer
        ;; *BEFORE* editing occurs) to start from, but line numbers
        ;; change as a result of edits.  To DTRT, we apply edits in
        ;; order of descending buffer position so that edits further
        ;; down in the buffer occur first w/o corrupting specified
        ;; buffer positions of edits occurring towards the beginning of
        ;; the buffer.  In this way we avoid using markers.  A pleasant
        ;; property of this approach is ability to push instructions
        ;; onto `path' directly, w/o need to maintain rev boundaries.
        (dolist (insn (cdr (assq :insn meta)))
          (goto-line (pop insn))
          (setq p (point))
          (case (pop insn)
            (k (setq s (buffer-substring-no-properties
                        p (progn (forward-line (car insn))
                                 (point))))
               (when prda
                 (push `(,p . ,(propertize s :vc-rcs-r/d/a prda)) path))
               (delete-region p (point)))
            (i (setq s (car insn))
               (when prda
                 (push `(,p . ,(length s)) path))
               (insert s)))))
      ;; For the initial revision, setting `:vc-rcs-r/d/a' directly is
      ;; equivalent to pushing an insert instruction (of the entire buffer
      ;; contents) onto `path' then erasing the buffer, but less wasteful.
      (put-text-property (point-min) (point-max) :vc-rcs-r/d/a (r/d/a))
      ;; Now apply the forward-chronological edits for the trunk.
      (dolist (insn path)
        (goto-char (pop insn))
        (if (stringp insn)
            (insert insn)
          (delete-char insn)))
      ;; Now apply the forward-chronological edits (directly from the
      ;; parse-tree) for the branch(es), if necessary.  We re-use vars
      ;; `pre' and `meta' for the sake of internal func `r/d/a'.
      (while nbls
        (setq pre (cdr (pop nbls)))
        (while (progn
                 (setq meta (cdr (assoc pre revisions))
                       prda nil)
                 (dolist (insn (cdr (assq :insn meta)))
                   (goto-line (pop insn))
                   (case (pop insn)
                     (k (delete-region
                         (point) (progn (forward-line (car insn))
                                        (point))))
                     (i (insert (propertize
                                 (car insn)
                                 :vc-rcs-r/d/a
                                 (or prda (setq prda (r/d/a))))))))
                 (prog1 (not (string= (if nbls (caar nbls) revision) pre))
                   (setq pre (cdr (assq 'next meta)))))))))
  ;; Lastly, for each line, insert at bol nicely-formatted history info.
  ;; We do two passes to collect summary information used to minimize
  ;; the annotation's usage of screen real-estate: (1) Consider rendered
  ;; width of revision plus author together as a unit; and (2) Omit
  ;; author entirely if all authors are the same as the user.
  (let ((ht (make-hash-table :test 'eq))
        (me (user-login-name))
        (maxw 0)
        (all-me t)
        rda w a)
    (goto-char (point-max))
    (while (not (bobp))
      (forward-line -1)
      (setq rda (get-text-property (point) :vc-rcs-r/d/a))
      (unless (gethash rda ht)
        (setq a (aref rda 2)
              all-me (and all-me (string= a me)))
        (puthash rda (setq w (+ (length (aref rda 0))
                                (length a)))
                 ht)
        (setq maxw (max w maxw))))
    (let ((padding (make-string maxw 32)))
      (flet ((pad (w) (substring-no-properties padding w))
             (render (rda &rest ls)
                     (propertize
                      (apply 'concat
                             (format-time-string "%Y-%m-%d" (aref rda 1))
                             "  "
                             (aref rda 0)
                             ls)
                      :vc-rcs-r/d/a rda)))
        (maphash
         (if all-me
             (lambda (rda w)
               (puthash rda (render rda (pad w) ": ") ht))
           (lambda (rda w)
             (puthash rda (render rda " " (pad w) " " (aref rda 2) ": ") ht)))
         ht)))
    (while (not (eobp))
      (insert (gethash (get-text-property (point) :vc-rcs-r/d/a) ht))
      (forward-line 1))))

(defun vc-rcs-annotate-current-time ()
  "Return the current time, based at midnight of the current day, and
encoded as fractional days."
  (vc-annotate-convert-time
   (apply 'encode-time 0 0 0 (nthcdr 3 (decode-time (current-time))))))

(defun vc-rcs-annotate-time ()
  "Return the time of the next annotation (as fraction of days)
systime, or nil if there is none.  Also, reposition point."
  (unless (eobp)
    (search-forward ": ")
    (vc-annotate-convert-time
     (aref (get-text-property (point) :vc-rcs-r/d/a) 1))))

(defun vc-rcs-annotate-extract-revision-at-line ()
  (aref (get-text-property (point) :vc-rcs-r/d/a) 0))


;;;
;;; Snapshot system
;;;

(defun vc-rcs-assign-name (file name)
  "Assign to FILE's latest version a given NAME."
  (vc-do-command nil 0 "rcs" (vc-name file) (concat "-n" name ":")))


;;;
;;; Miscellaneous
;;;

(defun vc-rcs-check-headers ()
  "Check if the current file has any headers in it."
  (save-excursion
    (goto-char (point-min))
         (re-search-forward "\\$[A-Za-z\300-\326\330-\366\370-\377]+\
\\(: [\t -#%-\176\240-\377]*\\)?\\$" nil t)))

(defun vc-rcs-clear-headers ()
  "Implementation of vc-clear-headers for RCS."
  (let ((case-fold-search nil))
    (goto-char (point-min))
    (while (re-search-forward
            (concat "\\$\\(Author\\|Date\\|Header\\|Id\\|Locker\\|Name\\|"
                    "RCSfile\\|Revision\\|Source\\|State\\): [^$\n]+\\$")
            nil t)
      (replace-match "$\\1$"))))

(defun vc-rcs-rename-file (old new)
  ;; Just move the master file (using vc-rcs-master-templates).
  (vc-rename-master (vc-name old) new vc-rcs-master-templates))


;;;
;;; Internal functions
;;;

(defun vc-rcs-workfile-is-newer (file)
  "Return non-nil if FILE is newer than its RCS master.
This likely means that FILE has been changed with respect
to its master version."
  (let ((file-time (nth 5 (file-attributes file)))
	(master-time (nth 5 (file-attributes (vc-name file)))))
    (or (> (nth 0 file-time) (nth 0 master-time))
	(and (= (nth 0 file-time) (nth 0 master-time))
	     (> (nth 1 file-time) (nth 1 master-time))))))

(defun vc-rcs-find-most-recent-rev (branch)
  "Find most recent revision on BRANCH."
  (goto-char (point-min))
  (let ((latest-rev -1) value)
    (while (re-search-forward (concat "^\\(" (regexp-quote branch)
				      "\\.\\([0-9]+\\)\\)\ndate[ \t]+[0-9.]+;")
			      nil t)
      (let ((rev (string-to-number (match-string 2))))
	(when (< latest-rev rev)
	  (setq latest-rev rev)
	  (setq value (match-string 1)))))
    (or value
	(vc-branch-part branch))))

(defun vc-rcs-fetch-master-state (file &optional workfile-version)
  "Compute the master file's idea of the state of FILE.
If a WORKFILE-VERSION is given, compute the state of that version,
otherwise determine the workfile version based on the master file.
This function sets the properties `vc-workfile-version' and
`vc-checkout-model' to their correct values, based on the master
file."
  (with-temp-buffer
    (if (or (not (vc-insert-file (vc-name file) "^[0-9]"))
            (progn (goto-char (point-min))
                   (not (looking-at "^head[ \t\n]+[^;]+;$"))))
        (error "File %s is not an RCS master file" (vc-name file)))
    (let ((workfile-is-latest nil)
	  (default-branch (vc-parse-buffer "^branch[ \t\n]+\\([^;]*\\);" 1)))
      (vc-file-setprop file 'vc-rcs-default-branch default-branch)
      (unless workfile-version
	;; Workfile version not known yet.  Determine that first.  It
	;; is either the head of the trunk, the head of the default
	;; branch, or the "default branch" itself, if that is a full
	;; revision number.
	(cond
	 ;; no default branch
	 ((or (not default-branch) (string= "" default-branch))
	  (setq workfile-version
		(vc-parse-buffer "^head[ \t\n]+\\([^;]+\\);" 1))
	  (setq workfile-is-latest t))
	 ;; default branch is actually a revision
	 ((string-match "^[0-9]+\\.[0-9]+\\(\\.[0-9]+\\.[0-9]+\\)*$"
			default-branch)
	  (setq workfile-version default-branch))
	 ;; else, search for the head of the default branch
	 (t (vc-insert-file (vc-name file) "^desc")
	    (setq workfile-version
		  (vc-rcs-find-most-recent-rev default-branch))
	    (setq workfile-is-latest t)))
	(vc-file-setprop file 'vc-workfile-version workfile-version))
      ;; Check strict locking
      (goto-char (point-min))
      (vc-file-setprop file 'vc-checkout-model
		       (if (re-search-forward ";[ \t\n]*strict;" nil t)
			   'locking 'implicit))
      ;; Compute state of workfile version
      (goto-char (point-min))
      (let ((locking-user
	     (vc-parse-buffer (concat "^locks[ \t\n]+[^;]*[ \t\n]+\\([^:]+\\):"
				      (regexp-quote workfile-version)
				      "[^0-9.]")
			      1)))
	(cond
	 ;; not locked
	 ((not locking-user)
          (if (or workfile-is-latest
                  (vc-rcs-latest-on-branch-p file workfile-version))
              ;; workfile version is latest on branch
              'up-to-date
            ;; workfile version is not latest on branch
            'needs-patch))
	 ;; locked by the calling user
	 ((and (stringp locking-user)
	       (string= locking-user (vc-user-login-name file)))
	  (if (or (eq (vc-checkout-model file) 'locking)
		  workfile-is-latest
		  (vc-rcs-latest-on-branch-p file workfile-version))
	      'edited
	    ;; Locking is not used for the file, but the owner does
	    ;; have a lock, and there is a higher version on the current
	    ;; branch.  Not sure if this can occur, and if it is right
	    ;; to use `needs-merge' in this case.
	    'needs-merge))
	 ;; locked by somebody else
	 ((stringp locking-user)
	  locking-user)
	 (t
	  (error "Error getting state of RCS file")))))))

(defun vc-rcs-consult-headers (file)
  "Search for RCS headers in FILE, and set properties accordingly.

Returns: nil            if no headers were found
         'rev           if a workfile revision was found
         'rev-and-lock  if revision and lock info was found"
  (cond
   ((not (get-file-buffer file)) nil)
   ((let (status version locking-user)
     (save-excursion
      (set-buffer (get-file-buffer file))
      (goto-char (point-min))
      (cond
       ;; search for $Id or $Header
       ;; -------------------------
       ;; The `\ 's below avoid an RCS 5.7 bug when checking in this file.
       ((or (and (search-forward "$Id\ : " nil t)
		 (looking-at "[^ ]+ \\([0-9.]+\\) "))
	    (and (progn (goto-char (point-min))
			(search-forward "$Header\ : " nil t))
		 (looking-at "[^ ]+ \\([0-9.]+\\) ")))
	(goto-char (match-end 0))
	;; if found, store the revision number ...
	(setq version (match-string-no-properties 1))
	;; ... and check for the locking state
	(cond
	 ((looking-at
	   (concat "[0-9]+[/-][01][0-9][/-][0-3][0-9] "             ; date
	    "[0-2][0-9]:[0-5][0-9]+:[0-6][0-9]+\\([+-][0-9:]+\\)? " ; time
	           "[^ ]+ [^ ]+ "))                       ; author & state
	  (goto-char (match-end 0)) ; [0-6] in regexp handles leap seconds
	  (cond
	   ;; unlocked revision
	   ((looking-at "\\$")
	    (setq locking-user 'none)
	    (setq status 'rev-and-lock))
	   ;; revision is locked by some user
	   ((looking-at "\\([^ ]+\\) \\$")
	    (setq locking-user (match-string-no-properties 1))
	    (setq status 'rev-and-lock))
	   ;; everything else: false
	   (nil)))
	 ;; unexpected information in
	 ;; keyword string --> quit
	 (nil)))
       ;; search for $Revision
       ;; --------------------
       ((re-search-forward (concat "\\$"
				   "Revision: \\([0-9.]+\\) \\$")
			   nil t)
	;; if found, store the revision number ...
	(setq version (match-string-no-properties 1))
	;; and see if there's any lock information
	(goto-char (point-min))
	(if (re-search-forward (concat "\\$" "Locker:") nil t)
	    (cond ((looking-at " \\([^ ]+\\) \\$")
		   (setq locking-user (match-string-no-properties 1))
		   (setq status 'rev-and-lock))
		  ((looking-at " *\\$")
		   (setq locking-user 'none)
		   (setq status 'rev-and-lock))
		  (t
		   (setq locking-user 'none)
		   (setq status 'rev-and-lock)))
	  (setq status 'rev)))
       ;; else: nothing found
       ;; -------------------
       (t nil)))
     (if status (vc-file-setprop file 'vc-workfile-version version))
     (and (eq status 'rev-and-lock)
	  (vc-file-setprop file 'vc-state
			   (cond
			    ((eq locking-user 'none) 'up-to-date)
			    ((string= locking-user (vc-user-login-name file)) 
                             'edited)
			    (t locking-user)))
	  ;; If the file has headers, we don't want to query the
	  ;; master file, because that would eliminate all the
	  ;; performance gain the headers brought us.  We therefore
	  ;; use a heuristic now to find out whether locking is used
	  ;; for this file.  If we trust the file permissions, and the
	  ;; file is not locked, then if the file is read-only we
          ;; assume that locking is used for the file, otherwise
          ;; locking is not used.
	  (not (vc-mistrust-permissions file))
	  (vc-up-to-date-p file)
	  (if (string-match ".r-..-..-." (nth 8 (file-attributes file)))
	      (vc-file-setprop file 'vc-checkout-model 'locking)
	    (vc-file-setprop file 'vc-checkout-model 'implicit)))
     status))))

(defun vc-release-greater-or-equal (r1 r2)
  "Compare release numbers, represented as strings.
Release components are assumed cardinal numbers, not decimal fractions
\(5.10 is a higher release than 5.9\).  Omitted fields are considered
lower \(5.6.7 is earlier than 5.6.7.1\).  Comparison runs till the end
of the string is found, or a non-numeric component shows up \(5.6.7 is
earlier than \"5.6.7 beta\", which is probably not what you want in
some cases\).  This code is suitable for existing RCS release numbers.
CVS releases are handled reasonably, too \(1.3 < 1.4* < 1.5\)."
  (let (v1 v2 i1 i2)
    (catch 'done
      (or (and (string-match "^\\.?\\([0-9]+\\)" r1)
	       (setq i1 (match-end 0))
	       (setq v1 (string-to-number (match-string 1 r1)))
	       (or (and (string-match "^\\.?\\([0-9]+\\)" r2)
			(setq i2 (match-end 0))
			(setq v2 (string-to-number (match-string 1 r2)))
			(if (> v1 v2) (throw 'done t)
			  (if (< v1 v2) (throw 'done nil)
			    (throw 'done
				   (vc-release-greater-or-equal
				    (substring r1 i1)
				    (substring r2 i2)))))))
		   (throw 'done t)))
	  (or (and (string-match "^\\.?\\([0-9]+\\)" r2)
		   (throw 'done nil))
	      (throw 'done t)))))

(defun vc-rcs-release-p (release)
  "Return t if we have RELEASE or better."
  (let ((installation (vc-rcs-system-release)))
    (if (and installation
	     (not (eq installation 'unknown)))
	(vc-release-greater-or-equal installation release))))

(defun vc-rcs-system-release ()
  "Return the RCS release installed on this system, as a string.
Return symbol UNKNOWN if the release cannot be deducted.  The user can
override this using variable `vc-rcs-release'.

If the user has not set variable `vc-rcs-release' and it is nil,
variable `vc-rcs-release' is set to the returned value."
  (or vc-rcs-release
      (setq vc-rcs-release
	    (or (and (zerop (vc-do-command nil nil "rcs" nil "-V"))
		     (with-current-buffer (get-buffer "*vc*")
		       (vc-parse-buffer "^RCS version \\([0-9.]+ *.*\\)" 1)))
		'unknown))))

(defun vc-rcs-set-non-strict-locking (file)
  (vc-do-command nil 0 "rcs" file "-U")
  (vc-file-setprop file 'vc-checkout-model 'implicit)
  (set-file-modes file (logior (file-modes file) 128)))

(defun vc-rcs-set-default-branch (file branch)
  (vc-do-command nil 0 "rcs" (vc-name file) (concat "-b" branch))
  (vc-file-setprop file 'vc-rcs-default-branch branch))

(defun vc-rcs-parse (&optional buffer)
  "Parse current buffer, presumed to be in RCS-style masterfile format.
Optional arg BUFFER specifies another buffer to parse.  Return an alist
of two elements, w/ keys `headers' and `revisions' and values in turn
sub-alists.  For `headers', the values unless otherwise specified are
strings and the keys are:

  desc     -- description
  head     -- latest revision
  branch   -- the branch the \"head revision\" lies on;
              absent if the head revision lies on the trunk
  access   -- ???
  symbols  -- sub-alist of (SYMBOL . REVISION) elements
  locks    -- if file is checked out, something like \"ttn:1.7\"
  strict   -- t if \"strict locking\" is in effect, otherwise nil
  comment  -- may be absent; typically something like \"# \" or \"; \"
  expand   -- may be absent; ???

For `revisions', the car is REVISION (string), the cdr a sub-alist,
with string values (unless otherwise specified) and keys:

  date     -- a time value (like that returned by `encode-time'); as a
              special case, a year value less than 100 is augmented by 1900
  author   -- username
  state    -- typically \"Exp\" or \"Rel\"
  branches -- list of revisions that begin branches from this revision
  next     -- on the trunk: the chronologically-preceding revision, or \"\";
              on a branch: the chronologically-following revision, or \"\"
  log      -- change log entry
  text     -- for the head revision on the trunk, the body of the file;
              other revisions have `:insn' instead
  :insn    -- for non-head revisions, a list of parsed instructions
              in one of two forms, in both cases START meaning \"first
              go to line START\":
               - `(START k COUNT)' -- kill COUNT lines
               - `(START i TEXT)'  -- insert TEXT (a string)
              The list is in descending order by START.

The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension."
  (setq buffer (get-buffer (or buffer (current-buffer))))
  (set-buffer buffer)
  ;; An RCS masterfile can be viewed as containing four regular (for the
  ;; most part) sections: (a) the "headers", (b) the "rev headers", (c)
  ;; the "description" and (d) the "rev bodies", in that order.  In the
  ;; returned alist (see docstring), elements from (b) and (d) are
  ;; combined pairwise to form the "revisions", while those from (a) and
  ;; (c) are simply combined to form the "headers".
  ;;
  ;; Loosely speaking, each section contains a series of alternating
  ;; "tags" and "printed representations".  In the (b) and (d), many
  ;; such series can appear, and a revision number on a line by itself
  ;; precedes the series of tags and printed representations associated
  ;; with it.
  ;;
  ;; In (a) and (b), the printed representations (with the exception of
  ;; the `comment' tag in the headers) terminate with a semicolon, which
  ;; is NOT part of the "value" finally associated with the tag.  All
  ;; other printed representations are in "@@-format"; there is an "@",
  ;; the middle part (to be translated into the value), another "@" and
  ;; a newline.  Each "@@" in the middle part indicates the position of
  ;; a single "@" (and consequently the requirement of an additional
  ;; initial step when translating to the value).
  ;;
  ;; Parser state includes vars that collect parts of the return value...
  (let ((desc nil) (headers nil) (revs nil)
        ;; ... as well as vars that support a single-pass, tag-assisted,
        ;; minimal-data-copying scan.  Basically -- skirting around the
        ;; grouping by revision required in (b) and (d) -- we repeatedly
        ;; and context-sensitively read a tag (that MUST be present),
        ;; determine the bounds of the printed representation, translate
        ;; it into a value, and push the tag plus value onto one of the
        ;; collection vars.  Finally, we return the parse tree
        ;; incorporating the values of the collection vars (see "rv").
        ;;
        ;; A symbol or string to keep track of context (for error messages).
        context
        ;; A symbol, the current tag.
        tok
        ;; Region (begin and end buffer positions) of the printed
        ;; representation for the current tag.
        b e
        ;; A list of buffer positions where "@@" can be found within the
        ;; printed representation region.  For each location, we push two
        ;; elements onto the list, 1+ and 2+ the location, respectively,
        ;; with the 2+ appearing at the head.  In this way, the expression
        ;;   `(,e ,@@-holes ,b)
        ;; describes regions that can be concatenated (in reverse order)
        ;; to "de-@@-format" the printed representation as the first step
        ;; to translating it into some value.  See internal func `gather'.
        @-holes)
    (flet ((sw () (skip-chars-forward " \t\n")) ; i.e., `[:space:]'
           (at (tag) (save-excursion (eq tag (read buffer))))
           (to-eol () (buffer-substring-no-properties
                       (point) (progn (forward-line 1)
                                      (1- (point)))))
           (to-semi () (setq b (point)
                             e (progn (search-forward ";")
                                      (1- (point)))))
           (to-one@ () (setq @-holes nil
                             b (progn (search-forward "@") (point))
                             e (progn (while (and (search-forward "@")
                                                  (= ?@ (char-after))
                                                  (progn
                                                    (push (point) @-holes)
                                                    (forward-char 1)
                                                    (push (point) @-holes))))
                                      (1- (point)))))
           (tok+val (set-b+e name &optional proc)
                    (unless (eq name (setq tok (read buffer)))
                      (error "Missing `%s' while parsing %s" name context))
                    (sw)
                    (funcall set-b+e)
                    (cons tok (if proc
                                  (funcall proc)
                                (buffer-substring-no-properties b e))))
           (k-semi (name &optional proc) (tok+val 'to-semi name proc))
           (gather () (let ((pairs `(,e ,@@-holes ,b))
                            acc)
                        (while pairs
                          (push (buffer-substring-no-properties
                                 (cadr pairs) (car pairs))
                                acc)
                          (setq pairs (cddr pairs)))
                        (apply 'concat acc)))
           (k-one@ (name &optional later) (tok+val 'to-one@ name
                                                   (if later
                                                       (lambda () t)
                                                     'gather))))
      (save-excursion
        (goto-char (point-min))
        ;; headers
        (setq context 'headers)
        (flet ((hpush (name &optional proc)
                      (push (k-semi name proc) headers)))
          (hpush 'head)
          (when (at 'branch)
            (hpush 'branch))
          (hpush 'access)
          (hpush 'symbols
                 (lambda ()
                   (mapcar (lambda (together)
                             (let ((two (split-string together ":")))
                               (setcar two (intern (car two)))
                               (setcdr two (cadr two))
                               two))
                           (split-string
                            (buffer-substring-no-properties b e)))))
          (hpush 'locks))
        (push `(strict . ,(when (at 'strict)
                            (search-forward ";")
                            t))
              headers)
        (when (at 'comment)
          (push (k-one@ 'comment) headers)
          (search-forward ";"))
        (when (at 'expand)
          (push (k-one@ 'expand) headers)
          (search-forward ";"))
        (setq headers (nreverse headers))
        ;; rev headers
        (sw) (setq context 'rev-headers)
        (while (looking-at "[0-9]")
          (push `(,(to-eol)
                  ,(k-semi 'date
                           (lambda ()
                             (let ((ls (mapcar 'string-to-number
                                               (split-string
                                                (buffer-substring-no-properties
                                                 b e)
                                                "\\."))))
                               ;; Hack the year -- verified to be the
                               ;; same algorithm used in RCS 5.7.
                               (when (< (car ls) 100)
                                 (setcar ls (+ 1900 (car ls))))
                               (apply 'encode-time (nreverse ls)))))
                  ,@(mapcar 'k-semi '(author state))
                  ,(k-semi 'branches
                           (lambda ()
                             (split-string
                              (buffer-substring-no-properties b e))))
                  ,(k-semi 'next))
                revs)
          (sw))
        (setq revs (nreverse revs))
        ;; desc
        (sw) (setq context 'desc
                   desc (k-one@ 'desc))
        ;; rev bodies
        (let (acc
              ;; Element of `revs' that initially holds only header info.
              ;; "Pairwise combination" occurs when we add body info.
              rev
              ;; Components of the editing commands (aside from the actual
              ;; text) that comprise the `text' printed representations
              ;; (not including the "head" revision).
              cmd start act
              ;; Ascending (reversed) `@-holes' which the internal func
              ;; `incg' pops to effect incremental gathering.
              asc
              ;; Function to extract text (for the `a' command), either
              ;; `incg' or `buffer-substring-no-properties'.  (This is
              ;; for speed; strictly speaking, it is sufficient to use
              ;; only the former since it behaves identically to the
              ;; latter in the absense of "@@".)
              sub)
          (flet ((incg (beg end) (let ((b beg) (e end) @-holes)
                                   (while (and asc (< (car asc) e))
                                     (push (pop asc) @-holes))
                                   ;; Self-deprecate when work is done.
                                   ;; Folding many dimensions into one.
                                   ;; Thanks B.Mandelbrot, for complex sum.
                                   ;; O beauteous math! --the Unvexed Bum
                                   (unless asc
                                     (setq sub 'buffer-substring-no-properties))
                                   (gather))))
            (while (and (sw)
                        (not (eobp))
                        (setq context (to-eol)
                              rev (or (assoc context revs)
                                      (error "Rev `%s' has body but no head"
                                             context))))
              (push (k-one@ 'log) (cdr rev))
              ;; For rev body `text' tags, delay translation slightly...
              (push (k-one@ 'text t) (cdr rev))
              ;; ... until we decide which tag and value is appropriate to
              ;; collect.  For the "head" revision, compute the value of the
              ;; `text' printed representation by simple `gather'.  For all
              ;; other revisions, replace the `text' tag+value with `:insn'
              ;; plus value, always scanning in-place.
              (if (string= context (cdr (assq 'head headers)))
                  (setcdr (cadr rev) (gather))
                (if @-holes
                    (setq asc (nreverse @-holes)
                          sub 'incg)
                  (setq sub 'buffer-substring-no-properties))
                (goto-char b)
                (setq acc nil)
                (while (< (point) e)
                  (forward-char 1)
                  (setq cmd (char-before)
                        start (read (current-buffer))
                        act (read (current-buffer)))
                  (forward-char 1)
                  (push (case cmd
                          (?d
                           ;; `d' means "delete lines".
                           ;; For Emacs spirit, we use `k' for "kill".
                           `(,start k ,act))
                          (?a
                           ;; `a' means "append after this line" but
                           ;; internally we normalize it so that START
                           ;; specifies the actual line for insert, thus
                           ;; requiring less hair in the realization algs.
                           ;; For Emacs spirit, we use `i' for "insert".
                           `(,(1+ start) i
                             ,(funcall sub (point) (progn (forward-line act)
                                                          (point)))))
                          (t (error "Bad command `%c' in `text' for rev `%s'"
                                    cmd context)))
                        acc))
                (goto-char (1+ e))
                (setcar (cdr rev) (cons :insn acc)))))))
      ;; rv
      `((headers ,desc ,@headers)
        (revisions ,@revs)))))

(provide 'vc-rcs)

;; arch-tag: 759b4916-5b0d-431d-b647-b185b8c652cf
;;; vc-rcs.el ends here