# View.pm: Class Used for Managing System Views

package RDA::Object::View;

# $Id: View.pm,v 1.67 2015/10/30 09:56:25 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Object/View.pm,v 1.67 2015/10/30 09:56:25 RDA Exp $
#
# Change History
# 20151030  MSC  Enhance the tracing mechanisms.

=head1 NAME

RDA::Object::View - Class Used for Managing System Views

=head1 SYNOPSIS

 require RDA::Object::View;

=head1 DESCRIPTION

The objects of the C<RDA::Object::View> class are used for managing system
views. It is a subclass of L<RDA::Object|RDA::Object>.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use IO::File;
  use RDA::Text qw(debug get_string);
  use RDA::Object;
  use RDA::Object::Env;
  use RDA::Object::Rda qw($RDA_LOCAL);
}

# Define the global public variables
use vars qw($AUTOLOAD $DUMP $STRINGS $VERSION @DELETE @EXPORT_OK @ISA %SDCL);
$DUMP    = 0;
$VERSION = sprintf('%d.%02d', q$Revision: 1.67 $ =~ /(\d+)\.(\d+)/);
@DELETE  = qw(_ini _nat);
@EXPORT_OK = qw(is_host is_port);
@ISA     = qw(RDA::Object Exporter);
%SDCL    = (
  als => {
    ## no critic (Interpolation)
    'findCommand'      => ['$[SYS]', 'find_unrestricted'],
    'getLocalDir'      => ['$[SYS]', 'get_dir'],
    'getLocalEnv'      => ['$[SYS]', 'get_value'],
    'getLocalFile'     => ['$[SYS]', 'get_file'],
    'grepLocalEnv'     => ['$[SYS]', 'grep'],
    'hasRestriction'   => ['$[SYS]', 'has_restriction'],
    'isDomainName'     => ['$[SYS]', 'is_domain_name'],
    'isHost'           => ['$[SYS]', 'is_host'],
    'isHostName'       => ['$[SYS]', 'is_host_name'],
    'isInteger'        => ['$[SYS]', 'is_integer'],
    'isIP'             => ['$[SYS]', 'is_ip'],
    'isIPv4'           => ['$[SYS]', 'is_ipv4'],
    'isIPv6'           => ['$[SYS]', 'is_ipv6'],
    'isNonSystemPort'  => ['$[SYS]', 'is_non_system_port'],
    'isPath'           => ['$[SYS]', 'is_path'],
    'isPort'           => ['$[SYS]', 'is_port'],
    'isPrivatePort'    => ['$[SYS]', 'is_private_port'],
    'isRe'             => ['$[SYS]', 'is_re'],
    'isReal'           => ['$[SYS]', 'is_real'],
    'isRestricted'     => ['$[SYS]', 'is_restricted'],
    'isSystemPort'     => ['$[SYS]', 'is_system_port'],
    'isUser'           => ['$[SYS]', 'is_user'],
    'isUserPort'       => ['$[SYS]', 'is_user_port'],
    'isUnsigned'       => ['$[SYS]', 'is_unsigned'],
    'isVirtualCygwin'  => ['${CUR.O_VIRTUAL}', 'is_cygwin'],
    'isVirtualUnix'    => ['${CUR.O_VIRTUAL}', 'is_unix'],
    'isVirtualVms'     => ['${CUR.O_VIRTUAL}', 'is_vms'],
    'isVirtualWindows' => ['${CUR.O_VIRTUAL}', 'is_windows'],
    'isWord'           => ['$[SYS]', 'is_word'],
    'lastTestCommand'  => ['$[SYS]', 'last_command'],
    'lastTestDir'      => ['$[SYS]', 'last_dir'],
    'lastTestFile'     => ['$[SYS]', 'last_file'],
    'replaceLocalEnv'  => ['$[SYS]', 'resolve'],
    'restoreContext'   => ['$[SYS]', 'restore_context'],
    'setContext'       => ['$[SYS]', 'set_context'],
    'setLocalEnv'      => ['$[SYS]', 'set_value'],
    'sourceContext'    => ['$[SYS]', 'source_context'],
    'testDir'          => ['$[SYS]', 'test_dir'],
    'testFile'         => ['$[SYS]', 'test_file'],
    'testParent'       => ['$[SYS]', 'test_parent'],
    'testVirtualFile'  => ['${CUR.O_VIRTUAL}', 'test_file'],
    },
  inc => [qw(RDA::Object)],
  met => {
    'basename'           => {ret => 0},
    'cat_dir'            => {ret => 0},
    'cat_file'           => {ret => 0},
    'clean_path'         => {ret => 0},
    'current_dir'        => {ret => 0},
    'dev_null'           => {ret => 0},
    'dev_tty'            => {ret => 0},
    'dirname'            => {ret => 0},
    'find'               => {ret => 0},
    'find_unrestricted'  => {ret => 0},
    'get_dir'            => {ret => 0},
    'get_cmd_names'      => {ret => 1},
    'get_env'            => {ret => 0},
    'get_family'         => {ret => 0},
    'get_file'           => {ret => 0},
    'get_init'           => {ret => 0},
    'get_list'           => {ret => 1},
    'get_native'         => {ret => 0},
    'get_os'             => {ret => 0},
    'get_separator'      => {ret => 0},
    'get_shlib'          => {ret => 0},
    'get_user'           => {ret => 0},
    'get_value'          => {ret => 0},
    'grep'               => {ret => 1},
    'has_short'          => {ret => 0},
    'has_restriction'    => {ret => 0},
    'is_absolute'        => {ret => 0},
    'is_cygwin'          => {ret => 0},
    'is_domain_name'     => {ret => 0},
    'is_host'            => {ret => 0},
    'is_host_name'       => {ret => 0},
    'is_integer'         => {ret => 0},
    'is_ip'              => {ret => 0},
    'is_ipv4'            => {ret => 0},
    'is_ipv6'            => {ret => 0},
    'is_non_system_port' => {ret => 0},
    'is_path'            => {ret => 0},
    'is_port'            => {ret => 0},
    'is_private_port'    => {ret => 0},
    'is_re'              => {ret => 0},
    'is_real'            => {ret => 0},
    'is_restricted'      => {ret => 0},
    'is_system_port'     => {ret => 0},
    'is_unix'            => {ret => 0},
    'is_unsigned'        => {ret => 0},
    'is_user'            => {ret => 0},
    'is_user_port'       => {ret => 0},
    'is_vms'             => {ret => 0},
    'is_windows'         => {ret => 0},
    'is_word'            => {ret => 0},
    'last_command'       => {ret => 0},
    'last_dir'           => {ret => 0},
    'last_file'          => {ret => 0},
    'parse_path'         => {ret => 1},
    'quote'              => {ret => 0},
    'quote2'             => {ret => 0},
    're'                 => {ret => 0},
    'resolve'            => {ret => 0},
    'restore_context'    => {ret => 0},
    'set_context'        => {ret => 0},
    'set_list'           => {ret => 0},
    'set_value'          => {ret => 0},
    'skip_tests'         => {ret => 0},
    'split_dir'          => {ret => 1},
    'split_volume'       => {ret => 1},
    'source_context'     => {ret => 0},
    'split_value'        => {ret => 1},
    'test_dir'           => {ret => 0},
    'test_file'          => {ret => 0},
    'test_parent'        => {ret => 0},
    'unquote'            => {ret => 0},
    'up_dir'             => {ret => 0},
    },
  top => 'SYS',
  );

# Define the global private constants

# Define the global private variables
my %tb_fct = (
  Cygwin  => {cfg => \&_sel_cyg_exec,
              exe => \&_val_exec,
              key => \&_lim_win_key,
              pth => \&_lim_win_pth,
             },
  Unix    => {cfg => \&_sel_os_exec,
              exe => \&_val_exec_x,
              key => \&_lim_no_chg,
              pth => \&_lim_no_chg,
             },
  Vms     => {cfg => \&_sel_fam_exec,
              exe => \&_val_exec,
              key => \&_lim_vms_pth,
              pth => \&_lim_vms_pth,
             },
  Windows => {cfg => \&_sel_fam_exec,
              exe => \&_val_exec_r,
              key => \&_lim_win_key,
              pth => \&_lim_win_pth,
             },
  );
my %tb_exe = (
  commands => q{_cmd},
  );
my %tb_ini = (
  Cygwin  => \&_ini_cygwin,
  Unix    => \&_ini_unix,
  Vms     => \&_ini_vms,
  Windows => \&_ini_windows,
  );
