From: Gurusamy Sarathy Date: Wed, 1 Mar 2000 17:24:53 +0000 (+0000) Subject: add support for Env arrays (from Gregor N. Purdy X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2675e62cfb03bffd85b62ed4fc8aad4f11a85e0a;p=p5sagit%2Fp5-mst-13.2.git add support for Env arrays (from Gregor N. Purdy ) p4raw-id: //depot/perl@5405 --- diff --git a/MANIFEST b/MANIFEST index d0e88b5..636318c 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1231,6 +1231,7 @@ t/lib/dumper-ovl.t See if Data::Dumper works for overloaded data t/lib/dumper.t See if Data::Dumper works t/lib/english.t See if English works t/lib/env.t See if Env works +t/lib/env-array.t See if Env works for arrays t/lib/errno.t See if Errno works t/lib/fatal.t See if Fatal works t/lib/fields.t See if base/fields works diff --git a/lib/Env.pm b/lib/Env.pm index b0afc3b..d1ee071 100644 --- a/lib/Env.pm +++ b/lib/Env.pm @@ -2,57 +2,96 @@ package Env; =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-hash named %ENV. For +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 simple variables. +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 = grep /^[A-Za-z_]\w*$/, (@_ ? @_ : 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, $_; + 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; + } + } } } @@ -74,4 +113,121 @@ 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) = @_; + my @temp = split($sep, $ENV{$$self}); + return scalar(@temp); +} + +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 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}; +} + 1; diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 7345727..53200eb 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -1320,6 +1320,14 @@ information, see L. Compatibility tests for C vs the older C. +=item lib/env + +Tests for new environment scalar capability (e.g., C). + +=item lib/env-array + +Tests for new environment array capability (e.g., C). + =item lib/io_const IO constants (SEEK_*, _IO*). @@ -1478,6 +1486,11 @@ of Perl variables and data. It is a data debugging tool for the XS programmer. $PERL_VERSION now stands for C<$^V> (a string value) rather than for C<$]> (a numeric value). +=item Env + +Env now supports accessing environment variables like PATH as array +variables. + =item ExtUtils::MakeMaker change#4135, also needs docs in module pod diff --git a/t/lib/env-array.t b/t/lib/env-array.t new file mode 100755 index 0000000..d90d892 --- /dev/null +++ b/t/lib/env-array.t @@ -0,0 +1,100 @@ +#!./perl + +$| = 1; + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +if ($^O eq 'VMS') { + print "1..11\n"; + foreach (1..11) { print "ok $_ # skipped for VMS\n"; } + exit 0; +} + +use Env qw(@FOO); +use vars qw(@BAR); + +sub array_equal +{ + my ($a, $b) = @_; + return 0 unless scalar(@$a) == scalar(@$b); + for my $i (0..scalar(@$a) - 1) { + return 0 unless $a->[$i] eq $b->[$i]; + } + return 1; +} + +sub test +{ + my ($desc, $code) = @_; + + &$code; + + print "# $desc...\n"; + print "# FOO = (", join(", ", @FOO), ")\n"; + print "# BAR = (", join(", ", @BAR), ")\n"; + + if (defined $check) { print "not " unless &$check; } + else { print "not " unless array_equal(\@FOO, \@BAR); } + + print "ok ", ++$i, "\n"; +} + +print "1..11\n"; + +test "Assignment", sub { + @FOO = qw(a B c); + @BAR = qw(a B c); +}; + +test "Storing", sub { + $FOO[1] = 'b'; + $BAR[1] = 'b'; +}; + +test "Truncation", sub { + $#FOO = 0; + $#BAR = 0; +}; + +test "Push", sub { + push @FOO, 'b', 'c'; + push @BAR, 'b', 'c'; +}; + +test "Pop", sub { + pop @FOO; + pop @BAR; +}; + +test "Shift", sub { + shift @FOO; + shift @BAR; +}; + +test "Push", sub { + push @FOO, 'c'; + push @BAR, 'c'; +}; + +test "Unshift", sub { + unshift @FOO, 'a'; + unshift @BAR, 'a'; +}; + +test "Reverse", sub { + @FOO = reverse @FOO; + @BAR = reverse @BAR; +}; + +test "Sort", sub { + @FOO = sort @FOO; + @BAR = sort @BAR; +}; + +test "Splice", sub { + splice @FOO, 1, 1, 'B'; + splice @BAR, 1, 1, 'B'; +}; diff --git a/t/lib/env.t b/t/lib/env.t index 93d2406..2573164 100755 --- a/t/lib/env.t +++ b/t/lib/env.t @@ -7,12 +7,19 @@ BEGIN { BEGIN { $ENV{FOO} = "foo"; + $ENV{BAR} = "bar"; } -use Env qw(FOO); +use Env qw(FOO $BAR); $FOO .= "/bar"; +$BAR .= "/baz"; + +print "1..2\n"; -print "1..1\n"; print "not " if $FOO ne 'foo/bar'; print "ok 1\n"; + +print "not " if $BAR ne 'bar/baz'; +print "ok 2\n"; +