package RDA::Object::Parser;

# $Id: Parser.pm,v 1.15 2009/01/13 16:51:53 mschenke Exp $
# ARCS: $Header: /u02/webapps/workbench/cvs/RDA_4/src/scripting/lib/RDA/Object/Parser.pm,v 1.15 2009/01/13 16:51:53 mschenke Exp $
#
# Change History
# 20090113  MSC  Change the copyright notice.

=head1 NAME

RDA::Object::Parser - Class Used for Parser Objects.

=head1 SYNOPSIS

require RDA::Object::Parser;

=head1 DESCRIPTION

The objects of the C<RDA::Object::Parser> class are used to parse data.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use RDA::Value;
}

# Define the global public variables
use vars qw($VERSION);
$VERSION = sprintf("%d.%02d", q$Revision: 1.15 $ =~ /(\d+)\.(\d+)/);

# Define the global private variables
my $TRC = 'PARSE> ';

my %tb_cod = map {$_ => 1} qw(beg end fmt var);

# Report the module version number
sub Version
{ $VERSION;
}

=head2 S<$h = RDA::Object::Parser-E<gt>new(...)>

The object constructor. It takes the ... as an argument.

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

=over 12

=item S<    B<'beg' > > Code to execute at the beginning of a block (B,R)

=item S<    B<'buf' > > Block line buffer size (B,R)

=item S<    B<'end' > > Code to execute at the end of a block (B,R)

=item S<    B<'esc' > > Continuation character (P)

=item S<    B<'fmt' > > Code to execute to reformat the input line (P)

=item S<    B<'flp' > > First line parsing indicator (B,R)

=item S<    B<'ini' > > Initially open blocks (P)

=item S<    B<'lin' > > Current line (P)

=item S<    B<'llp' > > Last line parsing indicator (B,R)

=item S<    B<'ltr' > > Left trim indicator (P)

=item S<    B<'max' > > Maximum number of lines in a block (B,R)

=item S<    B<'par' > > Parent information import indicator (B)

=item S<    B<'rtr' > > Right trim indicator (P)

=item S<    B<'trc' > > Trace indicator (P)

=item S<    B<'var' > > Line variable (P)

=item S<    B<'-blk'> > Block definition (P)

=item S<    B<'-buf'> > Block line buffer (R)

=item S<    B<'-cnt'> > Block line counter (R)

=item S<    B<'-cur'> > Current runtime block reference (P)

=item S<    B<'-end'> > Parser termination indicator (P)

=item S<    B<'-hit'> > Subexpression list of last pattern match (R)

=item S<    B<'-inp'> > Input buffer (P)

=item S<    B<'-kpt'> > Keep current line indicator (P)

=item S<    B<'-mrk'> > Last block marker (R)

=item S<    B<'-nam'> > Block name (B,R)

=item S<    B<'-par'> > Parent runtime block reference (R)

=item S<    B<'-pgm'> > Block script (B,R)

=back

Internal keys are prefixed by a dash.

=cut

sub new
{ my $slf   = shift;
  my $class = ref($slf) || $slf;
  my $trc   = shift;

  # Create the macro object
  $slf = bless {}, $class;

  # Initialize the parser end return the object reference
  $slf->reset($trc);
}

=head2 S<$h-E<gt>get_buffer>

This method returns a list containing all lines stored in the current block.

=cut

sub get_buffer
{ @{shift->{'-cur'}->{'-buf'}};
}

=head2 S<$h-E<gt>get_count>

This method returns the number of lines contained in the current block.

=cut

sub get_count
{ shift->{'-cur'}->{'-cnt'};
}

=head2 S<$h-E<gt>get_hit($off)>

This method retrieves a sub-expression from the last pattern match or the number
of sub-expressions when no argument is provided.

=cut