my %tb_prp = (
  Cygwin  => ['SYSTEM.RESTRICT.T_UNIX', 'SYSTEM.RESTRICT.T_WINDOWS'],
  Unix    => ['SYSTEM.RESTRICT.T_UNIX'],
  Vms     => ['SYSTEM.RESTRICT.T_VMS'],
  Windows => ['SYSTEM.RESTRICT.T_WINDOWS'],
  );

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

=head2 S<$h = RDA::Object::View-E<gt>new($agent,edit)>

The object constructor. This method enables you to specify the references of
the agent object and the edit directive array as arguments.

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

=over 12

=item S<    B<'agt' > > Reference to the agent object (N,S,V)

=item S<    B<'cfg' > > Reference to the RDA software configuration (N,S,V)

=item S<    B<'flg' > > Taint mode indicator (S)

=item S<    B<'oid' > > Object identifier (N,S,V)

=item S<    B<'par' > > Reference to the parent view object (N,V)

=item S<    B<'_bkp'> > Hash containing the saved values (S)

=item S<    B<'_cmd'> > Operating system command hash (S)

=item S<    B<'_dir'> > Last tested directory (N,S)

=item S<    B<'_env'> > Hash containing the environment variables (S)

=item S<    B<'_fam'> > Operating system family (N,S,V)

=item S<    B<'_fct'> > Restriction function hash (N,S,V)

=item S<    B<'_fil'> > Last tested file (N,S)

=item S<    B<'_ini'> > Initial values (S)

=item S<    B<'_lim'> > Restriction definition hash (N,S,V)

=item S<    B<'_nat'> > Reference to the native view object (S)

=item S<    B<'_ori'> > Reference to the original environment object (S)

=item S<    B<'_osn'> > Operating system name (N,S,V)

=item S<    B<'_ref'> > Environment reference indicator (S)

=item S<    B<'_skp'> > List of file tests to skip (N,S)

=item S<    B<'_tst'> > Test function (N,S,V)

=item S<    B<'_val'> > Directory restriction validation function (S)

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

=back

Internal keys are prefixed by an underscore.

=cut

sub new  ## no critic (Complex)
{ my ($cls, @arg) = @_;
  my ($cfg, $slf);

  if (ref($cls))
  { my ($oid, $osn, $tst) = splice(@arg, 0, 3);
    my ($fam, $key, $val);

    $fam = RDA::Object::Rda->get_family($osn);
    eval "require RDA::Local::$fam";
    die get_string('ERR_REQUIRE', "RDA::Local::$fam", $@) if $@;

    # Create the object
    $cfg = bless {}, "RDA::Local::$fam";
    $slf = bless {
      agt  => $cls->{'agt'},
      cfg  => $cfg,
      oid  => $oid,
      par  => $cls,
      _fam => $fam,
      _fct => $tb_fct{$fam},
      _osn => $osn,
      _skp => $cls->{'_skp'},
      _tst => (ref($tst) eq 'CODE') ? $tst : \&_test_mode,
      }, ref($cls);

    # Add attributes
    while (($key, $val) = splice(@arg, 0, 2))
    { $slf->{$key} = defined($val) ? $val : $key;
    }
  }
  else
  { my ($agt, $edt) = @arg;
    my ($env, $fam, $flg);

    # Create the object
    $cfg = bless $agt->get_config, 'RDA::Object::Rda';
    $fam = $cfg->get_family($^O);
    $slf = bless {
      agt  => $agt,
      cfg  => $cfg,
      oid  => 'SYS',
      _env => $env = {},
      _fam => $fam,
      _fct => $tb_fct{$fam},
      _ini => {},
      _osn => $^O,
      _ref => 0,
      _skp => q{-},
      _tst => \&_test_mode,
      _val => \&_is_dir,
      }, $cls;

    # Take a copy of the environment variables
    eval
    { foreach my $key (keys(%ENV))
      { $env->{$key} = $ENV{$key};
      }
    };
    die get_string('ERR_COPY', $@) if $@;
    $slf->{'_ori'} = RDA::Object::Env->new({%{$env}});

    # Check for debugging requests
    if (exists($slf->{'_env'}->{'RDA_DUMP'}))
    { foreach my $nam (split(/,/, uc($slf->{'_env'}->{'RDA_DUMP'})))
      { if ($nam =~ m/^([A-Z]+)$/)
        { $edt->{"DMP/$1"} = $flg = 1;
          $DUMP = 1 if $1 eq 'ENV';
        }
      }
    }

    # Report start script alterations
    if ($DUMP)
    { foreach my $key (grep {m/^RDA_ALTER_/} keys(%{$env}))
      { next unless $env->{$key} =~ m/^(\w+)=(.*)$/;
        if (exists($env->{$1}))
        { debug("ENV(start)] Set $1='".$env->{$1}.q{'}) if $env->{$1} ne $2;
        }
        elsif (length($2))
        { debug("ENV(start)] Unset $1");
        }
      }
    }

    # Adjust the environment
    foreach my $key (qw(BASH_ENV CDPATH ENV IFS LANG PERL5SHELL))
    { _set_value($slf, $key) if exists($slf->{'_env'}->{$key});
    }
    _set_value($slf, 'NLS_LANG', 'AMERICAN_AMERICA.US7ASCII');

    # Check for tracing requests
    if (exists($slf->{'_env'}->{'RDA_TRACK'}))
    { foreach my $nam (split(/,/, uc($slf->{'_env'}->{'RDA_TRACK'})))
      { $edt->{"TRC/$1"} = $2 if $nam =~ m/^([A-Z]+):(\d+)$/;
      }
    }

    # Complete the object initialization
    $slf->{'flg'} = RDA::Object->is_tainted($slf->{'_env'}->{'PATH'});
    $slf->{'_nat'} = $slf;
    &{$tb_ini{$RDA_LOCAL}}($slf, $cfg);

    # Store some initial values
    _set_init($slf, 'HOM', 'ORACLE_HOME');
    _set_init($slf, 'TNS', 'TNS_ADMIN');

    # Define extra paths
    _define_list($slf->{'_nat'}, 'cp', 'CLASSPATH');
  }

  # Return the object reference
  return $slf;
}

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

  $slf->{'_ini'}->{$nam} = $1
    if exists($slf->{'_env'}->{$env})
    && $slf->{'_env'}->{$env} =~ m/^([\000-\377]+)$/
    && -d $1;
  return;
}

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

This method undoes changes made to environment variables and next deletes the
system view.

=cut

sub delete_object
{ $_[0]->reset;
  $_[0]->SUPER::delete_object;
  return;
}

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

This method returns the value of an initial environment variable or the default
value when the variable is not defined.

It returns a reference to an original environment copy when no variable name is
specified.

=cut

sub get_env
{ my ($slf, $key, $dft) = @_;

  return defined($key)
    ? $slf->{'_ori'}->get_value($key, $dft)
    : $slf->{'_ori'};
}

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

This method indicates the family of the operating system associated with the
view.

=cut

sub get_family
{ return shift->{'_fam'};
}

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

This method returns the initial value of a saved environment variables or the
default value when the environment variable was not defined.

=cut

sub get_init
{ my ($slf, $key, $dft) = @_;

  return exists($slf->{'_ini'}->{$key = uc($key)})
    ? $slf->{'_ini'}->{$key}
    : $dft;
}

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

This method returns a reference to the native view.

=cut

sub get_native
{ return shift->{'_nat'};
}

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

This method returns the name of the operating system associated with the
view.

=cut

sub get_os
{ return shift->{'_osn'};
}

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

This method returns a reference to the current virtual view.

=cut

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

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

=head2 S<$h-E<gt>reset([$trace])>

This method reset the view to its original state.

=cut

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

  delete($slf->{'_dir'});
  delete($slf->{'_fil'});
  delete($slf->{'_vir'});
  return $slf->restore_content(delete($slf->{'_bkp'}), $trc);
}

*unlink = \&reset;

=head2 S<$h-E<gt>resume($bkp)>

This method resumes some view activities. It returns a list containing the
object reference and the previous values of the restored attributes.

=cut

sub resume
{ my ($slf, $rec) = @_;
  my ($bkp);

  die get_string('BAD_RESUME') unless ref($rec) eq 'HASH';
  $slf = $slf->get_top;

  # Restore the environment
  $slf->reset;

  # Restore the attributes
  $bkp = _switch($slf, {}, $rec);

  # Return the previous values
  return $bkp;
}

sub _switch
{ my ($slf, $bkp, $rec) = @_;

  # Restore saved attributes
  foreach my $key (keys(%{$rec}))
  { $slf->{$key} = $bkp->{$key} if exists($bkp->{$key});
    if (defined($rec->{$key}))
    { ($slf->{$key}, $bkp->{$key}) = ($rec->{$key}, $slf->{$key});
    }
    else
    { $bkp->{$key} = delete($slf->{$key});
    }
  }

  # Return the value of the modified attributes
  return $bkp;
}

