# String.pm: Class Used for String Macros

package RDA::Library::String;

# $Id: String.pm,v 1.25 2015/10/06 11:29:13 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Library/String.pm,v 1.25 2015/10/06 11:29:13 RDA Exp $
#
# Change History
# 20151006  MSC  Add the difftimes and times macros.

=head1 NAME

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

=head1 SYNOPSIS

 require RDA::Library::String;

=head1 DESCRIPTION

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

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use RDA::Text qw(get_string);
  use RDA::Object;
  use RDA::Object::Message;
  use RDA::Object::Rda;
  use RDA::Object::View;
  use RDA::Driver::Sgml;
  use RDA::Value::List;
  use RDA::Value::Scalar qw(:value);
}

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

# Define the global private constants

# Define the global private variables
my %tb_fct = (
  'bind'      => [\&_m_bind,      'T'],
  'bindDb'    => [\&_m_bind,      'T'],
  'bindSql'   => [\&_m_bind,      'T'],
  'chomp'     => [\&_m_chomp,     'T'],
  'compare'   => [\&_m_compare,   'N'],
  'concat'    => [\&_m_concat,    'T'],
  'decode'    => [\&_m_decode,    'T'],
  'difftime'  => [\&_m_difftime,  'N'],
  'difftimes' => [\&_m_difftimes, 'L'],
  'digest'    => [\&_m_digest,    'T'],
  'encode'    => [\&_m_encode,    'T'],
  'field'     => [\&_m_field,     'T'],
  'gmtime'    => [\&_m_gmtime,    'T'],
  'hex2chr'   => [\&_m_hex2chr,   'T'],
  'hex2dec'   => [\&_m_hex2dec,   'T'],
  'hex2int'   => [\&_m_hex2int,   'N'],
  'id'        => [\&_m_id,        'T'],
  'index'     => [\&_m_index,     'N'],
  'join'      => [\&_m_join,      'T'],
  'key'       => [\&_m_key,       'T'],
  'lc'        => [\&_m_lc,        'T'],
  'length'    => [\&_m_length,    'N'],
  'localtime' => [\&_m_localtime, 'T'],
  'm'         => [\&_m_m,         'X'],
  'match'     => [\&_m_match,     'X'],
  'mktime'    => [\&_m_mktime,    'N'],
  'oct2int'   => [\&_m_oct2int,   'N'],
  'pack'      => [\&_m_pack,      'T'],
  'repeat'    => [\&_m_repeat,    'T'],
  'replace'   => [\&_m_replace,   'T'],
  'rindex'    => [\&_m_rindex,    'N'],
  's'         => [\&_m_subst,     'T'],
  'shell'     => [\&_m_shell,     'T'],
  'split'     => [\&_m_split,     'L'],
  'sprintf'   => [\&_m_sprintf,   'T'],
  'substr'    => [\&_m_substr,    'T'],
  'time'      => [\&_m_time,      'T'],
  'times'     => [\&_m_times,     'L'],
  'tput'      => [\&_m_tput,      'T'],
  'translate' => [\&_m_translate, 'T'],
  'trim'      => [\&_m_trim,      'T'],
  'uc'        => [\&_m_uc,        'T'],
  'ucfirst'   => [\&_m_ucfirst,   'T'],
  'unpack'    => [\&_m_unpack,    'L'],
  'value'     => [\&_m_value,     'T'],
  'verbatim'  => [\&_m_verbatim,  'T'],
  'version'   => [\&_m_version,   'T'],
  );
my %tb_mon = (
  'jan' => 0,
  'feb' => 1,
  'mar' => 2,
  'apr' => 3,
  'may' => 4,
  'jun' => 5,
  'jul' => 6,
  'aug' => 7,
  'sep' => 8,
  'oct' => 9,
  'nov' => 10,
  'dec' => 11,
  );
my %tb_pre = (
  'b' => q{\b},  ## no critic (Interpolation)
  'e' => q{^},
  );
