#!/usr/bin/perl -w
# A work in progress
# by Tom Browder (with help from CPAN module from Rcs-1.05)
# tom.browder@gmail.com
# 2008-01-24
use Time::Local;
my $nargs = @ARGV;
if (!$nargs) {
print<<"HERE";
Usage: $0 -i= [--debug]
Use the '--debug' option to print the interpreted RCS file to stdout.
A common corruption case is where a reported unexpected character is actually
a missing line in a delta-text block. Look for problems in lines of the form:
a3 # the 3 is the number of following lines to be added
blah # text to be added
foo # text to be added
# ERROR! unexpected (the preceding delta text block
# has a missing line!
where may be one of several such as:
dN # lines to be deleted (where D is a positive integer)
@
To do:
report such errors
HERE
exit;
}
my $ifil = 0;
my $debug = 0;
my $errors = 0;
foreach my $a (@ARGV) {
my $val = 0;
my $idx = index $a, '=';
if ($idx >= 0) {
$val = substr $a, $idx+1;
$a = substr $a, 0, $idx;
}
if ($a eq '-i') {
$ifil = $val;
}
elsif ($a =~ /-debug/) {
$debug = 1;
}
else {
print "ERROR: Unknown arg '$a'.\n";
++$errors;
}
}
if (!$ifil) {
print "ERROR: No input file specified.\n";
++$errors;
}
elsif (! -f $ifil) {
print "ERROR: Cannot open input file '$ifil'.\n";
++$errors;
}
if ($errors) {
my $s = $errors > 1 ? 's' : '';
print "Exiting with $errors error$s.\n";
exit;
}
# global value for line number? no, use perlvar $.
parse_rcs_header($ifil);
parse_rcs_body($ifil);
#### subroutines ####
# from Rcs-1.05
#------------------------------------------------------------------
# _parse_rcs_body
# Private function
#------------------------------------------------------------------
sub parse_rcs_body {
my $self; # = shift;
local $_;
my %comments;
#my $rcsdir = $self->rcsdir;
#my $file = $self->file;
#my $rcs_file = $rcsdir . $Dir_Sep . $file . $self->arcext;
my $rcs_file = shift;
# parse RCS archive file
open RCS_FILE, $rcs_file
or return(print STDOUT "Unable to open $rcs_file: $!\n");
# skip header info and get description
DESC: while () {
if (/^desc$/) {
$comments{0} = '';
if ($debug) {
print "DEBUG: description on line $.\n";
}
$_ = ; # read first line
s/^\@//; # remove leading '@'
while (1) {
last DESC if /^\@$/;
s/\@\@/\@/g; # RCS replaces single '@' with '@@'
$comments{0} .= $_;
$_ = ;
}
}
}
=pod
if ($debug && $comments{0}) {
printf "DEBUG(%s,%u): header comments\n", __FILE__, __LINE__;
my $s = $comments{$revision};
chomp $s;
print "'$s'\n";
}
=cut
# parse revision comments
my $revision;
REVISION: while () {
if (/^[\d\.]+$/) {
if ($debug && defined($revision) && $comments{$revision}) {
printf "DEBUG(%s,%u): comments revision $revision\n", __FILE__, __LINE__;
my $s = $comments{$revision};
chomp $s;
print "'$s'\n";
}
chomp($revision = $_);
$_ = ;
if (/^log$/) {
if ($debug) {
print "DEBUG: log on line $.\n";
}
$comments{$revision} = '';
$_ = ; # read first line
s/^\@//; # remove leading '@'
while (1) {
next REVISION if /^\@$/;
s/\@\@/\@/g; # RCS replaces single '@' with '@@'
$comments{$revision} .= $_;
$_ = ;
}
}
}
}
# loop through 'text' section to avoid capturing bogus info
continue {
if (/^text$/) { # 'text' tag should always be there, but check anyway
if ($debug) {
print "DEBUG: text on line $.\n";
}
$_ = ; # read first line
if (not /^\@\@$/) { # forced revisions have single '@@' in text section
while () {
if ($debug) {
chomp;
print "'$_'\n";
}
s/\@\@//g; # RCS replaces single '@' with '@@'
last if /\@$/;
}
}
}
}
close RCS_FILE;
$self->{COMMENTS} = \%comments;
} # parse_rcs_body
#------------------------------------------------------------------
# from Rcs::Rcs
# _parse_rcs_header
# Private function
# Directly parse the RCS archive file.
#------------------------------------------------------------------
sub parse_rcs_header {
my $self; # = shift;
local $_;
my ($head, %lock);
my (@access_list, @revisions);
my (%author, %date, %state, %symbols);
#my $rcsdir = $self->rcsdir;
#my $file = $self->file;
#my $rcs_file = $rcsdir . $Dir_Sep . $file . $self->arcext;
my $rcs_file = shift;
# parse RCS archive file
open RCS_FILE, $rcs_file
or return(print STDOUT "Unable to open $rcs_file: $!\n");
while () {
next if /^\s*$/; # skip blank lines
last if /^desc$/; # end of header info
# get head revision
if (/^head\s/) {
($head) = /^head\s+(.*?);$/;
if ($debug) {
print "DEBUG: head '$head' on line $.\n";
}
next;
}
# get access list
if (/^access$/) {
if ($debug) {
print "DEBUG: access on line $.\n";
}
while () {
chomp;
s/\s//g; # remove all whitespace
push @access_list, (split(/;/))[0];
last if /;$/;
}
next;
}
# get symbols
if (/^symbols$/) {
if ($debug) {
print "DEBUG: symbols on line $.\n";
}
while () {
chomp;
s/\s//g; # remove all whitespace
my ($sym, $rev) = split(/:/);
$rev =~ s/;$//;
$symbols{$sym} = $rev;
last if /;$/;
}
next;
}
# get locker
if (/^locks/) {
if ($debug) {
print "DEBUG: locks on line $.\n";
}
# file not locked
if (/;$/) {
%lock = ();
next;
}
# get user who has file locked
while() {
s/\s+//g; # remove all white space
next unless $_ ; # skip blank line (now empty string)
last if /^;/; # end of locks
my ($locker, $rev) = split(/:/);
$rev =~ s/;.*//;
if ($debug) {
print "DEBUG: locker '$locker' on line $.\n";
print " revision '$rev'\n";
}
$lock{$rev} = $locker;
last if /;$/; # end of locks
}
next;
}
# get all revisions
if (/^\d+\.\d+/) {
chomp;
push @revisions, $_;
# get author, state and date of each revision
my $next_line = ;
chop(my $author = (split(/\s+/, $next_line))[3]);
chop(my $state = (split(/\s+/, $next_line))[5]);
chop(my $date = (split(/\s+/, $next_line))[1]);
# store date as date number
my ($year, $mon, $mday, $hour, $min, $sec) = split(/\./, $date);
$mon--; # convert to 0-11 range
my @date = ($sec,$min,$hour,$mday,$mon,$year);
# store value in hash using revision as key
$author{$_} = $author;
$state{$_} = $state;
$date{$_} = timegm(@date); # Time::Local
}
}
close RCS_FILE;
$self->{HEAD} = $head;
$self->{LOCK} = \%lock;
$self->{ACCESS} = \@access_list;
$self->{REVISIONS} = \@revisions;
$self->{AUTHOR} = \%author;
$self->{DATE} = \%date;
$self->{STATE} = \%state;
$self->{SYMBOLS} = \%symbols;
} # parse_rcs_header