X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FEnv.pm;h=deac5fc4b92601ac8dfab4650825c8d9721bc8f2;hb=3387927231e5bf4138a3082ecafb247e03a8061a;hp=1f06bebf24160deecbcbc8070dc367370d283cca;hpb=40da2db335c65d50d3bca886fcc7161ed72faf74;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Env.pm b/lib/Env.pm index 1f06beb..deac5fc 100644 --- a/lib/Env.pm +++ b/lib/Env.pm @@ -1,59 +1,99 @@ package Env; +our $VERSION = '1.01'; + =head1 NAME -Env - perl module that imports environment variables +Env - perl module that imports environment variables as scalars or arrays =head1 SYNOPSIS use Env; use Env qw(PATH HOME TERM); + use Env qw($SHELL @LD_LIBRARY_PATH); =head1 DESCRIPTION -Perl maintains environment variables in a pseudo-associative-array -named %ENV. For when this access method is inconvenient, the Perl -module C allows environment variables to be treated as simple -variables. +Perl maintains environment variables in a special hash named C<%ENV>. For +when this access method is inconvenient, the Perl module C allows +environment variables to be treated as scalar or array variables. -The Env::import() function ties environment variables with suitable +The C function ties environment variables with suitable names to global Perl variables with the same names. By default it -does so with all existing environment variables (C). If -the import function receives arguments, it takes them to be a list of -environment variables to tie; it's okay if they don't yet exist. +ties all existing environment variables (C) to scalars. If +the C function receives arguments, it takes them to be a list of +variables to tie; it's okay if they don't yet exist. The scalar type +prefix '$' is inferred for any element of this list not prefixed by '$' +or '@'. Arrays are implemented in terms of C and C, using +C<$Config::Config{path_sep}> as the delimiter. After an environment variable is tied, merely use it like a normal variable. You may access its value @path = split(/:/, $PATH); + print join("\n", @LD_LIBRARY_PATH), "\n"; or modify it $PATH .= ":."; + push @LD_LIBRARY_PATH, $dir; + +however you'd like. Bear in mind, however, that each access to a tied array +variable requires splitting the environment variable's string anew. + +The code: + + use Env qw(@PATH); + push @PATH, '.'; + +is equivalent to: + + use Env qw(PATH); + $PATH .= ":."; + +except that if C<$ENV{PATH}> started out empty, the second approach leaves +it with the (odd) value "C<:.>", but the first approach leaves it with "C<.>". -however you'd like. To remove a tied environment variable from the environment, assign it the undefined value undef $PATH; + undef @LD_LIBRARY_PATH; + +=head1 LIMITATIONS + +On VMS systems, arrays tied to environment variables are read-only. Attempting +to change anything will cause a warning. =head1 AUTHOR Chip Salzenberg EFE +and +Gregor N. Purdy EFE =cut sub import { my ($callpack) = caller(0); my $pack = shift; - my @vars = @_ ? @_ : keys(%ENV); + my @vars = grep /^[\$\@]?[A-Za-z_]\w*$/, (@_ ? @_ : keys(%ENV)); return unless @vars; - eval "package $callpack; use vars qw(" - . join(' ', map { '$'.$_ } @vars) . ")"; + @vars = map { m/^[\$\@]/ ? $_ : '$'.$_ } @vars; + + eval "package $callpack; use vars qw(" . join(' ', @vars) . ")"; die $@ if $@; foreach (@vars) { - tie ${"${callpack}::$_"}, Env, $_ if /^[A-Za-z_]\w*$/; + my ($type, $name) = m/^([\$\@])(.*)$/; + if ($type eq '$') { + tie ${"${callpack}::$name"}, Env, $name; + } else { + if ($^O eq 'VMS') { + tie @{"${callpack}::$name"}, Env::Array::VMS, $name; + } else { + tie @{"${callpack}::$name"}, Env::Array, $name; + } + } } } @@ -75,4 +115,140 @@ sub STORE { } } +###################################################################### + +package Env::Array; + +use Config; +use Tie::Array; + +@ISA = qw(Tie::Array); + +my $sep = $Config::Config{path_sep}; + +sub TIEARRAY { + bless \($_[1]); +} + +sub FETCHSIZE { + my ($self) = @_; + return 1 + scalar(() = $ENV{$$self} =~ /\Q$sep\E/g); +} + +sub STORESIZE { + my ($self, $size) = @_; + my @temp = split($sep, $ENV{$$self}); + $#temp = $size - 1; + $ENV{$$self} = join($sep, @temp); +} + +sub CLEAR { + my ($self) = @_; + $ENV{$$self} = ''; +} + +sub FETCH { + my ($self, $index) = @_; + return (split($sep, $ENV{$$self}))[$index]; +} + +sub STORE { + my ($self, $index, $value) = @_; + my @temp = split($sep, $ENV{$$self}); + $temp[$index] = $value; + $ENV{$$self} = join($sep, @temp); + return $value; +} + +sub EXISTS { + my ($self, $index) = @_; + return $index < $self->FETCHSIZE; +} + +sub DELETE { + my ($self, $index) = @_; + my @temp = split($sep, $ENV{$$self}); + my $value = splice(@temp, $index, 1, ()); + $ENV{$$self} = join($sep, @temp); + return $value; +} + +sub PUSH { + my $self = shift; + my @temp = split($sep, $ENV{$$self}); + push @temp, @_; + $ENV{$$self} = join($sep, @temp); + return scalar(@temp); +} + +sub POP { + my ($self) = @_; + my @temp = split($sep, $ENV{$$self}); + my $result = pop @temp; + $ENV{$$self} = join($sep, @temp); + return $result; +} + +sub UNSHIFT { + my $self = shift; + my @temp = split($sep, $ENV{$$self}); + my $result = unshift @temp, @_; + $ENV{$$self} = join($sep, @temp); + return $result; +} + +sub SHIFT { + my ($self) = @_; + my @temp = split($sep, $ENV{$$self}); + my $result = shift @temp; + $ENV{$$self} = join($sep, @temp); + return $result; +} + +sub SPLICE { + my $self = shift; + my $offset = shift; + my $length = shift; + my @temp = split($sep, $ENV{$$self}); + if (wantarray) { + my @result = splice @temp, $self, $offset, $length, @_; + $ENV{$$self} = join($sep, @temp); + return @result; + } else { + my $result = scalar splice @temp, $offset, $length, @_; + $ENV{$$self} = join($sep, @temp); + return $result; + } +} + +###################################################################### + +package Env::Array::VMS; +use Tie::Array; + +@ISA = qw(Tie::Array); + +sub TIEARRAY { + bless \($_[1]); +} + +sub FETCHSIZE { + my ($self) = @_; + my $i = 0; + while ($i < 127 and defined $ENV{$$self . ';' . $i}) { $i++; }; + return $i; +} + +sub FETCH { + my ($self, $index) = @_; + return $ENV{$$self . ';' . $index}; +} + +sub EXISTS { + my ($self, $index) = @_; + return $index < $self->FETCHSIZE; +} + +sub DELETE { } + 1;