=head2 S<$h-E<gt>set_virtual([$view])>

This method assigns a new view as current virtual view when the argument is
reference to a view object. Otherwise, it deletes the current virtual view.

It returns the previous value.

=cut

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

  if (ref($val) eq 'RDA::Object::View')
  { ($slf->{'_vir'}, $val) = ($val, $slf->{'_vir'});
  }
  else
  { $val = delete($slf->{'_vir'});
  }
  return $val;
}

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

This method suspends some view activities for the specified job. It returns
previous attributes.

=cut

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

  # Switch object attributes
  return _switch($slf->get_top, {}, {
    _bkp => {},
    _dir => undef,
    _fil => undef,
    _vir => undef,
    });
}

=head1 CONTEXT MANAGEMENT METHODS

=head2 S<$h-E<gt>restore_context($backup[,$trace])>

This method restore the environment.

=cut

sub restore_context
{ my ($slf, $bkp, $trc) = @_;
  my ($def, $val);

  unless ($slf->{'_ref'} || ref($bkp) ne 'HASH')  ## no critic (Unless)
  { $def = $slf->{'_env'};
    $trc = "ENV($$)]" if $DUMP;
    foreach my $key (keys(%{$bkp}))
    { if (defined($val = $bkp->{$key}))
      { next if exists($def->{$key}) && $def->{$key} eq $val;
        $ENV{$key} = $def->{$key} = $val;
        debug("$trc Restore $key='$val'") if $trc;
      }
      elsif (defined(delete($def->{$key})))
      { delete($ENV{$key});
        debug("$trc Remove $key") if $trc;
      }
    }
  }
  return $slf;
}

=head2 S<$h-E<gt>set_context($env[,$trace])>

This method adapts the environment for a new context. It returns the previous
values as a hash reference.

=cut

sub set_context
{ my ($slf, $env, $trc) = @_;
  my ($bkp, $def, $old, $val);

  $bkp = {};
  if (ref($env) eq 'HASH')
  { $trc = "ENV($$)]" if $DUMP;
    if (!$slf->{'_ref'})
    { $def = $slf->{'_env'};
      $old = $slf->{'_bkp'};
      foreach my $key (keys(%{$env}))
      { if (defined($val = $env->{$key}))
        { if (exists($def->{$key}))
          { next if $def->{$key} eq $val;
            $bkp->{$key} = $def->{$key};
          }
          else
          { $bkp->{$key} = undef;
          }
          $old->{$key} = $bkp->{$key} unless exists($old->{$key});
          $ENV{$key} = $def->{$key} = $val;
          debug("$trc Set $key='$val'") if $trc;
        }
        elsif (exists($def->{$key}))
        { $bkp->{$key} = delete($def->{$key});
          $old->{$key} = $bkp->{$key} unless exists($old->{$key});
          delete($ENV{$key});
          debug("$trc Unset $key") if $trc;
        }
      }
    }
    elsif ($trc)
    { foreach my $key (keys(%{$env}))
      { debug("$trc Skip $key") if $trc;
      }
    }
  }
  return $bkp;
}

=head2 S<$h-E<gt>source_context($program[,$shell])>

This method uses the program that is specified as an argument to modify the
environment. The program is sourced in 'sh' for UNIX or executes with 'cmd' for
Windows. For UNIX, you can provide the shell for sourcing the program.

It raises an error when trying to modify the read-only copy of the environment
variables.

It returns the number of modified variables.

=cut

sub source_context  ## no critic (Complex)
{ my ($slf, $pgm, $shl) = @_;
  my ($cfg, $chk, $cmd, $env, $prv, $ref, $sep, %prv);

  $slf = $slf->get_top;
  die get_string('READ_ONLY') if $slf->{'_ref'};
  die get_string('IS_TAINTED', $pgm)
    if RDA::Object->is_tainted($pgm);

  # Initialization
  if (RDA::Object::Rda->is_windows
    || (RDA::Object::Rda->is_cygwin && $pgm =~ m/\.(bat|cmd)$/i))
  { $ref = 'cmd /C "set" |';
    $cmd = 'cmd /C "'.RDA::Object::Rda->native($pgm).' 2>NUL && set" |';
    $sep = q{;};
  }
  else
  { $shl = 'sh'
      unless defined($shl)  ## no critic (Unless)
          && -x $shl && !RDA::Object->is_tainted($shl);
    $ref = "$shl -c 'env' |";
    $cmd = "$shl -c '. $pgm 2>/dev/null ; env' |";
    $sep = q{:};
  }

  # Take a copy of the current environment
  return {} unless open(IN, $ref);          ## no critic (Handle,Open)
  while (<IN>)
  { s/[\r\n]*$//;
    $prv{$1} = $2 if m/^(\w+)=(.*)$/;
  }
  close(IN);

  # Compare with the modified environment
  return {} unless $pgm && open(IN, $cmd);  ## no critic (Handle,Open)
  $env = {};
  while (<IN>)
  { s/[\r\n]*$//;
    if (m/^(\w+)=(.*)$/ )
    { ++$chk;
      $env->{$1} = $2
        unless defined($prv = delete($prv{$1})) && $prv eq $2;
    }
  }
  close(IN);
  if ($chk)
  { foreach my $key (keys(%prv))
    { $env->{$key} = undef if exists($env->{$key});
    }
  }

  # Validate the PATH environment variable
  if (exists($env->{'PATH'}))
  { $cfg = $slf->{'cfg'};
    $env->{'PATH'} = join($cfg->get_separator,
      grep {defined($_)}
      map{$slf->is_restricted($slf->test_dir('d', $cfg->cat_dir($_), 1))}
      split(/$sep/, $env->{'PATH'}));
  }

  # Set the context
  return $slf->set_context($env);
}

=head1 ENVIRONMENT VARIABLE MANAGEMENT METHODS

=head2 S<$h-E<gt>find($command[,$flag[,@dir...]])>

This method explores the path to find where a command is located. When the
command is found, it returns a full path name. Otherwise, it returns an
undefined variable. It only considers files or symbolic links in its
search. Unless the flag is set, the file path is quoted as required by a
command shell.

=cut

sub find
{ my ($slf, $cmd, $flg, @dir) = @_;

  return RDA::Object::Rda->find_path(@dir ?
    [@dir] :
    _get_path($slf), $cmd, $flg);
}

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

  $slf = $slf->get_top;
  return [split($slf->{'cfg'}->get_separator, $slf->{'_env'}->{'PATH'})];
}

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

This method returns the value of the specified environment variable when it
corresponds to an existing directory. Otherwise it returns an undefined value.

=cut

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

  return defined($pth = $slf->get_value($key, $val))
    ? $slf->test_dir('d', $slf->{'cfg'}->clean_path([$pth, q{}]))
    : undef;
}

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

This method returns the value of the specified environment variable when it
corresponds to an existing file. Otherwise it returns an undefined value.

=cut

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

  return defined($pth = $slf->get_value($key, $val))
    ? $slf->test_dir('f', $slf->{'cfg'}->clean_path($pth))
    : undef;
}

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

This method returns the value of the specified environment variable. It returns
the default value when the environment variable is not defined.

=cut

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

  $slf = $slf->get_top;
  $val = $slf->{'_env'}->{$key} if exists($slf->{'_env'}->{$key});
  if (wantarray)
  { return ($val) if defined($val);
    return ();
  }
  return $val;
}

=head2 S<$h-E<gt>grep($re[,$opt])>

This method returns the list of all environment variables with names that
match the regular expression. It supports the following attributes:

=over 9

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

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

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

=back

=cut

sub grep  ## no critic (Builtin)
{ my ($slf, $pat, $opt) = @_;
  my ($inv, $one, @tbl);

  # Decode the options
  $opt = q{} unless defined($opt);
  $pat = $slf->is_match($pat, index($opt, 'i') < 0);
  $inv = index($opt, 'v') >= 0;
  $one = index($opt, 'f') >= 0;

  # Scan the variables
  foreach my $key (sort keys(%{$slf->get_top('_env')}))
  { if ($inv xor $key =~ $pat)
    { push(@tbl, $key);
      last if $one;
    }
  }

  # Return the variable list
  return @tbl;
}

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

This method replaces all environment variable references contained in the
specified string.

For UNIX, C<$name>, C<${name}>, and C<${name:-text}> are resolved. For Windows,
C<%name%> format is supported. No replacements are performed for VMS.

