# Complex.pm: Class Used to Manage Complex Lexical Units

package RDA::Token::Complex;

# $Id: Complex.pm,v 1.4 2015/05/05 13:05:50 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Token/Complex.pm,v 1.4 2015/05/05 13:05:50 RDA Exp $
#
# Change History
# 20150505  MSC  Improve the documentation.

=head1 NAME

RDA::Token::Complex - Class Used to Manage Complex Lexical Units

=head1 SYNOPSIS

 require RDA::Token::Complex;

=head1 DESCRIPTION

The objects of the C<RDA::Token::Complex> class are used to manage lexical
units that may require reading additional data. It is a subclass of
L<RDA::Object::Token|RDA::Object::Token>.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use RDA::Text qw(debug get_string);
  use RDA::Driver::Template;
  use RDA::Object;
  use RDA::Object::Token;
}

# Define the global public variables
use vars qw($STRINGS $VERSION @DUMP @ISA %SDCL);
$VERSION = sprintf('%d.%02d', q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/);
@DUMP    = (
  hsh => {'RDA::Token::Action'  => 1,
          'RDA::Token::Complex' => 1,
          'RDA::Token::Quoted'  => 1,
          'RDA::Token::Simple'  => 1,
         },
  );
@ISA     = qw(RDA::Object::Token RDA::Object Exporter);
%SDCL    = (
  inc => [qw(RDA::Object::Token RDA::Object)]
  );

# Define the global private constants
my $TEMPLATE = RDA::Driver::Template->new(
  ## no critic (Interpolation,Long,NewLine)
  LEX_HEADER => q!
    %%&FROM_STRING ? #LEX_HEADER_STRING : #LEX_HEADER_STREAM%%
!,

  LEX_HEADER_STRING => q!
    %%&CONDITION%%
    $LEX_BUF =~ /\G(?:%%&REGEXP%%)/cg and do
    { $lgt = pos($LEX_BUF) - $LEX_POS;
      $str = substr($LEX_BUF, $LEX_POS, $lgt);
      $LEX_OFF += $lgt;
      $LEX_POS += $lgt;
      %%&WITH_TRACE  ? #LEX_TOKEN_TRACE     : '' %%
      %%&FROM_STRING ? #LEX_TOKEN_STRING    : #LEX_TOKEN_STREAM %%
      %%&WITH_SUB    ? #LEX_FOOTER_WITH_SUB : #LEX_FOOTER %%
!,
  LEX_HEADER_STREAM => q@
    %%&CONDITION%%
    $LEX_BUF =~ /\G(?:%%&REGEXP_START%%)/cg and do
    { my $bef = $LEX_POS;
      my $beg = pos($LEX_BUF);
      my $tmp = substr($LEX_BUF, $beg);
      my $flg = 0;
      # don't use \G
      unless ($tmp =~ /^(?:%%&REGEXP_MIDDLE%%%%&REGEXP_END%%)/g)
      { my $lin = '';
        do
        { while (1)
          { $lin = <$LEX_IFH>;
            $flg = 1;
            unless (defined($lin))
            { $slf->{'EOI'} = 1;
              $LEX_TOK = $RDA::Object::Token::EOI;
              die "Unable to find end of token %%&TOKEN_ID%%\n";
            }
            $LEX_REC++;
            $tmp .= $lin;
            last if $lin =~ /%%&REGEXP_END%%/;
          }
        } until ($tmp =~ /^(?:%%&REGEXP_MIDDLE%%%%&REGEXP_END%%)/g);
      }
      $LEX_POS = $beg + pos($tmp);
      $LEX_OFF += $LEX_POS;
      if ($flg)
      { $LEX_BUF = substr($LEX_BUF, 0, $beg).$tmp;
        $LEX_LGT = length($LEX_BUF);
      }
      $str = substr($LEX_BUF, $bef, $LEX_POS - $bef);
      pos($LEX_BUF) = $LEX_POS;
      %%&WITH_TRACE ? #LEX_TOKEN_TRACE     : ''%%
      %%&WITH_SUB   ? #LEX_FOOTER_WITH_SUB : #LEX_FOOTER %%
@,
  LEX_TOKEN_TRACE => q!
      if ($slf->is_trace)
      { my $tmp = '%%&REGEXP%%';
        debug("LEX: Token read (%%&TOKEN_ID%%, $tmp): $str");
      }
!,
  LEX_FOOTER_WITH_SUB => q!
    $slf->set_token($LEX_TOK = $slf->get_definition('%%&TOKEN_ID%%'));
    $LEX_TOK->set_text($str);
    $str = &{$LEX_TOK->get_action}($LEX_TOK, $str);
    $LEX_TOK->set_text($str);
    $LEX_TOK = $slf->get_token;
    %%&WITH_TRACE ? #LEX_FOOTER_WITH_SUB_TRACE : ''%%
    last CASE;
  };
!,
  LEX_FOOTER_WITH_SUB_TRACE => q!
    unless ($slf->get_token == $LEX_TOK)
    { $slf->debuf('LEX: Token type has changed - Type: '.$LEX_TOK->get_oid
        ." - Content: $str\n") if $slf->is_trace;
    }
!,
  LEX_FOOTER => q!
    $LEX_TOK = $slf->get_definition('%%&TOKEN_ID%%');
    $LEX_TOK->set_text($str);
    last CASE;
  };
!,
  );