my %tb_suf = (
  'b' => q{\b},  ## no critic (Interpolation)
  'e' => q{$},
  );
my %tb_sys = (
  's' => 0,
  'n' => 1,
  'r' => 2,
  'v' => 3,
  'm' => 4,
  );

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

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

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

C<RDA::Library::String> 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<'_col'> > Reference to the collector object

=item S<    B<'_id' > > User identification

=item S<    B<'_not'> > Statistics note

=item S<    B<'_out'> > Number of operating system requests timed out

=item S<    B<'_req'> > Number of operating system requests

=item S<    B<'_sys'> > Reference to the system view object

=item S<    B<'_tc' > > Terminal capability hash

=item S<    B<'_tim'> > Time references

=item S<    B<'_usr'> > User name

=back

Internal keys are prefixed by an underscore.

=cut

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

  # Create the macro object
  $agt = $col->get_agent;
  $slf = bless {
    _agt => $agt,
    _out => 0,
    _req => 0,
    _sys => $agt->get_system,
    _tim => [0, 0, 0, 0, time],
    }, ref($cls) || $cls;

  # Setup some parameters by default
  eval {
    local $SIG{'__WARN__'} = sub {};
    require Term::Cap;
    my $trm = Term::Cap->Tgetent({TERM => undef, OSPEED => 15});
    $slf->{'_tc'}->{'bell'}    = $trm->Tputs('bl', 1);
    $slf->{'_tc'}->{'bold'}    = $trm->Tputs('mb', 1);
    $slf->{'_tc'}->{'clear'}   = $trm->Tputs('cl', 1);
    $slf->{'_tc'}->{'home'}    = $trm->Tputs('ho', 1);
    $slf->{'_tc'}->{'off'}     = $trm->Tputs('me', 1);
    $slf->{'_tc'}->{'reverse'} = $trm->Tputs('mr', 1);
  };

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

  # 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>clr_stats>

This method resets the statistics. It creates a setting to indicate when the
module was executed for the last time.

=cut

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

  $slf->{'_not'} = q{};
  $slf->{'_req'} = $slf->{'_out'} = 0;
  return;
}

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

This method deletes the library control object.

=cut

sub delete_object
{ RDA::Object::dump_caller($_[0], 'Library') if $RDA::Object::DELETE;
  undef %{$_[0]};
  undef $_[0];
  return;
}

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

This method reports the library statistics in the specified module.

=cut

sub get_stats
{ my ($slf) = @_;
  my ($use);

  if ($slf->{'_req'})
  { $use = $slf->{'_col'}->get_usage;

    # Get the statistics record
    $use->{'OS'} = {not => q{}, out => 0, req => 0}
      unless exists($use->{'OS'});
    $use = $use->{'OS'};

    # Generate the module statistics
    $use->{'out'} += $slf->{'_out'};
    $use->{'req'} += $slf->{'_req'};
    $use->{'not'} = $slf->{'_not'} if $slf->{'_not'};

    # Clear statistics
    clr_stats($slf);
  }
  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->{'_col'} = $col;
  return $slf;
}

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

This method executes 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->eval_as_array) 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 STRING MACROS

=head2 S<bind($sql,$val...)>

This macro replaces the placeholders by the specified values. The placeholders
indicate code fragments in a database statement that will be supplied
later. The placeholders are numbered from 1 and begin with a C<:> character
(for example, C<:1>, C<:2>, and so on).

C<bindDb> and C<bindSql> are aliases.

=cut

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

  return _bind(@arg);
}

sub _bind
{ my ($sql, @arg) = @_;
  my ($cnt);

  foreach my $val (@arg)
  { ++$cnt;
    $sql =~ s/\:$cnt\b/$val/g if defined($val);
  }
  return $sql;
}

=head2 S<chomp($str)>

This macro removes the final end-of-line in the text string and returns the
resulting string.

