Imported Upstream version 0.18
This commit is contained in:
Mario Fetka
768
inc/Module/AutoInstall.pm
Normal file
768
inc/Module/AutoInstall.pm
Normal file
@@ -0,0 +1,768 @@
|
||||
#line 1
|
||||
package Module::AutoInstall;
|
||||
|
||||
use strict;
|
||||
use Cwd ();
|
||||
use ExtUtils::MakeMaker ();
|
||||
|
||||
use vars qw{$VERSION};
|
||||
BEGIN {
|
||||
$VERSION = '1.03';
|
||||
}
|
||||
|
||||
# special map on pre-defined feature sets
|
||||
my %FeatureMap = (
|
||||
'' => 'Core Features', # XXX: deprecated
|
||||
'-core' => 'Core Features',
|
||||
);
|
||||
|
||||
# various lexical flags
|
||||
my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS );
|
||||
my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly );
|
||||
my ( $PostambleActions, $PostambleUsed );
|
||||
|
||||
# See if it's a testing or non-interactive session
|
||||
_accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN );
|
||||
_init();
|
||||
|
||||
sub _accept_default {
|
||||
$AcceptDefault = shift;
|
||||
}
|
||||
|
||||
sub missing_modules {
|
||||
return @Missing;
|
||||
}
|
||||
|
||||
sub do_install {
|
||||
__PACKAGE__->install(
|
||||
[
|
||||
$Config
|
||||
? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
|
||||
: ()
|
||||
],
|
||||
@Missing,
|
||||
);
|
||||
}
|
||||
|
||||
# initialize various flags, and/or perform install
|
||||
sub _init {
|
||||
foreach my $arg (
|
||||
@ARGV,
|
||||
split(
|
||||
/[\s\t]+/,
|
||||
$ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || ''
|
||||
)
|
||||
)
|
||||
{
|
||||
if ( $arg =~ /^--config=(.*)$/ ) {
|
||||
$Config = [ split( ',', $1 ) ];
|
||||
}
|
||||
elsif ( $arg =~ /^--installdeps=(.*)$/ ) {
|
||||
__PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) );
|
||||
exit 0;
|
||||
}
|
||||
elsif ( $arg =~ /^--default(?:deps)?$/ ) {
|
||||
$AcceptDefault = 1;
|
||||
}
|
||||
elsif ( $arg =~ /^--check(?:deps)?$/ ) {
|
||||
$CheckOnly = 1;
|
||||
}
|
||||
elsif ( $arg =~ /^--skip(?:deps)?$/ ) {
|
||||
$SkipInstall = 1;
|
||||
}
|
||||
elsif ( $arg =~ /^--test(?:only)?$/ ) {
|
||||
$TestOnly = 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# overrides MakeMaker's prompt() to automatically accept the default choice
|
||||
sub _prompt {
|
||||
goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault;
|
||||
|
||||
my ( $prompt, $default ) = @_;
|
||||
my $y = ( $default =~ /^[Yy]/ );
|
||||
|
||||
print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] ';
|
||||
print "$default\n";
|
||||
return $default;
|
||||
}
|
||||
|
||||
# the workhorse
|
||||
sub import {
|
||||
my $class = shift;
|
||||
my @args = @_ or return;
|
||||
my $core_all;
|
||||
|
||||
print "*** $class version " . $class->VERSION . "\n";
|
||||
print "*** Checking for Perl dependencies...\n";
|
||||
|
||||
my $cwd = Cwd::cwd();
|
||||
|
||||
$Config = [];
|
||||
|
||||
my $maxlen = length(
|
||||
(
|
||||
sort { length($b) <=> length($a) }
|
||||
grep { /^[^\-]/ }
|
||||
map {
|
||||
ref($_)
|
||||
? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} )
|
||||
: ''
|
||||
}
|
||||
map { +{@args}->{$_} }
|
||||
grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} }
|
||||
)[0]
|
||||
);
|
||||
|
||||
while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) {
|
||||
my ( @required, @tests, @skiptests );
|
||||
my $default = 1;
|
||||
my $conflict = 0;
|
||||
|
||||
if ( $feature =~ m/^-(\w+)$/ ) {
|
||||
my $option = lc($1);
|
||||
|
||||
# check for a newer version of myself
|
||||
_update_to( $modules, @_ ) and return if $option eq 'version';
|
||||
|
||||
# sets CPAN configuration options
|
||||
$Config = $modules if $option eq 'config';
|
||||
|
||||
# promote every features to core status
|
||||
$core_all = ( $modules =~ /^all$/i ) and next
|
||||
if $option eq 'core';
|
||||
|
||||
next unless $option eq 'core';
|
||||
}
|
||||
|
||||
print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n";
|
||||
|
||||
$modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' );
|
||||
|
||||
unshift @$modules, -default => &{ shift(@$modules) }
|
||||
if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward combatability
|
||||
|
||||
while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) {
|
||||
if ( $mod =~ m/^-(\w+)$/ ) {
|
||||
my $option = lc($1);
|
||||
|
||||
$default = $arg if ( $option eq 'default' );
|
||||
$conflict = $arg if ( $option eq 'conflict' );
|
||||
@tests = @{$arg} if ( $option eq 'tests' );
|
||||
@skiptests = @{$arg} if ( $option eq 'skiptests' );
|
||||
|
||||
next;
|
||||
}
|
||||
|
||||
printf( "- %-${maxlen}s ...", $mod );
|
||||
|
||||
if ( $arg and $arg =~ /^\D/ ) {
|
||||
unshift @$modules, $arg;
|
||||
$arg = 0;
|
||||
}
|
||||
|
||||
# XXX: check for conflicts and uninstalls(!) them.
|
||||
if (
|
||||
defined( my $cur = _version_check( _load($mod), $arg ||= 0 ) ) )
|
||||
{
|
||||
print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n";
|
||||
push @Existing, $mod => $arg;
|
||||
$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
|
||||
}
|
||||
else {
|
||||
print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n";
|
||||
push @required, $mod => $arg;
|
||||
}
|
||||
}
|
||||
|
||||
next unless @required;
|
||||
|
||||
my $mandatory = ( $feature eq '-core' or $core_all );
|
||||
|
||||
if (
|
||||
!$SkipInstall
|
||||
and (
|
||||
$CheckOnly
|
||||
or _prompt(
|
||||
qq{==> Auto-install the }
|
||||
. ( @required / 2 )
|
||||
. ( $mandatory ? ' mandatory' : ' optional' )
|
||||
. qq{ module(s) from CPAN?},
|
||||
$default ? 'y' : 'n',
|
||||
) =~ /^[Yy]/
|
||||
)
|
||||
)
|
||||
{
|
||||
push( @Missing, @required );
|
||||
$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
|
||||
}
|
||||
|
||||
elsif ( !$SkipInstall
|
||||
and $default
|
||||
and $mandatory
|
||||
and
|
||||
_prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', )
|
||||
=~ /^[Nn]/ )
|
||||
{
|
||||
push( @Missing, @required );
|
||||
$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
|
||||
}
|
||||
|
||||
else {
|
||||
$DisabledTests{$_} = 1 for map { glob($_) } @tests;
|
||||
}
|
||||
}
|
||||
|
||||
$UnderCPAN = _check_lock(); # check for $UnderCPAN
|
||||
|
||||
if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) {
|
||||
require Config;
|
||||
print
|
||||
"*** Dependencies will be installed the next time you type '$Config::Config{make}'.\n";
|
||||
|
||||
# make an educated guess of whether we'll need root permission.
|
||||
print " (You may need to do that as the 'root' user.)\n"
|
||||
if eval '$>';
|
||||
}
|
||||
print "*** $class configuration finished.\n";
|
||||
|
||||
chdir $cwd;
|
||||
|
||||
# import to main::
|
||||
no strict 'refs';
|
||||
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
|
||||
}
|
||||
|
||||
# Check to see if we are currently running under CPAN.pm and/or CPANPLUS;
|
||||
# if we are, then we simply let it taking care of our dependencies
|
||||
sub _check_lock {
|
||||
return unless @Missing;
|
||||
|
||||
if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) {
|
||||
print <<'END_MESSAGE';
|
||||
|
||||
*** Since we're running under CPANPLUS, I'll just let it take care
|
||||
of the dependency's installation later.
|
||||
END_MESSAGE
|
||||
return 1;
|
||||
}
|
||||
|
||||
_load_cpan();
|
||||
|
||||
# Find the CPAN lock-file
|
||||
my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" );
|
||||
return unless -f $lock;
|
||||
|
||||
# Check the lock
|
||||
local *LOCK;
|
||||
return unless open(LOCK, $lock);
|
||||
|
||||
if (
|
||||
( $^O eq 'MSWin32' ? _under_cpan() : <LOCK> == getppid() )
|
||||
and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore'
|
||||
) {
|
||||
print <<'END_MESSAGE';
|
||||
|
||||
*** Since we're running under CPAN, I'll just let it take care
|
||||
of the dependency's installation later.
|
||||
END_MESSAGE
|
||||
return 1;
|
||||
}
|
||||
|
||||
close LOCK;
|
||||
return;
|
||||
}
|
||||
|
||||
sub install {
|
||||
my $class = shift;
|
||||
|
||||
my $i; # used below to strip leading '-' from config keys
|
||||
my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } );
|
||||
|
||||
my ( @modules, @installed );
|
||||
while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) {
|
||||
|
||||
# grep out those already installed
|
||||
if ( defined( _version_check( _load($pkg), $ver ) ) ) {
|
||||
push @installed, $pkg;
|
||||
}
|
||||
else {
|
||||
push @modules, $pkg, $ver;
|
||||
}
|
||||
}
|
||||
|
||||
return @installed unless @modules; # nothing to do
|
||||
return @installed if _check_lock(); # defer to the CPAN shell
|
||||
|
||||
print "*** Installing dependencies...\n";
|
||||
|
||||
return unless _connected_to('cpan.org');
|
||||
|
||||
my %args = @config;
|
||||
my %failed;
|
||||
local *FAILED;
|
||||
if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) {
|
||||
while (<FAILED>) { chomp; $failed{$_}++ }
|
||||
close FAILED;
|
||||
|
||||
my @newmod;
|
||||
while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) {
|
||||
push @newmod, ( $k => $v ) unless $failed{$k};
|
||||
}
|
||||
@modules = @newmod;
|
||||
}
|
||||
|
||||
if ( _has_cpanplus() ) {
|
||||
_install_cpanplus( \@modules, \@config );
|
||||
} else {
|
||||
_install_cpan( \@modules, \@config );
|
||||
}
|
||||
|
||||
print "*** $class installation finished.\n";
|
||||
|
||||
# see if we have successfully installed them
|
||||
while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
|
||||
if ( defined( _version_check( _load($pkg), $ver ) ) ) {
|
||||
push @installed, $pkg;
|
||||
}
|
||||
elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) {
|
||||
print FAILED "$pkg\n";
|
||||
}
|
||||
}
|
||||
|
||||
close FAILED if $args{do_once};
|
||||
|
||||
return @installed;
|
||||
}
|
||||
|
||||
sub _install_cpanplus {
|
||||
my @modules = @{ +shift };
|
||||
my @config = _cpanplus_config( @{ +shift } );
|
||||
my $installed = 0;
|
||||
|
||||
require CPANPLUS::Backend;
|
||||
my $cp = CPANPLUS::Backend->new;
|
||||
my $conf = $cp->configure_object;
|
||||
|
||||
return unless $conf->can('conf') # 0.05x+ with "sudo" support
|
||||
or _can_write($conf->_get_build('base')); # 0.04x
|
||||
|
||||
# if we're root, set UNINST=1 to avoid trouble unless user asked for it.
|
||||
my $makeflags = $conf->get_conf('makeflags') || '';
|
||||
if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) {
|
||||
# 0.03+ uses a hashref here
|
||||
$makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST};
|
||||
|
||||
} else {
|
||||
# 0.02 and below uses a scalar
|
||||
$makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' )
|
||||
if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } );
|
||||
|
||||
}
|
||||
$conf->set_conf( makeflags => $makeflags );
|
||||
$conf->set_conf( prereqs => 1 );
|
||||
|
||||
|
||||
|
||||
while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) {
|
||||
$conf->set_conf( $key, $val );
|
||||
}
|
||||
|
||||
my $modtree = $cp->module_tree;
|
||||
while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
|
||||
print "*** Installing $pkg...\n";
|
||||
|
||||
MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall;
|
||||
|
||||
my $success;
|
||||
my $obj = $modtree->{$pkg};
|
||||
|
||||
if ( $obj and defined( _version_check( $obj->{version}, $ver ) ) ) {
|
||||
my $pathname = $pkg;
|
||||
$pathname =~ s/::/\\W/;
|
||||
|
||||
foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) {
|
||||
delete $INC{$inc};
|
||||
}
|
||||
|
||||
my $rv = $cp->install( modules => [ $obj->{module} ] );
|
||||
|
||||
if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) {
|
||||
print "*** $pkg successfully installed.\n";
|
||||
$success = 1;
|
||||
} else {
|
||||
print "*** $pkg installation cancelled.\n";
|
||||
$success = 0;
|
||||
}
|
||||
|
||||
$installed += $success;
|
||||
} else {
|
||||
print << ".";
|
||||
*** Could not find a version $ver or above for $pkg; skipping.
|
||||
.
|
||||
}
|
||||
|
||||
MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall;
|
||||
}
|
||||
|
||||
return $installed;
|
||||
}
|
||||
|
||||
sub _cpanplus_config {
|
||||
my @config = ();
|
||||
while ( @_ ) {
|
||||
my ($key, $value) = (shift(), shift());
|
||||
if ( $key eq 'prerequisites_policy' ) {
|
||||
if ( $value eq 'follow' ) {
|
||||
$value = CPANPLUS::Internals::Constants::PREREQ_INSTALL();
|
||||
} elsif ( $value eq 'ask' ) {
|
||||
$value = CPANPLUS::Internals::Constants::PREREQ_ASK();
|
||||
} elsif ( $value eq 'ignore' ) {
|
||||
$value = CPANPLUS::Internals::Constants::PREREQ_IGNORE();
|
||||
} else {
|
||||
die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n";
|
||||
}
|
||||
} else {
|
||||
die "*** Cannot convert option $key to CPANPLUS version.\n";
|
||||
}
|
||||
}
|
||||
return @config;
|
||||
}
|
||||
|
||||
sub _install_cpan {
|
||||
my @modules = @{ +shift };
|
||||
my @config = @{ +shift };
|
||||
my $installed = 0;
|
||||
my %args;
|
||||
|
||||
_load_cpan();
|
||||
require Config;
|
||||
|
||||
if (CPAN->VERSION < 1.80) {
|
||||
# no "sudo" support, probe for writableness
|
||||
return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) )
|
||||
and _can_write( $Config::Config{sitelib} );
|
||||
}
|
||||
|
||||
# if we're root, set UNINST=1 to avoid trouble unless user asked for it.
|
||||
my $makeflags = $CPAN::Config->{make_install_arg} || '';
|
||||
$CPAN::Config->{make_install_arg} =
|
||||
join( ' ', split( ' ', $makeflags ), 'UNINST=1' )
|
||||
if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } );
|
||||
|
||||
# don't show start-up info
|
||||
$CPAN::Config->{inhibit_startup_message} = 1;
|
||||
|
||||
# set additional options
|
||||
while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) {
|
||||
( $args{$opt} = $arg, next )
|
||||
if $opt =~ /^force$/; # pseudo-option
|
||||
$CPAN::Config->{$opt} = $arg;
|
||||
}
|
||||
|
||||
local $CPAN::Config->{prerequisites_policy} = 'follow';
|
||||
|
||||
while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
|
||||
MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall;
|
||||
|
||||
print "*** Installing $pkg...\n";
|
||||
|
||||
my $obj = CPAN::Shell->expand( Module => $pkg );
|
||||
my $success = 0;
|
||||
|
||||
if ( $obj and defined( _version_check( $obj->cpan_version, $ver ) ) ) {
|
||||
my $pathname = $pkg;
|
||||
$pathname =~ s/::/\\W/;
|
||||
|
||||
foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) {
|
||||
delete $INC{$inc};
|
||||
}
|
||||
|
||||
my $rv = $args{force} ? CPAN::Shell->force( install => $pkg )
|
||||
: CPAN::Shell->install($pkg);
|
||||
$rv ||= eval {
|
||||
$CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, )
|
||||
->{install}
|
||||
if $CPAN::META;
|
||||
};
|
||||
|
||||
if ( $rv eq 'YES' ) {
|
||||
print "*** $pkg successfully installed.\n";
|
||||
$success = 1;
|
||||
}
|
||||
else {
|
||||
print "*** $pkg installation failed.\n";
|
||||
$success = 0;
|
||||
}
|
||||
|
||||
$installed += $success;
|
||||
}
|
||||
else {
|
||||
print << ".";
|
||||
*** Could not find a version $ver or above for $pkg; skipping.
|
||||
.
|
||||
}
|
||||
|
||||
MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall;
|
||||
}
|
||||
|
||||
return $installed;
|
||||
}
|
||||
|
||||
sub _has_cpanplus {
|
||||
return (
|
||||
$HasCPANPLUS = (
|
||||
$INC{'CPANPLUS/Config.pm'}
|
||||
or _load('CPANPLUS::Shell::Default')
|
||||
)
|
||||
);
|
||||
}
|
||||
|
||||
# make guesses on whether we're under the CPAN installation directory
|
||||
sub _under_cpan {
|
||||
require Cwd;
|
||||
require File::Spec;
|
||||
|
||||
my $cwd = File::Spec->canonpath( Cwd::cwd() );
|
||||
my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} );
|
||||
|
||||
return ( index( $cwd, $cpan ) > -1 );
|
||||
}
|
||||
|
||||
sub _update_to {
|
||||
my $class = __PACKAGE__;
|
||||
my $ver = shift;
|
||||
|
||||
return
|
||||
if defined( _version_check( _load($class), $ver ) ); # no need to upgrade
|
||||
|
||||
if (
|
||||
_prompt( "==> A newer version of $class ($ver) is required. Install?",
|
||||
'y' ) =~ /^[Nn]/
|
||||
)
|
||||
{
|
||||
die "*** Please install $class $ver manually.\n";
|
||||
}
|
||||
|
||||
print << ".";
|
||||
*** Trying to fetch it from CPAN...
|
||||
.
|
||||
|
||||
# install ourselves
|
||||
_load($class) and return $class->import(@_)
|
||||
if $class->install( [], $class, $ver );
|
||||
|
||||
print << '.'; exit 1;
|
||||
|
||||
*** Cannot bootstrap myself. :-( Installation terminated.
|
||||
.
|
||||
}
|
||||
|
||||
# check if we're connected to some host, using inet_aton
|
||||
sub _connected_to {
|
||||
my $site = shift;
|
||||
|
||||
return (
|
||||
( _load('Socket') and Socket::inet_aton($site) ) or _prompt(
|
||||
qq(
|
||||
*** Your host cannot resolve the domain name '$site', which
|
||||
probably means the Internet connections are unavailable.
|
||||
==> Should we try to install the required module(s) anyway?), 'n'
|
||||
) =~ /^[Yy]/
|
||||
);
|
||||
}
|
||||
|
||||
# check if a directory is writable; may create it on demand
|
||||
sub _can_write {
|
||||
my $path = shift;
|
||||
mkdir( $path, 0755 ) unless -e $path;
|
||||
|
||||
return 1 if -w $path;
|
||||
|
||||
print << ".";
|
||||
*** You are not allowed to write to the directory '$path';
|
||||
the installation may fail due to insufficient permissions.
|
||||
.
|
||||
|
||||
if (
|
||||
eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt(
|
||||
qq(
|
||||
==> Should we try to re-execute the autoinstall process with 'sudo'?),
|
||||
((-t STDIN) ? 'y' : 'n')
|
||||
) =~ /^[Yy]/
|
||||
)
|
||||
{
|
||||
|
||||
# try to bootstrap ourselves from sudo
|
||||
print << ".";
|
||||
*** Trying to re-execute the autoinstall process with 'sudo'...
|
||||
.
|
||||
my $missing = join( ',', @Missing );
|
||||
my $config = join( ',',
|
||||
UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
|
||||
if $Config;
|
||||
|
||||
return
|
||||
unless system( 'sudo', $^X, $0, "--config=$config",
|
||||
"--installdeps=$missing" );
|
||||
|
||||
print << ".";
|
||||
*** The 'sudo' command exited with error! Resuming...
|
||||
.
|
||||
}
|
||||
|
||||
return _prompt(
|
||||
qq(
|
||||
==> Should we try to install the required module(s) anyway?), 'n'
|
||||
) =~ /^[Yy]/;
|
||||
}
|
||||
|
||||
# load a module and return the version it reports
|
||||
sub _load {
|
||||
my $mod = pop; # class/instance doesn't matter
|
||||
my $file = $mod;
|
||||
|
||||
$file =~ s|::|/|g;
|
||||
$file .= '.pm';
|
||||
|
||||
local $@;
|
||||
return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 );
|
||||
}
|
||||
|
||||
# Load CPAN.pm and it's configuration
|
||||
sub _load_cpan {
|
||||
return if $CPAN::VERSION;
|
||||
require CPAN;
|
||||
if ( $CPAN::HandleConfig::VERSION ) {
|
||||
# Newer versions of CPAN have a HandleConfig module
|
||||
CPAN::HandleConfig->load;
|
||||
} else {
|
||||
# Older versions had the load method in Config directly
|
||||
CPAN::Config->load;
|
||||
}
|
||||
}
|
||||
|
||||
# compare two versions, either use Sort::Versions or plain comparison
|
||||
sub _version_check {
|
||||
my ( $cur, $min ) = @_;
|
||||
return unless defined $cur;
|
||||
|
||||
$cur =~ s/\s+$//;
|
||||
|
||||
# check for version numbers that are not in decimal format
|
||||
if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) {
|
||||
if ( ( $version::VERSION or defined( _load('version') )) and
|
||||
version->can('new')
|
||||
) {
|
||||
|
||||
# use version.pm if it is installed.
|
||||
return (
|
||||
( version->new($cur) >= version->new($min) ) ? $cur : undef );
|
||||
}
|
||||
elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) )
|
||||
{
|
||||
|
||||
# use Sort::Versions as the sorting algorithm for a.b.c versions
|
||||
return ( ( Sort::Versions::versioncmp( $cur, $min ) != -1 )
|
||||
? $cur
|
||||
: undef );
|
||||
}
|
||||
|
||||
warn "Cannot reliably compare non-decimal formatted versions.\n"
|
||||
. "Please install version.pm or Sort::Versions.\n";
|
||||
}
|
||||
|
||||
# plain comparison
|
||||
local $^W = 0; # shuts off 'not numeric' bugs
|
||||
return ( $cur >= $min ? $cur : undef );
|
||||
}
|
||||
|
||||
# nothing; this usage is deprecated.
|
||||
sub main::PREREQ_PM { return {}; }
|
||||
|
||||
sub _make_args {
|
||||
my %args = @_;
|
||||
|
||||
$args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing }
|
||||
if $UnderCPAN or $TestOnly;
|
||||
|
||||
if ( $args{EXE_FILES} and -e 'MANIFEST' ) {
|
||||
require ExtUtils::Manifest;
|
||||
my $manifest = ExtUtils::Manifest::maniread('MANIFEST');
|
||||
|
||||
$args{EXE_FILES} =
|
||||
[ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ];
|
||||
}
|
||||
|
||||
$args{test}{TESTS} ||= 't/*.t';
|
||||
$args{test}{TESTS} = join( ' ',
|
||||
grep { !exists( $DisabledTests{$_} ) }
|
||||
map { glob($_) } split( /\s+/, $args{test}{TESTS} ) );
|
||||
|
||||
my $missing = join( ',', @Missing );
|
||||
my $config =
|
||||
join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
|
||||
if $Config;
|
||||
|
||||
$PostambleActions = (
|
||||
$missing
|
||||
? "\$(PERL) $0 --config=$config --installdeps=$missing"
|
||||
: "\$(NOECHO) \$(NOOP)"
|
||||
);
|
||||
|
||||
return %args;
|
||||
}
|
||||
|
||||
# a wrapper to ExtUtils::MakeMaker::WriteMakefile
|
||||
sub Write {
|
||||
require Carp;
|
||||
Carp::croak "WriteMakefile: Need even number of args" if @_ % 2;
|
||||
|
||||
if ($CheckOnly) {
|
||||
print << ".";
|
||||
*** Makefile not written in check-only mode.
|
||||
.
|
||||
return;
|
||||
}
|
||||
|
||||
my %args = _make_args(@_);
|
||||
|
||||
no strict 'refs';
|
||||
|
||||
$PostambleUsed = 0;
|
||||
local *MY::postamble = \&postamble unless defined &MY::postamble;
|
||||
ExtUtils::MakeMaker::WriteMakefile(%args);
|
||||
|
||||
print << "." unless $PostambleUsed;
|
||||
*** WARNING: Makefile written with customized MY::postamble() without
|
||||
including contents from Module::AutoInstall::postamble() --
|
||||
auto installation features disabled. Please contact the author.
|
||||
.
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub postamble {
|
||||
$PostambleUsed = 1;
|
||||
|
||||
return << ".";
|
||||
|
||||
config :: installdeps
|
||||
\t\$(NOECHO) \$(NOOP)
|
||||
|
||||
checkdeps ::
|
||||
\t\$(PERL) $0 --checkdeps
|
||||
|
||||
installdeps ::
|
||||
\t$PostambleActions
|
||||
|
||||
.
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
#line 1003
|
||||
369
inc/Module/Install.pm
Normal file
369
inc/Module/Install.pm
Normal file
@@ -0,0 +1,369 @@
|
||||
#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
|
||||
# }
|
||||
|
||||
BEGIN {
|
||||
require 5.004;
|
||||
}
|
||||
use strict 'vars';
|
||||
|
||||
use vars qw{$VERSION};
|
||||
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.77';
|
||||
|
||||
*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 and (stat($0))[9] > time ) { die <<"END_DIE" }
|
||||
|
||||
Your installer $0 has a modification time in the future.
|
||||
|
||||
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";
|
||||
unless ( uc($1) eq $1 ) {
|
||||
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"};
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub preload {
|
||||
my $self = shift;
|
||||
unless ( $self->{extensions} ) {
|
||||
$self->load_extensions(
|
||||
"$self->{prefix}/$self->{path}", $self
|
||||
);
|
||||
}
|
||||
|
||||
my @exts = @{$self->{extensions}};
|
||||
unless ( @exts ) {
|
||||
my $admin = $self->{admin};
|
||||
@exts = $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 { 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;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#####################################################################
|
||||
# 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;
|
||||
open FH, "< $_[0]" or die "open($_[0]): $!";
|
||||
my $str = do { local $/; <FH> };
|
||||
close FH or die "close($_[0]): $!";
|
||||
return $str;
|
||||
}
|
||||
|
||||
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]): $!";
|
||||
}
|
||||
|
||||
# _version is for processing module versions (eg, 1.03_05) not
|
||||
# Perl versions (eg, 5.8.1).
|
||||
|
||||
sub _version ($) {
|
||||
my $s = shift || 0;
|
||||
$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;
|
||||
}
|
||||
|
||||
# Cloned from Params::Util::_CLASS
|
||||
sub _CLASS ($) {
|
||||
(
|
||||
defined $_[0]
|
||||
and
|
||||
! ref $_[0]
|
||||
and
|
||||
$_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s
|
||||
) ? $_[0] : undef;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# Copyright 2008 Adam Kennedy.
|
||||
61
inc/Module/Install/AutoInstall.pm
Normal file
61
inc/Module/Install/AutoInstall.pm
Normal file
@@ -0,0 +1,61 @@
|
||||
#line 1
|
||||
package Module::Install::AutoInstall;
|
||||
|
||||
use strict;
|
||||
use Module::Install::Base;
|
||||
|
||||
use vars qw{$VERSION $ISCORE @ISA};
|
||||
BEGIN {
|
||||
$VERSION = '0.77';
|
||||
$ISCORE = 1;
|
||||
@ISA = qw{Module::Install::Base};
|
||||
}
|
||||
|
||||
sub AutoInstall { $_[0] }
|
||||
|
||||
sub run {
|
||||
my $self = shift;
|
||||
$self->auto_install_now(@_);
|
||||
}
|
||||
|
||||
sub write {
|
||||
my $self = shift;
|
||||
$self->auto_install(@_);
|
||||
}
|
||||
|
||||
sub auto_install {
|
||||
my $self = shift;
|
||||
return if $self->{done}++;
|
||||
|
||||
# Flatten array of arrays into a single array
|
||||
my @core = map @$_, map @$_, grep ref,
|
||||
$self->build_requires, $self->requires;
|
||||
|
||||
my @config = @_;
|
||||
|
||||
# We'll need Module::AutoInstall
|
||||
$self->include('Module::AutoInstall');
|
||||
require Module::AutoInstall;
|
||||
|
||||
Module::AutoInstall->import(
|
||||
(@config ? (-config => \@config) : ()),
|
||||
(@core ? (-core => \@core) : ()),
|
||||
$self->features,
|
||||
);
|
||||
|
||||
$self->makemaker_args( Module::AutoInstall::_make_args() );
|
||||
|
||||
my $class = ref($self);
|
||||
$self->postamble(
|
||||
"# --- $class section:\n" .
|
||||
Module::AutoInstall::postamble()
|
||||
);
|
||||
}
|
||||
|
||||
sub auto_install_now {
|
||||
my $self = shift;
|
||||
$self->auto_install(@_);
|
||||
Module::AutoInstall::do_install();
|
||||
}
|
||||
|
||||
1;
|
||||
72
inc/Module/Install/Base.pm
Normal file
72
inc/Module/Install/Base.pm
Normal file
@@ -0,0 +1,72 @@
|
||||
#line 1
|
||||
package Module::Install::Base;
|
||||
|
||||
$VERSION = '0.77';
|
||||
|
||||
# Suspend handler for "redefined" warnings
|
||||
BEGIN {
|
||||
my $w = $SIG{__WARN__};
|
||||
$SIG{__WARN__} = sub { $w };
|
||||
}
|
||||
|
||||
### This is the ONLY module that shouldn't have strict on
|
||||
# use strict;
|
||||
|
||||
#line 41
|
||||
|
||||
sub new {
|
||||
my ($class, %args) = @_;
|
||||
|
||||
foreach my $method ( qw(call load) ) {
|
||||
*{"$class\::$method"} = sub {
|
||||
shift()->_top->$method(@_);
|
||||
} unless defined &{"$class\::$method"};
|
||||
}
|
||||
|
||||
bless( \%args, $class );
|
||||
}
|
||||
|
||||
#line 61
|
||||
|
||||
sub AUTOLOAD {
|
||||
my $self = shift;
|
||||
local $@;
|
||||
my $autoload = eval { $self->_top->autoload } or return;
|
||||
goto &$autoload;
|
||||
}
|
||||
|
||||
#line 76
|
||||
|
||||
sub _top { $_[0]->{_top} }
|
||||
|
||||
#line 89
|
||||
|
||||
sub admin {
|
||||
$_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new;
|
||||
}
|
||||
|
||||
#line 101
|
||||
|
||||
sub is_admin {
|
||||
$_[0]->admin->VERSION;
|
||||
}
|
||||
|
||||
sub DESTROY {}
|
||||
|
||||
package Module::Install::Base::FakeAdmin;
|
||||
|
||||
my $Fake;
|
||||
sub new { $Fake ||= bless(\@_, $_[0]) }
|
||||
|
||||
sub AUTOLOAD {}
|
||||
|
||||
sub DESTROY {}
|
||||
|
||||
# Restore warning handler
|
||||
BEGIN {
|
||||
$SIG{__WARN__} = $SIG{__WARN__}->();
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
#line 146
|
||||
83
inc/Module/Install/Can.pm
Normal file
83
inc/Module/Install/Can.pm
Normal file
@@ -0,0 +1,83 @@
|
||||
#line 1
|
||||
package Module::Install::Can;
|
||||
|
||||
use strict;
|
||||
use Module::Install::Base;
|
||||
use Config ();
|
||||
### This adds a 5.005 Perl version dependency.
|
||||
### This is a bug and will be fixed.
|
||||
use File::Spec ();
|
||||
use ExtUtils::MakeMaker ();
|
||||
|
||||
use vars qw{$VERSION $ISCORE @ISA};
|
||||
BEGIN {
|
||||
$VERSION = '0.77';
|
||||
$ISCORE = 1;
|
||||
@ISA = qw{Module::Install::Base};
|
||||
}
|
||||
|
||||
# check if we can load some module
|
||||
### Upgrade this to not have to load the module if possible
|
||||
sub can_use {
|
||||
my ($self, $mod, $ver) = @_;
|
||||
$mod =~ s{::|\\}{/}g;
|
||||
$mod .= '.pm' unless $mod =~ /\.pm$/i;
|
||||
|
||||
my $pkg = $mod;
|
||||
$pkg =~ s{/}{::}g;
|
||||
$pkg =~ s{\.pm$}{}i;
|
||||
|
||||
local $@;
|
||||
eval { require $mod; $pkg->VERSION($ver || 0); 1 };
|
||||
}
|
||||
|
||||
# check if we can run some command
|
||||
sub can_run {
|
||||
my ($self, $cmd) = @_;
|
||||
|
||||
my $_cmd = $cmd;
|
||||
return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
|
||||
|
||||
for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
|
||||
next if $dir eq '';
|
||||
my $abs = File::Spec->catfile($dir, $_[1]);
|
||||
return $abs if (-x $abs or $abs = MM->maybe_command($abs));
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
# can we locate a (the) C compiler
|
||||
sub can_cc {
|
||||
my $self = shift;
|
||||
my @chunks = split(/ /, $Config::Config{cc}) or return;
|
||||
|
||||
# $Config{cc} may contain args; try to find out the program part
|
||||
while (@chunks) {
|
||||
return $self->can_run("@chunks") || (pop(@chunks), next);
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
# Fix Cygwin bug on maybe_command();
|
||||
if ( $^O eq 'cygwin' ) {
|
||||
require ExtUtils::MM_Cygwin;
|
||||
require ExtUtils::MM_Win32;
|
||||
if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) {
|
||||
*ExtUtils::MM_Cygwin::maybe_command = sub {
|
||||
my ($self, $file) = @_;
|
||||
if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) {
|
||||
ExtUtils::MM_Win32->maybe_command($file);
|
||||
} else {
|
||||
ExtUtils::MM_Unix->maybe_command($file);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
#line 158
|
||||
68
inc/Module/Install/Compiler.pm
Normal file
68
inc/Module/Install/Compiler.pm
Normal file
@@ -0,0 +1,68 @@
|
||||
#line 1
|
||||
package Module::Install::Compiler;
|
||||
|
||||
use strict;
|
||||
use Module::Install::Base;
|
||||
use File::Basename ();
|
||||
|
||||
use vars qw{$VERSION $ISCORE @ISA};
|
||||
BEGIN {
|
||||
$VERSION = '0.77';
|
||||
$ISCORE = 1;
|
||||
@ISA = qw{Module::Install::Base};
|
||||
}
|
||||
|
||||
sub ppport {
|
||||
my $self = shift;
|
||||
if ( $self->is_admin ) {
|
||||
return $self->admin->ppport(@_);
|
||||
} else {
|
||||
# Fallback to just a check
|
||||
my $file = shift || 'ppport.h';
|
||||
unless ( -f $file ) {
|
||||
die "Packaging error, $file is missing";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub cc_files {
|
||||
require Config;
|
||||
my $self = shift;
|
||||
$self->makemaker_args(
|
||||
OBJECT => join ' ', map { substr($_, 0, -2) . $Config::Config{_o} } @_
|
||||
);
|
||||
}
|
||||
|
||||
sub cc_inc_paths {
|
||||
my $self = shift;
|
||||
$self->makemaker_args(
|
||||
INC => join ' ', map { "-I$_" } @_
|
||||
);
|
||||
}
|
||||
|
||||
sub cc_lib_paths {
|
||||
my $self = shift;
|
||||
$self->makemaker_args(
|
||||
LIBS => join ' ', map { "-L$_" } @_
|
||||
);
|
||||
}
|
||||
|
||||
sub cc_lib_links {
|
||||
my $self = shift;
|
||||
$self->makemaker_args(
|
||||
LIBS => join ' ', $self->makemaker_args->{LIBS}, map { "-l$_" } @_
|
||||
);
|
||||
}
|
||||
|
||||
sub cc_optimize_flags {
|
||||
my $self = shift;
|
||||
$self->makemaker_args(
|
||||
OPTIMIZE => join ' ', @_
|
||||
);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
#line 123
|
||||
93
inc/Module/Install/Fetch.pm
Normal file
93
inc/Module/Install/Fetch.pm
Normal file
@@ -0,0 +1,93 @@
|
||||
#line 1
|
||||
package Module::Install::Fetch;
|
||||
|
||||
use strict;
|
||||
use Module::Install::Base;
|
||||
|
||||
use vars qw{$VERSION $ISCORE @ISA};
|
||||
BEGIN {
|
||||
$VERSION = '0.77';
|
||||
$ISCORE = 1;
|
||||
@ISA = qw{Module::Install::Base};
|
||||
}
|
||||
|
||||
sub get_file {
|
||||
my ($self, %args) = @_;
|
||||
my ($scheme, $host, $path, $file) =
|
||||
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
|
||||
|
||||
if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
|
||||
$args{url} = $args{ftp_url}
|
||||
or (warn("LWP support unavailable!\n"), return);
|
||||
($scheme, $host, $path, $file) =
|
||||
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
|
||||
}
|
||||
|
||||
$|++;
|
||||
print "Fetching '$file' from $host... ";
|
||||
|
||||
unless (eval { require Socket; Socket::inet_aton($host) }) {
|
||||
warn "'$host' resolve failed!\n";
|
||||
return;
|
||||
}
|
||||
|
||||
return unless $scheme eq 'ftp' or $scheme eq 'http';
|
||||
|
||||
require Cwd;
|
||||
my $dir = Cwd::getcwd();
|
||||
chdir $args{local_dir} or return if exists $args{local_dir};
|
||||
|
||||
if (eval { require LWP::Simple; 1 }) {
|
||||
LWP::Simple::mirror($args{url}, $file);
|
||||
}
|
||||
elsif (eval { require Net::FTP; 1 }) { eval {
|
||||
# use Net::FTP to get past firewall
|
||||
my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
|
||||
$ftp->login("anonymous", 'anonymous@example.com');
|
||||
$ftp->cwd($path);
|
||||
$ftp->binary;
|
||||
$ftp->get($file) or (warn("$!\n"), return);
|
||||
$ftp->quit;
|
||||
} }
|
||||
elsif (my $ftp = $self->can_run('ftp')) { eval {
|
||||
# no Net::FTP, fallback to ftp.exe
|
||||
require FileHandle;
|
||||
my $fh = FileHandle->new;
|
||||
|
||||
local $SIG{CHLD} = 'IGNORE';
|
||||
unless ($fh->open("|$ftp -n")) {
|
||||
warn "Couldn't open ftp: $!\n";
|
||||
chdir $dir; return;
|
||||
}
|
||||
|
||||
my @dialog = split(/\n/, <<"END_FTP");
|
||||
open $host
|
||||
user anonymous anonymous\@example.com
|
||||
cd $path
|
||||
binary
|
||||
get $file $file
|
||||
quit
|
||||
END_FTP
|
||||
foreach (@dialog) { $fh->print("$_\n") }
|
||||
$fh->close;
|
||||
} }
|
||||
else {
|
||||
warn "No working 'ftp' program available!\n";
|
||||
chdir $dir; return;
|
||||
}
|
||||
|
||||
unless (-f $file) {
|
||||
warn "Fetching failed: $@\n";
|
||||
chdir $dir; return;
|
||||
}
|
||||
|
||||
return if exists $args{size} and -s $file != $args{size};
|
||||
system($args{run}) if exists $args{run};
|
||||
unlink($file) if $args{remove};
|
||||
|
||||
print(((!exists $args{check_for} or -e $args{check_for})
|
||||
? "done!" : "failed! ($!)"), "\n");
|
||||
chdir $dir; return !$?;
|
||||
}
|
||||
|
||||
1;
|
||||
34
inc/Module/Install/Include.pm
Normal file
34
inc/Module/Install/Include.pm
Normal file
@@ -0,0 +1,34 @@
|
||||
#line 1
|
||||
package Module::Install::Include;
|
||||
|
||||
use strict;
|
||||
use Module::Install::Base;
|
||||
|
||||
use vars qw{$VERSION $ISCORE @ISA};
|
||||
BEGIN {
|
||||
$VERSION = '0.77';
|
||||
$ISCORE = 1;
|
||||
@ISA = qw{Module::Install::Base};
|
||||
}
|
||||
|
||||
sub include {
|
||||
shift()->admin->include(@_);
|
||||
}
|
||||
|
||||
sub include_deps {
|
||||
shift()->admin->include_deps(@_);
|
||||
}
|
||||
|
||||
sub auto_include {
|
||||
shift()->admin->auto_include(@_);
|
||||
}
|
||||
|
||||
sub auto_include_deps {
|
||||
shift()->admin->auto_include_deps(@_);
|
||||
}
|
||||
|
||||
sub auto_include_dependent_dists {
|
||||
shift()->admin->auto_include_dependent_dists(@_);
|
||||
}
|
||||
|
||||
1;
|
||||
253
inc/Module/Install/Makefile.pm
Normal file
253
inc/Module/Install/Makefile.pm
Normal file
@@ -0,0 +1,253 @@
|
||||
#line 1
|
||||
package Module::Install::Makefile;
|
||||
|
||||
use strict 'vars';
|
||||
use Module::Install::Base;
|
||||
use ExtUtils::MakeMaker ();
|
||||
|
||||
use vars qw{$VERSION $ISCORE @ISA};
|
||||
BEGIN {
|
||||
$VERSION = '0.77';
|
||||
$ISCORE = 1;
|
||||
@ISA = qw{Module::Install::Base};
|
||||
}
|
||||
|
||||
sub Makefile { $_[0] }
|
||||
|
||||
my %seen = ();
|
||||
|
||||
sub prompt {
|
||||
shift;
|
||||
|
||||
# Infinite loop protection
|
||||
my @c = caller();
|
||||
if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
|
||||
die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
|
||||
}
|
||||
|
||||
# In automated testing, always use defaults
|
||||
if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) {
|
||||
local $ENV{PERL_MM_USE_DEFAULT} = 1;
|
||||
goto &ExtUtils::MakeMaker::prompt;
|
||||
} else {
|
||||
goto &ExtUtils::MakeMaker::prompt;
|
||||
}
|
||||
}
|
||||
|
||||
sub makemaker_args {
|
||||
my $self = shift;
|
||||
my $args = ( $self->{makemaker_args} ||= {} );
|
||||
%$args = ( %$args, @_ );
|
||||
return $args;
|
||||
}
|
||||
|
||||
# For mm args that take multiple space-seperated args,
|
||||
# append an argument to the current list.
|
||||
sub makemaker_append {
|
||||
my $self = sShift;
|
||||
my $name = shift;
|
||||
my $args = $self->makemaker_args;
|
||||
$args->{name} = defined $args->{$name}
|
||||
? join( ' ', $args->{name}, @_ )
|
||||
: join( ' ', @_ );
|
||||
}
|
||||
|
||||
sub build_subdirs {
|
||||
my $self = shift;
|
||||
my $subdirs = $self->makemaker_args->{DIR} ||= [];
|
||||
for my $subdir (@_) {
|
||||
push @$subdirs, $subdir;
|
||||
}
|
||||
}
|
||||
|
||||
sub clean_files {
|
||||
my $self = shift;
|
||||
my $clean = $self->makemaker_args->{clean} ||= {};
|
||||
%$clean = (
|
||||
%$clean,
|
||||
FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_),
|
||||
);
|
||||
}
|
||||
|
||||
sub realclean_files {
|
||||
my $self = shift;
|
||||
my $realclean = $self->makemaker_args->{realclean} ||= {};
|
||||
%$realclean = (
|
||||
%$realclean,
|
||||
FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_),
|
||||
);
|
||||
}
|
||||
|
||||
sub libs {
|
||||
my $self = shift;
|
||||
my $libs = ref $_[0] ? shift : [ shift ];
|
||||
$self->makemaker_args( LIBS => $libs );
|
||||
}
|
||||
|
||||
sub inc {
|
||||
my $self = shift;
|
||||
$self->makemaker_args( INC => shift );
|
||||
}
|
||||
|
||||
my %test_dir = ();
|
||||
|
||||
sub _wanted_t {
|
||||
/\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1;
|
||||
}
|
||||
|
||||
sub tests_recursive {
|
||||
my $self = shift;
|
||||
if ( $self->tests ) {
|
||||
die "tests_recursive will not work if tests are already defined";
|
||||
}
|
||||
my $dir = shift || 't';
|
||||
unless ( -d $dir ) {
|
||||
die "tests_recursive dir '$dir' does not exist";
|
||||
}
|
||||
%test_dir = ();
|
||||
require File::Find;
|
||||
File::Find::find( \&_wanted_t, $dir );
|
||||
$self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
|
||||
}
|
||||
|
||||
sub write {
|
||||
my $self = shift;
|
||||
die "&Makefile->write() takes no arguments\n" if @_;
|
||||
|
||||
# Make sure we have a new enough
|
||||
require ExtUtils::MakeMaker;
|
||||
|
||||
# MakeMaker can complain about module versions that include
|
||||
# an underscore, even though its own version may contain one!
|
||||
# Hence the funny regexp to get rid of it. See RT #35800
|
||||
# for details.
|
||||
|
||||
$self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
|
||||
|
||||
# Generate the
|
||||
my $args = $self->makemaker_args;
|
||||
$args->{DISTNAME} = $self->name;
|
||||
$args->{NAME} = $self->module_name || $self->name;
|
||||
$args->{VERSION} = $self->version;
|
||||
$args->{NAME} =~ s/-/::/g;
|
||||
if ( $self->tests ) {
|
||||
$args->{test} = { TESTS => $self->tests };
|
||||
}
|
||||
if ($] >= 5.005) {
|
||||
$args->{ABSTRACT} = $self->abstract;
|
||||
$args->{AUTHOR} = $self->author;
|
||||
}
|
||||
if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
|
||||
$args->{NO_META} = 1;
|
||||
}
|
||||
if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
|
||||
$args->{SIGN} = 1;
|
||||
}
|
||||
unless ( $self->is_admin ) {
|
||||
delete $args->{SIGN};
|
||||
}
|
||||
|
||||
# merge both kinds of requires into prereq_pm
|
||||
my $prereq = ($args->{PREREQ_PM} ||= {});
|
||||
%$prereq = ( %$prereq,
|
||||
map { @$_ }
|
||||
map { @$_ }
|
||||
grep $_,
|
||||
($self->configure_requires, $self->build_requires, $self->requires)
|
||||
);
|
||||
|
||||
# Remove any reference to perl, PREREQ_PM doesn't support it
|
||||
delete $args->{PREREQ_PM}->{perl};
|
||||
|
||||
# merge both kinds of requires into prereq_pm
|
||||
my $subdirs = ($args->{DIR} ||= []);
|
||||
if ($self->bundles) {
|
||||
foreach my $bundle (@{ $self->bundles }) {
|
||||
my ($file, $dir) = @$bundle;
|
||||
push @$subdirs, $dir if -d $dir;
|
||||
delete $prereq->{$file};
|
||||
}
|
||||
}
|
||||
|
||||
if ( my $perl_version = $self->perl_version ) {
|
||||
eval "use $perl_version; 1"
|
||||
or die "ERROR: perl: Version $] is installed, "
|
||||
. "but we need version >= $perl_version";
|
||||
}
|
||||
|
||||
$args->{INSTALLDIRS} = $self->installdirs;
|
||||
|
||||
my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
|
||||
|
||||
my $user_preop = delete $args{dist}->{PREOP};
|
||||
if (my $preop = $self->admin->preop($user_preop)) {
|
||||
foreach my $key ( keys %$preop ) {
|
||||
$args{dist}->{$key} = $preop->{$key};
|
||||
}
|
||||
}
|
||||
|
||||
my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
|
||||
$self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile');
|
||||
}
|
||||
|
||||
sub fix_up_makefile {
|
||||
my $self = shift;
|
||||
my $makefile_name = shift;
|
||||
my $top_class = ref($self->_top) || '';
|
||||
my $top_version = $self->_top->VERSION || '';
|
||||
|
||||
my $preamble = $self->preamble
|
||||
? "# Preamble by $top_class $top_version\n"
|
||||
. $self->preamble
|
||||
: '';
|
||||
my $postamble = "# Postamble by $top_class $top_version\n"
|
||||
. ($self->postamble || '');
|
||||
|
||||
local *MAKEFILE;
|
||||
open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
|
||||
my $makefile = do { local $/; <MAKEFILE> };
|
||||
close MAKEFILE or die $!;
|
||||
|
||||
$makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
|
||||
$makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
|
||||
$makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g;
|
||||
$makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
|
||||
$makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
|
||||
|
||||
# Module::Install will never be used to build the Core Perl
|
||||
# Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
|
||||
# PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
|
||||
$makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
|
||||
#$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
|
||||
|
||||
# Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
|
||||
$makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g;
|
||||
|
||||
# XXX - This is currently unused; not sure if it breaks other MM-users
|
||||
# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
|
||||
|
||||
open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
|
||||
print MAKEFILE "$preamble$makefile$postamble" or die $!;
|
||||
close MAKEFILE or die $!;
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
sub preamble {
|
||||
my ($self, $text) = @_;
|
||||
$self->{preamble} = $text . $self->{preamble} if defined $text;
|
||||
$self->{preamble};
|
||||
}
|
||||
|
||||
sub postamble {
|
||||
my ($self, $text) = @_;
|
||||
$self->{postamble} ||= $self->admin->postamble;
|
||||
$self->{postamble} .= $text if defined $text;
|
||||
$self->{postamble}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
#line 379
|
||||
500
inc/Module/Install/Metadata.pm
Normal file
500
inc/Module/Install/Metadata.pm
Normal file
@@ -0,0 +1,500 @@
|
||||
#line 1
|
||||
package Module::Install::Metadata;
|
||||
|
||||
use strict 'vars';
|
||||
use Module::Install::Base;
|
||||
|
||||
use vars qw{$VERSION $ISCORE @ISA};
|
||||
BEGIN {
|
||||
$VERSION = '0.77';
|
||||
$ISCORE = 1;
|
||||
@ISA = qw{Module::Install::Base};
|
||||
}
|
||||
|
||||
my @scalar_keys = qw{
|
||||
name
|
||||
module_name
|
||||
abstract
|
||||
author
|
||||
version
|
||||
distribution_type
|
||||
tests
|
||||
installdirs
|
||||
};
|
||||
|
||||
my @tuple_keys = qw{
|
||||
configure_requires
|
||||
build_requires
|
||||
requires
|
||||
recommends
|
||||
bundles
|
||||
resources
|
||||
};
|
||||
|
||||
my @resource_keys = qw{
|
||||
homepage
|
||||
bugtracker
|
||||
repository
|
||||
};
|
||||
|
||||
sub Meta { shift }
|
||||
sub Meta_ScalarKeys { @scalar_keys }
|
||||
sub Meta_TupleKeys { @tuple_keys }
|
||||
sub Meta_ResourceKeys { @resource_keys }
|
||||
|
||||
foreach my $key ( @scalar_keys ) {
|
||||
*$key = sub {
|
||||
my $self = shift;
|
||||
return $self->{values}{$key} if defined wantarray and !@_;
|
||||
$self->{values}{$key} = shift;
|
||||
return $self;
|
||||
};
|
||||
}
|
||||
|
||||
foreach my $key ( @resource_keys ) {
|
||||
*$key = sub {
|
||||
my $self = shift;
|
||||
unless ( @_ ) {
|
||||
return () unless $self->{values}{resources};
|
||||
return map { $_->[1] }
|
||||
grep { $_->[0] eq $key }
|
||||
@{ $self->{values}{resources} };
|
||||
}
|
||||
return $self->{values}{resources}{$key} unless @_;
|
||||
my $uri = shift or die(
|
||||
"Did not provide a value to $key()"
|
||||
);
|
||||
$self->resources( $key => $uri );
|
||||
return 1;
|
||||
};
|
||||
}
|
||||
|
||||
sub requires {
|
||||
my $self = shift;
|
||||
while ( @_ ) {
|
||||
my $module = shift or last;
|
||||
my $version = shift || 0;
|
||||
push @{ $self->{values}{requires} }, [ $module, $version ];
|
||||
}
|
||||
$self->{values}{requires};
|
||||
}
|
||||
|
||||
sub build_requires {
|
||||
my $self = shift;
|
||||
while ( @_ ) {
|
||||
my $module = shift or last;
|
||||
my $version = shift || 0;
|
||||
push @{ $self->{values}{build_requires} }, [ $module, $version ];
|
||||
}
|
||||
$self->{values}{build_requires};
|
||||
}
|
||||
|
||||
sub configure_requires {
|
||||
my $self = shift;
|
||||
while ( @_ ) {
|
||||
my $module = shift or last;
|
||||
my $version = shift || 0;
|
||||
push @{ $self->{values}{configure_requires} }, [ $module, $version ];
|
||||
}
|
||||
$self->{values}{configure_requires};
|
||||
}
|
||||
|
||||
sub recommends {
|
||||
my $self = shift;
|
||||
while ( @_ ) {
|
||||
my $module = shift or last;
|
||||
my $version = shift || 0;
|
||||
push @{ $self->{values}{recommends} }, [ $module, $version ];
|
||||
}
|
||||
$self->{values}{recommends};
|
||||
}
|
||||
|
||||
sub bundles {
|
||||
my $self = shift;
|
||||
while ( @_ ) {
|
||||
my $module = shift or last;
|
||||
my $version = shift || 0;
|
||||
push @{ $self->{values}{bundles} }, [ $module, $version ];
|
||||
}
|
||||
$self->{values}{bundles};
|
||||
}
|
||||
|
||||
# Resource handling
|
||||
my %lc_resource = map { $_ => 1 } qw{
|
||||
homepage
|
||||
license
|
||||
bugtracker
|
||||
repository
|
||||
};
|
||||
|
||||
sub resources {
|
||||
my $self = shift;
|
||||
while ( @_ ) {
|
||||
my $name = shift or last;
|
||||
my $value = shift or next;
|
||||
if ( $name eq lc $name and ! $lc_resource{$name} ) {
|
||||
die("Unsupported reserved lowercase resource '$name'");
|
||||
}
|
||||
$self->{values}{resources} ||= [];
|
||||
push @{ $self->{values}{resources} }, [ $name, $value ];
|
||||
}
|
||||
$self->{values}{resources};
|
||||
}
|
||||
|
||||
# Aliases for build_requires that will have alternative
|
||||
# meanings in some future version of META.yml.
|
||||
sub test_requires { shift->build_requires(@_) }
|
||||
sub install_requires { shift->build_requires(@_) }
|
||||
|
||||
# Aliases for installdirs options
|
||||
sub install_as_core { $_[0]->installdirs('perl') }
|
||||
sub install_as_cpan { $_[0]->installdirs('site') }
|
||||
sub install_as_site { $_[0]->installdirs('site') }
|
||||
sub install_as_vendor { $_[0]->installdirs('vendor') }
|
||||
|
||||
sub sign {
|
||||
my $self = shift;
|
||||
return $self->{values}{sign} if defined wantarray and ! @_;
|
||||
$self->{values}{sign} = ( @_ ? $_[0] : 1 );
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub dynamic_config {
|
||||
my $self = shift;
|
||||
unless ( @_ ) {
|
||||
warn "You MUST provide an explicit true/false value to dynamic_config\n";
|
||||
return $self;
|
||||
}
|
||||
$self->{values}{dynamic_config} = $_[0] ? 1 : 0;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub perl_version {
|
||||
my $self = shift;
|
||||
return $self->{values}{perl_version} unless @_;
|
||||
my $version = shift or die(
|
||||
"Did not provide a value to perl_version()"
|
||||
);
|
||||
|
||||
# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
|
||||
# numbers (eg, 5.006001 or 5.008009).
|
||||
|
||||
$version =~ s/^(\d+)\.(\d+)\.(\d+)$/sprintf("%d.%03d%03d",$1,$2,$3)/e;
|
||||
|
||||
$version =~ s/_.+$//;
|
||||
$version = $version + 0; # Numify
|
||||
unless ( $version >= 5.005 ) {
|
||||
die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
|
||||
}
|
||||
$self->{values}{perl_version} = $version;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub license {
|
||||
my $self = shift;
|
||||
return $self->{values}{license} unless @_;
|
||||
my $license = shift or die(
|
||||
'Did not provide a value to license()'
|
||||
);
|
||||
$self->{values}{license} = $license;
|
||||
|
||||
# Automatically fill in license URLs
|
||||
if ( $license eq 'perl' ) {
|
||||
$self->resources( license => 'http://dev.perl.org/licenses/' );
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub all_from {
|
||||
my ( $self, $file ) = @_;
|
||||
|
||||
unless ( defined($file) ) {
|
||||
my $name = $self->name or die(
|
||||
"all_from called with no args without setting name() first"
|
||||
);
|
||||
$file = join('/', 'lib', split(/-/, $name)) . '.pm';
|
||||
$file =~ s{.*/}{} unless -e $file;
|
||||
unless ( -e $file ) {
|
||||
die("all_from cannot find $file from $name");
|
||||
}
|
||||
}
|
||||
unless ( -f $file ) {
|
||||
die("The path '$file' does not exist, or is not a file");
|
||||
}
|
||||
|
||||
# Some methods pull from POD instead of code.
|
||||
# If there is a matching .pod, use that instead
|
||||
my $pod = $file;
|
||||
$pod =~ s/\.pm$/.pod/i;
|
||||
$pod = $file unless -e $pod;
|
||||
|
||||
# Pull the different values
|
||||
$self->name_from($file) unless $self->name;
|
||||
$self->version_from($file) unless $self->version;
|
||||
$self->perl_version_from($file) unless $self->perl_version;
|
||||
$self->author_from($pod) unless $self->author;
|
||||
$self->license_from($pod) unless $self->license;
|
||||
$self->abstract_from($pod) unless $self->abstract;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub provides {
|
||||
my $self = shift;
|
||||
my $provides = ( $self->{values}{provides} ||= {} );
|
||||
%$provides = (%$provides, @_) if @_;
|
||||
return $provides;
|
||||
}
|
||||
|
||||
sub auto_provides {
|
||||
my $self = shift;
|
||||
return $self unless $self->is_admin;
|
||||
unless (-e 'MANIFEST') {
|
||||
warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
|
||||
return $self;
|
||||
}
|
||||
# Avoid spurious warnings as we are not checking manifest here.
|
||||
local $SIG{__WARN__} = sub {1};
|
||||
require ExtUtils::Manifest;
|
||||
local *ExtUtils::Manifest::manicheck = sub { return };
|
||||
|
||||
require Module::Build;
|
||||
my $build = Module::Build->new(
|
||||
dist_name => $self->name,
|
||||
dist_version => $self->version,
|
||||
license => $self->license,
|
||||
);
|
||||
$self->provides( %{ $build->find_dist_packages || {} } );
|
||||
}
|
||||
|
||||
sub feature {
|
||||
my $self = shift;
|
||||
my $name = shift;
|
||||
my $features = ( $self->{values}{features} ||= [] );
|
||||
my $mods;
|
||||
|
||||
if ( @_ == 1 and ref( $_[0] ) ) {
|
||||
# The user used ->feature like ->features by passing in the second
|
||||
# argument as a reference. Accomodate for that.
|
||||
$mods = $_[0];
|
||||
} else {
|
||||
$mods = \@_;
|
||||
}
|
||||
|
||||
my $count = 0;
|
||||
push @$features, (
|
||||
$name => [
|
||||
map {
|
||||
ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
|
||||
} @$mods
|
||||
]
|
||||
);
|
||||
|
||||
return @$features;
|
||||
}
|
||||
|
||||
sub features {
|
||||
my $self = shift;
|
||||
while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
|
||||
$self->feature( $name, @$mods );
|
||||
}
|
||||
return $self->{values}{features}
|
||||
? @{ $self->{values}{features} }
|
||||
: ();
|
||||
}
|
||||
|
||||
sub no_index {
|
||||
my $self = shift;
|
||||
my $type = shift;
|
||||
push @{ $self->{values}{no_index}{$type} }, @_ if $type;
|
||||
return $self->{values}{no_index};
|
||||
}
|
||||
|
||||
sub read {
|
||||
my $self = shift;
|
||||
$self->include_deps( 'YAML::Tiny', 0 );
|
||||
|
||||
require YAML::Tiny;
|
||||
my $data = YAML::Tiny::LoadFile('META.yml');
|
||||
|
||||
# Call methods explicitly in case user has already set some values.
|
||||
while ( my ( $key, $value ) = each %$data ) {
|
||||
next unless $self->can($key);
|
||||
if ( ref $value eq 'HASH' ) {
|
||||
while ( my ( $module, $version ) = each %$value ) {
|
||||
$self->can($key)->($self, $module => $version );
|
||||
}
|
||||
} else {
|
||||
$self->can($key)->($self, $value);
|
||||
}
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub write {
|
||||
my $self = shift;
|
||||
return $self unless $self->is_admin;
|
||||
$self->admin->write_meta;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub version_from {
|
||||
require ExtUtils::MM_Unix;
|
||||
my ( $self, $file ) = @_;
|
||||
$self->version( ExtUtils::MM_Unix->parse_version($file) );
|
||||
}
|
||||
|
||||
sub abstract_from {
|
||||
require ExtUtils::MM_Unix;
|
||||
my ( $self, $file ) = @_;
|
||||
$self->abstract(
|
||||
bless(
|
||||
{ DISTNAME => $self->name },
|
||||
'ExtUtils::MM_Unix'
|
||||
)->parse_abstract($file)
|
||||
);
|
||||
}
|
||||
|
||||
# Add both distribution and module name
|
||||
sub name_from {
|
||||
my ($self, $file) = @_;
|
||||
if (
|
||||
Module::Install::_read($file) =~ m/
|
||||
^ \s*
|
||||
package \s*
|
||||
([\w:]+)
|
||||
\s* ;
|
||||
/ixms
|
||||
) {
|
||||
my ($name, $module_name) = ($1, $1);
|
||||
$name =~ s{::}{-}g;
|
||||
$self->name($name);
|
||||
unless ( $self->module_name ) {
|
||||
$self->module_name($module_name);
|
||||
}
|
||||
} else {
|
||||
die("Cannot determine name from $file\n");
|
||||
}
|
||||
}
|
||||
|
||||
sub perl_version_from {
|
||||
my $self = shift;
|
||||
if (
|
||||
Module::Install::_read($_[0]) =~ m/
|
||||
^
|
||||
(?:use|require) \s*
|
||||
v?
|
||||
([\d_\.]+)
|
||||
\s* ;
|
||||
/ixms
|
||||
) {
|
||||
my $perl_version = $1;
|
||||
$perl_version =~ s{_}{}g;
|
||||
$self->perl_version($perl_version);
|
||||
} else {
|
||||
warn "Cannot determine perl version info from $_[0]\n";
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
sub author_from {
|
||||
my $self = shift;
|
||||
my $content = Module::Install::_read($_[0]);
|
||||
if ($content =~ m/
|
||||
=head \d \s+ (?:authors?)\b \s*
|
||||
([^\n]*)
|
||||
|
|
||||
=head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
|
||||
.*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
|
||||
([^\n]*)
|
||||
/ixms) {
|
||||
my $author = $1 || $2;
|
||||
$author =~ s{E<lt>}{<}g;
|
||||
$author =~ s{E<gt>}{>}g;
|
||||
$self->author($author);
|
||||
} else {
|
||||
warn "Cannot determine author info from $_[0]\n";
|
||||
}
|
||||
}
|
||||
|
||||
sub license_from {
|
||||
my $self = shift;
|
||||
if (
|
||||
Module::Install::_read($_[0]) =~ m/
|
||||
(
|
||||
=head \d \s+
|
||||
(?:licen[cs]e|licensing|copyright|legal)\b
|
||||
.*?
|
||||
)
|
||||
(=head\\d.*|=cut.*|)
|
||||
\z
|
||||
/ixms ) {
|
||||
my $license_text = $1;
|
||||
my @phrases = (
|
||||
'under the same (?:terms|license) as perl itself' => 'perl', 1,
|
||||
'GNU general public license' => 'gpl', 1,
|
||||
'GNU public license' => 'gpl', 1,
|
||||
'GNU lesser general public license' => 'lgpl', 1,
|
||||
'GNU lesser public license' => 'lgpl', 1,
|
||||
'GNU library general public license' => 'lgpl', 1,
|
||||
'GNU library public license' => 'lgpl', 1,
|
||||
'BSD license' => 'bsd', 1,
|
||||
'Artistic license' => 'artistic', 1,
|
||||
'GPL' => 'gpl', 1,
|
||||
'LGPL' => 'lgpl', 1,
|
||||
'BSD' => 'bsd', 1,
|
||||
'Artistic' => 'artistic', 1,
|
||||
'MIT' => 'mit', 1,
|
||||
'proprietary' => 'proprietary', 0,
|
||||
);
|
||||
while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
|
||||
$pattern =~ s{\s+}{\\s+}g;
|
||||
if ( $license_text =~ /\b$pattern\b/i ) {
|
||||
if ( $osi and $license_text =~ /All rights reserved/i ) {
|
||||
print "WARNING: 'All rights reserved' in copyright may invalidate Open Source license.\n";
|
||||
}
|
||||
$self->license($license);
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
warn "Cannot determine license info from $_[0]\n";
|
||||
return 'unknown';
|
||||
}
|
||||
|
||||
sub bugtracker_from {
|
||||
my $self = shift;
|
||||
my $content = Module::Install::_read($_[0]);
|
||||
my @links = $content =~ m/L\<(http\:\/\/rt\.cpan\.org\/[^>]+)\>/g;
|
||||
unless ( @links ) {
|
||||
warn "Cannot determine bugtracker info from $_[0]\n";
|
||||
return 0;
|
||||
}
|
||||
if ( @links > 1 ) {
|
||||
warn "Found more than on rt.cpan.org link in $_[0]\n";
|
||||
return 0;
|
||||
}
|
||||
|
||||
# Set the bugtracker
|
||||
bugtracker( $links[0] );
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub install_script {
|
||||
my $self = shift;
|
||||
my $args = $self->makemaker_args;
|
||||
my $exe = $args->{EXE_FILES} ||= [];
|
||||
foreach ( @_ ) {
|
||||
if ( -f $_ ) {
|
||||
push @$exe, $_;
|
||||
} elsif ( -d 'script' and -f "script/$_" ) {
|
||||
push @$exe, "script/$_";
|
||||
} else {
|
||||
die("Cannot find script '$_'");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
29
inc/Module/Install/TestBase.pm
Normal file
29
inc/Module/Install/TestBase.pm
Normal file
@@ -0,0 +1,29 @@
|
||||
#line 1
|
||||
package Module::Install::TestBase;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Module::Install::Base;
|
||||
|
||||
use vars qw($VERSION @ISA);
|
||||
BEGIN {
|
||||
$VERSION = '0.11';
|
||||
@ISA = 'Module::Install::Base';
|
||||
}
|
||||
|
||||
sub use_test_base {
|
||||
my $self = shift;
|
||||
$self->include('Test::Base');
|
||||
$self->include('Test::Base::Filter');
|
||||
$self->include('Spiffy');
|
||||
$self->include('Test::More');
|
||||
$self->include('Test::Builder');
|
||||
$self->include('Test::Builder::Module');
|
||||
$self->requires('Filter::Util::Call');
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
#line 70
|
||||
64
inc/Module/Install/Win32.pm
Normal file
64
inc/Module/Install/Win32.pm
Normal file
@@ -0,0 +1,64 @@
|
||||
#line 1
|
||||
package Module::Install::Win32;
|
||||
|
||||
use strict;
|
||||
use Module::Install::Base;
|
||||
|
||||
use vars qw{$VERSION @ISA $ISCORE};
|
||||
BEGIN {
|
||||
$VERSION = '0.77';
|
||||
@ISA = qw{Module::Install::Base};
|
||||
$ISCORE = 1;
|
||||
}
|
||||
|
||||
# determine if the user needs nmake, and download it if needed
|
||||
sub check_nmake {
|
||||
my $self = shift;
|
||||
$self->load('can_run');
|
||||
$self->load('get_file');
|
||||
|
||||
require Config;
|
||||
return unless (
|
||||
$^O eq 'MSWin32' and
|
||||
$Config::Config{make} and
|
||||
$Config::Config{make} =~ /^nmake\b/i and
|
||||
! $self->can_run('nmake')
|
||||
);
|
||||
|
||||
print "The required 'nmake' executable not found, fetching it...\n";
|
||||
|
||||
require File::Basename;
|
||||
my $rv = $self->get_file(
|
||||
url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe',
|
||||
ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe',
|
||||
local_dir => File::Basename::dirname($^X),
|
||||
size => 51928,
|
||||
run => 'Nmake15.exe /o > nul',
|
||||
check_for => 'Nmake.exe',
|
||||
remove => 1,
|
||||
);
|
||||
|
||||
die <<'END_MESSAGE' unless $rv;
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
Since you are using Microsoft Windows, you will need the 'nmake' utility
|
||||
before installation. It's available at:
|
||||
|
||||
http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe
|
||||
or
|
||||
ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe
|
||||
|
||||
Please download the file manually, save it to a directory in %PATH% (e.g.
|
||||
C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to
|
||||
that directory, and run "Nmake15.exe" from there; that will create the
|
||||
'nmake.exe' file needed by this module.
|
||||
|
||||
You may then resume the installation process described in README.
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
END_MESSAGE
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
40
inc/Module/Install/WriteAll.pm
Normal file
40
inc/Module/Install/WriteAll.pm
Normal file
@@ -0,0 +1,40 @@
|
||||
#line 1
|
||||
package Module::Install::WriteAll;
|
||||
|
||||
use strict;
|
||||
use Module::Install::Base;
|
||||
|
||||
use vars qw{$VERSION @ISA $ISCORE};
|
||||
BEGIN {
|
||||
$VERSION = '0.77';
|
||||
@ISA = qw{Module::Install::Base};
|
||||
$ISCORE = 1;
|
||||
}
|
||||
|
||||
sub WriteAll {
|
||||
my $self = shift;
|
||||
my %args = (
|
||||
meta => 1,
|
||||
sign => 0,
|
||||
inline => 0,
|
||||
check_nmake => 1,
|
||||
@_,
|
||||
);
|
||||
|
||||
$self->sign(1) if $args{sign};
|
||||
$self->Meta->write if $args{meta};
|
||||
$self->admin->WriteAll(%args) if $self->is_admin;
|
||||
|
||||
$self->check_nmake if $args{check_nmake};
|
||||
unless ( $self->makemaker_args->{PL_FILES} ) {
|
||||
$self->makemaker_args( PL_FILES => {} );
|
||||
}
|
||||
|
||||
if ( $args{inline} ) {
|
||||
$self->Inline->write;
|
||||
} else {
|
||||
$self->Makefile->write;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
539
inc/Spiffy.pm
Normal file
539
inc/Spiffy.pm
Normal file
@@ -0,0 +1,539 @@
|
||||
#line 1
|
||||
package Spiffy;
|
||||
use strict;
|
||||
use 5.006001;
|
||||
use warnings;
|
||||
use Carp;
|
||||
require Exporter;
|
||||
our $VERSION = '0.30';
|
||||
our @EXPORT = ();
|
||||
our @EXPORT_BASE = qw(field const stub super);
|
||||
our @EXPORT_OK = (@EXPORT_BASE, qw(id WWW XXX YYY ZZZ));
|
||||
our %EXPORT_TAGS = (XXX => [qw(WWW XXX YYY ZZZ)]);
|
||||
|
||||
my $stack_frame = 0;
|
||||
my $dump = 'yaml';
|
||||
my $bases_map = {};
|
||||
|
||||
sub WWW; sub XXX; sub YYY; sub ZZZ;
|
||||
|
||||
# This line is here to convince "autouse" into believing we are autousable.
|
||||
sub can {
|
||||
($_[1] eq 'import' and caller()->isa('autouse'))
|
||||
? \&Exporter::import # pacify autouse's equality test
|
||||
: $_[0]->SUPER::can($_[1]) # normal case
|
||||
}
|
||||
|
||||
# TODO
|
||||
#
|
||||
# Exported functions like field and super should be hidden so as not to
|
||||
# be confused with methods that can be inherited.
|
||||
#
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
$class = ref($class) || $class;
|
||||
my $self = bless {}, $class;
|
||||
while (@_) {
|
||||
my $method = shift;
|
||||
$self->$method(shift);
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
my $filtered_files = {};
|
||||
my $filter_dump = 0;
|
||||
my $filter_save = 0;
|
||||
our $filter_result = '';
|
||||
sub import {
|
||||
no strict 'refs';
|
||||
no warnings;
|
||||
my $self_package = shift;
|
||||
|
||||
# XXX Using parse_arguments here might cause confusion, because the
|
||||
# subclass's boolean_arguments and paired_arguments can conflict, causing
|
||||
# difficult debugging. Consider using something truly local.
|
||||
my ($args, @export_list) = do {
|
||||
local *boolean_arguments = sub {
|
||||
qw(
|
||||
-base -Base -mixin -selfless
|
||||
-XXX -dumper -yaml
|
||||
-filter_dump -filter_save
|
||||
)
|
||||
};
|
||||
local *paired_arguments = sub { qw(-package) };
|
||||
$self_package->parse_arguments(@_);
|
||||
};
|
||||
return spiffy_mixin_import(scalar(caller(0)), $self_package, @export_list)
|
||||
if $args->{-mixin};
|
||||
|
||||
$filter_dump = 1 if $args->{-filter_dump};
|
||||
$filter_save = 1 if $args->{-filter_save};
|
||||
$dump = 'yaml' if $args->{-yaml};
|
||||
$dump = 'dumper' if $args->{-dumper};
|
||||
|
||||
local @EXPORT_BASE = @EXPORT_BASE;
|
||||
|
||||
if ($args->{-XXX}) {
|
||||
push @EXPORT_BASE, @{$EXPORT_TAGS{XXX}}
|
||||
unless grep /^XXX$/, @EXPORT_BASE;
|
||||
}
|
||||
|
||||
spiffy_filter()
|
||||
if ($args->{-selfless} or $args->{-Base}) and
|
||||
not $filtered_files->{(caller($stack_frame))[1]}++;
|
||||
|
||||
my $caller_package = $args->{-package} || caller($stack_frame);
|
||||
push @{"$caller_package\::ISA"}, $self_package
|
||||
if $args->{-Base} or $args->{-base};
|
||||
|
||||
for my $class (@{all_my_bases($self_package)}) {
|
||||
next unless $class->isa('Spiffy');
|
||||
my @export = grep {
|
||||
not defined &{"$caller_package\::$_"};
|
||||
} ( @{"$class\::EXPORT"},
|
||||
($args->{-Base} or $args->{-base})
|
||||
? @{"$class\::EXPORT_BASE"} : (),
|
||||
);
|
||||
my @export_ok = grep {
|
||||
not defined &{"$caller_package\::$_"};
|
||||
} @{"$class\::EXPORT_OK"};
|
||||
|
||||
# Avoid calling the expensive Exporter::export
|
||||
# if there is nothing to do (optimization)
|
||||
my %exportable = map { ($_, 1) } @export, @export_ok;
|
||||
next unless keys %exportable;
|
||||
|
||||
my @export_save = @{"$class\::EXPORT"};
|
||||
my @export_ok_save = @{"$class\::EXPORT_OK"};
|
||||
@{"$class\::EXPORT"} = @export;
|
||||
@{"$class\::EXPORT_OK"} = @export_ok;
|
||||
my @list = grep {
|
||||
(my $v = $_) =~ s/^[\!\:]//;
|
||||
$exportable{$v} or ${"$class\::EXPORT_TAGS"}{$v};
|
||||
} @export_list;
|
||||
Exporter::export($class, $caller_package, @list);
|
||||
@{"$class\::EXPORT"} = @export_save;
|
||||
@{"$class\::EXPORT_OK"} = @export_ok_save;
|
||||
}
|
||||
}
|
||||
|
||||
sub spiffy_filter {
|
||||
require Filter::Util::Call;
|
||||
my $done = 0;
|
||||
Filter::Util::Call::filter_add(
|
||||
sub {
|
||||
return 0 if $done;
|
||||
my ($data, $end) = ('', '');
|
||||
while (my $status = Filter::Util::Call::filter_read()) {
|
||||
return $status if $status < 0;
|
||||
if (/^__(?:END|DATA)__\r?$/) {
|
||||
$end = $_;
|
||||
last;
|
||||
}
|
||||
$data .= $_;
|
||||
$_ = '';
|
||||
}
|
||||
$_ = $data;
|
||||
my @my_subs;
|
||||
s[^(sub\s+\w+\s+\{)(.*\n)]
|
||||
[${1}my \$self = shift;$2]gm;
|
||||
s[^(sub\s+\w+)\s*\(\s*\)(\s+\{.*\n)]
|
||||
[${1}${2}]gm;
|
||||
s[^my\s+sub\s+(\w+)(\s+\{)(.*)((?s:.*?\n))\}\n]
|
||||
[push @my_subs, $1; "\$$1 = sub$2my \$self = shift;$3$4\};\n"]gem;
|
||||
my $preclare = '';
|
||||
if (@my_subs) {
|
||||
$preclare = join ',', map "\$$_", @my_subs;
|
||||
$preclare = "my($preclare);";
|
||||
}
|
||||
$_ = "use strict;use warnings;$preclare${_};1;\n$end";
|
||||
if ($filter_dump) { print; exit }
|
||||
if ($filter_save) { $filter_result = $_; $_ = $filter_result; }
|
||||
$done = 1;
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
sub base {
|
||||
push @_, -base;
|
||||
goto &import;
|
||||
}
|
||||
|
||||
sub all_my_bases {
|
||||
my $class = shift;
|
||||
|
||||
return $bases_map->{$class}
|
||||
if defined $bases_map->{$class};
|
||||
|
||||
my @bases = ($class);
|
||||
no strict 'refs';
|
||||
for my $base_class (@{"${class}::ISA"}) {
|
||||
push @bases, @{all_my_bases($base_class)};
|
||||
}
|
||||
my $used = {};
|
||||
$bases_map->{$class} = [grep {not $used->{$_}++} @bases];
|
||||
}
|
||||
|
||||
my %code = (
|
||||
sub_start =>
|
||||
"sub {\n",
|
||||
set_default =>
|
||||
" \$_[0]->{%s} = %s\n unless exists \$_[0]->{%s};\n",
|
||||
init =>
|
||||
" return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" .
|
||||
" unless \$#_ > 0 or defined \$_[0]->{%s};\n",
|
||||
weak_init =>
|
||||
" return do {\n" .
|
||||
" \$_[0]->{%s} = do { my \$self = \$_[0]; %s };\n" .
|
||||
" Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n" .
|
||||
" \$_[0]->{%s};\n" .
|
||||
" } unless \$#_ > 0 or defined \$_[0]->{%s};\n",
|
||||
return_if_get =>
|
||||
" return \$_[0]->{%s} unless \$#_ > 0;\n",
|
||||
set =>
|
||||
" \$_[0]->{%s} = \$_[1];\n",
|
||||
weaken =>
|
||||
" Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n",
|
||||
sub_end =>
|
||||
" return \$_[0]->{%s};\n}\n",
|
||||
);
|
||||
|
||||
sub field {
|
||||
my $package = caller;
|
||||
my ($args, @values) = do {
|
||||
no warnings;
|
||||
local *boolean_arguments = sub { (qw(-weak)) };
|
||||
local *paired_arguments = sub { (qw(-package -init)) };
|
||||
Spiffy->parse_arguments(@_);
|
||||
};
|
||||
my ($field, $default) = @values;
|
||||
$package = $args->{-package} if defined $args->{-package};
|
||||
die "Cannot have a default for a weakened field ($field)"
|
||||
if defined $default && $args->{-weak};
|
||||
return if defined &{"${package}::$field"};
|
||||
require Scalar::Util if $args->{-weak};
|
||||
my $default_string =
|
||||
( ref($default) eq 'ARRAY' and not @$default )
|
||||
? '[]'
|
||||
: (ref($default) eq 'HASH' and not keys %$default )
|
||||
? '{}'
|
||||
: default_as_code($default);
|
||||
|
||||
my $code = $code{sub_start};
|
||||
if ($args->{-init}) {
|
||||
my $fragment = $args->{-weak} ? $code{weak_init} : $code{init};
|
||||
$code .= sprintf $fragment, $field, $args->{-init}, ($field) x 4;
|
||||
}
|
||||
$code .= sprintf $code{set_default}, $field, $default_string, $field
|
||||
if defined $default;
|
||||
$code .= sprintf $code{return_if_get}, $field;
|
||||
$code .= sprintf $code{set}, $field;
|
||||
$code .= sprintf $code{weaken}, $field, $field
|
||||
if $args->{-weak};
|
||||
$code .= sprintf $code{sub_end}, $field;
|
||||
|
||||
my $sub = eval $code;
|
||||
die $@ if $@;
|
||||
no strict 'refs';
|
||||
*{"${package}::$field"} = $sub;
|
||||
return $code if defined wantarray;
|
||||
}
|
||||
|
||||
sub default_as_code {
|
||||
require Data::Dumper;
|
||||
local $Data::Dumper::Sortkeys = 1;
|
||||
my $code = Data::Dumper::Dumper(shift);
|
||||
$code =~ s/^\$VAR1 = //;
|
||||
$code =~ s/;$//;
|
||||
return $code;
|
||||
}
|
||||
|
||||
sub const {
|
||||
my $package = caller;
|
||||
my ($args, @values) = do {
|
||||
no warnings;
|
||||
local *paired_arguments = sub { (qw(-package)) };
|
||||
Spiffy->parse_arguments(@_);
|
||||
};
|
||||
my ($field, $default) = @values;
|
||||
$package = $args->{-package} if defined $args->{-package};
|
||||
no strict 'refs';
|
||||
return if defined &{"${package}::$field"};
|
||||
*{"${package}::$field"} = sub { $default }
|
||||
}
|
||||
|
||||
sub stub {
|
||||
my $package = caller;
|
||||
my ($args, @values) = do {
|
||||
no warnings;
|
||||
local *paired_arguments = sub { (qw(-package)) };
|
||||
Spiffy->parse_arguments(@_);
|
||||
};
|
||||
my ($field, $default) = @values;
|
||||
$package = $args->{-package} if defined $args->{-package};
|
||||
no strict 'refs';
|
||||
return if defined &{"${package}::$field"};
|
||||
*{"${package}::$field"} =
|
||||
sub {
|
||||
require Carp;
|
||||
Carp::confess
|
||||
"Method $field in package $package must be subclassed";
|
||||
}
|
||||
}
|
||||
|
||||
sub parse_arguments {
|
||||
my $class = shift;
|
||||
my ($args, @values) = ({}, ());
|
||||
my %booleans = map { ($_, 1) } $class->boolean_arguments;
|
||||
my %pairs = map { ($_, 1) } $class->paired_arguments;
|
||||
while (@_) {
|
||||
my $elem = shift;
|
||||
if (defined $elem and defined $booleans{$elem}) {
|
||||
$args->{$elem} = (@_ and $_[0] =~ /^[01]$/)
|
||||
? shift
|
||||
: 1;
|
||||
}
|
||||
elsif (defined $elem and defined $pairs{$elem} and @_) {
|
||||
$args->{$elem} = shift;
|
||||
}
|
||||
else {
|
||||
push @values, $elem;
|
||||
}
|
||||
}
|
||||
return wantarray ? ($args, @values) : $args;
|
||||
}
|
||||
|
||||
sub boolean_arguments { () }
|
||||
sub paired_arguments { () }
|
||||
|
||||
# get a unique id for any node
|
||||
sub id {
|
||||
if (not ref $_[0]) {
|
||||
return 'undef' if not defined $_[0];
|
||||
\$_[0] =~ /\((\w+)\)$/o or die;
|
||||
return "$1-S";
|
||||
}
|
||||
require overload;
|
||||
overload::StrVal($_[0]) =~ /\((\w+)\)$/o or die;
|
||||
return $1;
|
||||
}
|
||||
|
||||
#===============================================================================
|
||||
# It's super, man.
|
||||
#===============================================================================
|
||||
package DB;
|
||||
{
|
||||
no warnings 'redefine';
|
||||
sub super_args {
|
||||
my @dummy = caller(@_ ? $_[0] : 2);
|
||||
return @DB::args;
|
||||
}
|
||||
}
|
||||
|
||||
package Spiffy;
|
||||
sub super {
|
||||
my $method;
|
||||
my $frame = 1;
|
||||
while ($method = (caller($frame++))[3]) {
|
||||
$method =~ s/.*::// and last;
|
||||
}
|
||||
my @args = DB::super_args($frame);
|
||||
@_ = @_ ? ($args[0], @_) : @args;
|
||||
my $class = ref $_[0] ? ref $_[0] : $_[0];
|
||||
my $caller_class = caller;
|
||||
my $seen = 0;
|
||||
my @super_classes = reverse grep {
|
||||
($seen or $seen = ($_ eq $caller_class)) ? 0 : 1;
|
||||
} reverse @{all_my_bases($class)};
|
||||
for my $super_class (@super_classes) {
|
||||
no strict 'refs';
|
||||
next if $super_class eq $class;
|
||||
if (defined &{"${super_class}::$method"}) {
|
||||
${"$super_class\::AUTOLOAD"} = ${"$class\::AUTOLOAD"}
|
||||
if $method eq 'AUTOLOAD';
|
||||
return &{"${super_class}::$method"};
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
#===============================================================================
|
||||
# This code deserves a spanking, because it is being very naughty.
|
||||
# It is exchanging base.pm's import() for its own, so that people
|
||||
# can use base.pm with Spiffy modules, without being the wiser.
|
||||
#===============================================================================
|
||||
my $real_base_import;
|
||||
my $real_mixin_import;
|
||||
|
||||
BEGIN {
|
||||
require base unless defined $INC{'base.pm'};
|
||||
$INC{'mixin.pm'} ||= 'Spiffy/mixin.pm';
|
||||
$real_base_import = \&base::import;
|
||||
$real_mixin_import = \&mixin::import;
|
||||
no warnings;
|
||||
*base::import = \&spiffy_base_import;
|
||||
*mixin::import = \&spiffy_mixin_import;
|
||||
}
|
||||
|
||||
# my $i = 0;
|
||||
# while (my $caller = caller($i++)) {
|
||||
# next unless $caller eq 'base' or $caller eq 'mixin';
|
||||
# croak <<END;
|
||||
# Spiffy.pm must be loaded before calling 'use base' or 'use mixin' with a
|
||||
# Spiffy module. See the documentation of Spiffy.pm for details.
|
||||
# END
|
||||
# }
|
||||
|
||||
sub spiffy_base_import {
|
||||
my @base_classes = @_;
|
||||
shift @base_classes;
|
||||
no strict 'refs';
|
||||
goto &$real_base_import
|
||||
unless grep {
|
||||
eval "require $_" unless %{"$_\::"};
|
||||
$_->isa('Spiffy');
|
||||
} @base_classes;
|
||||
my $inheritor = caller(0);
|
||||
for my $base_class (@base_classes) {
|
||||
next if $inheritor->isa($base_class);
|
||||
croak "Can't mix Spiffy and non-Spiffy classes in 'use base'.\n",
|
||||
"See the documentation of Spiffy.pm for details\n "
|
||||
unless $base_class->isa('Spiffy');
|
||||
$stack_frame = 1; # tell import to use different caller
|
||||
import($base_class, '-base');
|
||||
$stack_frame = 0;
|
||||
}
|
||||
}
|
||||
|
||||
sub mixin {
|
||||
my $self = shift;
|
||||
my $target_class = ref($self);
|
||||
spiffy_mixin_import($target_class, @_)
|
||||
}
|
||||
|
||||
sub spiffy_mixin_import {
|
||||
my $target_class = shift;
|
||||
$target_class = caller(0)
|
||||
if $target_class eq 'mixin';
|
||||
my $mixin_class = shift
|
||||
or die "Nothing to mixin";
|
||||
eval "require $mixin_class";
|
||||
my @roles = @_;
|
||||
my $pseudo_class = join '-', $target_class, $mixin_class, @roles;
|
||||
my %methods = spiffy_mixin_methods($mixin_class, @roles);
|
||||
no strict 'refs';
|
||||
no warnings;
|
||||
@{"$pseudo_class\::ISA"} = @{"$target_class\::ISA"};
|
||||
@{"$target_class\::ISA"} = ($pseudo_class);
|
||||
for (keys %methods) {
|
||||
*{"$pseudo_class\::$_"} = $methods{$_};
|
||||
}
|
||||
}
|
||||
|
||||
sub spiffy_mixin_methods {
|
||||
my $mixin_class = shift;
|
||||
no strict 'refs';
|
||||
my %methods = spiffy_all_methods($mixin_class);
|
||||
map {
|
||||
$methods{$_}
|
||||
? ($_, \ &{"$methods{$_}\::$_"})
|
||||
: ($_, \ &{"$mixin_class\::$_"})
|
||||
} @_
|
||||
? (get_roles($mixin_class, @_))
|
||||
: (keys %methods);
|
||||
}
|
||||
|
||||
sub get_roles {
|
||||
my $mixin_class = shift;
|
||||
my @roles = @_;
|
||||
while (grep /^!*:/, @roles) {
|
||||
@roles = map {
|
||||
s/!!//g;
|
||||
/^!:(.*)/ ? do {
|
||||
my $m = "_role_$1";
|
||||
map("!$_", $mixin_class->$m);
|
||||
} :
|
||||
/^:(.*)/ ? do {
|
||||
my $m = "_role_$1";
|
||||
($mixin_class->$m);
|
||||
} :
|
||||
($_)
|
||||
} @roles;
|
||||
}
|
||||
if (@roles and $roles[0] =~ /^!/) {
|
||||
my %methods = spiffy_all_methods($mixin_class);
|
||||
unshift @roles, keys(%methods);
|
||||
}
|
||||
my %roles;
|
||||
for (@roles) {
|
||||
s/!!//g;
|
||||
delete $roles{$1}, next
|
||||
if /^!(.*)/;
|
||||
$roles{$_} = 1;
|
||||
}
|
||||
keys %roles;
|
||||
}
|
||||
|
||||
sub spiffy_all_methods {
|
||||
no strict 'refs';
|
||||
my $class = shift;
|
||||
return if $class eq 'Spiffy';
|
||||
my %methods = map {
|
||||
($_, $class)
|
||||
} grep {
|
||||
defined &{"$class\::$_"} and not /^_/
|
||||
} keys %{"$class\::"};
|
||||
my %super_methods;
|
||||
%super_methods = spiffy_all_methods(${"$class\::ISA"}[0])
|
||||
if @{"$class\::ISA"};
|
||||
%{{%super_methods, %methods}};
|
||||
}
|
||||
|
||||
|
||||
# END of naughty code.
|
||||
#===============================================================================
|
||||
# Debugging support
|
||||
#===============================================================================
|
||||
sub spiffy_dump {
|
||||
no warnings;
|
||||
if ($dump eq 'dumper') {
|
||||
require Data::Dumper;
|
||||
$Data::Dumper::Sortkeys = 1;
|
||||
$Data::Dumper::Indent = 1;
|
||||
return Data::Dumper::Dumper(@_);
|
||||
}
|
||||
require YAML;
|
||||
$YAML::UseVersion = 0;
|
||||
return YAML::Dump(@_) . "...\n";
|
||||
}
|
||||
|
||||
sub at_line_number {
|
||||
my ($file_path, $line_number) = (caller(1))[1,2];
|
||||
" at $file_path line $line_number\n";
|
||||
}
|
||||
|
||||
sub WWW {
|
||||
warn spiffy_dump(@_) . at_line_number;
|
||||
return wantarray ? @_ : $_[0];
|
||||
}
|
||||
|
||||
sub XXX {
|
||||
die spiffy_dump(@_) . at_line_number;
|
||||
}
|
||||
|
||||
sub YYY {
|
||||
print spiffy_dump(@_) . at_line_number;
|
||||
return wantarray ? @_ : $_[0];
|
||||
}
|
||||
|
||||
sub ZZZ {
|
||||
require Carp;
|
||||
Carp::confess spiffy_dump(@_);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
#line 1066
|
||||
653
inc/Test/Base.pm
Normal file
653
inc/Test/Base.pm
Normal file
@@ -0,0 +1,653 @@
|
||||
#line 1
|
||||
# TODO:
|
||||
#
|
||||
package Test::Base;
|
||||
use 5.006001;
|
||||
use Spiffy 0.30 -Base;
|
||||
use Spiffy ':XXX';
|
||||
our $VERSION = '0.55';
|
||||
|
||||
my @test_more_exports;
|
||||
BEGIN {
|
||||
@test_more_exports = qw(
|
||||
ok isnt like unlike is_deeply cmp_ok
|
||||
skip todo_skip pass fail
|
||||
eq_array eq_hash eq_set
|
||||
plan can_ok isa_ok diag
|
||||
use_ok
|
||||
$TODO
|
||||
);
|
||||
}
|
||||
|
||||
use Test::More import => \@test_more_exports;
|
||||
use Carp;
|
||||
|
||||
our @EXPORT = (@test_more_exports, qw(
|
||||
is no_diff
|
||||
|
||||
blocks next_block first_block
|
||||
delimiters spec_file spec_string
|
||||
filters filters_delay filter_arguments
|
||||
run run_compare run_is run_is_deeply run_like run_unlike
|
||||
WWW XXX YYY ZZZ
|
||||
tie_output no_diag_on_only
|
||||
|
||||
find_my_self default_object
|
||||
|
||||
croak carp cluck confess
|
||||
));
|
||||
|
||||
field '_spec_file';
|
||||
field '_spec_string';
|
||||
field _filters => [qw(norm trim)];
|
||||
field _filters_map => {};
|
||||
field spec =>
|
||||
-init => '$self->_spec_init';
|
||||
field block_list =>
|
||||
-init => '$self->_block_list_init';
|
||||
field _next_list => [];
|
||||
field block_delim =>
|
||||
-init => '$self->block_delim_default';
|
||||
field data_delim =>
|
||||
-init => '$self->data_delim_default';
|
||||
field _filters_delay => 0;
|
||||
field _no_diag_on_only => 0;
|
||||
|
||||
field block_delim_default => '===';
|
||||
field data_delim_default => '---';
|
||||
|
||||
my $default_class;
|
||||
my $default_object;
|
||||
my $reserved_section_names = {};
|
||||
|
||||
sub default_object {
|
||||
$default_object ||= $default_class->new;
|
||||
return $default_object;
|
||||
}
|
||||
|
||||
my $import_called = 0;
|
||||
sub import() {
|
||||
$import_called = 1;
|
||||
my $class = (grep /^-base$/i, @_)
|
||||
? scalar(caller)
|
||||
: $_[0];
|
||||
if (not defined $default_class) {
|
||||
$default_class = $class;
|
||||
}
|
||||
# else {
|
||||
# croak "Can't use $class after using $default_class"
|
||||
# unless $default_class->isa($class);
|
||||
# }
|
||||
|
||||
unless (grep /^-base$/i, @_) {
|
||||
my @args;
|
||||
for (my $ii = 1; $ii <= $#_; ++$ii) {
|
||||
if ($_[$ii] eq '-package') {
|
||||
++$ii;
|
||||
} else {
|
||||
push @args, $_[$ii];
|
||||
}
|
||||
}
|
||||
Test::More->import(import => \@test_more_exports, @args)
|
||||
if @args;
|
||||
}
|
||||
|
||||
_strict_warnings();
|
||||
goto &Spiffy::import;
|
||||
}
|
||||
|
||||
# Wrap Test::Builder::plan
|
||||
my $plan_code = \&Test::Builder::plan;
|
||||
my $Have_Plan = 0;
|
||||
{
|
||||
no warnings 'redefine';
|
||||
*Test::Builder::plan = sub {
|
||||
$Have_Plan = 1;
|
||||
goto &$plan_code;
|
||||
};
|
||||
}
|
||||
|
||||
my $DIED = 0;
|
||||
$SIG{__DIE__} = sub { $DIED = 1; die @_ };
|
||||
|
||||
sub block_class { $self->find_class('Block') }
|
||||
sub filter_class { $self->find_class('Filter') }
|
||||
|
||||
sub find_class {
|
||||
my $suffix = shift;
|
||||
my $class = ref($self) . "::$suffix";
|
||||
return $class if $class->can('new');
|
||||
$class = __PACKAGE__ . "::$suffix";
|
||||
return $class if $class->can('new');
|
||||
eval "require $class";
|
||||
return $class if $class->can('new');
|
||||
die "Can't find a class for $suffix";
|
||||
}
|
||||
|
||||
sub check_late {
|
||||
if ($self->{block_list}) {
|
||||
my $caller = (caller(1))[3];
|
||||
$caller =~ s/.*:://;
|
||||
croak "Too late to call $caller()"
|
||||
}
|
||||
}
|
||||
|
||||
sub find_my_self() {
|
||||
my $self = ref($_[0]) eq $default_class
|
||||
? splice(@_, 0, 1)
|
||||
: default_object();
|
||||
return $self, @_;
|
||||
}
|
||||
|
||||
sub blocks() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
|
||||
croak "Invalid arguments passed to 'blocks'"
|
||||
if @_ > 1;
|
||||
croak sprintf("'%s' is invalid argument to blocks()", shift(@_))
|
||||
if @_ && $_[0] !~ /^[a-zA-Z]\w*$/;
|
||||
|
||||
my $blocks = $self->block_list;
|
||||
|
||||
my $section_name = shift || '';
|
||||
my @blocks = $section_name
|
||||
? (grep { exists $_->{$section_name} } @$blocks)
|
||||
: (@$blocks);
|
||||
|
||||
return scalar(@blocks) unless wantarray;
|
||||
|
||||
return (@blocks) if $self->_filters_delay;
|
||||
|
||||
for my $block (@blocks) {
|
||||
$block->run_filters
|
||||
unless $block->is_filtered;
|
||||
}
|
||||
|
||||
return (@blocks);
|
||||
}
|
||||
|
||||
sub next_block() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
my $list = $self->_next_list;
|
||||
if (@$list == 0) {
|
||||
$list = [@{$self->block_list}, undef];
|
||||
$self->_next_list($list);
|
||||
}
|
||||
my $block = shift @$list;
|
||||
if (defined $block and not $block->is_filtered) {
|
||||
$block->run_filters;
|
||||
}
|
||||
return $block;
|
||||
}
|
||||
|
||||
sub first_block() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
$self->_next_list([]);
|
||||
$self->next_block;
|
||||
}
|
||||
|
||||
sub filters_delay() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
$self->_filters_delay(defined $_[0] ? shift : 1);
|
||||
}
|
||||
|
||||
sub no_diag_on_only() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
$self->_no_diag_on_only(defined $_[0] ? shift : 1);
|
||||
}
|
||||
|
||||
sub delimiters() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
$self->check_late;
|
||||
my ($block_delimiter, $data_delimiter) = @_;
|
||||
$block_delimiter ||= $self->block_delim_default;
|
||||
$data_delimiter ||= $self->data_delim_default;
|
||||
$self->block_delim($block_delimiter);
|
||||
$self->data_delim($data_delimiter);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub spec_file() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
$self->check_late;
|
||||
$self->_spec_file(shift);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub spec_string() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
$self->check_late;
|
||||
$self->_spec_string(shift);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub filters() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
if (ref($_[0]) eq 'HASH') {
|
||||
$self->_filters_map(shift);
|
||||
}
|
||||
else {
|
||||
my $filters = $self->_filters;
|
||||
push @$filters, @_;
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub filter_arguments() {
|
||||
$Test::Base::Filter::arguments;
|
||||
}
|
||||
|
||||
sub have_text_diff {
|
||||
eval { require Text::Diff; 1 } &&
|
||||
$Text::Diff::VERSION >= 0.35 &&
|
||||
$Algorithm::Diff::VERSION >= 1.15;
|
||||
}
|
||||
|
||||
sub is($$;$) {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
my ($actual, $expected, $name) = @_;
|
||||
local $Test::Builder::Level = $Test::Builder::Level + 1;
|
||||
if ($ENV{TEST_SHOW_NO_DIFFS} or
|
||||
not defined $actual or
|
||||
not defined $expected or
|
||||
$actual eq $expected or
|
||||
not($self->have_text_diff) or
|
||||
$expected !~ /\n./s
|
||||
) {
|
||||
Test::More::is($actual, $expected, $name);
|
||||
}
|
||||
else {
|
||||
$name = '' unless defined $name;
|
||||
ok $actual eq $expected,
|
||||
$name . "\n" . Text::Diff::diff(\$expected, \$actual);
|
||||
}
|
||||
}
|
||||
|
||||
sub run(&;$) {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
my $callback = shift;
|
||||
for my $block (@{$self->block_list}) {
|
||||
$block->run_filters unless $block->is_filtered;
|
||||
&{$callback}($block);
|
||||
}
|
||||
}
|
||||
|
||||
my $name_error = "Can't determine section names";
|
||||
sub _section_names {
|
||||
return @_ if @_ == 2;
|
||||
my $block = $self->first_block
|
||||
or croak $name_error;
|
||||
my @names = grep {
|
||||
$_ !~ /^(ONLY|LAST|SKIP)$/;
|
||||
} @{$block->{_section_order}[0] || []};
|
||||
croak "$name_error. Need two sections in first block"
|
||||
unless @names == 2;
|
||||
return @names;
|
||||
}
|
||||
|
||||
sub _assert_plan {
|
||||
plan('no_plan') unless $Have_Plan;
|
||||
}
|
||||
|
||||
sub END {
|
||||
run_compare() unless $Have_Plan or $DIED or not $import_called;
|
||||
}
|
||||
|
||||
sub run_compare() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
$self->_assert_plan;
|
||||
my ($x, $y) = $self->_section_names(@_);
|
||||
local $Test::Builder::Level = $Test::Builder::Level + 1;
|
||||
for my $block (@{$self->block_list}) {
|
||||
next unless exists($block->{$x}) and exists($block->{$y});
|
||||
$block->run_filters unless $block->is_filtered;
|
||||
if (ref $block->$x) {
|
||||
is_deeply($block->$x, $block->$y,
|
||||
$block->name ? $block->name : ());
|
||||
}
|
||||
elsif (ref $block->$y eq 'Regexp') {
|
||||
my $regexp = ref $y ? $y : $block->$y;
|
||||
like($block->$x, $regexp, $block->name ? $block->name : ());
|
||||
}
|
||||
else {
|
||||
is($block->$x, $block->$y, $block->name ? $block->name : ());
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub run_is() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
$self->_assert_plan;
|
||||
my ($x, $y) = $self->_section_names(@_);
|
||||
local $Test::Builder::Level = $Test::Builder::Level + 1;
|
||||
for my $block (@{$self->block_list}) {
|
||||
next unless exists($block->{$x}) and exists($block->{$y});
|
||||
$block->run_filters unless $block->is_filtered;
|
||||
is($block->$x, $block->$y,
|
||||
$block->name ? $block->name : ()
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
sub run_is_deeply() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
$self->_assert_plan;
|
||||
my ($x, $y) = $self->_section_names(@_);
|
||||
for my $block (@{$self->block_list}) {
|
||||
next unless exists($block->{$x}) and exists($block->{$y});
|
||||
$block->run_filters unless $block->is_filtered;
|
||||
is_deeply($block->$x, $block->$y,
|
||||
$block->name ? $block->name : ()
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
sub run_like() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
$self->_assert_plan;
|
||||
my ($x, $y) = $self->_section_names(@_);
|
||||
for my $block (@{$self->block_list}) {
|
||||
next unless exists($block->{$x}) and defined($y);
|
||||
$block->run_filters unless $block->is_filtered;
|
||||
my $regexp = ref $y ? $y : $block->$y;
|
||||
like($block->$x, $regexp,
|
||||
$block->name ? $block->name : ()
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
sub run_unlike() {
|
||||
(my ($self), @_) = find_my_self(@_);
|
||||
$self->_assert_plan;
|
||||
my ($x, $y) = $self->_section_names(@_);
|
||||
for my $block (@{$self->block_list}) {
|
||||
next unless exists($block->{$x}) and defined($y);
|
||||
$block->run_filters unless $block->is_filtered;
|
||||
my $regexp = ref $y ? $y : $block->$y;
|
||||
unlike($block->$x, $regexp,
|
||||
$block->name ? $block->name : ()
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
sub _pre_eval {
|
||||
my $spec = shift;
|
||||
return $spec unless $spec =~
|
||||
s/\A\s*<<<(.*?)>>>\s*$//sm;
|
||||
my $eval_code = $1;
|
||||
eval "package main; $eval_code";
|
||||
croak $@ if $@;
|
||||
return $spec;
|
||||
}
|
||||
|
||||
sub _block_list_init {
|
||||
my $spec = $self->spec;
|
||||
$spec = $self->_pre_eval($spec);
|
||||
my $cd = $self->block_delim;
|
||||
my @hunks = ($spec =~ /^(\Q${cd}\E.*?(?=^\Q${cd}\E|\z))/msg);
|
||||
my $blocks = $self->_choose_blocks(@hunks);
|
||||
$self->block_list($blocks); # Need to set early for possible filter use
|
||||
my $seq = 1;
|
||||
for my $block (@$blocks) {
|
||||
$block->blocks_object($self);
|
||||
$block->seq_num($seq++);
|
||||
}
|
||||
return $blocks;
|
||||
}
|
||||
|
||||
sub _choose_blocks {
|
||||
my $blocks = [];
|
||||
for my $hunk (@_) {
|
||||
my $block = $self->_make_block($hunk);
|
||||
if (exists $block->{ONLY}) {
|
||||
diag "I found ONLY: maybe you're debugging?"
|
||||
unless $self->_no_diag_on_only;
|
||||
return [$block];
|
||||
}
|
||||
next if exists $block->{SKIP};
|
||||
push @$blocks, $block;
|
||||
if (exists $block->{LAST}) {
|
||||
return $blocks;
|
||||
}
|
||||
}
|
||||
return $blocks;
|
||||
}
|
||||
|
||||
sub _check_reserved {
|
||||
my $id = shift;
|
||||
croak "'$id' is a reserved name. Use something else.\n"
|
||||
if $reserved_section_names->{$id} or
|
||||
$id =~ /^_/;
|
||||
}
|
||||
|
||||
sub _make_block {
|
||||
my $hunk = shift;
|
||||
my $cd = $self->block_delim;
|
||||
my $dd = $self->data_delim;
|
||||
my $block = $self->block_class->new;
|
||||
$hunk =~ s/\A\Q${cd}\E[ \t]*(.*)\s+// or die;
|
||||
my $name = $1;
|
||||
my @parts = split /^\Q${dd}\E +\(?(\w+)\)? *(.*)?\n/m, $hunk;
|
||||
my $description = shift @parts;
|
||||
$description ||= '';
|
||||
unless ($description =~ /\S/) {
|
||||
$description = $name;
|
||||
}
|
||||
$description =~ s/\s*\z//;
|
||||
$block->set_value(description => $description);
|
||||
|
||||
my $section_map = {};
|
||||
my $section_order = [];
|
||||
while (@parts) {
|
||||
my ($type, $filters, $value) = splice(@parts, 0, 3);
|
||||
$self->_check_reserved($type);
|
||||
$value = '' unless defined $value;
|
||||
$filters = '' unless defined $filters;
|
||||
if ($filters =~ /:(\s|\z)/) {
|
||||
croak "Extra lines not allowed in '$type' section"
|
||||
if $value =~ /\S/;
|
||||
($filters, $value) = split /\s*:(?:\s+|\z)/, $filters, 2;
|
||||
$value = '' unless defined $value;
|
||||
$value =~ s/^\s*(.*?)\s*$/$1/;
|
||||
}
|
||||
$section_map->{$type} = {
|
||||
filters => $filters,
|
||||
};
|
||||
push @$section_order, $type;
|
||||
$block->set_value($type, $value);
|
||||
}
|
||||
$block->set_value(name => $name);
|
||||
$block->set_value(_section_map => $section_map);
|
||||
$block->set_value(_section_order => $section_order);
|
||||
return $block;
|
||||
}
|
||||
|
||||
sub _spec_init {
|
||||
return $self->_spec_string
|
||||
if $self->_spec_string;
|
||||
local $/;
|
||||
my $spec;
|
||||
if (my $spec_file = $self->_spec_file) {
|
||||
open FILE, $spec_file or die $!;
|
||||
$spec = <FILE>;
|
||||
close FILE;
|
||||
}
|
||||
else {
|
||||
$spec = do {
|
||||
package main;
|
||||
no warnings 'once';
|
||||
<DATA>;
|
||||
};
|
||||
}
|
||||
return $spec;
|
||||
}
|
||||
|
||||
sub _strict_warnings() {
|
||||
require Filter::Util::Call;
|
||||
my $done = 0;
|
||||
Filter::Util::Call::filter_add(
|
||||
sub {
|
||||
return 0 if $done;
|
||||
my ($data, $end) = ('', '');
|
||||
while (my $status = Filter::Util::Call::filter_read()) {
|
||||
return $status if $status < 0;
|
||||
if (/^__(?:END|DATA)__\r?$/) {
|
||||
$end = $_;
|
||||
last;
|
||||
}
|
||||
$data .= $_;
|
||||
$_ = '';
|
||||
}
|
||||
$_ = "use strict;use warnings;$data$end";
|
||||
$done = 1;
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
sub tie_output() {
|
||||
my $handle = shift;
|
||||
die "No buffer to tie" unless @_;
|
||||
tie $handle, 'Test::Base::Handle', $_[0];
|
||||
}
|
||||
|
||||
sub no_diff {
|
||||
$ENV{TEST_SHOW_NO_DIFFS} = 1;
|
||||
}
|
||||
|
||||
package Test::Base::Handle;
|
||||
|
||||
sub TIEHANDLE() {
|
||||
my $class = shift;
|
||||
bless \ $_[0], $class;
|
||||
}
|
||||
|
||||
sub PRINT {
|
||||
$$self .= $_ for @_;
|
||||
}
|
||||
|
||||
#===============================================================================
|
||||
# Test::Base::Block
|
||||
#
|
||||
# This is the default class for accessing a Test::Base block object.
|
||||
#===============================================================================
|
||||
package Test::Base::Block;
|
||||
our @ISA = qw(Spiffy);
|
||||
|
||||
our @EXPORT = qw(block_accessor);
|
||||
|
||||
sub AUTOLOAD {
|
||||
return;
|
||||
}
|
||||
|
||||
sub block_accessor() {
|
||||
my $accessor = shift;
|
||||
no strict 'refs';
|
||||
return if defined &$accessor;
|
||||
*$accessor = sub {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
Carp::croak "Not allowed to set values for '$accessor'";
|
||||
}
|
||||
my @list = @{$self->{$accessor} || []};
|
||||
return wantarray
|
||||
? (@list)
|
||||
: $list[0];
|
||||
};
|
||||
}
|
||||
|
||||
block_accessor 'name';
|
||||
block_accessor 'description';
|
||||
Spiffy::field 'seq_num';
|
||||
Spiffy::field 'is_filtered';
|
||||
Spiffy::field 'blocks_object';
|
||||
Spiffy::field 'original_values' => {};
|
||||
|
||||
sub set_value {
|
||||
no strict 'refs';
|
||||
my $accessor = shift;
|
||||
block_accessor $accessor
|
||||
unless defined &$accessor;
|
||||
$self->{$accessor} = [@_];
|
||||
}
|
||||
|
||||
sub run_filters {
|
||||
my $map = $self->_section_map;
|
||||
my $order = $self->_section_order;
|
||||
Carp::croak "Attempt to filter a block twice"
|
||||
if $self->is_filtered;
|
||||
for my $type (@$order) {
|
||||
my $filters = $map->{$type}{filters};
|
||||
my @value = $self->$type;
|
||||
$self->original_values->{$type} = $value[0];
|
||||
for my $filter ($self->_get_filters($type, $filters)) {
|
||||
$Test::Base::Filter::arguments =
|
||||
$filter =~ s/=(.*)$// ? $1 : undef;
|
||||
my $function = "main::$filter";
|
||||
no strict 'refs';
|
||||
if (defined &$function) {
|
||||
local $_ = join '', @value;
|
||||
my $old = $_;
|
||||
@value = &$function(@value);
|
||||
if (not(@value) or
|
||||
@value == 1 and $value[0] =~ /\A(\d+|)\z/
|
||||
) {
|
||||
if ($value[0] && $_ eq $old) {
|
||||
Test::Base::diag("Filters returning numbers are supposed to do munging \$_: your filter '$function' apparently doesn't.");
|
||||
}
|
||||
@value = ($_);
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $filter_object = $self->blocks_object->filter_class->new;
|
||||
die "Can't find a function or method for '$filter' filter\n"
|
||||
unless $filter_object->can($filter);
|
||||
$filter_object->current_block($self);
|
||||
@value = $filter_object->$filter(@value);
|
||||
}
|
||||
# Set the value after each filter since other filters may be
|
||||
# introspecting.
|
||||
$self->set_value($type, @value);
|
||||
}
|
||||
}
|
||||
$self->is_filtered(1);
|
||||
}
|
||||
|
||||
sub _get_filters {
|
||||
my $type = shift;
|
||||
my $string = shift || '';
|
||||
$string =~ s/\s*(.*?)\s*/$1/;
|
||||
my @filters = ();
|
||||
my $map_filters = $self->blocks_object->_filters_map->{$type} || [];
|
||||
$map_filters = [ $map_filters ] unless ref $map_filters;
|
||||
my @append = ();
|
||||
for (
|
||||
@{$self->blocks_object->_filters},
|
||||
@$map_filters,
|
||||
split(/\s+/, $string),
|
||||
) {
|
||||
my $filter = $_;
|
||||
last unless length $filter;
|
||||
if ($filter =~ s/^-//) {
|
||||
@filters = grep { $_ ne $filter } @filters;
|
||||
}
|
||||
elsif ($filter =~ s/^\+//) {
|
||||
push @append, $filter;
|
||||
}
|
||||
else {
|
||||
push @filters, $filter;
|
||||
}
|
||||
}
|
||||
return @filters, @append;
|
||||
}
|
||||
|
||||
{
|
||||
%$reserved_section_names = map {
|
||||
($_, 1);
|
||||
} keys(%Test::Base::Block::), qw( new DESTROY );
|
||||
}
|
||||
|
||||
__DATA__
|
||||
|
||||
=encoding utf8
|
||||
|
||||
#line 1330
|
||||
344
inc/Test/Base/Filter.pm
Normal file
344
inc/Test/Base/Filter.pm
Normal file
@@ -0,0 +1,344 @@
|
||||
#line 1
|
||||
#. TODO:
|
||||
#.
|
||||
|
||||
#===============================================================================
|
||||
# This is the default class for handling Test::Base data filtering.
|
||||
#===============================================================================
|
||||
package Test::Base::Filter;
|
||||
use Spiffy -Base;
|
||||
use Spiffy ':XXX';
|
||||
|
||||
field 'current_block';
|
||||
|
||||
our $arguments;
|
||||
sub current_arguments {
|
||||
return undef unless defined $arguments;
|
||||
my $args = $arguments;
|
||||
$args =~ s/(\\s)/ /g;
|
||||
$args =~ s/(\\[a-z])/'"' . $1 . '"'/gee;
|
||||
return $args;
|
||||
}
|
||||
|
||||
sub assert_scalar {
|
||||
return if @_ == 1;
|
||||
require Carp;
|
||||
my $filter = (caller(1))[3];
|
||||
$filter =~ s/.*:://;
|
||||
Carp::croak "Input to the '$filter' filter must be a scalar, not a list";
|
||||
}
|
||||
|
||||
sub _apply_deepest {
|
||||
my $method = shift;
|
||||
return () unless @_;
|
||||
if (ref $_[0] eq 'ARRAY') {
|
||||
for my $aref (@_) {
|
||||
@$aref = $self->_apply_deepest($method, @$aref);
|
||||
}
|
||||
return @_;
|
||||
}
|
||||
$self->$method(@_);
|
||||
}
|
||||
|
||||
sub _split_array {
|
||||
map {
|
||||
[$self->split($_)];
|
||||
} @_;
|
||||
}
|
||||
|
||||
sub _peel_deepest {
|
||||
return () unless @_;
|
||||
if (ref $_[0] eq 'ARRAY') {
|
||||
if (ref $_[0]->[0] eq 'ARRAY') {
|
||||
for my $aref (@_) {
|
||||
@$aref = $self->_peel_deepest(@$aref);
|
||||
}
|
||||
return @_;
|
||||
}
|
||||
return map { $_->[0] } @_;
|
||||
}
|
||||
return @_;
|
||||
}
|
||||
|
||||
#===============================================================================
|
||||
# these filters work on the leaves of nested arrays
|
||||
#===============================================================================
|
||||
sub Join { $self->_peel_deepest($self->_apply_deepest(join => @_)) }
|
||||
sub Reverse { $self->_apply_deepest(reverse => @_) }
|
||||
sub Split { $self->_apply_deepest(_split_array => @_) }
|
||||
sub Sort { $self->_apply_deepest(sort => @_) }
|
||||
|
||||
|
||||
sub append {
|
||||
my $suffix = $self->current_arguments;
|
||||
map { $_ . $suffix } @_;
|
||||
}
|
||||
|
||||
sub array {
|
||||
return [@_];
|
||||
}
|
||||
|
||||
sub base64_decode {
|
||||
$self->assert_scalar(@_);
|
||||
require MIME::Base64;
|
||||
MIME::Base64::decode_base64(shift);
|
||||
}
|
||||
|
||||
sub base64_encode {
|
||||
$self->assert_scalar(@_);
|
||||
require MIME::Base64;
|
||||
MIME::Base64::encode_base64(shift);
|
||||
}
|
||||
|
||||
sub chomp {
|
||||
map { CORE::chomp; $_ } @_;
|
||||
}
|
||||
|
||||
sub chop {
|
||||
map { CORE::chop; $_ } @_;
|
||||
}
|
||||
|
||||
sub dumper {
|
||||
no warnings 'once';
|
||||
require Data::Dumper;
|
||||
local $Data::Dumper::Sortkeys = 1;
|
||||
local $Data::Dumper::Indent = 1;
|
||||
local $Data::Dumper::Terse = 1;
|
||||
Data::Dumper::Dumper(@_);
|
||||
}
|
||||
|
||||
sub escape {
|
||||
$self->assert_scalar(@_);
|
||||
my $text = shift;
|
||||
$text =~ s/(\\.)/eval "qq{$1}"/ge;
|
||||
return $text;
|
||||
}
|
||||
|
||||
sub eval {
|
||||
$self->assert_scalar(@_);
|
||||
my @return = CORE::eval(shift);
|
||||
return $@ if $@;
|
||||
return @return;
|
||||
}
|
||||
|
||||
sub eval_all {
|
||||
$self->assert_scalar(@_);
|
||||
my $out = '';
|
||||
my $err = '';
|
||||
Test::Base::tie_output(*STDOUT, $out);
|
||||
Test::Base::tie_output(*STDERR, $err);
|
||||
my $return = CORE::eval(shift);
|
||||
no warnings;
|
||||
untie *STDOUT;
|
||||
untie *STDERR;
|
||||
return $return, $@, $out, $err;
|
||||
}
|
||||
|
||||
sub eval_stderr {
|
||||
$self->assert_scalar(@_);
|
||||
my $output = '';
|
||||
Test::Base::tie_output(*STDERR, $output);
|
||||
CORE::eval(shift);
|
||||
no warnings;
|
||||
untie *STDERR;
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub eval_stdout {
|
||||
$self->assert_scalar(@_);
|
||||
my $output = '';
|
||||
Test::Base::tie_output(*STDOUT, $output);
|
||||
CORE::eval(shift);
|
||||
no warnings;
|
||||
untie *STDOUT;
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub exec_perl_stdout {
|
||||
my $tmpfile = "/tmp/test-blocks-$$";
|
||||
$self->_write_to($tmpfile, @_);
|
||||
open my $execution, "$^X $tmpfile 2>&1 |"
|
||||
or die "Couldn't open subprocess: $!\n";
|
||||
local $/;
|
||||
my $output = <$execution>;
|
||||
close $execution;
|
||||
unlink($tmpfile)
|
||||
or die "Couldn't unlink $tmpfile: $!\n";
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub flatten {
|
||||
$self->assert_scalar(@_);
|
||||
my $ref = shift;
|
||||
if (ref($ref) eq 'HASH') {
|
||||
return map {
|
||||
($_, $ref->{$_});
|
||||
} sort keys %$ref;
|
||||
}
|
||||
if (ref($ref) eq 'ARRAY') {
|
||||
return @$ref;
|
||||
}
|
||||
die "Can only flatten a hash or array ref";
|
||||
}
|
||||
|
||||
sub get_url {
|
||||
$self->assert_scalar(@_);
|
||||
my $url = shift;
|
||||
CORE::chomp($url);
|
||||
require LWP::Simple;
|
||||
LWP::Simple::get($url);
|
||||
}
|
||||
|
||||
sub hash {
|
||||
return +{ @_ };
|
||||
}
|
||||
|
||||
sub head {
|
||||
my $size = $self->current_arguments || 1;
|
||||
return splice(@_, 0, $size);
|
||||
}
|
||||
|
||||
sub join {
|
||||
my $string = $self->current_arguments;
|
||||
$string = '' unless defined $string;
|
||||
CORE::join $string, @_;
|
||||
}
|
||||
|
||||
sub lines {
|
||||
$self->assert_scalar(@_);
|
||||
my $text = shift;
|
||||
return () unless length $text;
|
||||
my @lines = ($text =~ /^(.*\n?)/gm);
|
||||
return @lines;
|
||||
}
|
||||
|
||||
sub norm {
|
||||
$self->assert_scalar(@_);
|
||||
my $text = shift;
|
||||
$text = '' unless defined $text;
|
||||
$text =~ s/\015\012/\n/g;
|
||||
$text =~ s/\r/\n/g;
|
||||
return $text;
|
||||
}
|
||||
|
||||
sub prepend {
|
||||
my $prefix = $self->current_arguments;
|
||||
map { $prefix . $_ } @_;
|
||||
}
|
||||
|
||||
sub read_file {
|
||||
$self->assert_scalar(@_);
|
||||
my $file = shift;
|
||||
CORE::chomp $file;
|
||||
open my $fh, $file
|
||||
or die "Can't open '$file' for input:\n$!";
|
||||
CORE::join '', <$fh>;
|
||||
}
|
||||
|
||||
sub regexp {
|
||||
$self->assert_scalar(@_);
|
||||
my $text = shift;
|
||||
my $flags = $self->current_arguments;
|
||||
if ($text =~ /\n.*?\n/s) {
|
||||
$flags = 'xism'
|
||||
unless defined $flags;
|
||||
}
|
||||
else {
|
||||
CORE::chomp($text);
|
||||
}
|
||||
$flags ||= '';
|
||||
my $regexp = eval "qr{$text}$flags";
|
||||
die $@ if $@;
|
||||
return $regexp;
|
||||
}
|
||||
|
||||
sub reverse {
|
||||
CORE::reverse(@_);
|
||||
}
|
||||
|
||||
sub slice {
|
||||
die "Invalid args for slice"
|
||||
unless $self->current_arguments =~ /^(\d+)(?:,(\d))?$/;
|
||||
my ($x, $y) = ($1, $2);
|
||||
$y = $x if not defined $y;
|
||||
die "Invalid args for slice"
|
||||
if $x > $y;
|
||||
return splice(@_, $x, 1 + $y - $x);
|
||||
}
|
||||
|
||||
sub sort {
|
||||
CORE::sort(@_);
|
||||
}
|
||||
|
||||
sub split {
|
||||
$self->assert_scalar(@_);
|
||||
my $separator = $self->current_arguments;
|
||||
if (defined $separator and $separator =~ s{^/(.*)/$}{$1}) {
|
||||
my $regexp = $1;
|
||||
$separator = qr{$regexp};
|
||||
}
|
||||
$separator = qr/\s+/ unless $separator;
|
||||
CORE::split $separator, shift;
|
||||
}
|
||||
|
||||
sub strict {
|
||||
$self->assert_scalar(@_);
|
||||
<<'...' . shift;
|
||||
use strict;
|
||||
use warnings;
|
||||
...
|
||||
}
|
||||
|
||||
sub tail {
|
||||
my $size = $self->current_arguments || 1;
|
||||
return splice(@_, @_ - $size, $size);
|
||||
}
|
||||
|
||||
sub trim {
|
||||
map {
|
||||
s/\A([ \t]*\n)+//;
|
||||
s/(?<=\n)\s*\z//g;
|
||||
$_;
|
||||
} @_;
|
||||
}
|
||||
|
||||
sub unchomp {
|
||||
map { $_ . "\n" } @_;
|
||||
}
|
||||
|
||||
sub write_file {
|
||||
my $file = $self->current_arguments
|
||||
or die "No file specified for write_file filter";
|
||||
if ($file =~ /(.*)[\\\/]/) {
|
||||
my $dir = $1;
|
||||
if (not -e $dir) {
|
||||
require File::Path;
|
||||
File::Path::mkpath($dir)
|
||||
or die "Can't create $dir";
|
||||
}
|
||||
}
|
||||
open my $fh, ">$file"
|
||||
or die "Can't open '$file' for output\n:$!";
|
||||
print $fh @_;
|
||||
close $fh;
|
||||
return $file;
|
||||
}
|
||||
|
||||
sub yaml {
|
||||
$self->assert_scalar(@_);
|
||||
require YAML;
|
||||
return YAML::Load(shift);
|
||||
}
|
||||
|
||||
sub _write_to {
|
||||
my $filename = shift;
|
||||
open my $script, ">$filename"
|
||||
or die "Couldn't open $filename: $!\n";
|
||||
print $script @_;
|
||||
close $script
|
||||
or die "Couldn't close $filename: $!\n";
|
||||
}
|
||||
|
||||
__DATA__
|
||||
|
||||
#line 639
|
||||
1175
inc/Test/Builder.pm
Normal file
1175
inc/Test/Builder.pm
Normal file
File diff suppressed because it is too large
Load Diff
82
inc/Test/Builder/Module.pm
Normal file
82
inc/Test/Builder/Module.pm
Normal file
@@ -0,0 +1,82 @@
|
||||
#line 1
|
||||
package Test::Builder::Module;
|
||||
|
||||
use Test::Builder;
|
||||
|
||||
require Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
|
||||
$VERSION = '0.72';
|
||||
|
||||
use strict;
|
||||
|
||||
# 5.004's Exporter doesn't have export_to_level.
|
||||
my $_export_to_level = sub {
|
||||
my $pkg = shift;
|
||||
my $level = shift;
|
||||
(undef) = shift; # redundant arg
|
||||
my $callpkg = caller($level);
|
||||
$pkg->export($callpkg, @_);
|
||||
};
|
||||
|
||||
|
||||
#line 82
|
||||
|
||||
sub import {
|
||||
my($class) = shift;
|
||||
|
||||
my $test = $class->builder;
|
||||
|
||||
my $caller = caller;
|
||||
|
||||
$test->exported_to($caller);
|
||||
|
||||
$class->import_extra(\@_);
|
||||
my(@imports) = $class->_strip_imports(\@_);
|
||||
|
||||
$test->plan(@_);
|
||||
|
||||
$class->$_export_to_level(1, $class, @imports);
|
||||
}
|
||||
|
||||
|
||||
sub _strip_imports {
|
||||
my $class = shift;
|
||||
my $list = shift;
|
||||
|
||||
my @imports = ();
|
||||
my @other = ();
|
||||
my $idx = 0;
|
||||
while( $idx <= $#{$list} ) {
|
||||
my $item = $list->[$idx];
|
||||
|
||||
if( defined $item and $item eq 'import' ) {
|
||||
push @imports, @{$list->[$idx+1]};
|
||||
$idx++;
|
||||
}
|
||||
else {
|
||||
push @other, $item;
|
||||
}
|
||||
|
||||
$idx++;
|
||||
}
|
||||
|
||||
@$list = @other;
|
||||
|
||||
return @imports;
|
||||
}
|
||||
|
||||
|
||||
#line 144
|
||||
|
||||
sub import_extra {}
|
||||
|
||||
|
||||
#line 175
|
||||
|
||||
sub builder {
|
||||
return Test::Builder->new;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
672
inc/Test/More.pm
Normal file
672
inc/Test/More.pm
Normal file
@@ -0,0 +1,672 @@
|
||||
#line 1
|
||||
package Test::More;
|
||||
|
||||
use 5.004;
|
||||
|
||||
use strict;
|
||||
|
||||
|
||||
# Can't use Carp because it might cause use_ok() to accidentally succeed
|
||||
# even though the module being used forgot to use Carp. Yes, this
|
||||
# actually happened.
|
||||
sub _carp {
|
||||
my($file, $line) = (caller(1))[1,2];
|
||||
warn @_, " at $file line $line\n";
|
||||
}
|
||||
|
||||
|
||||
|
||||
use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
|
||||
$VERSION = '0.72';
|
||||
$VERSION = eval $VERSION; # make the alpha version come out as a number
|
||||
|
||||
use Test::Builder::Module;
|
||||
@ISA = qw(Test::Builder::Module);
|
||||
@EXPORT = qw(ok use_ok require_ok
|
||||
is isnt like unlike is_deeply
|
||||
cmp_ok
|
||||
skip todo todo_skip
|
||||
pass fail
|
||||
eq_array eq_hash eq_set
|
||||
$TODO
|
||||
plan
|
||||
can_ok isa_ok
|
||||
diag
|
||||
BAIL_OUT
|
||||
);
|
||||
|
||||
|
||||
#line 157
|
||||
|
||||
sub plan {
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
$tb->plan(@_);
|
||||
}
|
||||
|
||||
|
||||
# This implements "use Test::More 'no_diag'" but the behavior is
|
||||
# deprecated.
|
||||
sub import_extra {
|
||||
my $class = shift;
|
||||
my $list = shift;
|
||||
|
||||
my @other = ();
|
||||
my $idx = 0;
|
||||
while( $idx <= $#{$list} ) {
|
||||
my $item = $list->[$idx];
|
||||
|
||||
if( defined $item and $item eq 'no_diag' ) {
|
||||
$class->builder->no_diag(1);
|
||||
}
|
||||
else {
|
||||
push @other, $item;
|
||||
}
|
||||
|
||||
$idx++;
|
||||
}
|
||||
|
||||
@$list = @other;
|
||||
}
|
||||
|
||||
|
||||
#line 257
|
||||
|
||||
sub ok ($;$) {
|
||||
my($test, $name) = @_;
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
$tb->ok($test, $name);
|
||||
}
|
||||
|
||||
#line 324
|
||||
|
||||
sub is ($$;$) {
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
$tb->is_eq(@_);
|
||||
}
|
||||
|
||||
sub isnt ($$;$) {
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
$tb->isnt_eq(@_);
|
||||
}
|
||||
|
||||
*isn't = \&isnt;
|
||||
|
||||
|
||||
#line 369
|
||||
|
||||
sub like ($$;$) {
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
$tb->like(@_);
|
||||
}
|
||||
|
||||
|
||||
#line 385
|
||||
|
||||
sub unlike ($$;$) {
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
$tb->unlike(@_);
|
||||
}
|
||||
|
||||
|
||||
#line 425
|
||||
|
||||
sub cmp_ok($$$;$) {
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
$tb->cmp_ok(@_);
|
||||
}
|
||||
|
||||
|
||||
#line 461
|
||||
|
||||
sub can_ok ($@) {
|
||||
my($proto, @methods) = @_;
|
||||
my $class = ref $proto || $proto;
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
unless( $class ) {
|
||||
my $ok = $tb->ok( 0, "->can(...)" );
|
||||
$tb->diag(' can_ok() called with empty class or reference');
|
||||
return $ok;
|
||||
}
|
||||
|
||||
unless( @methods ) {
|
||||
my $ok = $tb->ok( 0, "$class->can(...)" );
|
||||
$tb->diag(' can_ok() called with no methods');
|
||||
return $ok;
|
||||
}
|
||||
|
||||
my @nok = ();
|
||||
foreach my $method (@methods) {
|
||||
$tb->_try(sub { $proto->can($method) }) or push @nok, $method;
|
||||
}
|
||||
|
||||
my $name;
|
||||
$name = @methods == 1 ? "$class->can('$methods[0]')"
|
||||
: "$class->can(...)";
|
||||
|
||||
my $ok = $tb->ok( !@nok, $name );
|
||||
|
||||
$tb->diag(map " $class->can('$_') failed\n", @nok);
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
#line 523
|
||||
|
||||
sub isa_ok ($$;$) {
|
||||
my($object, $class, $obj_name) = @_;
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
my $diag;
|
||||
$obj_name = 'The object' unless defined $obj_name;
|
||||
my $name = "$obj_name isa $class";
|
||||
if( !defined $object ) {
|
||||
$diag = "$obj_name isn't defined";
|
||||
}
|
||||
elsif( !ref $object ) {
|
||||
$diag = "$obj_name isn't a reference";
|
||||
}
|
||||
else {
|
||||
# We can't use UNIVERSAL::isa because we want to honor isa() overrides
|
||||
my($rslt, $error) = $tb->_try(sub { $object->isa($class) });
|
||||
if( $error ) {
|
||||
if( $error =~ /^Can't call method "isa" on unblessed reference/ ) {
|
||||
# Its an unblessed reference
|
||||
if( !UNIVERSAL::isa($object, $class) ) {
|
||||
my $ref = ref $object;
|
||||
$diag = "$obj_name isn't a '$class' it's a '$ref'";
|
||||
}
|
||||
} else {
|
||||
die <<WHOA;
|
||||
WHOA! I tried to call ->isa on your object and got some weird error.
|
||||
Here's the error.
|
||||
$error
|
||||
WHOA
|
||||
}
|
||||
}
|
||||
elsif( !$rslt ) {
|
||||
my $ref = ref $object;
|
||||
$diag = "$obj_name isn't a '$class' it's a '$ref'";
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
my $ok;
|
||||
if( $diag ) {
|
||||
$ok = $tb->ok( 0, $name );
|
||||
$tb->diag(" $diag\n");
|
||||
}
|
||||
else {
|
||||
$ok = $tb->ok( 1, $name );
|
||||
}
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
|
||||
#line 592
|
||||
|
||||
sub pass (;$) {
|
||||
my $tb = Test::More->builder;
|
||||
$tb->ok(1, @_);
|
||||
}
|
||||
|
||||
sub fail (;$) {
|
||||
my $tb = Test::More->builder;
|
||||
$tb->ok(0, @_);
|
||||
}
|
||||
|
||||
#line 653
|
||||
|
||||
sub use_ok ($;@) {
|
||||
my($module, @imports) = @_;
|
||||
@imports = () unless @imports;
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
my($pack,$filename,$line) = caller;
|
||||
|
||||
local($@,$!,$SIG{__DIE__}); # isolate eval
|
||||
|
||||
if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
|
||||
# probably a version check. Perl needs to see the bare number
|
||||
# for it to work with non-Exporter based modules.
|
||||
eval <<USE;
|
||||
package $pack;
|
||||
use $module $imports[0];
|
||||
USE
|
||||
}
|
||||
else {
|
||||
eval <<USE;
|
||||
package $pack;
|
||||
use $module \@imports;
|
||||
USE
|
||||
}
|
||||
|
||||
my $ok = $tb->ok( !$@, "use $module;" );
|
||||
|
||||
unless( $ok ) {
|
||||
chomp $@;
|
||||
$@ =~ s{^BEGIN failed--compilation aborted at .*$}
|
||||
{BEGIN failed--compilation aborted at $filename line $line.}m;
|
||||
$tb->diag(<<DIAGNOSTIC);
|
||||
Tried to use '$module'.
|
||||
Error: $@
|
||||
DIAGNOSTIC
|
||||
|
||||
}
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
#line 702
|
||||
|
||||
sub require_ok ($) {
|
||||
my($module) = shift;
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
my $pack = caller;
|
||||
|
||||
# Try to deterine if we've been given a module name or file.
|
||||
# Module names must be barewords, files not.
|
||||
$module = qq['$module'] unless _is_module_name($module);
|
||||
|
||||
local($!, $@, $SIG{__DIE__}); # isolate eval
|
||||
local $SIG{__DIE__};
|
||||
eval <<REQUIRE;
|
||||
package $pack;
|
||||
require $module;
|
||||
REQUIRE
|
||||
|
||||
my $ok = $tb->ok( !$@, "require $module;" );
|
||||
|
||||
unless( $ok ) {
|
||||
chomp $@;
|
||||
$tb->diag(<<DIAGNOSTIC);
|
||||
Tried to require '$module'.
|
||||
Error: $@
|
||||
DIAGNOSTIC
|
||||
|
||||
}
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
|
||||
sub _is_module_name {
|
||||
my $module = shift;
|
||||
|
||||
# Module names start with a letter.
|
||||
# End with an alphanumeric.
|
||||
# The rest is an alphanumeric or ::
|
||||
$module =~ s/\b::\b//g;
|
||||
$module =~ /^[a-zA-Z]\w*$/;
|
||||
}
|
||||
|
||||
#line 779
|
||||
|
||||
use vars qw(@Data_Stack %Refs_Seen);
|
||||
my $DNE = bless [], 'Does::Not::Exist';
|
||||
|
||||
sub _dne {
|
||||
ref $_[0] eq ref $DNE;
|
||||
}
|
||||
|
||||
|
||||
sub is_deeply {
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
unless( @_ == 2 or @_ == 3 ) {
|
||||
my $msg = <<WARNING;
|
||||
is_deeply() takes two or three args, you gave %d.
|
||||
This usually means you passed an array or hash instead
|
||||
of a reference to it
|
||||
WARNING
|
||||
chop $msg; # clip off newline so carp() will put in line/file
|
||||
|
||||
_carp sprintf $msg, scalar @_;
|
||||
|
||||
return $tb->ok(0);
|
||||
}
|
||||
|
||||
my($got, $expected, $name) = @_;
|
||||
|
||||
$tb->_unoverload_str(\$expected, \$got);
|
||||
|
||||
my $ok;
|
||||
if( !ref $got and !ref $expected ) { # neither is a reference
|
||||
$ok = $tb->is_eq($got, $expected, $name);
|
||||
}
|
||||
elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't
|
||||
$ok = $tb->ok(0, $name);
|
||||
$tb->diag( _format_stack({ vals => [ $got, $expected ] }) );
|
||||
}
|
||||
else { # both references
|
||||
local @Data_Stack = ();
|
||||
if( _deep_check($got, $expected) ) {
|
||||
$ok = $tb->ok(1, $name);
|
||||
}
|
||||
else {
|
||||
$ok = $tb->ok(0, $name);
|
||||
$tb->diag(_format_stack(@Data_Stack));
|
||||
}
|
||||
}
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
sub _format_stack {
|
||||
my(@Stack) = @_;
|
||||
|
||||
my $var = '$FOO';
|
||||
my $did_arrow = 0;
|
||||
foreach my $entry (@Stack) {
|
||||
my $type = $entry->{type} || '';
|
||||
my $idx = $entry->{'idx'};
|
||||
if( $type eq 'HASH' ) {
|
||||
$var .= "->" unless $did_arrow++;
|
||||
$var .= "{$idx}";
|
||||
}
|
||||
elsif( $type eq 'ARRAY' ) {
|
||||
$var .= "->" unless $did_arrow++;
|
||||
$var .= "[$idx]";
|
||||
}
|
||||
elsif( $type eq 'REF' ) {
|
||||
$var = "\${$var}";
|
||||
}
|
||||
}
|
||||
|
||||
my @vals = @{$Stack[-1]{vals}}[0,1];
|
||||
my @vars = ();
|
||||
($vars[0] = $var) =~ s/\$FOO/ \$got/;
|
||||
($vars[1] = $var) =~ s/\$FOO/\$expected/;
|
||||
|
||||
my $out = "Structures begin differing at:\n";
|
||||
foreach my $idx (0..$#vals) {
|
||||
my $val = $vals[$idx];
|
||||
$vals[$idx] = !defined $val ? 'undef' :
|
||||
_dne($val) ? "Does not exist" :
|
||||
ref $val ? "$val" :
|
||||
"'$val'";
|
||||
}
|
||||
|
||||
$out .= "$vars[0] = $vals[0]\n";
|
||||
$out .= "$vars[1] = $vals[1]\n";
|
||||
|
||||
$out =~ s/^/ /msg;
|
||||
return $out;
|
||||
}
|
||||
|
||||
|
||||
sub _type {
|
||||
my $thing = shift;
|
||||
|
||||
return '' if !ref $thing;
|
||||
|
||||
for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) {
|
||||
return $type if UNIVERSAL::isa($thing, $type);
|
||||
}
|
||||
|
||||
return '';
|
||||
}
|
||||
|
||||
#line 925
|
||||
|
||||
sub diag {
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
$tb->diag(@_);
|
||||
}
|
||||
|
||||
|
||||
#line 994
|
||||
|
||||
#'#
|
||||
sub skip {
|
||||
my($why, $how_many) = @_;
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
unless( defined $how_many ) {
|
||||
# $how_many can only be avoided when no_plan is in use.
|
||||
_carp "skip() needs to know \$how_many tests are in the block"
|
||||
unless $tb->has_plan eq 'no_plan';
|
||||
$how_many = 1;
|
||||
}
|
||||
|
||||
if( defined $how_many and $how_many =~ /\D/ ) {
|
||||
_carp "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?";
|
||||
$how_many = 1;
|
||||
}
|
||||
|
||||
for( 1..$how_many ) {
|
||||
$tb->skip($why);
|
||||
}
|
||||
|
||||
local $^W = 0;
|
||||
last SKIP;
|
||||
}
|
||||
|
||||
|
||||
#line 1081
|
||||
|
||||
sub todo_skip {
|
||||
my($why, $how_many) = @_;
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
unless( defined $how_many ) {
|
||||
# $how_many can only be avoided when no_plan is in use.
|
||||
_carp "todo_skip() needs to know \$how_many tests are in the block"
|
||||
unless $tb->has_plan eq 'no_plan';
|
||||
$how_many = 1;
|
||||
}
|
||||
|
||||
for( 1..$how_many ) {
|
||||
$tb->todo_skip($why);
|
||||
}
|
||||
|
||||
local $^W = 0;
|
||||
last TODO;
|
||||
}
|
||||
|
||||
#line 1134
|
||||
|
||||
sub BAIL_OUT {
|
||||
my $reason = shift;
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
$tb->BAIL_OUT($reason);
|
||||
}
|
||||
|
||||
#line 1173
|
||||
|
||||
#'#
|
||||
sub eq_array {
|
||||
local @Data_Stack;
|
||||
_deep_check(@_);
|
||||
}
|
||||
|
||||
sub _eq_array {
|
||||
my($a1, $a2) = @_;
|
||||
|
||||
if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) {
|
||||
warn "eq_array passed a non-array ref";
|
||||
return 0;
|
||||
}
|
||||
|
||||
return 1 if $a1 eq $a2;
|
||||
|
||||
my $ok = 1;
|
||||
my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
|
||||
for (0..$max) {
|
||||
my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
|
||||
my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
|
||||
|
||||
push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] };
|
||||
$ok = _deep_check($e1,$e2);
|
||||
pop @Data_Stack if $ok;
|
||||
|
||||
last unless $ok;
|
||||
}
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
sub _deep_check {
|
||||
my($e1, $e2) = @_;
|
||||
my $tb = Test::More->builder;
|
||||
|
||||
my $ok = 0;
|
||||
|
||||
# Effectively turn %Refs_Seen into a stack. This avoids picking up
|
||||
# the same referenced used twice (such as [\$a, \$a]) to be considered
|
||||
# circular.
|
||||
local %Refs_Seen = %Refs_Seen;
|
||||
|
||||
{
|
||||
# Quiet uninitialized value warnings when comparing undefs.
|
||||
local $^W = 0;
|
||||
|
||||
$tb->_unoverload_str(\$e1, \$e2);
|
||||
|
||||
# Either they're both references or both not.
|
||||
my $same_ref = !(!ref $e1 xor !ref $e2);
|
||||
my $not_ref = (!ref $e1 and !ref $e2);
|
||||
|
||||
if( defined $e1 xor defined $e2 ) {
|
||||
$ok = 0;
|
||||
}
|
||||
elsif ( _dne($e1) xor _dne($e2) ) {
|
||||
$ok = 0;
|
||||
}
|
||||
elsif ( $same_ref and ($e1 eq $e2) ) {
|
||||
$ok = 1;
|
||||
}
|
||||
elsif ( $not_ref ) {
|
||||
push @Data_Stack, { type => '', vals => [$e1, $e2] };
|
||||
$ok = 0;
|
||||
}
|
||||
else {
|
||||
if( $Refs_Seen{$e1} ) {
|
||||
return $Refs_Seen{$e1} eq $e2;
|
||||
}
|
||||
else {
|
||||
$Refs_Seen{$e1} = "$e2";
|
||||
}
|
||||
|
||||
my $type = _type($e1);
|
||||
$type = 'DIFFERENT' unless _type($e2) eq $type;
|
||||
|
||||
if( $type eq 'DIFFERENT' ) {
|
||||
push @Data_Stack, { type => $type, vals => [$e1, $e2] };
|
||||
$ok = 0;
|
||||
}
|
||||
elsif( $type eq 'ARRAY' ) {
|
||||
$ok = _eq_array($e1, $e2);
|
||||
}
|
||||
elsif( $type eq 'HASH' ) {
|
||||
$ok = _eq_hash($e1, $e2);
|
||||
}
|
||||
elsif( $type eq 'REF' ) {
|
||||
push @Data_Stack, { type => $type, vals => [$e1, $e2] };
|
||||
$ok = _deep_check($$e1, $$e2);
|
||||
pop @Data_Stack if $ok;
|
||||
}
|
||||
elsif( $type eq 'SCALAR' ) {
|
||||
push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
|
||||
$ok = _deep_check($$e1, $$e2);
|
||||
pop @Data_Stack if $ok;
|
||||
}
|
||||
elsif( $type ) {
|
||||
push @Data_Stack, { type => $type, vals => [$e1, $e2] };
|
||||
$ok = 0;
|
||||
}
|
||||
else {
|
||||
_whoa(1, "No type in _deep_check");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
|
||||
sub _whoa {
|
||||
my($check, $desc) = @_;
|
||||
if( $check ) {
|
||||
die <<WHOA;
|
||||
WHOA! $desc
|
||||
This should never happen! Please contact the author immediately!
|
||||
WHOA
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
#line 1304
|
||||
|
||||
sub eq_hash {
|
||||
local @Data_Stack;
|
||||
return _deep_check(@_);
|
||||
}
|
||||
|
||||
sub _eq_hash {
|
||||
my($a1, $a2) = @_;
|
||||
|
||||
if( grep !_type($_) eq 'HASH', $a1, $a2 ) {
|
||||
warn "eq_hash passed a non-hash ref";
|
||||
return 0;
|
||||
}
|
||||
|
||||
return 1 if $a1 eq $a2;
|
||||
|
||||
my $ok = 1;
|
||||
my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
|
||||
foreach my $k (keys %$bigger) {
|
||||
my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
|
||||
my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
|
||||
|
||||
push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] };
|
||||
$ok = _deep_check($e1, $e2);
|
||||
pop @Data_Stack if $ok;
|
||||
|
||||
last unless $ok;
|
||||
}
|
||||
|
||||
return $ok;
|
||||
}
|
||||
|
||||
#line 1361
|
||||
|
||||
sub eq_set {
|
||||
my($a1, $a2) = @_;
|
||||
return 0 unless @$a1 == @$a2;
|
||||
|
||||
# There's faster ways to do this, but this is easiest.
|
||||
local $^W = 0;
|
||||
|
||||
# It really doesn't matter how we sort them, as long as both arrays are
|
||||
# sorted with the same algorithm.
|
||||
#
|
||||
# Ensure that references are not accidentally treated the same as a
|
||||
# string containing the reference.
|
||||
#
|
||||
# Have to inline the sort routine due to a threading/sort bug.
|
||||
# See [rt.cpan.org 6782]
|
||||
#
|
||||
# I don't know how references would be sorted so we just don't sort
|
||||
# them. This means eq_set doesn't really work with refs.
|
||||
return eq_array(
|
||||
[grep(ref, @$a1), sort( grep(!ref, @$a1) )],
|
||||
[grep(ref, @$a2), sort( grep(!ref, @$a2) )],
|
||||
);
|
||||
}
|
||||
|
||||
#line 1551
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user