File Coverage

blib/lib/Parse/Token.pm

Criterion	Covered	Total	%
statement	157	432	36.3
branch	33	182	18.1
condition	7	33	21.2
subroutine	36	59	61.0
pod	13	25	52.0
total	246	731	33.6

require 5.004;
use strict qw(vars);
use strict qw(refs);
use strict qw(subs);

package Parse::Token;		# or perhaps: Parse::AToken
$Parse::Token::VERSION = '2.21';
use Parse::Trace;
@Parse::Token::ISA = qw(Parse::Trace);

use vars qw($AUTOLOAD $trace $PENDING_TOKEN $EOI);
$trace = 0;

# other possibilities: pseudo-hash, constants (see The Perl Journal Spring 99)
my %_map;
my @attributes = qw(STATUS TEXT NAME CONDITION
		    REGEXP SUB DECORATION LEXER HANDLER READ_MORE_RE EXPRESSION
		    TEMPLATE TRACE IN_PKG);
my($STATUS, $TEXT, $NAME, $CONDITION,
   $REGEXP, $ACTION, $DECORATION, $LEXER, $HANDLER, $READ_MORE_RE, $EXPRESSION,
   $CODE, $TRACE, $IN_PKG) = @_map{@attributes} = (0..$#attributes);
sub _map {
  shift;
  if (@_) {
    wantarray ? @_map{@_} : $_map{$_[0]}
  } else {
    @attributes;
  }
}

$EOI = Parse::Token->new('EOI');

#  new()
# Purpose: token constructor
# Arguments: see definition
# Returns: Return a token object
sub new {
  my $receiver = shift;
  my $class = (ref $receiver or $receiver);
  my $self = bless [], $class;

  my $debug = 0;
  print STDERR "@_\n" if $debug;
  print STDERR "@{$_[1]}\n" if $debug and ref $_[1];

				# initialize...
  $self->[$STATUS] = 0;		# object status
  $self->[$TEXT] = '';		# recognized text
  (
   $self->[$CONDITION], 	# associated conditions
   $self->[$NAME],		# symbolic name
   $self->[$REGEXP],
   $self->[$ACTION],
   $self->[$EXPRESSION],
   $self->[$READ_MORE_RE],
   $self->[$HANDLER],
   $self->[$LEXER],
  ) = (
       $self->_parseName($_[0]), # condition + name
       $_[1],			# regexp, can be an array reference
       $_[2],			# associated sub
       $_[3],			# expression (Token::Action)
       $_[4],			# read more data if $_[4] =~ $LEX_BUFFER
       $_[5],			# name of the event handler
       $_[6],			# lexer instance
      );
  $self->[$IN_PKG] = '';	# defined in this package
  $self->[$DECORATION] = {};	# token decoration
  $self->[$CODE] = '';		# generated code
  $self->[$TRACE] = $trace;	# trace
  $self;
}
# Purpose: export a token object in the caller's package or
#          in the package returned by inpkg()
# Arguments:
# Returns: the token object
sub exportTo {
  my $self = shift;
  my $inpkg = $self->inpkg;
  unless (defined $inpkg) {
    $inpkg = caller;		# (caller(0))[0];
    $self->inpkg($inpkg);
  }
  my $name = $self->name;
  no strict 'refs';
  if ($^W and defined ${"$inpkg" . "::" . "$name"}) {
    require Carp;
    Carp::carp "the '${inpkg}::$name' token is already defined";
  }
  ${"$inpkg" . "::" . "$name"} = $self;
  $self;
}

# Purpose: create a list of token objects
# Arguments: a list of token specification or token objects
# Returns: list of token objects
sub factory {
  my $self = shift;

  unless (defined($_[0])) {
    require Carp;
    Carp::croak "argument of the factory() method must be a list of token specifications";
  }
  my $sub;
  my $ref;
  my @token;			# returned list of tokens
  my $token;
  my $arg;
  my $token_class = '';
  my $debug = 0;
  if (ref $_[0] eq 'ARRAY') {	# [Type => Segmented, Name => Xxxx, Etc.]
    my @args = @{$_[0]};
    my @specif = ();
    my $next_type = '';
    while (@args) {
      $arg = shift @args;
      if (ref $arg and $arg->isa(__PACKAGE__)) {
	push @token, $arg;
      } elsif ($arg =~ /^[Tt]ype$/) {
	if (@specif) {
	  $token_class = $next_type;
	  unless ($token_class->isa(__PACKAGE__)) {
	    eval { require $token_class };
	    if ($@) {
	      require Carp;
	      Carp::croak "$@"; # "unable to access to the $token_class class";
	    }
	  }
	  print STDERR "$token_class - @specif\n" if $debug;
	  push @token, $token_class->new(@specif);
	  @specif = ();
	}
	$next_type = __PACKAGE__ . '::' . shift(@args);
      } else {
	push @specif, $arg;
      }
    }
    if (@specif) {
      $token_class = $next_type; # todo: load if not defined;
      print STDERR "$token_class - @specif\n" if $debug;
      push @token, $token_class->new(@specif);
      @specif = ();
    }
  } else {
    while (@_) {
      $arg = shift;
				# it's already an instance
      if (ref $arg and $arg->isa(__PACKAGE__)) { # isa()
	push @token, $arg;
      } else {			# parse the specification
	my($name, $regexp) = ($arg, shift);
	if (@_) {
	  $ref = ref($_[0]);
	  if ($ref and $ref eq 'CODE') { # if next arg is a sub reference
	    $sub = shift;
	  } else {
	    $sub = undef;
	  }
	} else {
	  $sub = undef;
	}
	unless (ref($regexp) eq 'ARRAY') {
	  $token_class = __PACKAGE__ . '::Simple';
	} else {
	  $token_class = __PACKAGE__ . '::Segmented';
	}
	push @token, $token_class->new(Name => $name, Regex => $regexp, Sub => $sub);
      }
    }
  }
  @token;
}
sub _parseName {
  my $self = shift;
  my $name = shift;
  my $condition = '';
  if ($name =~ /^(.+:)(.+)/) { # Ex. A:B:C:SYMBOL, A,C:SYMBOL
    ($condition, $name) = ($1, $2);
  }
  ($condition, $name);
}
sub code {
  my $self = shift;
  if (defined $_[0]) {
    $self->[$CODE] = $_[0];
  } else {
    $self->[$CODE];
  }
}
sub getCode {
  my $self = shift;
  my $part = shift;
  $self->[$CODE];
}
sub setCode {
  my $self = shift;
  $self->[$CODE] = shift;
}
sub condition {
  my $self = shift;
  if (@_) {
    $self->[$CONDITION] = shift;
  } else {
    $self->[$CONDITION];
  }
}
sub expression {
  my $self = shift;
  if (@_) {
    $self->[$EXPRESSION] = shift;
  } else {
    $self->[$EXPRESSION];
  }
}
sub readmore {
  my $self = shift;
  if (@_) {
    $self->[$READ_MORE_RE] = shift;
  } else {
    $self->[$READ_MORE_RE];
  }
}
sub AUTOLOAD {			# is this useful or dangerous? ;-)
  my $self = shift;
  return unless ref($self);
  return if $AUTOLOAD =~ /\bDESTROY$/;
  my $name = $AUTOLOAD;
  $name =~ s/.*://;
  my $value = shift;
  if (defined $value) {
    ${$self->[$DECORATION]}{$name} = $value;
  } else {
    ${$self->[$DECORATION]}{$name};
  }
}
# set(ATTRIBUTE, VALUE)
# Purpose: set an attribute value
sub set {  ${$_[0]->[$DECORATION]}{$_[1]} = $_[2];}
# get(ATT)
# Purpose: return an attribute value
sub get {  ${$_[0]->[$DECORATION]}{$_[1]};}

sub inpkg {			# not documented
  my $self = shift;
  if (defined $_[0]) {
    $self->[$IN_PKG] = $_[0]
  } else {
    $self->[$IN_PKG];
  }
}
# status()
# Purpose: Indicate is the last token search has succeeded or not
# Arguments:
# Returns:
sub status {
  defined($_[1]) ?
    $_[0]->[$STATUS] = $_[1] :
      $_[0]->[$STATUS];
}
# setText()
# Purpose: Return the symbolic name of the object
# Arguments:
# Returns: see purpose
# Extension: save $1, $2... in a list
sub setText    { $_[0]->[$TEXT] = $_[1] } # set token string

# getText()
# Purpose:
# Arguments:
# Returns:
sub getText    { $_[0]->[$TEXT] }	# get token string

sub text {
  defined($_[1]) ?
    $_[0]->[$TEXT] = $_[1] :
      $_[0]->[$TEXT];
}

sub name { $_[0]->[$NAME] }	# name of the token
*type = \&name;			# synonym of the name() method

sub regexp { $_[0]->[$REGEXP] }	# regexp

sub handler { $_[0]->[$HANDLER] } # name of an event handler

# action()
# Purpose:
# Arguments:
# Returns:
sub action { $_[0]->[$ACTION] } # anonymous function

# lexer(EXP)
# lexer
# Purpose: Defines or returns the associated lexer
# Arguments:
# Returns:
sub lexer {
  if (defined $_[1]) {
    $_[0]->[$LEXER] = $_[1];
  } else {
    $_[0]->[$LEXER];
  }
}

sub getRegisteredLexerType {
  my $self = shift;
  my $type = shift;
  my $class = ref $self || $self;
  no strict 'refs';
  foreach (@{"${class}::REGISTERED_LEXER_TYPE"}) {
    return $_ if $type->isa("Parse::$_");
  }
  require Carp;
  Carp::croak "no template defined for the '$class' token in the '$type' lexer";
}
# not documented
sub do {
  my $self = shift;
  &{(shift)}($self, @_)
}

# next()
# Purpose: Return the string token if token is the pending token
# Arguments: no argument
# Returns: a token string if token is found, else undef
# Remark: $PENDING_TOKEN  is set by the Parse::ALex class
sub next {			# return the token string
  my $self = shift;
  my $lexer = $self->[$LEXER];
  my $pendingToken = $lexer->[$PENDING_TOKEN];
  if ($pendingToken == $EOI) {
    $self->[$STATUS] = $self == $EOI ? 1 : 0;
    return undef;
  }
  $lexer->next() unless $pendingToken;
  if ($self == $lexer->[$PENDING_TOKEN]) {
    $lexer->[$PENDING_TOKEN] = 0; # now no pending token
    my $text = $self->[$TEXT];
    $self->[$TEXT] = '';
    $self->[$STATUS] = 1;
    $text;			# return token string
  } else {
    $self->[$STATUS] = 0;
    undef;
  }
}
# isnext()
# Purpose: Return the status of the token object, and the recognized string
# Arguments: scalar reference
# Returns:
#  1. the object status
#  2. the recognized string is put in the scalar reference
sub isnext {
  my $self = shift;
  my $lexer = $self->[$LEXER];
  my $pendingToken = $lexer->[$PENDING_TOKEN];
  if ($pendingToken == $EOI) {
    ${$_[0]} = undef;
    return $self->[$STATUS] = $self == $EOI ? 1 : 0;
  }
  $lexer->next() unless $pendingToken;
  if ($self == $lexer->[$PENDING_TOKEN]) {
    $lexer->[$PENDING_TOKEN] = 0; # now no pending token
    ${$_[0]} = $self->[$TEXT];
    $self->[$TEXT] = '';
    $self->[$STATUS] = 1;
    1;
  } else {
    $self->[$STATUS] = 0;
    ${$_[0]} = undef;
    0;
  }
}

package Parse::Token::Action;
use Parse::Template;
@Parse::Token::Action::ISA = qw(Parse::Token Parse::Trace);

use vars qw(%TEMPLATE $template);
%TEMPLATE =
(EXPRESSION_PART => q!
 %%$CONDITION%%
 %%$EXPRESSION%%
 !
);
$template = new Parse::Template(%TEMPLATE);
sub new {
  my $receiver = shift;
  my ($name, $expression) = $receiver->_parse(@_);
  my $token = $receiver->SUPER::new($name, '', '', $expression);
  $token;
}
sub _parse {
  my $self = shift;
  unless (@_ >= 2) {
    require  Carp;
    Carp::croak "bad argument number (@_)";
  }
  my ($key, $value);
  my ($name, $expression);
  my $escape = '';
  while (@_ >= 2) {
    ($key, $value) = (shift, shift);
    if ($key =~ /^[Nn]ame$/) {
      $name = $value;
    } elsif ($key =~ /^[Ee]xpr$/) {
      $expression = $value;
    } else {
      require  Carp;
      Carp::croak "'$key' is an invalid attribute for a ", __PACKAGE__, "'s instance";
    }
  }
  ($name, $expression);
}
sub genCode {
  my $self = shift;

  my $lexer = $self->lexer;
  my $tokenid = $lexer->inpkg() . '::' . $self->name();
  my $condition = $lexer->genCondition($self->condition);
  my $expression = $self->expression;

  $template->env(
		 CONDITION => $condition,
		 EXPRESSION => $expression,
		);
  my $code = $template->eval('EXPRESSION_PART');
  $self->code($code);
  $code;
}

package Parse::Token::Simple;
use Parse::Trace;
use Parse::Template;
@Parse::Token::Simple::ISA = qw(Parse::Token Parse::Trace);

sub new {
  my $receiver = shift;
  my $token = $receiver->SUPER::new($receiver->_parse(@_));
  $token;
}
sub _parse {
  my $self = shift;
  unless (@_ >= 2) {
    require  Carp;
    Carp::croak "bad argument number (@_)";
  }
  my ($name, $regex, $action, $expression, $readif, $handler) =
    ('', '', '', '', '', '');
  my ($key, $value, $escape);
  while (@_ >= 2) {
    ($key, $value) = (shift, shift);
    if ($key =~ /^[Nn]ame$/) {
      $name = $value;
    } elsif ($key =~ /^(?:[Rr]egexp?|[Rr]e)$/) {
      $regex = $value;
    #} elsif ($key =~ /^[Rr]ead[Ii]f$/) { # regexp for continuation
    } elsif ($key =~ /^[Rr]eadMore$/) { # regexp for continuation
      $readif = $value == 1 ? "\$" : '';
    } elsif ($key =~ /^[Ss]ub$/) {
      $action = $value;
    } elsif ($key =~ /^[Hh]andler$/) {
      $handler = $value;
    } else {
      require  Carp;
      Carp::croak "'$key' is an invalid attribute for a ", __PACKAGE__, "'s instance";
    }
  }
  ($name, $regex, $action, $expression, $readif, $handler);
}

use vars qw(%TEMPLATE @REGISTERED_LEXER_TYPE $template);
@REGISTERED_LEXER_TYPE = qw(Lex CLex LexEvent);
%TEMPLATE = ();
####################################### Parse::Token::Simple - Parse::Lex class
$TEMPLATE{'LEX_HEADER_PART'} = q!
   %%$CONDITION%%
   $LEX_BUFFER =~ /\G(?:%%$REGEXP%%)/cg and do {
     %%$READ_MORE_RE ne '' ? LEX_READ_MORE_DATA_PART() : LEX_SET_TOKEN_PART()%%
     %%$WITH_TRACE ? LEX_TRACE_PART() : '' %%
     %%$WITH_SUB ? LEX_FOOTER_WITH_SUB_PART() : LEX_FOOTER_PART() %%
!;
$TEMPLATE{'LEX_READ_MORE_DATA_PART'} = q!
  my $pos = pos($LEX_BUFFER);
  my $line;
  $textLength = $pos - $LEX_POS;
  $pos = pos($LEX_BUFFER);
  while ($LEX_BUFFER =~ /\G(?:%%$READ_MORE_RE%%)/cg) {
     $line = <$LEX_FH>;
     if (defined $line) {
       $LEX_BUFFER .= $line;
       pos($LEX_BUFFER) = $pos;
       if ($LEX_BUFFER =~ /\G(?:%%$REGEXP%%)/cg) {
	 $pos = pos($LEX_BUFFER);
       } else {
	 last;
       }
     }
  }
  $textLength = pos($LEX_BUFFER) - $LEX_POS;
  $content = substr($LEX_BUFFER, $LEX_POS, $textLength); # $&
  $LEX_LENGTH = CORE::length($LEX_BUFFER);
  $LEX_OFFSET += $textLength;
  $LEX_POS += $textLength;
!;
$TEMPLATE{'LEX_SET_TOKEN_PART'} = q!
     $textLength = pos($LEX_BUFFER) - $LEX_POS;
     $content = substr($LEX_BUFFER, $LEX_POS, $textLength); # $&
     $LEX_OFFSET += $textLength;
     $LEX_POS += $textLength;
!;
$TEMPLATE{'LEX_TRACE_PART'} = q!
     if ($self->[%%$TRACE%%]) {
       my $tmp = '%%$REGEXP%%';
       my $trace = "Token read (" . $%%$TOKEN_ID%%->name . ", $tmp): $content";
       $self->context($trace);
     }
!;
$TEMPLATE{'LEX_FOOTER_WITH_SUB_PART'} = q!
    $%%$TOKEN_ID%%->setText($content);
    $self->[%%$PENDING_TOKEN%%] = $LEX_TOKEN = $%%$TOKEN_ID%%;
    $content = &{$%%$TOKEN_ID%%->action}($LEX_TOKEN, $content);
    ($LEX_TOKEN = $self->getToken)->setText($content);
    #print STDERR $LEX_TOKEN->name, " ", $self->[%%$PENDING_TOKEN%%]->name, " $content\n";
    %%$WITH_TRACE ? LEX_FOOTER_WITH_SUB_TRACE_PART() : ''%%
    last CASE;
  };
!;
$TEMPLATE{'LEX_FOOTER_WITH_SUB_TRACE_PART'} = q!
    if ($self->[%%$PENDING_TOKEN%%] ne $LEX_TOKEN) {
     if ($self->[%%$TRACE%%]) { # Trace
	    $self->context("Token type has changed - " .
			   "Type: " . $LEX_TOKEN->name .
			   " - Content: $content\n");
	  }
	}
!;
$TEMPLATE{'LEX_FOOTER_PART'} = q!
    $%%$TOKEN_ID%%->setText($content);
    $LEX_TOKEN = $%%$TOKEN_ID%%;
    last CASE;
   };