=cut

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

  $str =~ s/[\r\n]+$// if defined($str);
  return $str;
}

=head2 S<compare($op,$str1,$str2)>

This macro compares the two specified strings. The supported operations are as
follows:

=for stopwords eq ge gt le lt ne

=over 14

=item S<    B<'eq' > > True if C<$str1> equals to C<$str2>

=item S<    B<'ne' > > True if C<$str1> differs from C<$str2>

=item S<    B<'lt' > > True if C<$str1> is less than C<$str2>

=item S<    B<'le' > > True if C<$str1> is less than or equals to C<$str2>

=item S<    B<'gt' > > True if C<$str1> is greater than C<$str2>

=item S<    B<'ge' > > True if C<$str1> is greater than or equals to C<$str2>

=item S<    B<'diff' >> True if C<$str1> represents a different version than
C<$str2>

=item S<    B<'final'>> True if C<$str1> is older than or the same version as
C<$str2>

=item S<    B<'newer'>> True if C<$str1> represents a newer version than
C<$str2>

=item S<    B<'older'>> True if C<$str1> represents an older version than
C<$str2>

=item S<    B<'same' >> True if C<$str1> represents the same version as
C<$str2>

=item S<    B<'valid'>> True if C<$str1> is newer than or the same version as
C<$str2>

=back

When the string operator is in upper case, the string comparison is case
insensitive.

When the version operator is in upper case, it limits the comparison to the
number of elements present in the reference.

=cut

## no critic (Numbered)
sub _m_compare  ## no critic (Complex)
{ my ($slf, $ctx, $op, $str1, $str2) = @_;

  if (defined($str1) && defined($str2))
  { return $str1 eq $str2 if $op eq 'eq' || $op eq q{==};
    return $str1 ne $str2 if $op eq 'ne' || $op eq q{!=};
    return $str1 lt $str2 if $op eq 'lt' || $op eq q{<};
    return $str1 le $str2 if $op eq 'le' || $op eq q{<=};
    return $str1 gt $str2 if $op eq 'gt' || $op eq q{>};
    return $str1 ge $str2 if $op eq 'ge' || $op eq q{>=};
    return lc($str1) eq lc($str2) if $op eq 'EQ';
    return lc($str1) ne lc($str2) if $op eq 'NE';
    return lc($str1) lt lc($str2) if $op eq 'LT';
    return lc($str1) le lc($str2) if $op eq 'LE';
    return lc($str1) gt lc($str2) if $op eq 'GT';
    return lc($str1) ge lc($str2) if $op eq 'GE';
    return _cmp_version($str1, $str2, 0) == 0 if $op eq 'SAME'  || $op eq q{V=};
    return _cmp_version($str1, $str2, 0) != 0 if $op eq 'DIFF'  || $op eq q{V!};
    return _cmp_version($str1, $str2, 0) <  0 if $op eq 'OLDER' || $op eq q{V<};
    return _cmp_version($str1, $str2, 0) <= 0 if $op eq 'FINAL' || $op eq q{V-};
    return _cmp_version($str1, $str2, 0) >  0 if $op eq 'NEWER' || $op eq q{V>};
    return _cmp_version($str1, $str2, 0) >= 0 if $op eq 'VALID' || $op eq q{V+};
    return _cmp_version($str1, $str2, 1) == 0 if $op eq 'same';
    return _cmp_version($str1, $str2, 1) != 0 if $op eq 'diff';
    return _cmp_version($str1, $str2, 1) <  0 if $op eq 'older';
    return _cmp_version($str1, $str2, 1) <= 0 if $op eq 'final';
    return _cmp_version($str1, $str2, 1) >  0 if $op eq 'newer';
    return _cmp_version($str1, $str2, 1) >= 0 if $op eq 'valid';
  }
  return 0;
}

