# Buffer.pm: Class Used for Buffer Macros

package RDA::Library::Buffer;

# $Id: Buffer.pm,v 1.32 2015/11/13 15:58:10 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Library/Buffer.pm,v 1.32 2015/11/13 15:58:10 RDA Exp $
#
# Change History
# 20151110  MSC  Improve the documentation.

=head1 NAME

RDA::Library::Buffer - Class Used for Buffer Macros

=head1 SYNOPSIS

 require RDA::Library::Buffer;

=head1 DESCRIPTION

The objects of the C<RDA::Library::Buffer> class are used to interface with
buffer-related macros.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use IO::File;
  use RDA::Text qw(get_string);
  use RDA::Agent qw($RE_OID);
  use RDA::Driver::Archive;
  use RDA::Driver::Library;
  use RDA::Handle::Block;
  use RDA::Handle::Data;
  use RDA::Object;
  use RDA::Object::Buffer;
  use RDA::Object::Index;
  use RDA::Object::Message;
  use RDA::Object::Parser;
  use RDA::Object::Rda;
  use RDA::Object::View;
  use RDA::Object::Xml;
  use RDA::SDCL::Value qw($VALUE);
  use RDA::Value::Assoc qw(new_from_data);
  use RDA::Value::List;
  use RDA::Value::Scalar qw(:value new_number new_text);
}

# Define the global public variables
use vars qw($STRINGS $SUSPEND $VERSION @ISA);
$SUSPEND = {
  _buf => sub {return {}},
  _dep => sub {return {}},
  _idx => undef,
  _prs => sub {return RDA::Object::Parser->new($_[0]->{'_trc'})},
  _vir => undef,
  };
$VERSION = sprintf('%d.%02d', q$Revision: 1.32 $ =~ /(\d+)\.(\d+)/);
@ISA     = qw(RDA::Driver::Library Exporter);

# Define the global private constants
my $RPT = qr/^RDA::Object::(Pipe|Report)$/i;
my $XML = 'RDA::Object::Xml';

# Define the global private variables
my %tb_fct = (
  'asBuffer'          => [\&_m_as_buffer,     'O'],
  'asIndex'           => [\&_m_as_index,      'O'],
  'countBuffer'       => [\&_m_count,         'L'],
  'createBuffer'      => [\&_m_create,        'N'],
  'deleteBuffer'      => [\&_m_delete,        'N'],
  'diveIndex'         => [\&_m_dive_index,    'O'],
  'extractFiles'      => [\&_m_extract       ,'N'],
  'filterBuffer'      => [\&_m_filter,        'N'],
  'getBufferLine'     => [\&_m_get_line,      'T'],
  'getBufferLines'    => [\&_m_get_lines,     'L'],
  'getBytes'          => [\&_m_get_bytes,     'T'],
  'getCollectedFiles' => [\&_m_get_collected, 'L'],
  'getExtraArchives'  => [\&_m_get_extra_arc, 'L'],
  'getExtraFiles'     => [\&_m_get_extra_fil, 'L'],
  'getLastContent'    => [\&_m_get_last,      'L'],
  'getLine'           => [\&_m_get_line,      'T'],
  'getPos'            => [\&_m_get_pos,       'N'],
  'getPredictions'    => [\&_m_predict,       'L'],
  'getPrefix'         => [\&_m_get_prefix,    'T'],
  'getPrefixes'       => [\&_m_get_prefixes,  'L'],
  'getResultFiles'    => [\&_m_get_files,     'L'],
  'getResultGroups'   => [\&_m_get_groups,    'L'],
  'getResultReports'  => [\&_m_get_reports,   'X'],
  'grepBuffer'        => [\&_m_grep,          'L'],
  'hasBuffer'         => [\&_m_has_buffer,    'N'],
  'hasRda'            => [\&_m_has_rda,       'N'],
  'inputLine'         => [\&_m_input,         'N'],
  'isArchived'        => [\&_m_is_archived,   'T'],
  'loadIndex'         => [\&_m_load_index,    'O'],
  'loadResultBundle'  => [\&_m_load_bundle,   'O'],
  'loadResultReport'  => [\&_m_load_report,   'O'],
  'parse'             => [\&_m_parse,         'N'],
  'parseBegin'        => [\&_m_parse_beg,     'N'],
  'parseBuffer'       => [\&_m_parse_buf,     'L'],
  'parseCode'         => [\&_m_parse_code,    'X'],
  'parseCount'        => [\&_m_parse_cnt,     'N'],
  'parseEnd'          => [\&_m_parse_end,     'N'],
  'parseHit'          => [\&_m_parse_hit,     'T'],
  'parseInfo'         => [\&_m_parse_info,    'X'],
  'parseKeep'         => [\&_m_parse_keep,    'N'],
  'parseLast'         => [\&_m_parse_last,    'T'],
  'parseLine'         => [\&_m_parse_line,    'T'],
  'parseMarker'       => [\&_m_parse_mark,    'T'],
  'parsePattern'      => [\&_m_parse_pat,     'X'],
  'parseReplace'      => [\&_m_parse_repl,    'T'],
  'parseReset'        => [\&_m_parse_init,    'N'],
  'parseQuit'         => [\&_m_parse_quit,    'N'],
  'riseIndex'         => [\&_m_rise_index,    'O'],
  'selectIndex'       => [\&_m_select_index,  'O'],
  'selectResult'      => [\&_m_select_result, 'O'],
  'setHandle'         => [\&_m_set_handle,    'T'],
  'setLastPattern'    => [\&_m_set_last,      'T'],
  'setPos'            => [\&_m_setpos,        'N'],
  'writeBuffer'       => [\&_m_write,         'N'],
  );

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

