File Coverage

blib/lib/IO/Tokenized.pm

Criterion	Covered	Total	%
statement	133	170	78.2
branch	31	56	55.3
condition			n/a
subroutine	19	24	79.1
pod	10	12	83.3
total	193	262	73.6

package IO::Tokenized;

use strict;
use warnings;

use vars qw/$VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS/;
use constant BUFFER_SIZE => 30 * 1024;
use constant TOKEN_SEPARATOR => qr/\s/;

use Carp;
use Symbol;
use Exporter;

$VERSION = '0.04';

@ISA = qw(Exporter);
@EXPORT = ();
@EXPORT_OK = qw(initialize_parsing buffer_space token_separator flushbuffer
                skip resynch getline getlines gettoken gettokens setparser);

%EXPORT_TAGS = (all => [@EXPORT_OK],
		parse => [qw(initialize_parsing gettoken gettokens)],
		buffer => [qw(bufferspace flushbuffer resynch)]
	       );

sub new {
  my $class = shift;
  my ($self,@tokens) = @_;
  $self = gensym unless defined $self;
  bless $self,$class;
  initialize_parsing($self,@tokens);
}

sub initialize_parsing {
  my $self = shift;
  my @tokens = @_;
  @{${*$self}{__PACKAGE__}{definition}} = ();
  flushbuffer($self) &&
    carp __PACKAGE__ ."(re)initializing parser with not empty buffer";
  token_separator($self,TOKEN_SEPARATOR);
  buffer_space($self,BUFFER_SIZE);
  setparser($self,@tokens) if @tokens;
  return $self;
}

sub buffer_space {
  my $self = shift;

  ${*$self}{__PACKAGE__}{bufsize} = BUFFER_SIZE
    unless defined${*$self}{__PACKAGE__}{bufsize};

  my $oldvalue = ${*$self}{__PACKAGE__}{bufsize};
  ${*$self}{__PACKAGE__}{bufsize} = shift if @_;
  return $oldvalue;
}

sub token_separator {
  my $self = shift;
  my $oldvalue = ${*$self}{__PACKAGE__}{token_separator};
  ${*$self}{__PACKAGE__}{token_separator} = shift if @_;
  return $oldvalue;
}

sub flushbuffer {
  my $self = shift;
  my $oldvalue = ${*$self}{__PACKAGE__}{buffer};
  ${*$self}{__PACKAGE__}{buffer} = "";
  return $oldvalue;
}

# tries to read from self until repetedly removing skip prefix until
# one of the following is verified:
# 1. the buffer is not empty and doesn't start with a skip prefix
# 2. the end of file is reached without 1. beeing fulfilled.
#
# The function returns true in the first case, false in the second

sub skip {
  my $self = shift;
  my $re = token_separator($self);
  my $buffer = \${*$self}{__PACKAGE__}{buffer};
  while (1) {
    $$buffer = scalar <$self> unless length($$buffer);
    return unless defined $$buffer; #end of file
    $$buffer =~ s/^$re+//;
    return 1 if length($$buffer);
  }
}

# flushes buffer till the first token, if possible
sub resynch {
  my $self = shift;
  my $resyncher = ${*$self}{__PACKAGE__}{resyncher};
  &$resyncher($self);
}

sub getline {
  my $self = shift;
  my $buffer = \${*$self}{__PACKAGE__}{buffer};
  if ($$buffer =~ s!^(.*?$/)!!) {
    return $1;
  }
  else {
    $$buffer .= scalar <$self>;
    flusbuffer($self);
  }
}

sub getlines {
  my $self = shift;
  my @lines = (getline($self));
  push @lines,<$self> unless eof $self;
  return @lines;
}


sub gettoken {
  my $self = shift;
  my $parser = ${*$self}{__PACKAGE__}{parser};

  skip($self) || return;
  my ($token,$value) = &$parser($self);
  if ($token eq '') {
    return;
  }
  elsif ($token eq '') {
    croak "Overflowed buffer with no token found";
  }
  else {
    return ($token => $value);
  }
}

sub gettokens {
  my $self = shift;
  my @result;
  while (my $t = gettoken($self)) {
    push @result,$t;
  }
  return @result;
}

sub setparser {
  my $self = shift;
  my @oldvalue = @{${*$self}{__PACKAGE__}{definition}};
  @{${*$self}{__PACKAGE__}{definition}} = @_;
  my %regexp = ();
  my %functions = ();
  my @order = ();

  foreach my $definition (@{${*$self}{__PACKAGE__}{definition}}) {
    my ($tok,$re,$func) = @$definition;
    if ($tok eq "") {
      token_separator($self,$re);
      next;
    }
    if (exists $regexp{$tok}) {
      carp "token '$tok' redefined!";
      next;
    }
    push @order,$tok;
    $regexp{$tok} = $re;
    $functions{$tok} = $func if defined $func;
  }
  ${*$self}{__PACKAGE__}{parser} = eval {
    my @checkers = ();
    foreach my $tok (@order) {
      my $sub = eval {
	my $func = exists $functions{$tok} ? $functions{$tok} : sub {shift @_};
	my $re = qr/^($regexp{$tok})(.*)/s;
	my $token = $tok;

	sub {
	  my $self = shift;
	  my $buffer = \${*$self}{__PACKAGE__}{buffer};
	  my @items = ($$buffer =~ $re);
	  return (undef,undef) unless @items;
	  my $tmp = pop @items;
	  my $value = &$func(@items);
	  return unless defined $value;
	  $$buffer = $tmp;
	  return ($token => $value);
	}
      };
      croak $@ if $@;
      push @checkers,$sub;
    }
    # now define the parser
    sub {
      my $self = shift;
      my $buffer = \${*$self}{__PACKAGE__}{buffer};
      while (1) {
	foreach my $checker (@checkers) {
	  my ($token,$value) = &$checker($self);
	  return ($token,$value) if defined $token;
	}
	# no token matched... we try to extend the buffer by reading
	# another line but first we check that there is no overflow
	return ('' => undef) unless
	  length($$buffer) < buffer_space($self);
	my $line = scalar <$self>;
	return ('' => undef) unless defined $line;
	$$buffer .= $line;
      }
    };
  };
  croak $@ if $@;
  my $resynch = "(?=" . join("|",
			     map("(?:$regexp{$_})",@order)) . ")";
  ${*$self}{__PACKAGE__}{resyncher} = eval {
    my $resynch_re = qr/$resynch/os;
    #the resyncher
    sub {
      my $self = shift;
      my $buffer = \${*$self}{__PACKAGE__}{buffer};
      while (1) {
	return 1 if $$buffer =~ s/^.*?(?=$resynch_re)//;
	$$buffer = scalar <$self>;
	return unless defined $$buffer;
      }
    }
  };
  croak $@ if $@;
  return @oldvalue;
}

1;
__END__