Commit | Line | Data |
a0d0e21e |
1 | package Env; |
2 | |
3 | =head1 NAME |
4 | |
2675e62c |
5 | Env - perl module that imports environment variables as scalars or arrays |
cb1a09d0 |
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 |
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 |
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 |
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 |
33 | |
34 | or modify it |
35 | |
36 | $PATH .= ":."; |
2675e62c |
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 |
55 | To remove a tied environment variable from |
56 | the environment, assign it the undefined value |
57 | |
58 | undef $PATH; |
2675e62c |
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 |
65 | |
66 | =head1 AUTHOR |
67 | |
1fef88e7 |
68 | Chip Salzenberg E<lt>F<chip@fin.uucp>E<gt> |
2675e62c |
69 | and |
70 | Gregor N. Purdy E<lt>F<gregor@focusresearch.com>E<gt> |
a0d0e21e |
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 |
80 | @vars = map { m/^[\$\@]/ ? $_ : '$'.$_ } @vars; |
81 | |
82 | eval "package $callpack; use vars qw(" . join(' ', @vars) . ")"; |
40da2db3 |
83 | die $@ if $@; |
a0d0e21e |
84 | foreach (@vars) { |
2675e62c |
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 |
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 |
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; |