=cut

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

  if (defined($str))
  { if ($slf->is_unix)
    { $slf = $slf->get_top;
      $str =~ s{\$(\w+)}{_repl_unix1($slf, $1)}eg;
      $str =~ s{\$\{(\w+)\}}{_repl_unix1($slf, $1)}eg;
      1 while $str =~ s{\$\{(\w+)\:\-([^\{\}]*)\}}{_repl_unix2($slf, $1, $2)}eg;
    }
    elsif ($slf->is_windows || $slf->is_cygwin)
    { $slf = $slf->get_top;
      if ($flg)
      { $str =~ s{\$(\w+)}{_repl_windows($slf, $1, q{})}eg;
        $str =~ s{\$\{(\w+)\}}{_repl_windows($slf, $1, q{})}eg;
        1 while $str =~ s{\$\{(\w+)\:\-([^\{\}]*)\}}
                         {_repl_windows($slf, $1, $2)}eg;
      }
      else
      { $str =~ s{\%(\w+)\%}{_repl_windows($slf, $1, q{})}eg;
      }
    }
  }
  return $str;
}

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

  return exists($slf->{'_env'}->{$nam}) ? $slf->{'_env'}->{$nam} : q{};
}

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

  my $str = exists($slf->{'_env'}->{$nam}) ? $slf->{'_env'}->{$nam} : q{};
  return length($str) ? $str : $alt;
}

sub _repl_windows
{ my ($slf, $nam, $alt) = @_;
  my ($str);

  return $str
    if exists($slf->{'_env'}->{$nam}) && length($str = $slf->{'_env'}->{$nam});
  $nam = "\%$nam\%";
  ($str) = `cmd /c echo $nam`;
  $str =~ s/"?[\n\r]+$//;
  return ($str ne $nam && length($str)) ? $str : $alt;
}

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

This method sets the value of the specified environment variable. When the
value is undefined, the variable is deleted. It returns the previous value of
the environment variable.

=cut

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

  $slf = $slf->get_top;
  die get_string('READ_ONLY') if $slf->{'_ref'};

  # Backup the old value
  $old = delete($slf->{'_env'}->{$key});
  $slf->{'_bkp'}->{$key} = $old unless exists($slf->{'_bkp'}->{$key});

  # Modify the value
  $val = join($slf->{'cfg'}->get_separator,
    grep {defined($_) && !ref($_)} @{$val}) if ref($val) eq 'ARRAY';
  _set_value($slf, $key, $val);

  # Return the old value
  return $old;
}

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

  if (defined($val))
  { debug("ENV($$)] Set $key='$val'") if $DUMP;
    $ENV{$key} = $slf->{'_env'}->{$key} = $val;
  }
  else
  { debug("ENV($$)] Unset $key") if $DUMP;
    delete($ENV{$key});
    delete($slf->{'_env'}->{$key});
  }
  return;
}

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

This method returns the value of the specified environment variable as a
list. Unless you specify the separator as an extra argument, it uses the
operating system-specific separator to split the value.

It returns an empty list when the environment variable is not defined.

=cut

sub split_value
{ my ($slf, $key, $sep) = @_;
  my ($env);

  $env = $slf->get_top('_env');
  return () unless exists($env->{$key});
  $sep = $slf->{'cfg'}->get_separator unless defined($sep);
  return split($sep, $env->{$key}, -1);
}

=head1 EXECUTION RESTRICTION METHODS

=head2 S<$h-E<gt>find_unrestricted($command[,$flag[,@dir...]])>

Similar to C<find> but applies execution restriction directives.

=cut

sub find_unrestricted
{ my ($slf, $cmd, $flg, @dir) = @_;
  my ($fct, $flt, $key, $lim, $tbl);

  # Initialize the restrictions on first use
  $fct = $slf->{'_fct'}->{'pth'};
  $lim = exists($slf->{'_lim'})
    ? $slf->{'_lim'}
    : _init_restrictions($slf);

  # Apply basename restrictions
  return if exists($lim->{'bas'}->{$key = &$fct($cmd)});

  # Apply directory restrictions
  $tbl = @dir ? [@dir] : _get_path($slf);
  if (exists($lim->{'dir'}->{$key}))
  { $flt = $lim->{'dir'}->{$key};
    $tbl = [grep {!exists($flt->{&$fct($_)})} @{$tbl}];
    return unless @{$tbl};
  }

  # Explorer the directory list
  return RDA::Object::Rda->find_path($tbl, $cmd, $flg);
}

=head2 S<$h-E<gt>has_restriction($command)>

This command indicates whether the specified command has execution
restrictions.

=cut

sub has_restriction
{ my ($slf, $cmd) = @_;
  my ($lim, $pth);

  # Initialize the restrictions on first use
  $lim = exists($slf->{'_lim'})
    ? $slf->{'_lim'}
    : _init_restrictions($slf);

  # Check for restrictions
  $pth = &{$slf->{'_fct'}->{'pth'}}($cmd);
  return (exists($lim->{'pth'}->{$pth})
    || exists($lim->{'bas'}->{$slf->{'cfg'}->basename($pth)})) ? 1 : 0;
}

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

This methods forces a reload of the restriction directives at next use.

=cut

sub reset_restrictions
{ return delete(shift->{'_lim'});
}

=head1 OPERATING SYSTEM COMMAND MANAGEMENT METHODS

=cut

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

This method returns the list of the defined C<CMD> properties.

=cut

sub get_cmd_names
{ my ($slf) = @_;
  my ($tbl);

  # Load the operating system command paths on first use
  $slf = $slf->get_top;
  $tbl = exists($slf->{'_cmd'}) ? $slf->{'_cmd'} : _load_exec($slf);

  return (sort keys(%{$slf->{'_cmd'}}));
}

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

This method returns the path of the specified operating system command. It
returns the default value when the command is not defined.

=cut

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

  # Load the operating system command paths on first use
  $slf = $slf->get_top;
  $tbl = exists($slf->{'_cmd'}) ? $slf->{'_cmd'} : _load_exec($slf);

  # Get the current definition
  $val = (ref($tbl->{$key}) eq 'ARRAY')
    ? &{$slf->{'_fct'}->{'exe'}}($tbl, $key, $val)
    : $tbl->{$key}
    if exists($tbl->{$key});

  # Return the result
  if (wantarray)
  { return ($val) if defined($val);
    return ();
  }
  return $val;
}

sub _load_exec
{ my ($slf) = @_;
  my ($cfg, $grp, $ifh, $key, $lin, @val);

  $slf->{'_cmd'} = {};
  $cfg = $slf->{'cfg'};
  $ifh = IO::File->new;
  foreach my $pth (&{$slf->{'_fct'}->{'cfg'}}($slf))
  { if ($ifh->open('<'.$pth))
    { $lin = q{};
      while (<$ifh>)
      { # Join a continuation line
        s/^\s+//;
        s/[\n\n]+$//;
        $lin .= $_;
        next if $lin =~ s/\\$//;
        $lin =~ s/\s+$//;

        # Treat the line
        if ($lin =~ m/^\[(\w+)\]/)
        { $grp = exists($tb_exe{$1}) ? $tb_exe{$1} : undef;
        }
        elsif (defined($grp))
        { if ($lin =~ m/^(\w+)\s*=\s*'(.*)'/)
          { $slf->{$grp}->{$1} = $2;
          }
          elsif ($lin =~ s/^(\w+)\s*=\s*\050\s*//)
          { ($key, @val) = ($1);
            while ($lin =~ s/^'([^']+)'(,\s*)?//)
            { push(@val, $1);
              last unless $2;
            }
            $slf->{$grp}->{$key} = [@val] if $lin =~ m/^\s*\051/;
          }
        }
        $lin = q{};
      }
      $ifh->close;
      last;
    }
  }
  return $slf->{'_cmd'};
}

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

  return ($slf->{'cfg'}->get_file('D_RDA_DAT', lc($slf->{'_osn'}).'.cfg'),
          $slf->{'cfg'}->get_file('D_RDA_DAT', 'unix.cfg'));
}

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

  return ($slf->{'cfg'}->get_file('D_RDA_DAT', lc($slf->{'_fam'}).'.cfg'));
}

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

  return ($slf->{'cfg'}->get_file('D_RDA_DAT', lc($slf->{'_osn'}).'.cfg'),
          $slf->{'cfg'}->get_file('D_RDA_DAT', lc($slf->{'_fam'}).'.cfg'));
}

sub _val_exec
{ my ($tbl, $key, $dft) = @_;

  foreach my $pth (@{$tbl->{$key}})
  { if (defined($pth) && -f $pth)
    { $tbl->{$key} = $pth;
      return $pth;
    }
  }
  delete($tbl->{$key});
  return $dft;
}