!;
####################################### Parse::Token::Simple - Parse::LexEvent class
$TEMPLATE{'LEXEVENT_HEADER_PART'} = q!
   %%$CONDITION%%
   $LEX_BUFFER =~ /\G(?:%%$REGEXP%%)/cg and do {
     %%$READ_MORE_RE ne '' ? LEX_READ_MORE_DATA_PART() : LEXEVENT_SET_TOKEN_PART()%%
     %%$WITH_TRACE ? LEXEVENT_TRACE_PART() : '' %%
     %%$TOKEN_HANDLER%%($%%$TOKEN_ID%%, $content);
    redo PARSE;
  };
!;
$TEMPLATE{'LEX_READ_MORE_DATA_PART'} = q!
  my $pos = pos($LEX_BUFFER);
  my $line;
  $textLength = $pos - $LEX_POS;
  $pos = pos($LEX_BUFFER);
  while ($LEX_BUFFER =~ /\G(?:%%$READ_MORE_RE%%)/cg) {
     $line = <$LEX_FH>;
     if (defined $line) {
         $LEX_BUFFER .= $line;
         pos($LEX_BUFFER) = $pos;
	 if ($LEX_BUFFER =~ /\G(?:%%$REGEXP%%)/cg) {
	   $pos = pos($LEX_BUFFER);
	 } else {
	   last;
	 }
     }
  }
  $textLength = pos($LEX_BUFFER) - $LEX_POS;
  $content = substr($LEX_BUFFER, $LEX_POS, $textLength); # $&
  $LEX_LENGTH = CORE::length($LEX_BUFFER);
  $LEX_OFFSET += $textLength;
  $LEX_POS += $textLength;