=head2 S<$h = RDA::Library::Buffer-E<gt>new($driver,$collector)>

The object constructor. It takes the library driver and collector references as
arguments.

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

=over 12

=item S<    B<'_agt'> > Reference to the agent object

=item S<    B<'_buf'> > Buffer hash

=item S<    B<'_col'> > Reference to the collector object

=item S<    B<'_dep'> > Buffer dependency hash

=item S<    B<'_idx'> > Reference to the current index object

=item S<    B<'_prs'> > Reference to the parser object

=item S<    B<'_trc'> > Parser trace indicator

=item S<    B<'_vir'> > Reference to the current virtual view object

=item S<    B<'_xml'> > XML trace indicator

=back

Internal keys are prefixed by an underscore.

=cut

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

  # Create the macro object
  $slf = bless {
    _buf => {},
    _dep => {},
    _prv => [],
    _sys => $col->get_agent->get_system,
    }, ref($cls) || $cls;

  # Register the macros
  $drv->register($slf, [keys(%tb_fct)], qw(refresh reset suspend));

  # Return the object reference
  return refresh($slf, $col);
}

=head2 S<$h-E<gt>call($name,...)>

This method executes the macro code.

=cut

sub call
{ my ($slf, $nam, @arg) = @_;

  return &{$tb_fct{$nam}->[0]}($slf, @arg);
}

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

This method deletes the library control object.

=cut

sub delete_object  ## no critic (Unpack)
{ RDA::Object::dump_caller($_[0], 'Library') if $RDA::Object::DELETE;

  # Close all buffers
  foreach my $buf (values(%{$_[0]->{'_buf'}}))
  { $buf->close;
  }

  # Delete the current index
  $_[0]->{'_idx'}->delete_object if exists($_[0]->{'_idx'});

  # Delete the object
  undef %{$_[0]};
  undef $_[0];
  return;
}

sub _delete_index
{ my ($slf) = @_;

  $slf->{'_dep'} = {};
  $slf->{'_sys'}->set_virtual if delete($slf->{'_vir'});
  delete($slf->{'_idx'})->delete_object if exists($slf->{'_idx'});
  return;
}

=head2 S<$h-E<gt>refresh($col)>

This method updates the library control object for a new collector.

=cut

sub refresh
{ my ($slf, $col) = @_;

  $slf->{'_agt'} = $col->get_agent;
  $slf->{'_col'} = $col;
  $slf->{'_prs'} = RDA::Object::Parser->new(
    $slf->{'_trc'} = $col->get_trace('PARSE'));
  $slf->{'_xml'} = $col->get_trace('XML');
  return $slf;
}

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

This method resets the library.

=cut

sub reset  ## no critic (Builtin)
{ my ($slf) = @_;

  foreach my $buf (values(%{$slf->{'_buf'}}))
  { $buf->close;
  }
  $slf->{'_buf'} = {};
  _delete_index($slf);
  return;
}

=head2 S<$h-E<gt>run($name,$arg,$ctx)>

This method runs the macro with the specified argument list in a given context.

=cut

sub run
{ my ($slf, $nam, $arg, $ctx) = @_;
  my ($fct, $ret, $typ);

  $fct = $tb_fct{$nam};
  $typ = $fct->[1];

  # Treat a native context
  return &{$fct->[0]}($slf, $ctx, $arg) if $typ eq 'X';

  # Treat an array context
  return RDA::Value::List::new_from_data(&{$fct->[0]}($slf, $ctx,
    $arg->eval_as_array)) if $typ eq 'L';

  # Treat a scalar context
  return defined($ret = &{$fct->[0]}($slf, $ctx, $arg->eval_as_array))
    ? RDA::Value::Scalar->new($typ, $ret)
    : $VAL_UNDEF;
}

=head1 BUFFER MACROS

=head2 S<asBuffer($name)>

This macro returns a reference to the buffer object when the specified buffer
exists. Otherwise, it returns an undefined value.

=cut

sub _m_as_buffer
{ my ($slf, $ctx, $nam) = @_;

  return (defined($nam) && exists($slf->{'_buf'}->{$nam}))
    ? $slf->{'_buf'}->{$nam}
    : undef;
}

=head2 S<countBuffer($name[,$re...])>

This macro returns the number of lines in the specified buffer. You can search
additional regular expressions also. It returns a list containing the
respective counters.

=cut

sub _m_count
{ my ($slf, $ctx, $nam, @arg) = @_;

  return () unless defined($nam) && exists($slf->{'_buf'}->{$nam});
  return $slf->{'_buf'}->{$nam}->count(@arg);
}

=head2 S<createBuffer($name,'A',$file[,$flag])>

This macro creates a new buffer with the content of the specified archive file
from the current result set. When the flag is set, it ignores the prefix. When
no virtual context is defined, it opens the file from the current result set in
read-only mode. On successful completion, it returns a true value. Otherwise,
it returns a false value.

=head2 S<createBuffer($name,'B',$tag)>

This macro creates a new buffer with the content of the collected block
identified by the specified tag. On successful completion, it returns a true
value. Otherwise, it returns a false value.

=head2 S<createBuffer($name,'F',$file)>

This macro loads the file in a new buffer. On successful completion, it
returns a true value. Otherwise, it returns a false value.