sub get_hit
{ my ($slf, $off) = @_;

  $slf = $slf->{'-cur'};
  !exists($slf->{'-hit'})
    ? undef
    : defined($off) ? $slf->{'-hit'}->[$off] : scalar(@{$slf->{'-hit'}});
}

=head2 S<$h-E<gt>get_line([$cnt])>

This method gets a new line from the file. That line becomes the new current
line of the parser. You can specify a number of lines to discard as an optional
argument. It returns an undefined value when the end of the file is reached.

=cut

sub get_line
{ my ($slf, $cnt) = @_;

  if (defined($cnt))
  { $slf->_get_line while $cnt-- > 0;
  }
  $slf->_get_line;
}

sub _get_line
{ my ($slf) = @_;
  my ($esc, $flg, $lin, $str);

  # Get single line
  return $slf->_fmt_line($slf->{'-inp'}->getline) unless length($slf->{'esc'});

  # Get a line and its continuation lines
  $str = '';
  while (defined($lin = $slf->{'-inp'}->getline))
  { $flg = 1;
    $str .= $lin;
    $str =~ s/[\n\r]+$//;
    last unless $str =~ s#$slf->{'esc'}$##;
  }
  $flg ? $slf->_fmt_line($str) : undef;
}

# Reformat the line
sub _fmt_line
{ my ($slf, $lin) = @_;

  if (defined($lin))
  { # Treat the line
    $lin =~ s/[\n\r]+$//;
    $lin =~ s/^\s+// if $slf->{'ltr'};
    $lin =~ s/\s+$// if $slf->{'rtr'};

    # Reformat the line
    if (ref($slf->{'fmt'}))
    { $slf->{'var'}->assign_value(RDA::Value->new('T', $lin));
      $lin = $slf->{'fmt'}->eval_as_string;
    }
    $slf->{'var'}->assign_value(RDA::Value->new('T', $lin));
  }
  $slf->{'lin'} = $lin;
}

=head2 S<$h-E<gt>get_marker>

This method returns the last block marker.

=cut

sub get_marker
{ shift->{'-cur'}->{'-mrk'};
}

=head2 S<$h-E<gt>keep>

This method indicates that the current line must be kept for the next action
loop.

=cut

sub keep
{ shift->{'-kpt'} = 1;
}

=head2 S<$h-E<gt>parse($buf[,$lin])>

This method parses a file. You can specify the first line as an extra argument.

=cut

