17 |
# 3. The ./inc/ version of Module::Install loads |
# 3. The ./inc/ version of Module::Install loads |
18 |
# } |
# } |
19 |
|
|
20 |
use 5.004; |
BEGIN { |
21 |
|
require 5.004; |
22 |
|
} |
23 |
use strict 'vars'; |
use strict 'vars'; |
24 |
|
|
25 |
use vars qw{$VERSION}; |
use vars qw{$VERSION}; |
26 |
BEGIN { |
BEGIN { |
27 |
# All Module::Install core packages now require synchronised versions. |
# All Module::Install core packages now require synchronised versions. |
28 |
# This will be used to ensure we don't accidentally load old or |
# This will be used to ensure we don't accidentally load old or |
29 |
# different versions of modules. |
# different versions of modules. |
30 |
# This is not enforced yet, but will be some time in the next few |
# This is not enforced yet, but will be some time in the next few |
31 |
# releases once we can make sure it won't clash with custom |
# releases once we can make sure it won't clash with custom |
32 |
# Module::Install extensions. |
# Module::Install extensions. |
33 |
$VERSION = '0.67'; |
$VERSION = '0.76'; |
34 |
|
|
35 |
|
*inc::Module::Install::VERSION = *VERSION; |
36 |
|
@inc::Module::Install::ISA = __PACKAGE__; |
37 |
|
|
38 |
} |
} |
39 |
|
|
40 |
|
|
41 |
|
|
42 |
|
|
43 |
|
|
44 |
# Whether or not inc::Module::Install is actually loaded, the |
# Whether or not inc::Module::Install is actually loaded, the |
45 |
# $INC{inc/Module/Install.pm} is what will still get set as long as |
# $INC{inc/Module/Install.pm} is what will still get set as long as |
46 |
# the caller loaded module this in the documented manner. |
# the caller loaded module this in the documented manner. |
48 |
# they may not have a MI version that works with the Makefile.PL. This would |
# they may not have a MI version that works with the Makefile.PL. This would |
49 |
# result in false errors or unexpected behaviour. And we don't want that. |
# result in false errors or unexpected behaviour. And we don't want that. |
50 |
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; |
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; |
51 |
unless ( $INC{$file} ) { |
unless ( $INC{$file} ) { die <<"END_DIE" } |
52 |
die <<"END_DIE"; |
|
53 |
Please invoke ${\__PACKAGE__} with: |
Please invoke ${\__PACKAGE__} with: |
54 |
|
|
55 |
use inc::${\__PACKAGE__}; |
use inc::${\__PACKAGE__}; |
56 |
|
|
57 |
not: |
not: |
58 |
|
|
59 |
use ${\__PACKAGE__}; |
use ${\__PACKAGE__}; |
60 |
|
|
61 |
END_DIE |
END_DIE |
62 |
} |
|
63 |
|
|
64 |
|
|
65 |
|
|
66 |
|
|
67 |
# If the script that is loading Module::Install is from the future, |
# If the script that is loading Module::Install is from the future, |
68 |
# then make will detect this and cause it to re-run over and over |
# then make will detect this and cause it to re-run over and over |
69 |
# again. This is bad. Rather than taking action to touch it (which |
# again. This is bad. Rather than taking action to touch it (which |
70 |
# is unreliable on some platforms and requires write permissions) |
# is unreliable on some platforms and requires write permissions) |
71 |
# for now we should catch this and refuse to run. |
# for now we should catch this and refuse to run. |
72 |
if ( -f $0 and (stat($0))[9] > time ) { |
if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" } |
73 |
die << "END_DIE"; |
|
74 |
Your installer $0 has a modification time in the future. |
Your installer $0 has a modification time in the future. |
75 |
|
|
76 |
This is known to create infinite loops in make. |
This is known to create infinite loops in make. |
78 |
Please correct this, then run $0 again. |
Please correct this, then run $0 again. |
79 |
|
|
80 |
END_DIE |
END_DIE |
81 |
} |
|
82 |
|
|
83 |
|
|
84 |
|
|
85 |
|
|
86 |
|
# Build.PL was formerly supported, but no longer is due to excessive |
87 |
|
# difficulty in implementing every single feature twice. |
88 |
|
if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } |
89 |
|
|
90 |
|
Module::Install no longer supports Build.PL. |
91 |
|
|
92 |
|
It was impossible to maintain duel backends, and has been deprecated. |
93 |
|
|
94 |
|
Please remove all Build.PL files and only use the Makefile.PL installer. |
95 |
|
|
96 |
|
END_DIE |
97 |
|
|
98 |
|
|
99 |
|
|
100 |
|
|
101 |
|
|
102 |
|
# To save some more typing in Module::Install installers, every... |
103 |
|
# use inc::Module::Install |
104 |
|
# ...also acts as an implicit use strict. |
105 |
|
$^H |= strict::bits(qw(refs subs vars)); |
106 |
|
|
107 |
|
|
108 |
|
|
109 |
|
|
110 |
|
|
111 |
use Cwd (); |
use Cwd (); |
112 |
use File::Find (); |
use File::Find (); |
113 |
use File::Path (); |
use File::Path (); |
114 |
use FindBin; |
use FindBin; |
115 |
|
|
|
*inc::Module::Install::VERSION = *VERSION; |
|
|
@inc::Module::Install::ISA = __PACKAGE__; |
|
|
|
|
116 |
sub autoload { |
sub autoload { |
117 |
my $self = shift; |
my $self = shift; |
118 |
my $who = $self->_caller; |
my $who = $self->_caller; |
119 |
my $cwd = Cwd::cwd(); |
my $cwd = Cwd::cwd(); |
120 |
my $sym = "${who}::AUTOLOAD"; |
my $sym = "${who}::AUTOLOAD"; |
121 |
$sym->{$cwd} = sub { |
$sym->{$cwd} = sub { |
122 |
my $pwd = Cwd::cwd(); |
my $pwd = Cwd::cwd(); |
123 |
if ( my $code = $sym->{$pwd} ) { |
if ( my $code = $sym->{$pwd} ) { |
124 |
# delegate back to parent dirs |
# delegate back to parent dirs |
125 |
goto &$code unless $cwd eq $pwd; |
goto &$code unless $cwd eq $pwd; |
126 |
} |
} |
127 |
$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; |
$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; |
128 |
unshift @_, ($self, $1); |
unshift @_, ( $self, $1 ); |
129 |
goto &{$self->can('call')} unless uc($1) eq $1; |
goto &{$self->can('call')} unless uc($1) eq $1; |
130 |
}; |
}; |
131 |
} |
} |
132 |
|
|
133 |
sub import { |
sub import { |
134 |
my $class = shift; |
my $class = shift; |
135 |
my $self = $class->new(@_); |
my $self = $class->new(@_); |
136 |
my $who = $self->_caller; |
my $who = $self->_caller; |
137 |
|
|
138 |
unless ( -f $self->{file} ) { |
unless ( -f $self->{file} ) { |
139 |
require "$self->{path}/$self->{dispatch}.pm"; |
require "$self->{path}/$self->{dispatch}.pm"; |
140 |
File::Path::mkpath("$self->{prefix}/$self->{author}"); |
File::Path::mkpath("$self->{prefix}/$self->{author}"); |
141 |
$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); |
$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); |
142 |
$self->{admin}->init; |
$self->{admin}->init; |
143 |
@_ = ($class, _self => $self); |
@_ = ($class, _self => $self); |
144 |
goto &{"$self->{name}::import"}; |
goto &{"$self->{name}::import"}; |
145 |
} |
} |
146 |
|
|
147 |
*{"${who}::AUTOLOAD"} = $self->autoload; |
*{"${who}::AUTOLOAD"} = $self->autoload; |
148 |
$self->preload; |
$self->preload; |
149 |
|
|
150 |
# Unregister loader and worker packages so subdirs can use them again |
# Unregister loader and worker packages so subdirs can use them again |
151 |
delete $INC{"$self->{file}"}; |
delete $INC{"$self->{file}"}; |
152 |
delete $INC{"$self->{path}.pm"}; |
delete $INC{"$self->{path}.pm"}; |
153 |
|
|
154 |
|
return 1; |
155 |
} |
} |
156 |
|
|
157 |
sub preload { |
sub preload { |
158 |
my ($self) = @_; |
my $self = shift; |
159 |
|
unless ( $self->{extensions} ) { |
160 |
unless ( $self->{extensions} ) { |
$self->load_extensions( |
161 |
$self->load_extensions( |
"$self->{prefix}/$self->{path}", $self |
162 |
"$self->{prefix}/$self->{path}", $self |
); |
163 |
); |
} |
164 |
} |
|
165 |
|
my @exts = @{$self->{extensions}}; |
166 |
my @exts = @{$self->{extensions}}; |
unless ( @exts ) { |
167 |
unless ( @exts ) { |
my $admin = $self->{admin}; |
168 |
my $admin = $self->{admin}; |
@exts = $admin->load_all_extensions; |
169 |
@exts = $admin->load_all_extensions; |
} |
170 |
} |
|
171 |
|
my %seen; |
172 |
my %seen; |
foreach my $obj ( @exts ) { |
173 |
foreach my $obj ( @exts ) { |
while (my ($method, $glob) = each %{ref($obj) . '::'}) { |
174 |
while (my ($method, $glob) = each %{ref($obj) . '::'}) { |
next unless $obj->can($method); |
175 |
next unless $obj->can($method); |
next if $method =~ /^_/; |
176 |
next if $method =~ /^_/; |
next if $method eq uc($method); |
177 |
next if $method eq uc($method); |
$seen{$method}++; |
178 |
$seen{$method}++; |
} |
179 |
} |
} |
180 |
} |
|
181 |
|
my $who = $self->_caller; |
182 |
my $who = $self->_caller; |
foreach my $name ( sort keys %seen ) { |
183 |
foreach my $name ( sort keys %seen ) { |
*{"${who}::$name"} = sub { |
184 |
*{"${who}::$name"} = sub { |
${"${who}::AUTOLOAD"} = "${who}::$name"; |
185 |
${"${who}::AUTOLOAD"} = "${who}::$name"; |
goto &{"${who}::AUTOLOAD"}; |
186 |
goto &{"${who}::AUTOLOAD"}; |
}; |
187 |
}; |
} |
|
} |
|
188 |
} |
} |
189 |
|
|
190 |
sub new { |
sub new { |
191 |
my ($class, %args) = @_; |
my ($class, %args) = @_; |
192 |
|
|
193 |
# ignore the prefix on extension modules built from top level. |
# ignore the prefix on extension modules built from top level. |
194 |
my $base_path = Cwd::abs_path($FindBin::Bin); |
my $base_path = Cwd::abs_path($FindBin::Bin); |
195 |
unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { |
unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { |
196 |
delete $args{prefix}; |
delete $args{prefix}; |
197 |
} |
} |
198 |
|
|
199 |
return $args{_self} if $args{_self}; |
return $args{_self} if $args{_self}; |
200 |
|
|
201 |
$args{dispatch} ||= 'Admin'; |
$args{dispatch} ||= 'Admin'; |
202 |
$args{prefix} ||= 'inc'; |
$args{prefix} ||= 'inc'; |
203 |
$args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); |
$args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); |
204 |
$args{bundle} ||= 'inc/BUNDLES'; |
$args{bundle} ||= 'inc/BUNDLES'; |
205 |
$args{base} ||= $base_path; |
$args{base} ||= $base_path; |
206 |
$class =~ s/^\Q$args{prefix}\E:://; |
$class =~ s/^\Q$args{prefix}\E:://; |
207 |
$args{name} ||= $class; |
$args{name} ||= $class; |
208 |
$args{version} ||= $class->VERSION; |
$args{version} ||= $class->VERSION; |
209 |
unless ( $args{path} ) { |
unless ( $args{path} ) { |
210 |
$args{path} = $args{name}; |
$args{path} = $args{name}; |
211 |
$args{path} =~ s!::!/!g; |
$args{path} =~ s!::!/!g; |
212 |
} |
} |
213 |
$args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; |
$args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; |
214 |
|
$args{wrote} = 0; |
215 |
|
|
216 |
bless( \%args, $class ); |
bless( \%args, $class ); |
217 |
} |
} |
218 |
|
|
219 |
sub call { |
sub call { |
224 |
} |
} |
225 |
|
|
226 |
sub load { |
sub load { |
227 |
my ($self, $method) = @_; |
my ($self, $method) = @_; |
|
|
|
|
$self->load_extensions( |
|
|
"$self->{prefix}/$self->{path}", $self |
|
|
) unless $self->{extensions}; |
|
228 |
|
|
229 |
foreach my $obj (@{$self->{extensions}}) { |
$self->load_extensions( |
230 |
return $obj if $obj->can($method); |
"$self->{prefix}/$self->{path}", $self |
231 |
} |
) unless $self->{extensions}; |
232 |
|
|
233 |
|
foreach my $obj (@{$self->{extensions}}) { |
234 |
|
return $obj if $obj->can($method); |
235 |
|
} |
236 |
|
|
237 |
my $admin = $self->{admin} or die <<"END_DIE"; |
my $admin = $self->{admin} or die <<"END_DIE"; |
238 |
The '$method' method does not exist in the '$self->{prefix}' path! |
The '$method' method does not exist in the '$self->{prefix}' path! |
239 |
Please remove the '$self->{prefix}' directory and run $0 again to load it. |
Please remove the '$self->{prefix}' directory and run $0 again to load it. |
240 |
END_DIE |
END_DIE |
241 |
|
|
242 |
my $obj = $admin->load($method, 1); |
my $obj = $admin->load($method, 1); |
243 |
push @{$self->{extensions}}, $obj; |
push @{$self->{extensions}}, $obj; |
244 |
|
|
245 |
$obj; |
$obj; |
246 |
} |
} |
247 |
|
|
248 |
sub load_extensions { |
sub load_extensions { |
249 |
my ($self, $path, $top) = @_; |
my ($self, $path, $top) = @_; |
250 |
|
|
251 |
unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) { |
unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) { |
252 |
unshift @INC, $self->{prefix}; |
unshift @INC, $self->{prefix}; |
253 |
} |
} |
254 |
|
|
255 |
foreach my $rv ( $self->find_extensions($path) ) { |
foreach my $rv ( $self->find_extensions($path) ) { |
256 |
my ($file, $pkg) = @{$rv}; |
my ($file, $pkg) = @{$rv}; |
257 |
next if $self->{pathnames}{$pkg}; |
next if $self->{pathnames}{$pkg}; |
258 |
|
|
259 |
local $@; |
local $@; |
260 |
my $new = eval { require $file; $pkg->can('new') }; |
my $new = eval { require $file; $pkg->can('new') }; |
261 |
unless ( $new ) { |
unless ( $new ) { |
262 |
warn $@ if $@; |
warn $@ if $@; |
263 |
next; |
next; |
264 |
} |
} |
265 |
$self->{pathnames}{$pkg} = delete $INC{$file}; |
$self->{pathnames}{$pkg} = delete $INC{$file}; |
266 |
push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); |
push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); |
267 |
} |
} |
268 |
|
|
269 |
$self->{extensions} ||= []; |
$self->{extensions} ||= []; |
270 |
} |
} |
271 |
|
|
272 |
sub find_extensions { |
sub find_extensions { |
273 |
my ($self, $path) = @_; |
my ($self, $path) = @_; |
274 |
|
|
275 |
|
my @found; |
276 |
|
File::Find::find( sub { |
277 |
|
my $file = $File::Find::name; |
278 |
|
return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; |
279 |
|
my $subpath = $1; |
280 |
|
return if lc($subpath) eq lc($self->{dispatch}); |
281 |
|
|
282 |
|
$file = "$self->{path}/$subpath.pm"; |
283 |
|
my $pkg = "$self->{name}::$subpath"; |
284 |
|
$pkg =~ s!/!::!g; |
285 |
|
|
286 |
my @found; |
# If we have a mixed-case package name, assume case has been preserved |
287 |
File::Find::find( sub { |
# correctly. Otherwise, root through the file to locate the case-preserved |
288 |
my $file = $File::Find::name; |
# version of the package name. |
289 |
return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; |
if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { |
290 |
my $subpath = $1; |
my $content = Module::Install::_read($subpath . '.pm'); |
291 |
return if lc($subpath) eq lc($self->{dispatch}); |
my $in_pod = 0; |
292 |
|
foreach ( split //, $content ) { |
293 |
$file = "$self->{path}/$subpath.pm"; |
$in_pod = 1 if /^=\w/; |
294 |
my $pkg = "$self->{name}::$subpath"; |
$in_pod = 0 if /^=cut/; |
295 |
$pkg =~ s!/!::!g; |
next if ($in_pod || /^=cut/); # skip pod text |
296 |
|
next if /^\s*#/; # and comments |
297 |
# If we have a mixed-case package name, assume case has been preserved |
if ( m/^\s*package\s+($pkg)\s*;/i ) { |
298 |
# correctly. Otherwise, root through the file to locate the case-preserved |
$pkg = $1; |
299 |
# version of the package name. |
last; |
300 |
if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { |
} |
301 |
open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!"; |
} |
302 |
my $in_pod = 0; |
} |
|
while ( <PKGFILE> ) { |
|
|
$in_pod = 1 if /^=\w/; |
|
|
$in_pod = 0 if /^=cut/; |
|
|
next if ($in_pod || /^=cut/); # skip pod text |
|
|
next if /^\s*#/; # and comments |
|
|
if ( m/^\s*package\s+($pkg)\s*;/i ) { |
|
|
$pkg = $1; |
|
|
last; |
|
|
} |
|
|
} |
|
|
close PKGFILE; |
|
|
} |
|
303 |
|
|
304 |
push @found, [ $file, $pkg ]; |
push @found, [ $file, $pkg ]; |
305 |
}, $path ) if -d $path; |
}, $path ) if -d $path; |
306 |
|
|
307 |
@found; |
@found; |
308 |
} |
} |
309 |
|
|
310 |
|
|
311 |
|
|
312 |
|
|
313 |
|
|
314 |
|
##################################################################### |
315 |
|
# Utility Functions |
316 |
|
|
317 |
sub _caller { |
sub _caller { |
318 |
my $depth = 0; |
my $depth = 0; |
319 |
my $call = caller($depth); |
my $call = caller($depth); |
320 |
while ( $call eq __PACKAGE__ ) { |
while ( $call eq __PACKAGE__ ) { |
321 |
$depth++; |
$depth++; |
322 |
$call = caller($depth); |
$call = caller($depth); |
323 |
} |
} |
324 |
return $call; |
return $call; |
325 |
|
} |
326 |
|
|
327 |
|
sub _read { |
328 |
|
local *FH; |
329 |
|
open FH, "< $_[0]" or die "open($_[0]): $!"; |
330 |
|
my $str = do { local $/; <FH> }; |
331 |
|
close FH or die "close($_[0]): $!"; |
332 |
|
return $str; |
333 |
|
} |
334 |
|
|
335 |
|
sub _write { |
336 |
|
local *FH; |
337 |
|
open FH, "> $_[0]" or die "open($_[0]): $!"; |
338 |
|
foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" } |
339 |
|
close FH or die "close($_[0]): $!"; |
340 |
|
} |
341 |
|
|
342 |
|
sub _version ($) { |
343 |
|
my $s = shift || 0; |
344 |
|
$s =~ s/^(\d+)\.?//; |
345 |
|
my $l = $1 || 0; |
346 |
|
my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; |
347 |
|
$l = $l . '.' . join '', @v if @v; |
348 |
|
return $l + 0; |
349 |
|
} |
350 |
|
|
351 |
|
# Cloned from Params::Util::_CLASS |
352 |
|
sub _CLASS ($) { |
353 |
|
( |
354 |
|
defined $_[0] |
355 |
|
and |
356 |
|
! ref $_[0] |
357 |
|
and |
358 |
|
$_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s |
359 |
|
) ? $_[0] : undef; |
360 |
} |
} |
361 |
|
|
362 |
1; |
1; |
363 |
|
|
364 |
|
# Copyright 2008 Adam Kennedy. |