=head2 S<createBuffer($name,'H',$file[,$size])>

This macro creates a new buffer with the head of the specified file. By
default, it considers the first 64KiB. On successful completion, it returns a
true value. Otherwise, it returns a false value.

The buffer size will never exceed the file size. When the whole file is loaded,
it returns a negative value. Otherwise, it returns a positive value.

=head2 S<createBuffer($name,'O',$buffer)>

This macro associated the specified name to the buffer object reference
provided as an argument.

=head2 S<createBuffer($name,'R',$file)>

This macro opens the file in read-only mode. On successful completion, it
returns a true value. Otherwise, it returns a false value.

=head2 S<createBuffer($name,'S',$string)>

This macro creates a new buffer with the specified string. On successful
completion, it returns a true value. Otherwise, it returns a false value.

=head2 S<createBuffer($name,'T',$file[,$size])>

This macro creates a new buffer with the tail of the specified file. By
default, it considers the last 64KiB. On successful completion, it returns a
true value. Otherwise, it returns a false value.

The buffer size will never exceed the file size. When the whole file is loaded,
it returns a negative value. Otherwise, it returns a positive value.

=head2 S<createBuffer($name,'V',$file)>

This macro opens the file from the virtual context. When no virtual context is
defined, it opens the file from the current system in read-only mode. On
successful completion, it returns a true value. Otherwise, it returns a false
value.

=cut

sub _m_create  ## no critic (Complex)
{ my ($slf, $ctx, $nam, $typ, $arg, $max) = @_;

  if ($nam && $typ)
  { my ($blk, $mod, $obj);

    # Delete any previous buffer associated to this name
    delete($slf->{'_buf'}->{$nam})->close if exists($slf->{'_buf'}->{$nam});
    delete($slf->{'_dep'}->{$nam});

    # Create the new buffer
    $mod = uc($typ);
    if ($mod eq 'O')
    { $slf->{'_buf'}->{$nam} = $obj = $arg
        if ref($arg) eq 'RDA::Object::Buffer';
    }
    else
    { if ($mod eq 'A')
      { if (exists($slf->{'_idx'}))
        { $typ = ($mod eq $typ) ? 'B' : 'b';
          $arg = $slf->{'_idx'}->get_driver->find_handle($arg);
          $slf->{'_dep'}->{$nam} = $mod;
        }
        else
        { $typ = ($mod eq $typ) ? 'R' : 'r';
          $arg = RDA::Object::Rda->cat_file($ctx->get_collector->get_data(1),
            $arg) unless RDA::Object::Rda->is_absolute($arg);
        }
      }
      if ($mod eq 'B')
      { $arg = defined($blk = $ctx->get_output->find_block($arg))
          ? RDA::Handle::Block->new(RDA::Object::Rda->cat_file(
                $ctx->get_collector->get_dir($blk->[2]), $blk->[3]),
              $blk->[0], $blk->[1])
          : undef;
      }
      elsif ($mod eq 'V')
      { if (exists($slf->{'_idx'}))
        { $typ = ($mod eq $typ) ? 'B' : 'b';
          $arg = $slf->{'_idx'}->get_file($arg);
          $slf->{'_dep'}->{$nam} = $mod;
        }
        else
        { $typ = ($mod eq $typ) ? 'R' : 'r';
        }
      }
      $slf->{'_buf'}->{$nam} = $obj
        if defined($obj = RDA::Object::Buffer->new($typ, $arg, $max));
    }

    # Return the completion status
    return $obj->is_complete ? -1 : 1 if exists($slf->{'_buf'}->{$nam});
  }
  return 0;
}

=head2 S<deleteBuffer($name)>

This macro deletes the specified buffer.

=cut

sub _m_delete
{ my ($slf, $ctx, $nam) = @_;

  return unless defined($nam) && exists($slf->{'_buf'}->{$nam});
  delete($slf->{'_dep'}->{$nam});
  return delete($slf->{'_buf'}->{$nam})->close;
}


=head2 S<filterBuffer($name,$alt,$options[,$begin,$end,...])>

This macro replaces all strings that are delimited by one of the regular
expression pairs by the alternative text. The regular expressions should not
contain backtracking constructions. The following options are supported:

=over 9

=item B<    'i' > Ignores case distinctions in the patterns

=item B<    's' > Treats the buffer as a single line

=back

It returns the number of modifications.

This macro has no effect on read-only file buffers.

=cut

sub _m_filter
{ my ($slf, $ctx, $nam, @arg) = @_;

  return (defined($nam) && exists($slf->{'_buf'}->{$nam}))
    ? $slf->{'_buf'}->{$nam}->filter(@arg)
    : 0;
}

=head2 S<getBufferLine($name[,$skip])> or S<getLine($name[,$skip])>

This macro gets a line from the current position into the buffer. You can
specify the number of lines to skip as an extra argument. It returns an
undefined value if this is not possible.

=cut

sub _m_get_line
{ my ($slf, $ctx, $nam, $skp) = @_;

  return (defined($nam) && exists($slf->{'_buf'}->{$nam}))
    ? $slf->{'_buf'}->{$nam}->get_line($skp)
    : undef;
}

=head2 S<getBufferLines($name[,$flag])>

This macro returns all lines from the current position into the buffer. When
the flag is set, it starts from the beginning of the buffer. Otherwise, it
starts with the captured lines.

=cut