# Compare versions
sub _cmp_version
{ my ($ver1, $ver2, $flg) = @_;
  my ($str1, $str2, $val);

  ($ver1, $str1) = split(/\//, $ver1, 2) if $ver1 ne q{};
  ($ver2, $str2) = split(/\//, $ver2, 2) if $ver2 ne q{};

  return $val if ($val = _cmp_ver($ver1, $ver2, $flg));
  if (defined($str2))
  { return -2 unless defined($str1) && lc($str1) eq lc($str2);
  }
  return 0;
}

sub _cmp_ver
{ my ($ver1, $ver2, $flg) = @_;
  my ($num2, @tbl);

  @tbl = split(/\./, $ver2);
  foreach my $num1 (split(/\./, $ver1))
  { return $flg unless defined($num2 = shift(@tbl));
    return $num1 <=> $num2 unless $num1 == $num2;
  }
  return (scalar @tbl) ? -1 : 0;
}
## use critic

=head2 S<concat($str,...)>

This macro concatenates all text strings specified as arguments into a new
text string. It ignores invalid arguments.

=cut

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

  return join(q{}, grep {defined($_) && !ref($_)} @_);
}

=head2 S<decode($str)>

This macro replaces entities found in the string with the corresponding ISO
8859-1 character. It ignores unrecognized entities.

=cut

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

  return defined($str) ? RDA::Driver::Sgml::decode($str) : undef;
}

=head2 S<difftime($time1,$time0)>

This macro returns the time difference (in seconds) between the two times (as
returned by C<mktime>).

=cut

sub _m_difftime
{ my ($slf, $ctx, $ctm, $rtm) = @_;
  my $dur;

  if (defined($rtm) && defined($ctm))
  { eval {
      require POSIX;
      $dur = POSIX::difftime($ctm, $rtm);  ## no critic (Call)
    };
    return $dur unless $@;
  }
  return;
}

=head2 S<difftimes()>

This macro returns a five-element list giving the differences since the last
call, in user and system times, for this process and the children of this
process and the elapsed time. All times are measured in seconds.

=cut

sub _m_difftimes
{ my ($slf) = @_;
  my ($new, $prv);

  $prv = $slf->{'_tim'};
  $slf->{'_tim'} = $new = [times, time];
  return ($new->[0] - $prv->[0], $new->[1] - $prv->[1],
          $new->[2] - $prv->[2], $new->[3] - $prv->[3],
          $new->[4] - $prv->[4]);
}

=head2 S<digest($str,...)>

=for stopwords Salvia

This macro returns a digest of its arguments using the Salvia algorithm.

=cut

sub _m_digest
{ my ($slf, $ctx, @arg) = @_;
  my ($off, $sum, @hsh);

  ## no critic (Bit)
  $sum = $off = 0;
  $hsh[0] = $hsh[1] = $hsh[2] = $hsh[3] = 0;
  foreach my $chr (unpack('c*', _m_join($slf, $ctx, q{:}, '0', @arg , 'RDA')))
  { $sum = ($sum + $hsh[$off]) % 15;
    $hsh[$off] = _rotate($chr, ($sum + $chr) % 15) ^ _rotate($hsh[$off], $sum);
    $off = ($off + 1) & 3;
  }
  return sprintf('%08X%08X%08X%08X', @hsh);
}

sub _rotate
{ my ($val, $off) = @_;

  ## no critic (Bit)
  return (($val << $off) & 0xffffffff) | (($val >> (32 - $off)) & 0xffffffff);
}

=head2 S<encode($str[,$flg])>

This macro replaces control characters, ISO 8859-1 or UTF-8 characters, and
some sensitive characters characters with their entity representation. Unless
the flag is set, it encodes Wiki (C<%>, C<'>, C<*>, C<[>, C<]>, C<^>, C<`>,
C<{>, C<}>, and C<|>) characters also.

=cut

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

  return defined($str) ? RDA::Driver::Sgml::encode($str, $flg) : undef;
}

=head2 S<field($re,$num,$str)>

