# Context.pm: Class Used for Managing Execution Context

package RDA::SDCL::Context;

# $Id: Context.pm,v 1.9 2015/04/29 13:57:38 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/SDCL/Context.pm,v 1.9 2015/04/29 13:57:38 RDA Exp $
#
# Change History
# 20150425  MSC  Improve the tracing.

=head1 NAME

RDA::SDCL::Context - Class Used for Managing Execution Context

=head1 SYNOPSIS

 require RDA::SDCL::Context;

=head1 DESCRIPTION

The objects of the C<RDA::SDCL::Context> class are used to manage execution
context for collect specifications.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use RDA::Text qw(debug debug_object get_string);
  use RDA::Object;
  use RDA::SDCL::Block;
  use RDA::SDCL::Value qw($VALUE);
  use RDA::Value::Array;
  use RDA::Value::Assoc;
  use RDA::Value::Hash;
  use RDA::Value::List;
  use RDA::Value::Scalar qw(:value new_number);
}

# Define the global public variables
use vars qw($STRINGS $VERSION @ISA);
$VERSION = sprintf('%d.%02d', q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/);
@ISA     = qw(RDA::Object Exporter);

# Define the global private constants
my $OFF = q{  };

# Define the global private variables
my %tb_get = (
  'err' => \&_get_internal,
  'hit' => \&_get_internal,
  'val' => \&_get_internal,
  );
my %tb_int = (
  'err' => 'error',
  'hit' => 'matches',
  'val' => 'last',
  );
my %tb_set = (
  'err' => \&_set_internal,
  'hit' => \&_set_internal,
  'val' => \&_set_internal,
  );

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

=head2 S<$h = RDA::SDCL::Context-E<gt>new([$flag])>

The object constructor. It takes the output suppression indicator as an
argument.

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

The object constructor. It takes the parent context reference as an argument.

The following special keys are used:

=over 12

=item S<    B<'err' > > Last eval error

=item S<    B<'hit' > > Last match results

=item S<    B<'nam' > > Loop name

=item S<    B<'slf' > > Class attribute hash

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

=item S<    B<'val' > > Last value

=item S<    B<'_blk'> > Current calling block

=item S<    B<'_cnd'> > Condition hash

=item S<    B<'_flg'> > Activity indicator

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

=item S<    B<'_int'> > Internal variable definition

=item S<    B<'_nam'> > Named block definition hash

=item S<    B<'_out'> > Output suppression indicator

=item S<    B<'_par'> > Reference to the parent context

=item S<    B<'_pre'> > Trace prefix

=item S<    B<'_stk'> > Context stack

=item S<    B<'_top'> > Reference to the top context

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

=item S<    B<'_val'> > Last assigned value

=item S<    B<'_var'> > Variable definition hash

=back

Internal keys are prefixed by an underscore.

=cut

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

  if (ref($cls))
  { # Create the backup context object
    $slf = bless {
      err  => $cls->{'err'},
      hit  => $cls->{'hit'},
      trc  => $cls->{'trc'},
      val  => $cls->{'val'},
      _blk => $cls->{'_blk'},
      _cnd => $cls->{'_cnd'},
      _int => $cls->{'_int'},
      _pre => $cls->{'_pre'},
      _trc => $cls->{'_trc'},
      _var => $cls->{'_var'},
      }, ref($cls);

    # Update the context
    $cls->{'_cnd'} = {};
    $cls->{'_val'} = 0;
    $cls->{'_var'} =
      {map {$_ => $slf->{'_var'}->{$_}} keys(%{$cls->{'_glb'}})};
  }
  else
  { # Create the context object
    $slf = bless {
      err  => RDA::Value::List->new,
      hit  => RDA::Value::List->new,
      trc  => 0,
      val  => $VAL_UNDEF,
      _flg => 0,
      _glb => {},
      _nam => {},
      _stk => [],
      _trc => 0,
      _val => 0,
      _var => {},
      }, $cls;

    # Chain the contexts
    if (ref($par))
    { $slf->{'_par'} = $par;
      $slf->{'_top'} = $par->{'_top'};
    }
    else
    { $slf->{'_out'} = $par ? 1 : 0;
      $slf->{'_pre'} = 'TRACE';
      $slf->{'_top'} = $slf;
    }

    # Predefine default internal variables
    _init_internal($slf);
  }

  # Return the object reference
  return $slf;
}

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

