Update File::Copy tests to skip on OpenBSD, as it mounts too many filesystems nosuid.
[p5sagit/p5-mst-13.2.git] / lib / Env.pm
1 package Env;
2
3 our $VERSION = '1.01';
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     return 1 + scalar(() = $ENV{$$self} =~ /\Q$sep\E/g);
136 }
137
138 sub STORESIZE {
139     my ($self, $size) = @_;
140     my @temp = split($sep, $ENV{$$self});
141     $#temp = $size - 1;
142     $ENV{$$self} = join($sep, @temp);
143 }
144
145 sub CLEAR {
146     my ($self) = @_;
147     $ENV{$$self} = '';
148 }
149
150 sub FETCH {
151     my ($self, $index) = @_;
152     return (split($sep, $ENV{$$self}))[$index];
153 }
154
155 sub STORE {
156     my ($self, $index, $value) = @_;
157     my @temp = split($sep, $ENV{$$self});
158     $temp[$index] = $value;
159     $ENV{$$self} = join($sep, @temp);
160     return $value;
161 }
162
163 sub EXISTS {
164     my ($self, $index) = @_;
165     return $index < $self->FETCHSIZE;
166 }
167
168 sub DELETE {
169     my ($self, $index) = @_;
170     my @temp = split($sep, $ENV{$$self});
171     my $value = splice(@temp, $index, 1, ());
172     $ENV{$$self} = join($sep, @temp);
173     return $value;
174 }
175
176 sub PUSH {
177     my $self = shift;
178     my @temp = split($sep, $ENV{$$self});
179     push @temp, @_;
180     $ENV{$$self} = join($sep, @temp);
181     return scalar(@temp);
182 }
183
184 sub POP {
185     my ($self) = @_;
186     my @temp = split($sep, $ENV{$$self});
187     my $result = pop @temp;
188     $ENV{$$self} = join($sep, @temp);
189     return $result;
190 }
191
192 sub UNSHIFT {
193     my $self = shift;
194     my @temp = split($sep, $ENV{$$self});
195     my $result = unshift @temp, @_;
196     $ENV{$$self} = join($sep, @temp);
197     return $result;
198 }
199
200 sub SHIFT {
201     my ($self) = @_;
202     my @temp = split($sep, $ENV{$$self});
203     my $result = shift @temp;
204     $ENV{$$self} = join($sep, @temp);
205     return $result;
206 }
207
208 sub SPLICE {
209     my $self = shift;
210     my $offset = shift;
211     my $length = shift;
212     my @temp = split($sep, $ENV{$$self});
213     if (wantarray) {
214         my @result = splice @temp, $self, $offset, $length, @_;
215         $ENV{$$self} = join($sep, @temp);
216         return @result;
217     } else {
218         my $result = scalar splice @temp, $offset, $length, @_;
219         $ENV{$$self} = join($sep, @temp);
220         return $result;
221     }
222 }
223
224 ######################################################################
225
226 package Env::Array::VMS;
227 use Tie::Array;
228
229 @ISA = qw(Tie::Array);
230  
231 sub TIEARRAY {
232     bless \($_[1]);
233 }
234
235 sub FETCHSIZE {
236     my ($self) = @_;
237     my $i = 0;
238     while ($i < 127 and defined $ENV{$$self . ';' . $i}) { $i++; };
239     return $i;
240 }
241
242 sub FETCH {
243     my ($self, $index) = @_;
244     return $ENV{$$self . ';' . $index};
245 }
246
247 sub EXISTS {
248     my ($self, $index) = @_;
249     return $index < $self->FETCHSIZE;
250 }
251
252 sub DELETE { }
253
254 1;