1 | package Env; |
---|
2 | |
---|
3 | =head1 NAME |
---|
4 | |
---|
5 | Env - perl module that imports environment variables as scalars or arrays |
---|
6 | |
---|
7 | =head1 SYNOPSIS |
---|
8 | |
---|
9 | use Env; |
---|
10 | use Env qw(PATH HOME TERM); |
---|
11 | use Env qw($SHELL @LD_LIBRARY_PATH); |
---|
12 | |
---|
13 | =head1 DESCRIPTION |
---|
14 | |
---|
15 | Perl maintains environment variables in a special hash named C<%ENV>. For |
---|
16 | when this access method is inconvenient, the Perl module C<Env> allows |
---|
17 | environment variables to be treated as scalar or array variables. |
---|
18 | |
---|
19 | The C<Env::import()> function ties environment variables with suitable |
---|
20 | names to global Perl variables with the same names. By default it |
---|
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. |
---|
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); |
---|
32 | print join("\n", @LD_LIBRARY_PATH), "\n"; |
---|
33 | |
---|
34 | or modify it |
---|
35 | |
---|
36 | $PATH .= ":."; |
---|
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<.>". |
---|
54 | |
---|
55 | To remove a tied environment variable from |
---|
56 | the environment, assign it the undefined value |
---|
57 | |
---|
58 | undef $PATH; |
---|
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. |
---|
65 | |
---|
66 | =head1 AUTHOR |
---|
67 | |
---|
68 | Chip Salzenberg E<lt>F<chip@fin.uucp>E<gt> |
---|
69 | and |
---|
70 | Gregor N. Purdy E<lt>F<gregor@focusresearch.com>E<gt> |
---|
71 | |
---|
72 | =cut |
---|
73 | |
---|
74 | sub import { |
---|
75 | my ($callpack) = caller(0); |
---|
76 | my $pack = shift; |
---|
77 | my @vars = grep /^[\$\@]?[A-Za-z_]\w*$/, (@_ ? @_ : keys(%ENV)); |
---|
78 | return unless @vars; |
---|
79 | |
---|
80 | @vars = map { m/^[\$\@]/ ? $_ : '$'.$_ } @vars; |
---|
81 | |
---|
82 | eval "package $callpack; use vars qw(" . join(' ', @vars) . ")"; |
---|
83 | die $@ if $@; |
---|
84 | foreach (@vars) { |
---|
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 | } |
---|
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 | |
---|
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 | |
---|
233 | 1; |
---|