/MooseX-ConfigFromFile-0.04/inc/Module/Install.pm
Perl | 470 lines | 311 code | 82 blank | 77 comment | 34 complexity | de388685eb7b662ac27cb4baaaf677a5 MD5 | raw file
- #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.02';
- # 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($_[0]) <=> _version($_[1]);
- }
- # 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 - 2011 Adam Kennedy.