| 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; |
