[Summary view] [Print] [Text view]

   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;