sub _m_get_lines
{ my ($slf, $ctx, $nam, $flg) = @_;

  return () unless defined($nam) && exists($slf->{'_buf'}->{$nam});
  return $slf->{'_buf'}->{$nam}->get_lines($flg)
}

=head2 S<getBytes($name,$size[,$skip])>

This macro gets the specified number of bytes from the current position into
the buffer. You can specify the number of bytes to skip as an extra
argument. It returns an undefined value if this is not possible.

=cut

sub _m_get_bytes
{ my ($slf, $ctx, $nam, $siz, $skp) = @_;
  my ($buf, $hnd);

  return unless defined($nam) && exists($slf->{'_buf'}->{$nam})
    && defined($siz);
  return q{} unless $siz > 0;  ## no critic (Unless)

  $hnd = $slf->{'_buf'}->{$nam}->get_handle;
  $hnd->seek($skp, 1) if defined($skp);
  $hnd->read($buf, $siz);
  return $buf;
}

=head2 S<getLastContent($name)>

This macro returns the last lines captured in the last C<grepBuffer>.

=cut

sub _m_get_last
{ my ($slf, $ctx, $nam) = @_;

  return () unless defined($nam) && exists($slf->{'_buf'}->{$nam});
  return $slf->{'_buf'}->{$nam}->get_last;
}

=head2 S<getPos($name)>

This macro returns a value that represents the current position in the
buffer. If this is not possible, it returns an undefined value.

=cut

sub _m_get_pos
{ my ($slf, $ctx, $nam) = @_;

  return (defined($nam) && exists($slf->{'_buf'}->{$nam}))
    ? $slf->{'_buf'}->{$nam}->get_pos
    : undef;
}

=head2 S<grepBuffer($name,$re[,$options[,$length[,$min,$max]]])>

This macro returns the lines that match the regular expression. The following
options are supported:

=for stopwords Bn Cn Fn

=over 9

=item B<    'c' > Returns the match count instead of the match list

=item B<    'f' > Stops scanning on the first match

=item B<    'i' > Ignores case distinctions in both the pattern and the file

=item B<    'j' > Joins continuation lines

=item B<    'n' > Prefixes lines with a line number

=item B<    'o' > Prefixes lines with the offset to the next line

=item B<    'r' > Does not restart from the beginning of the file

=item B<    'v' > Inverts the sense of matching to select non-matching lines

=item B<    'An'> Includes E<lt>nE<gt> lines of trailing context after matching
lines

=item B<    'Bn'> Includes E<lt>nE<gt> lines of leading context before matching
lines

=item B<    'Cn'> Includes E<lt>nE<gt> lines of output context

=item B<    'Fn'> Stops file scanning after E<lt>nE<gt> matching lines

=item B<    (n) > Returns the (n)th capture buffer instead of the line

=back

It is possible to limit the number of matched lines to the specified number.
For a positive number, it returns the first matches only. For a negative
number, it returns the last matches only, unless context lines are requested.

You can restrict search to a line range.

=cut

sub _m_grep
{ my ($slf, $ctx, $nam, $re, @arg) = @_;

  return () unless defined($nam) && exists($slf->{'_buf'}->{$nam}) && $re;
  return $slf->{'_buf'}->{$nam}->grep($re, @arg);
}

=head2 S<hasBuffer($name,...)>

This macro returns the first name from the argument list that corresponds to an
existing buffer. Otherwise it returns an undefined value.

=cut

sub _m_has_buffer
{ my ($slf, $ctx, @nam) = @_;

  foreach my $nam (@nam)
  { return $nam if defined($nam) && exists($slf->{'_buf'}->{$nam});
  }
  return;
}

=head2 S<inputLine($name[,$num])>

This macro returns the current input line number and takes an optional single
argument that, when given, sets the value. If you do not provide an argument,
the previous value is unchanged.

=cut

sub _m_input
{ my ($slf, $ctx, $nam, $num) = @_;

  return (defined($nam) && exists($slf->{'_buf'}->{$nam}))
    ? $slf->{'_buf'}->{$nam}->input_line($num)
    : undef;
}

=head2 S<setHandle($name,$key[,$value])>

This macro specifies a new value for the given handle property. It returns the
previous value.

=cut

sub _m_set_handle
{ my ($slf, $ctx, $nam, @inf) = @_;

  return (defined($nam) && exists($slf->{'_buf'}->{$nam}))
    ? $slf->{'_buf'}->{$nam}->set_handle(@inf)
    : undef;
}

=head2 S<setLastPattern($name[,$pattern])>

This macro sets a new pattern to clear the last line buffer. It returns the
previous value.

=cut

sub _m_set_last
{ my ($slf, $ctx, $nam, $pat) = @_;

  return (defined($nam) && exists($slf->{'_buf'}->{$nam}))
    ? $slf->{'_buf'}->{$nam}->set_last($pat)
    : undef;
}

=head2 S<setPos($name[,$pos])>

This macro uses the value of a previous C<getPos> call to return to a
previously visited position. When the position is omitted, it returns to the
beginning of the buffer.

It returns a true value on success and an undefined value on failure.

=cut

sub _m_setpos
{ my ($slf, $ctx, $nam, $pos) = @_;

  return (defined($nam) && exists($slf->{'_buf'}->{$nam}))
    ? $slf->{'_buf'}->{$nam}->set_pos($pos)
    : undef;
}

=head2 S<writeBuffer([$rpt,]$name[,$str])>

This macro writes the buffer content to the report file. When you specify an
extra argument, the macro takes it as the first line and continues from the
current buffer position. Otherwise, the whole buffer is written.

