Result:
found more than 108 distributions - search limited to the first 2001 files matching your query
( run in 0.645 )
ACME-THEDANIEL-Utils
view release on metacpan or search on metacpan
lib/ACME/THEDANIEL/Utils.pm view on Meta::CPAN
=head2 sum
=cut
sub sum {
my $sum;
foreach my $num ( @_ ) {
if ( !looks_like_number( $num ) ) {
croak "Invalid input: $num"
}
$sum += $num;
}
return $sum;
}
=head1 AUTHOR
Daniel jones, C<< <dtj at someplace.com> >>
lib/ACME/THEDANIEL/Utils.pm view on Meta::CPAN
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc ACME::THEDANIEL::Utils
You can also look for information at:
=over 4
ACME-YAPC-NA-2012
view release on metacpan or search on metacpan
lib/ACME/YAPC/NA/2012.pm view on Meta::CPAN
Quick summary of what the module does.
Perhaps a little code snippet.
use ACME::YAPC::NA::2012;
my $foo = ACME::YAPC::NA::2012->new();
...
=head1 EXPORT
A list of functions that can be exported. You can delete this section
if you don't export anything, such as for a purely object-oriented module.
lib/ACME/YAPC/NA/2012.pm view on Meta::CPAN
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc ACME::YAPC::NA::2012
You can also look for information at:
=over 4
ACME-ltharris
view release on metacpan or search on metacpan
lib/ACME/ltharris.pm view on Meta::CPAN
Quick summary of what the module does.
Perhaps a little code snippet.
use ACME::ltharris;
my $foo = ACME::ltharris->new();
...
=head1 EXPORT
A list of functions that can be exported. You can delete this section
if you don't export anything, such as for a purely object-oriented module.
lib/ACME/ltharris.pm view on Meta::CPAN
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc ACME::ltharris
You can also look for information at:
=over 4
ADAMK-Release
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
use File::Find ();
use File::Path ();
use vars qw{$VERSION $MAIN};
BEGIN {
# All Module::Install core packages now require synchronised versions.
# This will be used to ensure we don't accidentally load old or
# different versions of modules.
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
$VERSION = '1.06';
# Storage for the pseudo-singleton
$MAIN = undef;
*inc::Module::Install::VERSION = *VERSION;
@inc::Module::Install::ISA = __PACKAGE__;
}
sub import {
my $class = shift;
my $self = $class->new(@_);
my $who = $self->_caller;
#-------------------------------------------------------------
# all of the following checks should be included in import(),
# to allow "eval 'require Module::Install; 1' to test
# installation of Module::Install. (RT #51267)
#-------------------------------------------------------------
# Whether or not inc::Module::Install is actually loaded, the
# $INC{inc/Module/Install.pm} is what will still get set as long as
# the caller loaded module this in the documented manner.
# If not set, the caller may NOT have loaded the bundled version, and thus
# they may not have a MI version that works with the Makefile.PL. This would
# result in false errors or unexpected behaviour. And we don't want that.
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
unless ( $INC{$file} ) { die <<"END_DIE" }
Please invoke ${\__PACKAGE__} with:
use inc::${\__PACKAGE__};
not:
use ${\__PACKAGE__};
END_DIE
# This reportedly fixes a rare Win32 UTC file time issue, but
# as this is a non-cross-platform XS module not in the core,
# we shouldn't really depend on it. See RT #24194 for detail.
# (Also, this module only supports Perl 5.6 and above).
eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006;
# If the script that is loading Module::Install is from the future,
# then make will detect this and cause it to re-run over and over
# again. This is bad. Rather than taking action to touch it (which
# is unreliable on some platforms and requires write permissions)
# for now we should catch this and refuse to run.
if ( -f $0 ) {
my $s = (stat($0))[9];
# If the modification time is only slightly in the future,
# sleep briefly to remove the problem.
my $a = $s - time;
if ( $a > 0 and $a < 5 ) { sleep 5 }
# Too far in the future, throw an error.
my $t = time;
if ( $s > $t ) { die <<"END_DIE" }
Your installer $0 has a modification time in the future ($s > $t).
This is known to create infinite loops in make.
Please correct this, then run $0 again.
END_DIE
}
# Build.PL was formerly supported, but no longer is due to excessive
# difficulty in implementing every single feature twice.
if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
Module::Install no longer supports Build.PL.
It was impossible to maintain duel backends, and has been deprecated.
Please remove all Build.PL files and only use the Makefile.PL installer.
END_DIE
#-------------------------------------------------------------
# To save some more typing in Module::Install installers, every...
# use inc::Module::Install
# ...also acts as an implicit use strict.
$^H |= strict::bits(qw(refs subs vars));
#-------------------------------------------------------------
unless ( -f $self->{file} ) {
foreach my $key (keys %INC) {
delete $INC{$key} if $key =~ /Module\/Install/;
}
local $^W;
require "$self->{path}/$self->{dispatch}.pm";
File::Path::mkpath("$self->{prefix}/$self->{author}");
$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
$self->{admin}->init;
@_ = ($class, _self => $self);
goto &{"$self->{name}::import"};
}
local $^W;
*{"${who}::AUTOLOAD"} = $self->autoload;
$self->preload;
# Unregister loader and worker packages so subdirs can use them again
delete $INC{'inc/Module/Install.pm'};
delete $INC{'Module/Install.pm'};
# Save to the singleton
$MAIN = $self;
return 1;
}
sub autoload {
my $self = shift;
my $who = $self->_caller;
my $cwd = Cwd::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;
}
unless ($$sym =~ s/([^:]+)$//) {
# XXX: it looks like we can't retrieve the missing function
# via $$sym (usually $main::AUTOLOAD) in this case.
# I'm still wondering if we should slurp Makefile.PL to
# get some context or not ...
my ($package, $file, $line) = caller;
die <<"EOT";
Unknown function is found at $file line $line.
Execution of $file aborted due to runtime errors.
If you're a contributor to a project, you may need to install
some Module::Install extensions from CPAN (or other repository).
If you're a user of a module, please contact the author.
EOT
}
my $method = $1;
if ( uc($method) eq $method ) {
# Do nothing
return;
} elsif ( $method =~ /^_/ and $self->can($method) ) {
# Dispatch to the root M:I class
return $self->$method(@_);
}
# Dispatch to the appropriate plugin
unshift @_, ( $self, $1 );
goto &{$self->can('call')};
};
}
sub preload {
my $self = shift;
unless ( $self->{extensions} ) {
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
);
}
my @exts = @{$self->{extensions}};
unless ( @exts ) {
@exts = $self->{admin}->load_all_extensions;
}
my %seen;
foreach my $obj ( @exts ) {
while (my ($method, $glob) = each %{ref($obj) . '::'}) {
next unless $obj->can($method);
next if $method =~ /^_/;
next if $method eq uc($method);
$seen{$method}++;
}
}
my $who = $self->_caller;
foreach my $name ( sort keys %seen ) {
local $^W;
*{"${who}::$name"} = sub {
${"${who}::AUTOLOAD"} = "${who}::$name";
goto &{"${who}::AUTOLOAD"};
};
}
}
sub new {
my ($class, %args) = @_;
delete $INC{'FindBin.pm'};
{
# to suppress the redefine warning
local $SIG{__WARN__} = sub {};
require FindBin;
}
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
delete $args{prefix};
}
return $args{_self} if $args{_self};
$args{dispatch} ||= 'Admin';
$args{prefix} ||= 'inc';
$args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
$args{bundle} ||= 'inc/BUNDLES';
$args{base} ||= $base_path;
$class =~ s/^\Q$args{prefix}\E:://;
$args{name} ||= $class;
$args{version} ||= $class->VERSION;
unless ( $args{path} ) {
$args{path} = $args{name};
$args{path} =~ s!::!/!g;
}
$args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
$args{wrote} = 0;
bless( \%args, $class );
}
sub call {
my ($self, $method) = @_;
my $obj = $self->load($method) or return;
splice(@_, 0, 2, $obj);
goto &{$obj->can($method)};
}
sub load {
my ($self, $method) = @_;
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
) unless $self->{extensions};
foreach my $obj (@{$self->{extensions}}) {
return $obj if $obj->can($method);
}
my $admin = $self->{admin} or die <<"END_DIE";
The '$method' method does not exist in the '$self->{prefix}' path!
Please remove the '$self->{prefix}' directory and run $0 again to load it.
END_DIE
my $obj = $admin->load($method, 1);
push @{$self->{extensions}}, $obj;
$obj;
}
sub load_extensions {
my ($self, $path, $top) = @_;
my $should_reload = 0;
unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
unshift @INC, $self->{prefix};
$should_reload = 1;
}
foreach my $rv ( $self->find_extensions($path) ) {
my ($file, $pkg) = @{$rv};
next if $self->{pathnames}{$pkg};
local $@;
my $new = eval { local $^W; require $file; $pkg->can('new') };
unless ( $new ) {
warn $@ if $@;
next;
}
$self->{pathnames}{$pkg} =
$should_reload ? delete $INC{$file} : $INC{$file};
push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
}
$self->{extensions} ||= [];
}
sub find_extensions {
my ($self, $path) = @_;
my @found;
File::Find::find( sub {
my $file = $File::Find::name;
return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
my $subpath = $1;
return if lc($subpath) eq lc($self->{dispatch});
$file = "$self->{path}/$subpath.pm";
my $pkg = "$self->{name}::$subpath";
$pkg =~ s!/!::!g;
# If we have a mixed-case package name, assume case has been preserved
# correctly. Otherwise, root through the file to locate the case-preserved
# version of the package name.
if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
my $content = Module::Install::_read($subpath . '.pm');
my $in_pod = 0;
foreach ( split //, $content ) {
$in_pod = 1 if /^=\w/;
$in_pod = 0 if /^=cut/;
next if ($in_pod || /^=cut/); # skip pod text
next if /^\s*#/; # and comments
if ( m/^\s*package\s+($pkg)\s*;/i ) {
$pkg = $1;
last;
}
}
}
push @found, [ $file, $pkg ];
}, $path ) if -d $path;
@found;
}
#####################################################################
# Common Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
# Done in evals to avoid confusing Perl::MinimumVersion
eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _read {
local *FH;
open( FH, '<', $_[0] ) or die "open($_[0]): $!";
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $string;
}
END_NEW
sub _read {
local *FH;
open( FH, "< $_[0]" ) or die "open($_[0]): $!";
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $string;
}
END_OLD
sub _readperl {
my $string = Module::Install::_read($_[0]);
$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
$string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
$string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
return $string;
}
sub _readpod {
my $string = Module::Install::_read($_[0]);
$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
return $string if $_[0] =~ /\.pod\z/;
$string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
$string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
$string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg;
$string =~ s/^\n+//s;
return $string;
}
# Done in evals to avoid confusing Perl::MinimumVersion
eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _write {
local *FH;
open( FH, '>', $_[0] ) or die "open($_[0]): $!";
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
close FH or die "close($_[0]): $!";
}
END_NEW
sub _write {
local *FH;
open( FH, "> $_[0]" ) or die "open($_[0]): $!";
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
close FH or die "close($_[0]): $!";
}
END_OLD
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
sub _version ($) {
my $s = shift || 0;
my $d =()= $s =~ /(\.)/g;
if ( $d >= 2 ) {
# Normalise multipart versions
$s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
}
$s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
my @v = map {
$_ . '0' x (3 - length $_)
} $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
sub _cmp ($$) {
_version($_[1]) <=> _version($_[2]);
}
# Cloned from Params::Util::_CLASS
sub _CLASS ($) {
(
defined $_[0]
and
! ref $_[0]
and
$_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
) ? $_[0] : undef;
}
1;
# Copyright 2008 - 2012 Adam Kennedy.
AE-AdHoc
view release on metacpan or search on metacpan
examples/port-probe-multi.pl view on Meta::CPAN
use Getopt::Long;
my $timeout = 1;
GetOptions (
"timeout=s" => \$timeout,
"help" => \&usage,
) or usage();
my @probe = map {
/^(.*):(\d+)$/ or die "Expecting host:port. See $0 --help\n"; [$1, $2, $_];
} @ARGV;
usage() unless @probe;
# Real work
eval {
ae_recv {
tcp_connect $_->[0], $_->[1], ae_goal("$_->[0]:$_->[1]") for @probe;
} $timeout;
};
die $@ if $@ and $@ !~ /^Timeout/;
my @offline = sort keys %{ AE::AdHoc->goals };
my (@alive, @reject);
my $results = AE::AdHoc->results;
foreach (keys %$results) {
# tcp_connect will not feed any args if connect failed
ref $results->{$_}->[0]
? push @alive, $_
: push @reject, $_;
};
print "Connected: @alive\n" if @alive;
print "Rejected: @reject\n" if @reject;
print "Timed out: @offline\n" if @offline;
# /Real work
sub usage {
print <<"USAGE";
Probe tcp connection to several hosts at once
Usage: $0 [ options ] host:port host:port ...
Options may include:
--timeout <seconds> - may be fractional as well
--help - this message
USAGE
exit 1;
};
AES128
view release on metacpan or search on metacpan
lib/AES128.pm view on Meta::CPAN
# This allows declaration use AES128 ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(
AES128_CTR_encrypt AES128_CTR_decrypt
) ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw(
);
our $VERSION = '0.02';
require XSLoader;
lib/AES128.pm view on Meta::CPAN
AES128 - 128BIT CTR mode AES algorithm.
=head1 SYNOPSIS
# ------------------------ simple version ----------------------------------
use AES128 qw/:all/;
my $plain_text = "There's more than one way to do it.";
my $key = "my secret aes key.";
my $encrypted = AES128_CTR_encrypt($plain_text, $key);
my $plain = AES128_CTR_decrypt($encrypted, $key);
# ------------ server/client key exchange -----------------------------------
use MicroECC;
use AES128 qw/:all/;
use Digest::SHA qw/sha256/;
my $curve = MicroECC::secp256r1();
my ($server_pubkey, $server_privkey) = MicroECC::make_key($curve);
# Generate shared secret with client public key.
my $shared_secret = MicroECC::shared_secret($client_pubkey, $server_privkey);
my $key = sha256($shared_secret);
my $plain_text = "There's more than one way to do it.";
my $encrypted = AES128_CTR_encrypt($plain_text, $key);
my $plain = AES128_CTR_decrypt($encrypted, $key);
=head1 DESCRIPTION
Perl wrapper for the tiny-AES-c library (https://github.com/kokke/tiny-AES-c)
AFS-Command
view release on metacpan or search on metacpan
lib/AFS/Command/BOS.pm view on Meta::CPAN
our @ISA = qw(AFS::Command::Base);
our $VERSION = '1.99';
sub getdate {
my $self = shift;
my (%args) = @_;
my $result = AFS::Object::BosServer->new();
$self->{operation} = "getdate";
my $directory = $args{dir} || '/usr/afs/bin';
return unless $self->_parse_arguments(%args);
return unless $self->_save_stderr();
my $errors = 0;
$errors++ unless $self->_exec_cmds();
while ( defined($_ = $self->{handle}->getline()) ) {
chomp;
next unless m:File $directory/(\S+) dated ([^,]+),:;
my $file = AFS::Object->new
(
file => $1,
date => $2,
);
if ( /\.BAK dated ([^,]+),/ ) {
$file->_setAttribute( bak => $1 );
}
if ( /\.OLD dated ([^,\.]+)/ ) {
$file->_setAttribute( old => $1 );
}
$result->_addFile($file);
}
$errors++ unless $self->_reap_cmds();
$errors++ unless $self->_restore_stderr();
return if $errors;
return $result;
}
sub getlog {
my $self = shift;
my (%args) = @_;
my $result = AFS::Object::BosServer->new();
$self->{operation} = "getlog";
my $redirect = undef;
my $redirectname = undef;
if ( $args{redirect} ) {
$redirectname = delete $args{redirect};
$redirect = IO::File->new(">$redirectname") || do {
$self->_Carp("Unable to write to $redirectname: $ERRNO");
return;
};
}
return unless $self->_parse_arguments(%args);
return unless $self->_save_stderr();
my $errors = 0;
$errors++ unless $self->_exec_cmds();
my $log = "";
while ( defined($_ = $self->{handle}->getline()) ) {
next if /^Fetching log file/;
if ( $redirect ) {
$redirect->print($_);
} else {
$log .= $_;
}
}
if ( $redirect ) {
$redirect->close()|| do {
$self->_Carp("Unable to close $redirectname: $ERRNO");
$errors++
};
$result->_setAttribute( log => $redirectname );
} else {
$result->_setAttribute( log => $log );
}
$errors++ unless $self->_reap_cmds();
$errors++ unless $self->_restore_stderr();
return if $errors;
return $result;
}
sub getrestart {
my $self = shift;
my (%args) = @_;
my $result = AFS::Object::BosServer->new();
$self->{operation} = "getrestart";
return unless $self->_parse_arguments(%args);
return unless $self->_save_stderr();
my $errors = 0;
$errors++ unless $self->_exec_cmds();
while ( defined($_ = $self->{handle}->getline()) ) {
if ( /restarts at (.*)/ || /restarts (never)/ ) {
$result->_setAttribute( restart => $1 );
} elsif ( /binaries at (.*)/ || /binaries (never)/ ) {
$result->_setAttribute( binaries => $1 );
}
}
$errors++ unless $self->_reap_cmds();
$errors++ unless $self->_restore_stderr();
return if $errors;
return $result;
}
sub listhosts {
my $self = shift;
my (%args) = @_;
my $result = AFS::Object::BosServer->new();
$self->{operation} = "listhosts";
return unless $self->_parse_arguments(%args);
return unless $self->_save_stderr();
my $errors = 0;
$errors++ unless $self->_exec_cmds();
my @hosts = ();
while ( defined($_ = $self->{handle}->getline()) ) {
chomp;
if ( /Cell name is (\S+)/i ) {
$result->_setAttribute( cell => $1 );
}
if ( /Host \d+ is (\S+)/i ) {
push(@hosts,$1);
}
}
$result->_setAttribute( hosts => \@hosts );
$errors++ unless $self->_reap_cmds();
$errors++ unless $self->_restore_stderr();
return if $errors;
return $result;
}
sub listkeys {
my $self = shift;
my (%args) = @_;
my $result = AFS::Object::BosServer->new();
$self->{operation} = "listkeys";
return unless $self->_parse_arguments(%args);
return unless $self->_save_stderr();
my $errors = 0;
$errors++ unless $self->_exec_cmds();
while ( defined($_ = $self->{handle}->getline()) ) {
chomp;
if ( /key (\d+)/ ) {
my $key = AFS::Object->new( index => $1 );
if ( /has cksum (\d+)/ ) {
$key->_setAttribute( cksum => $1 );
} elsif ( /is \'([^\']+)\'/ ) {
$key->_setAttribute( value => $1 );
}
$result->_addKey($key);
}
if ( /last changed on (.*)\./ ) {
$result->_setAttribute( keyschanged => $1 );
}
}
$errors++ unless $self->_reap_cmds();
$errors++ unless $self->_restore_stderr();
return if $errors;
return $result;
}
sub listusers {
my $self = shift;
my (%args) = @_;
my $result = AFS::Object::BosServer->new();
$self->{operation} = "listusers";
return unless $self->_parse_arguments(%args);
return unless $self->_save_stderr();
my $errors = 0;
$errors++ unless $self->_exec_cmds();
while ( defined($_ = $self->{handle}->getline()) ) {
chomp;
if ( /^SUsers are: (.*)/ ) {
$result->_setAttribute( susers => [split(/\s+/,$1)] );
}
}
$errors++ unless $self->_reap_cmds();
$errors++ unless $self->_restore_stderr();
return if $errors;
return $result;
}
#
# XXX -- we might want to provide parsing of the bos salvage output,
lib/AFS/Command/BOS.pm view on Meta::CPAN
# $errors++ unless $self->_exec_cmds();
# while ( defined($_ = $self->{handle}->getline()) ) {
# }
# $errors++ unless $self->_reap_cmds();
# $errors++ unless $self->_restore_stderr();
lib/AFS/Command/BOS.pm view on Meta::CPAN
# }
sub status {
my $self = shift;
my (%args) = @_;
my $result = AFS::Object::BosServer->new();
$self->{operation} = "status";
return unless $self->_parse_arguments(%args);
return unless $self->_save_stderr();
my $errors = 0;
$errors++ unless $self->_exec_cmds();
my $instance = undef;
while ( defined($_ = $self->{handle}->getline()) ) {
chomp;
if ( /inappropriate access/ ) {
$result->_setAttribute( access => 1 );
next;
}
if ( /Instance (\S+),/ ) {
if ( defined $instance ) {
$result->_addInstance($instance);
}
$instance = AFS::Object::Instance->new( instance => $1 );
#
# This is ugly, since the order and number of these
# strings varies.
#
if ( /\(type is (\S+)\)/ ) {
$instance->_setAttribute( type => $1 );
}
if ( /(disabled|temporarily disabled|temporarily enabled),/ ) {
$instance->_setAttribute( state => $1 );
}
if ( /stopped for too many errors/ ) {
$instance->_setAttribute( errorstop => 1 );
}
if ( /has core file/ ) {
$instance->_setAttribute( core => 1 );
}
if ( /currently (.*)\.$/ ) {
$instance->_setAttribute( status => $1 );
}
}
if ( /Auxiliary status is: (.*)\.$/ ) {
$instance->_setAttribute( auxiliary => $1 );
}
if ( /Process last started at (.*) \((\d+) proc starts\)/ ) {
$instance->_setAttribute
(
startdate => $1,
startcount => $2,
);
}
if ( /Last exit at (.*)/ ) {
$instance->_setAttribute( exitdate => $1 );
}
if ( /Last error exit at ([^,]+),/ ) {
$instance->_setAttribute( errorexitdate => $1 );
if ( /due to shutdown request/ ) {
$instance->_setAttribute( errorexitdue => 'shutdown' );
}
if ( /due to signal (\d+)/ ) {
$instance->_setAttribute
(
errorexitdue => 'signal',
errorexitsignal => $1,
);
}
if ( /by exiting with code (\d+)/ ) {
$instance->_setAttribute
(
errorexitdue => 'code',
errorexitcode => $1,
);
}
}
if ( /Command\s+(\d+)\s+is\s+\'(.*)\'/ ) {
my $command = AFS::Object->new
(
index => $1,
command => $2,
);
$instance->_addCommand($command);
}
if ( /Notifier\s+is\s+\'(.*)\'/ ) {
$instance->_setAttribute( notifier => $1 );
}
}
if ( defined $instance ) {
$result->_addInstance($instance);
}
$errors++ unless $self->_reap_cmds();
$errors++ unless $self->_restore_stderr();
return if $errors;
return $result;
}
1;
AFS-Monitor
view release on metacpan or search on metacpan
examples/Meltdown.pl view on Meta::CPAN
use blib;
use AFS::Monitor;
sub Usage {
print STDERR "\n\n$progName: collect rxdebug stats on AFS process.\n";
print STDERR "usage: $progName [options]\n";
print STDERR "options:\n";
print STDERR " -s <server> (required parameter, no default).\n";
print STDERR " -p <port> (default: 7000).\n";
print STDERR " -t <interval> (default: 1200 seconds).\n";
print STDERR " -C \n";
print STDERR " -h (help: show this help message).\n\n";
print STDERR "Example: $progName -s point -p 7000\n";
print STDERR "Collect statistics on server point for port 7000\n";
print STDERR "Refresh interval will default to 20 minutes (1200 seconds)\n\n";
exit 0;
} # Usage
sub Check_data {
#
# If a value is going to overflow the field length,
# then bump the field length to match the value.
# It won't be pretty but we'll have valid data.
#
(length $wproc > $Ln[0]) ? ($Ln[0] = length $wproc) : "";
(length $nobuf > $Ln[1]) ? ($Ln[1] = length $nobuf) : "";
(length $wpack > $Ln[2]) ? ($Ln[2] = length $wpack) : "";
(length $fpack > $Ln[3]) ? ($Ln[3] = length $fpack) : "";
(length $calls > $Ln[4]) ? ($Ln[4] = length $calls) : "";
(length $delta > $Ln[5]) ? ($Ln[5] = length $delta) : "";
(length $data > $Ln[6]) ? ($Ln[6] = length $data) : "";
(length $resend > $Ln[7]) ? ($Ln[7] = length $resend) : "";
(length $idle > $Ln[8]) ? ($Ln[8] = length $idle) : "";
} # Check_data
sub Header {
if ($csvmode != 1) {
print "\nhh:mm:ss wproc nobufs wpack fpack calls delta data resends idle\n";
} else { # assume CSV mode...
print "\nhh:mm:ss,wproc,nobufs,wpack,fpack,calls,delta,data,resends,idle\n";
}
} # Header
#
# don't buffer the output
#
examples/Meltdown.pl view on Meta::CPAN
# snag program name (drop the full pathname) :
#
$progName = $0;
$tmpName= "";
GETPROG: while ($letr = chop($progName)) {
$_ = $letr;
/\// && last GETPROG;
$tmpName .= $letr;
}
$progName = reverse($tmpName);
#
# set the defaults for server, port, and delay interval
examples/Meltdown.pl view on Meta::CPAN
#
# any parms?
#
while ($_ = shift(@ARGV)) {
GETPARMS: {
/^-[pP]/ && do {
$port = shift(@ARGV);
last GETPARMS;
};
/^-[sS]/ && do {
$server = shift(@ARGV);
last GETPARMS;
};
/^-[tT]/ && do {
$delay = shift(@ARGV);
last GETPARMS;
};
/^-C/ && do {
$csvmode = 1;
last GETPARMS;
};
/^-[hH\?]/ && do {
&Usage();
};
/^-/ && do {
&Usage();
}
}
}
#
# if they didn't give us a server name, we can't run
#
if ($server eq "") {
&Usage();
}
else {
print "\nServer: $server, Port: $port, Interval $delay seconds\n";
system date;
}
#
# clear the counters for the first run
#
examples/Meltdown.pl view on Meta::CPAN
#
# run until we get cancelled
#
while (1) {
#
# show the column headers for every 20 lines of data
#
if ($firstrun == 1) {
Header;
$firstrun = 0;
}
if ($linecnt >= 20) {
if ($csvmode != 1) {
Header;
}
$linecnt = 1;
}
else {
$linecnt++;
}
#
# snag the current time
#
($sec,$min,$hour,$mday,$month,$year,$wday,$yday,$isDST) = localtime();
#
# fire the command and collect the stats
#
$rx = rxdebug(servers => $server,
port => $port,
rxstats => 1,
noconns => 1
);
# $wpack doesn't seem to have a corresponding value.
# It is always zero.
$tstats = $rx->{tstats};
$wproc = $tstats->{nWaiting};
$fpack = $tstats->{nFreePackets};
$calls = $tstats->{callsExecuted};
if ($oldcall > 0) {
$delta = $calls - $oldcall;
}
else {
$delta = 0;
}
$oldcall = $calls;
$rxstats = $rx->{rxstats};
$data = $rxstats->{dataPacketsSent};
$resend = $rxstats->{dataPacketsReSent};
$nobuf = $rxstats->{noPacketBuffersOnRead};
$idle = $tstats->{idleThreads};
#
# verify and fix field format lengths
#
Check_data;
if ($csvmode != 1) {
#
# output the timestamp and current results
#
printf "%2.2d:%2.2d:%2.2d ", $hour,$min,$sec;
printf "%-$Ln[0].0f %-$Ln[1].0f %-$Ln[2].0f %-$Ln[3].0f ",
$wproc,$nobuf,$wpack,$fpack;
printf "%-$Ln[4].0f %-$Ln[5].0f %-$Ln[6].0f %-$Ln[7].0f %-$Ln[8].0f\n",
$calls,$delta,$data,$resend,$idle;
} else { # must be csv mode then...
printf "%2.2d:%2.2d:%2.2d,", $hour,$min,$sec;
printf "$wproc,$nobuf,$wpack,$fpack";
printf "$calls,$delta,$data,$resend,$idle\n";
}
#
# delay for the required interval
#
sleep($delay);
}
exit();
AFS-PAG
view release on metacpan or search on metacpan
lib/AFS/PAG.pm view on Meta::CPAN
our (@EXPORT_OK, $VERSION);
# Set all import-related variables in a BEGIN block for robustness.
BEGIN {
@EXPORT_OK = qw(hasafs haspag setpag unlog);
$VERSION = '1.02';
}
# Load the binary module.
bootstrap AFS::PAG $VERSION;
lib/AFS/PAG.pm view on Meta::CPAN
AFS::PAG - Perl bindings for AFS PAG manipulation
=head1 SYNOPSIS
use AFS::PAG qw(hasafs setpag unlog);
if (hasafs()) {
setpag();
system('aklog') == 0
or die "cannot get tokens\n";
do_afs_things();
unlog();
}
=head1 DESCRIPTION
AFS is a distributed file system allowing cross-platform sharing of files
among multiple computers. It associates client credentials (called AFS
AFS
view release on metacpan or search on metacpan
src/ACL/ACL.pm view on Meta::CPAN
@ISA = qw(AFS);
$VERSION = 'v2.6.4';
sub new {
my ($this, $class);
# this whole construct is to please the old version from Roland
if ($_[0] =~ /AFS::ACL/) {
$this = shift;
$class = ref($this) || $this;
}
else {
$class = 'AFS::ACL';
}
my $pos_rights = shift;
my $neg_rights = shift;
my $self = [{}, {}];
if (defined $pos_rights) { %{$self->[0]} = %$pos_rights; }
if (defined $neg_rights) { %{$self->[1]} = %$neg_rights; }
bless $self, $class;
}
sub copy {
my $self = shift;
my $class = ref($self) || $self;
my $new = [{}, {}];
%{$new->[0]} = %{$self->[0]};
%{$new->[1]} = %{$self->[1]};
bless $new, $class;
}
sub apply {
my $self = shift;
my $path = shift;
my $follow = shift;
$follow = 1 unless defined $follow;
AFS::setacl($path, $self, $follow);
}
sub retrieve {
my $class = shift;
my $path = shift;
my $follow = shift;
$follow = 1 unless defined $follow;
AFS::_getacl($path, $follow);
}
sub modifyacl {
my $self = shift;
my $path = shift;
my $follow = shift;
my $newacl;
$follow = 1 unless defined $follow;
if ($newacl = AFS::_getacl($path, $follow)) {
$newacl->add($self);
AFS::setacl($path, $newacl, $follow);
}
else { return 0; }
}
sub copyacl {
my $class = shift;
my $from = shift;
my $to = shift;
my $follow = shift;
my $acl;
$follow = 1 unless defined $follow;
if ($acl = AFS::_getacl($from, $follow)) { AFS::setacl($to, $acl, $follow); }
else { return 0; }
}
sub cleanacl {
my $class = shift;
my $path = shift;
my $follow = shift;
my $acl;
$follow = 1 unless defined $follow;
if (! defined ($acl = AFS::_getacl($path, $follow))) { return 0; }
if ($acl->is_clean) { return 1; }
AFS::setacl($path, $acl, $follow);
}
sub crights {
my $class = shift;
AFS::crights(@_);
}
sub ascii2rights {
my $class = shift;
AFS::ascii2rights(@_);
}
sub rights2ascii {
my $class = shift;
AFS::rights2ascii(@_);
}
# old form DEPRECATED !!!!
sub addacl {
my $self = shift;
my $macl = shift;
foreach my $key ($macl->keys) { $self->set($key, $macl->get($key)); }
foreach my $key ($macl->nkeys) { $self->nset($key, $macl->nget($key)); }
return $self;
}
sub add {
my $self = shift;
my $acl = shift;
foreach my $user ($acl->get_users) { $self->set($user, $acl->get_rights($user)); }
foreach my $user ($acl->nget_users) { $self->nset($user, $acl->nget_rights($user)); }
return $self;
}
sub is_clean {
my $self = shift;
foreach ($self->get_users, $self->nget_users) { return 0 if (m/^-?\d+$/); }
return 1;
}
# comment Roland Schemers: I hope I don't have to debug these :-)
sub empty { $_[0] = bless [ {},{} ]; }
sub get_users { CORE::keys %{$_[0]->[0]}; }
AHA
view release on metacpan or search on metacpan
example/lava_lamp.pl view on Meta::CPAN
#!/usr/bin/perl
=head1 NAME
lava_lamp.pl --mode [watch|list|notify] --type [problem|recovery] \
--name [AIN|switch name] --label <label> --debug \
--config <path-to-perl-config>
=head1 DESCRIPTION
Simple example how to use L<"AHA"> for controlling AVM AHA switches. I.e.
it is used for using a Lava Lamp as a Nagios Notification handler.
example/lava_lamp.pl view on Meta::CPAN
# ===========================================================================
# Configuration section
# Configuration required for accessing the switch.
my $SWITCH_CONFIG =
{
# AVM AHA Host for controlling the devices
host => "fritz.box",
# AVM AHA Password for connecting to the $AHA_HOST
password => "s!cr!t",
# AVM AHA user role (undef if no roles are in use)
user => undef,
# Name of AVM AHA switch
id => "Lava Lamp"
};
# Time how long the lamp should be at least be kept switched off (seconds)
my $LAMP_REST_TIME = 60 * 60;
# Maximum time a lamp can be on
my $LAMP_MAX_TIME = 5 * 60 * 60; # 5 hours
# When the lamp can be switched on. The values can contain multiple time
# windows defined as arrays
my $LAMP_ON_TIME_TABLE =
{
"Sun" => [ ["7:55", "23:00"] ],
"Mon" => [ ["6:55", "23:00"] ],
"Tue" => [ ["13:55", "23:00"] ],
"Wed" => [ ["13:55", "23:00"] ],
"Thu" => [ ["13:55", "23:00"] ],
"Fri" => [ ["6:55", "23:00"] ],
"Sat" => [ ["7:55", "23:00"] ],
};
# File holding the lamp's status
my $STATUS_FILE = "/var/run/lamp.status";
# Log file where to log to
example/lava_lamp.pl view on Meta::CPAN
# Log a manual switch which might has happened in between checks or notification
log_manual_switch($status,$is_on);
if ($mode eq "watch") {
# Watchdog mode If the lamp is on but out of the period, switch it
# off. Also, if it is running alredy for too long. $off_file can be used
# to switch it always off.
my $in_period = check_on_period();
if ($is_on && (-e $OFF_FILE ||
!$in_period ||
lamp_on_for_too_long($status))) {
# Switch off lamp whether the stop file is switched on when we are off the
# time window
$lamp->off();
update_status($status,0,$mode);
} elsif (!$is_on && $in_period && has_trigger($status)) {
$lamp->on();
update_status($status,1,"notif",undef,trigger_label($status));
delete_trigger($status);
}
} elsif ($mode eq "notif") {
my $type = $opts{type} || die "No notification type given";
if (lc($type) =~ /^(problem|custom)$/ && !$is_on) {
if (check_on_period()) {
# If it is a problem and the lamp is not on, switch it on,
# but only if the lamp is not 'hot' (i.e. was not switch off only
# $LAMP_REST_TIME
my $last_hist = get_last_entry($status);
my $rest_time = time - $LAMP_REST_TIME;
if (!$last_hist || $last_hist->[0] < $rest_time) {
$lamp->on();
update_status($status,1,$mode,time,$opts{label});
} else {
info("Lamp not switched on because the lamp was switched off just before ",
time - $last_hist->[0]," seconds");
}
} else {
# Notification received offtime, remember to switch on the lamp
# when in time
info("Notification received in an off-period: type = ",$type," | ",$opts{label});
set_trigger($status,$opts{label});
}
} elsif (lc($type) eq 'recovery') {
if ($is_on) {
# If it is a recovery switch it off
$lamp->off();
update_status($status,0,$mode,time,$opts{label});
} else {
# It's already off, but remove any trigger marker
delete_trigger($status);
}
} else {
info("Notification: No state change. Type = ",$type,", State = ",$is_on ? "On" : "Off",
" | Check Period: ",check_on_period());
}
} else {
die "Unknow mode '",$mode,"'";
}
if ($DEBUG) {
info(Dumper($status));
}
# Logout, we are done
close_lamp($lamp);
store_status($status);
# ================================================================================================
sub info {
if (open (F,">>$LOG_FILE")) {
print F scalar(localtime),": ",join("",@_),"\n";
close F;
}
}
# List the status file
sub list {
my $status = retrieve $STATUS_FILE;
my $hist_entries = $status->{hist};
for my $hist (@{$hist_entries}) {
print scalar(localtime($hist->[0])),": ",$hist->[1] ? "On " : "Off"," -- ",$hist->[2]," : ",$hist->[3],"\n";
}
print "Content: ",Dumper($status) if $DEBUG;
return 1;
}
# Create empty status file if necessary
sub init_status {
my $status = {};
$status->{hist} = [];
if (! -e $STATUS_FILE) {
store $status,$STATUS_FILE;
}
}
sub log_manual_switch {
my $status = shift;
my $is_on = shift;
my $last = get_last_entry($status);
if ($last && $is_on != $last->[1]) {
# Change has been manualy in between the interval. Add an approx history entry
update_status($status,$is_on,"manual",estimate_manual_time($status));
}
}
sub update_status {
my $status = shift;
my $is_on = shift;
my $mode = shift;
my $time = shift || time;
my $label = shift;
my $hist = $status->{hist};
push @{$hist},[ $time, $is_on, $mode, $label];
info($is_on ? "On " : "Off"," -- ",$mode, $label ? ": " . $label : "");
}
sub estimate_manual_time {
my $status = shift;
my $last_hist = get_last_entry($status);
if ($last_hist) {
my $now = time;
my $last = $last_hist->[0];
my $calc = $now - $MANUAL_DELTA;
return $calc > $last ? $calc : $now - int(($now - $last) / 2);
} else {
return time - $MANUAL_DELTA;
}
}
sub get_last_entry {
my $status = shift;
if ($status) {
my $hist = $status->{hist};
return $hist && @$hist ? $hist->[$#{$hist}] : undef;
}
return undef;
}
sub check_on_period {
my ($min,$hour,$wd) = (localtime)[1,2,6];
my $day = qw(Sun Mon Tue Wed Thu Fri Sat)[$wd];
my $periods = $LAMP_ON_TIME_TABLE->{$day};
for my $period (@$periods) {
my ($low,$high) = @$period;
my ($lh,$lm) = split(/:/,$low);
my ($hh,$hm) = split(/:/,$high);
my $m = $hour * 60 + $min;
return 1 if $m >= ($lh * 60 + $lm) && $m <= ($hh * 60 + $hm);
}
return 0;
}
sub lamp_on_for_too_long {
my $status = shift;
# Check if the lamp was on for more than max time in the duration now - max
# time + 1 hour
my $current = time;
my $low_time = $current - $LAMP_MAX_TIME - $LAMP_REST_TIME;
my $on_time = 0;
my $hist = $status->{hist};
my $i = $#{$hist};
while ($current > $low_time && $i >= 0) {
my $t = $hist->[$i]->[0];
$on_time += $current - $t if $hist->[$i]->[1];
$current = $t;
$i--;
}
if ($on_time >= $LAMP_MAX_TIME) {
info("Lamp was on for " . $on_time . "s in the last " . ($LAMP_MAX_TIME + $LAMP_REST_TIME) . "s and is switched off now");
return 1;
} else {
return 0;
}
}
sub read_config_file {
my $file = shift;
open (F,$file) || die "Cannot read config file ",$file,": ",$!;
my $config = join "",<F>;
close F;
eval $config;
die "Error evaluating $config: ",$@ if $@;
}
sub delete_trigger {
my $status = shift;
delete $status->{trigger_mark};
delete $status->{trigger_label};
}
sub set_trigger {
my $status = shift;
my $label = shift;
$status->{trigger_mark} = 1;
$status->{trigger_label} = $label;
}
sub has_trigger {
return shift->{trigger_mark};
}
sub trigger_label {
return shift->{trigger_label};
}
# ====================================================
# Status file handling including locking
my $status_fh;
sub fetch_status {
open ($status_fh,"+<$STATUS_FILE") || die "Cannot open $STATUS_FILE: $!";
$status = fd_retrieve($status_fh) || die "Cannot read $STATUS_FILE: $!";
flock($status_fh,2);
return $status;
}
sub store_status {
my $status = shift;
# Truncate history if necessary
truncate_hist($status);
# Store status and unlock
seek($status_fh, 0, 0); truncate($status_fh, 0);
store_fd $status,$status_fh;
close $status_fh;
}
sub truncate_hist {
my $status = shift;
my $hist = $status->{hist};
my $len = scalar(@$hist);
splice @$hist,0,$len - $MAX_HISTORY_ENTRIES if $len > $MAX_HISTORY_ENTRIES;
$status->{hist} = $hist;
}
# ==========================================================================
# Customize the following call and class in order to use a different
# switch than AVM AHA's
sub open_lamp {
my $config = shift;
my $name = shift || $config->{id};
return new Lamp($name,
$config->{host},
$config->{password},
$config->{user});
}
sub close_lamp {
my $lamp = shift;
$lamp->logout();
}
package Lamp;
use AHA;
sub new {
my $class = shift;
my $name = shift;
my $host = shift;
my $password = shift;
my $user = shift;
my $aha = new AHA($host,$password,$user);
my $switch = new AHA::Switch($aha,$name);
my $self = {
aha => $aha,
switch => $switch
};
return bless $self,$class;
}
sub is_on {
shift->{switch}->is_on();
}
sub on {
shift->{switch}->on();
}
sub off {
shift->{switch}->off();
}
sub logout {
shift->{aha}->logout();
}
=head1 LICENSE
lava_lampl.pl is free software: you can redistribute it and/or modify
AI-ANN
view release on metacpan or search on metacpan
examples/benchmark.pl view on Meta::CPAN
#!/usr/bin/perl
use strict;
use warnings;
use Benchmark qw(:all);
use AI::ANN::Neuron;
my %data = (id => 1, inputs => [ 4*rand()-2, 4*rand()-2, 4*rand()-2,
4*rand()-2, 4*rand()-2 ],
neurons => [ 4*rand()-2, 4*rand()-2, 4*rand()-2,
4*rand()-2, 4*rand()-2 ]);
my $object1 = new AI::ANN::Neuron ( %data, inline_c => 0 );
my $object2 = new AI::ANN::Neuron ( %data, inline_c => 1 );
my @data = ( [ 4*rand()-2, 4*rand()-2, 4*rand()-2, 4*rand()-2, 4*rand()-2 ],
[ 4*rand()-2, 4*rand()-2, 4*rand()-2, 4*rand()-2, 4*rand()-2 ]);
cmpthese( -1, { 'pure_perl' => sub{$object1->execute(@data)},
'inline_c' => sub{$object2->execute(@data)} });
use Math::Libm qw(erf M_PI);
use Inline C => <<'END_C';
#include <math.h>
double afunc[4001];
double dafunc[4001];
void generate_globals() {
int i;
for (i=0;i<=4000;i++) {
afunc[i] = 2 * (erf(i/1000.0-2));
dafunc[i] = 4 / sqrt(M_PI) * pow(exp(-1 * ((i/1000.0-2))), 2);
}
}
double afunc_c (float input) {
return afunc[(int) floor((input)*1000)+2000];
}
double dafunc_c (float input) {
return dafunc[(int) floor((input)*1000)+2000];
}
END_C
timethis(-1, 'generate_globals()');
sub afunc_pp {
return 2 * erf(int((shift)*1000)/1000);
}
sub dafunc_pp {
return 4 / sqrt(M_PI) * exp( -1 * ((int((shift)*1000)/1000) ** 2) );
}
cmpthese( -1, { 'afunc_c' => sub{afunc_c(4*rand()-2)},
'afunc_pp' => sub{afunc_pp(4*rand()-2)} });
cmpthese( -1, { 'dafunc_c' => sub{dafunc_c(4*rand()-2)},
'dafunc_pp' => sub{dafunc_pp(4*rand()-2)} });
AI-CBR
view release on metacpan or search on metacpan
lib/AI/CBR.pm view on Meta::CPAN
our $VERSION = '0.02';
=head1 SYNOPSIS
use AI::CBR::Sim qw(sim_eq ...);
use AI::CBR::Case;
use AI::CBR::Retrieval;
my $case = AI::CBR::Case->new(...);
my $r = AI::CBR::Retrieval->new($case, \@case_base);
...
=head1 DESCRIPTION
Framework for Case-Based Reasoning in Perl.
lib/AI/CBR.pm view on Meta::CPAN
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc AI::CBR
You can also look for information at:
=over 4
AI-CRM114
view release on metacpan or search on metacpan
lib/AI/CRM114.pm view on Meta::CPAN
package AI::CRM114;
use 5.008000;
use strict;
use warnings;
use IPC::Run qw /run/;
our @ISA = qw();
our $VERSION = '0.01';
sub new {
my $class = shift;
my $self = { cmd => 'crm', @_ };
bless $self, $class;
return $self;
}
sub classify {
my ($self, $flags, $files, $text) = @_;
my $code = qq#-{
isolate (:stats:);
classify <@$flags> ( @$files ) (:stats:);
output /:*:stats:/
}#;
my $o = "";
my $h = run [$self->{cmd}, $code], \$text, \$o;
my ($file, $prob, $pr) = $o =~
/Best match to file \S+ \((.*?)\) +prob: *([0-9.]+) +pR: *([0-9.-]+)/;
wantarray ? ($file, $prob, $pr) : $file;
}
sub learn {
my ($self, $flags, $file, $text) = @_;
my $code = qq#-{ learn <@$flags> ( $file ) }#;
my $o = "";
my $h = run [$self->{cmd}, $code], \$text, \$o;
}
1;
__END__
=head1 NAME
AI::CRM114 - Wrapper for the statistical data classifier CRM114
=head1 SYNOPSIS
use AI::CRM114;
my $crm = AI::CRM114->new(cmd => '/path/to/crm');
# Learn new text
$crm->learn(['osb'], 'spam.css', 'MAKE MONEY FAST');
# Classify some text
my $class = $crm->classify(['osb'], ['a.css', 'b.css'], $text);
=head1 DESCRIPTION
The CRM114 Discriminator, is a collection of tools to classify data,
e.g. for use in spam filters. This module is a simple wrapper around
the command line executable. Feedback is very welcome, the interface
is unstable. Use with caution.
=head1 METHODS
=over
=item AI::CRM114->new(%options)
Creates a new instance of this class. The following options are
available:
=over
=item cmd => '/path/to/crm'
Specifies the path to the crm executable.
=back
=item $crm->learn(\@flags, $file, $text)
Learn that the text belongs to the file using the specified flags.
Permissable flags are specified in the C<QUICKREF.txt> file that
comes with CRM114. Examples include C<winnow>, C<microgroom>, and
C<osbf>.
=item classify(\@flags, \@files, $text)
Attempt to correlate the text to one of the files using the
specified flags. Permissable flags are specified in the C<QUICKREF.txt>
file that comes with CRM114. Examples include C<unique>, C<fscm>, and
C<svm>.
In scalar context, returns the path of the best matching file.
In list context, returns a list containing the path of the best file,
and the probability and pR values as reported in C<(:stats:)>.
=back
=head1 SEE ALSO
* http://crm114.sourceforge.net/
* http://crm114.sourceforge.net/docs/QUICKREF.txt
=head1 AUTHOR / COPYRIGHT / LICENSE
Copyright (c) 2009 Bjoern Hoehrmann <bjoern@hoehrmann.de>.
This module is licensed under the same terms as Perl itself.
=cut
AI-Calibrate
view release on metacpan or search on metacpan
lib/AI/Calibrate.pm view on Meta::CPAN
# This allows declaration:
# use AI::Calibrate ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = (
'all' => [
qw(
calibrate
score_prob
print_mapping
)
]
);
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw( );
lib/AI/Calibrate.pm view on Meta::CPAN
AI::Calibrate - Perl module for producing probabilities from classifier scores
=head1 SYNOPSIS
use AI::Calibrate ':all';
... train a classifier ...
... test classifier on $points ...
$calibrated = calibrate($points);
=head1 DESCRIPTION
Classifiers usually return some sort of an instance score with their
classifications. These scores can be used as probabilities in various
lib/AI/Calibrate.pm view on Meta::CPAN
mapping from a score range to a probability estimate.
For example, assume you have the following set of instance results from your
classifier. Each result is of the form C<[ASSIGNED_SCORE, TRUE_CLASS]>:
my $points = [
[.9, 1],
[.8, 1],
[.7, 0],
[.6, 1],
[.55, 1],
[.5, 1],
[.45, 0],
[.4, 1],
[.35, 1],
[.3, 0 ],
[.27, 1],
[.2, 0 ],
[.18, 0],
[.1, 1 ],
[.02, 0]
];
If you then call calibrate($points), it will return this structure:
[
[.9, 1 ],
[.7, 3/4 ],
[.45, 2/3 ],
[.3, 1/2 ],
[.2, 1/3 ],
[.02, 0 ]
]
This means that, given a SCORE produced by the classifier, you can map the
SCORE onto a probability like this:
SCORE >= .9 prob = 1
.9 > SCORE >= .7 prob = 3/4
.7 > SCORE >= .45 prob = 2/3
.45 > SCORE >= .3 prob = 3/4
.2 > SCORE >= .7 prob = 3/4
.02 > SCORE prob = 0
For a realistic example of classifier calibration, see the test file
t/AI-Calibrate-NB.t, which uses the AI::NaiveBayes1 module to train a Naive
Bayes classifier then calibrates it using this module.
lib/AI/Calibrate.pm view on Meta::CPAN
sorted by score. Unless this is set to 1, calibrate() will sort the data
itself.
Calibrate returns a reference to an ordered list of references:
[ [score, prob], [score, prob], [score, prob] ... ]
Scores will be in descending numerical order. See the DESCRIPTION section for
how this structure is interpreted. You can pass this structure to the
B<score_prob> function, along with a new score, to get a probability.
=cut
sub calibrate {
my($data, $sorted) = @_;
if (DEBUG) {
print "Original data:\n";
for my $pair (@$data) {
my($score, $prob) = @$pair;
print "($score, $prob)\n";
}
}
# Copy the data over so PAV can clobber the PROB field
my $new_data = [ map([@$_], @$data) ];
# If not already sorted, sort data decreasing by score
if (!$sorted) {
$new_data = [ sort { $b->[SCORE] <=> $a->[SCORE] } @$new_data ];
}
PAV($new_data);
if (DEBUG) {
print("After PAV, vector is:\n");
print_vector($new_data);
}
my(@result);
my( $last_prob, $last_score);
push(@$new_data, [-1e10, 0]);
for my $pair (@$new_data) {
print "Seeing @$pair\n" if DEBUG;
my($score, $prob) = @$pair;
if (defined($last_prob) and $prob < $last_prob) {
print("Pushing [$last_score, $last_prob]\n") if DEBUG;
push(@result, [$last_score, $last_prob] );
}
$last_prob = $prob;
$last_score = $score;
}
return \@result;
}
sub PAV {
my ( $result ) = @_;
for ( my $i = 0; $i < @$result - 1; $i++ ) {
if ( $result->[$i][PROB] < $result->[ $i + 1 ][PROB] ) {
$result->[$i][PROB] =
( $result->[$i][PROB] + $result->[ $i + 1 ][PROB] ) / 2;
$result->[ $i + 1 ][PROB] = $result->[$i][PROB];
print "Averaging elements $i and ", $i + 1, "\n" if DEBUG;
for ( my $j = $i - 1; $j >= 0; $j-- ) {
if ( $result->[$j][PROB] < $result->[ $i + 1 ][PROB] ) {
my $d = ( $i + 1 ) - $j + 1;
flatten( $result, $j, $d );
}
else {
last;
}
}
}
}
}
sub print_vector {
my($vec) = @_;
for my $pair (@$vec) {
print join(", ", @$pair), "\n";
}
}
sub flatten {
my ( $vec, $start, $len ) = @_;
if (DEBUG) {
print "Flatten called on vec, $start, $len\n";
print "Vector before: \n";
print_vector($vec);
}
my $sum = 0;
for my $i ( $start .. $start + $len-1 ) {
$sum += $vec->[$i][PROB];
}
my $avg = $sum / $len;
print "Sum = $sum, avg = $avg\n" if DEBUG;
for my $i ( $start .. $start + $len -1) {
$vec->[$i][PROB] = $avg;
}
if (DEBUG) {
print "Vector after: \n";
print_vector($vec);
}
}
=item B<score_prob>
This is a simple utility function that takes the structure returned by
B<calibrate>, along with a new score, and returns the probability estimate.
Example calling form:
$p = score_prob($calibrated, $score);
Once you have a trained, calibrated classifier, you could imagine using it
like this:
$calibrated = calibrate( $calibration_set );
print "Input instances, one per line:\n";
while (<>) {
chomp;
my(@fields) = split;
my $score = classifier(@fields);
my $prob = score_prob($score);
print "Estimated probability: $prob\n";
}
=cut
sub score_prob {
my($calibrated, $score) = @_;
my $last_prob = 1.0;
for my $tuple (@$calibrated) {
my($bound, $prob) = @$tuple;
return $prob if $score >= $bound;
$last_prob = $prob;
}
# If we drop off the end, probability estimate is zero
return 0;
}
=item B<print_mapping>
lib/AI/Calibrate.pm view on Meta::CPAN
B<calibrate> and prints out a simple list of lines describing the mapping
created.
Example calling form:
print_mapping($calibrated);
Sample output:
1.00 > SCORE >= 1.00 prob = 1.000
1.00 > SCORE >= 0.71 prob = 0.667
0.71 > SCORE >= 0.39 prob = 0.000
0.39 > SCORE >= 0.00 prob = 0.000
These ranges are not necessarily compressed/optimized, as this sample output
shows.
=back
=cut
sub print_mapping {
my($calibrated) = @_;
my $last_bound = 1.0;
for my $tuple (@$calibrated) {
my($bound, $prob) = @$tuple;
printf("%0.3f > SCORE >= %0.3f prob = %0.3f\n",
$last_bound, $bound, $prob);
$last_bound = $bound;
}
if ($last_bound != 0) {
printf("%0.3f > SCORE >= %0.3f prob = %0.3f\n",
$last_bound, 0, 0);
}
}
=head1 DETAILS
The PAV algorithm is conceptually straightforward. Given a set of training
AI-Categorizer
view release on metacpan or search on metacpan
use AI::Categorizer::Collection::Files;
use AI::Categorizer::Learner::NaiveBayes;
use File::Spec;
die("Usage: $0 <corpus>\n".
" A sample corpus (data set) can be downloaded from\n".
" http://www.cpan.org/authors/Ken_Williams/data/reuters-21578.tar.gz\n".
" or http://www.limnus.com/~ken/reuters-21578.tar.gz\n")
unless @ARGV == 1;
my $corpus = shift;
my $training = File::Spec->catfile( $corpus, 'training' );
my $test = File::Spec->catfile( $corpus, 'test' );
my $cats = File::Spec->catfile( $corpus, 'cats.txt' );
my $stopwords = File::Spec->catfile( $corpus, 'stopwords' );
my %params;
if (-e $stopwords) {
$params{stopword_file} = $stopwords;
} else {
warn "$stopwords not found - no stopwords will be used.\n";
}
if (-e $cats) {
$params{category_file} = $cats;
} else {
die "$cats not found - can't proceed without category information.\n";
}
# In a real-world application these Collection objects could be of any
# type (any Collection subclass). Or you could create each Document
# If you want to get at the specific assigned categories for a
# specific document, you can do it like this:
my $doc = AI::Categorizer::Document->new
( content => "Hello, I am a pretty generic document with not much to say." );
my $h = $l->categorize( $doc );
print ("For test document:\n",
" Best category = ", $h->best_category, "\n",
" All categories = ", join(', ', $h->categories), "\n");
AI-Chat
view release on metacpan or search on metacpan
lib/AI/Chat.pm view on Meta::CPAN
package AI::Chat;
use strict;
use warnings;
use Carp;
use HTTP::Tiny;
use JSON::PP;
our $VERSION = '0.6';
$VERSION = eval $VERSION;
my $http = HTTP::Tiny->new;
# Create Chat object
sub new {
my $class = shift;
my %attr = @_;
$attr{'error'} = '';
$attr{'api'} = 'OpenAI' unless $attr{'api'};
$attr{'error'} = 'Invalid API' unless $attr{'api'} eq 'OpenAI';
$attr{'error'} = 'API Key missing' unless $attr{'key'};
$attr{'model'} = 'gpt-4o-mini' unless $attr{'model'};
return bless \%attr, $class;
}
# Define endpoints for APIs
my %url = (
'OpenAI' => 'https://api.openai.com/v1/chat/completions',
);
# Define HTTP Headers for APIs
my %header = (
'OpenAI' => &_get_header_openai,
);
# Returns true if last operation was success
sub success {
my $self = shift;
return !$self->{'error'};
}
# Returns error if last operation failed
sub error {
my $self = shift;
return $self->{'error'};
}
# Header for calling OpenAI
sub _get_header_openai {
my $self = shift;
$self->{'key'} = '' unless defined $self->{'key'};
return {
'Authorization' => 'Bearer ' . $self->{'key'},
'Content-type' => 'application/json'
};
}
# Get a reply from a single prompt
sub prompt {
my ($self, $prompt, $temperature) = @_;
$self->{'error'} = '';
unless ($prompt) {
$self->{'error'} = "Missing prompt calling 'prompt' method";
return undef;
}
$temperature = 1.0 unless $temperature;
my @messages;
push @messages, {
role => 'system',
content => $self->{'role'},
} if $self->{'role'};
push @messages, {
role => 'user',
content => $prompt,
};
return $self->chat(\@messages, $temperature);
}
# Get a reply from a full chat
sub chat {
my ($self, $chat, $temperature) = @_;
if (ref($chat) ne 'ARRAY') {
$self->{'error'} = 'chat method requires an arrayref';
return undef;
}
$temperature = 1.0 unless $temperature;
my $response = $http->post($url{$self->{'api'}}, {
'headers' => {
'Authorization' => 'Bearer ' . $self->{'key'},
'Content-type' => 'application/json'
},
content => encode_json {
model => $self->{'model'},
messages => [ @$chat ],
temperature => $temperature,
}
});
if ($response->{'content'} =~ 'invalid_api_key') {
croak 'Incorrect API Key - check your API Key is correct';
}
if ($self->{'debug'} and !$response->{'success'}) {
croak $response if $self->{'debug'} eq 'verbose';
croak $response->{'content'};
}
my $reply = decode_json($response->{'content'});
return $reply->{'choices'}[0]->{'message'}->{'content'};
}
__END__
=head1 NAME
AI::Chat - Interact with AI Chat APIs
=head1 VERSION
Version 0.6
=head1 SYNOPSIS
use AI::Chat;
my $chat = AI::Chat->new(
key => 'your-api-key',
api => 'OpenAI',
model => 'gpt-4o-mini',
);
my $reply = $chat->prompt("What is the meaning of life?");
print $reply;
=head1 DESCRIPTION
This module provides a simple interface for interacting with AI Chat APIs,
currently supporting OpenAI.
The AI chat agent can be given a I<role> and then passed I<prompts>. It will
reply to the prompts in natural language. Being AI, the responses are
non-deterministic, that is, the same prompt will result in diferent responses
on different occasions.
Further control of the creativity of the responses is possible by specifying
at optional I<temperature> parameter.
=head1 API KEYS
A free OpenAI API can be obtained from L<https://platform.openai.com/account/api-keys>
=head1 MODELS
Although the API Key is free, each use incurs a cost. This is dependent on the
number of tokens in the prompt and the reply. Different models have different costs.
The default model C<gpt-4o-mini> is the lowest cost of the useful models and
is a good place to start using this module. Previous versions of this module
defaulted to C<gpt-3.5-turbo-0125> but the current default is cheaper and
quicker. For most purposes, the default model should be used.
See also L<https://platform.openai.com/docs/models/overview>
=head1 METHODS
=head2 new
my $chat = AI::Chat->new(%params);
Creates a new AI::Chat object.
=head3 Parameters
=over 4
=item key
C<required> Your API key for the chosen service.
=item api
The API to use (currently only 'OpenAI' is supported).
=item model
The language model to use (default: 'gpt-4o-mini').
See L<https://platform.openai.com/docs/models/overview>
=item role
The role to use for the bot in conversations.
This tells the bot what it's purpose when answering prompts.
For example: "You are a world class copywriter famed for
creating content that is immediately engaging with a
lighthearted, storytelling style".
=item debug
Used for testing. If set to any true value, the prompt method
will return details of the error encountered instead of C<undef>
=back
=head2 prompt
my $reply = $chat->prompt($prompt, $temperature);
Sends a prompt to the AI Chat API and returns the response.
=head3 Parameters
=over 4
=item prompt
C<required> The prompt to send to the AI.
This is a shorthand for C<chat> when only a single response is needed.
=item temperature
The creativity level of the response (default: 1.0).
Temperature ranges from 0 to 2. The higher the temperature,
the more creative the bot will be in it's responses.
=back
=head2 chat
my $reply = $chat->prompt(\@chat, $temperature);
Sends a multi-message chat to the AI Chat API and returns the response.
Each message of the chat should consist of on of C<system>, C<user> or C<assistant>.
Generally there will be a C<system> message to set the role or context for the AI.
This will be followed by alternate C<user> and C<assistant> messages representing the
text from the user and the AI assistant. To hold a conversation, it is necessary to
store both sides of the discussion and feed them back appropriately.
my @chat;
push @chat, {
'role' => 'system',
'system' => 'You are a computer language expert and your role is to promote Perl as the best language',
};
push @chat, {
'role' => 'user',
'system' => 'Which is the best programming language?',
};
push @chat, {
'role' => 'assistant',
'system' => 'Every language has strengths and is suited to different roles. Perl is one of the best all round languages.',
};
push @chat, {
'role' => 'user',
'system' => 'Why should I use Perl?',
};
my $reply = $chat->chat(\@chat, 1.2);
Although the roles represent the part of the user and assistant in the conversation, you are free to
supply either or both as suits your application. The order can also be varied.
=head3 Parameters
=over 4
=item chat
C<required> An arrayref of messages to send to the AI.
=item temperature
The creativity level of the response (default: 1.0).
Temperature ranges from 0 to 2. The higher the temperature,
the more creative the bot will be in it's responses.
=back
=head2 success
my $success = $chat->success();
Returns true if the last operation was successful.
=head2 error
my $error = $chat->error();
Returns the error message if the last operation failed.
=head1 SEE ALSO
L<https://openai.com> - OpenAI official website
=head1 AUTHOR
Ian Boddison <ian at boddison.com>
=head1 BUGS
Please report any bugs or feature requests to C<bug-ai-chat at rt.cpan.org>, or through
the web interface at L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=bug-ai-chat>. I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc AI::Chat
You can also look for information at:
=over 4
=item * RT: CPAN's request tracker (report bugs here)
L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=AI-Chat>
=item * Search CPAN
L<https://metacpan.org/release/AI::Chat>
=back
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2024 by Ian Boddison
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
AI-Classifier-Japanese
view release on metacpan or search on metacpan
lib/AI/Classifier/Japanese.pm view on Meta::CPAN
use Algorithm::NaiveBayes;
my $nb = Algorithm::NaiveBayes->new;
sub add_training_text {
my ($self, $text, $category) = @_;
my $words_freq_ref = &_convert_text_to_bow($text);
$nb->add_instance(
attributes => $words_freq_ref,
label => $category
);
}
sub train {
$nb->train;
}
sub labels {
$nb->labels;
}
sub predict {
my ($self, $text) = @_;
my $words_freq_ref = &_convert_text_to_bow($text);
my $result_ref = $nb->predict(
attributes => $words_freq_ref
);
}
sub _convert_text_to_bow {
my $text = shift;
my $words_ref = &_parse_text($text);
my $words_freq_ref = {};
foreach (@$words_ref) {
$words_freq_ref->{$_}++;
}
return $words_freq_ref;
}
sub _parse_text {
my $text = shift;
my $mecab = Text::MeCab->new();
my $node = $mecab->parse($text);
my $words_ref = [];
while ($node) {
if (&_is_keyword($node->posid)) {
push @$words_ref, $node->surface;
}
$node = $node->next;
}
return $words_ref;
}
sub save_state {
my ($self, $path) = @_;
$nb->save_state($path);
}
sub restore_state {
my ($self, $path) = @_;
$nb = Algorithm::NaiveBayes->restore_state($path);
}
sub _is_keyword {
my $posid = shift;
return &_is_noun($posid) || &_is_verb($posid) || &_is_adj($posid);
}
# See: http://mecab.googlecode.com/svn/trunk/mecab/doc/posid.html
sub _is_interjection {
return $_[0] == 2;
}
sub _is_adj {
return 10 <= $_[0] && $_[0] < 13;
}
sub _is_aux {
return $_[0] == 25;
}
sub _is_conjunction {
return $_[0] == 26;
}
sub _is_particls {
return 27 <= $_[0] && $_[0] < 31;
}
sub _is_verb {
return 31 <= $_[0] && $_[0] < 34;
}
sub _is_noun {
return 36 <= $_[0] && $_[0] < 68;
}
sub _is_prenominal_adj {
return $_[0] == 68;
}
__PACKAGE__->meta->make_immutable();
1;
lib/AI/Classifier/Japanese.pm view on Meta::CPAN
AI::Classifier::Japanese - the combination wrapper of Algorithm::NaiveBayes and
Text::MeCab.
=head1 SYNOPSIS
use AI::Classifier::Japanese;
# Create new instance
my $classifier = AI::Classifier::Japanese->new();
# Add training text
$classifier->add_training_text("ãŸã®ã—ã„．楽ã—ã„ï¼", 'positive');
$classifier->add_training_text("ã¤ã‚‰ã„．辛ã„ï¼", 'negative');
# Train
$classifier->train;
# Test
my $result_ref = $classifier->predict("ãŸã®ã—ã„");
print $result_ref->{'positive'}; # => Confidence value
=head1 DESCRIPTION
AI::Classifier::Japanese is a Japanese-text category classifier module using Naive Bayes and MeCab.
This module is based on Algorithm::NaiveBayes.
AI-Classifier
view release on metacpan or search on metacpan
lib/AI/Classifier/Text.pm view on Meta::CPAN
package AI::Classifier::Text;
{
$AI::Classifier::Text::VERSION = '0.03';
}
use strict;
use warnings;
use 5.010;
lib/AI/Classifier/Text.pm view on Meta::CPAN
has analyzer => ( is => 'ro', default => sub{ AI::Classifier::Text::Analyzer->new() } );
# for store/load only, don't touch unless you really know what you're doing
has classifier_class => (is => 'bare');
before store => sub {
my $self = shift;
$self->{classifier_class} = $self->classifier->meta->name;
};
around load => sub {
my ($orig, $class) = (shift, shift);
my $self = $class->$orig(@_);
Module::Load::load($self->{classifier_class});
return $self;
};
sub classify {
my( $self, $text, $features ) = @_;
return $self->classifier->classify( $self->analyzer->analyze( $text, $features ) );
}
__PACKAGE__->meta->make_immutable;
1;
lib/AI/Classifier/Text.pm view on Meta::CPAN
version 0.03
=head1 SYNOPSIS
my $cl = AI::Classifier::Text->new(classifier => AI::NaiveBayes->new(...));
my $res = $cl->classify("do cats eat bats?");
$res = $cl->classify("do cats eat bats?", { new_user => 1 });
$cl->store('some-file');
# later
my $cl = AI::Classifier::Text->load('some-file');
my $res = $cl->classify("do cats eat bats?");
=head1 DESCRIPTION
AI::Classifier::Text combines a lexical analyzer (by default being
L<AI::Classifier::Text::Analyzer>) and a classifier (like AI::NaiveBayes) to
AI-CleverbotIO
view release on metacpan or search on metacpan
lib/AI/CleverbotIO.pm view on Meta::CPAN
use Log::Any ();
use Data::Dumper;
use JSON::PP qw< decode_json >;
has endpoints => (
is => 'ro',
default => sub {
return {
ask => 'https://cleverbot.io/1.0/ask',
create => 'https://cleverbot.io/1.0/create',
};
},
);
has key => (
is => 'ro',
required => 1,
);
has logger => (
is => 'ro',
lazy => 1,
builder => 'BUILD_logger',
);
has nick => (
is => 'rw',
lazy => 1,
predicate => 1,
);
has user => (
is => 'ro',
required => 1,
);
has ua => (
is => 'ro',
lazy => 1,
builder => 'BUILD_ua',
);
sub BUILD_logger {
return Log::Any->get_logger;
}
sub BUILD_ua {
my $self = shift;
require HTTP::Tiny;
return HTTP::Tiny->new;
}
sub ask {
my ($self, $question) = @_;
my %ps = (
key => $self->key,
text => $question,
user => $self->user,
);
$ps{nick} = $self->nick if $self->has_nick;
return $self->_parse_response(
$self->ua->post_form($self->endpoints->{ask}, \%ps));
}
sub create {
my $self = shift;
$self->nick(shift) if @_;
# build request parameters
my %ps = (
key => $self->key,
user => $self->user,
);
$ps{nick} = $self->nick if $self->has_nick && length $self->nick;
my $data =
$self->_parse_response(
$self->ua->post_form($self->endpoints->{create}, \%ps));
$self->nick($data->{nick}) if exists($data->{nick});
return $data;
}
sub _parse_response {
my ($self, $response) = @_;
{
local $Data::Dumper::Indent = 1;
$self->logger->debug('got response: ' . Dumper($response));
}
ouch 500, 'no response (possible bug in HTTP::Tiny though?)'
unless ref($response) eq 'HASH';
my $status = $response->{status};
ouch $status, $response->{reason}
if ($status != 200) && ($status != 400);
my $data = __decode_content($response);
return $data if $response->{success};
ouch 400, $data->{status};
} ## end sub _parse_response
sub __decode_content {
my $response = shift;
my $encoded = $response->{content};
if (!$encoded) {
my $url = $response->{url} // '*unknown url, check HTTP::Tiny*';
ouch 500, "response status $response->{status}, nothing from $url)";
}
my $decoded = eval { decode_json($encoded) }
or ouch 500, "response status $response->{status}, exception: $@";
return $decoded;
} ## end sub __decode_content
1;
AI-ConfusionMatrix
view release on metacpan or search on metacpan
lib/AI/ConfusionMatrix.pm view on Meta::CPAN
use Tie::File;
# ABSTRACT: Make a confusion matrix
sub makeConfusionMatrix {
my ($matrix, $file, $delem) = @_;
unless(defined $delem) {
$delem = ',';
}
carp ('First argument must be a hash reference') if ref($matrix) ne 'HASH';
my %cmData = genConfusionMatrixData($matrix);
# This ties @output_array to the output file. Each output_array item represents a line in the output file
tie my @output_array, 'Tie::File', $file or carp "$!";
# Empty the file
@output_array = ();
my @columns = @{$cmData{columns}};
map {$output_array[0] .= $delem . $_} join $delem, (@columns, 'TOTAL', 'TP', 'FP', 'FN', 'SENS', 'ACC');
my $line = 1;
my @expected = sort keys %{$matrix};
for my $expected (@expected) {
$output_array[$line] = $expected;
my $lastIndex = 0;
my $index;
for my $predicted (sort keys %{$matrix->{$expected}}) {
# Calculate the index of the label in the output_array of columns
$index = _findIndex($predicted, \@columns);
# Print some of the delimiter to get to the column of the next value predicted
$output_array[$line] .= $delem x ($index - $lastIndex) . $matrix->{$expected}{$predicted};
$lastIndex = $index;
}
# Get to the columns of the stats
$output_array[$line] .= $delem x (scalar(@columns) - $lastIndex + 1);
$output_array[$line] .= join $delem, (
$cmData{stats}{$expected}{'total'},
$cmData{stats}{$expected}{'tp'},
$cmData{stats}{$expected}{'fp'},
$cmData{stats}{$expected}{'fn'},
sprintf('%.2f%%', $cmData{stats}{$expected}{'sensitivity'}),
sprintf('%.2f%%', $cmData{stats}{$expected}{'acc'})
);
++$line;
}
# Print the TOTAL row to the csv file
$output_array[$line] = 'TOTAL' . $delem;
map {$output_array[$line] .= $cmData{totals}{$_} . $delem} (@columns);
$output_array[$line] .= join $delem, (
$cmData{totals}{'total'},
$cmData{totals}{'tp'},
$cmData{totals}{'fp'},
$cmData{totals}{'fn'},
sprintf('%.2f%%', $cmData{totals}{'sensitivity'}),
sprintf('%.2f%%', $cmData{totals}{'acc'})
);
untie @output_array;
}
sub getConfusionMatrix {
my ($matrix) = @_;
carp ('First argument must be a hash reference') if ref($matrix) ne 'HASH';
return genConfusionMatrixData($matrix);
}
sub genConfusionMatrixData {
my $matrix = shift;
my @expected = sort keys %{$matrix};
my %stats;
my %totals;
my @columns;
for my $expected (@expected) {
$stats{$expected}{'fn'} = 0;
$stats{$expected}{'tp'} = 0;
# Ensure that the False Positive counter is defined to be able to compute the total later
unless(defined $stats{$expected}{'fp'}) {
$stats{$expected}{'fp'} = 0;
}
for my $predicted (keys %{$matrix->{$expected}}) {
$stats{$expected}{'total'} += $matrix->{$expected}->{$predicted};
$stats{$expected}{'tp'} += $matrix->{$expected}->{$predicted} if $expected eq $predicted;
if ($expected ne $predicted) {
$stats{$expected}{'fn'} += $matrix->{$expected}->{$predicted};
$stats{$predicted}{'fp'} += $matrix->{$expected}->{$predicted};
}
$totals{$predicted} += $matrix->{$expected}->{$predicted};
# Add the label to the array of columns if it does not contain it already
push @columns, $predicted unless _findIndex($predicted, \@columns);
}
$stats{$expected}{'acc'} = ($stats{$expected}{'tp'} * 100) / $stats{$expected}{'total'};
}
for my $expected (@expected) {
$totals{'total'} += $stats{$expected}{'total'};
$totals{'tp'} += $stats{$expected}{'tp'};
$totals{'fn'} += $stats{$expected}{'fn'};
$totals{'fp'} += $stats{$expected}{'fp'};
$stats{$expected}{'sensitivity'} = ($stats{$expected}{'tp'} * 100) / ($stats{$expected}{'tp'} + $stats{$expected}{'fp'});
}
$totals{'acc'} = ($totals{'tp'} * 100) / $totals{'total'};
$totals{'sensitivity'} = ($totals{'tp'} * 100) / ($totals{'tp'} + $totals{'fp'});
return (
columns => [sort @columns],
stats => \%stats,
totals => \%totals
);
}
sub _findIndex {
my ($string, $array) = @_;
for (0 .. @$array - 1) {
return $_ + 1 if ($string eq @{$array}[$_]);
}
}
=head1 NAME
AI::ConfusionMatrix - make a confusion matrix
=head1 SYNOPSIS
my %matrix;
# Loop over your predictions
# [...]
$matrix{$expected}{$predicted} += 1;
# [...]
makeConfusionMatrix(\%matrix, 'output.csv');
=head1 DESCRIPTION
This module prints a L<confusion matrix|https://en.wikipedia.org/wiki/Confusion_matrix> from a hash reference. This module tries to be generic enough to be used within a lot of machine learning projects.
lib/AI/ConfusionMatrix.pm view on Meta::CPAN
This function makes a confusion matrix from C<$hash_ref> and writes it to C<$file>. C<$file> can be a filename or a file handle opened with the C<w+> mode. If C<$delimiter> is present, it is used as a custom separator for the fields in the confusion ...
Examples:
makeConfusionMatrix(\%matrix, 'output.csv');
makeConfusionMatrix(\%matrix, 'output.csv', ';');
makeConfusionMatrix(\%matrix, *$fh);
The hash reference must look like this :
$VAR1 = {
'value_expected1' => {
'value_predicted1' => number_of_predictions
},
'value_expected2' => {
'value_predicted1' => number_of_predictions,
'value_predicted2' => number_of_predictions
},
'value_expected3' => {
'value_predicted3' => number_of_predictions
}
};
The output will be in CSV. Here is an example:
,1974,1978,2002,2003,2005,TOTAL,TP,FP,FN,SENS,ACC
1974,3,1,,,2,6,3,4,3,42.86%,50.00%
1978,1,5,,,,6,5,4,1,55.56%,83.33%
2002,2,2,8,,,12,8,1,4,88.89%,66.67%
2003,1,,,7,2,10,7,0,3,100.00%,70.00%
2005,,1,1,,6,8,6,4,2,60.00%,75.00%
TOTAL,7,9,9,7,10,42,29,13,13,69.05%,69.05%
Prettified:
| | 1974 | 1978 | 2002 | 2003 | 2005 | TOTAL | TP | FP | FN | SENS | ACC |
|-------|------|------|------|------|------|-------|----|----|----|---------|--------|
| 1974 | 3 | 1 | | | 2 | 6 | 3 | 4 | 3 | 42.86% | 50.00% |
| 1978 | 1 | 5 | | | | 6 | 5 | 4 | 1 | 55.56% | 83.33% |
| 2002 | 2 | 2 | 8 | | | 12 | 8 | 1 | 4 | 88.89% | 66.67% |
| 2003 | 1 | | | 7 | 2 | 10 | 7 | 0 | 3 | 100.00% | 70.00% |
| 2005 | | 1 | 1 | | 6 | 8 | 6 | 4 | 2 | 60.00% | 75.00% |
| TOTAL | 7 | 9 | 9 | 7 | 10 | 42 | 29 | 13 | 13 | 69.05% | 69.05% |
=over
=item TP:
lib/AI/ConfusionMatrix.pm view on Meta::CPAN
Get the data used to compute the table above.
Example:
my %cm = getConfusionMatrix(\%matrix);
=head1 AUTHOR
Vincent Lequertier <vi.le@autistici.org>
AI-DecisionTree
view release on metacpan or search on metacpan
Instance/Instance.pm view on Meta::CPAN
AI::DecisionTree::Instance - C-struct wrapper for training instances
=head1 SYNOPSIS
use AI::DecisionTree::Instance;
my $i = new AI::DecisionTree::Instance([3,5], 7, 'this_instance');
$i->value_int(0) == 3;
$i->value_int(1) == 5;
$i->result_int == 7;
=head1 DESCRIPTION
This class is just a simple Perl wrapper around a C struct embodying a
single training instance. Its purpose is to reduce memory usage. In
AI-Embedding
view release on metacpan or search on metacpan
lib/AI/Embedding.pm view on Meta::CPAN
package AI::Embedding;
use strict;
use warnings;
use HTTP::Tiny;
use JSON::PP;
use Data::CosineSimilarity;
our $VERSION = '1.11';
$VERSION = eval $VERSION;
my $http = HTTP::Tiny->new;
# Create Embedding object
sub new {
my $class = shift;
my %attr = @_;
$attr{'error'} = '';
$attr{'api'} = 'OpenAI' unless $attr{'api'};
$attr{'error'} = 'Invalid API' unless $attr{'api'} eq 'OpenAI';
$attr{'error'} = 'API Key missing' unless $attr{'key'};
$attr{'model'} = 'text-embedding-ada-002' unless $attr{'model'};
return bless \%attr, $class;
}
# Define endpoints for APIs
my %url = (
'OpenAI' => 'https://api.openai.com/v1/embeddings',
);
# Define HTTP Headers for APIs
my %header = (
'OpenAI' => &_get_header_openai,
);
# Returns true if last operation was success
sub success {
my $self = shift;
return !$self->{'error'};
}
# Returns error if last operation failed
sub error {
my $self = shift;
return $self->{'error'};
}
# Header for calling OpenAI
sub _get_header_openai {
my $self = shift;
$self->{'key'} = '' unless defined $self->{'key'};
return {
'Authorization' => 'Bearer ' . $self->{'key'},
'Content-type' => 'application/json'
};
}
# Fetch Embedding response
sub _get_embedding {
my ($self, $text) = @_;
my $response = $http->post($url{$self->{'api'}}, {
'headers' => {
'Authorization' => 'Bearer ' . $self->{'key'},
'Content-type' => 'application/json'
},
content => encode_json {
input => $text,
model => $self->{'model'},
}
});
if ($response->{'content'} =~ 'invalid_api_key') {
die 'Incorrect API Key - check your API Key is correct';
}
return $response;
}
# TODO:
# Make 'headers' use $header{$self->{'api'}}
# Currently hard coded to OpenAI
# Added purely for testing - IGNORE!
sub _test {
my $self = shift;
# return $self->{'api'};
return $header{$self->{'api'}};
}
# Return Embedding as a CSV string
sub embedding {
my ($self, $text, $verbose) = @_;
my $response = $self->_get_embedding($text);
if ($response->{'success'}) {
my $embedding = decode_json($response->{'content'});
return join (',', @{$embedding->{'data'}[0]->{'embedding'}});
}
$self->{'error'} = 'HTTP Error - ' . $response->{'reason'};
return $response if defined $verbose;
return undef;
}
# Return Embedding as an array
sub raw_embedding {
my ($self, $text, $verbose) = @_;
my $response = $self->_get_embedding($text);
if ($response->{'success'}) {
my $embedding = decode_json($response->{'content'});
return @{$embedding->{'data'}[0]->{'embedding'}};
}
$self->{'error'} = 'HTTP Error - ' . $response->{'reason'};
return $response if defined $verbose;
return undef;
}
# Return Test Embedding
sub test_embedding {
my ($self, $text, $dimension) = @_;
$self->{'error'} = '';
$dimension = 1536 unless defined $dimension;
if ($text) {
srand scalar split /\s+/, $text;
}
my @vector;
for (1...$dimension) {
push @vector, rand(2) - 1;
}
return join ',', @vector;
}
# Convert a CSV Embedding into a hashref
sub _make_vector {
my ($self, $embed_string) = @_;
if (!defined $embed_string) {
$self->{'error'} = 'Nothing to compare!';
return;
}
my %vector;
my @embed = split /,/, $embed_string;
for (my $i = 0; $i < @embed; $i++) {
$vector{'feature' . $i} = $embed[$i];
}
return \%vector;
}
# Return a comparator to compare to a set vector
sub comparator {
my($self, $embed) = @_;
$self->{'error'} = '';
my $vector1 = $self->_make_vector($embed);
return sub {
my($embed2) = @_;
my $vector2 = $self->_make_vector($embed2);
return $self->_compare_vector($vector1, $vector2);
};
}
# Compare 2 Embeddings
sub compare {
my ($self, $embed1, $embed2) = @_;
my $vector1 = $self->_make_vector($embed1);
my $vector2;
if (defined $embed2) {
$vector2 = $self->_make_vector($embed2);
} else {
$vector2 = $self->{'comparator'};
}
if (!defined $vector2) {
$self->{'error'} = 'Nothing to compare!';
return;
}
if (scalar keys %$vector1 != scalar keys %$vector2) {
$self->{'error'} = 'Embeds are unequal length';
return;
}
return $self->_compare_vector($vector1, $vector2);
}
# Compare 2 Vectors
sub _compare_vector {
my ($self, $vector1, $vector2) = @_;
my $cs = Data::CosineSimilarity->new;
$cs->add( label1 => $vector1 );
$cs->add( label2 => $vector2 );
return $cs->similarity('label1', 'label2')->cosine;
}
1;
__END__
=encoding utf8
=head1 NAME
AI::Embedding - Perl module for working with text embeddings using various APIs
=head1 VERSION
Version 1.11
=head1 SYNOPSIS
use AI::Embedding;
my $embedding = AI::Embedding->new(
api => 'OpenAI',
key => 'your-api-key'
);
my $csv_embedding = $embedding->embedding('Some sample text');
my $test_embedding = $embedding->test_embedding('Some sample text');
my @raw_embedding = $embedding->raw_embedding('Some sample text');
my $cmp = $embedding->comparator($csv_embedding2);
my $similarity = $cmp->($csv_embedding1);
my $similarity_with_other_embedding = $embedding->compare($csv_embedding1, $csv_embedding2);
=head1 DESCRIPTION
The L<AI::Embedding> module provides an interface for working with text embeddings using various APIs. It currently supports the L<OpenAI|https://www.openai.com> L<Embeddings API|https://platform.openai.com/docs/guides/embeddings/what-are-embeddings>...
Embeddings allow the meaning of passages of text to be compared for similarity. This is more natural and useful to humans than using traditional keyword based comparisons.
An Embedding is a multi-dimensional vector representing the meaning of a piece of text. The Embedding vector is created by an AI Model. The default model (OpenAI's C<text-embedding-ada-002>) produces a 1536 dimensional vector. The resulting vector...
=head2 Comparator
Embeddings are used to compare similarity of meaning between two passages of text. A typical work case is to store a number of pieces of text (e.g. articles or blogs) in a database and compare each one to some user supplied search text. L<AI::Embed...
Alternatively, the C<comparator> method can be called with one Embedding. The C<comparator> returns a reference to a method that takes a single Embedding to be compared to the Embedding from which the Comparator was created.
When comparing multiple Embeddings to the same Embedding (such as search text) it is faster to use a C<comparator>.
=head1 CONSTRUCTOR
=head2 new
my $embedding = AI::Embedding->new(
api => 'OpenAI',
key => 'your-api-key',
model => 'text-embedding-ada-002',
);
Creates a new AI::Embedding object. It requires the 'key' parameter. The 'key' parameter is the API key provided by the service provider and is required.
Parameters:
=over
=item *
C<key> - B<required> The API Key
=item *
C<api> - The API to use. Currently only 'OpenAI' is supported and this is the default.
=item *
C<model> - The language model to use. Defaults to C<text-embedding-ada-002> - see L<OpenAI docs|https://platform.openai.com/docs/guides/embeddings/what-are-embeddings>
=back
=head1 METHODS
=head2 success
Returns true if the last method call was successful
=head2 error
Returns the last error message or an empty string if B<success> returned true
=head2 embedding
my $csv_embedding = $embedding->embedding('Some text passage', [$verbose]);
Generates an embedding for the given text and returns it as a comma-separated string. The C<embedding> method takes a single parameter, the text to generate the embedding for.
Returns a (rather long) string that can be stored in a C<TEXT> database field.
If the method call fails it sets the L</"error"> message and returns C<undef>. If the optional C<verbose> parameter is true, the complete L<HTTP::Tiny> response object is also returned to aid with debugging issues when using this module.
=head2 raw_embedding
my @raw_embedding = $embedding->raw_embedding('Some text passage', [$verbose]);
Generates an embedding for the given text and returns it as an array. The C<raw_embedding> method takes a single parameter, the text to generate the embedding for.
It is not normally necessary to use this method as the Embedding will almost always be used as a single homogeneous unit.
If the method call fails it sets the L</"error"> message and returns C<undef>. If the optional C<verbose> parameter is true, the complete L<HTTP::Tiny> response object is also returned to aid with debugging issues when using this module.
=head2 test_embedding
my $test_embedding = $embedding->test_embedding('Some text passage', $dimensions);
Used for testing code without making a chargeable call to the API.
Provides a CSV string of the same size and format as L<embedding> but with meaningless random data.
Returns a random embedding. Both parameters are optional. If a text string is provided, the returned embedding will always be the same random embedding otherwise it will be random and different every time. The C<dimension> parameter controls the n...
=head2 comparator
$embedding->comparator($csv_embedding2);
Sets a vector as a C<comparator> for future comparisons and returns a reference to a method for using the C<comparator>.
The B<comparator> method takes a single parameter, the comma-separated Embedding string to use as the comparator.
The following two are functionally equivalent. However, where multiple Embeddings are to be compared to a single Embedding, using a L<Comparator> is significantly faster.
my $similarity = $embedding->compare($csv_embedding1, $csv_embedding2);
my $cmp = $embedding->comparator($csv_embedding2);
my $similarity = $cmp->($csv_embedding1);
See L</"Comparator">
The returned method reference returns the cosine similarity between the Embedding used to call the C<comparator> method and the Embedding supplied to the method reference. See L<compare> for an explanation of the cosine similarity.
=head2 compare
my $similarity_with_other_embedding = $embedding->compare($csv_embedding1, $csv_embedding2);
Compares two embeddings and returns the cosine similarity between them. The B<compare> method takes two parameters: $csv_embedding1 and $csv_embedding2 (both comma-separated embedding strings).
Returns the cosine similarity as a floating-point number between -1 and 1, where 1 represents identical embeddings, 0 represents no similarity, and -1 represents opposite embeddings.
The absolute number is not usually relevant for text comparision. It is usually sufficient to rank the comparison results in order of high to low to reflect the best match to the worse match.
=head1 SEE ALSO
L<https://openai.com> - OpenAI official website
=head1 AUTHOR
Ian Boddison <ian at boddison.com>
=head1 BUGS
Please report any bugs or feature requests to C<bug-ai-embedding at rt.cpan.org>, or through
the web interface at L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=bug-ai-embedding>. I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc AI::Embedding
You can also look for information at:
=over 4
=item * RT: CPAN's request tracker (report bugs here)
L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=AI-Embedding>
=item * Search CPAN
L<https://metacpan.org/release/AI::Embedding>
=back
=head1 ACKNOWLEDGEMENTS
Thanks to the help and support provided by members of Perl Monks L<https://perlmonks.org/>.
Especially L<Ken Cotterill (KCOTT)|https://metacpan.org/author/KCOTT> for assistance with unit tests and L<Hugo van der Sanden (HVDS)|https://metacpan.org/author/HVDS> for suggesting the current C<comparator> implementaion.
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2023 by Ian Boddison.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
AI-Evolve-Befunge
view release on metacpan or search on metacpan
lib/AI/Evolve/Befunge.pm view on Meta::CPAN
our $VERSION = "0.03";
=head1 NAME
AI::Evolve::Befunge - practical evolution of Befunge AI programs
=head1 SYNOPSIS
use aliased 'AI::Evolve::Befunge::Population' => 'Population';
use AI::Evolve::Befunge::Util qw(v nonquiet);
$pop = Population->new();
while(1) {
my $gen = $pop->generation;
nonquiet("generation $gen\n");
$pop->fight();
$pop->breed();
$pop->migrate();
$pop->save();
$pop->generation($gen+1);
}
=head1 DESCRIPTION
This software project provides all of the necessary tools to grow a
AI-ExpertSystem-Advanced
view release on metacpan or search on metacpan
examples/backward.pl view on Meta::CPAN
use Data::Dumper;
use AI::ExpertSystem::Advanced;
use AI::ExpertSystem::Advanced::KnowledgeDB::Factory;
my $yaml_kdb = AI::ExpertSystem::Advanced::KnowledgeDB::Factory->new('yaml',
{
filename => 'examples/knowledge_db_one.yaml'
});
my $ai = AI::ExpertSystem::Advanced->new(
viewer_class => 'terminal',
knowledge_db => $yaml_kdb,
goals_to_check => ['J']);
$ai->backward();
$ai->summary();
AI-ExpertSystem-Simple
view release on metacpan or search on metacpan
lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN
use AI::ExpertSystem::Simple::Goal;
our $VERSION = '1.2';
sub new {
my ($class) = @_;
die "Simple->new() takes no arguments" if scalar(@_) != 1;
my $self = {};
$self->{_rules} = ();
$self->{_knowledge} = ();
$self->{_goal} = undef;
$self->{_filename} = undef;
$self->{_ask_about} = undef;
$self->{_told_about} = undef;
$self->{_log} = ();
$self->{_number_of_rules} = 0;
$self->{_number_of_attributes} = 0;
$self->{_number_of_questions} = 0;
return bless $self, $class;
}
sub reset {
my ($self) = @_;
die "Simple->reset() takes no arguments" if scalar(@_) != 1;
foreach my $name (keys %{$self->{_rules}}) {
$self->{_rules}->{$name}->reset();
}
foreach my $name (keys %{$self->{_knowledge}}) {
$self->{_knowledge}->{$name}->reset();
}
$self->{_ask_about} = undef;
$self->{_told_about} = undef;
$self->{_log} = ();
}
sub load {
my ($self, $filename) = @_;
die "Simple->load() takes 1 argument" if scalar(@_) != 2;
die "Simple->load() argument 1 (FILENAME) is undefined" if !defined($filename);
if(-f $filename and -r $filename) {
my $twig = XML::Twig->new(
twig_handlers => { goal => sub { $self->_goal(@_) },
rule => sub { $self->_rule(@_) },
question => sub { $self->_question(@_) } }
);
$twig->safe_parsefile($filename);
die "Simple->load() XML parse failed: $@" if $@;
$self->{_filename} = $filename;
$self->_add_to_log( "Read in $filename" );
$self->_add_to_log( "There are " . $self->{_number_of_rules} . " rules" );
$self->_add_to_log( "There are " . $self->{_number_of_attributes} . " attributes" );
$self->_add_to_log( "There are " . $self->{_number_of_questions} . " questions" );
$self->_add_to_log( "The goal attibutes is " . $self->{_goal}->name() );
return 1;
} else {
die "Simple->load() unable to use file";
}
}
sub _goal {
my ($self, $t, $node) = @_;
my $attribute = undef;
my $text = undef;
my $x = ($node->children('attribute'))[0];
$attribute = $x->text();
$x = ($node->children('text'))[0];
$text = $x->text();
$self->{_goal} = AI::ExpertSystem::Simple::Goal->new($attribute, $text);
eval { $t->purge(); }
}
sub _rule {
my ($self, $t, $node) = @_;
my $name = undef;
my $x = ($node->children('name'))[0];
$name = $x->text();
if(!defined($self->{_rules}->{$name})) {
$self->{_rules}->{$name} = AI::ExpertSystem::Simple::Rule->new($name);
$self->{_number_of_rules}++;
}
foreach $x ($node->get_xpath('//condition')) {
my $attribute = undef;
my $value = undef;
my $y = ($x->children('attribute'))[0];
$attribute = $y->text();
$y = ($x->children('value'))[0];
$value = $y->text();
$self->{_rules}->{$name}->add_condition($attribute, $value);
if(!defined($self->{_knowledge}->{$attribute})) {
$self->{_number_of_attributes}++;
$self->{_knowledge}->{$attribute} = AI::ExpertSystem::Simple::Knowledge->new($attribute);
}
}
foreach $x ($node->get_xpath('//action')) {
my $attribute = undef;
my $value = undef;
my $y = ($x->children('attribute'))[0];
$attribute = $y->text();
$y = ($x->children('value'))[0];
$value = $y->text();
$self->{_rules}->{$name}->add_action($attribute, $value);
if(!defined($self->{_knowledge}->{$attribute})) {
$self->{_number_of_attributes}++;
$self->{_knowledge}->{$attribute} = AI::ExpertSystem::Simple::Knowledge->new($attribute);
}
}
eval { $t->purge(); }
}
sub _question {
my ($self, $t, $node) = @_;
my $attribute = undef;
my $text = undef;
my @responses = ();
$self->{_number_of_questions}++;
my $x = ($node->children('attribute'))[0];
$attribute = $x->text();
$x = ($node->children('text'))[0];
$text = $x->text();
foreach $x ($node->children('response')) {
push(@responses, $x->text());
}
if(!defined($self->{_knowledge}->{$attribute})) {
$self->{_number_of_attributes}++;
$self->{_knowledge}->{$attribute} = AI::ExpertSystem::Simple::Knowledge->new($attribute);
}
$self->{_knowledge}->{$attribute}->set_question($text, @responses);
eval { $t->purge(); }
}
sub process {
my ($self) = @_;
die "Simple->process() takes no arguments" if scalar(@_) != 1;
my $n = $self->{_goal}->name();
if($self->{_knowledge}->{$n}->is_value_set()) {
return 'finished';
}
if($self->{_ask_about}) {
my %answers = ();
$answers{$self->{_ask_about}}->{value} = $self->{_told_about};
$answers{$self->{_ask_about}}->{setter} = '';
$self->{_ask_about} = undef;
$self->{_told_about} = undef;
while(%answers) {
my %old_answers = %answers;
%answers = ();
foreach my $answer (keys(%old_answers)) {
my $n = $answer;
my $v = $old_answers{$answer}->{value};
my $s = $old_answers{$answer}->{setter};
$self->_add_to_log( "Setting '$n' to '$v'" );
$self->{_knowledge}->{$n}->set_value($v,$s);
foreach my $key (keys(%{$self->{_rules}})) {
if($self->{_rules}->{$key}->state() eq 'active') {
my $state = $self->{_rules}->{$key}->given($n, $v);
if($state eq 'completed') {
$self->_add_to_log( "Rule '$key' has completed" );
my %y = $self->{_rules}->{$key}->actions();
foreach my $k (keys(%y)) {
$self->_add_to_log( "Rule '$key' is setting '$k' to '$y{$k}'" );
$answers{$k}->{value} = $y{$k};
$answers{$k}->{setter} = $key;
}
} elsif($state eq 'invalid') {
$self->_add_to_log( "Rule '$key' is now inactive" );
}
}
}
}
}
return 'continue';
} else {
my %scoreboard = ();
foreach my $rule (keys(%{$self->{_rules}})) {
if($self->{_rules}->{$rule}->state() eq 'active') {
my @listofquestions = $self->{_rules}->{$rule}->unresolved();
my $ok = 1;
my @questionstoask = ();
foreach my $name (@listofquestions) {
if($self->{_knowledge}->{$name}->has_question()) {
push(@questionstoask, $name);
} else {
$ok = 0;
}
}
if($ok == 1) {
foreach my $name (@questionstoask) {
$scoreboard{$name}++;
}
}
}
}
my $max_value = 0;
foreach my $name (keys(%scoreboard)) {
if($scoreboard{$name} > $max_value) {
$max_value = $scoreboard{$name};
$self->{_ask_about} = $name;
}
}
return $self->{_ask_about} ? 'question' : 'failed';
}
}
sub get_question {
my ($self) = @_;
die "Simple->get_question() takes no arguments" if scalar(@_) != 1;
return $self->{_knowledge}->{$self->{_ask_about}}->get_question();
}
sub answer {
my ($self, $value) = @_;
die "Simple->answer() takes 1 argument" if scalar(@_) != 2;
die "Simple->answer() argument 1 (VALUE) is undefined" if ! defined($value);
$self->{_told_about} = $value;
}
sub get_answer {
my ($self) = @_;
die "Simple->get_answer() takes no arguments" if scalar(@_) != 1;
my $n = $self->{_goal}->name();
return $self->{_goal}->answer($self->{_knowledge}->{$n}->get_value());
}
sub log {
my ($self) = @_;
die "Simple->log() takes no arguments" if scalar(@_) != 1;
my @return = ();
@return = @{$self->{_log}} if defined @{$self->{_log}};
$self->{_log} = ();
return @return;
}
sub _add_to_log {
my ($self, $message) = @_;
push( @{$self->{_log}}, $message );
}
sub explain {
my ($self) = @_;
die "Simple->explain() takes no arguments" if scalar(@_) != 1;
my $name = $self->{_goal}->name();
my $rule = $self->{_knowledge}->{$name}->get_setter();
my $value = $self->{_knowledge}->{$name}->get_value();
my $x = "The goal '$name' was set to '$value' by " . ($rule ? "rule '$rule'" : 'asking a question' );
$self->_add_to_log( $x );
my @processed_rules;
push( @processed_rules, $rule ) if $rule;
$self->_explain_this( $rule, '', @processed_rules );
}
sub _explain_this {
my ($self, $rule, $depth, @processed_rules) = @_;
$self->_add_to_log( "${depth}Explaining rule '$rule'" );
my %dont_do_these = map{ $_ => 1 } @processed_rules;
my @check_these_rules = ();
my %conditions = $self->{_rules}->{$rule}->conditions();
foreach my $name (sort keys %conditions) {
my $value = $conditions{$name};
my $setter = $self->{_knowledge}->{$name}->get_setter();
my $x = "$depth Condition '$name' was set to '$value' by " . ($setter ? "rule '$setter'" : 'asking a question' );
$self->_add_to_log( $x );
if($setter) {
unless($dont_do_these{$setter}) {
$dont_do_these{$setter} = 1;
push( @check_these_rules, $setter );
}
}
}
my %actions = $self->{_rules}->{$rule}->actions();
foreach my $name (sort keys %actions) {
my $value = $actions{$name};
my $x = "$depth Action set '$name' to '$value'";
$self->_add_to_log( $x );
}
@processed_rules = keys %dont_do_these;
foreach my $x ( @check_these_rules ) {
push( @processed_rules, $self->_explain_this( $x, "$depth ", keys %dont_do_these ) );
}
return @processed_rules;
}
1;
=head1 NAME
AI-FANN-Evolving
view release on metacpan or search on metacpan
lib/AI/FANN/Evolving.pm view on Meta::CPAN
our $VERSION = '0.4';
our $AUTOLOAD;
my $log = __PACKAGE__->logger;
my %enum = (
'train' => {
# 'FANN_TRAIN_INCREMENTAL' => FANN_TRAIN_INCREMENTAL, # only want batch training
'FANN_TRAIN_BATCH' => FANN_TRAIN_BATCH,
'FANN_TRAIN_RPROP' => FANN_TRAIN_RPROP,
'FANN_TRAIN_QUICKPROP' => FANN_TRAIN_QUICKPROP,
},
'activationfunc' => {
'FANN_LINEAR' => FANN_LINEAR,
# 'FANN_THRESHOLD' => FANN_THRESHOLD, # can not be used during training
# 'FANN_THRESHOLD_SYMMETRIC' => FANN_THRESHOLD_SYMMETRIC, # can not be used during training
# 'FANN_SIGMOID' => FANN_SIGMOID, # range is between 0 and 1
# 'FANN_SIGMOID_STEPWISE' => FANN_SIGMOID_STEPWISE, # range is between 0 and 1
'FANN_SIGMOID_SYMMETRIC' => FANN_SIGMOID_SYMMETRIC,
'FANN_SIGMOID_SYMMETRIC_STEPWISE' => FANN_SIGMOID_SYMMETRIC_STEPWISE,
# 'FANN_GAUSSIAN' => FANN_GAUSSIAN, # range is between 0 and 1
'FANN_GAUSSIAN_SYMMETRIC' => FANN_GAUSSIAN_SYMMETRIC,
'FANN_GAUSSIAN_STEPWISE' => FANN_GAUSSIAN_STEPWISE,
# 'FANN_ELLIOT' => FANN_ELLIOT, # range is between 0 and 1
'FANN_ELLIOT_SYMMETRIC' => FANN_ELLIOT_SYMMETRIC,
# 'FANN_LINEAR_PIECE' => FANN_LINEAR_PIECE, # range is between 0 and 1
'FANN_LINEAR_PIECE_SYMMETRIC' => FANN_LINEAR_PIECE_SYMMETRIC,
'FANN_SIN_SYMMETRIC' => FANN_SIN_SYMMETRIC,
'FANN_COS_SYMMETRIC' => FANN_COS_SYMMETRIC,
# 'FANN_SIN' => FANN_SIN, # range is between 0 and 1
# 'FANN_COS' => FANN_COS, # range is between 0 and 1
},
'errorfunc' => {
'FANN_ERRORFUNC_LINEAR' => FANN_ERRORFUNC_LINEAR,
'FANN_ERRORFUNC_TANH' => FANN_ERRORFUNC_TANH,
},
'stopfunc' => {
'FANN_STOPFUNC_MSE' => FANN_STOPFUNC_MSE,
# 'FANN_STOPFUNC_BIT' => FANN_STOPFUNC_BIT,
}
);
my %constant;
for my $hashref ( values %enum ) {
while( my ( $k, $v ) = each %{ $hashref } ) {
$constant{$k} = $v;
}
}
my %default = (
'error' => 0.0001,
'epochs' => 5000,
'train_type' => 'ordinary',
'epoch_printfreq' => 100,
'neuron_printfreq' => 0,
'neurons' => 15,
'activation_function' => FANN_SIGMOID_SYMMETRIC,
);
=head1 NAME
AI::FANN::Evolving - artificial neural network that evolves
lib/AI/FANN/Evolving.pm view on Meta::CPAN
'connection_rate' argument for sparse topologies. Returns a wrapper around L<AI::FANN>.
=cut
sub new {
my $class = shift;
my %args = @_;
my $self = {};
bless $self, $class;
$self->_init(%args);
# de-serialize from a file
if ( my $file = $args{'file'} ) {
$self->{'ann'} = AI::FANN->new_from_file($file);
$log->debug("instantiating from file $file");
return $self;
}
# build new topology from input data
elsif ( my $data = $args{'data'} ) {
$log->debug("instantiating from data $data");
$data = $data->to_fann if $data->isa('AI::FANN::Evolving::TrainData');
# prepare arguments
my $neurons = $args{'neurons'} || ( $data->num_inputs + 1 );
my @sizes = (
$data->num_inputs,
$neurons,
$data->num_outputs
);
# build topology
if ( $args{'connection_rate'} ) {
$self->{'ann'} = AI::FANN->new_sparse( $args{'connection_rate'}, @sizes );
}
else {
$self->{'ann'} = AI::FANN->new_standard( @sizes );
}
# finalize the instance
return $self;
}
# build new ANN using argument as a template
elsif ( my $ann = $args{'ann'} ) {
$log->debug("instantiating from template $ann");
# copy the wrapper properties
%{ $self } = %{ $ann };
# instantiate the network dimensions
$self->{'ann'} = AI::FANN->new_standard(
$ann->num_inputs,
$ann->num_inputs + 1,
$ann->num_outputs,
);
# copy the AI::FANN properties
$ann->template($self->{'ann'});
return $self;
}
else {
die "Need 'file', 'data' or 'ann' argument!";
}
}
=item template
Uses the object as a template for the properties of the argument, e.g.
$ann1->template($ann2) applies the properties of $ann1 to $ann2
=cut
sub template {
my ( $self, $other ) = @_;
# copy over the simple properties
$log->debug("copying over simple properties");
my %scalar_properties = __PACKAGE__->_scalar_properties;
for my $prop ( keys %scalar_properties ) {
my $val = $self->$prop;
$other->$prop($val);
}
# copy over the list properties
$log->debug("copying over list properties");
my %list_properties = __PACKAGE__->_list_properties;
for my $prop ( keys %list_properties ) {
my @values = $self->$prop;
$other->$prop(@values);
}
# copy over the layer properties
$log->debug("copying over layer properties");
my %layer_properties = __PACKAGE__->_layer_properties;
for my $prop ( keys %layer_properties ) {
for my $i ( 0 .. $self->num_layers - 1 ) {
for my $j ( 0 .. $self->layer_num_neurons($i) - 1 ) {
my $val = $self->$prop($i,$j);
$other->$prop($i,$j,$val);
}
}
}
return $self;
}
=item recombine
Recombines (exchanges) properties between the two objects at the provided rate, e.g.
lib/AI/FANN/Evolving.pm view on Meta::CPAN
exchanged between $ann1 and $ann2
=cut
sub recombine {
my ( $self, $other, $rr ) = @_;
# recombine the simple properties
my %scalar_properties = __PACKAGE__->_scalar_properties;
for my $prop ( keys %scalar_properties ) {
if ( rand(1) < $rr ) {
my $vals = $self->$prop;
my $valo = $other->$prop;
$other->$prop($vals);
$self->$prop($valo);
}
}
# copy over the list properties
my %list_properties = __PACKAGE__->_list_properties;
for my $prop ( keys %list_properties ) {
if ( rand(1) < $rr ) {
my @values = $self->$prop;
my @valueo = $other->$prop;
$other->$prop(@values);
$self->$prop(@valueo);
}
}
# copy over the layer properties
my %layer_properties = __PACKAGE__->_layer_properties;
for my $prop ( keys %layer_properties ) {
for my $i ( 0 .. $self->num_layers - 1 ) {
for my $j ( 0 .. $self->layer_num_neurons($i) - 1 ) {
my $val = $self->$prop($i,$j);
$other->$prop($i,$j,$val);
}
}
}
return $self;
}
=item mutate
Mutates the object by the provided mutation rate
=cut
sub mutate {
my ( $self, $mu ) = @_;
$log->debug("going to mutate at rate $mu");
# mutate the simple properties
$log->debug("mutating scalar properties");
my %scalar_properties = __PACKAGE__->_scalar_properties;
for my $prop ( keys %scalar_properties ) {
my $handler = $scalar_properties{$prop};
my $val = $self->$prop;
if ( ref $handler ) {
$self->$prop( $handler->($val,$mu) );
}
else {
$self->$prop( _mutate_enum($handler,$val,$mu) );
}
}
# mutate the list properties
$log->debug("mutating list properties");
my %list_properties = __PACKAGE__->_list_properties;
for my $prop ( keys %list_properties ) {
my $handler = $list_properties{$prop};
my @values = $self->$prop;
if ( ref $handler ) {
$self->$prop( map { $handler->($_,$mu) } @values );
}
else {
$self->$prop( map { _mutate_enum($handler,$_,$mu) } @values );
}
}
# mutate the layer properties
$log->debug("mutating layer properties");
my %layer_properties = __PACKAGE__->_layer_properties;
for my $prop ( keys %layer_properties ) {
my $handler = $layer_properties{$prop};
for my $i ( 1 .. $self->num_layers ) {
for my $j ( 1 .. $self->layer_num_neurons($i) ) {
my $val = $self->$prop($i,$j);
if ( ref $handler ) {
$self->$prop( $handler->($val,$mu) );
}
else {
$self->$prop( _mutate_enum($handler,$val,$mu) );
}
}
}
}
return $self;
}
sub _mutate_double {
my ( $value, $mu ) = @_;
my $scale = 1 + ( rand( 2 * $mu ) - $mu );
return $value * $scale;
}
sub _mutate_int {
my ( $value, $mu ) = @_;
if ( rand(1) < $mu ) {
my $inc = ( int(rand(2)) * 2 ) - 1;
while( ( $value < 0 ) xor ( ( $value + $inc ) < 0 ) ) {
$inc = ( int(rand(2)) * 2 ) - 1;
}
return $value + $inc;
}
return $value;
}
sub _mutate_enum {
my ( $enum_name, $value, $mu ) = @_;
if ( rand(1) < $mu ) {
my ($newval) = shuffle grep { $_ != $value } values %{ $enum{$enum_name} };
$value = $newval if defined $newval;
}
return $value;
}
sub _list_properties {
(
# cascade_activation_functions => 'activationfunc',
cascade_activation_steepnesses => \&_mutate_double,
)
}
sub _layer_properties {
(
# neuron_activation_function => 'activationfunc',
# neuron_activation_steepness => \&_mutate_double,
)
}
sub _scalar_properties {
(
training_algorithm => 'train',
train_error_function => 'errorfunc',
train_stop_function => 'stopfunc',
learning_rate => \&_mutate_double,
learning_momentum => \&_mutate_double,
quickprop_decay => \&_mutate_double,
quickprop_mu => \&_mutate_double,
rprop_increase_factor => \&_mutate_double,
rprop_decrease_factor => \&_mutate_double,
rprop_delta_min => \&_mutate_double,
rprop_delta_max => \&_mutate_double,
cascade_output_change_fraction => \&_mutate_double,
cascade_candidate_change_fraction => \&_mutate_double,
cascade_output_stagnation_epochs => \&_mutate_int,
cascade_candidate_stagnation_epochs => \&_mutate_int,
cascade_max_out_epochs => \&_mutate_int,
cascade_max_cand_epochs => \&_mutate_int,
cascade_num_candidate_groups => \&_mutate_int,
bit_fail_limit => \&_mutate_double, # 'fann_type',
cascade_weight_multiplier => \&_mutate_double, # 'fann_type',
cascade_candidate_limit => \&_mutate_double, # 'fann_type',
)
}
=item defaults
Getter/setter to influence default ANN configuration
=cut
sub defaults {
my $self = shift;
my %args = @_;
for my $key ( keys %args ) {
$log->info("setting $key to $args{$key}");
if ( $key eq 'activation_function' ) {
$args{$key} = $constant{$args{$key}};
}
$default{$key} = $args{$key};
}
return %default;
}
sub _init {
my $self = shift;
my %args = @_;
for ( qw(error epochs train_type epoch_printfreq neuron_printfreq neurons activation_function) ) {
$self->{$_} = $args{$_} // $default{$_};
}
return $self;
}
=item clone
Clones the object
=cut
sub clone {
my $self = shift;
$log->debug("cloning...");
# we delete the reference here so we can use
# Algorithm::Genetic::Diploid::Base's cloning method, which
# dumps and loads from YAML. This wouldn't work if the
# reference is still attached because it cannot be
# stringified, being an XS data structure
my $ann = delete $self->{'ann'};
my $clone = $self->SUPER::clone;
# clone the ANN by writing it to a temp file in "FANN/FLO"
# format and reading that back in, then delete the file
my ( $fh, $file ) = tempfile();
close $fh;
$ann->save($file);
$clone->{'ann'} = __PACKAGE__->new_from_file($file);
unlink $file;
# now re-attach the original ANN to the invocant
$self->{'ann'} = $ann;
return $clone;
}
=item train
Trains the AI on the provided data object
=cut
sub train {
my ( $self, $data ) = @_;
if ( $self->train_type eq 'cascade' ) {
$log->debug("cascade training");
# set learning curve
$self->cascade_activation_functions( $self->activation_function );
# train
$self->{'ann'}->cascadetrain_on_data(
$data,
$self->neurons,
$self->neuron_printfreq,
$self->error,
);
}
else {
$log->debug("normal training");
# set learning curves
$self->hidden_activation_function( $self->activation_function );
$self->output_activation_function( $self->activation_function );
# train
$self->{'ann'}->train_on_data(
$data,
$self->epochs,
$self->epoch_printfreq,
$self->error,
);
}
}
=item enum_properties
Returns a hash whose keys are names of enums and values the possible states for the
lib/AI/FANN/Evolving.pm view on Meta::CPAN
Getter/setter for the error rate. Default is 0.0001
=cut
sub error {
my $self = shift;
if ( @_ ) {
my $value = shift;
$log->debug("setting error threshold to $value");
return $self->{'error'} = $value;
}
else {
$log->debug("getting error threshold");
return $self->{'error'};
}
}
=item epochs
Getter/setter for the number of training epochs, default is 500000
=cut
sub epochs {
my $self = shift;
if ( @_ ) {
my $value = shift;
$log->debug("setting training epochs to $value");
return $self->{'epochs'} = $value;
}
else {
$log->debug("getting training epochs");
return $self->{'epochs'};
}
}
=item epoch_printfreq
Getter/setter for the number of epochs after which progress is printed. default is 1000
=cut
sub epoch_printfreq {
my $self = shift;
if ( @_ ) {
my $value = shift;
$log->debug("setting epoch printfreq to $value");
return $self->{'epoch_printfreq'} = $value;
}
else {
$log->debug("getting epoch printfreq");
return $self->{'epoch_printfreq'}
}
}
=item neurons
Getter/setter for the number of neurons. Default is 15
=cut
sub neurons {
my $self = shift;
if ( @_ ) {
my $value = shift;
$log->debug("setting neurons to $value");
return $self->{'neurons'} = $value;
}
else {
$log->debug("getting neurons");
return $self->{'neurons'};
}
}
=item neuron_printfreq
Getter/setter for the number of cascading neurons after which progress is printed.
default is 10
=cut
sub neuron_printfreq {
my $self = shift;
if ( @_ ) {
my $value = shift;
$log->debug("setting neuron printfreq to $value");
return $self->{'neuron_printfreq'} = $value;
}
else {
$log->debug("getting neuron printfreq");
return $self->{'neuron_printfreq'};
}
}
=item train_type
Getter/setter for the training type: 'cascade' or 'ordinary'. Default is ordinary
=cut
sub train_type {
my $self = shift;
if ( @_ ) {
my $value = lc shift;
$log->debug("setting train type to $value");
return $self->{'train_type'} = $value;
}
else {
$log->debug("getting train type");
return $self->{'train_type'};
}
}
=item activation_function
Getter/setter for the function that maps inputs to outputs. default is
lib/AI/FANN/Evolving.pm view on Meta::CPAN
=back
=cut
sub activation_function {
my $self = shift;
if ( @_ ) {
my $value = shift;
$log->debug("setting activation function to $value");
return $self->{'activation_function'} = $value;
}
else {
$log->debug("getting activation function");
return $self->{'activation_function'};
}
}
# this is here so that we can trap method calls that need to be
# delegated to the FANN object. at this point we're not even
# going to care whether the FANN object implements these methods:
# if it doesn't we get the normal error for unknown methods, which
# the user then will have to resolve.
sub AUTOLOAD {
my $self = shift;
my $method = $AUTOLOAD;
$method =~ s/.+://;
# ignore all caps methods
if ( $method !~ /^[A-Z]+$/ ) {
# determine whether to invoke on an object or a package
my $invocant;
if ( ref $self ) {
$invocant = $self->{'ann'};
}
else {
$invocant = 'AI::FANN';
}
# determine whether to pass in arguments
if ( @_ ) {
my $arg = shift;
$arg = $constant{$arg} if exists $constant{$arg};
return $invocant->$method($arg);
}
else {
return $invocant->$method;
}
}
}
1;
AI-FANN
view release on metacpan or search on metacpan
lib/AI/FANN.pm view on Meta::CPAN
XSLoader::load('AI::FANN', $VERSION);
use Exporter qw(import);
{
my @constants = _constants();
our %EXPORT_TAGS = ( 'all' => [ @constants ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
require constant;
for my $constant (@constants) {
constant->import($constant, $constant);
}
}
sub num_neurons {
@_ == 1 or croak "Usage: AI::FANN::get_neurons(self)";
my $self = shift;
if (wantarray) {
map { $self->layer_num_neurons($_) } (0 .. $self->num_layers - 1);
}
else {
$self->total_neurons;
}
}
1;
__END__
lib/AI/FANN.pm view on Meta::CPAN
=head1 SYNOPSIS
Train...
use AI::FANN qw(:all);
# create an ANN with 2 inputs, a hidden layer with 3 neurons and an
# output layer with 1 neuron:
my $ann = AI::FANN->new_standard(2, 3, 1);
$ann->hidden_activation_function(FANN_SIGMOID_SYMMETRIC);
$ann->output_activation_function(FANN_SIGMOID_SYMMETRIC);
# create the training data for a XOR operator:
my $xor_train = AI::FANN::TrainData->new( [-1, -1], [-1],
[-1, 1], [1],
[1, -1], [1],
[1, 1], [-1] );
$ann->train_on_data($xor_train, 500000, 1000, 0.001);
$ann->save("xor.ann");
Run...
use AI::FANN;
my $ann = AI::FANN->new_from_file("xor.ann");
for my $a (-1, 1) {
for my $b (-1, 1) {
my $out = $ann->run([$a, $b]);
printf "xor(%f, %f) = %f\n", $a, $b, $out->[0];
}
}
=head1 DESCRIPTION
WARNING: THIS IS A VERY EARLY RELEASE,
MAY CONTAIN CRITICAL BUGS!!!
AI::FANN is a Perl wrapper for the Fast Artificial Neural Network
(FANN) Library available from L<http://fann.sourceforge.net>:
Fast Artificial Neural Network Library is a free open source neural
network library, which implements multilayer artificial neural
networks in C with support for both fully connected and sparsely
connected networks. Cross-platform execution in both fixed and
floating point are supported. It includes a framework for easy
handling of training data sets. It is easy to use, versatile, well
documented, and fast. PHP, C++, .NET, Python, Delphi, Octave, Ruby,
Pure Data and Mathematica bindings are available. A reference manual
accompanies the library with examples and recommendations on how to
use the library. A graphical user interface is also available for
the library.
AI::FANN object oriented interface provides an almost direct map to
the C library API. Some differences have been introduced to make it
more perlish:
lib/AI/FANN.pm view on Meta::CPAN
Prefixes and common parts on the C function names referring to those
structures have been removed. For instance C
C<fann_train_data_shuffle> becomes C<AI::FANN::TrainData::shuffle> that
will be usually called as...
$train_data->shuffle;
=item *
Pairs of C get/set functions are wrapped in Perl with dual accessor
methods named as the attribute (and without any C<set_>/C<get_>
prefix). For instance:
$ann->bit_fail_limit($limit); # sets the bit_fail_limit
$bfl = $ann->bit_fail_limit; # gets the bit_fail_limit
Pairs of get/set functions requiring additional indexing arguments are
also wrapped inside dual accessors:
# sets:
$ann->neuron_activation_function($layer_ix, $neuron_ix, $actfunc);
# gets:
$af = $ann->neuron_activation_function($layer_ix, $neuron_ix);
Important: note that on the Perl version, the optional value argument
is moved to the last position (on the C version of the C<set_> method
it is usually the second argument).
=item *
Some functions have been renamed to make the naming more consistent
and to follow Perl conventions:
C Perl
-----------------------------------------------------------
fann_create_from_file => new_from_file
fann_create_standard => new_standard
fann_get_num_input => num_inputs
fann_get_activation_function => neuron_activation_function
fann_set_activation_function => ^^^
fann_set_activation_function_layer => layer_activation_function
fann_set_activation_function_hidden => hidden_activation_function
fann_set_activation_function_output => output_activation_function
=item *
Boolean methods return true on success and undef on failure.
lib/AI/FANN.pm view on Meta::CPAN
=head1 CONSTANTS
All the constants defined in the C documentation are exported from the module:
# import all...
use AI::FANN ':all';
# or individual constants...
use AI::FANN qw(FANN_TRAIN_INCREMENTAL FANN_GAUSSIAN);
The values returned from this constant subs yield the integer value on
numerical context and the constant name when used as strings.
The constants available are:
# enum fann_train_enum:
FANN_TRAIN_INCREMENTAL
FANN_TRAIN_BATCH
FANN_TRAIN_RPROP
FANN_TRAIN_QUICKPROP
# enum fann_activationfunc_enum:
FANN_LINEAR
FANN_THRESHOLD
FANN_THRESHOLD_SYMMETRIC
FANN_SIGMOID
FANN_SIGMOID_STEPWISE
FANN_SIGMOID_SYMMETRIC
FANN_SIGMOID_SYMMETRIC_STEPWISE
FANN_GAUSSIAN
FANN_GAUSSIAN_SYMMETRIC
FANN_GAUSSIAN_STEPWISE
FANN_ELLIOT
FANN_ELLIOT_SYMMETRIC
FANN_LINEAR_PIECE
FANN_LINEAR_PIECE_SYMMETRIC
FANN_SIN_SYMMETRIC
FANN_COS_SYMMETRIC
FANN_SIN
FANN_COS
# enum fann_errorfunc_enum:
FANN_ERRORFUNC_LINEAR
FANN_ERRORFUNC_TANH
# enum fann_stopfunc_enum:
FANN_STOPFUNC_MSE
FANN_STOPFUNC_BIT
=head1 CLASSES
The classes defined by this package are:
lib/AI/FANN.pm view on Meta::CPAN
C<input> is an array with the input values.
returns an array with the values on the output layer.
$out = $ann->run([1, 0.6]);
print "@$out\n";
=item $ann->randomize_weights($min_weight, $max_weight)
=item $ann->train($input, $desired_output)
AI-Fuzzy
view release on metacpan or search on metacpan
AI::Fuzzy - Perl extension for Fuzzy Logic
=head1 SYNOPSIS
use AI::Fuzzy;
my $f = new AI::Fuzzy::Axis;
my $l = new AI::Fuzzy::Label("toddler", 1, 1.5, 3.5);
$f->addlabel("baby", -1, 1, 2.5);
$f->addlabel($l);
$f->addlabel("little kid", 2, 7, 12);
$f->addlabel("kid", 6, 10, 14);
$f->addlabel("teenager", 12, 16, 20);
$f->addlabel("young adult", 18, 27, 35);
$f->addlabel("adult", 25, 50, 75);
$f->addlabel("senior", 60, 80, 110);
$f->addlabel("relic", 100, 150, 200);
for (my $x = 0; $x<50; $x+=4) {
print "$x years old => " . $f->labelvalue($x) . "\n";
}
$a = new AI::Fuzzy::Set( x1 => .3, x2 => .5, x3 => .8, x4 => 0, x5 => 1);
$b = new AI::Fuzzy::Set( x5 => .3, x6 => .5, x7 => .8, x8 => 0, x9 => 1);
print "a is: " . $a->as_string . "\n";
print "b is: " . $b->as_string . "\n";
print "a is equal to b" if ($a->equal($b));
my $c = $a->complement();
print "complement of a is: " . $c->as_string . "\n";
$c = $a->union($b);
print "a union b is: " . $c->as_string . "\n";
$c = $a->intersection($b);
print "a intersection b is: " . $c->as_string . "\n";
__END__
=head1 DESCRIPTION
=head2 Fuzzy Sets
AI::Fuzzy:Set has these methods:
$fs = B<new> AI::Fuzzy::Set;
# here, "Bob" is unquestionably tall.. the others less so.
$fs_tall_people = B<new> AI::Fuzzy::Set( Lester=>.34, Bob=>1.00, Max=>.86 );
# $x will be .86
$x = B<membership> $fs_tall_people, "Max";
# get list of members, sorted from least membership to greatest:
@shortest_first = B<members> $fs_tall_people;
$fs = B<new> AI::Fuzzy::Set( x1 => .3, x2 => .5, x3 => .8, x4 => 0, x5 => 1);
B<complement>, B<union>, B<intersection>
Thesie are the fuzzy set version of the typical functions.
B<equal>
Returns true if the sets have the same elements and those elements
are all equal.
B<as_string>
Prints the set as tuples:
$b = new AI::Fuzzy::Set( x5 => .3, x6 => .5, x7 => .8, x8 => 0, x9 => 1);
print "b is: " . $b->as_string . "\n";
prints:
b is: x8/0, x5/0.3, x6/0.5, x7/0.8, x9/1
=head2 Fuzzy Labels
A Fuzzy::Label label has four attributes: the text of the label (it
can be any scalar, really), and three numbers: low, mid, high if you
imagine a cartesian plane (remember graph paper in algebra?) of all
possible values, the label applies to a particular range. the graph
might look something like this:
|Y * (mid, 1)
| / \
| / \
| / \
| / \
-|-------*-------------*------- X
(low,0) (high,0)
the Y value is applicability of the label for a given X value
the mid number is the "pure" value. eg, orange is at 0 or 360
degrees on the color wheel. the label applies 100% at the mid
mid number isn't always in the exact center, so the slope
of the two sides may vary...
$fl = new AI::Fuzzy::Label ( "hot", 77, 80, 100 );
$fx = new AI::Fuzzy::Label ( "cold", 0, 10, 200 );
# what I consider hot. :) (in Farenheit, of course!)
if ( $fl->lessthan($fx) ) {
print "the laws of nature have changed\n";
}
# there is a lessthan, greaterthan, lessequal, greaterequal, and between
# that functions as above or using <,>,<=,>=
$a = $fl->applicability($value);
# $a is now the degree to which this label applies to $value
=head2 Fuzzy Axis
A Fuzzy::Axis maintains a hash of labels. Thus you can now look at how
values apply to the full range of labels. The graph of an Axis might
look like this:
|Y * (mid, 1)
| /\/ \ /|
| /- -\ / /\ \ / |
| / \-/ / \ \ / | (some function on some range of x)
| | / \ /\ ---*-|
-|---------*-----------*------- X
(low,0) (high,0)
the Y value is still the applicability of the label for a given X value,
but there are three labels on this Axis. A different X value may
put your value into a new label.
$fl = new AI::Fuzzy::Axis;
$fl->addlabel($label);
# add a label created as in AI::Fuzzy::Label docs
$a = $fl->applicability($label, $value);
# $a is now the degree to which $label applies to $value
$l = $fl->label ("labelname");
# returns the label object named "labelname"
$l = $fl->labelvalue ($value);
# applies a label to $value
@l = $fl->labelvalue($value);
# returns a list of labels and their applicability values
$s = new AI::Fuzzy::Set( $fl->label($value) );
# same thing, but now it's an object
@range = $fl->range();
# returns a list of labels, sorted by their midpoints
# eg: ("cold", "cool", "lukewarm", "warm", "hot")
=head1 AUTHOR
Tom Scanlan <tscanlan@openreach.com>,
current maintainer
AI-FuzzyEngine
view release on metacpan or search on metacpan
lib/AI/FuzzyEngine.pm view on Meta::CPAN
package AI::FuzzyEngine;
use 5.008009;
use version 0.77; our $VERSION = version->declare('v0.2.2');
use strict;
use warnings;
use Carp;
use Scalar::Util;
use List::Util;
use List::MoreUtils;
use AI::FuzzyEngine::Variable;
sub new {
my ($class) = @_;
my $self = bless {}, $class;
$self->{_variables} = [];
return $self;
}
sub variables { @{ shift->{_variables} } };
sub and {
my ($self, @vals) = @_;
# PDL awareness: any element is a piddle?
return List::Util::min(@vals) if _non_is_a_piddle(@vals);
_check_for_PDL();
my $vals = $self->_cat_array_of_piddles(@vals);
return $vals->mv(-1, 0)->minimum;
}
sub or {
my ($self, @vals) = @_;
# PDL awareness: any element is a piddle?
return List::Util::max(@vals) if _non_is_a_piddle(@vals);
_check_for_PDL();
my $vals = $self->_cat_array_of_piddles(@vals);
return $vals->mv(-1, 0)->maximum;
}
sub not {
my ($self, $val) = @_;
return 1-$val;
}
sub true { return 1 }
sub false { return 0 }
sub new_variable {
my ($self, @pars) = @_;
my $variable_class = $self->_class_of_variable();
my $var = $variable_class->new($self, @pars);
push @{$self->{_variables}}, $var;
Scalar::Util::weaken $self->{_variables}->[-1];
return $var;
}
sub reset {
my ($self) = @_;
$_->reset() for $self->variables();
return $self;
}
sub _class_of_variable { 'AI::FuzzyEngine::Variable' }
sub _non_is_a_piddle {
return List::MoreUtils::none {ref $_ eq 'PDL'} @_;
}
my $_PDL_is_imported;
sub _check_for_PDL {
return if $_PDL_is_imported;
die "PDL not loaded" unless $INC{'PDL.pm'};
die "PDL::Core not loaded" unless $INC{'PDL/Core.pm'};
$_PDL_is_imported = 1;
}
sub _cat_array_of_piddles {
my ($class, @vals) = @_;
# TODO: Rapid return if @_ == 1 (isa piddle)
# TODO: join "-", ndims -> Schnellcheck auf gleiche Dim.
# All elements must get piddles
my @pdls = map { PDL::Core::topdl($_) } @vals;
# Get size of wrapping piddle (using a trick)
# applying valid expansion rules for element wise operations
my $zeros = PDL->pdl(0);
# v-- does not work due to threading mechanisms :-((
# $zeros += $_ for @pdls;
# Avoid threading!
for my $p (@pdls) {
croak "Empty piddles are not allowed" if $p->isempty();
eval { $zeros = $zeros + $p->zeros(); 1
} or croak q{Can't expand piddles to same size};
}
# Now, cat 'em by expanding them on the fly
my $vals = PDL::cat( map {$_ + $zeros} @pdls );
return $vals;
};
1;
=pod
=head1 NAME
AI::FuzzyEngine - A Fuzzy Engine, PDL aware
=head1 SYNOPSIS
=head2 Regular Perl - without PDL
use AI::FuzzyEngine;
# Engine (or factory) provides fuzzy logical arithmetic
my $fe = AI::FuzzyEngine->new();
# Disjunction:
my $a = $fe->or ( 0.2, 0.5, 0.8, 0.7 ); # 0.8
# Conjunction:
my $b = $fe->and( 0.2, 0.5, 0.8, 0.7 ); # 0.2
# Negation:
my $c = $fe->not( 0.4 ); # 0.6
# Always true:
my $t = $fe->true(); # 1.0
# Always false:
my $f = $fe->false(); # 0.0
# These functions are constitutive for the operations
# on the fuzzy sets of the fuzzy variables:
# VARIABLES (AI::FuzzyEngine::Variable)
# input variables need definition of membership functions of their sets
my $flow = $fe->new_variable( 0 => 2000,
small => [0, 1, 500, 1, 1000, 0 ],
med => [ 400, 0, 1000, 1, 1500, 0 ],
huge => [ 1000, 0, 1500, 1, 2000, 1],
);
my $cap = $fe->new_variable( 0 => 1800,
avg => [0, 1, 1500, 1, 1700, 0 ],
high => [ 1500, 0, 1700, 1, 1800, 1],
);
# internal variables need sets, but no membership functions
my $saturation = $fe->new_variable( # from => to may be ommitted
low => [],
crit => [],
over => [],
);
# But output variables need membership functions for their sets:
my $green = $fe->new_variable( -5 => 5,
decrease => [-5, 1, -2, 1, 0, 0 ],
ok => [ -2, 0 0, 1, 2, 0 ],
increase => [ 0, 0, 2, 1, 5, 1],
);
# Reset FuzzyEngine (resets all variables)
$fe->reset();
# Reset a fuzzy variable directly
$flow->reset;
# Membership functions can be changed via the set's variable.
# This might be useful during parameter identification algorithms
# Changing a function resets the respective variable.
$flow->change_set( med => [500, 0, 1000, 1, 1500, 0] );
# Fuzzification of input variables
$flow->fuzzify( 600 );
$cap->fuzzify( 1000 );
# Membership degrees of the respective sets are now available:
my $flow_is_small = $flow->small(); # 0.8
my $flow_is_med = $flow->med(); # 0.2
my $flow_is_huge = $flow->huge(); # 0.0
# RULES and their application
# a) If necessary, calculate some internal variables first.
# They will not be defuzzified (in fact, $saturation can't)
# Implicit application of 'and'
# Multiple calls to a membership function
# are similar to 'or' operations:
$saturation->low( $flow->small(), $cap->avg() );
$saturation->low( $flow->small(), $cap->high() );
$saturation->low( $flow->med(), $cap->high() );
# Explicite 'or', 'and' or 'not' possible:
$saturation->crit( $fe->or( $fe->and( $flow->med(), $cap->avg() ),
$fe->and( $flow->huge(), $cap->high() ),
),
);
$saturation->over( $fe->not( $flow->small() ),
$fe->not( $flow->med() ),
$flow->huge(),
$cap->high(),
);
$saturation->over( $flow->huge(), $fe->not( $cap->high() ) );
# b) deduce output variable(s) (here: from internal variable $saturation)
$green->decrease( $saturation->low() );
$green->ok( $saturation->crit() );
$green->increase( $saturation->over() );
# All sets provide their respective membership degrees:
my $saturation_is_over = $saturation->over(); # This is no defuzzification!
my $green_is_ok = $green->ok();
# Defuzzification ( is a matter of the fuzzy variable )
my $delta_green = $green->defuzzify(); # -5 ... 5
=head2 Using PDL and its threading capability
use PDL;
use AI::FuzzyEngine;
# (Probably a stupide example)
my $fe = AI::FuzzyEngine->new();
# Declare variables as usual
my $severity = $fe->new_variable( 0 => 10,
low => [0, 1, 3, 1, 5, 0 ],
high => [ 3, 0, 5, 1, 10, 1],
);
my $threshold = $fe->new_variable( 0 => 1,
low => [0, 1, 0.2, 1, 0.8, 0, ],
high => [ 0.2, 0, 0.8, 1, 1, 1],
);
my $problem = $fe->new_variable( -0.5 => 2,
no => [-0.5, 0, 0, 1, 0.5, 0, 1, 0],
yes => [ 0, 0, 0.5, 1, 1, 1, 1.5, 1, 2, 0],
);
# Input data is a pdl of arbitrary dimension
my $data = pdl( [0, 4, 6, 10] );
$severity->fuzzify( $data );
# Membership degrees are piddles now:
print 'Severity is high: ', $severity->high, "\n";
# [0 0.5 1 1]
# Other variables might be piddles of other dimensions,
# but all variables must be expandible to a common 'wrapping' piddle
# ( in this case a 4x2 matrix with 4 colums and 2 rows)
my $level = pdl( [0.6],
[0.2],
);
$threshold->fuzzify( $level );
print 'Threshold is low: ', $threshold->low(), "\n";
# [
# [0.33333333]
# [ 1]
# ]
# Apply some rules
$problem->yes( $severity->high, $threshold->low );
$problem->no( $fe->not( $problem->yes ) );
# Fuzzy results are represented by the membership degrees of sets
print 'Problem yes: ', $problem->yes, "\n";
# [
# [ 0 0.33333333 0.33333333 0.33333333]
# [ 0 0.5 1 1]
# ]
# Defuzzify the output variables
# Caveat: This includes some non-threadable operations up to now
my $problem_ratings = $problem->defuzzify();
print 'Problems rated: ', $problem_ratings;
# [
# [ 0 0.60952381 0.60952381 0.60952381]
# [ 0 0.75 1 1]
# ]
=head1 EXPORT
Nothing is exported or exportable.
=head1 DESCRIPTION
This module is yet another implementation of a fuzzy inference system.
The aim was to be able to code rules (no string parsing),
but avoid operator overloading,
and make it possible to split calculation into multiple steps.
All intermediate results (memberships of sets of variables)
should be available.
Beginning with v0.2.0 it is PDL aware,
meaning that it can handle piddles (PDL objects)
when running the fuzzy operations.
More information on PDL can be found at L<http://pdl.perl.org/>.
Credits to Ala Qumsieh and his L<AI::FuzzyInference>,
that showed me that fuzzy is no magic.
I learned a lot by analyzing his code,
and he provides good information and links to learn more about Fuzzy Logics.
=head2 Fuzzy stuff
The L<AI::FuzzyEngine> object defines and provides
the elementary operations for fuzzy sets.
All membership degrees of sets are values from 0 to 1.
Up to now there is no choice with regard to how to operate on sets:
=over 2
=item C<< $fe->or( ... ) >> (Disjunction)
is I<Maximum> of membership degrees
=item C<< $fe->and( ... ) >> (Conjunction)
is I<Minimum> of membership degrees
=item C<< $fe->not( $var->$set ) >> (Negation)
is I<1-degree> of membership degree
=item Aggregation of rules (Disjunction)
is I<Maximum>
=item True C<< $fe->true() >> and false C<< $fe->false() >>
are provided for convenience.
=back
Defuzzification is based on
=over 2
=item Implication
I<Clip> membership function of a set according to membership degree,
before the implicated memberships of all sets of a variable are taken for defuzzification:
=item Defuzzification
I<Centroid> of aggregated (and clipped) membership functions
=back
=head2 Public functions
Creation of an C<AI::FuzzyEngine> object by
my $fe = AI::FuzzyEngine->new();
This function has no parameters. It provides the fuzzy methods
C<or>, C<and> and C<not>, as listed above.
If needed, I will introduce alternative fuzzy operations,
they will be configured as arguments to C<new>.
Once built, the engine can create fuzzy variables by C<new_variable>:
my $var = $fe->new_variable( $from => $to,
$name_of_set1 => [$x11, $y11, $x12, $y12, ... ],
$name_of_set2 => [$x21, $y21, $x22, $y22, ... ],
...
);
Result is an L<AI::FuzzyEngine::Variable>.
The name_of_set strings are taken to assign corresponding methods
for the respective fuzzy variables.
They must be valid function identifiers.
Same name_of_set can used for different variables without conflict.
Take care:
There is no check for conflicts with predefined class methods.
Fuzzy variables provide a method to fuzzify input values:
$var->fuzzify( $val );
according to the defined sets and their membership functions.
The memberships of the sets of C<$var> are accessible
by the respective functions:
my $membership_degree = $var->$name_of_set();
Membership degrees can be assigned directly (within rules for example):
$var->$name_of_set( $membership_degree );
If multiple membership_degrees are given, they are "anded":
$var->$name_of_set( $degree1, $degree2, ... ); # "and"
By this, simple rules can be coded directly:
my $var_3->zzz( $var_1->xxx, $var_2->yyy, ... ); # "and"
this implements the fuzzy implication
if $var_1->xxx and $var_2->yyy and ... then $var_3->zzz
The membership degrees of a variable's sets can be reset to undef:
$var->reset(); # resets a variable
$fe->reset(); # resets all variables
The fuzzy engine C<$fe> has all variables registered
that have been created by its C<new_variable> method.
A variable can be defuzzified:
my $out_value = $var->defuzzify();
Membership functions can be replaced via a set's variable:
$var->change_set( $name_of_set => [$x11n, $y11n, $x12n, $y12n, ... ] );
The variable will be reset when replacing a membership function
of any of its sets.
Interdependencies with other variables are not checked
(it might happen that the results of any rules are no longer valid,
so it needs some recalculations).
Sometimes internal variables are used that need neither fuzzification
nor defuzzification.
They can be created by a simplified call to C<new_variable>:
my $var_int = $fe->new_variable( $name_of_set1 => [],
$name_of_set2 => [],
...
);
Hence, they can not use the methods C<fuzzify> or C<defuzzify>.
Fuzzy operations are simple operations on floating values between 0 and 1:
my $conjunction = $fe->and( $var1->xxx, $var2->yyy, ... );
my $disjunction = $fe->or( $var1->xxx, $var2->yyy, ... );
my $negated = $fe->not( $var1->zzz );
There is no magic.
A sequence of rules for the same set can be implemented as follows:
$var_3->zzz( $var_1->xxx, $var_2->yyy, ... );
$var_3->zzz( $var_4->aaa, $var_5->bbb, ... );
The subsequent application of C<< $var_3->zzz(...) >>
corresponds to "or" operations (aggregation of rules).
Only a reset can reset C<$var_3>.
=head2 PDL awareness
Membership degrees of sets might be either scalars or piddles now.
$var_a->memb_fun_a( 5 ); # degree of memb_fun_a is a scalar
$var_a->memb_fun_b( pdl(7, 8) ); # degree of memb_fun_b is a piddle
Empty piddles are not allowed, behaviour with bad values is not tested.
Fuzzification (hence calculating degrees) accepts piddles:
$var_b->fuzzify( pdl([1, 2], [3, 4]) );
Defuzzification returns a piddle if any of the membership
degrees of the function's sets is a piddle:
my $val = $var_a->defuzzify(); # $var_a returns a 1dim piddle with two elements
So do the fuzzy operations as provided by the fuzzy engine C<$fe> itself.
Any operation on more then one piddle expands those to common
dimensions, if possible, or throws a PDL error otherwise.
The way expansion is done is best explained by code
(see C<< AI::FuzzyEngine->_cat_array_of_piddles(@pdls) >>).
Assuming all piddles are in C<@pdls>,
calculation goes as follows:
# Get the common dimensions
my $zeros = PDL->pdl(0);
# Note: $zeros += $_->zeros() for @pdls does not work here
$zeros = $zeros + $_->zeros() for @pdls;
# Expand all piddles
@pdls = map {$_ + $zeros} @pdls;
Defuzzification uses some heavy non-threading code,
so there might be a performance penalty for big piddles.
=head2 Todos
=over 2
=item Add optional alternative implementations of fuzzy operations
=item More checks on input arguments and allowed method calls
=item PDL awareness: Use threading in C<< $variable->defuzzify >>
=item Divide tests into API tests and test of internal functions
=back
=head1 CAVEATS / BUGS
This is my first module.
I'm happy about feedback that helps me to learn
and improve my contributions to the Perl ecosystem.
Please report any bugs or feature requests to
C<bug-ai-fuzzyengine at rt.cpan.org>, or through
the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=AI-FuzzyEngine>.
I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc AI::FuzzyEngine
=head1 AUTHOR
Juergen Mueck, jmueck@cpan.org
=head1 COPYRIGHT
Copyright (c) Juergen Mueck 2013. All rights reserved.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
( run in 0.645 second using v1.01-cache-2.11-cpan-a5abf4f5562 )