#
# Copyright (c) 2003 Lev A. Serebryakov <lev@serebryakov.spb.ru>
#
#    This module is free software; you can redistribute it and/or modify it
#    under the same terms as Perl itself.
#
# This is RCS file reader. It supports internal string buffer
# and some special operations
#
# $Id: Reader.pm 783 2003-12-05 17:08:35Z lev $
#
package Cvs::Repository::Reader;

use strict;

use vars qw($VERSION);
$VERSION  = join('.',0,76,('$LastChangedRevision: 783 $' =~ /^\$\s*LastChangedRevision:\s+(\d+)\s*\$$/),'cvs2svn');

use Cvs::Repository::Exception qw(:INTERNAL);

sub New
{
  my $proto = shift;
  my $name  = shift;
  my $class = ref($proto) || $proto;
  my $self = bless({},$class);
  
  local *RCS;
  
  open(RCS,'< '.$name) or throw "Could not open RCS file '$name'";
  binmode(RCS);

  $self->{'buffer'} = [];
  $self->{'io'}     = *RCS{IO};
  $self->{'pos'}    = 0;
  

  return $self;
}

sub fillBuffer
{
  my $self = shift;
  my $checker = shift || undef;
  my $IO = $self->{'io'};
  my $s;

  # We don't use "default checker" because
  # it is too slow.
  if(defined $checker) {
    while(defined($s = <$IO>)) {
      push @{$self->{'buffer'}},$s;
      last unless &{$checker}($s);
    }
  } else {
    my $lines = 0;
    for($lines = 0; $lines < 64 && defined($s = <$IO>); ++$lines) {
      push @{$self->{'buffer'}},$s;
    }
  }
}

sub getLine
{
  $_[0]->fillBuffer() unless @{$_[0]->{'buffer'}};
  my $s = shift @{$_[0]->{'buffer'}};
  $_[0]->{'pos'} += length($s) if defined $s;
  return $s;
}

sub ungetLine
{
  return unless $_[1];
  $_[0]->{'pos'} -= length($_[1]);
  unshift @{$_[0]->{'buffer'}},$_[1];
}

sub getNotEmptyLine
{
  my $s;
  while(defined($s = $_[0]->getLine())) {
    return $s if $s !~ /^\s*$/;
  }
  return undef;
}

sub readUpToSemicolon
{
  my $str = '';
  my $s;
  while(defined($s = $_[0]->getLine())) {
    if($s =~ /^(.*?)\s*;\s*(.*)$/) {
      $str .= $1 || '';
      $s    = $2 || '';
      $_[0]->ungetLine($s) if $s;
      $str =~ s/^\s+//;
      return $str;
    }
    $str .= $s;
  }
  return undef;
}

sub readWord
{
  my $s = $_[0]->getNotEmptyLine();
  return undef unless defined $s;
  if($s !~ /^\s*([^\s;\@]+)\s*(.*)$/) {
    $s =~ /^\s*(.)(.+)$/;
  }
  $s = $1;

  $_[0]->ungetLine($2) if defined $2 && $2;
  return $s;
}

sub readString
{
  my $str = '';
  my $s;
  my $start = 0;
  my $size = 0;
  
  $s = $_[0]->getNotEmptyLine();
  return undef unless defined $s;
  # Start is HERE + length of part, which will be deleted
  $start = $_[0]->{'pos'} - length($s);
  # Is here begin of string?
  if($s !~ s/^\s*\@((?:\@\@)*)/$1/) {
    # No, return invalid string & exit
    $_[0]->ungetLine($s);
    return undef;
  }
  $start += ($+[0] - $-[0]);
  # First @ is deleted
  # Start is current pos + length of removed part
  # We don't use $& due to time penalty on regexps...
  $start = $_[0]->{'pos'} + ($+[0] - $-[0]);
  # We need to have ODD nuber of @ to finish string
  while($s !~ /(?<!\@)\@(\@\@)*(?!\@)/) {
    # Add old and read new
    $str .= $s;
    $s = $_[0]->getLine();
    if(!defined $s) {
      $_[0]->ungetLine($str);
      return undef;
    }
  }
  # Ok, regexp works! 
  $s    =~ /^(.*?(?<!\@)(?:\@\@)*)\@(?!\@)(.*)$/;
  $str .= $1 || '';
  $s    = $2 || '';
  $_[0]->ungetLine($s) if $s;
  # @ was lost!
  $size = $_[0]->{'pos'} - $start - 2;
  $str =~ s/\@\@/\@/g;
  return ($str, $start, $size);
}

sub skipString
{
  my $s;
  my $start = 0;
  my $size  = 0;

  $s = $_[0]->getNotEmptyLine();
  return undef unless defined $s;
  # Start is HERE + length of part, which will be deleted
  $start = $_[0]->{'pos'} - length($s);
  # Is here begin of string?
  if($s !~ s/^\s*\@((?:\@\@)*)/$1/) {
    # No, return invalid string & exit
    $_[0]->ungetLine($s);
    return undef;
  }
  $start += ($+[0] - $-[0]);
  # First @ is deleted
  # No unget after this point -- we don't store parts of string :(
  while($s !~ /(?<!\@)\@(\@\@)*(?!\@)/) {
   $s = $_[0]->getLine();
   return undef unless defined $s;
  }
  $s    =~ /^.*?(?<!\@)(?:\@\@)*\@(?!\@)(.*)$/;
  $s = $1 || '';
  $_[0]->ungetLine($s) if $s;
  # -2 because last '@' was lost
  $size = $_[0]->{'pos'} - $start - 2;
  return ($start, $size);
}

sub readStringFrom
{
  my ($self, $start, $size) = @_;
  my $s = '';
  my $oldpos;
  
  throw "Start position is invalid: '$start'" if $start < 1;
  --$start;
  $size += 2;
  $oldpos = tell($self->{'io'});
  throw "Invalid current position: '$oldpos'" if $oldpos < 0;
  seek($self->{'io'},$start,0) or throw "Seek failed: '$!'";
  my $wr = read($self->{'io'},$s,$size);
  throw "Could not read '$size' bytes from '$start' (only '$wr' was read)" unless $wr == $size;
  seek($self->{'io'},$oldpos,0) or throw "Return seek failed: '$!'";
  throw "Invalid string ($start,$size)" if substr($s,0,1) ne '@' or substr($s,-1,1) ne '@';
  $s = substr($s,1,$size-2);
  $s =~ s/\@\@/\@/g;
  return $s;
}

sub pos
{
  return $_[0]->{'pos'};
}

sub DESTROY
{
  close($_[0]->{'io'});
}

1;