=cut

sub _m_write
{ my ($slf, $ctx, $arg, @arg) = @_;
  my ($rpt);

  return (ref($arg) =~ $RPT)       ? _s_write($slf, $ctx, $arg, @arg) :
         ($rpt = $ctx->get_report) ? _s_write($slf, $ctx, $rpt, $arg, @arg) :
                                     0;
}

sub _s_write
{ my ($slf, $ctx, $rpt, $nam, $str) = @_;
  my ($buf, $lin);

  if (exists($slf->{'_buf'}->{$nam}))
  { # Write the buffer to the report file, taking care on end-of-lines
    $buf = $slf->{'_buf'}->{$nam};
    $rpt->begin_block(1);
    if (defined ($str))
    { $rpt->write("$str\n");
    }
    else
    { $buf->set_pos;
    }
    while ($lin = $buf->get_line)
    { $lin =~ s/[\r\n]+$//;
      $lin = q{} if $lin =~ m/^\000*$/;
      $rpt->write("$lin\n");
    }
    $rpt->end_block;

    # Indicate the successful completion
    return 1;
  }
  return 0;
}

=head1 PARSER MACROS

=head2 S<parse($name[,$line])>

This macro parses the buffer content. You can specify a first line to parse
as an extra argument. It returns zero on successful completion. Otherwise,
it returns a nonzero value.

=cut

sub _m_parse
{ my ($slf, $ctx, $nam, $lin) = @_;

  return unless defined($nam) && exists($slf->{'_buf'}->{$nam});
  return $slf->{'_prs'}->parse($ctx, $slf->{'_buf'}->{$nam}, $lin);
}

=head2 S<parseBegin($block,$pattern,$next[,$group])>

This macro adds a conditional block start action to the action list of the
specified block. When a group is specified, all begin actions belonging to that
group are used as auto close conditions in the next block. It returns zero on
successful completion. Otherwise, it returns a nonzero value.

=cut

sub _m_parse_beg
{ my ($slf, $ctx, $blk, $pat, $nxt, $grp) = @_;

  return $slf->{'_prs'}->add_begin($blk,
    RDA::Object::View->is_pattern($pat, 'imsx', 1), $nxt, $grp);
}

=head2 S<parseBuffer()>

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

=cut

sub _m_parse_buf
{ return shift->{'_prs'}->get_buffer;
}

=head2 S<parseCode($name,code,...)>

This macro adds a code list to the action list of the specified block. It
returns zero on successful completion. Otherwise, it returns a nonzero value.

=cut

sub _m_parse_code
{ my ($slf, $ctx, $arg) = @_;
  my ($blk, $cod, $pat, @arg, @tbl);

  ($blk, @arg) = @{$arg};
  return new_number((ref($blk) && ($blk = $blk->eval_as_string))
    ? $slf->{'_prs'}->add_code($blk, @arg)
    : -1);
}

=head2 S<parseCount()>

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

=cut

sub _m_parse_cnt
{ return shift->{'_prs'}->get_count;
}

=head2 S<parseEnd($block,$pattern)>

This macro adds a conditional block end action to the action list of the
specified block. It returns zero on successful completion. Otherwise, it
returns a nonzero value.

=cut

sub _m_parse_end
{ my ($slf, $ctx, $blk, $pat) = @_;

  return $slf->{'_prs'}->add_end($blk,
    RDA::Object::View->is_pattern($pat, 'imsx', 1));
}

=head2 S<parseHit($offset)>

This macro retrieves a subexpression from the last pattern match or the number
of subexpressions when an argument is not provided.

=cut

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

  return $slf->{'_prs'}->get_hit($off);
}

=head2 S<parseInfo($block,$key[,value])>

This macro assigns the value to the given block key. It does not evaluate the
code attribute values. Otherwise, it evaluates the value as a scalar and
executes the code values. If you omit the value, the block attribute is
deleted. It returns the previous value.

=cut

sub _m_parse_info
{ my ($slf, $ctx, $arg) = @_;
  my ($blk, $key, $val) = @{$arg};

  return $VAL_UNDEF unless ref($blk) && ($blk = $blk->eval_as_string)
                        && ref($key) && ($key = $key->eval_as_string);
  $val = $slf->{'_prs'}->set_attr($blk, $key, $val);
  return (ref($val) =~ $VALUE) ? $val :
         defined($val)         ? new_text($val) :
                                 $VAL_UNDEF;
}

=head2 S<parseKeep()>

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

=cut

sub _m_parse_keep
{ return shift->{'_prs'}->keep;
}

=head2 S<parseLast()>

This macro gets the last block marker.

=cut

sub _m_parse_last
{ return shift->{'_prs'}->get_marker;
}

=head2 S<parseLine([$count])>

This macro 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 _m_parse_line
{ my ($slf, $ctx, $cnt) = @_;

  return $slf->{'_prs'}->get_line($cnt);
}

=head2 S<parseMarker([$str])>

This macro sets a new block marker.

=cut

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

  return $slf->{'_prs'}->set_marker($str);
}

=head2 S<parsePattern($name,$pattern,code,...)>

This macro adds a pattern list to the action list of the specified block. When
the action is executed, only the code associated to the first matching pattern
is executed. It returns zero on successful completion. Otherwise, it returns
a nonzero value.

=cut

