#!/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=<input rcs file> [--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
<end char>      # ERROR! unexpected <end char> (the preceding delta text block
                # has a missing line!

where <end char> 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 (<RCS_FILE>) {
    if (/^desc$/) {
      $comments{0} = '';
      if ($debug) {
	print "DEBUG: description on line $.\n";
      }
      $_ = <RCS_FILE>;      # read first line
      s/^\@//;              # remove leading '@'
      while (1) {
	last DESC if /^\@$/;
	s/\@\@/\@/g;      # RCS replaces single '@' with '@@'
	$comments{0} .= $_;
	$_ = <RCS_FILE>;
      }
    }
  }

=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 (<RCS_FILE>) {
    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 = $_);
      $_ = <RCS_FILE>;
      if (/^log$/) {
	if ($debug) {
	  print "DEBUG: log on line $.\n";
	}
	$comments{$revision} = '';
	$_ = <RCS_FILE>;  # read first line
	s/^\@//;          # remove leading '@'
	while (1) {
	  next REVISION if /^\@$/;
	  s/\@\@/\@/g;  # RCS replaces single '@' with '@@'
	  $comments{$revision} .= $_;
	  $_ = <RCS_FILE>;
	}
      }
    }
  }

  # 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";
      }
      $_ = <RCS_FILE>;         # read first line
      if (not /^\@\@$/) {      # forced revisions have single '@@' in text section
	while (<RCS_FILE>) {
	  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 (<RCS_FILE>) {
    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 (<RCS_FILE>) {
	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 (<RCS_FILE>) {
	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(<RCS_FILE>) {
	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 = <RCS_FILE>;
      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
