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