This method deletes the object.

=cut

sub delete_object
{ undef %{$_[0]};
  undef $_[0];
  return;
}

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

This method returns the current calling block.

=cut

sub get_current
{ return shift->{'_blk'};
}

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

This method returns the variable dictionary.

=cut

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

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

This method returns a reference to the top context.

=cut

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

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

=head2 S<$h-E<gt>pop_context($block[,$parent])>

This method restores a previous context. When there is no previous context, it
deactivates the context.

=cut

sub pop_context
{ my ($slf, $blk, $par) = @_;
  my ($bkp);

  if (ref($bkp = pop(@{$slf->{'_stk'}})))
  { # Update kept variables
    foreach my $nam (keys(%{$slf->{'_glb'}}))
    { $bkp->{'_var'}->{$nam} = $slf->{'_var'}->{$nam};
    }

    # Restore the previous context (recursive context)
    $slf->{'err'} = $bkp->{'err'};
    $slf->{'hit'} = $bkp->{'hit'};
    $slf->{'trc'} = $bkp->{'trc'};
    $slf->{'val'} = $bkp->{'val'};
    $slf->{'_blk'} = $bkp->{'_blk'};
    $slf->{'_cnd'} = $bkp->{'_cnd'};
    $slf->{'_int'} = $bkp->{'_int'};
    $slf->{'_pre'} = $bkp->{'_pre'};
    $slf->{'_trc'} = $bkp->{'_trc'};
    $slf->{'_val'} = 0;
    $slf->{'_var'} = $bkp->{'_var'};

    # Delete the backup
    $bkp->delete_object;
  }
  else
  { # Clear the context
    $slf->{'_cnd'} = {};

    # Clear the internal variables
    $slf->{'hit'} = RDA::Value::List->new;

    # Delete the local variables
    foreach my $nam (keys(%{$slf->{'_var'}}))
    { delete($slf->{'_var'}->{$nam})
        unless exists($slf->{'_glb'}->{$nam});
    }

    # Transfer library context information
    if (ref($par))
    { my ($cnt, $ctx, $def, $dst, $src, $val, %tbl);

      # Determine the macros to reset
      ## no critic (Interpolation)
      %tbl = map {$_ => 0}
        $slf->{'_var'}->{'@RESET_MACROS'}->{'val'}->eval_as_array
        if exists($slf->{'_var'}->{'@RESET_MACROS'});

      # Share macros
      if (exists($slf->{'_var'}->{'@SHARE_MACROS'}))
      { $cnt = 0;
        $dst = $par->get_lib;
        $src = $blk->get_lib;
        $val = $slf->{'_var'}->{'@SHARE_MACROS'}->{'val'};
        foreach my $itm ($val->eval_as_array)
        { next unless $itm && ($def = $dst->share($src, $itm));
          if (exists($tbl{$itm}))
          { $ctx = $def->get_context;
            $ctx->{'_glb'} = {};
            $ctx->{'_var'} = {};
          }
          ++$cnt;
        }

        # Force to keep the block when macros are shared
        $slf->{'_var'}->{'$KEEP_BLOCK'}->{'val'} = $VAL_UNDEF if $cnt;
      }

      # Copy internal variables
      $par->{'ctx'}->{'err'} = $slf->{'err'};
      $par->{'ctx'}->{'val'} = $slf->{'val'};
    }

    # Make the context inactive
    $slf->{'_flg'} = 0;
  }
  return;
}

=head2 S<$h-E<gt>push_context($block,$parent[,$level])>

This method activates a context or takes a backup of the current context to
enable recursive calls.

=cut

