# Env.pm: Class Used for Managing Environment Variables

package RDA::Object::Env;

# $Id: Env.pm,v 1.17 2014/04/24 17:04:24 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Object/Env.pm,v 1.17 2014/04/24 17:04:24 RDA Exp $
#
# Change History
# 20140424  MSC  Rename the delete method.

=head1 NAME

RDA::Object::Env - Class Used for Managing Environment Variables

=head1 SYNOPSIS

 require RDA::Object::Env;

=head1 DESCRIPTION

The objects of the C<RDA::Object::Env> class are used for managing environment
variables. It is a subclass of L<RDA::Object|RDA::Object>.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use RDA::Text qw(get_string);
  use RDA::Object;
  use RDA::Object::Rda;
  use RDA::Object::View;
}

# Define the global public variables
use vars qw($STRINGS $VERSION @ISA %SDCL);
$VERSION = sprintf('%d.%02d', q$Revision: 1.17 $ =~ /(\d+)\.(\d+)/);
@ISA     = qw(RDA::Object Exporter);
%SDCL    = (
  als => {
    ## no critic (Interpolation)
    'getEnv'     => ['$[ENV]', 'get_value'],
    'grepEnv'    => ['$[ENV]', 'grep'],
    'replaceEnv' => ['$[ENV]', 'resolve'],
    'setEnv'     => ['$[ENV]', 'set_value'],
    'source'     => ['$[ENV]', 'source'],
    'unsource'   => ['$[ENV]', 'unsource'],
    },
  beg => \&_begin_env,
  inc => [qw(RDA::Object)],
  met => {
    'find'          => {ret => 0},
    'get_separator' => {ret => 0},
    'get_value'     => {ret => 0},
    'grep'          => {ret => 1},
    'resolve'       => {ret => 0},
    'source'        => {ret => 0},
    'unsource'      => {ret => 0},
    'set_value'     => {ret => 0},
    'split_value'   => {ret => 1},
    },
  top => 'ENV',
  );

# Define the global private constants

# Define the global private variables

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

=head2 S<$h = RDA::Object::Env-E<gt>new($env)>

The object constructor. This method gets a reference to an environment copy as
an argument and considers the object as read-only.

=head2 S<$h = $obj-E<gt>new([$flag])>

This object constructor clones the environment variable object and returns a
reference to the new object. Modifications are allowed in that new object
unless the flag is set.

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

=over 12

=item S<    B<'oid' > > Object identifier

=item S<    B<'_bkp'> > Hash that contains the saved values

=item S<    B<'_env'> > Hash that contains the original environment variables

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

=back

Internal keys are prefixed by an underscore.

=cut

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

  # Create the object
  if (ref($cls))
  { $slf = bless {
      oid  => 'COPY',
      _env => {%{$cls->{'_env'}}},
      _ref => $env ? -1 : 0,
    }, ref($cls);
  }
  else
  { die get_string('NO_ENV') unless ref($env) eq 'HASH';
    $slf = bless {
      oid  => 'ENV',
      _env => $env,
      _ref => 1
      }, $cls;

    # Eliminate environment alterations
    foreach my $key (grep {m/^RDA_ALTER_/} keys(%{$env}))
    { next unless delete($env->{$key}) =~ m/^(\w+)=(.*)$/;
      if (length($2))
      { $env->{$1} = $2;
      }
      else
      { delete($env->{$1});
      }
    }
  }

  # Return the object reference
  return $slf;
}

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

This method undoes changes made to environment variables performed by previous
C<source> calls and next deletes the environment copy.

=cut

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

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

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, @arg) = @_;

  return RDA::Object::Rda->find_path($slf->{'_env'}->{'PATH'}, @arg);
}

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

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

If the flag is set, it retrieves the value from the current environment instead
of the local copy.

=cut

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

  $val = $1
    if exists($slf->{'_env'}->{$key})
    && $slf->{'_env'}->{$key} =~ m/^([^']*)$/;
  if (wantarray)
  { return ($val) if defined($val);
    return ();
  }
  return $val;
}

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

This method returns the operating system specific value separator.

=cut

sub get_separator
{ return RDA::Object::Rda->get_separator;
}

=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) = @_;

  $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 = RDA::Object::View->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->{'_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 (RDA::Object::Rda->is_unix)
    { $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 (RDA::Object::Rda->is_windows || RDA::Object::Rda->is_cygwin)
    { 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. When the flag is set, it
adjusts the internal copy of the environment variable also. An error is raised
when trying to modify the read-only copy of the environment variables.

It returns the previous value of the environment variable.

=cut

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

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

  $old = delete($slf->{'_env'}->{$key});
  $slf->{'_env'}->{$key} = (ref($val) eq 'ARRAY')
    ? join(RDA::Object::Rda->get_separator,
             grep {defined($_) && !ref($_)} @{$val})
    : $val
    if defined($val);
  return $old;
}

=head2 S<$h-E<gt>source($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. Unless the flag is set, the method modifies the internal copy of the
environment variables only. 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  ## no critic (Complex)
{ my ($slf, $pgm, $shl) = @_;
  my ($chk, $cmd, $cnt, $prv, $ref, %prv);

  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" |';
  }
  else
  { $shl = 'sh'
      unless defined($shl) && -x $shl  ## no critic (Unless)
          && !RDA::Object->is_tainted($shl);
    $ref = "$shl -c 'env' |";
    $cmd = "$shl -c '. $pgm 2>/dev/null ; env' |";
  }

  # Take a copy of the current environment
  return 0 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 0 unless $pgm && open(IN, $cmd);  ## no critic (Handle,Open)
  $chk = $cnt = 0;
  while (<IN>)
  { s/[\r\n]*$//;
    if (m/^(\w+)=(.*)$/)
    { ++$chk;
      unless (defined($prv = delete($prv{$1})) && $prv eq $2)
      { $slf->{'_bkp'}->{$1} = $slf->{'_env'}->{$1};
        $slf->{'_env'}->{$1} = $2;
        ++$cnt;
      }
    }
  }
  close(IN);
  if ($chk)
  { foreach my $key (keys(%prv))
    { if (exists($slf->{'_env'}->{$key}))
      { $slf->{'_bkp'}->{$key} = $slf->{'_env'}->{$key};
        delete($slf->{'_env'}->{$key});
        ++$cnt;
      }
    }
  }

  # Returns the number of modified variables
  return $cnt;
}

=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) = @_;

  return () unless exists($slf->{'_env'}->{$key});
  $sep = RDA::Object::Rda->get_separator unless defined($sep);
  return split($sep, $slf->{'_env'}->{$key}, -1);
}

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

This method undoes changes made to environment variables performed by previous
C<source> calls. It returns the number of restored variables.

=cut

sub unsource
{ my ($slf) = @_;
  my ($cnt, $tbl, $val);

  $cnt = 0;
  if (exists($slf->{'_bkp'}))
  { foreach my $key (keys(%{$tbl = delete($slf->{'_bkp'})}))
    { if (defined($val = $tbl->{$key}))
      { $slf->{'_env'}->{$key}  = $val;
      }
      else
      { delete($slf->{'_env'}->{$key});
      }
      ++$cnt;
    }
  }

  # Return the number of modified variables
  return $cnt;
}

*unlink = \&unsource;

# --- SDCL extensions ---------------------------------------------------------

# Define a package attribute to access environment variables
sub _begin_env
{ my ($pkg) = @_;

  $pkg->set_top('ENV', $pkg->get_agent->get_env->new);
  return;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Object|RDA::Object>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Object::View|RDA::Object::View>,
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