use
5.006;
use
vars
qw{$VERSION $MAIN}
;
BEGIN {
$VERSION
=
'1.16'
;
$MAIN
=
undef
;
*inc::Module::Install::VERSION
=
*VERSION
;
@inc::Module::Install::ISA
= __PACKAGE__;
}
sub
import
{
my
$class
=
shift
;
my
$self
=
$class
->new(
@_
);
my
$who
=
$self
->_caller;
my
$file
=
join
(
'/'
,
'inc'
,
split
/::/, __PACKAGE__ ) .
'.pm'
;
unless
(
$INC
{
$file
} ) {
die
<<"END_DIE" }
Please invoke ${\__PACKAGE__} with:
use inc::${\__PACKAGE__};
not:
use ${\__PACKAGE__};
END_DIE
eval
"use Win32::UTCFileTime"
if
$^O eq
'MSWin32'
&& $] >= 5.006;
if
( -f $0 ) {
my
$s
= (
stat
($0))[9];
my
$a
=
$s
-
time
;
if
(
$a
> 0 and
$a
< 5 ) {
sleep
5 }
my
$t
=
time
;
if
(
$s
>
$t
) {
die
<<"END_DIE" }
Your installer $0 has a modification time in the future ($s > $t).
This is known to create infinite loops in make.
Please correct this, then run $0 again.
END_DIE
}
if
( $0 =~ /Build.PL$/i ) {
die
<<"END_DIE" }
Module::Install no longer supports Build.PL.
It was impossible to maintain duel backends, and has been deprecated.
Please remove all Build.PL files and only use the Makefile.PL installer.
END_DIE
$^H |= strict::bits(
qw(refs subs vars)
);
unless
( -f
$self
->{file} ) {
foreach
my
$key
(
keys
%INC
) {
delete
$INC
{
$key
}
if
$key
=~ /Module\/Install/;
}
local
$^W;
require
"$self->{path}/$self->{dispatch}.pm"
;
File::Path::mkpath(
"$self->{prefix}/$self->{author}"
);
$self
->{admin} =
"$self->{name}::$self->{dispatch}"
->new(
_top
=>
$self
);
$self
->{admin}->init;
@_
= (
$class
,
_self
=>
$self
);
goto
&{
"$self->{name}::import"
};
}
local
$^W;
*{
"${who}::AUTOLOAD"
} =
$self
->autoload;
$self
->preload;
delete
$INC
{
'inc/Module/Install.pm'
};
delete
$INC
{
'Module/Install.pm'
};
$MAIN
=
$self
;
return
1;
}
sub
autoload {
my
$self
=
shift
;
my
$who
=
$self
->_caller;
my
$cwd
= Cwd::getcwd();
my
$sym
=
"${who}::AUTOLOAD"
;
$sym
->{
$cwd
} =
sub
{
my
$pwd
= Cwd::getcwd();
if
(
my
$code
=
$sym
->{
$pwd
} ) {
goto
&$code
unless
$cwd
eq
$pwd
;
}
unless
(
$$sym
=~ s/([^:]+)$//) {
my
(
$package
,
$file
,
$line
) =
caller
;
die
<<"EOT";
Unknown function is found at $file line $line.
Execution of $file aborted due to runtime errors.
If you're a contributor to a project, you may need to install
some Module::Install extensions from CPAN (or other repository).
If you're a user of a module, please contact the author.
EOT
}
my
$method
= $1;
if
(
uc
(
$method
) eq
$method
) {
return
;
}
elsif
(
$method
=~ /^_/ and
$self
->can(
$method
) ) {
return
$self
->
$method
(
@_
);
}
unshift
@_
, (
$self
, $1 );
goto
&{
$self
->can(
'call'
)};
};
}
sub
preload {
my
$self
=
shift
;
unless
(
$self
->{extensions} ) {
$self
->load_extensions(
"$self->{prefix}/$self->{path}"
,
$self
);
}
my
@exts
= @{
$self
->{extensions}};
unless
(
@exts
) {
@exts
=
$self
->{admin}->load_all_extensions;
}
my
%seen
;
foreach
my
$obj
(
@exts
) {
while
(
my
(
$method
,
$glob
) =
each
%{
ref
(
$obj
) .
'::'
}) {
next
unless
$obj
->can(
$method
);
next
if
$method
=~ /^_/;
next
if
$method
eq
uc
(
$method
);
$seen
{
$method
}++;
}
}
my
$who
=
$self
->_caller;
foreach
my
$name
(
sort
keys
%seen
) {
local
$^W;
*{
"${who}::$name"
} =
sub
{
${
"${who}::AUTOLOAD"
} =
"${who}::$name"
;
goto
&{
"${who}::AUTOLOAD"
};
};
}
}
sub
new {
my
(
$class
,
%args
) =
@_
;
delete
$INC
{
'FindBin.pm'
};
{
local
$SIG
{__WARN__} =
sub
{};
}
my
$base_path
= Cwd::abs_path(
$FindBin::Bin
);
unless
( Cwd::abs_path(Cwd::getcwd()) eq
$base_path
) {
delete
$args
{prefix};
}
return
$args
{_self}
if
$args
{_self};
$args
{dispatch} ||=
'Admin'
;
$args
{prefix} ||=
'inc'
;
$args
{author} ||= ($^O eq
'VMS'
?
'_author'
:
'.author'
);
$args
{bundle} ||=
'inc/BUNDLES'
;
$args
{base} ||=
$base_path
;
$class
=~ s/^\Q
$args
{prefix}\E:://;
$args
{name} ||=
$class
;
$args
{version} ||=
$class
->VERSION;
unless
(
$args
{path} ) {
$args
{path} =
$args
{name};
$args
{path} =~ s!::!/!g;
}
$args
{file} ||=
"$args{base}/$args{prefix}/$args{path}.pm"
;
$args
{wrote} = 0;
bless
( \
%args
,
$class
);
}
sub
call {
my
(
$self
,
$method
) =
@_
;
my
$obj
=
$self
->load(
$method
) or
return
;
splice
(
@_
, 0, 2,
$obj
);
goto
&{
$obj
->can(
$method
)};
}
sub
load {
my
(
$self
,
$method
) =
@_
;
$self
->load_extensions(
"$self->{prefix}/$self->{path}"
,
$self
)
unless
$self
->{extensions};
foreach
my
$obj
(@{
$self
->{extensions}}) {
return
$obj
if
$obj
->can(
$method
);
}
my
$admin
=
$self
->{admin} or
die
<<"END_DIE";
The '$method' method does not exist in the '$self->{prefix}' path!
Please remove the '$self->{prefix}' directory and run $0 again to load it.
END_DIE
my
$obj
=
$admin
->load(
$method
, 1);
push
@{
$self
->{extensions}},
$obj
;
$obj
;
}
sub
load_extensions {
my
(
$self
,
$path
,
$top
) =
@_
;
my
$should_reload
= 0;
unless
(
grep
{ !
ref
$_
and
lc
$_
eq
lc
$self
->{prefix} }
@INC
) {
unshift
@INC
,
$self
->{prefix};
$should_reload
= 1;
}
foreach
my
$rv
(
$self
->find_extensions(
$path
) ) {
my
(
$file
,
$pkg
) = @{
$rv
};
next
if
$self
->{pathnames}{
$pkg
};
local
$@;
my
$new
=
eval
{
local
$^W;
require
$file
;
$pkg
->can(
'new'
) };
unless
(
$new
) {
warn
$@
if
$@;
next
;
}
$self
->{pathnames}{
$pkg
} =
$should_reload
?
delete
$INC
{
$file
} :
$INC
{
$file
};
push
@{
$self
->{extensions}}, &{
$new
}(
$pkg
,
_top
=>
$top
);
}
$self
->{extensions} ||= [];
}
sub
find_extensions {
my
(
$self
,
$path
) =
@_
;
my
@found
;
File::Find::find(
sub
{
my
$file
=
$File::Find::name
;
return
unless
$file
=~ m!^\Q
$path
\E/(.+)\.pm\Z!is;
my
$subpath
= $1;
return
if
lc
(
$subpath
) eq
lc
(
$self
->{dispatch});
$file
=
"$self->{path}/$subpath.pm"
;
my
$pkg
=
"$self->{name}::$subpath"
;
$pkg
=~ s!/!::!g;
if
(
$subpath
eq
lc
(
$subpath
) ||
$subpath
eq
uc
(
$subpath
) ) {
my
$content
= Module::Install::_read(
$subpath
.
'.pm'
);
my
$in_pod
= 0;
foreach
(
split
/\n/,
$content
) {
$in_pod
= 1
if
/^=\w/;
$in_pod
= 0
if
/^=cut/;
next
if
(
$in_pod
|| /^=cut/);
next
if
/^\s*
if
( m/^\s
*package
\s+(
$pkg
)\s*;/i ) {
$pkg
= $1;
last
;
}
}
}
push
@found
, [
$file
,
$pkg
];
},
$path
)
if
-d
$path
;
@found
;
}
sub
_caller {
my
$depth
= 0;
my
$call
=
caller
(
$depth
);
while
(
$call
eq __PACKAGE__ ) {
$depth
++;
$call
=
caller
(
$depth
);
}
return
$call
;
}
eval
( $] >= 5.006 ?
<<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _read {
local *FH;
open( FH, '<', $_[0] ) or die "open($_[0]): $!";
binmode FH;
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $string;
}
END_NEW
sub
_read {
local
*FH
;
open
( FH,
"< $_[0]"
) or
die
"open($_[0]): $!"
;
binmode
FH;
my
$string
=
do
{
local
$/; <FH> };
close
FH or
die
"close($_[0]): $!"
;
return
$string
;
}
END_OLD
sub
_readperl {
my
$string
= Module::Install::_read(
$_
[0]);
$string
=~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
$string
=~ s/(\n)\n
*__
(?:DATA|END)__\b.*\z/$1/s;
$string
=~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
return
$string
;
}
sub
_readpod {
my
$string
= Module::Install::_read(
$_
[0]);
$string
=~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
return
$string
if
$_
[0] =~ /\.pod\z/;
$string
=~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
$string
=~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
$string
=~ s/\n*=cut\b[^\n]*\n+/\n\n/sg;
$string
=~ s/^\n+//s;
return
$string
;
}
eval
( $] >= 5.006 ?
<<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _write {
local *FH;
open( FH, '>', $_[0] ) or die "open($_[0]): $!";
binmode FH;
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
close FH or die "close($_[0]): $!";
}
END_NEW
sub
_write {
local
*FH
;
open
( FH,
"> $_[0]"
) or
die
"open($_[0]): $!"
;
binmode
FH;
foreach
( 1 ..
$#_
) {
print
FH
$_
[
$_
] or
die
"print($_[0]): $!"
;
}
close
FH or
die
"close($_[0]): $!"
;
}
END_OLD
sub
_version {
my
$s
=
shift
|| 0;
my
$d
=()=
$s
=~ /(\.)/g;
if
(
$d
>= 2 ) {
$s
=~ s/(\.)(\d{1,3})/
sprintf
(
"$1%03d"
,$2)/eg;
}
$s
=~ s/^(\d+)\.?//;
my
$l
= $1 || 0;
my
@v
=
map
{
$_
.
'0'
x (3 -
length
$_
)
}
$s
=~ /(\d{1,3})\D?/g;
$l
=
$l
.
'.'
.
join
''
,
@v
if
@v
;
return
$l
+ 0;
}
sub
_cmp {
_version(
$_
[1]) <=> _version(
$_
[2]);
}
sub
_CLASS {
(
defined
$_
[0]
and
!
ref
$_
[0]
and
$_
[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
) ?
$_
[0] :
undef
;
}
1;