package RDA::Block;

# $Id: Block.pm,v 1.76 2008/03/07 15:49:17 mschenke Exp $
# ARCS: $Header: /home/cvs/repository/RDA_4/src/scripting/lib/RDA/Block.pm,v 1.76 2008/03/07 15:49:17 mschenke Exp $
#
# Change History
# 20080307  MSC  Only filter 'D' and 'R' dynamic names.

=head1 NAME

RDA::Block - Class Used for Objects to Execute Data Collection Specifications

=head1 SYNOPSIS

require RDA::Block;

=head1 DESCRIPTION

The objects of the C<RDA::Block> class are used to execute data collection
specifications.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use File::Spec;
  use IO::File;
  use RDA::Output;
  use RDA::Value;
}

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

# Define the global private constants
my $EXE_FCT = 0; # Execution function
my $GET_FCT = 1; # Parsing function
my $SUB_BLK = 2; # When not null, sub block type
my $TXT_BLK = 3; # 0 = code / 1 or function reference = text

my $SPC_FCT = 0; # Associated execution function
my $SPC_REF = 1; # Associated reference
my $SPC_VAL = 2; # Associated value
my $SPC_BLK = 3; # Associated code block
my $SPC_LIN = 4; # Source line
my $SPC_COD = 5; # Source code

my $CONT    = 0;
my $ERROR   = -1;
my $RET_RET = 1;
my $RET_BRK = 2;
my $RET_NXT = 3;

# Define the global private variables
my $re_nam = qr/^S(\d{3})([A-Z]\w*)$/i;
my %tb_cmd = (
  'append'   => [\&_exe_append,   \&_get_var_txt,  'T', \&_merge_txt],
  'break'    => [\&_exe_break,    \&_get_cond,     0,   0],
  'call'     => [\&_exe_call,     \&_get_call,     0,   0],
  'close'    => [\&_exe_close,    \&_get_none,     0,   0],
  'data'     => [\&_exe_data,     \&_get_report,   0,   0],
  'debug'    => [\&_exe_debug,    \&_get_list,     0,   0],
  'decr'     => [\&_exe_decr,     \&_get_incr,     0,   0],
  'delete'   => [\&_exe_delete,   \&_get_del_list, 0,   0],
  'die'      => [\&_exe_die,      \&_get_list,     0,   0],
  'echo'     => [\&_exe_echo,     \&_get_list,     0,   0],
  'else'     => [\&_exe_else,     \&_get_none,     'B', 0],
  'elsif'    => [\&_exe_elsif,    \&_get_cond,     'B', 0],
  'for'      => [\&_exe_for,      \&_get_for,      'L', 0],
  'if'       => [\&_exe_if,       \&_get_cond,     'B', 0],
  'import'   => [\&_exe_import,   \&_get_var_list, 0,   0],
  'incr'     => [\&_exe_incr,     \&_get_incr,     0,   0],
  'job'      => [\&_exe_job,      \&_get_none,     'B', 0],
  'keep'     => [\&_exe_keep,     \&_get_var_list, 0,   0],
  'loop'     => [\&_exe_loop,     \&_get_loop,     'L', 0],
  'macro'    => [\&_exe_macro,    \&_get_name,     'M', 0],
  'next'     => [\&_exe_next,     \&_get_cond,     0,   0],
  'output'   => [\&_exe_output,   \&_get_output,   0,   0],
  'prefix'   => [\&_exe_prefix,   \&_get_none,     'B', 0],
  'pretoc'   => [\&_exe_pretoc,   \&_get_list,     0,   0],
  'report'   => [\&_exe_report,   \&_get_report,   0,   0],
  'resume'   => [\&_exe_resume,   \&_get_name,     0,   0],
  'return'   => [\&_exe_return,   \&_get_value,    0,   0],
  'run'      => [\&_exe_run,      \&_get_run,      0,   0],
  'set'      => [\&_exe_var,      \&_get_var_txt,  'T', \&_merge_txt],
  'share'    => [\&_exe_share,    \&_get_list,     0,   0],
  'sleep'    => [\&_exe_sleep,    \&_get_value,    0,   0],
  'suspend'  => [\&_exe_suspend,  \&_get_name,     0,   0],
  'thread'   => [\&_exe_job,      \&_get_thread,   'B', 0],
  'toc'      => [\&_exe_toc,      \&_get_list,     0,   0],
  'unprefix' => [\&_exe_unprefix, \&_get_none,     0,   0],
  'unpretoc' => [\&_exe_unpretoc, \&_get_value,    0,   0],
  'var'      => [\&_exe_var,      \&_get_var_def,  0,   0],
  'wait'     => [\&_exe_wait,     \&_get_none,     0,   0],
  'while'    => [\&_exe_while,    \&_get_cond,     'L', 0],
  'write'    => [\&_exe_write,    \&_get_list,     0,   0],
  );
my %tb_fct = (
  'findShares'    => \&_m_findShares,
  'getFile'       => \&_m_getFile,
  'getOutputPid'  => \&_m_getOutputPid,
  'getShare'      => \&_m_getShare,
  'getToc'        => \&_m_getToc,
  'hasOutput'     => \&_m_hasOutput,
  'inThread'      => \&_m_inThread,
  'isCreated'     => \&_m_isCreated,
  'isFiltered'    => \&_m_isFiltered,
  'isImplemented' => \&_m_isImplemented,
  'isRendered'    => \&_m_isRendered,
  'isTocCreated'  => \&_m_isTocCreated,
  'lock'          => \&_m_lock,
  'renderFile'    => \&_m_renderFile,
  'setAbbr'       => \&_m_setAbbr,
  'setDebug'      => \&_m_setDebug,
  'setShare'      => \&_m_setShare,
  'setTrace'      => \&_m_setTrace,
  'slock'         => \&_m_slock,
  'testOutput'    => \&_m_testOutput,
  'unlock'        => \&_m_unlock,
  );

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

=head2 S<$h = RDA::Block-E<gt>new($nam,$dir,$agt)>

The object constructor. It takes the module name, module directory, and the
agent reference as arguments.

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

=over 16

=item B<    '_abr'     > Module abbreviation

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

=item B<    '_alt'     > Alternative file name list object

=item B<    '_bas'     > Maximum length of the report basename

=item B<    '_cas'     > Indicates a case sensitive context

=item B<    '_chl'     > List of children

=item B<    '_cnt'     > Thread counter

=item B<    '_cod'     > Associated code block

=item B<    '_ctl'     > Output control object

=item B<    '_ctx'     > Current execution context

=item B<    '_dbg'     > Debug flag

=item B<    '_dir'     > Module directory

=item B<    '_err'     > Number of parsing errors

=item B<    '_evl'     > Eval indicator

=item B<    '_flg'     > Last condition

=item B<    '_flt'     > Output filtering sequence

=item B<    '_glb'     > Hash that contains the list of variables to keep

=item B<    '_grp'     > Report group

=item B<    '_lib'     > Hash that contains the macro definitions

=item B<    '_lin'     > Current line number in the specification file

=item B<    '_loc'     > Hash that contains local definitions

=item B<    '_lst'     > Last specification executed

=item B<    '_lvl'     > Code block level

=item B<    '_nam'     > Module name

=item B<    '_opn'     > Hash that contains open output file objects

=item B<    '_out'     > Output file object

=item B<    '_par'     > Reference to the parent object

=item B<    '_pid'     > Process identifier list

=item B<    '_pre'     > Trace prefix

=item B<    '_rda'     > RDA version number

=item B<    '_ret'     > Return code of the last command

=item B<    '_rnd'     > Direct report rendering indicator

=item B<    '_rpt'     > Report directory

=item B<    '_stk'     > Recursivity stack

=item B<    '_thr'     > Thread indicator

=item B<    '_toc'     > Table of Content object

=item B<    '_top'     > Reference to the top object

=item B<    '_trc'     > Trace flag

=item B<    '_typ'     > Associated code block type

=item B<    '_val'     > Last value

=item B<    '_var'     > Hash that contains all variable definitions

=item B<    '_ver'     > Specification version number

=back

Internal keys are prefixed by an underscore.

=cut

sub new
{ my $slf = shift;
  my $cls = ref($slf) || $slf;
  my $nam = shift;
  my $dir = shift;
  my $agt = shift;

  # Create the data collection object
  $slf = bless {_nam => $nam}, $cls;

  # Get some setup information
  $slf->{'_cnt'} = 0;
  $slf->{'_dir'} = $dir if defined($dir);
  $slf->{'_ver'} = 0;
  if (defined($agt))
  { $slf->{'_abr'} = ($nam =~ $re_nam) ? uc($2).'_' : '';
    $slf->{'_agt'} = $agt;
    $slf->{'_bas'} = $agt->get_setting('RDA_BASENAME', 38);
    $slf->{'_cas'} = $agt->get_setting('RDA_CASE',     1);
    $slf->{'_grp'} = $agt->get_setting('RPT_GROUP',    'RDA').'_';
    $slf->{'_pid'} = $agt->get_info('pid', []);
    $slf->{'_rda'} = $agt->get_setting('RDA_VERSION',  '');
    $slf->{'_rpt'} = $agt->get_setting('RPT_DIRECTORY', File::Spec->curdir);

    $slf->{'_ctl'} = $agt->output;
    $slf->{'_alt'} = $slf->{'_ctl'}->new('A', $slf);
    $slf->{'_flt'} = $slf->{'_ctl'}->is_filtered ? 1 : 0;
    $slf->{'_rnd'} = $slf->{'_ctl'}->is_rendered;
    $slf->{'_toc'} = $slf->{'_ctl'}->new('T', $slf);
  }
  else
  { $slf->{'_flt'} = $slf->{'_rnd'} = 0;
  }

  # Return the object reference
  $slf;
}