sub _val_exec_r
{ my ($tbl, $key, $dft) = @_;

  foreach my $pth (@{$tbl->{$key}})
  { if (defined($pth) && -f $pth && -r $pth)
    { $tbl->{$key} = $pth;
      return $pth;
    }
  }
  delete($tbl->{$key});
  return $dft;
}

sub _val_exec_x
{ my ($tbl, $key, $dft) = @_;

  foreach my $pth (@{$tbl->{$key}})
  { if (defined($pth) && -f $pth && -x $pth)
    { $tbl->{$key} = $pth;
      return $pth;
    }
  }
  delete($tbl->{$key});
  return $dft;
}

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

This method sets the path of the specified operating system command. When the
value is undefined, the definition is deleted. When the value is a reference to
an array, RDA will select the first list item that corresponds to an executable
file. It returns the previous value of the command path.

=cut

sub set_exec
{ my ($slf, $key, $val) = @_;
  my ($old, $tbl);

  # Load the operating system command paths on first use
  $slf = $slf->get_top;
  $tbl = exists($slf->{'_cmd'}) ? $slf->{'_cmd'} : _load_exec($slf);

  # Get the old path
  $old = delete($tbl->{$key});

  # Modify the path
  $tbl->{$key} = $val if defined($val) && ref($val) =~ m/^(?:ARRAY)?$/;

  # Return the old path
  return $old;
}

=head1 PATH MANAGEMENT METHODS

=cut

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

  return $slf->get_top('_ini')->{$uid} = {
    cfg => $slf->{'cfg'},
    det => [],
    nam => $nam,
    };
}

=head2 S<$h-E<gt>get_list($uid)>

This method returns the list of predefined path elements.

=cut

sub get_list
{ my ($slf, $uid) = @_;

  $slf = $slf->get_top;
  return @{$slf->{'_ini'}->{$uid}->{'det'}}
    if exists($slf->{'_ini'}->{$uid = lc($uid)});
  return ();
}

=head2 S<$h-E<gt>set_list($uid[,$list])>

This method assigns a new list of elements for the specified path.

=cut

sub set_list
{ my ($slf, $uid, $tbl) = @_;
  my ($cfg, $def, $det);

  $slf = $slf->get_top;
  return unless exists($slf->{'_ini'}->{$uid = lc($uid)});
  $def = $slf->{'_ini'}->{$uid};
  $cfg = $def->{'cfg'};
  $det = (ref($tbl) eq 'ARRAY')
    ? [map {$cfg->clean_path($_)} @{$tbl}]
    : $def->{'det'};
  return $slf->set_value($def->{'nam'},
    (@{$det}) ? join($cfg->get_separator, @{$det}) : undef);
}

sub _set_list
{ my ($slf, $uid) = @_;
  my ($def);

  $def = $slf->{'_ini'}->{$uid};
  _set_value($slf, $def->{'nam'}, $slf->{'_ini'}->{uc($uid)} =
    join($def->{'cfg'}->get_separator, @{$def->{'det'}}));
  return;
}

=head1 VALIDATION METHODS

=head2 S<RDA::Object::View-E<gt>is_domain_name($string[,$flag])>

This method indicates whether the string represents a domain name name. Unless
the flag is set, it raises an error instead of returning an undefined value.

=cut

sub is_domain_name
{ my (undef, $str, $flg) = @_;
  my ($ret);

  if (defined($str))
  { return $ret if defined($ret = _is_dns_name($str, '253', 2, 2));
    die get_string('BAD_DOMAIN_NAME', $str) unless $flg;
  }
  else
  { die get_string('NO_DOMAIN_NAME') unless $flg;
  }
  return;
}

sub _is_dns_name
{ my ($str, $lgt, $fix, $min) = @_;
  my ($cnt);

  return unless $str =~ m/^([A-Za-z\d\-\.]{1,$lgt})$/;
  $cnt = 0;
  foreach my $lbl (split(/\./, $str = $1, -1))
  { return
      unless $lbl =~ m/^[A-Za-z\d](\-*[A-Za-z\d]+)*$/  ## no critic (Unless)
          && length($lbl) < 64;
    ++$cnt;
  }
  return
    ($str =~ m/\.\d+$/)            ? undef :
    ($cnt == $fix || $cnt >= $min) ? $str :
                                     undef;
}

=head2 S<RDA::Object::View-E<gt>is_host($string[,$flag])>

This method indicates whether the string represents a host name or an IP
address. Unless the flag is set, it raises an error instead of returning an
undefined value.

=cut

sub is_host
{ my (undef, $str, $flg) = @_;
  my ($ret);

  if (defined($str))
  { return $ret if defined($ret = _is_dns_name($str, '255', 1, 3)) ||
                   defined($ret = _is_ipv4($str)) ||
                   defined($ret = _is_ipv6($str));
    die get_string('BAD_HOST', $str) unless $flg;
  }
  else
  { die get_string('NO_HOST') unless $flg;
  }
  return;
}

=head2 S<RDA::Object::View-E<gt>is_host_name($string[,$flag])>

This method indicates whether the string represents a host name. Unless the flag
is set, it raises an error instead of returning an undefined value.

=cut

sub is_host_name
{ my (undef, $str, $flg) = @_;
  my ($ret);

  if (defined($str))
  { return $ret if defined($ret = _is_dns_name($str, '255', 1, 3));
    die get_string('BAD_HOST_NAME', $str) unless $flg;
  }
  else
  { die get_string('NO_HOST_NAME') unless $flg;
  }
  return;
}

=head2 S<RDA::Object::View-E<gt>is_integer($string[,$flag])>

This method indicates whether the string represents an integer number. Unless
the flag is set, it raises an error instead of returning an undefined value.

=cut

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

  if (defined($str))
  {return $1 if $str =~ m/^([+-]?\d+)$/;
    die get_string('BAD_INTEGER', $str) unless $flg;
  }
  else
  { die get_string('NO_INTEGER') unless $flg;
  }
  return;
}

=head2 S<RDA::Object::View-E<gt>is_ip($string[,$flag])>

This method indicates whether the string represents an IP address. Unless the
flag is set, it raises an error instead of returning an undefined value.

=cut

sub is_ip
{ my (undef, $str, $flg) = @_;
  my ($ret);

  if (defined($str))
  { return $ret if defined($ret = _is_ipv4($str)) ||
                   defined($ret = _is_ipv6($str));
    die get_string('BAD_IP', $str) unless $flg;
  }
  else
  { die get_string('NO_IP') unless $flg;
  }
  return;
}

=head2 S<RDA::Object::View-E<gt>is_ipv4($string[,$flag])>

This method indicates whether the string represents an IPv4 address. Unless the
flag is set, it raises an error instead of returning an undefined value.

=cut

sub is_ipv4
{ my (undef, $str, $flg) = @_;
  my ($ret);

  if (defined($str))
  { return $ret if defined($ret = _is_ipv4($str));
    die get_string('BAD_IPV4', $str) unless $flg;
  }
  else
  { die get_string('NO_IPV4') unless $flg;
  }
  return;
}

sub _is_ipv4
{ my ($str) = @_;

  return unless defined($str) && $str =~ m/^(\d{1,3}(\.\d{1,3}){3})$/;
  foreach my $itm (split(/\./, $str = $1))
  { return if $itm > 255 || $itm =~ m/^0\d/;
  }
  return $str;
}

=head2 S<RDA::Object::View-E<gt>is_ipv6($string[,$flag])>

This method indicates whether the string represents an IPv6 address. Unless the
flag is set, it raises an error instead of returning an undefined value.

=cut

sub is_ipv6
{ my (undef, $str, $flg) = @_;
  my ($ret);

  if (defined($str))
  { return $ret if defined($ret = _is_ipv6($str));
    die get_string('BAD_IPV6', $str) unless $flg;
  }
  else
  { die get_string('NO_IPV6') unless $flg;
  }
  return;
}

