diff options
Diffstat (limited to 'inc/Module/Install.pm')
| -rw-r--r-- | inc/Module/Install.pm | 470 |
1 files changed, 470 insertions, 0 deletions
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm new file mode 100644 index 0000000..4ecf46b --- /dev/null +++ b/inc/Module/Install.pm @@ -0,0 +1,470 @@ +#line 1 +package Module::Install; + +# For any maintainers: +# The load order for Module::Install is a bit magic. +# It goes something like this... +# +# IF ( host has Module::Install installed, creating author mode ) { +# 1. Makefile.PL calls "use inc::Module::Install" +# 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install +# 3. The installed version of inc::Module::Install loads +# 4. inc::Module::Install calls "require Module::Install" +# 5. The ./inc/ version of Module::Install loads +# } ELSE { +# 1. Makefile.PL calls "use inc::Module::Install" +# 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install +# 3. The ./inc/ version of Module::Install loads +# } + +use 5.005; +use strict 'vars'; +use Cwd (); +use File::Find (); +use File::Path (); + +use vars qw{$VERSION $MAIN}; +BEGIN { + # All Module::Install core packages now require synchronised versions. + # This will be used to ensure we don't accidentally load old or + # different versions of modules. + # This is not enforced yet, but will be some time in the next few + # releases once we can make sure it won't clash with custom + # Module::Install extensions. + $VERSION = '1.06'; + + # Storage for the pseudo-singleton + $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; + + #------------------------------------------------------------- + # all of the following checks should be included in import(), + # to allow "eval 'require Module::Install; 1' to test + # installation of Module::Install. (RT #51267) + #------------------------------------------------------------- + + # Whether or not inc::Module::Install is actually loaded, the + # $INC{inc/Module/Install.pm} is what will still get set as long as + # the caller loaded module this in the documented manner. + # If not set, the caller may NOT have loaded the bundled version, and thus + # they may not have a MI version that works with the Makefile.PL. This would + # result in false errors or unexpected behaviour. And we don't want that. + 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 + + # This reportedly fixes a rare Win32 UTC file time issue, but + # as this is a non-cross-platform XS module not in the core, + # we shouldn't really depend on it. See RT #24194 for detail. + # (Also, this module only supports Perl 5.6 and above). + eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; + + # If the script that is loading Module::Install is from the future, + # then make will detect this and cause it to re-run over and over + # again. This is bad. Rather than taking action to touch it (which + # is unreliable on some platforms and requires write permissions) + # for now we should catch this and refuse to run. + if ( -f $0 ) { + my $s = (stat($0))[9]; + + # If the modification time is only slightly in the future, + # sleep briefly to remove the problem. + my $a = $s - time; + if ( $a > 0 and $a < 5 ) { sleep 5 } + + # Too far in the future, throw an error. + 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 + } + + + # Build.PL was formerly supported, but no longer is due to excessive + # difficulty in implementing every single feature twice. + 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 + + #------------------------------------------------------------- + + # To save some more typing in Module::Install installers, every... + # use inc::Module::Install + # ...also acts as an implicit use strict. + $^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; + + # Unregister loader and worker packages so subdirs can use them again + delete $INC{'inc/Module/Install.pm'}; + delete $INC{'Module/Install.pm'}; + + # Save to the singleton + $MAIN = $self; + + return 1; +} + +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} ) { + # Delegate back to parent dirs + goto &$code unless $cwd eq $pwd; + } + unless ($$sym =~ s/([^:]+)$//) { + # XXX: it looks like we can't retrieve the missing function + # via $$sym (usually $main::AUTOLOAD) in this case. + # I'm still wondering if we should slurp Makefile.PL to + # get some context or not ... + 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 ) { + # Do nothing + return; + } elsif ( $method =~ /^_/ and $self->can($method) ) { + # Dispatch to the root M:I class + return $self->$method(@_); + } + + # Dispatch to the appropriate plugin + 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'}; + { + # to suppress the redefine warning + local $SIG{__WARN__} = sub {}; + require FindBin; + } + + # ignore the prefix on extension modules built from top level. + 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) = @_; + + 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 we have a mixed-case package name, assume case has been preserved + # correctly. Otherwise, root through the file to locate the case-preserved + # version of the package name. + 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/); # skip pod text + next if /^\s*#/; # and comments + if ( m/^\s*package\s+($pkg)\s*;/i ) { + $pkg = $1; + last; + } + } + } + + push @found, [ $file, $pkg ]; + }, $path ) if -d $path; + + @found; +} + + + + + +##################################################################### +# Common Utility Functions + +sub _caller { + my $depth = 0; + my $call = caller($depth); + while ( $call eq __PACKAGE__ ) { + $depth++; + $call = caller($depth); + } + return $call; +} + +# Done in evals to avoid confusing Perl::MinimumVersion +eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; +sub _read { + local *FH; + open( FH, '<', $_[0] ) or die "open($_[0]): $!"; + 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]): $!"; + 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; +} + +# Done in evals to avoid confusing Perl::MinimumVersion +eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; +sub _write { + local *FH; + open( FH, '>', $_[0] ) or die "open($_[0]): $!"; + 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]): $!"; + foreach ( 1 .. $#_ ) { + print FH $_[$_] or die "print($_[0]): $!"; + } + close FH or die "close($_[0]): $!"; +} +END_OLD + +# _version is for processing module versions (eg, 1.03_05) not +# Perl versions (eg, 5.8.1). +sub _version ($) { + my $s = shift || 0; + my $d =()= $s =~ /(\.)/g; + if ( $d >= 2 ) { + # Normalise multipart versions + $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]); +} + +# Cloned from Params::Util::_CLASS +sub _CLASS ($) { + ( + defined $_[0] + and + ! ref $_[0] + and + $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s + ) ? $_[0] : undef; +} + +1; + +# Copyright 2008 - 2012 Adam Kennedy. |