"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/Env.pm" (23 Apr 2014, 5524 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 package Env;
    2 
    3 our $VERSION = '1.04';
    4 
    5 =head1 NAME
    6 
    7 Env - perl module that imports environment variables as scalars or arrays
    8 
    9 =head1 SYNOPSIS
   10 
   11     use Env;
   12     use Env qw(PATH HOME TERM);
   13     use Env qw($SHELL @LD_LIBRARY_PATH);
   14 
   15 =head1 DESCRIPTION
   16 
   17 Perl maintains environment variables in a special hash named C<%ENV>.  For
   18 when this access method is inconvenient, the Perl module C<Env> allows
   19 environment variables to be treated as scalar or array variables.
   20 
   21 The C<Env::import()> function ties environment variables with suitable
   22 names to global Perl variables with the same names.  By default it
   23 ties all existing environment variables (C<keys %ENV>) to scalars.  If
   24 the C<import> function receives arguments, it takes them to be a list of
   25 variables to tie; it's okay if they don't yet exist. The scalar type
   26 prefix '$' is inferred for any element of this list not prefixed by '$'
   27 or '@'. Arrays are implemented in terms of C<split> and C<join>, using
   28 C<$Config::Config{path_sep}> as the delimiter.
   29 
   30 After an environment variable is tied, merely use it like a normal variable.
   31 You may access its value 
   32 
   33     @path = split(/:/, $PATH);
   34     print join("\n", @LD_LIBRARY_PATH), "\n";
   35 
   36 or modify it
   37 
   38     $PATH .= ":.";
   39     push @LD_LIBRARY_PATH, $dir;
   40 
   41 however you'd like. Bear in mind, however, that each access to a tied array
   42 variable requires splitting the environment variable's string anew.
   43 
   44 The code:
   45 
   46     use Env qw(@PATH);
   47     push @PATH, '.';
   48 
   49 is equivalent to:
   50 
   51     use Env qw(PATH);
   52     $PATH .= ":.";
   53 
   54 except that if C<$ENV{PATH}> started out empty, the second approach leaves
   55 it with the (odd) value "C<:.>", but the first approach leaves it with "C<.>".
   56 
   57 To remove a tied environment variable from
   58 the environment, assign it the undefined value
   59 
   60     undef $PATH;
   61     undef @LD_LIBRARY_PATH;
   62 
   63 =head1 LIMITATIONS
   64 
   65 On VMS systems, arrays tied to environment variables are read-only. Attempting
   66 to change anything will cause a warning.
   67 
   68 =head1 AUTHOR
   69 
   70 Chip Salzenberg E<lt>F<chip@fin.uucp>E<gt>
   71 and
   72 Gregor N. Purdy E<lt>F<gregor@focusresearch.com>E<gt>
   73 
   74 =cut
   75 
   76 sub import {
   77     my ($callpack) = caller(0);
   78     my $pack = shift;
   79     my @vars = grep /^[\$\@]?[A-Za-z_]\w*$/, (@_ ? @_ : keys(%ENV));
   80     return unless @vars;
   81 
   82     @vars = map { m/^[\$\@]/ ? $_ : '$'.$_ } @vars;
   83 
   84     eval "package $callpack; use vars qw(" . join(' ', @vars) . ")";
   85     die $@ if $@;
   86     foreach (@vars) {
   87     my ($type, $name) = m/^([\$\@])(.*)$/;
   88     if ($type eq '$') {
   89         tie ${"${callpack}::$name"}, Env, $name;
   90     } else {
   91         if ($^O eq 'VMS') {
   92         tie @{"${callpack}::$name"}, Env::Array::VMS, $name;
   93         } else {
   94         tie @{"${callpack}::$name"}, Env::Array, $name;
   95         }
   96     }
   97     }
   98 }
   99 
  100 sub TIESCALAR {
  101     bless \($_[1]);
  102 }
  103 
  104 sub FETCH {
  105     my ($self) = @_;
  106     $ENV{$$self};
  107 }
  108 
  109 sub STORE {
  110     my ($self, $value) = @_;
  111     if (defined($value)) {
  112     $ENV{$$self} = $value;
  113     } else {
  114     delete $ENV{$$self};
  115     }
  116 }
  117 
  118 ######################################################################
  119 
  120 package Env::Array;
  121  
  122 use Config;
  123 use Tie::Array;
  124 
  125 @ISA = qw(Tie::Array);
  126 
  127 my $sep = $Config::Config{path_sep};
  128 
  129 sub TIEARRAY {
  130     bless \($_[1]);
  131 }
  132 
  133 sub FETCHSIZE {
  134     my ($self) = @_;
  135     return 1 + scalar(() = $ENV{$$self} =~ /\Q$sep\E/g);
  136 }
  137 
  138 sub STORESIZE {
  139     my ($self, $size) = @_;
  140     my @temp = split($sep, $ENV{$$self});
  141     $#temp = $size - 1;
  142     $ENV{$$self} = join($sep, @temp);
  143 }
  144 
  145 sub CLEAR {
  146     my ($self) = @_;
  147     $ENV{$$self} = '';
  148 }
  149 
  150 sub FETCH {
  151     my ($self, $index) = @_;
  152     return (split($sep, $ENV{$$self}))[$index];
  153 }
  154 
  155 sub STORE {
  156     my ($self, $index, $value) = @_;
  157     my @temp = split($sep, $ENV{$$self});
  158     $temp[$index] = $value;
  159     $ENV{$$self} = join($sep, @temp);
  160     return $value;
  161 }
  162 
  163 sub EXISTS {
  164     my ($self, $index) = @_;
  165     return $index < $self->FETCHSIZE;
  166 }
  167 
  168 sub DELETE {
  169     my ($self, $index) = @_;
  170     my @temp = split($sep, $ENV{$$self});
  171     my $value = splice(@temp, $index, 1, ());
  172     $ENV{$$self} = join($sep, @temp);
  173     return $value;
  174 }
  175 
  176 sub PUSH {
  177     my $self = shift;
  178     my @temp = split($sep, $ENV{$$self});
  179     push @temp, @_;
  180     $ENV{$$self} = join($sep, @temp);
  181     return scalar(@temp);
  182 }
  183 
  184 sub POP {
  185     my ($self) = @_;
  186     my @temp = split($sep, $ENV{$$self});
  187     my $result = pop @temp;
  188     $ENV{$$self} = join($sep, @temp);
  189     return $result;
  190 }
  191 
  192 sub UNSHIFT {
  193     my $self = shift;
  194     my @temp = split($sep, $ENV{$$self});
  195     my $result = unshift @temp, @_;
  196     $ENV{$$self} = join($sep, @temp);
  197     return $result;
  198 }
  199 
  200 sub SHIFT {
  201     my ($self) = @_;
  202     my @temp = split($sep, $ENV{$$self});
  203     my $result = shift @temp;
  204     $ENV{$$self} = join($sep, @temp);
  205     return $result;
  206 }
  207 
  208 sub SPLICE {
  209     my $self = shift;
  210     my $offset = shift;
  211     my $length = shift;
  212     my @temp = split($sep, $ENV{$$self});
  213     if (wantarray) {
  214     my @result = splice @temp, $offset, $length, @_;
  215     $ENV{$$self} = join($sep, @temp);
  216     return @result;
  217     } else {
  218     my $result = scalar splice @temp, $offset, $length, @_;
  219     $ENV{$$self} = join($sep, @temp);
  220     return $result;
  221     }
  222 }
  223 
  224 ######################################################################
  225 
  226 package Env::Array::VMS;
  227 use Tie::Array;
  228 
  229 @ISA = qw(Tie::Array);
  230  
  231 sub TIEARRAY {
  232     bless \($_[1]);
  233 }
  234 
  235 sub FETCHSIZE {
  236     my ($self) = @_;
  237     my $i = 0;
  238     while ($i < 127 and defined $ENV{$$self . ';' . $i}) { $i++; };
  239     return $i;
  240 }
  241 
  242 sub FETCH {
  243     my ($self, $index) = @_;
  244     return $ENV{$$self . ';' . $index};
  245 }
  246 
  247 sub EXISTS {
  248     my ($self, $index) = @_;
  249     return $index < $self->FETCHSIZE;
  250 }
  251 
  252 sub DELETE { }
  253 
  254 1;