sub _m_parse_pat
{ my ($slf, $ctx, $arg) = @_;
  my ($blk, $cod, $pat, @arg, @tbl);

  ($blk, @arg) = @{$arg};
  return new_number(-1)
    unless ref($blk) && ($blk = $blk->eval_as_string);
  while (($pat, $cod) = splice(@arg, 0, 2))
  { push(@tbl, RDA::Object::View->is_pattern($pat->eval_as_string), $cod)
      if ref($pat) =~ $VALUE && ref($cod) =~ $VALUE;
  }
  return new_number($slf->{'_prs'}->add_pattern($blk, @tbl));
}

=head2 S<parseReplace($line)>

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

=cut

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

  return $slf->{'_prs'}->set_line($lin);
}

=head2 S<parseReset()>

This macro resets the parser.

=cut

sub _m_parse_init
{ my ($slf) = @_;

  $slf->{'_prs'}->reset($slf->{'_trc'});
  return 0;
}

=head2 S<parseQuit()>

This macro indicates that the parser must terminate its file processing. It
closes open blocks.

=cut

sub _m_parse_quit
{ return shift->{'_prs'}->quit;
}

=head1 RESULT SET MACROS

=head2 S<asIndex()>

This macro returns a reference to the current index object when
defined. Otherwise, it returns an undefined value.

=cut

sub _m_as_index
{ my ($slf) = @_;

  return exists($slf->{'_idx'}) ? $slf->{'_idx'} : undef;
}

=head2 S<diveIndex($path[,$prefix])>

This macro allows to dive in a result set contains in an inner archive. It
returns a reference to the index object.

=cut

sub _m_dive_index
{ my ($slf, $ctx, $pth, $pre) = @_;
  my ($idx, $obj);

  return unless exists($slf->{'_idx'});

  # Close open buffers
  foreach my $nam (keys(%{$slf->{'_dep'}}))
  { delete($slf->{'_buf'}->{$nam})->close if exists($slf->{'_buf'}->{$nam});
  }

  # Dive in the archive
  $slf->{'_idx'}->dive($pth, $pre);
  $slf->{'_sys'}->set_virtual($slf->{'_vir'} = $obj)
    if ($obj = $slf->{'_idx'}->get_view);
  return $slf->{'_idx'};
}

=head2 extractFiles([$dir[,@itm]])>

This macro extracts the requested items to the specified directory, F<extract>
by default. It uses the RDA work directory as base for relative destination
directories. When the list of requested items is empty, it considers all
collected files.

Files and directories specified as items can contain wild cards. C<*> matches
any string, including the null string. C<?> matches any single
character. C<[...]> matches any one of the enclosed characters, which are taken
literally. When a path element starts with a C<.>, this character must be
matched explicitly.

It returns the number of extracted files.

=cut

sub _m_extract
{ my ($slf, $ctx, $dst, @itm) = @_;

  return () unless exists($slf->{'_idx'});
  return $slf->{'_idx'}->extract($dst, @itm);
}

=head2 S<getCollectedFiles([$pattern[,$level,@dir]])>

This macro returns the list of all files matching the specified pattern in the
specified directory structures. By default, it searches the files in the whole
directory structure.

When no pattern is specified, it returns all files entries from the directory.

The depth of the search is limited to the specified level or 20 by default.


=cut

sub _m_get_collected
{ my ($slf, $ctx, $pat, $lvl, @dir) = @_;

  return () unless exists($slf->{'_idx'});
  return $slf->{'_idx'}->find($pat, $lvl, @dir);
}

=head2 S<getExtraArchives()>

This macro returns the list of extra archives.

=cut

sub _m_get_extra_arc
{ my ($slf) = @_;

  return () unless exists($slf->{'_idx'});
  return $slf->{'_idx'}->get_driver->get_extra_archives;
}

=head2 S<getExtraFiles([$flag])>

This macro returns the list of extra files. When the flag is set, it regroups
the file per directory.

=cut

sub _m_get_extra_fil
{ my ($slf, $ctx, $flg) = @_;

  return () unless exists($slf->{'_idx'});
  return $slf->{'_idx'}->get_driver->get_extra_files($flg);
}

=head2 S<getPredictions([@itm])>

This macro returns the number of files and the accumulated file size that will
result from the extraction of the requested items. When the list of requested
items is empty, it considers all collected files.

Files and directories specified as items can contain wild cards. C<*> matches
any string, including the null string. C<?> matches any single
character. C<[...]> matches any one of the enclosed characters, which are taken
literally. When a path element starts with a C<.>, this character must be
matched explicitly.

=cut

sub _m_predict
{ my ($slf, $ctx, @itm) = @_;

  return () unless exists($slf->{'_idx'});
  return $slf->{'_idx'}->predict(@itm);
}

=head2 S<getPrefix()>

This macro returns the file prefix for the current index.

=cut

sub _m_get_prefix
{ my ($slf) = @_;

  return exists($slf->{'_idx'}) ? $slf->{'_idx'}->get_prefix : undef;
}

=head2 S<getPrefixes()>

This macro returns the list of other possible file prefixes.

=cut

sub _m_get_prefixes
{ my ($slf) = @_;

  return () unless exists($slf->{'_idx'});
  return $slf->{'_idx'}->get_prefixes;
}

=head2 S<getResultFiles($type)>

This macro returns the list of the module files from the specified type. It
supports the following types:

=over 9

=item B<    'D' > To get the metadata files

=item B<    'E' > To get the Explorer catalog files

=item B<    'I' > To get the index files

=back

=cut

sub _m_get_files
{ my ($slf, $ctx, $typ) = @_;

  return () unless exists($slf->{'_idx'});
  return $slf->{'_idx'}->get_driver->get_files($typ);
}