=head2 S<$h-E<gt>chk_trace($level)>

This method indicates if the current trace level is equal to or higher than
the level specified by the argument.

=cut

sub chk_trace
{ my ($slf, $lvl) = @_;

  $slf->get_top->{'_trc'} >= $lvl;
}

=head2 S<$h-E<gt>collect([$dbg[,$trc]])>

This method executes the data collection specifications. It returns a
completion status. Possible values are as follows:

=over 16

=item B<     0  > Successful completion

=item B<    -1  > Execution error

=back

When the script is complete, it closes output files automatically.

=cut

sub collect
{ my ($slf, $dbg, $trc) = @_;

  # Abort when not called on a top code block
  return $ERROR unless $slf == $slf->{'_top'};

  # Initialize the code block
  delete($slf->{'_out'});
  $slf->{'_cnt'} = 0;
  $slf->{'_dbg'} = $slf->{'_rnd'} ? 0 : $dbg || 0;
  $slf->{'_evl'} = 0;
  $slf->{'_glb'} = {};
  $slf->{'_opn'} = {};
  $slf->{'_thr'} = 0;
  $slf->{'_pre'} = 'TRACE/';
  $slf->{'_trc'} = $slf->{'_rnd'} ? 0 : $trc || 0;
  $slf->{'_var'} = {};

  # Initialize the macro list
  $slf->{'_lib'} = {};
  $slf->{'_agt'}->get_macros($slf->{'_lib'});
  map {$slf->{'_lib'}->{$_} = $slf} keys(%tb_fct);

  # Execute the associated code block
  my $ret = $slf->run;

  # Close the output files
  $slf->_close_all(1);

  # Remove lock files
  eval {
    require RDA::Lock;
    RDA::Lock::end($slf->{'_agt'});
  };

  # Return the completion status
  ref($ret) ? 0 : $ret;
}

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

  if ($flg && exists($slf->{'_alt'}))
  { $slf->{'_alt'}->close;
    delete($slf->{'_alt'});
  }
  if (exists($slf->{'_toc'}))
  { $slf->{'_toc'}->close;
    delete($slf->{'_toc'});
  }
  if (exists($slf->{'_out'}))
  { $slf->{'_out'}->close;
    delete($slf->{'_out'});
  }
  foreach my $out (values(%{$slf->{'_opn'}}))
  { $out->close;
  }
  $slf->{'_opn'} = {};
}

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

This method deletes an object and all sub objects, thus handling circular
references.

=cut

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

  # Delete children
  if (exists($slf->{'_chl'}))
  { my $chl;
    while (defined($chl = pop(@{$slf->{'_chl'}})))
    { $chl->delete;
    }
    delete $slf->{'_chl'};
  }

  # Remove references to other objects and next delete the object
  delete $slf->{'_ctx'};
  delete $slf->{'_opn'};
  delete $slf->{'_out'};
  delete $slf->{'_par'};
  delete $slf->{'_top'};
  undef $slf;
}

=head2 S<$h-E<gt>eval($ctx,$par,$pre,$trc)>

This method evaluates the block in a dedicated context. You can specify the
trace prefix and level as arguments. It returns an error indicator.

=cut

sub eval
{ my ($slf, $ctx, $par, $pre, $trc) = @_;

  # Prepare the block for the execution
  $slf->{'_cnt'} = 0;
  $slf->{'_evl'} = 1;
  $slf->{'_glb'} = {};
  $slf->{'_lib'} = {%{$ctx->get_lib}};
  $slf->{'_loc'} = {};
  $slf->{'_par'} = $ctx if $par;
  $slf->{'_pre'} = $pre || 'TRACE/EVAL/';
  $slf->{'_stk'} = [];
  $slf->{'_thr'} = 1;
  $slf->{'_trc'} = $trc || 0;
  $slf->{'_val'} = $VAL_UNDEF;
  $slf->{'_var'} = {};

  # Execute the block and return an error indicator
  $slf->_exec == $ERROR;
}

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

This method returns the reference of the current execution context.

=cut

sub get_context
{ shift->{'_ctx'};
}

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

This method returns the reference of the variable dictionary that is associated
with the current execution context.

=cut

sub get_dict
{ shift->{'_ctx'}->{'_var'};
}

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

This method returns the file handle of the output file. It creates the file
on the first call. It also executes prefix blocks when present. It returns
C<undef> when there is an error.

=cut

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

  # Abort the data collection when no output file is available
  $slf = $slf->get_top;
  die "RDA-00201: Output file not specified\n" unless exists($slf->{'_out'});

  # Get the file handle
  $slf->{'_out'}->get_handle;
}

=head2 S<$h-E<gt>get_info($key[,$default])>

This method returns the value of the given object key. If the object key does
not exist, then it returns the default value.

=cut

sub get_info
{ my ($slf, $key, $val) = @_;

  $val = $slf->{$key} if exists($slf->{$key});
  $val;
}

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

This method returns the reference of the macro library.

=cut

sub get_lib
{ shift->{'_top'}->{'_lib'};
}

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

This method returns the reference of the parent object. When the object has
no parent, it returns C<undef>.

=cut

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

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

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

This method returns the prefix for tracing purpose.

=cut

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

  shift->get_top->{'_pre'}.$str;
}

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

This method returns the reference of the top object.

=cut

sub get_top
{ my $slf = shift->{'_top'};

  while (exists($slf->{'_par'}))
  { $slf = $slf->{'_par'}->{'_top'};
  }
  $slf;
}

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

This method returns the version number of the specifications.

=cut

sub get_version
{ shift->{'_ver'};
}

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

This method indicates whether the code belongs to a thread.

=cut

sub in_thread
{ shift->get_top->{'_thr'};
}

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

This method loads and parses the data collection specifications. The file name
is deduced from the object identifier by adding a C<.def> suffix to it.

=cut

sub load
{ my ($slf) = @_;
  my ($fil, $ifh);

  # Determine the data collection specification file
  $ifh = IO::File->new;
  $fil = File::Spec->catfile($slf->{'_dir'}, $slf->{'_nam'});

  # Load and parse the file
  $slf->parse(($ifh->open("<$fil.def") ||
               $ifh->open("<$fil.ctl")) ? $ifh : undef);
}

=head2 S<$h-E<gt>parse($ifh)>

This method parses the data collection specifications from the specified input
handle. It closes the specification file at the end of parsing.

=cut

