Commit | Line | Data |
---|---|---|
a0d0e21e LW |
1 | package Env; |
2 | ||
3 | =head1 NAME | |
4 | ||
2675e62c | 5 | Env - perl module that imports environment variables as scalars or arrays |
cb1a09d0 AD |
6 | |
7 | =head1 SYNOPSIS | |
8 | ||
9 | use Env; | |
10 | use Env qw(PATH HOME TERM); | |
2675e62c | 11 | use Env qw($SHELL @LD_LIBRARY_PATH); |
a0d0e21e LW |
12 | |
13 | =head1 DESCRIPTION | |
14 | ||
2675e62c | 15 | Perl maintains environment variables in a special hash named C<%ENV>. For |
aa689395 | 16 | when this access method is inconvenient, the Perl module C<Env> allows |
2675e62c | 17 | environment variables to be treated as scalar or array variables. |
a0d0e21e | 18 | |
2675e62c | 19 | The C<Env::import()> function ties environment variables with suitable |
a0d0e21e | 20 | names to global Perl variables with the same names. By default it |
2675e62c GS |
21 | ties all existing environment variables (C<keys %ENV>) to scalars. If |
22 | the C<import> function receives arguments, it takes them to be a list of | |
23 | variables to tie; it's okay if they don't yet exist. The scalar type | |
24 | prefix '$' is inferred for any element of this list not prefixed by '$' | |
25 | or '@'. Arrays are implemented in terms of C<split> and C<join>, using | |
26 | C<$Config::Config{path_sep}> as the delimiter. | |
a0d0e21e LW |
27 | |
28 | After an environment variable is tied, merely use it like a normal variable. | |
29 | You may access its value | |
30 | ||
31 | @path = split(/:/, $PATH); | |
2675e62c | 32 | print join("\n", @LD_LIBRARY_PATH), "\n"; |
a0d0e21e LW |
33 | |
34 | or modify it | |
35 | ||
36 | $PATH .= ":."; | |
2675e62c GS |
37 | push @LD_LIBRARY_PATH, $dir; |
38 | ||
39 | however you'd like. Bear in mind, however, that each access to a tied array | |
40 | variable requires splitting the environment variable's string anew. | |
41 | ||
42 | The code: | |
43 | ||
44 | use Env qw(@PATH); | |
45 | push @PATH, '.'; | |
46 | ||
47 | is equivalent to: | |
48 | ||
49 | use Env qw(PATH); | |
50 | $PATH .= ":."; | |
51 | ||
52 | except that if C<$ENV{PATH}> started out empty, the second approach leaves | |
53 | it with the (odd) value "C<:.>", but the first approach leaves it with "C<.>". | |
a0d0e21e | 54 | |
a0d0e21e LW |
55 | To remove a tied environment variable from |
56 | the environment, assign it the undefined value | |
57 | ||
58 | undef $PATH; | |
2675e62c GS |
59 | undef @LD_LIBRARY_PATH; |
60 | ||
61 | =head1 LIMITATIONS | |
62 | ||
63 | On VMS systems, arrays tied to environment variables are read-only. Attempting | |
64 | to change anything will cause a warning. | |
a0d0e21e LW |
65 | |
66 | =head1 AUTHOR | |
67 | ||
1fef88e7 | 68 | Chip Salzenberg E<lt>F<chip@fin.uucp>E<gt> |
2675e62c GS |
69 | and |
70 | Gregor N. Purdy E<lt>F<gregor@focusresearch.com>E<gt> | |
a0d0e21e LW |
71 | |
72 | =cut | |
73 | ||
74 | sub import { | |
75 | my ($callpack) = caller(0); | |
76 | my $pack = shift; | |
2675e62c | 77 | my @vars = grep /^[\$\@]?[A-Za-z_]\w*$/, (@_ ? @_ : keys(%ENV)); |
40da2db3 | 78 | return unless @vars; |
a0d0e21e | 79 | |
2675e62c GS |
80 | @vars = map { m/^[\$\@]/ ? $_ : '$'.$_ } @vars; |
81 | ||
82 | eval "package $callpack; use vars qw(" . join(' ', @vars) . ")"; | |
40da2db3 | 83 | die $@ if $@; |
a0d0e21e | 84 | foreach (@vars) { |
2675e62c GS |
85 | my ($type, $name) = m/^([\$\@])(.*)$/; |
86 | if ($type eq '$') { | |
87 | tie ${"${callpack}::$name"}, Env, $name; | |
88 | } else { | |
89 | if ($^O eq 'VMS') { | |
90 | tie @{"${callpack}::$name"}, Env::Array::VMS, $name; | |
91 | } else { | |
92 | tie @{"${callpack}::$name"}, Env::Array, $name; | |
93 | } | |
94 | } | |
a0d0e21e LW |
95 | } |
96 | } | |
97 | ||
98 | sub TIESCALAR { | |
99 | bless \($_[1]); | |
100 | } | |
101 | ||
102 | sub FETCH { | |
103 | my ($self) = @_; | |
104 | $ENV{$$self}; | |
105 | } | |
106 | ||
107 | sub STORE { | |
108 | my ($self, $value) = @_; | |
109 | if (defined($value)) { | |
110 | $ENV{$$self} = $value; | |
111 | } else { | |
112 | delete $ENV{$$self}; | |
113 | } | |
114 | } | |
115 | ||
2675e62c GS |
116 | ###################################################################### |
117 | ||
118 | package Env::Array; | |
119 | ||
120 | use Config; | |
121 | use Tie::Array; | |
122 | ||
123 | @ISA = qw(Tie::Array); | |
124 | ||
125 | my $sep = $Config::Config{path_sep}; | |
126 | ||
127 | sub TIEARRAY { | |
128 | bless \($_[1]); | |
129 | } | |
130 | ||
131 | sub FETCHSIZE { | |
132 | my ($self) = @_; | |
133 | my @temp = split($sep, $ENV{$$self}); | |
134 | return scalar(@temp); | |
135 | } | |
136 | ||
137 | sub STORESIZE { | |
138 | my ($self, $size) = @_; | |
139 | my @temp = split($sep, $ENV{$$self}); | |
140 | $#temp = $size - 1; | |
141 | $ENV{$$self} = join($sep, @temp); | |
142 | } | |
143 | ||
144 | sub CLEAR { | |
145 | my ($self) = @_; | |
146 | $ENV{$$self} = ''; | |
147 | } | |
148 | ||
149 | sub FETCH { | |
150 | my ($self, $index) = @_; | |
151 | return (split($sep, $ENV{$$self}))[$index]; | |
152 | } | |
153 | ||
154 | sub STORE { | |
155 | my ($self, $index, $value) = @_; | |
156 | my @temp = split($sep, $ENV{$$self}); | |
157 | $temp[$index] = $value; | |
158 | $ENV{$$self} = join($sep, @temp); | |
159 | return $value; | |
160 | } | |
161 | ||
162 | sub PUSH { | |
163 | my $self = shift; | |
164 | my @temp = split($sep, $ENV{$$self}); | |
165 | push @temp, @_; | |
166 | $ENV{$$self} = join($sep, @temp); | |
167 | return scalar(@temp); | |
168 | } | |
169 | ||
170 | sub POP { | |
171 | my ($self) = @_; | |
172 | my @temp = split($sep, $ENV{$$self}); | |
173 | my $result = pop @temp; | |
174 | $ENV{$$self} = join($sep, @temp); | |
175 | return $result; | |
176 | } | |
177 | ||
178 | sub UNSHIFT { | |
179 | my $self = shift; | |
180 | my @temp = split($sep, $ENV{$$self}); | |
181 | my $result = unshift @temp, @_; | |
182 | $ENV{$$self} = join($sep, @temp); | |
183 | return $result; | |
184 | } | |
185 | ||
186 | sub SHIFT { | |
187 | my ($self) = @_; | |
188 | my @temp = split($sep, $ENV{$$self}); | |
189 | my $result = shift @temp; | |
190 | $ENV{$$self} = join($sep, @temp); | |
191 | return $result; | |
192 | } | |
193 | ||
194 | sub SPLICE { | |
195 | my $self = shift; | |
196 | my $offset = shift; | |
197 | my $length = shift; | |
198 | my @temp = split($sep, $ENV{$$self}); | |
199 | if (wantarray) { | |
200 | my @result = splice @temp, $self, $offset, $length, @_; | |
201 | $ENV{$$self} = join($sep, @temp); | |
202 | return @result; | |
203 | } else { | |
204 | my $result = scalar splice @temp, $offset, $length, @_; | |
205 | $ENV{$$self} = join($sep, @temp); | |
206 | return $result; | |
207 | } | |
208 | } | |
209 | ||
210 | ###################################################################### | |
211 | ||
212 | package Env::Array::VMS; | |
213 | use Tie::Array; | |
214 | ||
215 | @ISA = qw(Tie::Array); | |
216 | ||
217 | sub TIEARRAY { | |
218 | bless \($_[1]); | |
219 | } | |
220 | ||
221 | sub FETCHSIZE { | |
222 | my ($self) = @_; | |
223 | my $i = 0; | |
224 | while ($i < 127 and defined $ENV{$$self . ';' . $i}) { $i++; }; | |
225 | return $i; | |
226 | } | |
227 | ||
228 | sub FETCH { | |
229 | my ($self, $index) = @_; | |
230 | return $ENV{$$self . ';' . $index}; | |
231 | } | |
232 | ||
a0d0e21e | 233 | 1; |