sub parse
{ my ($slf, $buf, $lin) = @_;
  my ($cnt, $cur, $prv, $siz, $typ);

  # Abort if no parsing variable is defined
  return -1 unless ref($slf->{'var'}) && $slf->{'var'}->is_scalar_lvalue;

  # Initialisation
  $slf->{'-inp'} = $buf;
  $slf->{'-end'} = 0;
  $slf->{'-kpt'} = 0;

  # Create the initial runtime blocks
  print $TRC."*** Auto init block ".'TOP'."\n" if $slf->{'trc'};
  $slf->{'-cur'} = $cur = $slf->_set_block('TOP');
  $cur = $slf->_beg_block($slf->{'ini'}, '*** Auto init block ')
    if $slf->{'ini'};

  # Check if the first line has not been provided as argument
  defined($lin) ? $slf->_fmt_line($lin) : $slf->_get_line;

  # Parse the file
  while (defined($slf->{'lin'}))
  { print $TRC."Line ".$slf->{'-inp'}->input_line_number.": '".$slf->{'lin'}
      ."'\n"  if $slf->{'trc'};

    # Check if the maximum number of lines in the block is reached
    $cnt = $cur->{'-cnt'}++;
    $prv = undef;
    if ($cur->{'max'} && $cnt >= $cur->{'max'})
    { $cur = $slf->_end_block(1, '*** Size close block ');
      next;
    }
    if ($siz = $cur->{'buf'})
    { push(@{$cur->{'-buf'}}, $slf->{'lin'});
      $prv = shift(@{$cur->{'-buf'}})
        if $siz > 0 && scalar(@{$cur->{'-buf'}}) > $siz;
    }

    # Execute the block script
    ++$cnt unless $cur->{'flp'};
    foreach my $act (@{$cur->{'-pgm'}})
    { # Treat an action
      $typ = $act->[0];
      $cur->{'-hit'} = [];
      if ($typ eq 'A')     # --- Block auto close
      { next unless $cnt && $slf->{'lin'} =~ $act->[1];

        # Undo last line bufferisation
        --$cur->{'-cnt'};
        if ($siz = $cur->{'buf'})
        { pop(@{$cur->{'-buf'}});
          unshift(@{$cur->{'-buf'}}, $prv) if defined($prv);
        }

        # Auto close the current block
        $cur = $slf->_end_block($act->[2], '*** Auto close block ');

        # Auto open new block if requested
        if ($act->[3])
        { $cur = $slf->_beg_block($act->[3], '*** Auto begin block ',
            $act->[4]);
          $slf->{'-kpt'} = $cur->{'flp'};
        }
        else
        { $slf->{'-kpt'} = 1;
        }
        last;
      }
      elsif ($typ eq 'B')  # --- Block beginning
      { next unless $slf->{'lin'} =~ $act->[1];
        $cur = $slf->_beg_block($act->[2], '*** Begin block ', $act->[3]);
        $slf->{'-kpt'} = $cur->{'flp'};
        last;
      }
      elsif ($typ eq 'C')  # --- Code execution
      { my $ret;

        # Execute the code
        $ret = $VAL_ZERO;
        foreach my $cod (@{$act->[1]})
        { $cod->dump(0, $TRC.'Eval code value: ') if $slf->{'trc'};
          $ret = $cod->eval_value(1);
        }
        $ret->dump(0, $TRC.'Eval code result: ') if $slf->{'trc'};

        # Determine next action
        last if $slf->{'-end'};
        if ($ret = $ret->eval_as_number)
        { $cur = $slf->_end_block($ret, '*** Code close block ') if $ret > 0;
          last;
        }
      }
      elsif ($typ eq 'E')  # --- Block end
      { next unless $slf->{'lin'} =~ $act->[1];

        # Close the current block
        $slf->{'-kpt'} = $cur->{'llp'};
        $cur = $slf->_end_block($act->[2], '*** Close block ');
        last;
      }
      elsif ($typ eq 'P')  # --- Pattern group
      { my ($cod, $pat, $ret, @tbl);

        # Check the pattern and execute corresponding code
        $ret = $VAL_ZERO;
        @tbl = @{$act->[1]};
        while (($pat, $cod) = splice(@tbl, 0, 2))
        { $cur->{'-hit'} = [$slf->{'lin'} =~ $pat]; 
          next unless scalar(@{$cur->{'-hit'}});
          $cod->dump(0, $TRC.'Eval pattern code value: ') if $slf->{'trc'};
          $ret = $cod->eval_value(1);
          last;
        }
        $ret->dump(0, $TRC.'Eval pattern code result: ') if $slf->{'trc'};

        # Determine next action
        last if $slf->{'-end'};
        if ($ret = $ret->eval_as_number)
        { $cur = $slf->_end_block($ret, '*** Pattern close block ') if $ret > 0;
          last;
        }
      }
    }

    # Get the next line
    $slf->{'lin'} = $slf->_get_line($buf) unless $slf->{'-kpt'};
    $slf->{'-kpt'} = 0;
  }

  # Close open blocks
  $slf->_end_block(-1, '*** EOF close block ');

  # Indicate a successful completion
  0;
}

=head2 S<$h-E<gt>quit>

This method indicates that the parser must terminate file processing. Open
blocks are closed.

=cut

sub quit
{ my $slf = shift;

  $slf->{'lin'} = undef;
  $slf->{'-kpt'} = 1;
  $slf->{'-end'} = -1;
}