sub parse
{ my ($slf, $ifh) = @_;
  my ($cmd, $buf, $cur, $lin, $par, $pod, $spc, $sub, $txt, $typ);

  # Create the top code block
  $slf->{'_cod'} = [];
  $slf->{'_ctx'} = $slf;
  $slf->{'_lvl'} = 0;
  $slf->{'_top'} = $slf;
  $slf->{'_typ'} = 'T';

  # Load and parse the file
  $slf->{'_lin'} = $slf->{'_err'} = 0;

  if ($ifh)
  { $lin = '';
    $pod = $sub = $txt = 0;
    $cur = $slf;
    $par = undef;
    while (defined($buf = $ifh->getline))
    { # Trim leading spaces
      $buf =~ s/^\s*//;
      $buf =~ s/[\r\n]+$//;
      $lin .= $buf;

      # Join continuation line
      $slf->{'_lin'}++;
      next if $lin =~ s/\\$//;
      $lin =~ s/\s+$//;

      # Ignore a documentation block
      if ($pod)
      { $pod = 0 if $lin =~ m/^=cut/;
        $lin = '';
        next;
      }
      if ($lin =~ m/^=[a-z]/)
      { $pod = 1;
        $lin = '';
        next;
      }

      # Detect and treat the beginning of a block
      if ($lin =~ s/^\{\s*//)
      { # Generate an error if a block is not expected
        $slf->gen_load_err("Invalid block start") unless $sub;

        # Do not limit the block to a single line
        $sub = 0;
      }

      # Treat the line
      if ($lin =~ m/^\}(\s*\#.*)?$/)
      { # Indicate that a code or text block must be closed
        if ($par)
        { $sub = 1;
        }
        else
        { $slf->gen_load_err("Invalid block end");
        }
      }
      elsif ($txt)
      { # Take all lines without other processing
        $lin =~ s/^["]//;
        push(@{$cur->[$SPC_VAL]}, $lin);
      }
      elsif ($lin =~ m/^(\w+)\s*(.*)$/)
      { # Treat a command
        if (exists($tb_cmd{$1}))
        { # Create the specification and parse the arguments
          $cmd = $tb_cmd{$1};
          $spc = [$cmd->[$EXE_FCT], undef, undef, undef, $slf->{'_lin'}, $lin];
          $lin = defined($2) ? $2 : '';
          eval {&{$cmd->[$GET_FCT]}($cur->{'_ctx'}, $spc, \$lin)};
          if ($@)
          { $slf->gen_load_err($@);
          }
          elsif ($lin !~ m/^(#.*)?$/)
          { $slf->gen_load_err("Invalid characters at end of line");
          }

          # Add the command in the current block
          push(@{$cur->{'_cod'}}, $spc);

          # Prepare the parsing of a sub block
          if ($typ = $cmd->[$SUB_BLK])
          { $par = $cur;
            if ($txt = $cmd->[$TXT_BLK])
            { $cur = $spc;
              $cur->[$SPC_VAL] = [];
            }
            else
            { $spc->[$SPC_BLK] = $cur = $cur->new;
              $cur->set_parent($par);
              $cur->{'_cod'} = [];
              $cur->{'_ctx'} = ($typ eq 'M') ? $cur : $par->{'_ctx'};
              $cur->{'_lvl'} = $par->{'_lvl'} + 1;
              $cur->{'_typ'} = $typ;
            }
            $sub = 2;
          }
        }
        else
        { $slf->gen_load_err("Invalid command '$1'");
        }
      }
      elsif ($lin !~ m/^#/ && $lin !~ m/^$/)
      { $slf->gen_load_err("Invalid specification");
      }
      elsif ($lin =~ m/\$Id\:\s+\S+\s+(\d+)(\.(\d+))?\s/)
      { $slf->{'_ver'} = sprintf('%d.%02d', $1, $3 || 0);
      }
      $lin = '';

      # Check of a sub block must be closed
      if ($sub > 0 && --$sub == 0)
      { # Perform the specified post treatment
        &$txt($slf, $cur) if ref($txt) eq 'CODE';

        # Return to the previous level
        $txt = 0;
        $cur = $par;
        $par = exists($cur->{'_par'}) ? $cur->{'_par'} : undef;
      }
    }
    $slf->gen_load_err("Missing block end") if $par;
    $ifh->close;
  }
  else
  { $slf->gen_load_err(
      "RDA-00260: Cannot open the specification file '".$slf->{'_nam'}."': $!");
  }

  # Delete the code tree when there are errors
  delete($slf->{'_cod'}) if $slf->{'_err'};

  # Returns the number of errors found
  $slf->{'_err'};
}

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

This method executes a data collection or macro code block. You can pass
arguments as a list value.

=cut

sub run
{ my ($slf, $nam, $arg, $ctx) = @_;
  my ($blk, $dic, $glb, $loc, $ptr);

  # Abort the run if the block is not appropriate
  return $ERROR unless $slf == $slf->{'_ctx'};

  # Execute internal macros
  return &{$tb_fct{$nam}}($slf, $ctx, $arg->eval_as_array)
    if $nam && exists($tb_fct{$nam});

  # Evalue the argument list before adjusting the context
  $arg = $arg->eval_value if ref($arg);

  # Manage recursivity calls
  $dic = $slf->{'_var'};
  $glb = $slf->{'_glb'};
  if (exists($slf->{'_stk'}))
  { push(@{$slf->{'_stk'}}, $slf->{'_loc'}) if exists($slf->{'_loc'});
    $slf->{'_loc'} = $loc = {};
    foreach my $nam (keys(%$dic))
    { $loc->{$nam} = delete($dic->{$nam}) unless exists($glb->{$nam});
    }
  }
  else
  { $slf->{'_stk'} = [];
    $slf->{'_loc'} = {} unless exists($slf->{'_loc'});
  }

  # Execute the associated code block
  $slf->{'_val'} = $VAL_UNDEF;
  $slf->{'_var'}->{'@arg'} = RDA::Value->new('A', $arg) if ref($arg);
  $slf->_exec;

  # Removing the local variables and restore the previous context
  foreach my $nam (keys(%$dic))
  { delete($dic->{$nam}) unless exists($glb->{$nam});
  }
  if (exists($slf->{'_loc'}))
  { # Restore the previous local variable context
    $loc = $slf->{'_loc'};
    foreach my $nam (keys(%$loc))
    { $dic->{$nam} = $loc->{$nam};
    }

    # Restore the previous 'if' context
    while (ref($ptr = pop(@{$slf->{'_stk'}})) eq 'ARRAY')
    { $blk = $ptr->[0];
      $blk->{'_ifc'} = $ptr->[1];
      $blk->{'_flg'} = $ptr->[2];
    }

    # Update the recursivity stack
    if (defined($ptr))
    { $slf->{'_loc'} = $ptr;
    }
    else
    { delete($slf->{'_stk'});
    }
  }

  # Detect some runtime errors
  my $ret = $slf->{'_ret'};
  $slf->gen_exec_err("Break or next used outside a loop")
    if $ret == $RET_NXT || $ret == $RET_BRK;
  return $ret
    if $ret == $ERROR;

  # Return the last value
  $slf->{'_val'};
}

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

This method assigns the specified value to a given key.

=cut

sub set_info
{ my ($slf, $key, $val) = @_;

  $slf->{$key} = $val;
}

=head2 S<$h-E<gt>set_parent($parent)>

This method assigns a parent to the object. It also updates the list child
objects in the parent object to facilitate deleting objects. It returns the
object reference.

=cut

sub set_parent
{ my ($slf, $par) = @_;

  $slf->{'_par'} = $par;
  $slf->{'_top'} = $par->{'_top'};
  push(@{$par->{'_chl'}}, $slf);
  $slf;
}

=head2 S<$h-E<gt>xref($agent)>

This method produces a cross-reference of the macro definitions and the macro
and module calls.

=cut

sub xref
{ my ($slf, $agt) = @_;

  if (-t STDOUT )
  { my $pag =
      exists($ENV{'PAGER'}) ? $ENV{'PAGER'} :
      $agt->is_vms ? 'TYPE/PAGE=SAVE SYS$INPUT' :
      'more';
    open(OUT, "| $pag")
      || die "RDA-00239: Cannot open pager:\n $!\n";
    _xref($slf, $agt, *OUT);
    close(OUT);
  }
  else
  { _xref($slf, $agt, *STDOUT);
  }
  wait();
}

sub _xref
{ my ($slf, $agt, $out) = @_;
  my ($err, @tb_loc, @tb_int, @tb_oth);

  # Analyze the code
  $err = $slf->load;
  _xref_code($slf, $slf);

  # Initialize the macro list
  $slf->{'_lib'} = {};
  $agt->get_macros($slf->{'_lib'});
  map {$slf->{'_lib'}->{$_} = $slf} keys(%tb_fct);

  # Classify the macros
  foreach my $mac (sort keys(%{$slf->{'-use'}}))
  {if (exists($slf->{'-def'}->{$mac}))
   { push(@tb_loc,$mac)
   }
   elsif (exists($slf->{'_lib'}->{$mac}))
   { push(@tb_int,$mac)
   }
   else
   { push(@tb_oth,$mac)
   }
  }

  # Display the cross-reference
  $agt->dsp_string($out, '', "Module ".$slf->{'_nam'}.".def Cross Reference\n");
  $agt->dsp_string($out, '', "  $err error(s) detected at load\n") if $err;
  _xref_dsp($slf, $agt, $out, $slf->{'-run'}, '-run', 'Called Modules');
  _xref_dsp($slf, $agt, $out, $slf->{'-def'}, '-def', 'Locally Defined Macros');
  _xref_dsp($slf, $agt, $out, \@tb_loc, '-use', 'Calls to Local Macros');
  _xref_dsp($slf, $agt, $out, \@tb_int, '-use', 'Calls to Predefined Macros');
  _xref_dsp($slf, $agt, $out, \@tb_oth, '-use', 'Calls to other Macros');
}

# Analyse recursively the code
sub _xref_code
{ my ($slf, $blk) = @_;

  foreach my $spc (@{$blk->{'_cod'}})
  { my $lin = $spc->[$SPC_LIN];
    if (defined($spc->[$SPC_REF]))
    { push(@{$slf->{'-def'}->{$spc->[$SPC_REF]}}, $lin)
        if $spc->[$SPC_COD] =~ m/^macro /;
      push(@{$slf->{'-run'}->{ref($spc->[$SPC_REF]) ? '<Ref>'
        : $spc->[$SPC_REF]}}, $lin) if $spc->[$SPC_COD] =~ m/^run /;
      _xref_set($slf, $spc->[$SPC_VAL], $lin)
        if $spc->[$SPC_COD] =~ m/^(append|set)\b/;
    }
    _xref_value($slf, $spc->[$SPC_REF], $lin);
    _xref_value($slf, $spc->[$SPC_VAL], $lin);
    _xref_code($slf, $spc->[$SPC_BLK]) if ref($spc->[$SPC_BLK]);
  }
}

# Display a result set
sub _xref_dsp
{ my ($slf, $agt, $out, $tbl, $key, $ttl) = @_;
  my ($cur, $max);

  return unless ($cur = ref($tbl));
  $tbl = [sort keys(%$tbl)] if $cur eq 'HASH';

  if (scalar(@$tbl))
  { # Determine the name length
    $max = 0;
    foreach my $nam (@$tbl)
    { $max = $cur if ($cur = length($nam)) > $max;
    }

    # Display the table
    $agt->dsp_string($out, '', "\n$ttl:\n");
    foreach my $nam (@$tbl)
    { $agt->dsp_string($out, sprintf("  %-*s  ", $max, $nam),
        join(', ', @{$slf->{$key}->{$nam}}));
    }
  }
}

# Analyse append/set text
sub _xref_set
{ my ($slf, $obj, $lin) = @_;
  my %tbl;

  %tbl = map {$_ => 1} $obj->{'val'} =~ m/___Macro_(\w+)\(\d+\)___/g;
  foreach my $nam (keys(%tbl))
  { push(@{$slf->{'-use'}->{$nam}}, $lin);
  }
}

# Analyse recursively a value
sub _xref_value
{ my ($slf, $obj, $lin) = @_;
  my ($ref, $val);

  $ref = ref($obj);
  if ($ref eq 'ARRAY')
  { foreach my $ptr (@$obj)
    {_xref_value($slf, $ptr, $lin);
    }
  }
  elsif ($ref eq 'RDA::Value')
  { push(@{$slf->{'-use'}->{$obj->{'nam'}}}, $lin) if $obj->{'typ'} eq 'M';
    _xref_value($slf, $val, $lin) if ref($val = $obj->{'arg'});
    _xref_value($slf, $val, $lin) if ref($val = $obj->{'val'});
  }
}

# --- Parsing routines -------------------------------------------------------

# Get a macro call
sub _get_call
{ my ($slf, $spc, $str) = @_;
  my ($var);

  die "RDA-00210: Invalid or missing macro call\n"
    unless ref($var = $slf->_parse_value($str)) && $var->is_macro;
  $spc->[$SPC_VAL] = $var;
}

# Get a condition
#   value
#   !value
sub _get_cond
{ my ($slf, $spc, $str) = @_;

  $spc->[$SPC_REF] = $1 if $$str =~ s/^(\!)\s*//;
  $slf->_get_value($spc, $str, $VAL_ONE);
}

# Get a variable list for a delete command
sub _get_del_list
{ my ($slf, $spc, $str) = @_;
  my $rec;

  $rec = $slf->_parse_list($str);
  die "RDA-00220: Invalid value(s) found in variable list\n"
    unless $rec->is_var_list(1);
  $spc->[$SPC_VAL] = $rec;
}

# Get the parameters of a 'for' command
#   for $var (value1,value2,value3)
#   for $var (value1,value2)
sub _get_for
{ my ($slf, $spc, $str) = @_;
  my ($cnt, $rec);

  # Get the for variable
  die "RDA-00211: Missing scalar variable\n"
    unless ($rec = $slf->_parse_value($str)) && $rec->is_scalar_lvalue;
  $spc->[$SPC_REF] = $rec;

  # Get the for list
  $spc->[$SPC_VAL] = $rec = $slf->_parse_sub_list($str);
  $cnt = $rec->count_items;
  die "RDA-00212: Invalid command format\n" if $cnt < 2 || $cnt > 3;
}

# Get a increment/decrement
#   $var
#   $var,$value
sub _get_incr
{ my ($slf, $spc, $str) = @_;
  my ($rec, $var, @tbl);

  $rec = $slf->_parse_list($str);
  die "RDA-00213: Missing scalar variable\n"
    unless ($var = $rec->shift_item) && $var->is_scalar_lvalue;
  $var->set_info('dft', $VAL_ZERO);
  $spc->[$SPC_REF] = $var;
  $spc->[$SPC_VAL] = $rec->shift_item($VAL_ONE);
  die "RDA-00214: Extra value(s) found\n" if $rec->count_items;
}

# Get a list
#   <empty list>
#   value
#   value,...
sub _get_list
{ my ($slf, $spc, $str) = @_;

  $spc->[$SPC_VAL] = $slf->_parse_list($str);
}

# Get the parameters of a 'loop' command
#   loop $var (list)
#   loop $var[value] (list)
#   loop $var{value} (list)
sub _get_loop
{ my ($slf, $spc, $str) = @_;
  my ($rec);

  # Get the loop variable
  die "RDA-00211: Missing scalar variable\n"
    unless ($rec = $slf->_parse_value($str)) && $rec->is_scalar_lvalue;
  $spc->[$SPC_REF] = $rec;

  # Get the loop list
  $spc->[$SPC_VAL] = $slf->_parse_sub_list($str);
}

# Get a name
sub _get_name
{ my ($slf, $spc, $str) = @_;

  die "RDA-00215: Invalid or missing name\n"
    unless $$str =~ s/^([A-Za-z]\w*)\s*//;
  $spc->[$SPC_REF] = $1;
}

# Check that no argument has been provided
sub _get_none
{
}

# Get an output file
sub _get_output
{ my ($slf, $spc, $str) = @_;

  $slf->_get_report($spc, $str,
     ($$str =~ s/^(P|[EORS][NF])\s*,\s*//) ? $1 : 'OF');
}

# Get a report name
sub _get_report
{ my ($slf, $spc, $str, $typ) = @_;
  my $rec;

  if ($$str =~ s/^([A-Za-z]\w*)\s*(#.*)?$//)
  { $spc->[$SPC_REF] = $1;
    $typ = lc($typ) if $typ;
  }
  elsif (ref($rec = $slf->_parse_value($str)))
  { $spc->[$SPC_REF] = $rec;
  }
  else
  { die "RDA-00215: Invalid or missing name\n"
  }
  $spc->[$SPC_VAL] = $typ;
}

# Get a module call
sub _get_run
{ my ($slf, $spc, $str) = @_;

  if ($$str =~ s/^\&\{\s*//)
  { $spc->[$SPC_REF] = $slf->_parse_value($str);
    die "RDA-00216: Invalid or missing name\n"
      unless $$str =~ s/^\}\s*//;
  }
  elsif ($$str =~ s/^(\w+)\s*//)
  { $spc->[$SPC_REF] = $1;
  }
  else
  { die "RDA-00216: Invalid or missing name\n"
  }
  $spc->[$SPC_VAL] = $slf->_parse_sub_list($str);
}

# Set thread specification
sub _get_thread
{ my ($slf, $spc) = @_;

  $spc->[$SPC_REF] = 1;
}

# Get a single value
#   number
#   "..."
#   '...'
#   @name
#   $name[value]
#   $name{value}
#   $name
#   name(value,...)
sub _get_value
{ my ($slf, $spc, $str, $dft) = @_;

  $spc->[$SPC_VAL] = $slf->_parse_value($str) || $dft;
}

# Assemble the lines of a text block
sub _merge_txt
{ my ($slf, $spc) = @_;
  $spc->[$SPC_VAL] = RDA::Value->new('T', join("\n", @{$spc->[$SPC_VAL]}));
}

# Define or assign a variable or a list of variables
#   lvalue
#   lvalue = value
#   lvalue = (value,...)
#   (lvalue,...) = (value)
sub _get_var_def
{ my ($slf, $spc, $str) = @_;
  my ($rec);

  if ($$str =~ m/^\(/)
  { $rec = $slf->_parse_sub_list($str);
    die "RDA-00217: Invalid left value list\n" unless $rec->is_lvalue;
    $spc->[$SPC_REF] = $rec;
    $spc->[$SPC_VAL] =
      ($$str =~ s/=\s*//) ? $slf->_parse_value($str) : $VAL_EMPTY;
  }
  elsif ($rec = $slf->_parse_value($str))
  { die "RDA-00218: Invalid left value\n" unless $rec->is_lvalue;
    $spc->[$SPC_REF] = $rec;
    $spc->[$SPC_VAL] =
      ($$str =~ s/=\s*//) ? $slf->_parse_value($str) :
      ($rec->is_scalar_lvalue || $rec->is_ref_value) ? $VAL_UNDEF :
      $VAL_EMPTY;
  }
  else
  { die "RDA-00219: Invalid or missing variable\n";
  }
}

# Get a variable list
sub _get_var_list
{ my ($slf, $spc, $str) = @_;
  my $rec;

  $rec = $slf->_parse_list($str);
  die "RDA-00220: Invalid value(s) found in variable list\n"
    unless $rec->is_var_list(0);
  $spc->[$SPC_VAL] = $rec;
}

# Get a variable followed by a text block
#  $var
#  $var[...]
#  $var{...}
sub _get_var_txt
{ my ($slf, $spc, $str) = @_;
  my $rec;

  $spc->[$SPC_VAL] = [];
  if (ref($rec = $slf->_parse_value($str)))
  { die "RDA-00221: Invalid variable\n" unless $rec->is_scalar_lvalue;
    $spc->[$SPC_REF] = $rec;
    $$str =~ s/^\=?\s*//;
  }
}

# Parse a list of values between parentheses
sub _parse_sub_list
{ my ($slf, $str) = @_;
  my $rec;

  # Get the sub list
  die "RDA-00222: Missing opening parenthesis\n" unless $$str =~ s/^\(\s*//;
  $rec = $slf->_parse_list($str, ')');
  die "RDA-00223: Missing closing parenthesis\n" unless $$str =~ s/^\)\s*//;

  # Return the list
  $rec;
}

# Parse a list of values
sub _parse_list
{ my ($slf, $str, $del) = @_;
  my ($itm, $rec);

  $del = '#' unless defined($del);
  $rec = RDA::Value->new('L');

  # Detect an empty list
  return $rec if length($$str) == 0 || substr($$str, 0, 1) eq $del;

  # Get the first list element
  return $rec unless ref($itm = $slf->_parse_value($str));
  $rec->push_item($itm);

  # Get next list elements
  while ($$str =~ s/^\s*,\s*//)
  { return $rec unless ref($itm = $slf->_parse_value($str));
    $rec->push_item($itm);
  }

  # Return the list
  $rec;
}

# Parse a value
sub _parse_value
{ my ($slf, $str, $del) = @_;
  my ($arg, $nam, $rec);

  # Extract a value
  if ($$str =~ s/^'([^\']*)'\s*//)
  { $rec = RDA::Value->new('T', $1);
  }
  elsif ($$str =~ s/^"([^\"]*)\s*"//)
  { $arg = $1;
    $arg =~ s/(\\[0-7]{3}|\\0x[0-9A-Fa-f]{2})/chr(oct(substr($&,1)))/eg;
    $rec = RDA::Value->new('T', $arg);
  }
  elsif ($$str =~ s/^([-+]?\d+(\.\d*)?([eE][\+\-]?\d+)?)\s*//)
  { $rec = RDA::Value->new('N', 0 + $1);
  }
  elsif ($$str =~ s/^\$(\w+)\s*\[\s*//)
  { $nam = "\@$1";
    $arg = $slf->_parse_list($str, ']');
    die "RDA-00224: Invalid or missing array index\n"
      unless $arg->count_items == 1;
    $rec = RDA::Value->new('I', $slf, $nam, $arg->shift_item);
    die "RDA-00225: Invalid array index end\n"
      unless $$str =~ s/^\]\s*//;
  }
  elsif ($$str =~ s/^\$(\w+)\s*\{\s*//)
  { $nam = "\%$1";
    $arg = $slf->_parse_list($str, '}');
    die "RDA-00226: Invalid or missing hash key\n"
      unless $arg->count_items == 1;
    $rec = RDA::Value->new('K', $slf, $nam, $arg->shift_item);
    die "RDA-00227: Invalid hash key end\n"
      unless $$str =~ s/^\}\s*//;
  }
  elsif ($$str =~ s/^([\$\@\%]\w+)\s*//)
  { $rec = RDA::Value->new('V', $slf, $1);
  }
  elsif ($$str =~ s/^\\([\$\@\%]\w+)\s*//)
  { $rec = RDA::Value->new('R', $slf, $1);
  }
  elsif ($$str =~ s/^(\w+)\s*\(\s*//)
  { $nam = $1;
    $rec = RDA::Value->new('M', $slf, $nam, $slf->_parse_list($str, ')'));
    die "RDA-00228: Invalid macro end\n" unless $$str =~ s/^\)\s*//;
  }
  elsif ($$str =~ s/^true\s*//)
  { $rec = $VAL_ONE;
  }
  elsif ($$str =~ s/^false\s*//)
  { $rec = $VAL_ZERO;
  }
  elsif ($$str =~ s/^undef\s*//)
  { $rec = $VAL_UNDEF;
  }
  elsif ($$str =~ s/^last\s*//)
  { $rec = RDA::Value->new('C', $slf);
  }
  elsif ($$str =~ m/\(/)
  { $rec = $slf->_parse_sub_list($str);
  }
  elsif ($$str !~ m/^(#.*)?$/)
  { die "RDA-00229: Invalid value\n";
  }

  # Return the value found, otherwise undef
  $rec;
}

# --- Execution routines -----------------------------------------------------

sub _exec
{ my ($slf) = @_;
  my ($ret, $top, $tr1, $tr2, $trc);

  # Abort when there is no associated code block
  unless (exists($slf->{'_cod'}))
  { $slf->{'_ret'} = $ERROR;
    return;
  }

  # Determine the debugging requirements
  $top = $slf->get_top;
  $tr1 = $top->{'_pre'}.$slf->{'_top'}->{'_nam'}.':';
  $tr2 = '.'.('  ' x $slf->{'_lvl'});
  $trc = '';

  # Initialize the code block for its execution
  $slf->{'_flg'} = 1;
  $slf->{'_ret'} = $CONT;

  # Execute the code block
  foreach my $spc (@{$slf->{'_cod'}})
  { if ($top->{'_trc'})
    { $trc = $tr1.$spc->[$SPC_LIN].$tr2.$spc->[$SPC_COD];
      print "$trc\n";
    }
    $slf->{'_lst'} = $spc;
    eval {&{$spc->[$SPC_FCT]}($slf, $spc, $trc)};
    $slf->gen_exec_err($@) if $@;
    last                   if $slf->{'_ret'};
  }

  # Return the last return code
  $slf->{'_ret'};
}

# Append a text to a scalar variable
sub _exe_append
{ my ($slf, $spc) = @_;
  my ($txt, $var);

  $var = $spc->[$SPC_REF];
  $txt = join("\n", $var->eval_as_string, $spc->[$SPC_VAL]->eval_as_string);
  $slf->{'_ctx'}->{'_val'} =
    $var->assign_value(RDA::Value->new('T', $txt), 1);
}

# Interrupt a loop
sub _exe_break
{ my ($slf, $spc) = @_;
  my $val;

  # Evaluate the condition
  $val = $slf->{'_ctx'}->{'_val'} = $spc->[$SPC_VAL]->eval_value(1);
  $val->dump(1, $slf->get_prefix('last: '))
    if $slf->{'_ctx'}->chk_trace(2);
  $val = $val->eval_as_scalar(1);
  $val = !$val unless defined($spc->[$SPC_REF]);

  # Take the appropriate action
  $slf->{'_ret'} = $RET_BRK unless $slf->{'_ret'} || $val;
}

# Execute a macro
sub _exe_call
{ my ($slf, $spc) = @_;

  $slf->{'_ctx'}->{'_val'} = $spc->[$SPC_VAL]->eval_value;
  $slf->{'_ctx'}->{'_val'}->dump(1, $slf->get_prefix('last: '))
    if $slf->{'_ctx'}->chk_trace(2);
}

# Close the output file
sub _exe_close
{ my ($slf) = @_;

  $slf = $slf->get_top;
  if (exists($slf->{'_out'}))
  { $slf->{'_out'}->close;
    delete($slf->{'_out'});
  }
}

# Specify a new -data- report, closing the current one
sub _exe_data
{ my ($slf, $spc) = @_;

  _output($slf, 'D', $spc->[$SPC_REF]);
}

# Display some debugging information
sub _exe_debug
{ my ($slf, $spc) = @_;

  print $spc->[$SPC_VAL]->eval_as_line if $slf->get_top->{'_dbg'};
}

# Decrement a numerical value
sub _exe_decr
{ my ($slf, $spc, $trc) = @_;

  _exe_incr($slf, $spc, $trc, 1);
}

# Delete some variables
sub _exe_delete
{ my ($slf, $spc) = @_;

  $spc->[$SPC_VAL]->delete_value;
}

# Echo some information
sub _exe_die
{ my ($slf, $spc) = @_;

  die $spc->[$SPC_VAL]->eval_as_line;
}

# Echo some information
sub _exe_echo
{ my ($slf, $spc) = @_;

  print $spc->[$SPC_VAL]->eval_as_line unless $slf->get_top->{'_rnd'};
}

# Do an if condition
sub _exe_else
{ my ($slf, $spc) = @_;
  my $val;

  # Get the last condition, but prevent further matches
  $val = $slf->{'_flg'};
  $slf->{'_flg'} = 1;

  # When fullfilled, execute it
  $slf->{'_ret'} = $spc->[$SPC_BLK]->_exec unless $val;
}

# Do an elsif condition
sub _exe_elsif
{ my ($slf, $spc) = @_;
  my $val;

  # Check the last condition
  return if $slf->{'_flg'};

  # Evaluate the condition
  $val = $slf->{'_ctx'}->{'_val'} = $spc->[$SPC_VAL]->eval_value(1);
  $val->dump(1, $slf->get_prefix('last: '))
    if $slf->{'_ctx'}->chk_trace(2);
  $val = $val->eval_as_scalar(1);
  $val = !$val if defined($spc->[$SPC_REF]);

  # When fullfilled, execute it
  $slf->{'_flg'} = $val;
  $slf->{'_ret'} = $spc->[$SPC_BLK]->_exec unless $slf->{'_ret'} || !$val;
}

# Do a for
sub _exe_for
{ my ($slf, $spc, $trc) = @_;
  my ($blk, $cur, $inc, $lim, $nam, $rec, $ret, $var);

  $blk = $spc->[$SPC_BLK];
  $var = $spc->[$SPC_REF];
  $rec = $spc->[$SPC_VAL];
  $cur = $rec->get_item(0)->eval_as_number;
  $lim = $rec->get_item(1)->eval_as_number;
  $inc = $rec->get_item(2, $VAL_ONE)->eval_as_number;
  if ($inc >= 0)
  { for (; $cur <= $lim ; $cur += $inc)
    { # Update the loop variable
      $slf->{'_ctx'}->{'_val'} =
        $var->assign_value(RDA::Value->new('N', $cur), 1);

      # Execute the loop iteration
      $ret = $blk->_exec;
      last if $ret == $RET_BRK;
      if ($ret == $RET_RET || $ret == $ERROR)
      { $slf->{'_ret'} = $ret;
        return;
      }

      # Prepare for the next iteration
      print "$trc **\n" if $trc;
    }
  }
  else
  { for (; $cur >= $lim ; $cur += $inc)
    { # Update the loop variable
      $slf->{'_ctx'}->{'_val'} =
        $var->assign_value(RDA::Value->new('N', $cur), 1);

      # Execute the loop iteration
      $ret = $blk->_exec;
      last if $ret == $RET_BRK;
      if ($ret == $RET_RET || $ret == $ERROR)
      { $slf->{'_ret'} = $ret;
        return;
      }

      # Prepare for the next iteration
      print "$trc **\n" if $trc;
    }
  }
}

# Do an if condition
sub _exe_if
{ my ($slf, $spc) = @_;
  my ($top, $val);

  # Make it works in a recursive context
  $top = $slf->{'_top'};
  if (!exists($slf->{'_ifc'}))
  { $slf->{'_ifc'} = $top->{'_loc'};
  }
  elsif ($slf->{'_ifc'} != $top->{'_loc'})
  { push(@{$top->{'_stk'}}, [$slf, $slf->{'_ifc'}, $slf->{'_flg'}]);
    $slf->{'_ifc'} = $top->{'_loc'};
  }

  # Evaluate the condition
  $val = $slf->{'_ctx'}->{'_val'} = $spc->[$SPC_VAL]->eval_value(1);
  $val->dump(1, $slf->get_prefix('last: '))
    if $slf->{'_ctx'}->chk_trace(2);
  $val = $val->eval_as_scalar(1);
  $val = !$val if defined($spc->[$SPC_REF]);

  # When fullfilled, execute it
  $slf->{'_flg'} = $val;
  $slf->{'_ret'} = $spc->[$SPC_BLK]->_exec unless $slf->{'_ret'} || !$val;
}

# Import some variables from upper levels
sub _exe_import
{ my ($slf, $spc) = @_;
  my ($ctx, $dic, $flg, $nam);

  $ctx = $slf->{'_ctx'};
  $dic = $ctx->{'_var'};
  $flg = $ctx->chk_trace(2);
  foreach my $rec (@{$spc->[$SPC_VAL]->get_items})
  { $nam = $rec->get_info('nam');
    _import_var($dic, $ctx, $nam, $flg) unless exists($dic->{$nam});
  }
}

sub _import_var
{ my ($dic, $ctx, $nam, $flg) = @_;

  while (exists($ctx->{'_par'}))
  { $ctx = $ctx->{'_par'}->{'_ctx'};
    if (exists($ctx->{'_var'}->{$nam}))
    { $dic->{$nam} = $ctx->{'_var'}->{$nam};
      $dic->{$nam}->dump(1, $ctx->get_prefix("$nam: "))
        if $flg;
      return;
    }
  }
}

# Increment a numerical value
sub _exe_incr
{ my ($slf, $spc, $trc, $dir) = @_;
  my ($val, $var);

  # Get the increment
  $val = $spc->[$SPC_VAL]->eval_as_number;
  $val = -$val if $dir;

  # Update the variable
  $var = $spc->[$SPC_REF];
  $val += $var->eval_as_number;
  $slf->{'_ctx'}->{'_val'} = $var->assign_value(RDA::Value->new('N', $val), 1);
}

# Execute a block in a separate process
sub _exe_job
{ my ($slf, $spc) = @_;
  my ($flg, $opn, $out, $pid, $thr, $toc, $top);

  $top = $slf->get_top;
  ++$top->{'_cnt'};
  if (!defined($pid = _fork($top)))
  { # Save the reports
    $flg = $top->{'_thr'};
    $out = delete($top->{'_out'});
    $opn = $top->{'_opn'};
    $toc = delete($top->{'_toc'});
    $top->{'_opn'} = {};

    # Execute the block in main process
    $top->{'_thr'} = 1;
    $spc->[$SPC_BLK]->_exec;

    # Close thread reports and restore the original reports
    $top->_close_all(0);
    $top->{'_out'} = $out if $out;
    $top->{'_opn'} = $opn;
    $top->{'_toc'} = $toc if $toc;
    $top->{'_thr'} = $flg;
  }
  elsif (!$pid)
  { # Prepare the lock context
    eval {
      require RDA::Lock;
      RDA::Lock::init($top->{'_agt'}, $spc->[$SPC_REF]);
    };

    # Reset libraries requiring thread preparation
    foreach my $lib (@{$top->{'_agt'}->can_thread})
    { $lib->reset;
    }

    # Execute the block in a child process
    $top->{'_ctl'}->reseq(1);
    $top->_close_all(0);
    $top->{'_thr'} = 1;
    $top->{'_pre'} .= sprintf('T%03d/', $top->{'_cnt'});
    $spc->[$SPC_BLK]->_exec;
    $top->_close_all(1);

    # Remove lock files
    eval {
      require RDA::Lock;
      RDA::Lock::end($top->{'_agt'});
    };

    exit(0);
  }
  else
  { $top->{'_ctl'}->reseq(0);
    push(@{$top->{'_pid'}}, $pid) if $pid < 0 && $spc->[$SPC_REF];
  }
}

sub _fork
{ my ($top) = @_;
  my ($flg, $pid);

  # Abort when can't fork
  return undef unless ($flg = $top->{'_agt'}->can_fork);

  # Force the creation of the alias file for sharing it between the threads
  $top->{'_alt'}->get_handle if $top->{'_alt'} && $top->{'_thr'} == 0;

  # Create the thread process
  return undef unless defined($pid = fork());
  unless ($pid)
  { # When fork is emulated, a child process is sufficient
    return 0 if $flg < 0;

    # Make a double fork to have an independant child process
    exit(1) unless defined($pid = fork());
    exit(0) if $pid;
    return 0;
  }

  # Don't need to wait when fork is emulated
  return $pid if $flg < 0;

  # In the parent process, wait for the grand child process fork
  waitpid($pid, 0);
  $? ? undef : 1;
}

# Keep some variables
sub _exe_keep
{ my ($slf, $spc) = @_;
  my $glb;

  # Make global all variables from the list
  $glb = $slf->{'_ctx'}->{'_glb'};
  foreach my $rec (@{$spc->[$SPC_VAL]->get_items})
  { $glb->{$rec->get_info('nam')} = 1;
  }
}

# Do a loop
sub _exe_loop
{ my ($slf, $spc, $trc) = @_;
  my ($blk, $cur, $rec, $ret, $var);

  $blk = $spc->[$SPC_BLK];
  $var = $spc->[$SPC_REF];
  $rec = $spc->[$SPC_VAL]->eval_value;
  while (defined($cur = $rec->shift_item))
  { # Update the loop variable
    $slf->{'_ctx'}->{'_val'} = $var->assign_value($cur, 1);

    # Execute the loop iteration
    $ret = $blk->_exec;
    last if $ret == $RET_BRK;
    if ($ret == $RET_RET || $ret == $ERROR)
    { $slf->{'_ret'} = $ret;
      return;
    }

    # Prepare for the next iteration
    print "$trc **\n" if $trc;
  }
}

# Define a macro
sub _exe_macro
{ my ($slf, $spc) = @_;
  my ($blk, $nam);

  # Initialize the context
  $blk           = $spc->[$SPC_BLK];
  $blk->{'_glb'} = {};
  $blk->{'_var'} = {};

  # Register the macro
  $nam = $spc->[$SPC_REF];
  $slf->{'_top'}->{'_lib'}->{$nam} = $blk;
}

# Interrupt the current loop iteration and start the next one
sub _exe_next
{ my ($slf, $spc) = @_;
  my $val;

  # Evaluate the condition
  $val = $slf->{'_ctx'}->{'_val'} = $spc->[$SPC_VAL]->eval_value(1);
  $val->dump(1, $slf->get_prefix('last: '))
    if $slf->{'_ctx'}->chk_trace(2);
  $val = $val->eval_as_scalar(1);
  $val = !$val unless defined($spc->[$SPC_REF]);

  # Take the appropriate action
  $slf->{'_ret'} = $RET_NXT unless $val || $slf->{'_ret'};
}

# Specify an output file, closing the current one
sub _exe_output
{ my ($slf, $spc) = @_;

  _output($slf, $spc->[$SPC_VAL], $spc->[$SPC_REF]);
}

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

  # Ignore the command in eval mode
  my $top = $slf->get_top;
  return if $top->{'_evl'};

  # Determine the report name
  if (ref($nam))
  { $nam = $slf->{'_ctx'}->{'_val'} = $nam->eval_value;
    $nam = $nam->eval_as_string(1);
    $arg = $1
      if $typ eq 'D' && $nam =~ s/(\.(box|csv|dat|gif|htm|jar|png|zip))$//;
    if ($typ eq 'D' || $typ eq 'R')
    { $nam =~ s/[\\\/\.]/_/g;
      $nam =~ s/\W//g;
      die "RDA-00215: Invalid or missing name\n"
        unless $nam =~ m/^[A-Za-z]\w*$/;
      $nam = sprintf('_flt_%04d_%04d', $top->{'_cnt'}, $top->{'_flt'}++)
        if $top->{'_flt'};
    }
  }

  # Close the previous output file
  if (exists($top->{'_out'}))
  { $top->{'_out'}->close;
    delete($top->{'_out'});
  }

  # Determine the corresponding output file but do not open it yet
  $top->{'_out'} = $top->{'_ctl'}->new($typ, $top, $nam, $arg);
}

# Specify a code block to execute when writing to the output file
sub _exe_prefix
{ my ($slf, $spc) = @_;

  $slf = $slf->get_top;
  die "RDA-00201: Output file not specified\n" unless exists($slf->{'_out'});
  $slf->{'_out'}->prefix($spc->[$SPC_BLK]);
}

# Push a table of content contribution
sub _exe_pretoc
{ my ($slf, $spc) = @_;

  # Ignore the request in a thread
  $slf = $slf->get_top;
  return if $slf->{'_thr'} || !exists($slf->{'_toc'});

  # Push the line
  $slf->{'_toc'}->push_string($spc->[$SPC_VAL]->eval_as_line);
}

# Specify a new report, closing the current one
sub _exe_report
{ my ($slf, $spc) = @_;

  _output($slf, 'R', $spc->[$SPC_REF]);
}

# Resume the output to a report
sub _exe_resume
{ my ($slf, $spc) = @_;
  my $nam;

  # Close the previous output file and suppress any prefix block
  $slf = $slf->get_top;
  if (exists($slf->{'_out'}))
  { $slf->{'_out'}->close;
    delete($slf->{'_out'});
  }

  # Restore the output file
  $nam = $spc->[$SPC_REF];
  $slf->{'_out'} = delete($slf->{'_opn'}->{$nam})
    if exists($slf->{'_opn'}->{$nam});
}

# Terminate the current context execution
sub _exe_return
{ my ($slf, $spc) = @_;

  $slf->{'_ctx'}->{'_val'} = $spc->[$SPC_VAL]->eval_value
    if defined($spc->[$SPC_VAL]);
  $slf->{'_ret'} = $RET_RET unless $slf->{'_ret'};
}

# Execute a module
sub _exe_run
{ my ($slf, $spc) = @_;
  my ($agt, $blk, $nam, $ret, $top);

  # Get the module name
  $nam = $nam->eval_as_string if ref($nam = $spc->[$SPC_REF]);
  return unless length($nam);

  # Load the block
  $top = $slf->get_top;
  $agt = $top->{'_agt'};
  unless ($blk = $agt->get_block($nam))
  { $blk = RDA::Block->new($nam, $top->{'_dir'});
    $blk->load();
    $blk->{'_glb'} = {};
    $blk->{'_var'} = {};

    # Initialize the macro list
    $blk->{'_lib'} = {};
    $agt->get_macros($blk->{'_lib'});
    map {$blk->{'_lib'}->{$_} = $blk} keys(%tb_fct);
  }
  $blk->{'_cnt'} = 0;
  $blk->{'_par'} = $slf->{'_ctx'};
  $blk->{'_pre'} = $top->{'_pre'};

  # Execute the associated code block
  $ret = $blk->run(undef, $spc->[$SPC_VAL], $blk);
  $slf->{'_ctx'}->{'_val'} = $blk->{'_val'};

  # Keep or free the block memory
  if (exists($blk->{'_glb'}->{'$KEEP_BLOCK'}))
  { # Store the block reference
    $agt->keep_block($nam, $blk);

    # Share macros
    if (exists($blk->{'_var'}->{'@SHARE_MACROS'}))
    { my ($dst, $src);
      $dst = $slf->{'_top'}->{'_lib'};
      $src = $blk->{'_lib'};
      foreach my $itm ($blk->{'_var'}->{'@SHARE_MACROS'}->eval_as_array)
      { $dst->{$itm} = $src->{$itm} if $itm && exists($src->{$itm});
      }
    }
  }
  else
  { # Resynchronize the calling block
    $top->{'_out'}->deprefix($blk) if exists($top->{'_out'});
    foreach my $out (values(%{$top->{'_opn'}}))
    { $out->deprefix($blk);
    }

    # Delete the block
    $blk->delete;
  }

  # Propagate any error
  die "RDA-00241: Error encountered in the block called\n" if $ret == $ERROR;
}

# Share a report between modules
sub _exe_share
{ my ($slf, $spc) = @_;
  my ($grp, $rec, $txt);

  # Ignore the request in a thread
  $slf = $slf->get_top;
  return if $slf->{'_thr'} || !exists($slf->{'_ctl'});

  # Share the file
  die "RDA-00201: Output file not specified\n" unless exists($slf->{'_out'});
  $rec = $spc->[$SPC_VAL];
  $slf->{'_ctl'}->add_share($slf->{'_out'},
    $rec->get_item(0)->eval_as_string,
    $rec->get_item(1)->eval_as_string);
}

# Suspend the data collection
sub _exe_sleep
{ my ($slf, $spc) = @_;
  my $val;

  $slf->{'_ctx'}->{'_val'} = $val = defined($spc->[$SPC_VAL])
    ? $spc->[$SPC_VAL]->eval_value
    : $VAL_ONE;
  $val = $val->eval_as_number(1);
  eval "sleep($val)" if $val > 0;
}

# Suspend the output to a report
sub _exe_suspend
{ my ($slf, $spc) = @_;

  $slf = $slf->get_top;
  $slf->{'_opn'}->{$spc->[$SPC_REF]} = delete($slf->{'_out'})
    if exists($slf->{'_out'});
}

# Write a table of content line
sub _exe_toc
{ my ($slf, $spc) = @_;
  my ($ofh);

  # Ignore the request in a thread or in eval mode
  $slf = $slf->get_top;
  return if $slf->{'_thr'} || $slf->{'_evl'} || !exists($slf->{'_toc'});

  # Write the line
  print $ofh $spc->[$SPC_VAL]->eval_as_line
    if ($ofh = $slf->{'_toc'}->get_handle);
}

# Suppress the execution of a code block when writing into the output file
sub _exe_unprefix
{ my ($slf) = @_;

  $slf = $slf->get_top;
  $slf->{'_out'}->unprefix if exists($slf->{'_out'});
}

# Remove the last table of content contribution(s)
sub _exe_unpretoc
{ my ($slf, $spc) = @_;
  my ($cnt, $toc);

  $slf = $slf->get_top;
  if (exists($slf->{'_toc'}))
  { $toc = $slf->{'_toc'};
    $cnt = defined($spc->[$SPC_VAL]) ? $spc->[$SPC_VAL]->eval_as_number : 1;
    $toc->pop_string while $cnt-- > 0;
  }
}

# Execute a variable definition
sub _exe_var
{ my ($slf, $spc) = @_;

  $slf->{'_ctx'}->{'_val'} = $spc->[$SPC_REF]->assign_value($spc->[$SPC_VAL])
    if ref($spc->[$SPC_REF]);
}

# Wait that all threads execution is complete
sub _exe_wait
{ my ($slf) = @_;
  my $pid;

  $slf = $slf->get_top;
  unless ($slf->{'_thr'} || $slf->{'_evl'})
  { sleep(1);

    # Wait until the thread lock can be get
    eval {
      sleep(1);
      require RDA::Lock;
      RDA::Lock::wait_thread($slf->{'_agt'});
    };

    # When fork is emulated, wait for thread completion
    while (defined($pid = shift(@{$slf->{'_pid'}})))
    { waitpid($pid, 0);
    }
  }
}

# Do a while loop
sub _exe_while
{ my ($slf, $spc) = @_;
  my ($blk, $ret, $val);

  $blk = $spc->[$SPC_BLK];
  $slf->{'_flg'} = 1;
  for (; ;)
  { # Evaluate the condition
    $val = $slf->{'_ctx'}->{'_val'} = $spc->[$SPC_VAL]->eval_value(1);
    $val->dump(1, $slf->get_prefix('last: '))
      if $slf->{'_ctx'}->chk_trace(2);
    $val = $val->eval_as_scalar(1);
    $val = !$val if defined($spc->[$SPC_REF]);
    last if $slf->{'_ret'} || !$val;

    # Execute the loop iteration
    $ret = $blk->_exec;
    last if $ret == $RET_BRK;
    if ($ret == $RET_RET || $ret == $ERROR)
    { $slf->{'_ret'} = $ret;
      return;
    }
  }
}

# Write a line in the output file
sub _exe_write
{ my ($slf, $spc) = @_;

  local $SIG{'PIPE'} = 'IGNORE';
  print {$slf->get_handle} $spc->[$SPC_VAL]->eval_as_line;
}

=head1 ERROR METHODS

=head2 S<$h-E<gt>gen_exec_err($msg[,$flg])>

This method generates an error message at execution time. It adds the context
to the error message automatically. This method does not stop the data
collection process.

When the flag is set, RDA considers the message as a warning.

=cut

sub gen_exec_err
{ my ($slf, $msg, $flg) = @_;

  $msg =~ s/\n$//;
  $slf->{'_ret'} = $ERROR unless $flg;
  print $msg." in ".$slf->{'_top'}->{'_nam'}." near line ".
    $slf->{'_lst'}->[$SPC_LIN], "\n";
}

=head2 S<$h-E<gt>gen_load_err($msg)>

This method generates an error message at load time. It adds the context to the
error message automatically. Any error causes the code removal at load end.

=cut

sub gen_load_err
{ my ($slf, $msg) = @_;

  $slf = $slf->{'_top'};
  $slf->{'_err'}++;
  $msg =~ s/\n$//;
  $msg .= " in ".$slf->{'_nam'}." near line ".$slf->{'_lin'} if $slf->{'_lin'};
  print "$msg\n";
}

=head1 INTERNAL MACROS

=head2 S<findShares($group,$module...)>

This macro returns the identifiers of all shared files that belong to the
specified group. It only searches the specified modules.

=cut

sub _m_findShares
{ my $slf = shift;
  my $ctx = shift;

  RDA::Value::new_list($ctx->get_top->{'_ctl'}->find_shares(@_));
}

=head2 S<getFile([$report[,$module]])>

This macro returns the name of the output file that is associated with the
specified report. It is possible to refer to another module. When no argument
is specified, it returns the name of the current output file if defined.
Otherwise it returns an undefined value.

=cut

sub _m_getFile
{ my ($slf, $ctx, $rep, $mod) = @_;
  my ($fil, $top);

  $top = $ctx->get_top;
  $mod = ($mod && $mod =~ $re_nam) ? "$2_" : $top->{'_abr'};
  if (!defined($rep))
  { return $VAL_UNDEF unless exists($top->{'_out'});
    $fil = $top->{'_out'}->get_file;
    $fil =~ s/\.(dat|txt)$/.htm/i;
  }
  elsif ($rep eq '.')
  { return $VAL_UNDEF unless exists($top->{'_out'});
    $fil = $top->{'_out'}->get_file;
  }
  elsif ($rep eq '/')
  { return $VAL_UNDEF unless exists($top->{'_out'});
    $fil = $top->{'_out'}->get_file(1);
  }
  elsif ($rep eq '$')
  { return $VAL_UNDEF unless exists($top->{'_out'});
    $fil = $top->{'_agt'}->quote($top->{'_out'}->get_file(1));
  }
  else
  { $fil = $top->{'_grp'}.$mod.$rep.'.htm';
  }
  RDA::Value->new('T', $top->{'_cas'} ? $fil : lc($fil));
}

=head2 S<getOutputPid()>

This macro returns the process identifier of the command accessed through an
output pipe. Otherwise it returns an undefined value.

=cut

sub _m_getOutputPid
{ my ($slf, $ctx) = @_;
  my ($pid, $top);

  $top = $ctx->get_top;
  $pid = $top->{'_out'}->get_pid if exists($top->{'_out'});
  defined($pid) ? RDA::Value->new('N', $pid) : $VAL_UNDEF;
}

=head2 S<getShare($id)>

This macro returns the link text of the specified shared file.

=cut

sub _m_getShare
{ my ($slf, $ctx, $id) = @_;

  RDA::Value->new('T', $ctx->get_top->{'_ctl'}->get_share($id));
}

=head2 S<getToc([$flg])>

This macro returns the file name of the Table of Contents. If the flag is set,
it returns the path to that file.

=cut

sub _m_getToc
{ my ($slf, $ctx, $flg) = @_;
  my ($fil, $top);

  $top = $ctx->get_top;
  return $VAL_UNDEF unless exists($top->{'_toc'});
  $fil = $top->{'_toc'}->get_file($flg);
  RDA::Value->new('T', $top->{'_cas'} ? $fil : lc($fil));
}

=head2 S<hasOutput($flg)>

This macro indicates whether lines were written to the output file since the
last prefix command. When the flag is set, it clears any prefix also.

=cut

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

  my $top = $ctx->get_top;
  (exists($top->{'_out'}) && $top->{'_out'}->has_output($flg))
    ? $VAL_ONE
    : $VAL_ZERO;
}

=head2 S<inThread()>

This macro indicates whether the code belongs to a thread.

=cut

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

  $ctx->in_thread ? $VAL_ONE : $VAL_ZERO;
}

=head2 S<isCreated([$flg])>

This macro indicates whether the output file was created. It still reports
false in the prefix block that is executed for the first line written to the
output file.

When the flag is set, it clears any prefix also.

=cut

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

  my $top = $ctx->get_top;
  (exists($top->{'_out'}) && $top->{'_out'}->is_created($flg))
    ? $VAL_ONE
    : $VAL_ZERO;
}

=head2 S<isFiltered()>

This macro indicates whether reports are filtered.

=cut

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

  $ctx->get_top->{'_ctl'}->is_filtered ? $VAL_ONE : $VAL_ZERO;
}


=head2 S<isImplemented($name)>

This macro indicates whether the specified macro is implemented.

=cut

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

  exists($ctx->get_lib->{$nam})
    ? $VAL_ONE
    : $VAL_ZERO;
}

=head2 S<isRendered()>

This macro indicates whether the current report is rendered immediately.

=cut

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

  my $top = $ctx->get_top;
  (exists($top->{'_out'}) && $top->{'_out'}->is_rendered)
    ? $VAL_ONE
    : $VAL_ZERO;
}


=head2 S<isTocCreated([$flg])>

This macro indicates whether the Table of Contents file has been created.

When the flag is set, it clears any C<pretoc> also.

=cut

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

  my $top = $ctx->get_top;
  (exists($top->{'_toc'}) && $top->{'_toc'}->is_created($flg))
    ? $VAL_ONE
    : $VAL_ZERO;
}

=head2 S<lock($nam[,$flag])>

This macro takes an exclusive lock. When the flag is set, it does not wait
until the lock is available. It returns true for success and false for failure.

=cut

sub _m_lock
{ my ($slf, $ctx, $nam, $flg) = @_;
  my ($ret, $top);

  if ($nam)
  { $top = $ctx->get_top;
    $nam = $top->{'_grp'}.$top->{'_abr'}.$nam;
    eval {
      require RDA::Lock;
      $ret = RDA::Lock::mlock($top->{'_agt'}, $nam, $flg);
    };
  }
  $ret ? $VAL_ONE : $VAL_ZERO;
}

=head2 S<renderFile([$file[,$title]])>

This macro renders the specified file. When no argument is specified, it closes
and renders the current output file.

It returns the name of the generated file.

=cut

sub _m_renderFile
{ my ($slf, $ctx, $fil, $ttl) = @_;
  my ($out, $sub, $top);

  $top = $ctx->get_top;
  unless ($fil)
  { return $VAL_UNDEF unless exists($top->{'_out'});
    $out = $top->{'_out'};
    $fil = $out->get_file;
    $sub = $out->get_sub;
    $out->close;
    delete($top->{'_out'});
  }
  RDA::Value->new('T', $top->{'_agt'}->render->gen_html($fil, $ttl, $sub));
}

=head2 S<setAbbr([$abbr])>

This macro changes the module abbreviation. It remains unchanged if the
specified abbreviation does not start with a letter followed by alphanumerical
characters or when it is undefined.

It returns the previous abbreviation.

=cut

sub _m_setAbbr
{ my ($slf, $ctx, $abr) = @_;
  my ($old, $top);

  $top = $ctx->get_top;
  $old = $top->{'_abr'};
  $top->{'_abr'} = $abr if defined($abr) && $abr =~ s/^([A-Z]\w*?)\_*$/$1_/i;
  RDA::Value->new('T', $old);
}

=head2 S<setDebug([$flg])>

This macro enables or disables the debug mode. It remains unchanged if the flag
is undefined.

It returns the previous flag setting.

=cut

sub _m_setDebug
{ my ($slf, $ctx, $flg) = @_;
  my ($old, $top);

  $top = $ctx->get_top;
  $old = $top->{'_dbg'};
  $top->{'_dbg'} = $flg if defined($flg);
  $old ? $VAL_ONE : $VAL_ZERO;
}

=head2 S<setShare($id[,$flag])>

This macro creates a link to the specified shared file and returns its current
name. When the flag is set, the original file extension is preserved.

=cut

sub _m_setShare
{ my ($slf, $ctx, $id, $flg) = @_;
  my $fil;

  return $VAL_UNDEF unless ($fil = $ctx->get_top->{'_ctl'}->set_share($id));
  $fil =~ s/\.(dat|txt)$/.htm/i unless $flg;
  RDA::Value->new('T', $fil);
}

=head2 S<setTrace([$lvl])>

This macro sets the trace level:

=over 8

=item B<    0  > No trace

=item B<    1  > Trace the command execution.

=item B<    2  > Trace the variable assignment also.

=back

The level is unchanged if the new level is not defined.

It returns the previous trace level.

=cut

sub _m_setTrace
{ my ($slf, $ctx, $lvl) = @_;
  my ($old, $top);

  $top = $ctx->get_top;
  $old = $top->{'_trc'};
  $top->{'_trc'} = $lvl if defined($lvl);
  RDA::Value->new('N', $old);
}

=head2 S<slock($nam[,$flag])>

This macro takes a share lock. When the flag is set, it does not wait until the
lock is available. It returns true for success and false for failure.

=cut

sub _m_slock
{ my ($slf, $ctx, $nam, $flg) = @_;
  my ($ret, $top);

  if ($nam)
  { $top = $ctx->get_top;
    $nam = $top->{'_grp'}.$top->{'_abr'}.$nam;
    eval {
      require RDA::Lock;
      $ret = RDA::Lock::slock($top->{'_agt'}, $nam, $flg);
    };
  }
  $ret ? $VAL_ONE : $VAL_ZERO;
}

=head2 S<testOutput()>

This macro determines if files can be created and removed from the report
directory. It creates the directory if it does not exist already. It returns
an error message in case of a problem, or an undefined value on successful
completion.

=cut

sub _m_testOutput
{ my ($slf, $ctx) = @_;
  my ($cnt, $pth, $top);

  # Test if the report group is compatible with basename constraint
  $top = $ctx->get_top;
  return RDA::Value->new(
    'T',
    "RDA-00237: The output file prefix is too long\n"
    ) if length($top->{'_grp'}) + 11 > $top->{'_bas'};

  # Create the output directory when needed
  return RDA::Value->new(
    'T',
    "RDA-00200: Cannot create the report directory $pth:\n $!\n"
    ) unless -d ($pth = $top->{'_rpt'}) || mkdir($pth, 0770);

  # Try to create a test file
  $pth = File::Spec->catfile($pth, $top->{'_grp'}.'__test.txt');
  return RDA::Value->new(
    'T',
    "RDA-00204: Cannot create a test file in the report directory:\n $!\n"
    ) unless open(TST, ">$pth");
  close(TST);

  # Unlink the file
  $cnt = 0;
  ++$cnt while unlink($pth);
  return RDA::Value->new(
    'T',
    "RDA-00205: Cannot remove the test file from the report directory:\n $!\n"
    ) unless $cnt;

  # Indicate a successful completion
  $VAL_UNDEF;
}

=head2 S<unlock($nam)>

This macro releases the specified lock. It returns true for success and  false
for failure.

=cut

sub _m_unlock
{ my ($slf, $ctx, $nam) = @_;
  my ($ret, $top);

  if ($nam)
  { $top = $ctx->get_top;
    $nam = $top->{'_grp'}.$top->{'_abr'}.$nam;
    eval {
      require RDA::Lock;
      $ret = RDA::Lock::unlock($top->{'_agt'}, $nam);
    };
  }
  $ret ? $VAL_ONE : $VAL_ZERO;
}

1;

__END__

=head1 SEE ALSO

See also L<RDA::Agent|RDA::Agent>, L<RDA::Daemon|RDA::Daemon>,
L<RDA::Discover|RDA::Discover>, L<RDA::Extra|RDA::Extra>,
L<RDA::Filter|RDA::Filter>, L<RDA::Lock|RDA::Lock>,
L<RDA::Log|RDA::Log>, L<RDA::Module|RDA::Module>,
L<RDA::Output|RDA::Output>, L<RDA::Pod|RDA::Pod>,
L<RDA::Profile|RDA::Profile>, L<RDA::Remote|RDA::Remote>,
L<RDA::Render|RDA::Render>, L<RDA::Setting|RDA::Setting>,
L<RDA::Upgrade|RDA::Upgrade>, L<RDA::Value|RDA::Value>,
L<RDA::Web|RDA::Web>.

=head1 COPYRIGHT NOTICE

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