sub _is_ipv6
{ my ($str) = @_;
  my ($tmp);

  $str = lc($str);

  # Treat special cases
  if ($str =~ m/^(::ffff:(\d{1,3}(\.\d{1,3}){3}))$/)
  { return _is_ipv4($2) ? $1 : undef;
  }
  if ($str =~ s/\.ipv6-literal\.net$//)
  { $str =~ s/-/:/g;
    $str =~ s/s(\d+)$/%$1/;
  }

  # Validate the address
  return unless $str =~ m/^([\da-f]{0,4}(\:[\da-f]{0,4}){2,7}(%\w+)?)$/ ||
                $str =~ m/^\[([\da-f]{0,4}(\:[\da-f]{0,4}){2,7})\]$/;
  $tmp = $str = $1;
  return if $tmp =~ s/::/:/ && $tmp =~ m/::/;
  return $str;
}

=head2 S<RDA::Object::View-E<gt>is_match($string[,case[,$flag]])>

This method indicates whether the string represents a valid pattern. Unless the
flag is set, it raises an error instead of returning an undefined value.

=cut

sub is_match
{ my (undef, $str, $cas, $flg) = @_;
  my ($err, $pat);

  if (!defined($str))
  { die get_string('NO_PATTERN') unless $flg;
  }
  elsif ($str =~ m/\(\?+\{.*\}\)/s)
  { die get_string('BAD_PATTERN', $str) unless $flg;
  }
  else
  { $str =~ s/\!/\\041/g;
    if ($str =~ m/^([^!]*)$/)
    { $pat = $cas ? eval "qr!$1!" : eval "qr!$1!i";  ## no critic (Eval)
      return $pat unless ($err = $@);
      unless ($flg)
      { $err =~ s/\s+at\s+\(eval\s+\d+\)\s+line\s+\d+\.$//;
        die get_string('ERR_PATTERN', $str, $err);
      }
    }
    else
    { die get_string('BAD_PATTERN', $str) unless $flg;
    }
  }
  return $pat;
}

=head2 S<RDA::Object::View-E<gt>is_non_system_port($string[,$flag])>

This method indicates whether the string represents a non-system IP port number
(between 1024 and 65535). Unless the flag is set, it raises an error instead of
returning an undefined value.

=cut

sub is_non_system_port
{ return _is_port(1024, 65535, @_);
}

=head2 S<RDA::Object::View-E<gt>is_pattern($string[,modifiers[,$flag]])>

This method indicates whether the string represents a valid pattern, with
possible modifiers. Unless the flag is set, it raises an error instead of
returning an undefined value.

=cut

sub is_pattern
{ my (undef, $str, $mod, $flg) = @_;
  my ($err, $pat);

  if (!defined($str))
  { die get_string('NO_PATTERN') unless $flg;
  }
  elsif ($str =~ m/\(\?+\{.*\}\)/s)
  { die get_string('BAD_PATTERN', $str) unless $flg;
  }
  else
  { $mod = 'imsx' unless defined($mod);
    $str =~ s/\!/\\041/g;
    if ($str =~ m/^([^!]*?)\#([$mod]+)$/)
    { $pat = eval "qr!$1!$2";  ## no critic (Eval)
      return $pat unless ($err = $@);
      unless ($flg)
      { $err =~ s/\s+at\s+\(eval\s+\d+\)\s+line\s+\d+\.$//;
        die get_string('ERR_PATTERN', $str, $err);
      }
    }
    elsif ($str =~ m/^([^!]*)$/)
    { $pat = eval "qr!$1!";  ## no critic (Eval)
      return $pat unless ($err = $@);
      unless ($flg)
      { $err =~ s/\s+at\s+\(eval\s+\d+\)\s+line\s+\d+\.$//;
        die get_string('ERR_PATTERN', $str, $err);
      }
    }
    else
    { die get_string('BAD_PATTERN', $str) unless $flg;
    }
  }
  return;
}

=head2 S<RDA::Object::View-E<gt>is_port($string[,$flag])>

This method indicates whether the string represents an IP port number. Unless
the flag is set, it raises an error instead of returning an undefined value.

=cut

sub is_port
{ return _is_port(1, 65535, @_);
}

sub _is_port
{ my ($min, $max, undef, $str, $flg) = @_;

  if (defined($str))
  { return $1 if $str =~ m/^([1-9]\d{0,4})$/ && $1 >= $min && $1 <= $max;
    die get_string('BAD_PORT', $str) unless $flg;
  }
  else
  { die get_string('NO_PORT') unless $flg;
  }
  return;
}

=head2 S<RDA::Object::View-E<gt>is_private_port($string[,$flag])>

This method indicates whether the string represents a private or dynamic IP
port number (between 49152 and 65535). Unless the flag is set, it raises an
error instead of returning an undefined value.

=cut

sub is_private_port
{ return _is_port(49152, 65535, @_);
}

=head2 S<RDA::Object::View-E<gt>is_re($string[,$flag])>

This method indicates whether the string represents a valid regular
expression. Unless the flag is set, it raises an error instead of returning an
undefined value.

=cut

sub is_re
{ my (undef, $str, $flg) = @_;
  my ($err);

  if (!defined($str))
  { die get_string('NO_PATTERN') unless $flg;
  }
  elsif ($str =~ m/\(\?+\{.*\}\)/s)
  { die get_string('BAD_PATTERN', $str) unless $flg;
  }
  else
  { $str =~ s/\!/\\041/g;
    if ($str =~ m/^([^!]*)$/)
    { $str = $1;
      eval "qr!$str!";  ## no critic (Eval)
      return $str unless ($err = $@);
      unless ($flg)
      { $err =~ s/\s+at\s+\(eval\s+\d+\)\s+line\s+\d+\.$//;
        die get_string('ERR_PATTERN', $str, $err);
      }
    }
    else
    { die get_string('BAD_PATTERN', $str) unless $flg;
    }
  }
  return;
}

=head2 S<RDA::Object::View-E<gt>is_real($string[,$flag])>

This method indicates whether the string represents a real number. Unless the
flag is set, it raises an error instead of returning an undefined value.

=cut

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

  if (defined($str))
  {return $1 if $str =~ m/^([+-]?(\d+(\.\d*)?|\.\d+)([eE][\+\-]?\d+)?)$/;
    die get_string('BAD_REAL', $str) unless $flg;
  }
  else
  { die get_string('NO_REAL') unless $flg;
  }
  return;
}

=head2 S<$h-E<gt>is_restricted($path)>

This method indicates whether the specified path is an acceptable directory
to be inserted in the C<PATH> environment variable.

=cut

sub is_restricted
{ my ($slf, $pth) = @_;

  return defined($pth)
    ? &{$slf->{'_val'}}($pth =~ m/^([\000-\377]*)$/)
    : undef;
}

sub _is_dir
{ my ($pth) = @_;

  return (defined($pth) && -d $pth && RDA::Object::Rda->is_absolute($pth))
    ? $pth
    : undef;
}

sub _is_restricted
{ my ($pth) = @_;
  my (@sta);

  return (defined($pth) && -d $pth && RDA::Object::Rda->is_absolute($pth)
    && (@sta = stat(_)) && !($sta[2] & 2))  ## no critic (Bit)
    ? $pth
    : undef;
}

=head2 S<RDA::Object::View-E<gt>is_system_port($string[,$flag])>

This method indicates whether the string represents a system IP port number
(between 1 and 1023). Unless the flag is set, it raises an error instead of
returning an undefined value.

=cut

sub is_system_port
{ return _is_port(1, 1023, @_);
}

=head2 S<RDA::Object::View-E<gt>is_unsigned($string[,$flag])>

This method indicates whether the string represents an unsigned integer
number. Unless the flag is set, it raises an error instead of returning an
undefined value.

=cut

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

  if (defined($str))
  {return $1 if $str =~ m/^(\d+)$/;
    die get_string('BAD_UNSIGNED', $str) unless $flg;
  }
  else
  { die get_string('NO_UNSIGNED') unless $flg;
  }
  return;
}

=head2 S<RDA::Object::View-E<gt>is_user($string[,$flag])>

This method indicates whether the string represents a user name. It must start
with a letter, followed by alphanumeric characters, plus signs, dashes,
periods, or underscores, possibly ended by a dollar. Unless the flag is set,
it raises an error instead of returning an undefined value.

=cut

sub is_user
{ my (undef, $str, $flg) = @_;

  if (defined($str))
  { return $1 if $str =~ m/^([A-Za-z][\w\+\-\.]*\$?)$/;
    die get_string('BAD_USER', $str) unless $flg;
  }
  else
  { die get_string('NO_USER') unless $flg;
  }
  return;
}

=head2 S<RDA::Object::View-E<gt>is_user_port($string[,$flag])>

This method indicates whether the string represents an user IP port number
(between 1024 and 49151). Unless the flag is set, it raises an error instead of
returning an undefined value.

=cut

sub is_user_port
{ return _is_port(1024, 49151, @_);
}

=head2 S<RDA::Object::View-E<gt>is_word($string[,$flag])>

This method indicates whether the string represents a word, composed of zero or
more alphanumeric characters and underscores. Unless the flag is set, it raises
an error instead of returning an undefined value.

