AI-MaxEntropy
view release on metacpan or search on metacpan
The MIT License
Copyright (c) 2008, Laye Suen
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
THE SOFTWARE.
The entry "type => ..." specifies which algorithm is used for the
optimization. Valid values include:
'lbfgs' Limited-memory Broyden-Fletcher-Goldfarb-Shanno (L-BFGS)
'gis' General Iterative Scaling (GIS)
If ommited, 'lbfgs' is used by default.
progress_cb
The entry "progress_cb => ..." specifies the progress callback
subroutine which is used to trace the process of the algorithm. The
specified callback routine will be called at each iteration of the
algorithm.
For L-BFGS, "progress_cb" will be directly passed to "fmin" in
Algorithm::LBFGS. f(x) is the negative log-likelihood of current lambda
vector.
For GIS, the "progress_cb" is supposed to have a prototype like
progress_cb(i, lambda, d_lambda, lambda_norm, d_lambda_norm)
COPYRIGHT AND LICENSE
The MIT License
Copyright (C) 2008, Laye Suen
Permission is hereby granted, free of charge, to any person obtaining a
copy of this software and associated documentation files (the
"Software"), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:
The above copyright notice and this permission notice shall be included
in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
REFERENCE
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);
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"};
}
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
# 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) ) {
open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!";
my $in_pod = 0;
while ( <PKGFILE> ) {
$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;
}
}
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
# merge both kinds of requires into prereq_pm
my $prereq = ($args->{PREREQ_PM} ||= {});
%$prereq = ( %$prereq,
map { @$_ }
map { @$_ }
grep $_,
($self->build_requires, $self->requires)
);
# 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";
}
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.pm view on Meta::CPAN
optimization. Valid values include:
'lbfgs' Limited-memory Broyden-Fletcher-Goldfarb-Shanno (L-BFGS)
'gis' General Iterative Scaling (GIS)
If ommited, C<'lbfgs'> is used by default.
=head3 progress_cb
The entry C<progress_cb =E<gt> ...> specifies the progress callback
subroutine which is used to trace the process of the algorithm.
The specified callback routine will be called at each iteration of the
algorithm.
For L-BFGS, C<progress_cb> will be directly passed to
L<Algorithm::LBFGS/fmin>. C<f(x)> is the negative log-likelihood of current
lambda vector.
For GIS, the C<progress_cb> is supposed to have a prototype like
progress_cb(i, lambda, d_lambda, lambda_norm, d_lambda_norm)
lib/AI/MaxEntropy.pm view on Meta::CPAN
=head1 COPYRIGHT AND LICENSE
The MIT License
Copyright (C) 2008, Laye Suen
Permission is hereby granted, free of charge, to any person obtaining a
copy of this software and associated documentation files (the "Software"),
to deal in the Software without restriction, including without limitation
the rights to use, copy, modify, merge, publish, distribute, sublicense,
and/or sell copies of the Software, and to permit persons to whom the
Software is furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
DEALINGS IN THE SOFTWARE.
=head1 REFERENCE
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/Model.pm view on Meta::CPAN
=head1 COPYRIGHT AND LICENSE
The MIT License
Copyright (C) 2008, Laye Suen
Permission is hereby granted, free of charge, to any person obtaining a
copy of this software and associated documentation files (the "Software"),
to deal in the Software without restriction, including without limitation
the rights to use, copy, modify, merge, publish, distribute, sublicense,
and/or sell copies of the Software, and to permit persons to whom the
Software is furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
DEALINGS IN THE SOFTWARE.
=head1 REFERENCE
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;
}
}
lib/AI/MaxEntropy/Util.pm view on Meta::CPAN
=head1 COPYRIGHT AND LICENSE
The MIT License
Copyright (C) 2008, Laye Suen
Permission is hereby granted, free of charge, to any person obtaining a
copy of this software and associated documentation files (the "Software"),
to deal in the Software without restriction, including without limitation
the rights to use, copy, modify, merge, publish, distribute, sublicense,
and/or sell copies of the Software, and to permit persons to whom the
Software is furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
DEALINGS IN THE SOFTWARE.
PERL_MAGIC_overload|5.007002||p
PERL_MAGIC_pos|5.007002||p
PERL_MAGIC_qr|5.007002||p
PERL_MAGIC_regdata|5.007002||p
PERL_MAGIC_regdatum|5.007002||p
PERL_MAGIC_regex_global|5.007002||p
PERL_MAGIC_shared_scalar|5.007003||p
PERL_MAGIC_shared|5.007003||p
PERL_MAGIC_sigelem|5.007002||p
PERL_MAGIC_sig|5.007002||p
PERL_MAGIC_substr|5.007002||p
PERL_MAGIC_sv|5.007002||p
PERL_MAGIC_taint|5.007002||p
PERL_MAGIC_tiedelem|5.007002||p
PERL_MAGIC_tiedscalar|5.007002||p
PERL_MAGIC_tied|5.007002||p
PERL_MAGIC_utf8|5.008001||p
PERL_MAGIC_uvar_elem|5.007003||p
PERL_MAGIC_uvar|5.007002||p
PERL_MAGIC_vec|5.007002||p
PERL_MAGIC_vstring|5.008001||p
PERL_UINT_MIN|5.004000||p
PERL_ULONG_MAX|5.004000||p
PERL_ULONG_MIN|5.004000||p
PERL_UNUSED_DECL|5.007002||p
PERL_UQUAD_MAX|5.004000||p
PERL_UQUAD_MIN|5.004000||p
PERL_USHORT_MAX|5.004000||p
PERL_USHORT_MIN|5.004000||p
PERL_VERSION|5.006000||p
PL_DBsingle|||pn
PL_DBsub|||pn
PL_DBtrace|||n
PL_Sv|5.005000||p
PL_compiling|5.004050||p
PL_copline|5.005000||p
PL_curcop|5.004050||p
PL_curstash|5.004050||p
PL_debstash|5.004050||p
PL_defgv|5.004050||p
PL_diehook|5.004050||p
PL_dirty|5.004050||p
ck_retarget|||
ck_return|||
ck_rfun|||
ck_rvconst|||
ck_sassign|||
ck_select|||
ck_shift|||
ck_sort|||
ck_spair|||
ck_split|||
ck_subr|||
ck_substr|||
ck_svconst|||
ck_trunc|||
ck_unpack|||
cl_and|||
cl_anything|||
cl_init_zero|||
cl_init|||
cl_is_anything|||
cl_or|||
closest_cop|||
dofile|||
dofindlabel|||
doform|||
doing_taint||5.008001|n
dooneliner|||
doopen_pm|||
doparseform|||
dopoptoeval|||
dopoptolabel|||
dopoptoloop|||
dopoptosub_at|||
dopoptosub|||
dounwind|||
dowantarray|||
dump_all||5.006000|
dump_eval||5.006000|
dump_fds|||
dump_form||5.006000|
dump_indent||5.006000|v
dump_mstats|||
dump_packsubs||5.006000|
dump_sub||5.006000|
dump_vindent||5.006000|
dumpuntil|||
dup_attrlist|||
emulate_eaccess|||
eval_pv|5.006000||p
eval_sv|5.006000||p
expect_number|||
fbm_compile||5.005000|
fbm_instr||5.005000|
fd_on_nosuid_fs|||
form||5.004000|v
fp_dup|||
fprintf_nocontext|||vn
free_global_struct|||
free_tied_hv_pool|||
free_tmps|||
gen_constant_list|||
get_av|5.006000||p
get_context||5.006000|n
get_cv|5.006000||p
get_db_sub|||
get_debug_opts|||
get_hash_seed|||
get_hv|5.006000||p
get_mstats|||
get_no_modify|||
get_num|||
get_op_descs||5.005000|
get_op_names||5.005000|
get_opargs|||
get_ppaddr||5.006000|
isALPHA|||
isDIGIT|||
isLOWER|||
isSPACE|||
isUPPER|||
is_an_int|||
is_gv_magical_sv|||
is_gv_magical|||
is_handle_constructor|||
is_list_assignment|||
is_lvalue_sub||5.007001|
is_uni_alnum_lc||5.006000|
is_uni_alnumc_lc||5.006000|
is_uni_alnumc||5.006000|
is_uni_alnum||5.006000|
is_uni_alpha_lc||5.006000|
is_uni_alpha||5.006000|
is_uni_ascii_lc||5.006000|
is_uni_ascii||5.006000|
is_uni_cntrl_lc||5.006000|
is_uni_cntrl||5.006000|
magic_freearylen_p|||
magic_freeovrld|||
magic_freeregexp|||
magic_getarylen|||
magic_getdefelem|||
magic_getglob|||
magic_getnkeys|||
magic_getpack|||
magic_getpos|||
magic_getsig|||
magic_getsubstr|||
magic_gettaint|||
magic_getuvar|||
magic_getvec|||
magic_get|||
magic_killbackrefs|||
magic_len|||
magic_methcall|||
magic_methpack|||
magic_nextpack|||
magic_regdata_cnt|||
magic_setenv|||
magic_setfm|||
magic_setglob|||
magic_setisa|||
magic_setmglob|||
magic_setnkeys|||
magic_setpack|||
magic_setpos|||
magic_setregexp|||
magic_setsig|||
magic_setsubstr|||
magic_settaint|||
magic_setutf8|||
magic_setuvar|||
magic_setvec|||
magic_set|||
magic_sizepack|||
magic_wipepack|||
magicname|||
make_trie|||
malloced_size|||n
scan_const|||
scan_formline|||
scan_heredoc|||
scan_hex|||
scan_ident|||
scan_inputsymbol|||
scan_num||5.007001|
scan_oct|||
scan_pat|||
scan_str|||
scan_subst|||
scan_trans|||
scan_version||5.009001|
scan_vstring||5.008001|
scan_word|||
scope|||
screaminstr||5.005000|
seed|||
set_context||5.006000|n
set_csh|||
set_numeric_local||5.006000|
share_hek_flags|||
share_hek|||
si_dup|||
sighandler|||n
simplify_sort|||
skipspace|||
sortsv||5.007003|
ss_dup|||
stack_grow|||
start_glob|||
start_subparse||5.004000|
stashpv_hvname_match||5.009003|
stdize_locale|||
strEQ|||
strGE|||
strGT|||
strLE|||
strLT|||
strNE|||
str_to_version||5.006000|
strnEQ|||
strnNE|||
study_chunk|||
sub_crush_depth|||
sublex_done|||
sublex_push|||
sublex_start|||
sv_2bool|||
sv_2cv|||
sv_2io|||
sv_2iuv_non_preserve|||
sv_2iv_flags||5.009001|
sv_2iv|||
sv_2mortal|||
sv_2nv|||
sv_2pv_flags||5.007002|
sv_2pv_nolen|5.006000||p
swash_fetch||5.007002|
swash_init||5.006000|
sys_intern_clear|||
sys_intern_dup|||
sys_intern_init|||
taint_env|||
taint_proper|||
tmps_grow||5.006000|
toLOWER|||
toUPPER|||
to_byte_substr|||
to_uni_fold||5.007003|
to_uni_lower_lc||5.006000|
to_uni_lower||5.007003|
to_uni_title_lc||5.006000|
to_uni_title||5.007003|
to_uni_upper_lc||5.006000|
to_uni_upper||5.007003|
to_utf8_case||5.007003|
to_utf8_fold||5.007003|
to_utf8_lower||5.007003|
to_utf8_substr|||
to_utf8_title||5.007003|
to_utf8_upper||5.007003|
tokeq|||
tokereport|||
too_few_arguments|||
too_many_arguments|||
unlnk|||
unpack_rec|||
unpack_str||5.007003|
unpackstring||5.008001|
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
line_t oldline = PL_curcop->cop_line;
PL_curcop->cop_line = PL_copline;
PL_hints &= ~HINT_BLOCK_SCOPE;
if (stash)
PL_curstash = PL_curcop->cop_stash = stash;
newSUB(
#if ((PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22)))
start_subparse(),
#elif ((PERL_VERSION == 3) && (PERL_SUBVERSION == 22))
start_subparse(0),
#else /* 5.003_23 onwards */
start_subparse(FALSE, 0),
#endif
newSVOP(OP_CONST, 0, newSVpv(name,0)),
newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
);
PL_hints = oldhints;
PL_curcop->cop_stash = old_cop_stash;
PL_curstash = old_curstash;
#endif
#ifndef PERL_MAGIC_vec
# define PERL_MAGIC_vec 'v'
#endif
#ifndef PERL_MAGIC_utf8
# define PERL_MAGIC_utf8 'w'
#endif
#ifndef PERL_MAGIC_substr
# define PERL_MAGIC_substr 'x'
#endif
#ifndef PERL_MAGIC_defelem
# define PERL_MAGIC_defelem 'y'
#endif
#ifndef PERL_MAGIC_glob
# define PERL_MAGIC_glob '*'
#endif
const char *s = start;
STRLEN len = *len_p;
UV value = 0;
NV value_nv = 0;
const UV max_div_8 = UV_MAX / 8;
bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
bool overflowed = FALSE;
for (; len-- && *s; s++) {
/* gcc 2.95 optimiser not smart enough to figure that this subtraction
out front allows slicker code. */
int digit = *s - '0';
if (digit >= 0 && digit <= 7) {
/* Write it in this wonky order with a goto to attempt to get the
compiler to make the common case integer-only loop pretty tight.
*/
redo:
if (!overflowed) {
if (value <= max_div_8) {
value = (value << 3) | digit;
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.636 second using v1.01-cache-2.11-cpan-88abd93f124 )