sub push_context
{ my ($slf, $blk, $par, $flg) = @_;

  if ($slf->{'_flg'})
  { # Backup the context
    push(@{$slf->{'_stk'}}, $slf->new);
  }
  else
  { # Make the context active
    $slf->{'_flg'} = 1;
  }
  if (ref($par))
  { $slf->{'_par'} = $par if $flg;
    $slf->{'_trc'} = ($slf->{'trc'} = $par->{'trc'}) > 1;
  }
  $slf->{'_blk'} = $blk;
  $slf->{'_val'} = 0;
  _init_internal($slf);

  # Return the context reference
  return $slf;
}

=head1 CONDITION MANAGEMENT METHODS

=head2 S<$h-E<gt>end_cond($name)>

This method retrieves the condition value and stores a true value for next
queries.

=cut

sub end_cond
{ my ($slf, $nam) = @_;
  my ($val);

  $val = $slf->{'_cnd'}->{$nam};
  $slf->{'_cnd'}->{$nam} = 1;
  return $val;
}

=head2 S<$h-E<gt>get_cond($name)>

This method retrieves the condition value.

=cut

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

  return $slf->{'_cnd'}->{$nam};
}

=head2 S<$h-E<gt>set_cond($name,$flag)>

This method stores a condition value.

=cut

sub set_cond
{ my ($slf, $nam, $val) = @_;

  return $slf->{'_cnd'}->{$nam} = $val;
}

=head1 NAMED BLOCK MANAGEMENT METHODS

=head2 S<$h-E<gt>find_code($name)>

This method finds the definition of a named block. It returns an undefined
value when no definitions are found.

=cut

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

  while (ref($slf) eq __PACKAGE__)
  { return $slf->{'_nam'}->{$nam} if exists($slf->{'_nam'}->{$nam});
    $slf = $slf->{'_par'};
  }
  return;
}

=head2 S<$h-E<gt>set_code($name)>

This method defines a named block. It returns the context reference.

=cut

sub set_code
{ my ($slf, $nam, $def) = @_;

  $slf->{'_nam'}->{$nam} = $def;
  return $slf;
}

=head1 VARIABLE MANAGEMENT METHODS

=head2 S<$h-E<gt>check_variable($name)>

This method indicates whether the specified variable is defined.

=cut

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

  return exists($slf->{'_var'}->{$nam});
}

=head2 S<$h-E<gt>delete_variable($name)>

This method deletes the specified variable. It returns its previous content or
an undefined value when the variable does not exists.

=cut

sub delete_variable
{ my ($slf, $nam, $flg) = @_;
  my ($val);

  # Check if the variable exists
  unless (exists($slf->{'_var'}->{$nam}))
  { return () if $flg;
    return $VAL_UNDEF;
  }

  # Delete the variable and return its previous value
  $val = $slf->{'_var'}->{$nam}->{'val'};
  _trace_warning($slf, get_string('Deleted', $nam)) if $slf->{'_trc'};
  delete($slf->{'_glb'}->{$nam});
  delete($slf->{'_var'}->{$nam});
  return $val;
}

=head2 S<$h-E<gt>get_content($name[,$flag])>

This method returns the current value of the specified variable. It follows
the pointers to get the effective value. When the flag is set, it creates
nonexistent variables. Otherwise, it returns an undefined value.

=cut

sub get_content
{ my ($slf, $nam, $flg, $typ) = @_;
  my ($dic, $val);

  # Create the variable when not yet defined
  $dic = $slf->{'_var'};
  unless (exists($dic->{$nam}))
  { _trace_warning($slf, get_string('Undefined', $nam)) if $slf->{'_trc'};
    return $flg
      ? [$slf, $nam,
         $dic->{$nam}->{'val'} = $slf->get_default($typ || $nam), $dic]
      : undef;
  }

  # Follow the pointers to return the variable value
  $val = $dic->{$nam}->{'val'};
  return $val->is_pointer ? [_resolve_pointer($val)] : [$slf, $nam, $val, $dic];
}