=cut

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

  if (defined($str))
  {return $1 if $str =~ m/^(\w*)$/;
    die get_string('BAD_WORD', $str) unless $flg;
  }
  else
  { die get_string('NO_WORD') unless $flg;
  }
  return;
}

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

This method returns the last file successfully tested by the C<test_file>
method, quoted as appropriate to execute it in a shell.

=cut

sub last_command
{ return RDA::Object::Rda->quote(shift->{'_fil'});
}

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

This method returns the last directory successfully tested by the C<test_dir>
or C<test_parent> method.

=cut

sub last_dir
{ return shift->{'_dir'};
}

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

This method returns the last file successfully tested by the C<test_file>
method.

=cut

sub last_file
{ return shift->{'_fil'};
}

=head2 S<$h-E<gt>skip_tests([$skp])>

This method indicates which tests must be skipped by the C<test_dir> and
C<test_file> methods, when the argument starts with a dash followed by zero or
more letters. It returns the previous setting.

=cut

sub skip_tests
{ my ($slf, $skp) = @_;
  my ($old);

  $slf = $slf->get_top;
  $old = $slf->{'_skp'};
  $slf->{'_skp'} = $skp if defined($skp) && $skp =~ m/^-\w*$/;
  return $old;
}

=head2 S<$h-E<gt>test_dir($opt,$dir) or $h-E<gt>test_file($opt,$file)>

This method applies one or more tests on the specified file or
directory. Possible tests are as follows:

=over 9

=item B<    'b' > File is a block special file

=item B<    'c' > File is a character special file

=item B<    'd' > File is a directory

=item B<    'e' > File exists

=item B<    'f' > File is a plain file

=item B<    'g' > File has setgid bit set

=item B<    'k' > File has sticky bit set

=item B<    'l' > File is a symbolic link

=item B<    'o' > File is owned by effective uid

=item B<    'p' > File is a named pipe (FIFO)

=item B<    'r' > File is readable by effective uid/gid

=item B<    's' > File has nonzero size

=item B<    't' > File handle is opened to a tty

=item B<    'u' > File has setuid bit set

=item B<    'w' > File is writable by effective uid/gid

=item B<    'x' > File is executable by effective uid/gid

=item B<    'z' > File has zero size (is empty)

=item B<    'B' > File is a binary file (opposite of C<T>)

=item B<    'S' > File is a socket

=item B<    'T' > File is an ASCII text file (heuristic guess)

=back

It returns the path when all specified tests are successful. Otherwise, it
returns an undefined value.

=head2 S<$h-E<gt>test_parent($opt,$file)>

By analogy, this method applies one or more tests on the parent directory of
the specified file. On successful results, it returns the path of the parent
directory.

=cut

sub test_dir
{ return &{$_[0]->{'_tst'}}('_dir', @_);
}

sub test_file
{ return &{$_[0]->{'_tst'}}('_fil', @_);
}

sub test_parent
{ my ($slf, $opt, $fil, $flg) = @_;

  return defined($fil)
    ? &{$slf->{'_tst'}}('_dir', $slf, $opt,
        $slf->{'cfg'}->clean_path([$fil, $slf->{'cfg'}->up_dir, q{}], 1), $flg)
    : undef;
}