This macro removes leading and trailing spaces from the string, splits it into
fields, and returns the specified field. Field numbers start at 0. You can use
negative field numbers to count the fields from the end.

=cut

sub _m_field
{ my ($slf, $ctx, $re, $num, $str) = @_;
  my $lim;

  return unless defined($re) && defined($num) && defined($str);
  $str =~ s/^\s+//;
  $str =~ s/\s+$//;
  $lim = ($num < 0) ? 0 : $num + 2;
  return (split(/$re/, $str, $lim))[$num];
}

=head2 S<gmtime([$format[,$time]])>

This macro returns the GMT time. You can specify a C<strftime(3)> format as an
argument.

=cut

sub _m_gmtime
{ my ($slf, $ctx, $fmt, $tim) = @_;
  my ($str, @tim);

  if ($fmt)
  { eval {
      require POSIX;
      @tim = gmtime(defined($tim) ? $tim : time);
      $tim[-1] = -1;
      $str = POSIX::strftime($fmt, @tim);  ## no critic (Call)
    };
    return $str unless $@;
  }
  return $str = gmtime(defined($tim) ? $tim : time);
}

=head2 S<hex2chr($str)>

This macro replaces all hexadecimal C<\0xXX> or octal C<\NNN> sequences in the
string with character representation.

=cut

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

  $str =~ s/\\([0-3][0-7]{2}|0x[0-9A-Fa-f]{2})/chr(oct($1))/eg if $str;
  return $str;
}

=head2 S<hex2dec($str)>

This macro replaces all hexadecimal numbers in the string with decimal
representation.

=cut

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

  $str =~ s{(0x[\da-fA-F]+)}{hex(lc($1))}eg if $str;
  return $str;
}

=head2 S<hex2int($str)>

This macro converts a string representing an hexadecimal number in a number.

=cut

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

  return hex($str);
}

=head2 S<id()>

This macro returns user and group identifiers. When it is not supported on a
platform, it returns the user name only.

=cut

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

  unless (exists($slf->{'_id'}))
  { eval {
      my ($id, $sep, $str, @grp);
      $id  = $>;
      $str = qq{uid=$id(}.getpwuid($id);
      @grp = split(/\s/, $));
      $id  = shift(@grp);
      $str .= qq{) gid=$id(}.getgrgid($id);
      $sep = q{) groups=};
      foreach my $alt (sort @grp)
      { $str .= $sep.$alt.q{(}.getgrgid($alt);
        $sep = q{),};
      }
      $str .= q{)};
      $slf->{'_id'} = $str;
    };
    if ($@)
    { $slf->{'_id'} = $slf->{'_col'}->get_config->get_user;
    }
  }

  return $slf->{'_id'};
}

=head2 S<index($str,$sub[,$off])>

This macro returns the position of the first occurrence of the substring in the
text string. The offset, when specified, indicates where to start looking. If
the substring is not found, it returns -1.

=cut

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

  $off = 0 unless defined($off);
  return (defined($str) && defined($sub)) ? index($str, $sub, $off) : -1;
}

=head2 S<join($sep,$str,...)>

This macro joins all text strings that are specified as arguments into a new
text string with the fields separated by the specified separator. It ignores
invalid arguments.

=cut

sub _m_join
{ my $slf = shift;
  my $ctx = shift;
  my $sep = shift;

  return join($sep, grep {defined($_) && !ref($_)} @_);
}

=head2 S<key($str)>

This macro extracts the key part of a string such as 'key=value'. It removes
leading and trailing spaces from the key.

=cut

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

  return unless defined($str);
  $str =~ s/^\s+//;
  $str =~ s/\s+$//;
  return (split(/\s*=\s*/, $str, 2))[0];
}

=head2 S<lc($str)>

This macro converts the specified text string to lower case.

=cut

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

  return defined($str) ? lc($str) : undef;
}

=head2 S<length($str)>

This macro returns the length of the specified text string. It returns an
undefined value for an undefined argument.