=head2 S<$h-E<gt>set_marker($str)>

This method specifies a new block marker and returns it.

=cut

sub set_marker
{ my ($slf, $str) = @_;

  $str = '' unless defined($str);
  $slf->{'-cur'}->{'-mrk'} =
    $slf->{'-inp'}->input_line_number.'|'.$slf->{'-inp'}->tell.':'.$str;
}

=head1 PARSER CONFIGURATION METHODS

=head2 S<$h-E<gt>add_begin($name,$pattern,$next[,$grp]])>

This method adds a conditional block start action to the action list of the
specified block. When you specify a group, all begin actions belonging to that
group are used as auto close conditions in the next block.

=cut

sub add_begin
{ my ($slf, $nam, $pat, $nxt, $grp) = @_;
  my $blk;
 
  return 1 unless ref($blk = $slf->_get_block($nam));
  return 2 unless $pat;
  $pat = ($pat =~ s/\#i$//) ? qr#$pat#i : qr#$pat#;
  return 3 unless $slf->_val_block($nxt);
  return 4 if $grp && $grp =~ /\W/;
  push(@{$blk->{'-pgm'}}, ['B', $pat, $nxt, $grp]);

  # Indicate a successful completion
  0;
}

=head2 S<$h-E<gt>add_code($block,code,...)>

This method adds a code list to the action list of the specified block.

=cut

sub add_code
{ my $slf = shift;
  my $nam = shift;
  my ($blk, @tbl);
 
  return 1 unless ref($blk = $slf->_get_block($nam));
  @tbl = grep {ref($_) eq 'RDA::Value'} @_;
  push(@{$blk->{'-pgm'}}, ['C', [@tbl]]) if scalar(@tbl);

  # Indicate a successful completion
  0;
}

=head2 S<$h-E<gt>add_end($name,$pattern)>

This method adds a conditional block end action to the action list of the
specified block.

=cut

sub add_end
{ my ($slf, $nam, $pat, $nxt, $grp) = @_;
  my $blk;
 
  return 1 unless ref($blk = $slf->_get_block($nam));
  return 2 unless $pat;
  $pat = ($pat =~ s/\#i$//) ? qr#$pat#i : qr#$pat#;
  push(@{$blk->{'-pgm'}}, ['E', $pat, 1]);

  # Indicate a successful completion
  0;
}

=head2 S<$h-E<gt>add_pattern($name,$pattern,code,...)>

This method adds a pattern list to the action list of the specified block.

=cut

sub add_pattern
{ my $slf = shift;
  my $nam = shift;
  my ($blk, $pat, $cod, @tbl);
 
  return 1 unless ref($blk = $slf->_get_block($nam));
  while (($pat, $cod) = splice(@_, 0, 2))
  { next unless ref($pat) eq 'RDA::Value' && ref($cod) eq 'RDA::Value';
    $pat = $pat->eval_as_string;
    $pat = ($pat =~ s/\#i$//) ? qr#$pat#i : qr#$pat#;
    push(@tbl, $pat, $cod);
  }
  return 2 unless scalar(@tbl);
  push(@{$blk->{'-pgm'}}, ['P', [@tbl]]);

  # Indicate a successful completion
  0;
}

=head2 S<$h-E<gt>reset>

This method resets the parser. It returns the reference of the parser object.

=cut

sub reset
{ my ($slf, $trc) = @_;
 
  # Reset the block definitions
  $slf->{'-blk'} = {};
  $slf->_get_block('TOP', $slf);

  # Define some global attributes
  $slf->{'esc'} = '';
  $slf->{'fmt'} = undef;
  $slf->{'ini'} = '';
  $slf->{'ltr'} = 0;
  $slf->{'rtr'} = 1;
  $slf->{'trc'} = $trc ? 1 : 0;

  # Return the parser object reference
  $slf;
}

=head2 S<$h-E<gt>set_info($name,$key[,value])>

This method assigns the value to the given block key. It does not evaluate the
value for code attributes. Otherwise, it evaluates the value as a scalar and
executes code values. When the value is omitted, it deletes the block
attribute.

It returns the previous value.

=cut

sub set_info
{ my ($slf, $nam, $key, $val) = @_;
  my ($blk, $old);
 
  if ($key && ref($blk = $slf->_get_block($nam)))
  { if ($tb_cod{$key})
    { $old = (exists($blk->{$key}) && ref($blk->{$key}) eq 'RDA::Value')
        ? $blk->{$key}
        : $VAL_UNDEF;
      $blk->{$key} = (ref($val) eq 'RDA::Value') ? $val : undef;
    }
    else
    { $old = exists($blk->{$key}) ? RDA::Value->new('T', $blk->{$key})
        : $VAL_UNDEF;
      if (ref($val) eq 'RDA::Value')
      { $blk->{$key} = $val->eval_as_scalar;
      }
      else
      { delete($blk->{$key});
      }
    }
  }
  $old;
}

=head2 S<$h-E<gt>set_line($line)>

This method replaces the current line by the specified value. It returns the
previous value.

=cut

sub set_line
{ my ($slf, $lin) = @_;

  ($slf->{'lin'}, $lin) = ($lin, $slf->{'lin'});
  $slf->{'var'}->assign_value(RDA::Value->new('T', $slf->{'lin'}));
  $lin;
}

# --- Internal block functions ------------------------------------------------

# Begin one or more blocks
sub _beg_block
{ my ($slf, $nxt, $msg, $grp) = @_;
  my $cur;

  $cur = $slf->{'-cur'};
  foreach my $nam (split(/\//, $nxt))
  { print $TRC.$msg.$nam."\n" if $slf->{'trc'};

    # Open the new block
    $cur = $slf->_set_block($nam, $cur, $grp);

    # Execute the begin code
    $cur->{'beg'}->eval_value(1) if ref($cur->{'beg'});
  }
  $slf->{'-cur'} = $cur;
}

# Dump a block
sub _dump_block
{ my ($blk, $pre) = @_;
  my $val;

  print $pre."Block ".$blk->{'-nam'}."\n";
  foreach my $key (sort keys(%$blk))
  { $val = $blk->{$key};
    if (ref($val) eq 'RDA::Value')
    { $val->dump(1,"* $key=");
    }
    elsif (ref($val) eq 'ARRAY')
    { next unless $key eq '-pgm';
      print "  * -pgm:\n";
      foreach my $act (@$val)
      { _dump_action($act);
      }
    }
    elsif (defined($val))
    { print "  * $key = $val\n";
    }
    else
    { print "  * $key\n";
    }
  }
}

sub _dump_action
{ my ($act, $str) = @_;

  print "$str:\n" if $str;
  print "    $act: [";
  foreach my $arg (@$act)
  { if (ref($arg) eq 'ARRAY')
    { print "[\n";
      foreach my $det (@$arg)
      { if (ref($det) eq 'RDA::Value')
        { $det->dump(3);
        }
        else
        { print "      $det\n";
        }
      }
      print "      ]\n    ";
    }
    elsif (defined($arg))
    { print $arg.' ';
    }
    else
    { print '*undef* ';
    }
  }
  print "]\n";
}

# End one or more blocks
sub _end_block
{ my ($slf, $lvl, $msg) = @_;
  my ($cur, $flg);

  $cur = $slf->{'-cur'};
  while ($lvl < 0 || (exists($cur->{'-par'}) && $lvl-- > 0))
  { print $TRC.$msg.$cur->{'-nam'}."\n" if $slf->{'trc'};

    # Execute the end code
    $cur->{'end'}->eval_value(1) if ref($cur->{'end'});
 
    # Return to the parent block
    last unless exists($cur->{'-par'});
    $slf->{'-cur'} = $cur = $cur->{'-par'};
    print $TRC."--> Back in block ".$cur->{'-nam'}."\n" if $slf->{'trc'};
  }
  $cur;
}

# Get a block and create it on first use
sub _get_block
{ my ($slf, $nam, $blk) = @_;
 
  # Return a reference when the block already exists
  return $slf->{'-blk'}->{$nam} if exists($slf->{'-blk'}->{$nam});

  # Validate the name
  return undef unless $nam && $nam =~ m/^\w+$/;

  # Create it
  $blk = {} unless ref($blk);
  $slf->{'-blk'}->{$nam} = $blk;

  $blk->{'beg'} = undef;
  $blk->{'buf'} = 0;
  $blk->{'end'} = undef;
  $blk->{'flp'} = 1;
  $blk->{'llp'} = 1;
  $blk->{'max'} = 0;
  $blk->{'par'} = 1;
  $blk->{'var'} = undef;

  $blk->{'-nam'} = $nam;
  $blk->{'-pgm'} = [];

  # Return the block reference
  $blk;
}

# Define a runtime block
sub _set_block
{ my ($slf, $ref, $par, $grp) = @_;
  my ($blk);

  # Get the reference block definition
  $ref = $slf->_get_block($ref) unless ref($ref);

  # Create the runtime block
  $blk = {};

  foreach my $key (qw(beg buf cnt end flp llp max par -nam))
  { $blk->{$key} = $ref->{$key} if exists($ref->{$key});
  }

  $blk->{'-buf'} = [];
  $blk->{'-cnt'} = 0;
  $blk->{'-mrk'} = undef;
  $blk->{'-pgm'} = [];

  # Inherit parent information
  if (ref($par))
  { $blk->{'-par'} = $par;
    if ($grp && $ref->{'par'})
    { # Extract parent actions 
      foreach my $act (@{$par->{'-pgm'}})
      { push(@{$blk->{'-pgm'}}, ['A', $act->[1], $act->[2] + 1])
          if $act->[0] eq 'A' || $act->[0] eq 'E';
        push(@{$blk->{'-pgm'}}, ['A', $act->[1], 1, $act->[2], $act->[3]])
          if $act->[0] eq 'B' && $act->[3] eq $grp;
      }
     
      # Get parent attributes
      foreach my $key (qw(fmt ltr rtr))
      { $blk->{$key} = $par->{$key} unless exists($blk->{$key});
      }
    }
  }

  # Get the block change patterns
  push(@{$blk->{'-pgm'}}, @{$ref->{'-pgm'}});

  # Return the block reference
  $blk;
}

# Validate a block list
sub _val_block
{ my ($slf, $nxt) = @_;

  return 0 unless $nxt;
  foreach my $nam (split(/\//, $nxt))
  { return 0 unless ref($slf->_get_block($nam));
  }
  1; 
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>, L<RDA::Block|RDA::Block>,
L<RDA::Value|RDA::Value>,
L<RDA::Object::Buffer|RDA::Object::Buffer>,
L<RDA::Object::Data|RDA::Object::Data>,
L<RDA::Object::Html|RDA::Object::Html>,
L<RDA::Object::Request|RDA::Object::Request>,
L<RDA::Object::Response|RDA::Object::Response>,
L<RDA::Object::Sgml|RDA::Object::Sgml>,
L<RDA::Object::UsrAgent|RDA::Object::UsrAgent>,
L<RDA::Object::Xml|RDA::Object::Xml>,
L<RDA::Macro::Buffer|RDA::Macro::Buffer>

=head1 COPYRIGHT NOTICE

Copyright (c) 2002-2009, Oracle. All rights reserved.

=head1 TRADEMARK NOTICE

Oracle, JD Edwards, PeopleSoft, and Siebel are registered trademarks of Oracle
Corporation and/or its affiliates. Other names may be trademarks of their
respective owners.

=cut