lib/perl5/5.8.8/Env.pm

   1 package Env;
   2
   3 our $VERSION = '1.00';
   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     my @temp = split($sep, $ENV{$$self});
 136     return scalar(@temp);
 137 }
 138
 139 sub STORESIZE {
 140     my ($self, $size) = @_;
 141     my @temp = split($sep, $ENV{$$self});
 142     $#temp = $size - 1;
 143     $ENV{$$self} = join($sep, @temp);
 144 }
 145
 146 sub CLEAR {
 147     my ($self) = @_;
 148     $ENV{$$self} = '';
 149 }
 150
 151 sub FETCH {
 152     my ($self, $index) = @_;
 153     return (split($sep, $ENV{$$self}))[$index];
 154 }
 155
 156 sub STORE {
 157     my ($self, $index, $value) = @_;
 158     my @temp = split($sep, $ENV{$$self});
 159     $temp[$index] = $value;
 160     $ENV{$$self} = join($sep, @temp);
 161     return $value;
 162 }
 163
 164 sub PUSH {
 165     my $self = shift;
 166     my @temp = split($sep, $ENV{$$self});
 167     push @temp, @_;
 168     $ENV{$$self} = join($sep, @temp);
 169     return scalar(@temp);
 170 }
 171
 172 sub POP {
 173     my ($self) = @_;
 174     my @temp = split($sep, $ENV{$$self});
 175     my $result = pop @temp;
 176     $ENV{$$self} = join($sep, @temp);
 177     return $result;
 178 }
 179
 180 sub UNSHIFT {
 181     my $self = shift;
 182     my @temp = split($sep, $ENV{$$self});
 183     my $result = unshift @temp, @_;
 184     $ENV{$$self} = join($sep, @temp);
 185     return $result;
 186 }
 187
 188 sub SHIFT {
 189     my ($self) = @_;
 190     my @temp = split($sep, $ENV{$$self});
 191     my $result = shift @temp;
 192     $ENV{$$self} = join($sep, @temp);
 193     return $result;
 194 }
 195
 196 sub SPLICE {
 197     my $self = shift;
 198     my $offset = shift;
 199     my $length = shift;
 200     my @temp = split($sep, $ENV{$$self});
 201     if (wantarray) {
 202         my @result = splice @temp, $self, $offset, $length, @_;
 203         $ENV{$$self} = join($sep, @temp);
 204         return @result;
 205     } else {
 206         my $result = scalar splice @temp, $offset, $length, @_;
 207         $ENV{$$self} = join($sep, @temp);
 208         return $result;
 209     }
 210 }
 211
 212 ######################################################################
 213
 214 package Env::Array::VMS;
 215 use Tie::Array;
 216
 217 @ISA = qw(Tie::Array);
 218
 219 sub TIEARRAY {
 220     bless \($_[1]);
 221 }
 222
 223 sub FETCHSIZE {
 224     my ($self) = @_;
 225     my $i = 0;
 226     while ($i < 127 and defined $ENV{$$self . ';' . $i}) { $i++; };
 227     return $i;
 228 }
 229
 230 sub FETCH {
 231     my ($self, $index) = @_;
 232     return $ENV{$$self . ';' . $index};
 233 }
 234
 235 1;