=cut

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

  return defined($str) ? length($str) : undef;
}

=head2 S<localtime([$format[,$time]])>

This macro returns the local time. You can specify a C<strftime(3)> format as
an argument.

=cut

sub _m_localtime
{ my ($slf, $ctx, $fmt, $tim) = @_;
  my $str;

  if ($fmt)
  { eval {
      require POSIX;
      ## no critic (Call)
      $str = POSIX::strftime($fmt, localtime(defined($tim) ? $tim : time));
    };
    return $str unless $@;
  }
  return $str = localtime(defined($tim) ? $tim : time);
}

=head2 S<match($str,$re[,$flg])>

This macro indicates whether the string matches the regular expression. When
the flag is set, it ignores case distinctions in both the pattern and the
string. It returns the match result as a list.

The match list is also accessible through the C<matches> internal variable.

=cut

sub _m_match
{ my ($slf, $ctx, $str, $pat, $flg) = @_;
  my (@hit);

  @hit = $str =~ RDA::Object::View->is_pattern($flg ? "$pat#i" : $pat)
    if defined($str) && $pat;
  return $ctx->get_context->set_internal('hit',
    RDA::Value::List::new_from_data(@hit));
}

sub _m_m
{ my ($slf, $ctx, $str, $pat) = @_;
  my ($opt, @hit);

  if (defined($str) && $pat)
  { $opt = ($pat =~ s/\#([igmsx]+)$//) ? $1 : q{};
    $pat = RDA::Object::View->is_re($pat);
    @hit = eval "\$str =~ m!\$pat!$opt";  ## no critic (Eval)
  }
  return $ctx->get_context->set_internal('hit',
    RDA::Value::List::new_from_data(@hit));
}

=head2 S<mktime(sec,min,hour,day,mon,year)>

=for stopwords mon

This macro converts date/time information to a calendar time. The month ("mon")
begins at zero (that is, January is 0, not 1). The year ("year") is given in
years since 1900 (that is, the year 1995 is 95; the year 2001 is 101).

It returns an undefined value on failure.

=cut

sub _m_mktime
{ my ($slf, $ctx, $sec, $min, $hr, $day, $mon, $yea) = @_;
  my ($tim, $wdy, $ydy);

  return unless defined($mon) && defined($yea);

  # Convert arguments
  $mon = $tb_mon{$mon} if exists($tb_mon{$mon = lc($mon)});
  $yea -= 1900         if $yea >= 1900;
  $wdy = $ydy = 0;

  # Convert the date/time
  eval {
    require POSIX;
    ## no critic (Call)
    eval {POSIX::tzset()};
    $tim = POSIX::mktime($sec, $min, $hr, $day, $mon, $yea, $wdy, $ydy, -1);
  };
  return $@ ? undef : $tim;
}

=head2 S<oct2int($str)>

This macro converts a string representing an octal number in a number.

=cut

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

  return oct($str);
}

=head2 S<pack($fmt,$arg,...)>

This macro takes a list of values and converts it into a string using the
rules specified by the template. The resulting string is the concatenation of
the converted values.

=cut

sub _m_pack
{ my $slf = shift;
  my $ctx = shift;
  my $fmt = shift;

  return pack($fmt, @_);
}

=head2 S<repeat($str[,$cnt])>

This macro repeats the string by the specified number (1 by default).

=cut

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

  return (defined($str) && defined($cnt)) ? $str x $cnt : $str;
}

=head2 S<replace($str,$re[,$str[,$flg]])>

This macro replaces the first occurrence of the C<$re> pattern by C<$str>. When
the flag is set, it replaces all occurrences.

=cut

## no critic (Numbered)
sub _m_replace
{ my ($slf, $ctx, $str, $re1, $re2, $flg) = @_;

  if (defined($str) && defined($re1))
  { $re2 = q{} unless defined($re2);
    if ($flg)
    { $str =~ s{$re1}{$re2}mg;
    }
    else
    { $str =~ s{$re1}{$re2}m;
    }
  }
  return $str;
}

