#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.006;
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.14';

    # 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::getcwd();
    my $sym  = "${who}::AUTOLOAD";
    $sym->{$cwd} = sub {
        my $pwd = Cwd::getcwd();
        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::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 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 /\n/, $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]): $!";
    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;
}

# 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]): $!";
    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

# _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.