!;
$TEMPLATE{'LEXEVENT_SET_TOKEN_PART'} = q!
     $textLength = pos($LEX_BUFFER) - $LEX_POS;
     $content = substr($LEX_BUFFER, $LEX_POS, $textLength); # $&
     $LEX_OFFSET += $textLength;
     $LEX_POS += $textLength;
!;
$TEMPLATE{'LEXEVENT_TRACE_PART'} = q!
     if ($self->[%%$TRACE%%]) {
       my $tmp = '%%$REGEXP%%';
       my $trace = "Token read (" . $%%$TOKEN_ID%%->name . ", $tmp): $content";
       $self->context($trace);
     }
!;
####################################### Parse::Token::Simple - Parse::CLex class
$TEMPLATE{'CLEX_HEADER_PART'} = q!
   %%$CONDITION%%
   $LEX_BUFFER =~ s/^(?:%%$REGEXP%%)// and do {
     $content = $&;
     $textLength = CORE::length($content);
     $LEX_OFFSET += $textLength;
     $LEX_POS += $textLength;
     %%$WITH_TRACE ? CLEX_TRACE_PART() : '' %%
     %%$WITH_SUB ? CLEX_FOOTER_WITH_SUB_PART() : CLEX_FOOTER_PART() %%
!;
$TEMPLATE{'CLEX_TRACE_PART'} = q!
     if ($self->[%%$TRACE%%]) {
       my $tmp = '%%$REGEXP%%';
       my $trace = "Token read (" . $%%$TOKEN_ID%%->name . ", $tmp): $content";
       $self->context($trace);
     }