sub _m_subst
{ my ($slf, $ctx, $str, $re1, $re2, $flg) = @_;
  my ($opt);

  if (defined($str) && defined($re1))
  { # Validate the replacement string
    if (defined($re2))
    { $re2 =~ s/\!/\\041/g;
      ($re2) = $re2 =~ m/^([^!]+)$/;
    }
    else
    { $re2 = q{};
    }

    # Do the replacement
    $opt = $flg ? 'gm' : 'm';
    $re1 =~ s/\!/\\041/g;
    if ($re1 =~ s/^([^!]+?)\#([igmsx]+)$//)
    { eval "\$str =~ s!$1!$re2!$opt$2"; ## no critic (Eval)
      die $@ if $@;
    }
    elsif ($re1 =~ m/^([^!]+)$/)
    { eval "\$str =~ s!$1!$re2!$opt"; ## no critic (Eval)
      die $@ if $@;
    }
  }
  return $str;
}
## use critic

=head2 S<rindex($str,$sub[,$off])>

This macro returns the position of the last occurrence of the substring in
the text string. The offset, when specified, is the rightmost position that
may be returned. If the substring is not found, it returns -1.

=cut

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

  return -1 unless defined($str) && defined($sub);
  return defined($off) ? rindex($str, $sub, $off) : rindex($str, $sub);
}

=head2 S<shell([$env])>

This macro returns the shell path, quoted as required by a command shell.
First, it attempts to deduce the path from the environment. Next, it attempts
to extract the login shell. To force a search for a specific environment
variable, provide the environment variable as an argument.

=cut

sub _m_shell
{ my ($slf, $ctx, $env) = @_;
  my ($shl);

  $env = RDA::Object::Rda->is_windows ? 'COMSPEC' : 'SHELL'
    unless defined($env);
  eval {$shl = (getpwuid($<))[8]}
    unless defined($shl = $slf->{'_sys'}->get_value($env));
  return (-f $shl) ? RDA::Object::Rda->quote($shl) : undef;
}

=head2 S<split($re,$str[,$num])>

This macro splits a string into fields. It is possible to limit the number of
fields.

=cut

sub _m_split
{ my ($slf, $ctx, $re, $str, $num) = @_;

  $num = 0 unless defined($num);
  return () unless defined($re) && defined($str);
  return split(/$re/, $str, $num);
}

=head2 S<sprintf($fmt,$arg,...)>

This macro returns a text string according to the specified format.

=cut

sub _m_sprintf
{ my $slf = shift;
  my $ctx = shift;
  my $fmt = shift;

  return sprintf($fmt, @_);
}

=head2 S<substr($str[,$off[,$lgt]])>

This macro extracts and returns a substring out of the string. The first
character is at the specified offset. If the offset is negative, it starts that
far from the end of the string. If the length is omitted, it returns everything
to the end of the string. If the length is negative, it leaves that many
characters off the end of the string.

=cut

sub _m_substr
{ my ($slf, $ctx, $str, $off, $lgt) = @_;

  if (defined($str))
  { $str = defined($lgt) ? substr($str, $off, $lgt) : substr($str, $off);
  }
  return $str;
}

=head2 S<time()>

This macro returns the number of non-leap seconds since the time that the
system considers to be the epoch.

=cut

sub _m_time
{ return time;
}

=head2 S<times()>

This macro returns a four-element list giving the user and system times, in
seconds, for this process and the children of this process.

=cut

sub _m_times
{ return times;
}

=head2 S<tput($mode)>

This macro returns the corresponding escape sequence. The following modes are
supported:

=over 16

=item S<    B<'bell' >> Inserts a bell

=item S<    B<'bold' >> Puts the next characters in bold

=item S<    B<'clear'>> Clears the screen

=item S<    B<'home' >> Goes to screen home