=head2 S<getResultGroups()>

This macro returns the list of all group prefixes.

=cut

sub _m_get_groups
{ my ($slf) = @_;

  return () unless exists($slf->{'_idx'});
  return $slf->{'_idx'}->get_driver->get_groups;
}

=head2 S<getResultReports()>

This macro returns a reference to a hash associating the reports with their
corresponding archive file. It returns an undefined value when there is no
current index.

=cut

sub _m_get_reports
{ my ($slf) = @_;

  return exists($slf->{'_idx'})
    ? RDA::Value::Assoc::new_from_data(
        %{$slf->{'_idx'}->get_driver->get_reports})
    : $VAL_UNDEF;
}

=head2 S<hasRda()>

This macro indicates whether the archive contains RDA results.

=cut

sub _m_has_rda
{ my ($slf) = @_;

  return exists($slf->{'_idx'}) ? $slf->{'_idx'}->get_driver->has_rda : 0;
}

=head2 S<isArchived([$zip])>

This macro indicates whether the results are archived.

=cut

sub _m_is_archived
{ my ($slf, $ctx, $zip) = @_;

  return defined($zip) || defined($zip = $ctx->get_agent('zip'))
    ? $zip
    : undef;
}

=head2 S<loadIndex($path[,$prefix[,$all]])>

This macro creates a result index based on the specified archive. It supports
C<zip> files or directories containing an expanded archive only. The second
argument allows to select a specific result set in an archive. Unless the third
argument is set, the index only considers files that has been collected
completely. It returns a reference to the archive object.

=cut

sub _m_load_index
{ my ($slf, $ctx, $pth, $pre, $all) = @_;
  my ($abs, $agt, $cfg, $cwd);

  return unless defined($pth);

  $agt = $ctx->get_agent;
  $cfg = $agt->get_config;
  if ($cfg->is_absolute($pth))
  { if (-d $pth)
    { return _create_index($agt, $abs, $pre, $all)
        if -r ($abs = $cfg->cat_dir($pth));
    }
    elsif (-f $pth)
    { return _create_index($agt, $abs, $pre, $all)
        if -r ($abs = $cfg->cat_file($pth));
    }
  }
  else
  { $cwd = $cfg->get_group('D_CWD');
    if (-d ($abs = $cfg->cat_dir($cwd, $pth)) ||
        -f ($abs = $cfg->cat_file($cwd, $pth)))
    { return _create_index($agt, $abs, $pre, $all)
        if -r $abs;
    }
  }
  die get_string('BAD_ZIP', $pth);
}

sub _create_index
{ my ($agt, $pth, $pre, $all) = @_;
  my ($ctl);

  $ctl = $agt->get_registry('WEB.ARC',
    \&RDA::Driver::Archive::new, 'RDA::Driver::Archive',  ## no critic (Call)
    $agt);
  $ctl = $ctl->add_archive($pth);
  $ctl->select($pre);
  return RDA::Object::Index->new($agt,
    'all' => $all ? 1 : 0,
    'ctl' => $ctl->get_current,
    'err' => 0,
    );
}

=head2 S<riseIndex()>

This macro returns to the previous context and adapts the archive context
accordingly.

=cut

sub _m_rise_index
{ my ($slf) = @_;
  my ($idx, $obj);

  return unless exists($slf->{'_idx'});

  # Close open buffers
  foreach my $nam (keys(%{$slf->{'_dep'}}))
  { delete($slf->{'_buf'}->{$nam})->close if exists($slf->{'_buf'}->{$nam});
  }

  # Rise in the archive
  $slf->{'_idx'}->rise;
  $slf->{'_sys'}->set_virtual($slf->{'_vir'} = $obj)
    if ($obj = $slf->{'_idx'}->get_view);
  return $slf->{'_idx'};
}

=head2 S<selectIndex([$path[,$prefix[,$all]]])>

When you specifies a path, this macro deletes any previous current index,
creates a new result index using the C<loadIndex> macro, and selects it as
current virtual context. It returns a reference to the index object.

Otherwise, it deletes any previous current index and returns an undefined
value.

=cut

sub _m_select_index
{ my ($slf, $ctx, $pth, $pre, $all) = @_;
  my ($idx, $obj);

  # Delete any previous index
  if (exists($slf->{'_idx'}))
  { foreach my $nam (keys(%{$slf->{'_dep'}}))
    { delete($slf->{'_buf'}->{$nam})->close if exists($slf->{'_buf'}->{$nam});
    }
    _delete_index($slf);
  }

  # Create and select a new index
  return unless defined($idx = _m_load_index($slf, $ctx, $pth, $pre, $all));
  $slf->{'_sys'}->set_virtual($slf->{'_vir'} = $obj)
    if ($obj = $idx->get_view);
  return $slf->{'_idx'} = $idx;
}

=head2 S<selectResult($prefix)>

This macro selects the result corresponding to the specified prefix and adapt
the index accordingly. When successful, it returns a reference to the index
object. Otherwise, it returns an undefined value.

=cut

sub _m_select_result
{ my ($slf, $ctx, $pre) = @_;
  my ($obj, $res);

  return unless exists($slf->{'_idx'});
  $res =  $slf->{'_idx'}->select($pre);
  $slf->{'_sys'}->set_virtual($slf->{'_vir'} = $obj)
    if ($obj = $slf->{'_idx'}->get_view);
  return $res;
}

