AI-MaxEntropy
view release on metacpan or search on metacpan
inc/Module/AutoInstall.pm view on Meta::CPAN
# 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 ) ];
inc/Module/AutoInstall.pm view on Meta::CPAN
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 = [];
inc/Module/AutoInstall.pm view on Meta::CPAN
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;
}
inc/Module/AutoInstall.pm view on Meta::CPAN
*** 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 ) ) ) {
inc/Module/AutoInstall.pm view on Meta::CPAN
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
inc/Module/AutoInstall.pm view on Meta::CPAN
*** 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
inc/Module/AutoInstall.pm view on Meta::CPAN
*** 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]/
)
inc/Module/AutoInstall.pm view on Meta::CPAN
_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.
.
inc/Module/AutoInstall.pm view on Meta::CPAN
.
}
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')
) {
inc/Module/AutoInstall.pm view on Meta::CPAN
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} =
inc/Module/AutoInstall.pm view on Meta::CPAN
$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;
}
inc/Module/AutoInstall.pm view on Meta::CPAN
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
inc/Module/Install.pm view on Meta::CPAN
}
use Cwd ();
use File::Find ();
use File::Path ();
use FindBin;
*inc::Module::Install::VERSION = *VERSION;
@inc::Module::Install::ISA = __PACKAGE__;
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";
unshift @_, ($self, $1);
goto &{$self->can('call')} unless uc($1) eq $1;
};
}
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);
inc/Module/Install.pm view on Meta::CPAN
}
*{"${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"};
}
sub preload {
my ($self) = @_;
unless ( $self->{extensions} ) {
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
);
}
my @exts = @{$self->{extensions}};
unless ( @exts ) {
inc/Module/Install.pm view on Meta::CPAN
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};
inc/Module/Install.pm view on Meta::CPAN
$args{version} ||= $class->VERSION;
unless ( $args{path} ) {
$args{path} = $args{name};
$args{path} =~ s!::!/!g;
}
$args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
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);
}
inc/Module/Install.pm view on Meta::CPAN
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};
inc/Module/Install.pm view on Meta::CPAN
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
inc/Module/Install.pm view on Meta::CPAN
}
close PKGFILE;
}
push @found, [ $file, $pkg ];
}, $path ) if -d $path;
@found;
}
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
1;
inc/Module/Install/AutoInstall.pm view on Meta::CPAN
use strict;
use Module::Install::Base;
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
$VERSION = '0.68';
$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
inc/Module/Install/AutoInstall.pm view on Meta::CPAN
$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;
inc/Module/Install/Base.pm view on Meta::CPAN
#line 1
package Module::Install::Base;
$VERSION = '0.68';
# 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;
}
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 138
inc/Module/Install/Include.pm view on Meta::CPAN
use strict;
use Module::Install::Base;
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
$VERSION = '0.68';
$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;
inc/Module/Install/MakeMaker.pm view on Meta::CPAN
use ExtUtils::MakeMaker ();
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
$VERSION = '0.68';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
my $makefile;
sub WriteMakefile {
my ($self, %args) = @_;
$makefile = $self->load('Makefile');
# mapping between MakeMaker and META.yml keys
$args{MODULE_NAME} = $args{NAME};
unless ($args{NAME} = $args{DISTNAME} or !$args{MODULE_NAME}) {
$args{NAME} = $args{MODULE_NAME};
$args{NAME} =~ s/::/-/g;
}
inc/Module/Install/Makefile.pm view on Meta::CPAN
use Module::Install::Base;
use ExtUtils::MakeMaker ();
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
$VERSION = '0.68';
$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, @_ ) if @_;
$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";
}
require File::Find;
%test_dir = ();
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 @_;
my $args = $self->makemaker_args;
$args->{DISTNAME} = $self->name;
$args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args);
$args->{VERSION} = $self->version || $self->determine_VERSION($args);
$args->{NAME} =~ s/-/::/g;
if ( $self->tests ) {
$args->{test} = { TESTS => $self->tests };
inc/Module/Install/Makefile.pm view on Meta::CPAN
my $user_preop = delete $args{dist}->{PREOP};
if (my $preop = $self->admin->preop($user_preop)) {
$args{dist} = $preop;
}
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"
inc/Module/Install/Makefile.pm view on Meta::CPAN
# 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__
inc/Module/Install/Metadata.pm view on Meta::CPAN
my @scalar_keys = qw{
name module_name abstract author version license
distribution_type perl_version tests installdirs
};
my @tuple_keys = qw{
build_requires requires recommends bundles
};
sub Meta { shift }
sub Meta_ScalarKeys { @scalar_keys }
sub Meta_TupleKeys { @tuple_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 (@tuple_keys) {
*$key = sub {
my $self = shift;
return $self->{values}{$key} unless @_;
my @rv;
while (@_) {
my $module = shift or last;
my $version = shift || 0;
if ( $module eq 'perl' ) {
$version =~ s{^(\d+)\.(\d+)\.(\d+)}
{$1 + $2/1_000 + $3/1_000_000}e;
inc/Module/Install/Metadata.pm view on Meta::CPAN
}
my $rv = [ $module, $version ];
push @rv, $rv;
}
push @{ $self->{values}{$key} }, @rv;
@rv;
};
}
# configure_requires is currently a null-op
sub configure_requires { 1 }
# 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, skipping\n";
return $self;
}
$self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0;
return $self;
}
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;
die "all_from: cannot find $file from $name" unless -e $file;
}
inc/Module/Install/Metadata.pm view on Meta::CPAN
my $pod = $file;
if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
$file = $pod;
}
$self->author_from($file) unless $self->author;
$self->license_from($file) unless $self->license;
$self->abstract_from($file) unless $self->abstract;
}
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];
inc/Module/Install/Metadata.pm view on Meta::CPAN
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', 0 );
require YAML;
my $data = YAML::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' ) {
inc/Module/Install/Metadata.pm view on Meta::CPAN
$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 {
my ( $self, $file ) = @_;
require ExtUtils::MM_Unix;
$self->version( ExtUtils::MM_Unix->parse_version($file) );
}
sub abstract_from {
my ( $self, $file ) = @_;
require ExtUtils::MM_Unix;
$self->abstract(
bless(
{ DISTNAME => $self->name },
'ExtUtils::MM_Unix'
)->parse_abstract($file)
);
}
sub _slurp {
my ( $self, $file ) = @_;
local *FH;
open FH, "< $file" or die "Cannot open $file.pod: $!";
do { local $/; <FH> };
}
sub perl_version_from {
my ( $self, $file ) = @_;
if (
$self->_slurp($file) =~ m/
^
use \s*
v?
([\d_\.]+)
\s* ;
/ixms
inc/Module/Install/Metadata.pm view on Meta::CPAN
my $v = $1;
$v =~ s{_}{}g;
$self->perl_version($1);
}
else {
warn "Cannot determine perl version info from $file\n";
return;
}
}
sub author_from {
my ( $self, $file ) = @_;
my $content = $self->_slurp($file);
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 $file\n";
}
}
sub license_from {
my ( $self, $file ) = @_;
if (
$self->_slurp($file) =~ m/
(
=head \d \s+
(?:licen[cs]e|licensing|copyright|legal)\b
.*?
)
(=head\\d.*|=cut.*|)
inc/Test/Builder.pm view on Meta::CPAN
BEGIN {
use Config;
# Load threads::shared when threads are turned on.
# 5.8.0's threads are so busted we no longer support them.
if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'}) {
require threads::shared;
# Hack around YET ANOTHER threads::shared bug. It would
# occassionally forget the contents of the variable when sharing it.
# So we first copy the data, then share, then put our copy back.
*share = sub (\[$@%]) {
my $type = ref $_[0];
my $data;
if( $type eq 'HASH' ) {
%$data = %{$_[0]};
}
elsif( $type eq 'ARRAY' ) {
@$data = @{$_[0]};
}
elsif( $type eq 'SCALAR' ) {
inc/Test/Builder.pm view on Meta::CPAN
else {
die("Unknown type: ".$type);
}
return $_[0];
};
}
# 5.8.0's threads::shared is busted when threads are off
# and earlier Perls just don't have that module at all.
else {
*share = sub { return $_[0] };
*lock = sub { 0 };
}
}
#line 128
my $Test = Test::Builder->new;
sub new {
my($class) = shift;
$Test ||= $class->create;
return $Test;
}
#line 150
sub create {
my $class = shift;
my $self = bless {}, $class;
$self->reset;
return $self;
}
#line 169
use vars qw($Level);
sub reset {
my ($self) = @_;
# We leave this a global because it has to be localized and localizing
# hash keys is just asking for pain. Also, it was documented.
$Level = 1;
$self->{Test_Died} = 0;
$self->{Have_Plan} = 0;
$self->{No_Plan} = 0;
$self->{Original_Pid} = $$;
inc/Test/Builder.pm view on Meta::CPAN
$self->{No_Header} = 0;
$self->{No_Ending} = 0;
$self->_dup_stdhandles unless $^C;
return undef;
}
#line 221
sub exported_to {
my($self, $pack) = @_;
if( defined $pack ) {
$self->{Exported_To} = $pack;
}
return $self->{Exported_To};
}
#line 243
sub plan {
my($self, $cmd, $arg) = @_;
return unless $cmd;
local $Level = $Level + 1;
if( $self->{Have_Plan} ) {
$self->croak("You tried to plan twice");
}
inc/Test/Builder.pm view on Meta::CPAN
else {
my @args = grep { defined } ($cmd, $arg);
$self->croak("plan() doesn't understand @args");
}
return 1;
}
#line 290
sub expected_tests {
my $self = shift;
my($max) = @_;
if( @_ ) {
$self->croak("Number of tests must be a positive integer. You gave it '$max'")
unless $max =~ /^\+?\d+$/ and $max > 0;
$self->{Expected_Tests} = $max;
$self->{Have_Plan} = 1;
$self->_print("1..$max\n") unless $self->no_header;
}
return $self->{Expected_Tests};
}
#line 315
sub no_plan {
my $self = shift;
$self->{No_Plan} = 1;
$self->{Have_Plan} = 1;
}
#line 330
sub has_plan {
my $self = shift;
return($self->{Expected_Tests}) if $self->{Expected_Tests};
return('no_plan') if $self->{No_Plan};
return(undef);
};
#line 348
sub skip_all {
my($self, $reason) = @_;
my $out = "1..0";
$out .= " # Skip $reason" if $reason;
$out .= "\n";
$self->{Skip_All} = 1;
$self->_print($out) unless $self->no_header;
exit(0);
}
#line 382
sub ok {
my($self, $test, $name) = @_;
# $test might contain an object which we don't want to accidentally
# store, so we turn it into a boolean.
$test = $test ? 1 : 0;
$self->_plan_check;
lock $self->{Curr_Test};
$self->{Curr_Test}++;
inc/Test/Builder.pm view on Meta::CPAN
}
else {
$self->diag(qq[ $msg test at $file line $line.\n]);
}
}
return $test ? 1 : 0;
}
sub _unoverload {
my $self = shift;
my $type = shift;
$self->_try(sub { require overload } ) || return;
foreach my $thing (@_) {
if( $self->_is_object($$thing) ) {
if( my $string_meth = overload::Method($$thing, $type) ) {
$$thing = $$thing->$string_meth();
}
}
}
}
sub _is_object {
my($self, $thing) = @_;
return $self->_try(sub { ref $thing && $thing->isa('UNIVERSAL') }) ? 1 : 0;
}
sub _unoverload_str {
my $self = shift;
$self->_unoverload(q[""], @_);
}
sub _unoverload_num {
my $self = shift;
$self->_unoverload('0+', @_);
for my $val (@_) {
next unless $self->_is_dualvar($$val);
$$val = $$val+0;
}
}
# This is a hack to detect a dualvar such as $!
sub _is_dualvar {
my($self, $val) = @_;
local $^W = 0;
my $numval = $val+0;
return 1 if $numval != 0 and $numval ne $val;
}
#line 530
sub is_eq {
my($self, $got, $expect, $name) = @_;
local $Level = $Level + 1;
$self->_unoverload_str(\$got, \$expect);
if( !defined $got || !defined $expect ) {
# undef only matches undef and nothing else
my $test = !defined $got && !defined $expect;
$self->ok($test, $name);
$self->_is_diag($got, 'eq', $expect) unless $test;
return $test;
}
return $self->cmp_ok($got, 'eq', $expect, $name);
}
sub is_num {
my($self, $got, $expect, $name) = @_;
local $Level = $Level + 1;
$self->_unoverload_num(\$got, \$expect);
if( !defined $got || !defined $expect ) {
# undef only matches undef and nothing else
my $test = !defined $got && !defined $expect;
$self->ok($test, $name);
$self->_is_diag($got, '==', $expect) unless $test;
return $test;
}
return $self->cmp_ok($got, '==', $expect, $name);
}
sub _is_diag {
my($self, $got, $type, $expect) = @_;
foreach my $val (\$got, \$expect) {
if( defined $$val ) {
if( $type eq 'eq' ) {
# quote and force string context
$$val = "'$$val'"
}
else {
# force numeric context
inc/Test/Builder.pm view on Meta::CPAN
return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
got: %s
expected: %s
DIAGNOSTIC
}
#line 608
sub isnt_eq {
my($self, $got, $dont_expect, $name) = @_;
local $Level = $Level + 1;
if( !defined $got || !defined $dont_expect ) {
# undef only matches undef and nothing else
my $test = defined $got || defined $dont_expect;
$self->ok($test, $name);
$self->_cmp_diag($got, 'ne', $dont_expect) unless $test;
return $test;
}
return $self->cmp_ok($got, 'ne', $dont_expect, $name);
}
sub isnt_num {
my($self, $got, $dont_expect, $name) = @_;
local $Level = $Level + 1;
if( !defined $got || !defined $dont_expect ) {
# undef only matches undef and nothing else
my $test = defined $got || defined $dont_expect;
$self->ok($test, $name);
$self->_cmp_diag($got, '!=', $dont_expect) unless $test;
return $test;
}
return $self->cmp_ok($got, '!=', $dont_expect, $name);
}
#line 660
sub like {
my($self, $this, $regex, $name) = @_;
local $Level = $Level + 1;
$self->_regex_ok($this, $regex, '=~', $name);
}
sub unlike {
my($self, $this, $regex, $name) = @_;
local $Level = $Level + 1;
$self->_regex_ok($this, $regex, '!~', $name);
}
#line 685
my %numeric_cmps = map { ($_, 1) }
("<", "<=", ">", ">=", "==", "!=", "<=>");
sub cmp_ok {
my($self, $got, $type, $expect, $name) = @_;
# Treat overloaded objects as numbers if we're asked to do a
# numeric comparison.
my $unoverload = $numeric_cmps{$type} ? '_unoverload_num'
: '_unoverload_str';
$self->$unoverload(\$got, \$expect);
inc/Test/Builder.pm view on Meta::CPAN
if( $type =~ /^(eq|==)$/ ) {
$self->_is_diag($got, $type, $expect);
}
else {
$self->_cmp_diag($got, $type, $expect);
}
}
return $ok;
}
sub _cmp_diag {
my($self, $got, $type, $expect) = @_;
$got = defined $got ? "'$got'" : 'undef';
$expect = defined $expect ? "'$expect'" : 'undef';
return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
%s
%s
%s
DIAGNOSTIC
}
sub _caller_context {
my $self = shift;
my($pack, $file, $line) = $self->caller(1);
my $code = '';
$code .= "#line $line $file\n" if defined $file and defined $line;
return $code;
}
#line 771
sub BAIL_OUT {
my($self, $reason) = @_;
$self->{Bailed_Out} = 1;
$self->_print("Bail out! $reason");
exit 255;
}
#line 784
*BAILOUT = \&BAIL_OUT;
#line 796
sub skip {
my($self, $why) = @_;
$why ||= '';
$self->_unoverload_str(\$why);
$self->_plan_check;
lock($self->{Curr_Test});
$self->{Curr_Test}++;
$self->{Test_Results}[$self->{Curr_Test}-1] = &share({
inc/Test/Builder.pm view on Meta::CPAN
$out .= "\n";
$self->_print($out);
return 1;
}
#line 838
sub todo_skip {
my($self, $why) = @_;
$why ||= '';
$self->_plan_check;
lock($self->{Curr_Test});
$self->{Curr_Test}++;
$self->{Test_Results}[$self->{Curr_Test}-1] = &share({
'ok' => 1,
inc/Test/Builder.pm view on Meta::CPAN
$self->_print($out);
return 1;
}
#line 916
sub maybe_regex {
my ($self, $regex) = @_;
my $usable_regex = undef;
return $usable_regex unless defined $regex;
my($re, $opts);
# Check for qr/foo/
if( ref $regex eq 'Regexp' ) {
$usable_regex = $regex;
inc/Test/Builder.pm view on Meta::CPAN
elsif( ($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
(undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
)
{
$usable_regex = length $opts ? "(?$opts)$re" : $re;
}
return $usable_regex;
};
sub _regex_ok {
my($self, $this, $regex, $cmp, $name) = @_;
my $ok = 0;
my $usable_regex = $self->maybe_regex($regex);
unless (defined $usable_regex) {
$ok = $self->ok( 0, $name );
$self->diag(" '$regex' doesn't look much like a regex to me.");
return $ok;
}
inc/Test/Builder.pm view on Meta::CPAN
return $ok;
}
# I'm not ready to publish this. It doesn't deal with array return
# values from the code or context.
#line 1000
sub _try {
my($self, $code) = @_;
local $!; # eval can mess up $!
local $@; # don't set $@ in the test
local $SIG{__DIE__}; # don't trip an outside DIE handler.
my $return = eval { $code->() };
return wantarray ? ($return, $@) : $return;
}
#line 1022
sub is_fh {
my $self = shift;
my $maybe_fh = shift;
return 0 unless defined $maybe_fh;
return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
return eval { $maybe_fh->isa("IO::Handle") } ||
# 5.5.4's tied() and can() doesn't like getting undef
eval { (tied($maybe_fh) || '')->can('TIEHANDLE') };
}
#line 1067
sub level {
my($self, $level) = @_;
if( defined $level ) {
$Level = $level;
}
return $Level;
}
#line 1100
sub use_numbers {
my($self, $use_nums) = @_;
if( defined $use_nums ) {
$self->{Use_Nums} = $use_nums;
}
return $self->{Use_Nums};
}
#line 1134
foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
my $method = lc $attribute;
my $code = sub {
my($self, $no) = @_;
if( defined $no ) {
$self->{$attribute} = $no;
}
return $self->{$attribute};
};
no strict 'refs';
*{__PACKAGE__.'::'.$method} = $code;
}
#line 1188
sub diag {
my($self, @msgs) = @_;
return if $self->no_diag;
return unless @msgs;
# Prevent printing headers when compiling (i.e. -c)
return if $^C;
# Smash args together like print does.
# Convert undef to 'undef' so its readable.
inc/Test/Builder.pm view on Meta::CPAN
$msg .= "\n" unless $msg =~ /\n\Z/;
local $Level = $Level + 1;
$self->_print_diag($msg);
return 0;
}
#line 1225
sub _print {
my($self, @msgs) = @_;
# Prevent printing headers when only compiling. Mostly for when
# tests are deparsed with B::Deparse
return if $^C;
my $msg = join '', @msgs;
local($\, $", $,) = (undef, ' ', '');
my $fh = $self->output;
inc/Test/Builder.pm view on Meta::CPAN
$msg =~ s/\n(.)/\n# $1/sg;
# Stick a newline on the end if it needs it.
$msg .= "\n" unless $msg =~ /\n\Z/;
print $fh $msg;
}
#line 1259
sub _print_diag {
my $self = shift;
local($\, $", $,) = (undef, ' ', '');
my $fh = $self->todo ? $self->todo_output : $self->failure_output;
print $fh @_;
}
#line 1296
sub output {
my($self, $fh) = @_;
if( defined $fh ) {
$self->{Out_FH} = $self->_new_fh($fh);
}
return $self->{Out_FH};
}
sub failure_output {
my($self, $fh) = @_;
if( defined $fh ) {
$self->{Fail_FH} = $self->_new_fh($fh);
}
return $self->{Fail_FH};
}
sub todo_output {
my($self, $fh) = @_;
if( defined $fh ) {
$self->{Todo_FH} = $self->_new_fh($fh);
}
return $self->{Todo_FH};
}
sub _new_fh {
my $self = shift;
my($file_or_fh) = shift;
my $fh;
if( $self->is_fh($file_or_fh) ) {
$fh = $file_or_fh;
}
else {
$fh = do { local *FH };
open $fh, ">$file_or_fh" or
$self->croak("Can't open test output log $file_or_fh: $!");
_autoflush($fh);
}
return $fh;
}
sub _autoflush {
my($fh) = shift;
my $old_fh = select $fh;
$| = 1;
select $old_fh;
}
sub _dup_stdhandles {
my $self = shift;
$self->_open_testhandles;
# Set everything to unbuffered else plain prints to STDOUT will
# come out in the wrong order from our own prints.
_autoflush(\*TESTOUT);
_autoflush(\*STDOUT);
_autoflush(\*TESTERR);
_autoflush(\*STDERR);
$self->output(\*TESTOUT);
$self->failure_output(\*TESTERR);
$self->todo_output(\*TESTOUT);
}
my $Opened_Testhandles = 0;
sub _open_testhandles {
return if $Opened_Testhandles;
# We dup STDOUT and STDERR so people can change them in their
# test suites while still getting normal test output.
open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";
open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!";
$Opened_Testhandles = 1;
}
#line 1396
sub _message_at_caller {
my $self = shift;
local $Level = $Level + 1;
my($pack, $file, $line) = $self->caller;
return join("", @_) . " at $file line $line.\n";
}
sub carp {
my $self = shift;
warn $self->_message_at_caller(@_);
}
sub croak {
my $self = shift;
die $self->_message_at_caller(@_);
}
sub _plan_check {
my $self = shift;
unless( $self->{Have_Plan} ) {
local $Level = $Level + 2;
$self->croak("You tried to run a test without a plan");
}
}
#line 1444
sub current_test {
my($self, $num) = @_;
lock($self->{Curr_Test});
if( defined $num ) {
unless( $self->{Have_Plan} ) {
$self->croak("Can't change the current test number without a plan!");
}
$self->{Curr_Test} = $num;
inc/Test/Builder.pm view on Meta::CPAN
elsif( $num < @$test_results ) {
$#{$test_results} = $num - 1;
}
}
return $self->{Curr_Test};
}
#line 1489
sub summary {
my($self) = shift;
return map { $_->{'ok'} } @{ $self->{Test_Results} };
}
#line 1544
sub details {
my $self = shift;
return @{ $self->{Test_Results} };
}
#line 1569
sub todo {
my($self, $pack) = @_;
$pack = $pack || $self->exported_to || $self->caller($Level);
return 0 unless $pack;
no strict 'refs';
return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
: 0;
}
#line 1590
sub caller {
my($self, $height) = @_;
$height ||= 0;
my @caller = CORE::caller($self->level + $height + 1);
return wantarray ? @caller : $caller[0];
}
#line 1602
#line 1616
#'#
sub _sanity_check {
my $self = shift;
$self->_whoa($self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!');
$self->_whoa(!$self->{Have_Plan} and $self->{Curr_Test},
'Somehow your tests ran without a plan!');
$self->_whoa($self->{Curr_Test} != @{ $self->{Test_Results} },
'Somehow you got a different number of results than tests ran!');
}
#line 1637
sub _whoa {
my($self, $check, $desc) = @_;
if( $check ) {
local $Level = $Level + 1;
$self->croak(<<"WHOA");
WHOA! $desc
This should never happen! Please contact the author immediately!
WHOA
}
}
#line 1659
sub _my_exit {
$? = $_[0];
return 1;
}
#line 1672
$SIG{__DIE__} = sub {
# We don't want to muck with death in an eval, but $^S isn't
# totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
# with it. Instead, we use caller. This also means it runs under
# 5.004!
my $in_eval = 0;
for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) {
$in_eval = 1 if $sub =~ /^\(eval\)/;
}
$Test->{Test_Died} = 1 unless $in_eval;
};
sub _ending {
my $self = shift;
$self->_sanity_check();
# Don't bother with an ending if this is a forked copy. Only the parent
# should do the ending.
# Exit if plan() was never called. This is so "require Test::Simple"
# doesn't puke.
# Don't do an ending if we bailed out.
if( ($self->{Original_Pid} != $$) or
inc/Test/Builder/Module.pm view on Meta::CPAN
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' ) {
inc/Test/Builder/Module.pm view on Meta::CPAN
}
@$list = @other;
return @imports;
}
#line 144
sub import_extra {}
#line 175
sub builder {
return Test::Builder->new;
}
1;
inc/Test/More.pm view on Meta::CPAN
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
inc/Test/More.pm view on Meta::CPAN
$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);
inc/Test/More.pm view on Meta::CPAN
$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.
inc/Test/More.pm view on Meta::CPAN
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
inc/Test/More.pm view on Meta::CPAN
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
inc/Test/More.pm view on Meta::CPAN
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
inc/Test/More.pm view on Meta::CPAN
}
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}";
inc/Test/More.pm view on Meta::CPAN
}
$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;
}
inc/Test/More.pm view on Meta::CPAN
$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;
inc/Test/More.pm view on Meta::CPAN
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;
inc/Test/More.pm view on Meta::CPAN
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;
inc/Test/More.pm view on Meta::CPAN
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
inc/Test/Number/Delta.pm view on Meta::CPAN
@ISA = qw( Exporter );
@EXPORT = qw( delta_not_ok delta_ok delta_within delta_not_within );
#line 116
my $Test = Test::Builder->new;
my $Epsilon = 1e-6;
my $Relative = undef;
sub import {
my $self = shift;
my $pack = caller;
my $found = grep /within|relative/, @_;
croak "Can't specify more than one of 'within' or 'relative'"
if $found > 1;
if ($found) {
my ($param,$value) = splice @_, 0, 2;
croak "'$param' parameter must be non-zero"
if $value == 0;
if ($param eq 'within') {
inc/Test/Number/Delta.pm view on Meta::CPAN
}
$Test->exported_to($pack);
$Test->plan(@_);
$self->export_to_level(1, $self, $_) for @EXPORT;
}
#--------------------------------------------------------------------------#
# _check -- recursive function to perform comparison
#--------------------------------------------------------------------------#
sub _check {
my ($p, $q, $epsilon, $name, @indices) = @_;
my ($ok, $diag) = ( 1, q{} ); # assume true
if ( ref $p eq 'ARRAY' || ref $q eq 'ARRAY' ) {
if ( @$p == @$q ) {
for my $i ( 0 .. $#{$p} ) {
my @new_indices;
($ok, $diag, @new_indices) = _check(
$p->[$i],
$q->[$i],
$epsilon,
inc/Test/Number/Delta.pm view on Meta::CPAN
if ( ! $ok ) {
my ($ep, $dp) = _ep_dp( $epsilon );
$diag = sprintf("%.${dp}f and %.${dp}f are not equal" .
" to within %.${ep}f", $p, $q, $epsilon
);
}
}
return ( $ok, $diag, scalar(@indices) ? @indices : () );
}
sub _ep_dp {
my $epsilon = shift;
my ($exp) = sprintf("%e",$epsilon) =~ m/e(.+)/;
my $ep = $exp < 0 ? -$exp : 1;
my $dp = $ep + 1;
return ($ep, $dp);
}
#line 200
#--------------------------------------------------------------------------#
# delta_within()
#--------------------------------------------------------------------------#
#line 237
sub delta_within($$$;$) {
my ($p, $q, $epsilon, $name) = @_;
croak "Value of epsilon to delta_within must be non-zero"
if $epsilon == 0;
$epsilon = abs($epsilon);
my ($ok, $diag, @indices) = _check( $p, $q, $epsilon, $name );
if ( @indices ) {
$diag = "At [" . join( "][", @indices ) . "]: $diag";
}
return $Test->ok($ok,$name) || $Test->diag( $diag );
}
#--------------------------------------------------------------------------#
# delta_ok()
#--------------------------------------------------------------------------#
#line 264
sub delta_ok($$;$) {
my ($p, $q, $name) = @_;
{
local $Test::Builder::Level = $Test::Builder::Level + 1;
my $e = $Relative
? $Relative * (abs($p) > abs($q) ? abs($p) : abs($q))
: $Epsilon;
delta_within( $p, $q, $e, $name );
}
}
#--------------------------------------------------------------------------#
# delta_not_ok()
#--------------------------------------------------------------------------#
#line 292
sub delta_not_within($$$;$) {
my ($p, $q, $epsilon, $name) = @_;
croak "Value of epsilon to delta_not_within must be non-zero"
if $epsilon == 0;
$epsilon = abs($epsilon);
my ($ok, undef, @indices) = _check( $p, $q, $epsilon, $name );
$ok = !$ok;
my ($ep, $dp) = _ep_dp( $epsilon );
my $diag = sprintf("Arguments are equal to within %.${ep}f", $epsilon);
return $Test->ok($ok,$name) || $Test->diag( $diag );
}
#line 315
sub delta_not_ok($$;$) {
my ($p, $q, $name) = @_;
{
local $Test::Builder::Level = $Test::Builder::Level + 1;
my $e = $Relative
? $Relative * (abs($p) > abs($q) ? abs($p) : abs($q))
: $Epsilon;
delta_not_within( $p, $q, $e, $name );
}
}
lib/AI/MaxEntropy.pm view on Meta::CPAN
package AI::MaxEntropy;
use Algorithm::LBFGS;
use AI::MaxEntropy::Model;
use XSLoader;
our $VERSION = '0.20';
XSLoader::load('AI::MaxEntropy', $VERSION);
sub new {
my $class = shift;
my $self = {
smoother => {},
algorithm => {},
@_,
samples => [],
x_bucket => {},
y_bucket => {},
x_list => [],
y_list => [],
lib/AI/MaxEntropy.pm view on Meta::CPAN
f_num => 0,
af_num => 0,
f_freq => [],
f_map => [],
last_cut => -1,
_c => {}
};
return bless $self, $class;
}
sub see {
my ($self, $x, $y, $w) = @_;
$w = 1 if not defined($w);
my ($x1, $y1) = ([], undef);
# preprocess if $x is hashref
$x = [
map {
my $attr = $_;
ref($x->{$attr}) eq 'ARRAY' ?
map { "$attr:$_" } @{$x->{$attr}} : "$_:$x->{$_}"
} keys %$x
lib/AI/MaxEntropy.pm view on Meta::CPAN
# old x
else { push @$x1, $x_id }
# update f_freq
$self->{f_freq}->[$y_id]->[$x_id] += $w;
}
# add the sample
push @{$self->{samples}}, [$x1, $y1, $w];
$self->{last_cut} = -1;
}
sub cut {
my ($self, $t) = @_;
$self->{f_num} = 0;
for my $y (0 .. $self->{y_num} - 1) {
for my $x (0 .. $self->{x_num} - 1) {
if ($self->{f_freq}->[$y]->[$x] >= $t) {
$self->{f_map}->[$y]->[$x] = $self->{f_num};
$self->{f_num}++;
}
else { $self->{f_map}->[$y]->[$x] = -1 }
}
}
$self->{last_cut} = $t;
}
sub forget_all {
my $self = shift;
$self->{samples} = [];
$self->{x_bucket} = {};
$self->{y_bucket} = {};
$self->{x_num} = 0;
$self->{y_num} = 0;
$self->{f_num} = 0;
$self->{x_list} = [];
$self->{y_list} = [];
$self->{af_num} = 0;
$self->{f_freq} = [];
$self->{f_map} = [];
$self->{last_cut} = -1;
$self->{_c} = {};
}
sub _cache {
my $self = shift;
$self->_cache_samples;
$self->_cache_f_map;
}
sub _free_cache {
my $self = shift;
$self->_free_cache_samples;
$self->_free_cache_f_map;
}
sub learn {
my $self = shift;
# cut 0 for default
$self->cut(0) if $self->{last_cut} == -1;
# initialize
$self->{lambda} = [map { 0 } (1 .. $self->{f_num})];
$self->_cache;
# optimize
my $type = $self->{algorithm}->{type} || 'lbfgs';
if ($type eq 'lbfgs') {
my $o = Algorithm::LBFGS->new(%{$self->{algorithm}});
$o->fmin(\&_neg_log_likelihood, $self->{lambda},
$self->{algorithm}->{progress_cb}, $self);
}
elsif ($type eq 'gis') {
die 'GIS is not applicable'
if $self->{af_num} == -1 or $self->{last_cut} != 0;
my $progress_cb = $self->{algorithm}->{progress_cb};
$progress_cb = sub {
print "$_[0]: |lambda| = $_[3], |d_lambda| = $_[4]\n"; 0;
} if defined($progress_cb) and $progress_cb eq 'verbose';
my $epsilon = $self->{algorithm}->{epsilon} || 1e-3;
$self->{lambda} = $self->_apply_gis($progress_cb, $epsilon);
}
else { die "$type is not a valid algorithm type" }
# finish
$self->_free_cache;
return $self->_create_model;
}
sub _create_model {
my $self = shift;
my $model = AI::MaxEntropy::Model->new;
$model->{$_} = ref($self->{$_}) eq 'ARRAY' ? [@{$self->{$_}}] :
ref($self->{$_}) eq 'HASH' ? {%{$self->{$_}}} :
$self->{$_}
for qw/x_list y_list lambda x_num y_num f_num x_bucket y_bucket/;
$model->{f_map}->[$_] = [@{$self->{f_map}->[$_]}]
for (0 .. $self->{y_num} - 1);
return $model;
}
lib/AI/MaxEntropy/Model.pm view on Meta::CPAN
use strict;
use warnings;
package AI::MaxEntropy::Model;
use YAML::Syck;
our $VERSION = '0.20';
sub new {
my ($class, $model) = @_;
my $self = bless {}, $class;
$self->load($model) if defined($model);
return $self;
}
sub load {
my ($self, $file) = @_;
my $model = LoadFile($file);
($self->{x_list}, $self->{y_list}, $self->{f_map}, $self->{lambda})
= @$model;
$self->{x_num} = scalar(@{$self->{x_list}});
$self->{y_num} = scalar(@{$self->{y_list}});
$self->{f_num} = scalar(@{$self->{lambda}});
$self->{x_bucket}->{$self->{x_list}->[$_]} = $_
for (0 .. $self->{x_num} - 1);
$self->{y_bucket}->{$self->{y_list}->[$_]} = $_
for (0 .. $self->{y_num} - 1);
}
sub save {
my ($self, $file) = @_;
my $data = [
$self->{x_list},
$self->{y_list},
$self->{f_map},
$self->{lambda}
];
DumpFile($file, $data);
}
sub all_x { @{$_[0]->{x_list}} }
sub all_labels { @{$_[0]->{y_list}} }
sub score {
my $self = shift;
my ($x, $y) = @_;
# preprocess if $x is hashref
$x = [
map {
my $attr = $_;
ref($x->{$attr}) eq 'ARRAY' ?
map { "$attr:$_" } @{$x->{$attr}} : "$_:$x->{$_}"
} keys %$x
] if ref($x) eq 'HASH';
lib/AI/MaxEntropy/Model.pm view on Meta::CPAN
if (defined($x1)) {
my $lambda_i = $self->{f_map}->[$y1]->[$x1];
$lambda_f += $self->{lambda}->[$lambda_i]
if $lambda_i != -1;
}
}
}
return $lambda_f;
}
sub predict {
my $self = shift;
my $x = shift;
my @score = map { $self->score($x => $_) } @{$self->{y_list}};
my ($max_score, $max_y) = (undef, undef);
for my $y (0 .. $self->{y_num} - 1) {
($max_score, $max_y) = ($score[$y], $y) if not defined($max_y);
($max_score, $max_y) = ($score[$y], $y) if $score[$y] > $max_score;
}
return $self->{y_list}->[$max_y];
}
lib/AI/MaxEntropy/Util.pm view on Meta::CPAN
our $VERSION = '0.20';
our @ISA = qw/Exporter/;
our @EXPORT_OK =
qw/traverse_partially map_partially train_and_test precision recall/;
our %EXPORT_TAGS =
(all => [@EXPORT_OK]);
sub traverse_partially(&$$;$) {
my ($code, $samples, $pattern, $t) = @_;
$t ||= 'x';
my ($p, $n) = (length($pattern), scalar(@$samples));
for my $i (grep { substr($pattern, $_, 1) eq $t } (0 .. $p - 1)) {
for (int($n * $i / $p) .. int($n * ($i + 1) / $p) - 1) {
$_ = $samples->[$_];
$code->();
}
}
}
sub map_partially(&$$;$) {
my ($code, $samples, $pattern, $t) = @_;
my @r;
traverse_partially { push @r, $code->($_) } $samples, $pattern, $t;
return \@r;
}
sub train_and_test {
my ($me, $samples, $pattern) = @_;
traverse_partially { $me->see(@$_) } $samples, $pattern, 'x';
my $m = $me->learn;
my $r = map_partially { [$_ => $m->predict($_->[0])] }
$samples, $pattern, 'o';
return ($r, $m);
}
sub precision {
my $r = shift;
my ($c, $n) = (0, 0);
for (@$r) {
my $w = defined($_->[0]->[2]) ? $_->[0]->[2] : 1;
$n += $w;
$c += $w if $_->[0]->[1] eq $_->[1];
}
return $c / $n;
}
sub recall {
my $r = shift;
my $label = shift;
my ($c, $n) = (0, 0);
for (@$r) {
if ($_->[0]->[1] eq $label) {
my $w = defined($_->[0]->[2]) ? $_->[0]->[2] : 1;
$n += $w;
$c += $w if $_->[1] eq $label;
}
}
my @srcext = qw( xs c h cc cpp );
my $srcext = join '|', @srcext;
if (@ARGV) {
my %seen;
@files = grep { -f && !exists $seen{$_} } map { glob $_ } @ARGV;
}
else {
eval {
require File::Find;
File::Find::find(sub {
$File::Find::name =~ /\.($srcext)$/i
and push @files, $File::Find::name;
}, '.');
};
if ($@) {
@files = map { glob "*.$_" } @srcext;
}
}
if (!@ARGV || $opt{filter}) {
else {
info("Looks good");
}
}
close PATCH if $patch_opened;
exit 0;
sub mydiff
{
local *F = shift;
my($file, $str) = @_;
my $diff;
if (exists $opt{diff}) {
$diff = run_diff($opt{diff}, $file, $str);
}
if (!defined $diff and can_use('Text::Diff')) {
if (!defined $diff) {
error("Cannot generate a diff. Please install Text::Diff or use --copy.");
return;
}
print F $diff;
}
sub run_diff
{
my($prog, $file, $str) = @_;
my $tmp = 'dppptemp';
my $suf = 'aaa';
my $diff = '';
local *F;
while (-e "$tmp.$suf") { $suf++ }
$tmp = "$tmp.$suf";
unlink $tmp;
}
else {
error("Cannot open '$tmp' for writing: $!");
}
return undef;
}
sub can_use
{
eval "use @_;";
return $@ eq '';
}
sub rec_depend
{
my $func = shift;
my %seen;
return () unless exists $depends{$func};
grep !$seen{$_}++, map { ($_, rec_depend($_)) } @{$depends{$func}};
}
sub parse_version
{
my $ver = shift;
if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
return ($1, $2, $3);
}
elsif ($ver !~ /^\d+\.[\d_]+$/) {
die "cannot parse version '$ver'\n";
}
if ($r < 5 || ($r == 5 && $v < 6)) {
if ($s % 10) {
die "cannot parse version '$ver'\n";
}
}
return ($r, $v, $s);
}
sub format_version
{
my $ver = shift;
$ver =~ s/$/000000/;
my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
$v = int $v;
$s = int $s;
if ($r < 5 || ($r == 5 && $v < 6)) {
$ver = sprintf "%d.%03d", $r, $v;
$s > 0 and $ver .= sprintf "_%02d", $s;
return $ver;
}
return sprintf "%d.%d.%d", $r, $v, $s;
}
sub info
{
$opt{quiet} and return;
print @_, "\n";
}
sub diag
{
$opt{quiet} and return;
$opt{diag} and print @_, "\n";
}
sub warning
{
$opt{quiet} and return;
print "*** ", @_, "\n";
}
sub error
{
print "*** ERROR: ", @_, "\n";
}
my %given_hints;
sub hint
{
$opt{quiet} and return;
$opt{hints} or return;
my $func = shift;
exists $hints{$func} or return;
$given_hints{$func}++ and return;
my $hint = $hints{$func};
$hint =~ s/^/ /mg;
print " --- hint for $func ---\n", $hint;
}
sub usage
{
my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms;
my %M = ( 'I' => '*' );
$usage =~ s/^\s*perl\s+\S+/$^X $0/;
$usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g;
print <<ENDUSAGE;
Usage: $usage
# define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END
#endif
#ifndef XPUSHu
# define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END
#endif
#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
/* Replace: 1 */
# define PL_DBsingle DBsingle
# define PL_DBsub DBsub
# define PL_Sv Sv
# define PL_compiling compiling
# define PL_copline copline
# define PL_curcop curcop
# define PL_curstash curstash
# define PL_debstash debstash
# define PL_defgv defgv
# define PL_diehook diehook
# define PL_dirty dirty
# define PL_dowarn dowarn
t/01-samples.t view on Meta::CPAN
use strict;
use warnings;
use Test::More tests => 10;
use Test::Number::Delta within => 1e-5;
my $__;
sub NAME { $__ = shift };
###
NAME 'Load the module';
BEGIN { use_ok 'AI::MaxEntropy' }
###
NAME 'Create a Maximum Entropy Leaner';
my $me = AI::MaxEntropy->new;
ok $me,
$__;
t/02-learn_by_lbfgs.t view on Meta::CPAN
use strict;
use warnings;
use Test::More tests => 5;
use Test::Number::Delta within => 1e-5;
my $__;
sub NAME { $__ = shift };
###
NAME 'Load the module';
BEGIN { use_ok 'AI::MaxEntropy' }
my $me = AI::MaxEntropy->new(smoother => {});
$me->see(['round', 'smooth', 'red'] => 'apple' => 2);
$me->see(['long', 'smooth', 'yellow'] => 'banana' => 3);
$me->cut(0);
$me->_cache;
t/03-learn_by_gis.t view on Meta::CPAN
use strict;
use warnings;
use Test::More tests => 3;
use Test::Number::Delta within => 1e-5;
my $__;
sub NAME { $__ = shift };
###
NAME 'Load the module';
BEGIN { use_ok 'AI::MaxEntropy' }
my ($lambda, $d_lambda, $p1_f, $n);
my $zero = 1e-5;
my $me = AI::MaxEntropy->new();
$me->see(['round', 'smooth', 'red'] => 'apple' => 2);
$me->see(['long', 'smooth', 'yellow'] => 'banana' => 3);
$me->{algorithm}->{type} = 'gis';
###
NAME 'The first iteration';
$me->{algorithm}->{progress_cb} =
sub { ($lambda, $d_lambda) = ($_[1], $_[2]); 1 };
$me->learn;
$p1_f = [
2 * (exp(0) / (exp(0) + exp(0))),
2 * (exp(0) / (exp(0) + exp(0))) + 3 * (exp(0) / (exp(0) + exp(0))),
2 * (exp(0) / (exp(0) + exp(0))),
3 * (exp(0) / (exp(0) + exp(0))),
3 * (exp(0) / (exp(0) + exp(0))),
2 * (exp(0) / (exp(0) + exp(0))),
2 * (exp(0) / (exp(0) + exp(0))) + 3 * (exp(0) / (exp(0) + exp(0))),
2 * (exp(0) / (exp(0) + exp(0))),
t/03-learn_by_gis.t view on Meta::CPAN
(1.0 / 3) * log(3 / $p1_f->[8]),
(1.0 / 3) * log(3 / $p1_f->[9])
]
],
$__;
###
NAME 'The second iteration';
my @l = @$lambda;
$me->{algorithm}->{progress_cb} =
sub { ($lambda, $d_lambda) = ($_[1], $_[2]); $n++; $n >= 2 ? 1 : 0 };
$me->learn;
my $p0 = exp($l[0] + $l[1] + $l[2]) + exp($l[5] + $l[6] + $l[7]);
my $p0_0 = exp($l[0] + $l[1] + $l[2]) / $p0;
my $p0_1 = exp($l[5] + $l[6] + $l[7]) / $p0;
my $p1 = exp($l[6] + $l[8] + $l[9]) + exp($l[1] + $l[3] + $l[4]);
my $p1_0 = exp($l[1] + $l[3] + $l[4]) / $p1;
my $p1_1 = exp($l[6] + $l[8] + $l[9]) / $p1;
$p1_f = [
2 * $p0_0,
2 * $p0_0 + 3 * $p1_0,
t/04-model.t view on Meta::CPAN
use strict;
use warnings;
use Test::More tests => 5;
use Test::Number::Delta within => 1e-5;
my $__;
sub NAME { $__ = shift };
###
NAME 'Load AI::MaxEntropy';
BEGIN { use_ok 'AI::MaxEntropy' }
###
NAME 'Load AI::MaxEntropy::Model';
BEGIN { use_ok 'AI::MaxEntropy::Model' }
my $me = AI::MaxEntropy->new;
t/05-util.t view on Meta::CPAN
use strict;
use warnings;
use Test::More tests => 8;
use Test::Number::Delta within => 1e-5;
my $__;
sub NAME { $__ = shift };
###
NAME 'Load the module';
BEGIN { use_ok 'AI::MaxEntropy::Util', qw(:all) }
###
NAME 'traverse_partially x-x-x';
my $a = [1, 2, 3, 4, 5];
my $b = [];
traverse_partially { push @$b, $_ } $a, 'x-x-x';
( run in 0.374 second using v1.01-cache-2.11-cpan-a5abf4f5562 )