use
5.005;
use
vars
qw{$VERSION $MAIN}
;
BEGIN {
$VERSION
=
'0.87'
;
$MAIN
=
undef
;
*inc::Module::Install::VERSION
=
*VERSION
;
@inc::Module::Install::ISA
= __PACKAGE__;
}
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
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)
);
sub
autoload {
my
$self
=
shift
;
my
$who
=
$self
->_caller;
my
$cwd
= Cwd::cwd();
my
$sym
=
"${who}::AUTOLOAD"
;
$sym
->{
$cwd
} =
sub
{
my
$pwd
= Cwd::cwd();
if
(
my
$code
=
$sym
->{
$pwd
} ) {
goto
&$code
unless
$cwd
eq
$pwd
;
}
$$sym
=~ /([^:]+)$/ or
die
"Cannot autoload $who - $sym"
;
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
import
{
my
$class
=
shift
;
my
$self
=
$class
->new(
@_
);
my
$who
=
$self
->_caller;
unless
( -f
$self
->{file} ) {
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"
};
}
*{
"${who}::AUTOLOAD"
} =
$self
->autoload;
$self
->preload;
delete
$INC
{
"$self->{file}"
};
delete
$INC
{
"$self->{path}.pm"
};
$MAIN
=
$self
;
return
1;
}
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
) {
*{
"${who}::$name"
} =
sub
{
${
"${who}::AUTOLOAD"
} =
"${who}::$name"
;
goto
&{
"${who}::AUTOLOAD"
};
};
}
}
sub
new {
my
(
$class
,
%args
) =
@_
;
my
$base_path
= Cwd::abs_path(
$FindBin::Bin
);
unless
( Cwd::abs_path(Cwd::cwd()) 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
) =
@_
;
unless
(
grep
{ !
ref
$_
and
lc
$_
eq
lc
$self
->{prefix} }
@INC
) {
unshift
@INC
,
$self
->{prefix};
}
foreach
my
$rv
(
$self
->find_extensions(
$path
) ) {
my
(
$file
,
$pkg
) = @{
$rv
};
next
if
$self
->{pathnames}{
$pkg
};
local
$@;
my
$new
=
eval
{
require
$file
;
$pkg
->can(
'new'
) };
unless
(
$new
) {
warn
$@
if
$@;
next
;
}
$self
->{pathnames}{
$pkg
} =
delete
$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
//,
$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
;
}
sub
_read {
local
*FH
;
if
( $] >= 5.006 ) {
open
( FH,
'<'
,
$_
[0] ) or
die
"open($_[0]): $!"
;
}
else
{
open
( FH,
"< $_[0]"
) or
die
"open($_[0]): $!"
;
}
my
$string
=
do
{
local
$/; <FH> };
close
FH or
die
"close($_[0]): $!"
;
return
$string
;
}
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
;
}
sub
_write {
local
*FH
;
if
( $] >= 5.006 ) {
open
( FH,
'>'
,
$_
[0] ) or
die
"open($_[0]): $!"
;
}
else
{
open
( FH,
"> $_[0]"
) or
die
"open($_[0]): $!"
;
}
foreach
( 1 ..
$#_
) {
print
FH
$_
[
$_
] or
die
"print($_[0]): $!"
;
}
close
FH or
die
"close($_[0]): $!"
;
}
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(
$_
[0]) <=> _version(
$_
[1]);
}
sub
_CLASS ($) {
(
defined
$_
[0]
and
!
ref
$_
[0]
and
$_
[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
) ?
$_
[0] :
undef
;
}
1;