source: perl/modules/Facebook/inc/Module/Install.pm @ a98e071

#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 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 = '0.91';

        # Storage for the pseudo-singleton
        $MAIN    = undef;

        *inc::Module::Install::VERSION = *VERSION;
        @inc::Module::Install::ISA     = __PACKAGE__;

}





# 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





# 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));





use Cwd        ();
use File::Find ();
use File::Path ();
use FindBin;

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;
                }
                $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
                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 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;

        # Unregister loader and worker packages so subdirs can use them again
        delete $INC{"$self->{file}"};
        delete $INC{"$self->{path}.pm"};

        # Save to the singleton
        $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) = @_;

        # 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) = @_;

        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 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;
}

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

# _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 - 2009 Adam Kennedy.