our $TODO should be local $::TODO, revealing a bug in the de-commenting regexp.
[perl.git] / lib / Env.pm
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;