!;

$TEMPLATE{'CLEX_FOOTER_WITH_SUB_PART'} = q!
     $%%$TOKEN_ID%%->setText($content);
     $self->[%%$PENDING_TOKEN%%] = $LEX_TOKEN = $%%$TOKEN_ID%%;
     $content = &{$%%$TOKEN_ID%%->action}($LEX_TOKEN, $content);
     ($LEX_TOKEN = $self->getToken)->setText($content);
     %%$WITH_TRACE ? CLEX_FOOTER_WITH_SUB_TRACE_PART() : ''%%
     last CASE;
  };
!;
$TEMPLATE{'CLEX_FOOTER_WITH_SUB_TRACE_PART'} = q!
        if ($self->[%%$PENDING_TOKEN%%] ne $LEX_TOKEN) {
	  if ($self->isTrace) {
	    $self->context("token type has changed - " .
			   "Type: " . $LEX_TOKEN->name .
			   " - Content: $content\n");
	  }
	}
!;
$TEMPLATE{'CLEX_FOOTER_PART'} = q!
     $%%$TOKEN_ID%%->setText($content);
     $LEX_TOKEN = $%%$TOKEN_ID%%;
     last CASE;
   };
!;
$template = new Parse::Template(%TEMPLATE);
sub genCode {
  my $self = shift;

  my $lexer = $self->lexer;
  my($TRACE, $EOI, $HOLD_TEXT,  $PENDING_TOKEN) =
    $lexer->_map('TRACE', 'EOI', 'HOLD_TEXT', 'PENDING_TOKEN');

  my $tokenid = $lexer->inpkg() . '::' . $self->name();
  my $condition = $lexer->genCondition($self->condition);
  my $with_sub = $self->action ? 1 : 0;
  my $readmore =   $lexer->isFromString ? '' : $self->readmore;
  my $handler = $self->handler || $tokenid;
  $handler = $handler =~ /::/ ? $handler : $lexer->inpkg . '::' . $handler;

  $template->env(
		 CONDITION => $condition,
		 TOKEN_ID=> $tokenid,
		 TOKEN_HANDLER => $handler,
		 SKIP => $lexer->skip,
		 'IS_HOLD' => $lexer->isHold,
		 'WITH_TRACE' => $lexer->isTrace,
		 READ_MORE_RE => $readmore,
		 'WITH_SUB' => $with_sub,
		 'HOLD_TEXT' => $HOLD_TEXT,
		 'EOI' => $EOI,
		 'TRACE' => $TRACE,
		 'PENDING_TOKEN' => $PENDING_TOKEN,
		);

  my $ppregexp = $template->ppregexp($self->regexp);
  my $debug = 0;
  if ($debug) {
    print STDERR "REGEXP[$tokenid]->\t\t$ppregexp\n";
  }
  $template->env('REGEXP' => $ppregexp);
  # find the template code defined for this lexer type
  my $lexer_type = __PACKAGE__->getRegisteredLexerType(ref $lexer);
  my $code = $template->eval("\U$lexer_type" . '_HEADER_PART');
  $self->code($code);
  $code;
}

