Clean up mktables intro comments; remove trailing white space
[p5sagit/p5-mst-13.2.git] / lib / Env.pm
CommitLineData
a0d0e21e 1package Env;
2
b5ebbd35 3our $VERSION = '1.01';
b75c8c73 4
a0d0e21e 5=head1 NAME
6
2675e62c 7Env - perl module that imports environment variables as scalars or arrays
cb1a09d0 8
9=head1 SYNOPSIS
10
11 use Env;
12 use Env qw(PATH HOME TERM);
2675e62c 13 use Env qw($SHELL @LD_LIBRARY_PATH);
a0d0e21e 14
15=head1 DESCRIPTION
16
2675e62c 17Perl maintains environment variables in a special hash named C<%ENV>. For
aa689395 18when this access method is inconvenient, the Perl module C<Env> allows
2675e62c 19environment variables to be treated as scalar or array variables.
a0d0e21e 20
2675e62c 21The C<Env::import()> function ties environment variables with suitable
a0d0e21e 22names to global Perl variables with the same names. By default it
2675e62c 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.
a0d0e21e 29
30After an environment variable is tied, merely use it like a normal variable.
31You may access its value
32
33 @path = split(/:/, $PATH);
2675e62c 34 print join("\n", @LD_LIBRARY_PATH), "\n";
a0d0e21e 35
36or modify it
37
38 $PATH .= ":.";
2675e62c 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, '.';
48
49is equivalent to:
50
51 use Env qw(PATH);
52 $PATH .= ":.";
53
54except that if C<$ENV{PATH}> started out empty, the second approach leaves
55it with the (odd) value "C<:.>", but the first approach leaves it with "C<.>".
a0d0e21e 56
a0d0e21e 57To remove a tied environment variable from
58the environment, assign it the undefined value
59
60 undef $PATH;
2675e62c 61 undef @LD_LIBRARY_PATH;
62
63=head1 LIMITATIONS
64
65On VMS systems, arrays tied to environment variables are read-only. Attempting
66to change anything will cause a warning.
a0d0e21e 67
68=head1 AUTHOR
69
1fef88e7 70Chip Salzenberg E<lt>F<chip@fin.uucp>E<gt>
2675e62c 71and
72Gregor N. Purdy E<lt>F<gregor@focusresearch.com>E<gt>
a0d0e21e 73
74=cut
75
76sub import {
77 my ($callpack) = caller(0);
78 my $pack = shift;
2675e62c 79 my @vars = grep /^[\$\@]?[A-Za-z_]\w*$/, (@_ ? @_ : keys(%ENV));
40da2db3 80 return unless @vars;
a0d0e21e 81
2675e62c 82 @vars = map { m/^[\$\@]/ ? $_ : '$'.$_ } @vars;
83
84 eval "package $callpack; use vars qw(" . join(' ', @vars) . ")";
40da2db3 85 die $@ if $@;
a0d0e21e 86 foreach (@vars) {
2675e62c 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 }
a0d0e21e 97 }
98}
99
100sub TIESCALAR {
101 bless \($_[1]);
102}
103
104sub FETCH {
105 my ($self) = @_;
106 $ENV{$$self};
107}
108
109sub STORE {
110 my ($self, $value) = @_;
111 if (defined($value)) {
112 $ENV{$$self} = $value;
113 } else {
114 delete $ENV{$$self};
115 }
116}
117
2675e62c 118######################################################################
119
120package Env::Array;
121
122use Config;
123use Tie::Array;
124
125@ISA = qw(Tie::Array);
126
127my $sep = $Config::Config{path_sep};
128
129sub TIEARRAY {
130 bless \($_[1]);
131}
132
133sub FETCHSIZE {
134 my ($self) = @_;
b5ebbd35 135 return 1 + scalar(() = $ENV{$$self} =~ /\Q$sep\E/g);
2675e62c 136}
137
138sub STORESIZE {
139 my ($self, $size) = @_;
140 my @temp = split($sep, $ENV{$$self});
141 $#temp = $size - 1;
142 $ENV{$$self} = join($sep, @temp);
143}
144
145sub CLEAR {
146 my ($self) = @_;
147 $ENV{$$self} = '';
148}
149
150sub FETCH {
151 my ($self, $index) = @_;
152 return (split($sep, $ENV{$$self}))[$index];
153}
154
155sub 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
b5ebbd35 163sub EXISTS {
164 my ($self, $index) = @_;
165 return $index < $self->FETCHSIZE;
166}
167
168sub 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
2675e62c 176sub 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
184sub 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
192sub 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
200sub 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
208sub 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
226package Env::Array::VMS;
227use Tie::Array;
228
229@ISA = qw(Tie::Array);
230
231sub TIEARRAY {
232 bless \($_[1]);
233}
234
235sub FETCHSIZE {
236 my ($self) = @_;
237 my $i = 0;
238 while ($i < 127 and defined $ENV{$$self . ';' . $i}) { $i++; };
239 return $i;
240}
241
242sub FETCH {
243 my ($self, $index) = @_;
244 return $ENV{$$self . ';' . $index};
245}
246
b5ebbd35 247sub EXISTS {
248 my ($self, $index) = @_;
249 return $index < $self->FETCHSIZE;
250}
251
252sub DELETE { }
253
a0d0e21e 2541;