=item S<    B<'off' > > Suppresses any mode

=item S<    B<'reverse'>> Puts the next characters in reverse mode

=back

=cut

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

  return exists($slf->{'_tc'}->{$mod}) ? $slf->{'_tc'}->{$mod} : q{};
}

=head2 S<translate($str,$src,$dst[,$flg])>

This macro translates all occurrences of the characters found in the search
string to the corresponding character in the replacement list. If the
replacement list is shorter than the search list, then the last character of
the replacement list is replicated as necessary. When the flag is set, any
substitution that would result in multiple consecutive characters is replaced
with a single occurrence. It returns the resulting text string.

C<translate($str,'A-Z','a-z')> converts a string to lower case.

C<translate($str,'a-z','A-Z')> converts a string to upper case.

=cut

sub _m_translate
{ my ($slf, $ctx, $str, $src, $dst, $flg) = @_;

  if (defined($str) && defined($src) && defined($dst))
  { if ($flg)
    { eval "\$str =~ tr{$src}{$dst}s";  ## no critic (Eval)
    }
    else
    { eval "\$str =~ tr{$src}{$dst}";   ## no critic (Eval)
    }
  }
  return $str;
}

=head2 S<trim($str[,$del])>

This macro trims all leading and trailing spaces. You can specify extra
characters to trim as a second argument.

=cut

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

  if (defined($str))
  { $str =~ s{^\s+}{}g;
    $str =~ s{\s+$}{}g;
    if ($del)
    { $str =~ s{^$del}{};
      $str =~ s{$del$}{};
    }
  }
  return $str;
}

=head2 S<uc($str)>

This macro converts the specified text string to upper case.

=cut

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

  return defined($str) ? uc($str) : undef;
}

=head2 S<ucfirst($str)>

This macro converts the first character of the specified text string to
upper case.

=cut

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

  return defined($str) ? ucfirst($str) : undef;
}

=head2 S<unpack($fmt,$val)>

This macro takes a string and expands it into a list of values.

=cut

sub _m_unpack
{ my ($slf, $ctx, $fmt, $val) = @_;

  return () unless defined($fmt) && defined($val);
  return unpack($fmt, $val);
}

=head2 S<value($str)>

This macro extracts the value part of a string such as C<key=value>. It removes
leading and trailing spaces from the value.

=cut

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

  return unless defined($str);
  $str =~ s/^\s+//;
  $str =~ s/\s+$//;
  return (split(/\s*=\s*/, $str, 2))[1];
}

=head2 S<verbatim($str[,$opt])>

This macro encodes characters to use the string in a regular expression. It
supports the following options:

=over 9

=item S<    B<'b'> > Aligns on word boundary.

=item S<    B<'e'> > Specifies an exact match of the whole string.

=back

=cut

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

  if (defined($str))
  { $str =~ s{([\\\/\#\.\*\+\?\|\(\)\[\]\{\}\^\$\@\%])}{\\$1}g;
    $str = $tb_pre{$opt}.$str.$tb_suf{$opt}
      if defined($opt) && exists($tb_pre{$opt});
  }
  return $str;
}

=head2 S<version($str,...)>

This macro normalizes a version string. It returns an undefined value when the
arguments do not contain any numeric fragment.

=cut

sub _m_version
{ my ($slf, $ctx, @arg) = @_;
  my ($str, @num, @str);

  foreach my $arg (@arg)
  { push(@str, split(/[\.\-]/, $arg)) if $arg;
  }

  if (@num = grep {m/^\d+$/} @str)
  { $str = join(q{.}, @num);
    $str .= q{/}.join(q{.}, @str) if (@str = grep {m/\D/} @str);
  }
  return $str;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Driver::Library|RDA::Driver::Library>,
L<RDA::Driver::Sgml|RDA::Driver::Sgml>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Object::View|RDA::Object::View>,
L<RDA::SDCL::Block|RDA::SDCL::Block>,
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