package Parse::Token::Segmented;
use Parse::Trace;
@Parse::Token::Segmented::ISA = qw(Parse::Token Parse::Trace);
sub new {
  my $receiver = shift;
  #my ($name, $regex, $action) = $receiver->_parse(@_);
  my $token = $receiver->SUPER::new($receiver->_parse(@_));
  $token;
}
sub _parse {
  my $self = shift;
  unless (@_ >= 2) {
    require  Carp;
    Carp::croak "bad argument number (@_)";
  }
  my ($name, $regex, $action, $expression, $readif, $handler) =
    ('', '', '', '', '', '');
  my ($key, $value, $escape) = ('', '', '');
  while (@_ >= 2) {
    ($key, $value) = (shift, shift);
    if ($key =~ /^[Nn]ame$/) {
      $name = $value;
    } elsif ($key =~ /^(?:[Rr]egexp?|[Rr]e)$/) {
      $regex = $value;
    } elsif ($key =~ /^[Ss]ub$/) {
      $action = $value;
    } elsif ($key =~ /^[Hh]andler$/) {
      $handler = $value;
    } else {
      require  Carp;
      Carp::croak "'$key' is an invalid attribute for a ", __PACKAGE__, "'s instance";
    }
  }
  ($name, $regex, $action, $expression, $readif, $handler);
}

use vars qw(%TEMPLATE @REGISTERED_LEXER_TYPE);
@REGISTERED_LEXER_TYPE = qw(Lex CLex LexEvent);
%TEMPLATE = ();
####################################### Parse::Token::Segmented - Parse::Lex class
$TEMPLATE{'LEX_HEADER_PART'} = q!
  %%$FROM_STRING ? LEX_HEADER_STRING_PART() : LEX_HEADER_STREAM_PART() %%
!;