sub _resolve_pointer
{ my ($val) = @_;
  my ($ctx, $dic, $nam, %tbl);

  while ($val->is_pointer)
  { $ctx = $val->{'ctx'};
    $dic = exists($val->{'dic'}) ? $val->{'dic'} : $val->{'ctx'}->{'_var'};
    $nam = $val->{'nam'};
    die get_string('POINTER_LOOP')      if $tbl{$dic.$nam}++;
    die get_string('POINTER_DEF', $nam) unless exists($dic->{$nam});
    $val = $dic->{$nam}->{'val'};
  }
  return ($ctx, $nam, $val, $dic);
}

=head2 S<$h-E<gt>get_default($name)>

This method returns the default value for the specified variable name.

=cut

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

  return $VAL_UNDEF             if $nam =~ m/^\.?\$/;
  return RDA::Value::List->new  if $nam =~ m/^\@/;
  return RDA::Value::Hash->new  if $nam =~ m/^\%/;
  return RDA::Value::Array->new if $nam =~ m/^\.\@/;
  return RDA::Value::Assoc->new if $nam =~ m/^\.\%/;
  die get_string('BAD_TYPE', $nam);
}

=head2 S<$h-E<gt>get_object($name)>

This method returns the current value of the specified global object. It
returns an undefined value when the global object is not defined.

=cut

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

  $slf = $slf->get_top;
  return exists($slf->{'_var'}->{$nam})
    ? $slf->{'_var'}->{$nam}->{'val'}
    : $VAL_UNDEF;
}

=head2 S<$h-E<gt>get_value($name[,$flag])>

This method returns the current value of the specified variable. When the flag
is set, it creates nonexistent variables. Otherwise, it returns an undefined
value.

=cut

sub get_value
{ my ($slf, $nam, $flg, $typ) = @_;

  # Create the variable when not yet defined
  unless (exists($slf->{'_var'}->{$nam}))
  { _trace_warning($slf, get_string('Undefined', $nam)) if $slf->{'_trc'};
    return $flg
      ? $slf->{'_var'}->{$nam}->{'val'} = $slf->get_default($typ || $nam)
      : $slf->get_default($nam);
  }

  # Return the variable value
  return $slf->{'_var'}->{$nam}->{'val'};
}

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

This method imports variables from previous contexts.

=cut

sub import_variables
{ my ($slf, @arg) = @_;
  my ($ctx, $dic, $trc);

  $dic = $slf->{'_var'};
  $trc = $slf->{'_trc'};
  foreach my $nam (@arg)
  { # Skip already defined variable
    next if exists($dic->{$nam});

    # Search in previous contexts
    $ctx = $slf;
    while (exists($ctx->{'_par'}))
    { $ctx = $ctx->{'_par'};
      if (exists($ctx->{'_var'}->{$nam}))
      { $dic->{$nam} = $ctx->{'_var'}->{$nam};
        _trace_value($slf, $nam, $dic->{$nam}->{'val'}) if $trc;
        last;
      }
    }
  }
  return;
}

=head2 S<$h-E<gt>incr_value($name,$num)>

This method increments the specified variable and returns the new value.

=cut

sub incr_value
{ my ($slf, $nam, $val) = @_;
  my ($dic, $trc, $var);

  # Reject non scalar variable
  die get_string('BAD_INCR', $nam) unless $nam =~ m/^\$/;

  # Increment the variable and return the new value
  $dic = $slf->{'_var'};
  $trc = $slf->{'_trc'};
  if (exists($dic->{$nam}))
  { $var = $dic->{$nam}->{'val'};
    ($slf, $nam, $var, $dic) = _resolve_pointer($var) if $var->is_pointer;
    $val += $var->eval_as_number;
  }
  else
  { _trace_warning($slf, get_string('Undefined', $nam)) if $trc;
  }
  $val = new_number($val);
  _trace_value($slf, $nam, $val) if $trc;
  return $dic->{$nam}->{'val'} = $slf->{'_val'} = $val;
}

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

This method keeps specified variables in next calls. Missing variables are
created.

=cut