# Define the global private variables

# Report the package version
sub Version
{ return $VERSION;
}

=head2 S<$h = RDA::Token::Complex-E<gt>new($name,$pattern,$sub)>

The object constructor. This method enables you to specify a symbolic name, a
regular expression, and an anonymous subroutine as arguments. See the
L<RDA::Object::Token|RDA::Object::Token> super class for more details.

C<RDA::Token::Complex> is represented by a blessed hash reference. The
following special keys are used:

=over 12

=item S<    B<'lvl' > > Trace level

=item S<    B<'oid' > > Symbolic name

=item S<    B<'_act'> > Associated sub

=item S<    B<'_cnd'> > Associated conditions

=item S<    B<'_det'> > Token decoration

=item S<    B<'_exp'> > For an action token

=item S<    B<'_lex'> > Lexical analyzer instance

=item S<    B<'_pat'> > Regular expression (can be an array reference)

=item S<    B<'_sta'> > Object status

=item S<    B<'_tpl'> > Associated template

=item S<    B<'_txt'> > Recognized text

=back

Internal keys are prefixed by an underscore.

=cut

sub new
{ my ($cls, @arg) = @_;
  my ($slf);

  $slf = $cls->SUPER::new(@arg);
  $slf->set_template($TEMPLATE);
  return $slf;
}

# Generate the code
sub gen_code
{ my ($slf) = @_;
  my ($beg, $end, $exp, $lex, $mid, $tpl);

  $lex = $slf->get_lexer;
  $tpl = $slf->get_template;

  # Set the context
  $exp = $slf->get_re;
  $beg = $tpl->val_re($exp->[0]);
  $mid = defined($exp->[1]) ? $tpl->val_re($exp->[1]) : '(?:.*?)';
  $end = $tpl->val_re($exp->[2] || $exp->[0]);
  debug(q{REGEXP[}.$slf->get_oid.qq{]->\t\t$beg$mid$end})
    if $slf->{'lvl'} & 8;  ## no critic (Bit)

  $tpl->set_context($slf->{'lvl'},
    CONDITION     => $lex->gen_condition($slf->get_condition),
    FROM_STRING   => $lex->is_string,
    IS_HOLD       => $lex->is_hold,
    REGEXP        => $beg.$mid.$end,
    REGEXP_START  => $beg,
    REGEXP_MIDDLE => $mid,
    REGEXP_END    => $end,
    TOKEN_ID      => $slf->get_oid,
    WITH_TRACE    => $lex->is_trace,
    WITH_SUB      => defined($slf->get_action) ? 1 : 0,
    );

  # Evaluate the code part
  return $tpl->eval_part('LEX_HEADER');
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Token|RDA::Object::Token>,
L<RDA::Text|RDA::Text>

=head1 COPYRIGHT NOTICE

Copyright (c) 1996, 2016, Oracle and/or its affiliates. All rights reserved.

=head1 TRADEMARK NOTICE

Oracle and Java are registered trademarks of Oracle and/or its
affiliates. Other names may be trademarks of their respective owners.

=cut