$TEMPLATE{'LEX_HEADER_STRING_PART'} = q!
   %%$CONDITION%%
   $LEX_BUFFER =~ /\G(?:%%$REGEXP%%)/cg and do {
     $textLength = pos($LEX_BUFFER) - $LEX_POS; # length $&
     $content = substr($LEX_BUFFER, $LEX_POS, $textLength); # $&
     $LEX_OFFSET += $textLength;
     $LEX_POS += $textLength;
     %%$WITH_TRACE ? LEX_TOKEN_TRACE_PART() : '' %%
     %%$WITH_SUB ? LEX_FOOTER_WITH_SUB_PART() : LEX_FOOTER_PART() %%
!;
$TEMPLATE{'LEX_HEADER_STREAM_PART'} = q@
    %%$CONDITION%%
    $LEX_BUFFER =~ /\G(?:%%"$REGEXP_START"%%)/cg and do {
      my $before_pos = $LEX_POS;
      my $start_pos = pos($LEX_BUFFER);
      my $tmp = substr($LEX_BUFFER, $start_pos);
      my $line_read = 0;
      # don't use \G
      #print STDERR "before: $LEX_POS - initpos: $start_pos - tmp: $tmp\n";
      unless ($tmp =~ /^(?:%%"$REGEXP_MIDDLE$REGEXP_END"%%)/g) {
	my $line = '';
	do {
	  while (1) {
	    $line = <$LEX_FH>;
	    $line_read = 1;
	    unless (defined($line)) { #
	      $self->[%%$EOI%%] = 1;
	      $LEX_TOKEN = $Parse::Token::EOI;
	      require Carp;
	      Carp::croak "unable to find end of the '", $%%$TOKEN_ID%%->name, "' token";
	    }
	    $LEX_RECORD++;
	    $tmp .= $line;
	    last if $line =~ /%%$REGEXP_END%%/;
	  }
	} until ($tmp =~ /^(?:%%"$REGEXP_MIDDLE$REGEXP_END"%%)/g); # don't forget /g
      }
      $LEX_POS = $start_pos + pos($tmp);
      $LEX_OFFSET += $LEX_POS;
      if ($line_read) {
	$LEX_BUFFER = substr($LEX_BUFFER, 0, $start_pos) . $tmp;
	$LEX_LENGTH = CORE::length($LEX_BUFFER);
      }
      $content = substr($LEX_BUFFER, $before_pos, $LEX_POS - $before_pos);
      pos($LEX_BUFFER) = $LEX_POS;
      #print STDERR "LEX_BUFFER: $LEX_BUFFER\n";
      #print STDERR "pos: $before_pos - length: ", $LEX_POS -$before_pos, " - content->$content<-\n";
      %%$WITH_TRACE ? LEX_TOKEN_TRACE_PART() : '' %%
      %%$WITH_SUB ? LEX_FOOTER_WITH_SUB_PART() : LEX_FOOTER_PART() %%
@;
$TEMPLATE{'LEX_TOKEN_TRACE_PART'} = q!
     if ($self->[%%$TRACE%%]) { # Trace
       my $tmp = '%%$REGEXP%%';
       my $trace = "Token read (" . $%%$TOKEN_ID%%->name . ", $tmp): $content";
        $self->context($trace);
     }
!;
$TEMPLATE{'LEX_FOOTER_WITH_SUB_PART'} = q!
    $%%$TOKEN_ID%%->setText($content);
    $self->[%%$PENDING_TOKEN%%] = $LEX_TOKEN = $%%$TOKEN_ID%%;
    $content = &{$%%$TOKEN_ID%%->action}($LEX_TOKEN, $content);
    ($LEX_TOKEN = $self->getToken)->setText($content);
     %%$WITH_TRACE ? LEX_FOOTER_WITH_SUB_TRACE_PART() : ''%%
    last CASE;
  };
!;
$TEMPLATE{'LEX_FOOTER_WITH_SUB_TRACE_PART'} = q!
    if ($self->[%%$PENDING_TOKEN%%] ne $LEX_TOKEN) {
     if ($self->[%%$TRACE%%]) { # Trace
	    $self->context("Token type has changed - " .
			   "Type: " . $LEX_TOKEN->name .
			   " - Content: $content\n");
	  }
	}
!;
$TEMPLATE{'LEX_FOOTER_PART'} = q!
    $%%$TOKEN_ID%%->setText($content);
    $LEX_TOKEN = $%%$TOKEN_ID%%;
    last CASE;
   };
!;
####################################### Parse::Token::Segmented - Parse::LexEvent class
$TEMPLATE{'LEXEVENT_HEADER_PART'} = q!
  %%$FROM_STRING ? LEXEVENT_HEADER_STRING_PART() : LEXEVENT_HEADER_STREAM_PART() %%
!;

$TEMPLATE{'LEXEVENT_HEADER_STRING_PART'} = q!
   %%$CONDITION%%
   $LEX_BUFFER =~ /\G(?:%%$REGEXP%%)/cg and do {
     $textLength = pos($LEX_BUFFER) - $LEX_POS;
     $content = substr($LEX_BUFFER, $LEX_POS, $textLength); # $&
     $LEX_OFFSET += $textLength;
     $LEX_POS += $textLength;
     %%$WITH_TRACE ? LEXEVENT_TRACE_PART() : '' %%
     %%$TOKEN_HANDLER%%($%%$TOKEN_ID%%, $content);
    redo PARSE;
  };
!;
$TEMPLATE{'LEXEVENT_HEADER_STREAM_PART'} = q@
    %%$CONDITION%%
    $LEX_BUFFER =~ /\G(?:%%"$REGEXP_START"%%)/cg and do {
      my $before_pos = $LEX_POS;
      my $start_pos = pos($LEX_BUFFER);
      my $tmp = substr($LEX_BUFFER, $start_pos);
      my $line_read = 0;
      # don't use \G
      #print STDERR "before: $LEX_POS - initpos: $start_pos - tmp: $tmp\n";
      unless ($tmp =~ /^(?:%%"$REGEXP_MIDDLE$REGEXP_END"%%)/g) {
	my $line = '';
	do {
	  while (1) {
	    $line = <$LEX_FH>;
	    $line_read = 1;
	    unless (defined($line)) { #
	      $self->[%%$EOI%%] = 1;
	      $LEX_TOKEN = $Parse::Token::EOI;
	      require Carp;
	      Carp::croak "unable to find end of the '", $%%$TOKEN_ID%%->name, "' token";
	    }
	    $LEX_RECORD++;
	    $tmp .= $line;
	    last if $line =~ /%%$REGEXP_END%%/;
	  }
	} until ($tmp =~ /^(?:%%"$REGEXP_MIDDLE$REGEXP_END"%%)/g); # don't forget /g
      }
      $LEX_POS = $start_pos + pos($tmp);
      $LEX_OFFSET += $LEX_POS;
      if ($line_read) {
         $LEX_BUFFER = substr($LEX_BUFFER, 0, $start_pos) . $tmp;
         $LEX_LENGTH = CORE::length($LEX_BUFFER);
      }
      $content = substr($LEX_BUFFER, $before_pos, $LEX_POS - $before_pos);
      pos($LEX_BUFFER) = $LEX_POS;
      #print STDERR "LEX_BUFFER: $LEX_BUFFER\n";
      #print STDERR "pos: $before_pos - length: ", $LEX_POS -$before_pos, " - content->$content<-\n";
      %%$WITH_TRACE ? LEXEVENT_TRACE_PART() : '' %%
      %%$TOKEN_HANDLER%%($%%$TOKEN_ID%%, $content);
     redo PARSE;
   };
