lib/Env.pm

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