sub _test_mode
{ my ($key, $slf, $opt, $fil, $flg) = @_;
  my ($pth, $res, $skp);

  if (defined($fil))
  { return unless $fil =~ m/^([\000-\377]*)$/;
    $fil = $pth = $1;
    $fil =~ s/`/\\`/g;
    $fil =~ s/\\+$/\\\\/;
    $fil =~ s/'/'."'".'/g;
    $opt = q{} unless defined($opt);
    if (ref($slf))
    { $skp = $slf->get_top('_skp');
    }
    else
    { $flg = 1;
      $skp = q{};
    }
    foreach my $tst (split(//, $opt))
    { next if index($skp, $tst) >= 0;
      $res = index('bcdefgkloprstuwxzBST', $tst) >= 0
        && eval "-$tst '$fil'";  ## no critic (Eval)
      return if !$res || $@;
    }
    $slf->{$key} = $pth unless $flg;
  }
  return $pth;
}

=head1 OPERATING SYSTEM-RELATED METHODS

=head2 S<$h-E<gt>basename($file[,@suf])>

This method extracts the base name of the file specification and  removes the
suffix when it belongs to the suffix list. It matches each element of this list
as a string against the end of the name.

When treating existing files from systems that are not case-sensitive, the
pattern matching for suffix removal ignores case.

=head2 S<$h-E<gt>cat_dir([$dir...,]$dir)>

This method concatenates directory names to form a complete path ending with a
directory. It removes the trailing slash from the resulting string, except for
the root directory.

It discards undefined values and references from the argument list.

=head2 S<$h-E<gt>cat_file([$dir...,]$file)>

This method concatenates directory names and a file name to form a complete
path ending with a file name.

It discards undefined values and references from the argument list.

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

This method performs a logical cleanup of a path. When the flag is set, it
performs additional platform-specific simplifications.

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

This method returns a string representation of the current directory (C<.> for
UNIX).

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

This method returns a string representation of the null device.

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

This method returns a string representation of the terminal device.

=head2 S<$h-E<gt>dirname($file)>

This method returns the directory portion of the input file specification.

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

This method returns the character used as the separator.

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

This method returns the user name.

=head2 S<$h-E<gt>is_absolute($path)>

This method indicates whether or not the argument is an absolute path.

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

This method returns a true value when the operating system associated to the
view is Cygwin.

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

This method verifies that the string does not contain characters invalid in a
path.

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

This method returns a true value when the operating system associated to the
view belongs to the UNIX family.

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

This method returns a true value when the operating system associated to the
view is VMS.

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

This method returns a true value when the operating system associated to the
view belongs to the Windows family.

=head2 S<$h-E<gt>parse_path($path[,@suf])>

This method divides a file path into the directories, its file name, and
optionally the file suffix. The directory part contains everything up to and
including the last directory separator in the $path including the volume, when
applicable. The remainder of the path is the file name.

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

This method encodes a string to be considered as a single argument by a command
shell. Unless the flag is set, variable substitution is disabled.

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

This method is similar to the C<quote> method but the result does not contain
the leading and trailing quotation marks.

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

This method converts a string containing wild cards into a Perl regular
expression.

=head2 S<$h-E<gt>split_dir($path)>

This method returns the list of directories contained in the specified
path. Unlike just splitting the directories on the separator, empty directory
names (C<''>) can be returned, because these are significant on some operating
systems. The first element can contain volume information.

For UNIX,

    $h->split_dir("/a/b//c/");

Yields:

    ('', 'a', 'b', '', 'c', '')

=head2 S<$h-E<gt>split_volume($path)>

This method separates the volume from the other path information.

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

This method removes the quoting characters from a string.

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

This method returns a string representation of the parent directory (C<..> for
UNIX).

=cut

sub AUTOLOAD  ## no critic (Autoload)
{ my ($slf, @arg) = @_;
  my ($cmd);

  ($cmd) = $AUTOLOAD =~ m/::(\w+)$/;
  return unless ref($slf->{'cfg'}) && $slf->{'cfg'}->can($cmd);
  return $slf->{'cfg'}->$cmd(@arg);
}

# --- Initialization routines -------------------------------------------------

# Get libclntsh.so directory
sub _get_libclntsh
{ my ($slf, $nam) = @_;
  my ($env, $ora, $sep);

  $env = $slf->{'_env'};
  if (exists($env->{$nam}))
  { $sep = $slf->get_separator;
    foreach my $dir (split(/$sep/, $env->{$nam}))
    { return $ora
        if -d ($ora = RDA::Object::Rda->cat_dir($dir))
        && -f RDA::Object::Rda->cat_file($ora, 'libclntsh.so');
    }
  }
  return (exists($env->{'ORACLE_HOME'})
    && -d ($ora = RDA::Object::Rda->cat_dir($env->{'ORACLE_HOME'}, 'lib'))
    && -f RDA::Object::Rda->cat_file($ora, 'libclntsh.so')) ? $ora : undef;
}

# Get oci.dll directory
sub _get_oci
{ my ($slf, $pat, $fct) = @_;
  my ($env, $sep);

  $env = $slf->{'_env'};
  unless (exists($env->{'RDA_NO_DBD_ORACLE'}) && $env->{'RDA_NO_DBD_ORACLE'})
  { $sep = $slf->get_separator;
    foreach my $dir (split(/$sep/, $env->{'PATH'}))
    { return $1 if RDA::Object::Rda->is_absolute($dir)
        && $dir =~ $pat
        && -f RDA::Object::Rda->cat_file($1, 'oci.dll')
    }
  }
  return;
}

# Get 32-bit oci.dll directory
sub _get_oci32
{ my ($slf, $pat, $fct) = @_;
  my ($env, $lin, $pth, $sep);

  $env = $slf->{'_env'};
  unless (exists($env->{'RDA_NO_DBD_ORACLE'}) && $env->{'RDA_NO_DBD_ORACLE'})
  { $sep = $slf->get_separator;
    foreach my $dir (split(/$sep/, $env->{'PATH'}))
    { next unless RDA::Object::Rda->is_absolute($dir) && $dir =~ $pat
        && -f ($pth = RDA::Object::Rda->cat_file($dir = $1, 'oci.dll'));
      $pth =~ s/'/'"'"'/g;
      ($lin) = `/bin/file '$pth'`;
      return $dir if $lin =~ m/: PE32 executable /;
    }
  }
  return;
}

# Get Perl directory
sub _get_perl
{ my ($pat, $fct) = @_;
  my ($dir);

  if ($^X !~ m/\b(?:rda|sdci)(?:\.exe|_\w+56)$/i
    && RDA::Object::Rda->is_absolute($^X))
  { $dir = RDA::Object::Rda->dirname($^X);
    return $1 if &$fct($dir =~ $pat);
  }
  return;
}

# Set a Cygwin system view
sub _ini_cygwin
{ my ($slf, $cfg) = @_;
  my ($bin, $fct, $pat, $pth, $tbl);

  $pat = qr/^([^;]*)$/;

  # Adapt the command path
  $fct = $slf->{'_val'};
  $tbl = _define_list($slf, 'pth', 'PATH')->{'det'};
  push(@{$tbl}, $bin = $pth) if &$fct($pth = '/bin');
  push(@{$tbl}, $pth)        if &$fct($pth = '/usr/sbin');
  push(@{$tbl}, $bin = $pth) if &$fct($pth = '/usr/bin');
  push(@{$tbl}, $pth)        if &$fct($pth = '/etc');
  push(@{$tbl}, $pth)        if &$fct($pth = '/usr/ccs/bin');
  push(@{$tbl}, $pth)        if &$fct($pth = '/sbin');
  die get_string('ERR_INSECURE') unless defined($bin);
  if ($ENV{'SYSTEMROOT'} =~ m/^([A-Z]:\\\w+)$/)
  { push(@{$tbl}, $pth) if -d ($pth = $cfg->cat_dir($1, 'System32'));
    push(@{$tbl}, $pth) if -d ($pth = $cfg->cat_dir($1));
    push(@{$tbl}, $pth) if -d ($pth = $cfg->cat_dir($1, 'System32', 'wbem'));
  }
  unshift(@{$tbl}, $pth)
    if defined($pth = _get_perl($pat, $fct)) && _is_new($tbl, $pth);
  _set_list($slf, 'pth');
  push(@{$tbl}, $pth)
    if defined($pth = _get_oci32($slf, $pat, $fct)) && _is_new($tbl, $pth);
  _set_list($slf, 'pth');

  # Create the native view
  $slf->{'_nat'} = $slf->new('NAT', 'MSWin32');

  # Return the object reference
  return $slf;
}

# Set a Unix system view
sub _ini_unix
{ my ($slf, $cfg) = @_;
  my ($bin, $fct, $nam, $pth, $tbl);

  $slf->{'_val'} = \&_is_restricted if $slf->{'flg'};

  # Adapt the command path
  $fct = $slf->{'_val'};
  $tbl = _define_list($slf, 'pth', 'PATH')->{'det'};
  push(@{$tbl}, $bin = $pth) if &$fct($pth = '/bin');
  push(@{$tbl}, $pth)        if &$fct($pth = '/usr/sbin');
  push(@{$tbl}, $bin = $pth) if &$fct($pth = '/usr/bin');
  push(@{$tbl}, $pth)        if &$fct($pth = '/etc');
  push(@{$tbl}, $pth)        if &$fct($pth = '/usr/ccs/bin');
  push(@{$tbl}, $pth)        if &$fct($pth = '/usr/local/bin');
  push(@{$tbl}, $pth)        if &$fct($pth = '/sbin');
  die get_string('ERR_INSECURE') unless defined($bin);
  unshift(@{$tbl}, $pth)
    if defined($pth = _get_perl(qr/^([^:;]*)$/, $fct)) && _is_new($tbl, $pth);
  _set_list($slf, 'pth');

  # Adapt the shared library path
  if (defined($nam = $cfg->get_shlib))
  { $tbl = _define_list($slf, 'shl', $nam)->{'det'};
    foreach my $pth ('/lib',
                     '/usr/lib',
                     '/usr/local/lib')
    { push(@{$tbl}, $pth) if -d $pth;
    }
    push(@{$tbl}, $pth) if defined($pth = _get_libclntsh($slf, $nam));
    _set_list($slf, 'shl');
  }

  # Return the object reference
  return $slf;
}

# Set a VMS system view
sub _ini_vms
{ my ($slf) = @_;

  # Prevent environment modification
  $slf->{'_ref'} = -1;

  # Return the object reference
  return $slf;
}

# Set a Windows system view
sub _ini_windows
{ my ($slf, $cfg) = @_;
  my ($fct, $pat, $pth, $tbl);

  $pat = qr/^([^;]*)$/;

  # Adapt the command path
  $fct = $slf->{'_val'};
  $tbl = _define_list($slf, 'pth', 'PATH')->{'det'};
  if ($ENV{'SYSTEMROOT'} =~ m/^([A-Z]:\\\w+)$/)
  { push(@{$tbl}, $pth) if -d ($pth = $cfg->cat_dir($1, 'System32'));
    push(@{$tbl}, $pth) if -d ($pth = $cfg->cat_dir($1));
    push(@{$tbl}, $pth) if -d ($pth = $cfg->cat_dir($1, 'System32', 'wbem'));
  }
  unshift(@{$tbl}, $pth)
    if defined($pth = _get_perl($pat, $fct)) && _is_new($tbl, $pth);
  push(@{$tbl}, $pth)
    if defined($pth = _get_oci($slf, $pat, $fct)) && _is_new($tbl, $pth);
  _set_list($slf, 'pth');

  # Return the object reference
  return $slf;
}

# Check if not yet in the list
sub _is_new
{ my ($tbl, $val) = @_;

  foreach my $itm (@{$tbl})
  { return 0 if $val eq $itm;
  }
  return 1;
}

# --- Restriction routines ----------------------------------------------------

# Load the execution restrictions
sub _init_restrictions
{ my ($slf) = @_;
  my ($bas, $cfg, $col, $dir, $fct, $lim);

  $lim = {bas => {}, dir => {}, pth => {}};

  # Load restrictions
  $cfg = $slf->{'cfg'};
  $col = $slf->{'agt'}->get_collector;
  $fct = $slf->{'_fct'};
  foreach my $prp (@{$tb_prp{$slf->{'_fam'}}})
  { foreach my $cmd ($col->get_value($prp))
    { $bas = $cfg->basename($cmd = $cfg->cat_file($cmd));
      if ($cfg->is_absolute($cmd))
      { $dir= $cfg->dirname($cmd);
        foreach my $key (&{$fct->{'key'}}($bas))
        { $lim->{'dir'}->{$key}->{&{$fct->{'pth'}}($dir)} = 1;
          $lim->{'pth'}->{&{$fct->{'pth'}}($cfg->cat_file($dir, $key))} = 1;
        }
      }
      else
      { foreach my $key (&{$fct->{'key'}}($bas))
        { $lim->{'bas'}->{$key} = 0;
        }
      }
    }
  }

  # Return the restriction definition hash
  return $slf->{'_lim'} = $lim;
}

# Return the argument without change
sub _lim_no_chg
{ return shift;
}

# Normalize the path on VMS
sub _lim_vms_pth
{ my ($pth) = @_;

  return uc($pth);
}

# Normalize the path on Windows
sub _lim_win_pth
{ my ($dir) = @_;

  return lc($dir);
}

# Return the list of restriction keys
sub _lim_win_key
{ my ($cmd) = @_;

  $cmd = lc($cmd);
  return ($cmd) if $cmd =~ m/\.(bat|cmd|exe)$/;
  return ($cmd, "$cmd.bat", "$cmd.cmd", "$cmd.exe");
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Local::Cygwin|RDA::Local::Cygwin>,
L<RDA::Local::Unix|RDA::Local::Unix>,
L<RDA::Local::Vms|RDA::Local::Vms>,
L<RDA::Local::Windows|RDA::Local::Windows>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::View|RDA::Object::View>,
L<RDA::Object::Rda|RDA::Object::Rda>,
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