@;
$TEMPLATE{'LEXEVENT_TRACE_PART'} = q!
     if ($self->[%%$TRACE%%]) {
       my $tmp = '%%$REGEXP%%';
       my $trace = "Token read (" . $%%$TOKEN_ID%%->name . ", $tmp): $content";
       $self->context($trace);
     }
!;
####################################### Parse::Token::Segmented - Parse::CLex class
$TEMPLATE{'CLEX_HEADER_PART'} = q!
  %%$FROM_STRING ? CLEX_HEADER_STRING_PART() : CLEX_HEADER_STREAM_PART() %%
!;
$TEMPLATE{'CLEX_HEADER_STRING_PART'} = q!
   %%$CONDITION%%
   $LEX_BUFFER =~ s/^(?:%%$REGEXP%%)// and do {
     $content = $&;
     $textLength = CORE::length($content);
     $LEX_OFFSET += $textLength;
     $LEX_POS += $textLength;
     %%$WITH_TRACE ? CLEX_TOKEN_TRACE_PART() : '' %%
     %%$WITH_SUB ? CLEX_FOOTER_WITH_SUB_PART() : CLEX_FOOTER_PART() %%
!;
$TEMPLATE{'CLEX_HEADER_STREAM_PART'} = q!
    %%$CONDITION%%
    $LEX_BUFFER =~ s/^(?:%%$REGEXP_START%%)// and do {
      my $string = $LEX_BUFFER;
      $content = $&;
      my $length = CORE::length($content) + CORE::length($LEX_BUFFER);
     do {
       until ($string =~ /%%$REGEXP_END%%/) {
	 $string = <$LEX_FH>;
	 unless (defined($string)) { #
           $self->[%%$EOI%%] = 1;
           $LEX_TOKEN = $Parse::Token::EOI;
	   require Carp;
	   Carp::croak "unable to find end of the '", $%%$TOKEN_ID%%->name, "' token";
	 }
	 $length = CORE::length($string);
	 $LEX_RECORD++;
	 $LEX_BUFFER .= $string;
       }
       $string = '';
     } until ($LEX_BUFFER =~ s/^(?:%%"$REGEXP_MIDDLE$REGEXP_END"%%)//);
     $content .= $&;
     $textLength = CORE::length($content);
     $LEX_OFFSET += $textLength;
     $LEX_POS += $length - CORE::length($LEX_BUFFER);
     %%$WITH_TRACE ? CLEX_TOKEN_TRACE_PART() : '' %%
     %%$WITH_SUB ? CLEX_FOOTER_WITH_SUB_PART() : CLEX_FOOTER_PART() %%
!;
$TEMPLATE{'CLEX_TOKEN_TRACE_PART'} = q!
     if ($self->[%%$TRACE%%]) { # Trace
       my $tmp = '%%$REGEXP%%';
       my $trace = "Token read (" . $%%$TOKEN_ID%%->name . ", $tmp): $content";
        $self->context($trace);
     }
!;
$TEMPLATE{'CLEX_FOOTER_WITH_SUB_PART'} = q!
     $%%$TOKEN_ID%%->setText($content);
     $self->[%%$PENDING_TOKEN%%] = $LEX_TOKEN = $%%$TOKEN_ID%%;
     $content = &{$%%$TOKEN_ID%%->action}($LEX_TOKEN, $content);
     ($LEX_TOKEN = $self->getToken)->setText($content);
     %%$WITH_TRACE ? CLEX_FOOTER_WITH_SUB_TRACE_PART() : ''%%
     last CASE;
  };
!;
$TEMPLATE{'CLEX_FOOTER_WITH_SUB_TRACE_PART'} = q!
        if ($self->[%%$PENDING_TOKEN%%] ne $LEX_TOKEN) {
	  if ($self->isTrace) {
	    $self->context("token type has changed - " .
			   "Type: " . $LEX_TOKEN->name .
			   " - Content: $content\n");
	  }
	}
!;
$TEMPLATE{'CLEX_FOOTER_PART'} = q!
     $%%$TOKEN_ID%%->setText($content);
     $LEX_TOKEN = $%%$TOKEN_ID%%;
     last CASE;
   };
!;
my $template = new Parse::Template(%TEMPLATE);
sub genCode {
  my $self = shift;
  my $debug = 0;

  my $lexer = $self->lexer;
  my $tokenid = $lexer->inpkg() . '::' . $self->name();
  my $condition = $lexer->genCondition($self->condition);
  my $handler = $self->handler || $tokenid;
  $handler = $handler =~ /::/ ? $handler : $lexer->inpkg . '::' . $handler;

  my($TRACE, $EOI, $HOLD_TEXT,  $PENDING_TOKEN) =
    $lexer->_map('TRACE', 'EOI', 'HOLD_TEXT', 'PENDING_TOKEN');

  my $with_sub = $self->action ? 1 : 0;
  $template->env(
		 'CONDITION' => $condition,
		 'TOKEN_ID' => $tokenid,
		 TOKEN_HANDLER => $handler,
		 'SKIP' => $lexer->skip,
		 'FROM_STRING' => $lexer->isFromString,
		 'IS_HOLD' => $lexer->isHold,
		 'WITH_TRACE' => $lexer->isTrace,
		 'WITH_SUB' => $with_sub,
		 'HOLD_TEXT' => $HOLD_TEXT,
		 'EOI' => $EOI,
		 'TRACE' => $TRACE,
		 'PENDING_TOKEN' => $PENDING_TOKEN,
		);

  my $ppregexp;
  my $tmpregexp;
  my $regexp = $self->regexp;
  print STDERR "REGEXP[$tokenid]->\t\t@{$self->[$REGEXP]}\n" if $debug;

  if ($#{$regexp} >= 3) {
    require Carp;
    Carp::carp join  " " , "Warning!", $#{$regexp} + 1,
    "arguments in token definition";
  }
  $ppregexp = $tmpregexp = $template->ppregexp(${$regexp}[0]);
  $template->env('REGEXP_START' => $ppregexp);

  $ppregexp = ${$regexp}[1] ? $template->ppregexp(${$regexp}[1]) : '(?:.*?)';
  $tmpregexp .= $ppregexp;
  $template->env('REGEXP_MIDDLE' => $ppregexp);

  $ppregexp = $template->ppregexp(${$regexp}[2] or ${$regexp}[0]);
  $template->env('REGEXP_END' => $ppregexp);
  $ppregexp = "$tmpregexp$ppregexp";

  if ($debug) {
    print STDERR "REGEXP[$tokenid]->\t\t$ppregexp\n";
  }
  $template->env('REGEXP' => $ppregexp);

  # find the template code defined for this lexer type
  my $lexer_type = __PACKAGE__->getRegisteredLexerType(ref $lexer);
  my $code = $template->eval("\U$lexer_type" . '_HEADER_PART');
  $self->code($code);
  $code;
}

