Result:
found more than 317 distributions - search limited to the first 2001 files matching your query
( run in 1.832 )
ACME-THEDANIEL-Utils
view release on metacpan or search on metacpan
t/00-load.t view on Meta::CPAN
use Test::More;
plan tests => 1;
BEGIN {
use_ok( 'ACME::THEDANIEL::Utils' ) || print "Bail out!\n";
}
diag( "Testing ACME::THEDANIEL::Utils $ACME::THEDANIEL::Utils::VERSION, Perl $], $^X" );
ACME-YAPC-NA-2012
view release on metacpan or search on metacpan
t/00-load.t view on Meta::CPAN
#!perl -T
use Test::More tests => 1;
BEGIN {
use_ok( 'ACME::YAPC::NA::2012' ) || print "Bail out!\n";
}
diag( "Testing ACME::YAPC::NA::2012 $ACME::YAPC::NA::2012::VERSION, Perl $], $^X" );
ACME-ltharris
view release on metacpan or search on metacpan
t/00-load.t view on Meta::CPAN
#!perl -T
use Test::More tests => 1;
BEGIN {
use_ok( 'ACME::ltharris' ) || print "Bail out!\n";
}
diag( "Testing ACME::ltharris $ACME::ltharris::VERSION, Perl $], $^X" );
ADAMK-Release
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
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
inc/Module/Install.pm view on Meta::CPAN
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 $_)
AE-AdHoc
view release on metacpan or search on metacpan
examples/port-probe-multi.pl view on Meta::CPAN
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
AES128
view release on metacpan or search on metacpan
automagically add a dot between the original filename and the
suffix. If you want the dot, you have to include it in the option
argument.
If neither C<--patch> or C<--copy> are given, the default is to
simply print the diffs for each file. This requires either
C<Text::Diff> or a C<diff> program to be installed.
=head2 --diff=I<program>
Manually set the diff program and options to use. The default
Using this option instructs F<ppport.h> to leave C++
comments untouched.
=head2 --quiet
Be quiet. Don't print anything except fatal errors.
=head2 --nodiag
Don't output any diagnostic messages. Only portability
alerts will be printed.
=head2 --nohints
Don't output any hints. Hints often contain useful portability
notes. Warnings will still be displayed.
grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL
grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL
gv_fetchpvn_flags() NEED_gv_fetchpvn_flags NEED_gv_fetchpvn_flags_GLOBAL
load_module() NEED_load_module NEED_load_module_GLOBAL
mg_findext() NEED_mg_findext NEED_mg_findext_GLOBAL
my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL
my_sprintf() NEED_my_sprintf NEED_my_sprintf_GLOBAL
my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL
my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL
newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL
newSV_type() NEED_newSV_type NEED_newSV_type_GLOBAL
usage() if "@ARGV" =~ /^--?h(?:elp)?$/;
die "Getopt::Long not found. Please don't use any options.\n";
}
if ($opt{version}) {
print "This is $0 $VERSION.\n";
exit 0;
}
usage() if $opt{help};
strip() if $opt{strip};
if ($@) {
die "Invalid version number format: '$opt{'compat-version'}'\n";
}
die "Only Perl 5 is supported\n" if $r != 5;
die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000;
$opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s;
}
else {
$opt{'compat-version'} = 5;
}
cast_ulong||5.006000|n
cast_uv||5.006000|n
check_locale_boundary_crossing|||
check_type_and_open|||
check_uni|||
check_utf8_print|||
checkcomma|||
ckWARN|5.006000||p
ck_entersub_args_core|||
ck_entersub_args_list||5.013006|
ck_entersub_args_proto_or_list||5.013006|
do_open9||5.006000|
do_open_raw|||
do_openn||5.007001|
do_open||5.003070|
do_pmop_dump||5.006000|
do_print|||
do_readline|||
do_seek|||
do_semop|||
do_shmio|||
do_smartmatch|||
do_spawn_nowait|||
do_spawn|||
do_sprintf|||
do_sv_dump||5.006000|
do_sysseek|||
do_tell|||
do_trans_complex_utf8|||
do_trans_complex|||
forget_pmop|||
form_nocontext|||vn
form_short_octal_warning|||
form||5.004000|v
fp_dup|||
fprintf_nocontext|||vn
free_c_backtrace|||
free_global_struct|||
free_tied_hv_pool|||
free_tmps|||
gen_constant_list|||
is_uni_graph||5.006000|
is_uni_idfirst_lc||5.006000|
is_uni_idfirst||5.006000|
is_uni_lower_lc||5.006000|
is_uni_lower||5.006000|
is_uni_print_lc||5.006000|
is_uni_print||5.006000|
is_uni_punct_lc||5.006000|
is_uni_punct||5.006000|
is_uni_space_lc||5.006000|
is_uni_space||5.006000|
is_uni_upper_lc||5.006000|
is_utf8_lower||5.006000|
is_utf8_mark||5.006000|
is_utf8_perl_space||5.011001|
is_utf8_perl_word||5.011001|
is_utf8_posix_digit||5.011001|
is_utf8_print||5.006000|
is_utf8_punct||5.006000|
is_utf8_space||5.006000|
is_utf8_string_loclen||5.009003|n
is_utf8_string_loc||5.008001|n
is_utf8_string||5.006001|n
my_pclose||5.003070|
my_popen_list||5.007001|
my_popen||5.003070|
my_setenv|||
my_setlocale|||
my_snprintf|5.009004||pvn
my_socketpair||5.007003|n
my_sprintf|5.009003||pvn
my_stat_flags|||
my_stat||5.024000|
my_strerror||5.021001|
my_strftime||5.007002|
my_strlcat|5.009004||pn
my_strlcpy|5.009004||pn
my_unexec|||
my_vsnprintf||5.009004|n
need_utf8|||n
newANONATTRSUB||5.006000|
newANONHASH|||
newANONLIST|||
newANONSUB|||
pregcomp||5.009005|
pregexec|||
pregfree2||5.011000|
pregfree|||
prescan_version||5.011004|
printbuf|||
printf_nocontext|||vn
process_special_blocks|||
ptr_hash|||n
ptr_table_clear||5.009005|
ptr_table_fetch||5.009005|
ptr_table_find|||n
re_exec_indentf|||v
re_indentf|||v
re_intuit_start||5.019001|
re_intuit_string||5.006000|
re_op_compile|||
re_printf|||v
realloc||5.007002|n
reentrant_free||5.024000|
reentrant_init||5.024000|
reentrant_retry||5.024000|vn
reentrant_size||5.024000|
if (exists $opt{'list-unsupported'}) {
my $f;
for $f (sort { lc $a cmp lc $b } keys %API) {
next unless $API{$f}{todo};
print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n";
}
exit 0;
}
# Scan for possible replacement candidates
my $f;
my $count = 0;
my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$";
for $f (sort { lc $a cmp lc $b } keys %API) {
next unless $f =~ /$match/;
print "\n=== $f ===\n\n";
my $info = 0;
if ($API{$f}{base} || $API{$f}{todo}) {
my $base = format_version($API{$f}{base} || $API{$f}{todo});
print "Supported at least starting from perl-$base.\n";
$info++;
}
if ($API{$f}{provided}) {
my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003";
print "Support by $ppport provided back to perl-$todo.\n";
print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f};
print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f};
print "\n$hints{$f}" if exists $hints{$f};
print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f};
$info++;
}
print "No portability information available.\n" unless $info;
$count++;
}
$count or print "Found no API matching '$opt{'api-info'}'.";
print "\n";
exit 0;
}
if (exists $opt{'list-provided'}) {
my $f;
push @flags, 'explicit' if exists $need{$f};
push @flags, 'depend' if exists $depends{$f};
push @flags, 'hint' if exists $hints{$f};
push @flags, 'warning' if exists $warnings{$f};
my $flags = @flags ? ' ['.join(', ', @flags).']' : '';
print "$f$flags\n";
}
exit 0;
}
my @files;
$warnings += hint($func);
}
unless ($opt{quiet}) {
for $func (sort keys %{$file{uses_todo}}) {
print "*** WARNING: Uses $func, which may not be portable below perl ",
format_version($API{$func}{todo}), ", even with '$ppport'\n";
$warnings++;
}
}
}
else {
local *F;
if (open F, ">$newfile") {
info("Writing copy of '$filename' with changes to '$newfile'");
print F $c;
close F;
}
else {
error("Cannot open '$newfile' for writing: $!");
}
if (!defined $diff) {
error("Cannot generate a diff. Please install Text::Diff or use --copy.");
return;
}
print F $diff;
}
sub run_diff
{
my($prog, $file, $str) = @_;
while (-e "$tmp.$suf") { $suf++ }
$tmp = "$tmp.$suf";
if (open F, ">$tmp") {
print F $str;
close F;
if (open F, "$prog $file $tmp |") {
while (<F>) {
s/\Q$tmp\E/$file.patched/;
if ($s % 10) {
die "invalid version '$ver'\n";
}
$s /= 10;
$ver = sprintf "%d.%03d", $r, $v;
$s > 0 and $ver .= sprintf "_%02d", $s;
return $ver;
}
return sprintf "%d.%d.%d", $r, $v, $s;
}
sub info
{
$opt{quiet} and return;
print @_, "\n";
}
sub diag
{
$opt{quiet} and return;
$opt{diag} and print @_, "\n";
}
sub warning
{
$opt{quiet} and return;
print "*** ", @_, "\n";
}
sub error
{
print "*** ERROR: ", @_, "\n";
}
my %given_hints;
my %given_warnings;
sub hint
my $func = shift;
my $rv = 0;
if (exists $warnings{$func} && !$given_warnings{$func}++) {
my $warn = $warnings{$func};
$warn =~ s!^!*** !mg;
print "*** WARNING: $func\n", $warn;
$rv++;
}
if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) {
my $hint = $hints{$func};
$hint =~ s/^/ /mg;
print " --- hint for $func ---\n", $hint;
}
$rv;
}
sub usage
my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms;
my %M = ( 'I' => '*' );
$usage =~ s/^\s*perl\s+\S+/$^X $0/;
$usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g;
print <<ENDUSAGE;
Usage: $usage
See perldoc $0 for details.
. "Please install a newer version, or --unstrip will not work.\\n";
}
Devel::PPPort::WriteFile(\$0);
exit 0;
}
print <<END;
Sorry, but this is a stripped version of \$0.
To be able to use its original script and doc functionality,
please try to regenerate this file using:
$c =~ s!^$LF!!mg;
$c =~ s!^\s*#\s*!#!mg;
$c =~ s!^\s+!!mg;
open OUT, ">$0" or die "cannot strip $0: $!\n";
print OUT "$pl$c\n";
exit 0;
}
__DATA__
#ifndef isGRAPH
# define isGRAPH(c) isgraph(c)
#endif
#ifndef isPRINT
# define isPRINT(c) isprint(c)
#endif
#ifndef isPUNCT
# define isPUNCT(c) ispunct(c)
#endif
return UV_MAX;
}
#endif
#endif
#if !defined(my_snprintf)
#if defined(NEED_my_snprintf)
static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...);
static
#else
extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...);
#endif
#define my_snprintf DPPP_(my_my_snprintf)
#define Perl_my_snprintf DPPP_(my_my_snprintf)
#if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL)
int
DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...)
{
dTHX;
int retval;
va_list ap;
va_start(ap, format);
#ifdef HAS_VSNPRINTF
retval = vsnprintf(buffer, len, format, ap);
#else
retval = vsprintf(buffer, format, ap);
#endif
va_end(ap);
if (retval < 0 || (len > 0 && (Size_t)retval >= len))
Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
return retval;
}
#endif
#endif
#if !defined(my_sprintf)
#if defined(NEED_my_sprintf)
static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...);
static
#else
extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...);
#endif
#define my_sprintf DPPP_(my_my_sprintf)
#define Perl_my_sprintf DPPP_(my_my_sprintf)
#if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL)
int
DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...)
{
va_list args;
va_start(args, pat);
vsprintf(buffer, pat, args);
va_end(args);
return strlen(buffer);
}
#endif
(U8)*pv;
const U8 c = (U8)u & 0xFF;
if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) {
if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
chsize = my_snprintf(octbuf, sizeof octbuf,
"%" UVxf, u);
else
chsize = my_snprintf(octbuf, sizeof octbuf,
"%cx{%" UVxf "}", esc, u);
} else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
chsize = 1;
} else {
if (c == dq || c == esc || !isPRINT(c)) {
case '"' : if (dq == '"')
octbuf[1] = '"';
else
chsize = 1;
break;
default: chsize = my_snprintf(octbuf, sizeof octbuf,
pv < end && isDIGIT((U8)*(pv+readsize))
? "%c%03o" : "%c%o", esc, c);
}
} else {
chsize = 1;
} else if (chsize > 1) {
sv_catpvn(dsv, octbuf, chsize);
wrote += chsize;
} else {
char tmp[2];
my_snprintf(tmp, sizeof tmp, "%c", c);
sv_catpvn(dsv, tmp, 1);
wrote++;
}
if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
break;
AFS-Command
view release on metacpan or search on metacpan
lib/AFS/Command/BOS.pm view on Meta::CPAN
my $log = "";
while ( defined($_ = $self->{handle}->getline()) ) {
next if /^Fetching log file/;
if ( $redirect ) {
$redirect->print($_);
} else {
$log .= $_;
}
}
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 {
#
examples/Meltdown.pl view on Meta::CPAN
(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
#
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
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
#
AFS-PAG
view release on metacpan or search on metacpan
t/lib/Test/RRA/Config.pm view on Meta::CPAN
Test::RRA::Config - Perl test configuration
=head1 SYNOPSIS
use Test::RRA::Config qw($MINIMUM_VERSION);
print "Required Perl version is $MINIMUM_VERSION\n";
=head1 DESCRIPTION
Test::RRA::Config encapsulates per-package configuration for generic Perl
test programs that are shared between multiple packages using the
AFS
view release on metacpan or search on metacpan
src/inc/Test/Builder.pm view on Meta::CPAN
my($self, $cmd, $arg) = @_;
return unless $cmd;
if( $Have_Plan ) {
die sprintf "You tried to plan twice! Second plan at %s line %d\n",
($self->caller)[1,2];
}
if( $cmd eq 'no_plan' ) {
$self->no_plan;
src/inc/Test/Builder.pm view on Meta::CPAN
if( defined $max ) {
$Expected_Tests = $max;
$Have_Plan = 1;
$self->_print("1..$max\n") unless $self->no_header;
}
return $Expected_Tests;
}
src/inc/Test/Builder.pm view on Meta::CPAN
$out .= " # Skip $reason" if $reason;
$out .= "\n";
$Skip_All = 1;
$self->_print($out) unless $self->no_header;
exit(0);
}
sub ok {
src/inc/Test/Builder.pm view on Meta::CPAN
}
$Test_Results[$Curr_Test-1] = $result;
$out .= "\n";
$self->_print($out);
unless( $test ) {
my $msg = $todo ? "Failed (TODO)" : "Failed";
$self->diag(" $msg test ($file at line $line)\n");
}
src/inc/Test/Builder.pm view on Meta::CPAN
else {
$$val = 'undef';
}
}
return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
got: %s
expected: %s
DIAGNOSTIC
}
src/inc/Test/Builder.pm view on Meta::CPAN
}
unless( $ok ) {
$this = defined $this ? "'$this'" : 'undef';
my $match = $cmp eq '=~' ? "doesn't match" : "matches";
$self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
%s
%13s '%s'
DIAGNOSTIC
}
src/inc/Test/Builder.pm view on Meta::CPAN
sub _cmp_diag {
my($self, $got, $type, $expect) = @_;
$got = defined $got ? "'$got'" : 'undef';
$expect = defined $expect ? "'$expect'" : 'undef';
return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
%s
%s
%s
DIAGNOSTIC
}
sub BAILOUT {
my($self, $reason) = @_;
$self->_print("Bail out! $reason");
exit 255;
}
sub skip {
src/inc/Test/Builder.pm view on Meta::CPAN
my $out = "ok";
$out .= " $Curr_Test" if $self->use_numbers;
$out .= " # skip $why\n";
$Test->_print($out);
return 1;
}
src/inc/Test/Builder.pm view on Meta::CPAN
my $out = "not ok";
$out .= " $Curr_Test" if $self->use_numbers;
$out .= " # TODO & SKIP $why\n";
$Test->_print($out);
return 1;
}
src/inc/Test/Builder.pm view on Meta::CPAN
sub diag {
my($self, @msgs) = @_;
return unless @msgs;
# Prevent printing headers when compiling (i.e. -c)
return if $^C;
# Escape each line with a #.
foreach (@msgs) {
$_ = 'undef' unless defined;
src/inc/Test/Builder.pm view on Meta::CPAN
push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;
local $Level = $Level + 1;
my $fh = $self->todo ? $self->todo_output : $self->failure_output;
local($\, $", $,) = (undef, ' ', '');
print $fh @msgs;
return 0;
}
sub _print {
my($self, @msgs) = @_;
# Prevent printing headers when only compiling. Mostly for when
# tests are deparsed with B::Deparse
return if $^C;
local($\, $", $,) = (undef, ' ', '');
my $fh = $self->output;
src/inc/Test/Builder.pm view on Meta::CPAN
s/\n(.)/\n# $1/sg;
}
push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;
print $fh @msgs;
}
my($Out_FH, $Fail_FH, $Todo_FH);
src/inc/Test/Builder.pm view on Meta::CPAN
# We dup STDOUT and STDERR so people can change them in their
# test suites while still getting normal test output.
open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";
open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!";
# Set everything to unbuffered else plain prints to STDOUT will
# come out in the wrong order from our own prints.
_autoflush(\*TESTOUT);
_autoflush(\*STDOUT);
_autoflush(\*TESTERR);
_autoflush(\*STDERR);
src/inc/Test/Builder.pm view on Meta::CPAN
# Bailout if plan() was never called. This is so
# "require Test::Simple" doesn't puke.
do{ _my_exit(0) && return } if !$Have_Plan && !$Test_Died;
# Figure out if we passed or failed and print helpful messages.
if( @Test_Results ) {
# The plan? We have no plan.
if( $No_Plan ) {
$self->_print("1..$Curr_Test\n") unless $self->no_header;
$Expected_Tests = $Curr_Test;
}
# 5.8.0 threads bug. Shared arrays will not be auto-extended
# by a slice. Worse, we have to fill in every entry else
AHA
view release on metacpan or search on metacpan
example/lava_lamp.pl view on Meta::CPAN
# ================================================================================================
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 {
AI-ANN
view release on metacpan or search on metacpan
lib/AI/ANN/Neuron.pm view on Meta::CPAN
# if ($#neurons < $#neuronweights) {
# foreach my $i ($#neurons+1..$#neuronweights) {
# $neurons[$i]=0;
# }
# }
#print STDERR $self->{'id'}."\n";
#print STDERR join(',', @inputs)."\n";
#print STDERR join(',', @neurons)."\n";
#print STDERR join(',', @inputweights)."\n";
#print STDERR join(',', @neuronweights)."\n";
my $output = 0;
if ($self->{'inline_c'}) {
$output = _execute_internals( \@inputs, \@neurons, \@inputweights, \@neuronweights );
} else {
foreach my $id (0..$#inputweights) {
AI-CRM114
view release on metacpan or search on metacpan
t/00basic.t view on Meta::CPAN
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl HTML-Encoding.t'
#########################
# change 'tests => 1' to 'tests => last_test_to_print';
use Test::More tests => 1;
BEGIN { use_ok('AI::CRM114') };
#########################
AI-Calibrate
view release on metacpan or search on metacpan
lib/AI/Calibrate.pm view on Meta::CPAN
our %EXPORT_TAGS = (
'all' => [
qw(
calibrate
score_prob
print_mapping
)
]
);
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
lib/AI/Calibrate.pm view on Meta::CPAN
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) ];
lib/AI/Calibrate.pm view on Meta::CPAN
}
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;
}
lib/AI/Calibrate.pm view on Meta::CPAN
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 );
lib/AI/Calibrate.pm view on Meta::CPAN
}
}
}
}
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>
lib/AI/Calibrate.pm view on Meta::CPAN
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 {
lib/AI/Calibrate.pm view on Meta::CPAN
# If we drop off the end, probability estimate is zero
return 0;
}
=item B<print_mapping>
This is a simple utility function that takes the structure returned by
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
lib/AI/Calibrate.pm view on Meta::CPAN
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
lib/AI/Calibrate.pm view on Meta::CPAN
For further information on the PAV algorithm, you can read the section in my
paper referenced below.
=head1 EXPORT
This module exports three functions: calibrate, score_prob and print_mapping.
=head1 BUGS
None known. This implementation is straightforward but inefficient (its time
is O(n^2) in the length of the data series). A linear time algorithm is
AI-Categorizer
view release on metacpan or search on metacpan
$test = AI::Categorizer::Collection::Files->new( path => $test, %params );
# We turn on verbose mode so you can watch the progress of loading &
# training. This looks nicer if you have Time::Progress installed!
print "Loading training set\n";
my $k = AI::Categorizer::KnowledgeSet->new( verbose => 1 );
$k->load( collection => $training );
print "Training categorizer\n";
my $l = AI::Categorizer::Learner::NaiveBayes->new( verbose => 1 );
$l->train( knowledge_set => $k );
print "Categorizing test set\n";
my $experiment = $l->categorize_collection( collection => $test );
print $experiment->stats_table;
# 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
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.
AI-Classifier-Japanese
view release on metacpan or search on metacpan
lib/AI/Classifier/Japanese.pm view on Meta::CPAN
# 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
that you may choose to grant warranty protection to some or all
third parties, at your option).
c) If the modified program normally reads commands interactively when
run, you must cause it, when started running for such interactive use
in the simplest and most usual way, to print or display an
announcement including an appropriate copyright notice and a notice
that there is no warranty (or else, saying that you provide a
warranty) and that users may redistribute the program under these
conditions, and telling the user how to view a copy of this General
Public License.
AI-ConfusionMatrix
view release on metacpan or search on metacpan
lib/AI/ConfusionMatrix.pm view on Meta::CPAN
$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;
lib/AI/ConfusionMatrix.pm view on Meta::CPAN
$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;
}
lib/AI/ConfusionMatrix.pm view on Meta::CPAN
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.
=head3 Functions:
=head4 C<makeConfusionMatrix($hash_ref, $file [, $delimiter ])>
AI-DecisionTree
view release on metacpan or search on metacpan
eg/example.pl view on Meta::CPAN
outlook => 'rain',
temperature => 'mild',
humidity => 'high',
wind => 'strong',
} );
print "Result 1: $result\n"; # no
# Try a new unseen example
$result = $dtree->get_result( attributes => {
outlook => 'sunny',
temperature => 'hot',
humidity => 'normal',
wind => 'strong',
} );
print "Result 2: $result\n"; # yes
# Show the created tree structure as rules
print map "$_\n", $dtree->rule_statements;
# Will barf on inconsistent data
my $t2 = new AI::DecisionTree;
$t2->add_instance( attributes => { foo => 'bar' },
result => 1 );
$t2->add_instance( attributes => { foo => 'bar' },
result => 0 );
eval {$t2->train};
print "$@\n";
AI-Embedding
view release on metacpan or search on metacpan
t/00-load.t view on Meta::CPAN
use Test::More tests => 1;
#plan tests => 2;
BEGIN {
use_ok( 'AI::Embedding' ) || print "Bail out!\n";
}
diag( "Testing AI::Embedding $AI::Embedding::VERSION, Perl $], $^X" );
AI-Evolve-Befunge
view release on metacpan or search on metacpan
lib/AI/Evolve/Befunge/Blueprint.pm view on Meta::CPAN
package AI::Evolve::Befunge::Blueprint;
use strict;
use warnings;
use Carp;
use Language::Befunge::Vector;
use Perl6::Export::Attrs;
lib/AI/Evolve/Befunge/Blueprint.pm view on Meta::CPAN
# FIXME: consolidate "host" and "id" into a single string
=head1 NAME
AI::Evolve::Befunge::Blueprint - code storage object
=head1 SYNOPSIS
my $blueprint = Blueprint->new(code => $codestring, dimensions => 4);
my $name = $blueprint->name;
my $string = $blueprint->as_string;
=head1 DESCRIPTION
Blueprint is a container object for a befunge creature's code. It gives
new blueprints a unique name, so that we can keep track of them and
tell critters apart. One or more Critter objects may be created from
the Befunge source code contained within this object, so that it may
compete with other critters. As the critter(s) compete, the fitness
score of this object is modified, for use as sort criteria later on.
=head1 METHODS
=head2 new
my $blueprint = Blueprint->new(code => $codestring, dimensions => 4);
Create a new Blueprint object. Two attributes are mandatory:
code - a Befunge code string. This must be exactly the right
length to fill a hypercube of the given dimensions.
dimensions - The number of dimensions we will operate in.
lib/AI/Evolve/Befunge/Blueprint.pm view on Meta::CPAN
=cut
sub new {
my $self = bless({}, shift);
my %args = @_;
my $usage = 'Usage: AI::Evolve::Befunge::Blueprint->new(code => "whatever", dimensions => 4, [, id => 2, host => "localhost", fitness => 5]);\n';
croak $usage unless exists $args{code};
croak $usage unless exists $args{dimensions};
$$self{code} = $args{code};
$$self{dims} = $args{dimensions};
if($$self{dims} > 1) {
lib/AI/Evolve/Befunge/Blueprint.pm view on Meta::CPAN
}
=head2 new_from_string
my $blueprint = Blueprint->new_from_string($string);
Parses a text representation of a blueprint, returns a Blueprint
object. The text representation was likely created by L</as_string>,
below.
=cut
lib/AI/Evolve/Befunge/Blueprint.pm view on Meta::CPAN
my ($package, $line) = @_;
return undef unless defined $line;
chomp $line;
if($line =~ /^\[I(-?\d+) D(\d+) F(\d+) H([^\]]+)\](.+)/) {
my ($id, $dimensions, $fitness, $host, $code) = ($1, $2, $3, $4, $5);
return AI::Evolve::Befunge::Blueprint->new(
id => $id,
dimensions => $dimensions,
fitness => $fitness,
host => $host,
code => $code,
lib/AI/Evolve/Befunge/Blueprint.pm view on Meta::CPAN
}
=head2 new_from_file
my $blueprint = Blueprint->new_from_file($file);
Reads a text representation (single line of text) of a blueprint from
a results file (or a migration file), returns a Blueprint object.
Calls L</new_from_string> to do the dirty work.
=cut
sub new_from_file {
lib/AI/Evolve/Befunge/Blueprint.pm view on Meta::CPAN
}
=head2 as_string
print $blueprint->as_string();
Return a text representation of this blueprint. This is suitable for
sticking into a results file, or migrating to another node. See
L</new_from_string> above.
=cut
AI-ExpertSystem-Advanced
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
open( FH, '>', $_[0] ) or die "open($_[0]): $!";
} else {
open( FH, "> $_[0]" ) or die "open($_[0]): $!";
}
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
close FH or die "close($_[0]): $!";
}
# _version is for processing module versions (eg, 1.03_05) not
inc/Module/Install.pm view on Meta::CPAN
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 $_)
AI-ExpertSystem-Simple
view release on metacpan or search on metacpan
bin/simpleshell view on Meta::CPAN
}
if($tkinterface) {
say_something('response', '', '*');
} else {
print '** ';
}
$x = <STDIN>;
$x = 0 if $x !~ m#^[0-9]+$#;
}
return $responses[ $x - 1 ];
}
######################################################################
# The various ways of printing out a message
######################################################################
sub say_status { say_something('status', '>> ', shift) }
sub say_question { say_something('question', '', shift) }
sub say_something {
my ($tag1, $tag2, $text) = @_;
if($tkinterface) {
print "$tag1:$text\n";
} else {
print "$tag2$text\n";
}
}
######################################################################
# The various ways of printing out a message
######################################################################
sub process_log {
my ($prefix, $override) = @_;
AI-FANN-Evolving
view release on metacpan or search on metacpan
lib/AI/FANN/Evolving.pm view on Meta::CPAN
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
lib/AI/FANN/Evolving.pm view on Meta::CPAN
}
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;
}
lib/AI/FANN/Evolving.pm view on Meta::CPAN
# train
$self->{'ann'}->cascadetrain_on_data(
$data,
$self->neurons,
$self->neuron_printfreq,
$self->error,
);
}
else {
$log->debug("normal training");
lib/AI/FANN/Evolving.pm view on Meta::CPAN
# train
$self->{'ann'}->train_on_data(
$data,
$self->epochs,
$self->epoch_printfreq,
$self->error,
);
}
}
lib/AI/FANN/Evolving.pm view on Meta::CPAN
$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
lib/AI/FANN/Evolving.pm view on Meta::CPAN
$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
AI-FANN
view release on metacpan or search on metacpan
lib/AI/FANN.pm view on Meta::CPAN
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
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)
lib/AI/FANN.pm view on Meta::CPAN
=item $ann->train_epoch($train_data)
C<$train_data> is a AI::FANN::TrainData object.
=item $ann->print_connections
-
=item $ann->print_parameters
-
=item $ann->cascade_activation_functions()
AI-Fuzzy
view release on metacpan or search on metacpan
$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
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
$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 <,>,<=,>=
AI-FuzzyEngine
view release on metacpan or search on metacpan
lib/AI/FuzzyEngine.pm view on Meta::CPAN
# 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]
# ]
AI-FuzzyInference
view release on metacpan or search on metacpan
FuzzyInference.pm view on Meta::CPAN
sub show {
my $self = shift;
for my $var (keys %{$self->{RESULTS}}) {
print "Var $var = $self->{RESULTS}{$var}.\n";
}
}
# sub value() - public method.
#
AI-Gene-Sequence
view release on metacpan or search on metacpan
AI/Gene/Sequence.pm view on Meta::CPAN
# elsewhere
package main;
my $gene = Somegene->new;
$gene->seed;
print $gene->render, "\n";
$gene->mutate(5);
print $gene->render, "\n";
$gene->mutate(5);
print $gene->render, "\n";
=head1 DESCRIPTION
This is a class which provides generic methods for the
creation and mutation of genetic sequences. Various mutations
( run in 1.832 second using v1.01-cache-2.11-cpan-de7293f3b23 )