lib/Env.pm

   1 package Env;
   2
   3 our $VERSION = '1.01';
   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, $self, $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;