=head1 XML LOAD MACROS

=head2 S<loadResultBundle($bundle[,$xml])>

This macro generates the specified XML bundle, parses it, and returns the
resulting XML object. You can specify a parser as an argument to control what
information is extracted.

It accepts a bundle name, a bundle definition array reference, or a hash
reference as the bundle argument. The hash supports the following keys:

=over 11

=item S<    B<'agt'> > When present, specifies the remote agent name.

=item S<    B<'bnd'> > Specifies the bundle name or definition.

=back

=cut

sub _m_load_bundle
{ my ($slf, $ctx, $nam, $xml) = @_;
  my ($agt, $dst, $ref);

  # Determine the bundle to generate
  $dst = q{.};
  $ref = ref($nam);
  $ref = ref($nam = $nam->eval_as_data(1))
    if $ref =~ m/^RDA::Value::(Array|Assoc|Hash|List)$/;
  if ($ref eq 'HASH')
  { $dst = $1 if defined($nam->{'agt'}) && $nam->{'agt'} =~ $RE_OID;
    $ref = ref($nam = $nam->{'bnd'});
  }
  $nam = undef if $ref && $ref ne 'ARRAY';

  # Produce the bundle and parse it
  $xml = RDA::Object::Xml->new($slf->{'_xml'}) unless ref($xml) eq $XML;
  if (defined($nam))
  { $agt = $slf->{'_agt'};
    $agt->abort if $agt->submit($dst,
      RDA::Object::Message->new('CONVERT.GEN_BUNDLE',
        _save   => {fct =>\&_load_data, arg => $xml},
        attach  => 1,
        (ref($nam) ? 'bundle'
                   : 'name')  => $nam,
        set     => exists($slf->{'_idx'}) ? $slf->{'_idx'}->get_id : undef,
        verbose => $slf->{'_xml'}))->is_error($agt);
  }
  return $xml;
}

=head2 S<loadResultReport($report[,$xml])>

This macro converts the specified report in XML, parses its XML representation,
and returns the resulting XML object. You can specify a parser as an argument
to control what information is extracted.

It accepts a report name, a report object reference, or a hash reference as the
report argument. The hash supports the following keys:

=over 11

=item S<    B<'agt'> > When present, specifies the remote agent name.

=item S<    B<'nam'> > Specifies the report name.

=item S<    B<'typ'> > When present, specifies the report type.

=back

=cut

sub _m_load_report
{ my ($slf, $ctx, $rpt, $xml) = @_;
  my ($agt, $dst, $ref, $typ);

  # Determine the report to convert
  $dst = q{.};
  $ref = ref($rpt);
  $ref = ref($rpt = $rpt->eval_as_data(1))
    if $ref =~ m/^RDA::Value::(Assoc|Hash)$/;
  if ($ref eq 'HASH')
  { $dst = $1 if defined($rpt->{'agt'}) && $rpt->{'agt'} =~ $RE_OID;
    $typ = $1 if defined($rpt->{'typ'}) && $rpt->{'typ'} =~ m/^([A-Z])$/;
    $rpt = $rpt->{'nam'}
  }
  elsif ($ref eq 'RDA::Object::Report')
  { $rpt->end;
    $typ = $rpt->get_info('dir');
    $rpt = $rpt->get_info('fil');
  }
  elsif ($ref)
  { $rpt = undef;
  }
  elsif (defined($rpt) && $rpt =~ s/^([A-Z])\|//)
  { $typ = $1;
  }

  # Perform the conversion and parse the conversion results
  $xml = RDA::Object::Xml->new($slf->{'_xml'}) unless ref($xml) eq $XML;
  if (defined($rpt))
  { $agt = $slf->{'_agt'};
    $agt->abort if $agt->submit($dst,
      RDA::Object::Message->new('CONVERT.GEN_XML',
        _save   => {fct =>\&_load_data, arg => $xml},
        attach  => 1,
        reports => $rpt,
        set     => exists($slf->{'_idx'}) ? $slf->{'_idx'}->get_id : undef,
        type    => $typ,
        verbose => $slf->{'_xml'}))->is_error($agt);
  }
  return $xml;
}

sub _load_data
{ my ($rsp, $arg) = @_;

  $arg->parse_file(RDA::Object::Buffer->new('B', RDA::Handle::Data->new($rsp)));
  return 0;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Driver::Archive|RDA::Driver::Archive>,
L<RDA::Driver::Library|RDA::Driver::Library>,
L<RDA::Handle::Block|RDA::Handle::Block>,
L<RDA::Handle::Data|RDA::Handle::Data>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Buffer|RDA::Object::Buffer>,
L<RDA::Object::Collect|RDA::Object::Collect>,
L<RDA::Object::Index|RDA::Object::Index>,
L<RDA::Object::Message|RDA::Object::Message>,
L<RDA::Object::Parser|RDA::Object::Parser>,
L<RDA::Object::Pipe|RDA::Object::Pipe>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Object::Report|RDA::Object::Report>,
L<RDA::Object::View|RDA::Object::View>,
L<RDA::Object::Xml|RDA::Object::Xml>,
L<RDA::SDCL::Block|RDA::SDCL::Block>,
L<RDA::SDCL::Value|RDA::SDCL::Value>,
L<RDA::Text|RDA::Text>,
L<RDA::Value::List|RDA::Value::List>,
L<RDA::Value::Scalar|RDA::Value::Scalar>

=head1 COPYRIGHT NOTICE

Copyright (c) 2002, 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