1 | use Config;
|
---|
2 | use File::Basename qw(&basename &dirname);
|
---|
3 | use File::Spec;
|
---|
4 | use Cwd;
|
---|
5 |
|
---|
6 | my $origdir = cwd;
|
---|
7 | chdir dirname($0);
|
---|
8 | my $file = basename($0, '.PL');
|
---|
9 | $file =~ s!_(pm)$!.$1!i;
|
---|
10 |
|
---|
11 | my $useConfig;
|
---|
12 | my $Config_archname;
|
---|
13 | my $Config_version;
|
---|
14 | my $Config_inc_version_list;
|
---|
15 |
|
---|
16 | # Expand the variables only if explicitly requested because
|
---|
17 | # otherwise relocating Perl becomes much harder.
|
---|
18 |
|
---|
19 | if ($ENV{PERL_BUILD_EXPAND_CONFIG_VARS}) {
|
---|
20 | $useConfig = '';
|
---|
21 | $Config_archname = qq('$Config{archname}');
|
---|
22 | $Config_version = qq('$Config{version}');
|
---|
23 | my @Config_inc_version_list =
|
---|
24 | reverse split / /, $Config{inc_version_list};
|
---|
25 | $Config_inc_version_list =
|
---|
26 | @Config_inc_version_list ?
|
---|
27 | qq(@Config_inc_version_list) : q(());
|
---|
28 | } else {
|
---|
29 | $useConfig = 'use Config;';
|
---|
30 | $Config_archname = q($Config{archname});
|
---|
31 | $Config_version = q($Config{version});
|
---|
32 | $Config_inc_version_list =
|
---|
33 | q(reverse split / /, $Config{inc_version_list});
|
---|
34 | }
|
---|
35 |
|
---|
36 | open OUT,">$file" or die "Can't create $file: $!";
|
---|
37 |
|
---|
38 | print "Extracting $file (with variable substitutions)\n";
|
---|
39 |
|
---|
40 | # In this section, perl variables will be expanded during extraction.
|
---|
41 | # You can use $Config{...} to use Configure variables.
|
---|
42 |
|
---|
43 | print OUT <<"!GROK!THIS!";
|
---|
44 | package lib;
|
---|
45 |
|
---|
46 | # THIS FILE IS AUTOMATICALLY GENERATED FROM lib_pm.PL.
|
---|
47 | # ANY CHANGES TO THIS FILE WILL BE OVERWRITTEN BY THE NEXT PERL BUILD.
|
---|
48 |
|
---|
49 | $useConfig
|
---|
50 |
|
---|
51 | use strict;
|
---|
52 |
|
---|
53 | my \$archname = $Config_archname;
|
---|
54 | my \$version = $Config_version;
|
---|
55 | my \@inc_version_list = $Config_inc_version_list;
|
---|
56 |
|
---|
57 | !GROK!THIS!
|
---|
58 | print OUT <<'!NO!SUBS!';
|
---|
59 |
|
---|
60 | our @ORIG_INC = @INC; # take a handy copy of 'original' value
|
---|
61 | our $VERSION = '0.5565';
|
---|
62 | my $Is_MacOS = $^O eq 'MacOS';
|
---|
63 | my $Mac_FS;
|
---|
64 | if ($Is_MacOS) {
|
---|
65 | require File::Spec;
|
---|
66 | $Mac_FS = eval { require Mac::FileSpec::Unixish };
|
---|
67 | }
|
---|
68 |
|
---|
69 | sub import {
|
---|
70 | shift;
|
---|
71 |
|
---|
72 | my %names;
|
---|
73 | foreach (reverse @_) {
|
---|
74 | my $path = $_; # we'll be modifying it, so break the alias
|
---|
75 | if ($path eq '') {
|
---|
76 | require Carp;
|
---|
77 | Carp::carp("Empty compile time value given to use lib");
|
---|
78 | }
|
---|
79 |
|
---|
80 | $path = _nativize($path);
|
---|
81 |
|
---|
82 | if (-e $path && ! -d _) {
|
---|
83 | require Carp;
|
---|
84 | Carp::carp("Parameter to use lib must be directory, not file");
|
---|
85 | }
|
---|
86 | unshift(@INC, $path);
|
---|
87 | # Add any previous version directories we found at configure time
|
---|
88 | foreach my $incver (@inc_version_list)
|
---|
89 | {
|
---|
90 | my $dir = $Is_MacOS
|
---|
91 | ? File::Spec->catdir( $path, $incver )
|
---|
92 | : "$path/$incver";
|
---|
93 | unshift(@INC, $dir) if -d $dir;
|
---|
94 | }
|
---|
95 | # Put a corresponding archlib directory in front of $path if it
|
---|
96 | # looks like $path has an archlib directory below it.
|
---|
97 | my($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir)
|
---|
98 | = _get_dirs($path);
|
---|
99 | unshift(@INC, $arch_dir) if -d $arch_auto_dir;
|
---|
100 | unshift(@INC, $version_dir) if -d $version_dir;
|
---|
101 | unshift(@INC, $version_arch_dir) if -d $version_arch_dir;
|
---|
102 | }
|
---|
103 |
|
---|
104 | # remove trailing duplicates
|
---|
105 | @INC = grep { ++$names{$_} == 1 } @INC;
|
---|
106 | return;
|
---|
107 | }
|
---|
108 |
|
---|
109 |
|
---|
110 | sub unimport {
|
---|
111 | shift;
|
---|
112 |
|
---|
113 | my %names;
|
---|
114 | foreach (@_) {
|
---|
115 | my $path = _nativize($_);
|
---|
116 |
|
---|
117 | my($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir)
|
---|
118 | = _get_dirs($path);
|
---|
119 | ++$names{$path};
|
---|
120 | ++$names{$arch_dir} if -d $arch_auto_dir;
|
---|
121 | ++$names{$version_dir} if -d $version_dir;
|
---|
122 | ++$names{$version_arch_dir} if -d $version_arch_dir;
|
---|
123 | }
|
---|
124 |
|
---|
125 | # Remove ALL instances of each named directory.
|
---|
126 | @INC = grep { !exists $names{$_} } @INC;
|
---|
127 | return;
|
---|
128 | }
|
---|
129 |
|
---|
130 | sub _get_dirs {
|
---|
131 | my($dir) = @_;
|
---|
132 | my($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir);
|
---|
133 |
|
---|
134 | # we could use this for all platforms in the future, but leave it
|
---|
135 | # Mac-only for now, until there is more time for testing it.
|
---|
136 | if ($Is_MacOS) {
|
---|
137 | $arch_auto_dir = File::Spec->catdir( $dir, $archname, 'auto' );
|
---|
138 | $arch_dir = File::Spec->catdir( $dir, $archname, );
|
---|
139 | $version_dir = File::Spec->catdir( $dir, $version );
|
---|
140 | $version_arch_dir = File::Spec->catdir( $dir, $version, $archname );
|
---|
141 | } else {
|
---|
142 | $arch_auto_dir = "$dir/$archname/auto";
|
---|
143 | $arch_dir = "$dir/$archname";
|
---|
144 | $version_dir = "$dir/$version";
|
---|
145 | $version_arch_dir = "$dir/$version/$archname";
|
---|
146 | }
|
---|
147 | return($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir);
|
---|
148 | }
|
---|
149 |
|
---|
150 | sub _nativize {
|
---|
151 | my($dir) = @_;
|
---|
152 |
|
---|
153 | if ($Is_MacOS && $Mac_FS && ! -d $dir) {
|
---|
154 | $dir = Mac::FileSpec::Unixish::nativize($dir);
|
---|
155 | $dir .= ":" unless $dir =~ /:$/;
|
---|
156 | }
|
---|
157 |
|
---|
158 | return $dir;
|
---|
159 | }
|
---|
160 |
|
---|
161 | 1;
|
---|
162 | __END__
|
---|
163 |
|
---|
164 | =head1 NAME
|
---|
165 |
|
---|
166 | lib - manipulate @INC at compile time
|
---|
167 |
|
---|
168 | =head1 SYNOPSIS
|
---|
169 |
|
---|
170 | use lib LIST;
|
---|
171 |
|
---|
172 | no lib LIST;
|
---|
173 |
|
---|
174 | =head1 DESCRIPTION
|
---|
175 |
|
---|
176 | This is a small simple module which simplifies the manipulation of @INC
|
---|
177 | at compile time.
|
---|
178 |
|
---|
179 | It is typically used to add extra directories to perl's search path so
|
---|
180 | that later C<use> or C<require> statements will find modules which are
|
---|
181 | not located on perl's default search path.
|
---|
182 |
|
---|
183 | =head2 Adding directories to @INC
|
---|
184 |
|
---|
185 | The parameters to C<use lib> are added to the start of the perl search
|
---|
186 | path. Saying
|
---|
187 |
|
---|
188 | use lib LIST;
|
---|
189 |
|
---|
190 | is I<almost> the same as saying
|
---|
191 |
|
---|
192 | BEGIN { unshift(@INC, LIST) }
|
---|
193 |
|
---|
194 | For each directory in LIST (called $dir here) the lib module also
|
---|
195 | checks to see if a directory called $dir/$archname/auto exists.
|
---|
196 | If so the $dir/$archname directory is assumed to be a corresponding
|
---|
197 | architecture specific directory and is added to @INC in front of $dir.
|
---|
198 |
|
---|
199 | To avoid memory leaks, all trailing duplicate entries in @INC are
|
---|
200 | removed.
|
---|
201 |
|
---|
202 | =head2 Deleting directories from @INC
|
---|
203 |
|
---|
204 | You should normally only add directories to @INC. If you need to
|
---|
205 | delete directories from @INC take care to only delete those which you
|
---|
206 | added yourself or which you are certain are not needed by other modules
|
---|
207 | in your script. Other modules may have added directories which they
|
---|
208 | need for correct operation.
|
---|
209 |
|
---|
210 | The C<no lib> statement deletes all instances of each named directory
|
---|
211 | from @INC.
|
---|
212 |
|
---|
213 | For each directory in LIST (called $dir here) the lib module also
|
---|
214 | checks to see if a directory called $dir/$archname/auto exists.
|
---|
215 | If so the $dir/$archname directory is assumed to be a corresponding
|
---|
216 | architecture specific directory and is also deleted from @INC.
|
---|
217 |
|
---|
218 | =head2 Restoring original @INC
|
---|
219 |
|
---|
220 | When the lib module is first loaded it records the current value of @INC
|
---|
221 | in an array C<@lib::ORIG_INC>. To restore @INC to that value you
|
---|
222 | can say
|
---|
223 |
|
---|
224 | @INC = @lib::ORIG_INC;
|
---|
225 |
|
---|
226 | =head1 CAVEATS
|
---|
227 |
|
---|
228 | In order to keep lib.pm small and simple, it only works with Unix
|
---|
229 | filepaths. This doesn't mean it only works on Unix, but non-Unix
|
---|
230 | users must first translate their file paths to Unix conventions.
|
---|
231 |
|
---|
232 | # VMS users wanting to put [.stuff.moo] into
|
---|
233 | # their @INC would write
|
---|
234 | use lib 'stuff/moo';
|
---|
235 |
|
---|
236 | =head1 NOTES
|
---|
237 |
|
---|
238 | In the future, this module will likely use File::Spec for determining
|
---|
239 | paths, as it does now for Mac OS (where Unix-style or Mac-style paths
|
---|
240 | work, and Unix-style paths are converted properly to Mac-style paths
|
---|
241 | before being added to @INC).
|
---|
242 |
|
---|
243 | =head1 SEE ALSO
|
---|
244 |
|
---|
245 | FindBin - optional module which deals with paths relative to the source file.
|
---|
246 |
|
---|
247 | =head1 AUTHOR
|
---|
248 |
|
---|
249 | Tim Bunce, 2nd June 1995.
|
---|
250 |
|
---|
251 | =cut
|
---|
252 | !NO!SUBS!
|
---|
253 |
|
---|
254 | close OUT or die "Can't close $file: $!";
|
---|
255 | chdir $origdir;
|
---|