sub keep_variables
{ my ($slf, @arg) = @_;
  my ($dic, $glb, $trc);

  $dic = $slf->{'_var'};
  $glb = $slf->{'_glb'};
  $trc = $slf->{'_trc'};
  foreach my $nam (@arg)
  { $glb->{$nam} = 1;
    next if exists($dic->{$nam});
    $dic->{$nam}->{'val'} = $slf->get_default($nam);
    _trace_value($slf, $nam, $dic->{$nam}->{'val'}) if $trc;
  }
  return;
}

=head2 S<$h-E<gt>set_object($name,$value)>

This method defines a global object.

=cut

sub set_object
{ my ($slf, $nam, $val, $flg) = @_;

  # Validate the value
  if (defined($val))
  { $val = RDA::Value::Scalar::new_object($val)
      unless ref($val) =~ $VALUE;
    die get_string('INCOMPATIBLE')
      if ($nam =~ m/^@/ xor ref($val) eq 'RDA::Value::List')
      || ($nam =~ m/^%/ xor ref($val) eq 'RDA::Value::Hash');
  }
  else
  { $val = $slf->get_default($nam);
  }

  # Define the global object
  $slf = $slf->get_top;
  $slf->{'_glb'}->{$nam} = -1;
  _trace_value($slf, $nam, $val) if $slf->{'_trc'} && !$flg;
  return $slf->{'_var'}->{$nam}->{'val'} = $slf->{'_val'} = $val;
}

=head2 S<$h-E<gt>set_value($name,$value)>

This method provides a new value for the specified variable.

=cut

sub set_value
{ my ($slf, $nam, $val) = @_;

  _trace_value($slf, $nam, $val) if $slf->{'_trc'};
  return $slf->{'_var'}->{$nam}->{'val'} = $slf->{'_val'} = $val;
}

=head2 S<$h-E<gt>share_variable($name,$reference)>

This method shares a variable between two contexts.

=cut

sub share_variable
{ my ($slf, $nam, $ref) = @_;
  my ($dic);

  # Validate the arguments
  die get_string('BAD_REF')
    unless ref($ref) && $ref->is_pointer;
  die get_string('INCOMPATIBLE')
    unless substr($nam, 0, 1) eq substr($ref->{'nam'}, 0, 1);

  # Create the variable when not yet defined
  $dic = exists($ref->{'dic'}) ? $ref->{'dic'} : $ref->{'ctx'}->{'_var'};
  $ref = $ref->{'nam'};
  $dic->{$ref}->{'val'} = $slf->get_default($ref)
    unless exists($dic->{$ref});
  $ref = $dic->{$ref};

  # Share the variables
  _trace_value($slf, $nam, $ref->{'val'}) if $slf->{'_trc'};
  return $slf->{'_var'}->{$nam} = $ref;
}

=head1 INTERNAL VARIABLE MANAGEMENT METHODS

=head2 S<$h-E<gt>define_internal($abbr,$name[,$object[,$get[,$set]]])>

This method defines an internal variable.

=cut

sub define_internal
{ my ($slf, $abr, $nam, $obj, $get, $set) = @_;

  # Validate the arguments
  die get_string('BAD_ABBR', $abr) unless $abr && $abr =~ m/^[A-Za-z]\w*$/;
  $obj = $slf                                       unless ref($obj);
  ($get, $set) = (\&_get_internal, \&_set_internal) unless ref($get) eq 'CODE';
  $set = \&_set_error                               unless ref($set) eq 'CODE';

  # Define the internal variable
  return $slf->{'_int'}->{$abr} = [$nam, $obj, $set, $get];
}

=head2 S<$h-E<gt>delete_internal($abbr)>

This method deletes an internal variable definition.

=cut

sub delete_internal
{ my ($slf, $abr) = @_;

  return delete($slf->{'_int'}->{$abr});
}

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

  return $slf->{'_int'} =
    {map {$_ => [$tb_int{$_}, $slf, $tb_set{$_}, $tb_get{$_}]} keys(%tb_int)};
}

=head2 S<$h-E<gt>get_internal($abbr)>

This method returns the current value of the specified internal variable.

=cut