package Parse::Token::Delimited;
use Parse::Trace;
@Parse::Token::Delimited::ISA = qw(Parse::Token::Segmented Parse::Trace);

# Examples:
# [qw(/[*] (?s:.*?) [*]/)]
# [qw()]
# [qw(<[?] (?s:.*?) [?]>)]

sub _parse {
  my $self = shift;
  unless (@_ >= 2) {
    require  Carp;
    Carp::croak "bad argument number (@_)";
  }
  my ($name, $regex, $action, $expression, $readif, $handler) =
    ('', '', '', '', '', '');
  my ($key, $value, $start, $end, $escape) = ('', '');
  while (@_ >= 2) {
    ($key, $value) = (shift, shift);
    if ($key =~ /^[Nn]ame$/) {
      $name = $value;
    } elsif ($key =~ /^[Ss]tart$/) {
      $start = $value;
      $end = $value unless defined $end;
    } elsif ($key =~ /^[Ee]nd$/) {
      $end = $value;
      $start = $value unless defined $start;
    } elsif ($key =~ /^[Ss]ub$/) {
      $action = $value;
    } elsif ($key =~ /^[Hh]andler$/) {
      $handler = $value;
    } else {
      require  Carp;
      Carp::croak "'$key' is an invalid attribute for a ", __PACKAGE__, "'s instance";
    }
  }
  unless (defined $start) {
    require Carp;
    Carp::croak "'Start' regex not defined";
  }
  unless (defined $end) {
    require Carp;
    Carp::croak "'End' regex not defined";
  }
  $regex = $self->_buildRegexp($start, $end);
  ($name, $regex, $action, $expression, $readif, $handler);
}
sub _buildRegexp {
  my $self = shift;
  my ($start, $end) = @_;
  my $content;
  $content = q!(?s:.*?)!;
  #print STDERR "[$start, $content, $end]\n";
  [$start, $content, $end];
}

package Parse::Token::Quoted;
use Parse::Trace;
@Parse::Token::Quoted::ISA = qw(Parse::Token::Segmented Parse::Trace);

sub _parse {
  my $self = shift;
  unless (@_ >= 2) {
    require  Carp;
    Carp::croak "bad argument number (@_)";
  }

  my ($name, $regex, $action, $expression, $readif, $handler) =
    ('', '', '', '', '', '');
  my ($key, $value, $start, $end, $escape) = ('', '');
  while (@_ >= 2) {
    ($key, $value) = (shift, shift);
    if ($key =~ /^[Nn]ame$/) {
      $name = $value;
    } elsif ($key =~ /^[Qq]uote$/) {
      $start = $value unless defined $start;
      $end = $value unless defined $end;
    } elsif ($key =~ /^[Ss]tart$/) {
      $start = $value;
      $end = $value unless defined $end;
    } elsif ($key =~ /^[Ee]nd$/) {
      $end = $value;
      $start = $value unless defined $start;
    } elsif ($key =~ /^[Ee]scape$/) {
      $escape = $value;
    } elsif ($key =~ /^[Ss]ub$/) {
      $action = $value;
    } elsif ($key =~ /^[Hh]andler$/) {
      $handler = $value;
    } else {
      require  Carp;
      Carp::croak "'$key' is an invalid attribute for a ", __PACKAGE__, "'s instance";
    }
  }
  unless (defined $start) {
    require Carp;
    Carp::croak "'Start' char not defined";
  }
  unless (defined $end) {
    require Carp;
    Carp::croak "'end' char not defined";
  }
  $regex = $self->_buildRegexp($start, $end, $escape);
  ($name, $regex, $action, $expression, $readif, $handler);
}
# Examples:
# [qw(" [^"]+(?:""[^"]*)* ")]
# [qw(" [^\\"]+(?:\\.[^\\"]*)* ")]
sub _buildRegexp {
  my $self = shift;
  my ($start, $end, $escape) = @_;
  my $content;
  $start = quotemeta $start;
  $end = quotemeta $end;
  if (defined $escape and $escape ne '') {
    $escape = quotemeta $escape;
    $content = qq![^$end$escape]*(?:$escape.! . qq![^$end$escape]*)*!;
  } else {
    $content = qq![^$end]*(?:$end$end! . qq![^$end]*)*!;
  }
  #print STDERR "[$start, $content, $end]\n";
  [$start, $content, $end];
}

package Parse::Token::Nested;
use Parse::Trace;
@Parse::Token::Nested::ISA = qw(Parse::Trace);

# Examples:
# (+ (* 3 4) 4)
#
sub new {
  die "Sorry! Not yet implemented";
}

1;
__END__