sub get_internal
{ my ($slf, $abr) = @_;
  my ($rec);

  die get_string('BAD_INTERNAL', $abr) unless exists($slf->{'_int'}->{$abr});
  $rec = $slf->{'_int'}->{$abr};
  return &{$rec->[3]}($rec->[1], $abr);
}

sub _get_internal
{ my ($slf, $abr) = @_;

  return $slf->{$abr};
}

=head2 S<$h-E<gt>set_internal($abbr,$value)>

This method modifies the value of an internal variable.

=cut

sub set_internal
{ my ($slf, $abr, $val) = @_;
  my ($rec);

  die get_string('BAD_INTERNAL', $abr) unless exists($slf->{'_int'}->{$abr});
  $rec = $slf->{'_int'}->{$abr};
  if ($slf->{'_trc'})
  { if ($val == $slf->{'_val'})
    { _trace_warning($slf, get_string('Same', $rec->[0]));
    }
    else
    { _trace_value($slf, $rec->[0], $val)
    }
  }
  return &{$rec->[2]}($rec->[1], $abr, $val);
}

sub _set_error
{ my ($slf, $abr) = @_;

  die get_string('SET_INTERNAL', $slf->{'_int'}->{$abr}->[0]);
}

sub _set_internal
{ my ($slf, $abr, $val) = @_;

  return $slf->{$abr} = $val;
}

=head2 S<$h-E<gt>set_last($value)>

This method specifies the last assigned value.

=cut

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

  return $slf->{'_val'} = $val;
}

=head1 TRACE MANAGEMENT METHODS

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

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

=cut

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

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

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

This method returns the current trace level.

=cut

sub get_trace
{ return shift->{'trc'};
}

=head2 S<$h-E<gt>set_prefix($text)>

This method specifies a new trace prefix in the package context and returns its
previous value.

=cut

sub set_prefix
{ my ($slf, $txt) = @_;

  $slf = $slf->{'_top'};
  ($slf->{'_pre'}, $txt) = ($txt, $slf->{'_pre'});
  return $txt;
}

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

This method specifies a new trace level for the current context and returns its
previous value.

=cut

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

  return 0 if $slf->{'_top'}->{'_out'};
  $slf->{'_trc'} = $lvl > 1;
  ($slf->{'trc'}, $lvl) = ($lvl, $slf->{'trc'});
  return $lvl;
}

=head2 S<$h-E<gt>trace($string...)>

This method adds a line into the trace.

=cut

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

  debug($slf->{'_top'}->{'_pre'}.q{:}, @arg);
  return;
}

=head2 S<$h-E<gt>trace_data($text,$data)>

This method dumps the data into the trace when the variable tracing is enabled.

=cut

sub trace_data
{ my ($slf, $txt, $val) = @_;

  debug(RDA::Object::dump_data($val, 1,
    $slf->{'_top'}->{'_pre'}.q{/}.$txt.': ')) if $slf->{'_trc'};
  return;
}

=head2 S<$h-E<gt>trace_value($text,$value)>

This method dumps the value into the trace when the variable tracing is
enabled.

=cut

sub trace_value
{ my ($slf, $txt, $val) = @_;

  debug_object($val, 1, $slf->{'_top'}->{'_pre'}.q{/}.$txt.': ')
    if $slf->{'_trc'};
  return;
}

sub _trace_value
{ my ($slf, $txt, $val) = @_;

  debug_object($val, 1, $slf->{'_top'}->{'_pre'}.q{/}.$txt.': ');
  return;
}

=head2 S<$h-E<gt>trace_warning($string...)>

This method adds a warning line into the trace when the variable tracing is
enabled.

=cut

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

  debug($OFF.$slf->{'_top'}->{'_pre'}.q{:}, @arg) if $slf->{'_trc'};
  return;
}

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

  debug($OFF.$slf->{'_top'}->{'_pre'}.q{:}, @arg);
  return;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::SDCL::Block|RDA::SDCL::Block>,
L<RDA::SDCL::Value|RDA::SDCL::Value>,
L<RDA::Text|RDA::Text>

=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