Result:
found more than 680 distributions - search limited to the first 2001 files matching your query
( run in 1.342 )
AAAA-Crypt-DH
view release on metacpan or search on metacpan
inc/Devel/CheckLib.pm view on Meta::CPAN
@incpaths = (ref($args{incpath}) ? @{$args{incpath}} : $args{incpath})
if $args{incpath};
my $analyze_binary = $args{analyze_binary};
my @argv = @ARGV;
push @argv, _parse_line('\s+', 0, $ENV{PERL_MM_OPT}||'');
# work-a-like for Makefile.PL's LIBS and INC arguments
# if given as command-line argument, append to %args
for my $arg (@argv) {
for my $mm_attr_key (qw(LIBS INC)) {
if (my ($mm_attr_value) = $arg =~ /\A $mm_attr_key = (.*)/x) {
# it is tempting to put some \s* into the expression, but the
# MM command-line parser only accepts LIBS etc. followed by =,
# so we should not be any more lenient with whitespace than that
$args{$mm_attr_key} .= " $mm_attr_value";
}
}
}
# using special form of split to trim whitespace
if(defined($args{LIBS})) {
foreach my $arg (split(' ', $args{LIBS})) {
die("LIBS argument badly-formed: $arg\n") unless($arg =~ /^-[lLR]/);
push @{$arg =~ /^-l/ ? \@libs : \@libpaths}, substr($arg, 2);
}
}
if(defined($args{INC})) {
foreach my $arg (split(' ', $args{INC})) {
die("INC argument badly-formed: $arg\n") unless($arg =~ /^-I/);
push @incpaths, substr($arg, 2);
}
}
my ($cc, $ld) = _findcc($args{debug}, $args{ccflags}, $args{ldflags});
my @missing;
my @wrongresult;
my @wronganalysis;
my @use_headers;
# first figure out which headers we can't find ...
for my $header (@headers) {
push @use_headers, $header;
my($ch, $cfile) = File::Temp::tempfile(
'assertlibXXXXXXXX', SUFFIX => '.c'
);
my $ofile = $cfile;
$ofile =~ s/\.c$/$Config{_o}/;
print $ch qq{#include <$_>\n} for @use_headers;
print $ch qq{int main(void) { return 0; }\n};
close($ch);
my $exefile = File::Temp::mktemp( 'assertlibXXXXXXXX' ) . $Config{_exe};
my @sys_cmd;
# FIXME: re-factor - almost identical code later when linking
if ( $Config{cc} eq 'cl' ) { # Microsoft compiler
require Win32;
@sys_cmd = (
@$cc,
$cfile,
"/Fe$exefile",
(map { '/I'.Win32::GetShortPathName($_) } @incpaths),
"/link",
@$ld,
split(' ', $Config{libs}),
);
} elsif($Config{cc} =~ /bcc32(\.exe)?/) { # Borland
@sys_cmd = (
@$cc,
@$ld,
(map { "-I$_" } @incpaths),
"-o$exefile",
$cfile
);
} else { # Unix-ish: gcc, Sun, AIX (gcc, cc), ...
@sys_cmd = (
@$cc,
@$ld,
$cfile,
(map { "-I$_" } @incpaths),
"-o", "$exefile"
);
}
warn "# @sys_cmd\n" if $args{debug};
my $rv = $args{debug} ? system(@sys_cmd) : _quiet_system(@sys_cmd);
push @missing, $header if $rv != 0 || ! -x $exefile;
_cleanup_exe($exefile);
unlink $cfile;
}
# now do each library in turn with headers
my($ch, $cfile) = File::Temp::tempfile(
'assertlibXXXXXXXX', SUFFIX => '.c'
);
my $ofile = $cfile;
$ofile =~ s/\.c$/$Config{_o}/;
print $ch qq{#include <$_>\n} foreach (@headers);
print $ch "int main(int argc, char *argv[]) { ".($args{function} || 'return 0;')." }\n";
close($ch);
for my $lib ( @libs ) {
my $exefile = File::Temp::mktemp( 'assertlibXXXXXXXX' ) . $Config{_exe};
my @sys_cmd;
if ( $Config{cc} eq 'cl' ) { # Microsoft compiler
require Win32;
my @libpath = map {
q{/libpath:} . Win32::GetShortPathName($_)
} @libpaths;
# this is horribly sensitive to the order of arguments
@sys_cmd = (
@$cc,
$cfile,
"${lib}.lib",
"/Fe$exefile",
(map { '/I'.Win32::GetShortPathName($_) } @incpaths),
"/link",
@$ld,
split(' ', $Config{libs}),
(map {'/libpath:'.Win32::GetShortPathName($_)} @libpaths),
);
} elsif($Config{cc} eq 'CC/DECC') { # VMS
} elsif($Config{cc} =~ /bcc32(\.exe)?/) { # Borland
@sys_cmd = (
@$cc,
@$ld,
"-o$exefile",
(map { "-I$_" } @incpaths),
(map { "-L$_" } @libpaths),
"-l$lib",
$cfile);
} else { # Unix-ish
# gcc, Sun, AIX (gcc, cc)
@sys_cmd = (
@$cc,
@$ld,
$cfile,
"-o", "$exefile",
(map { "-I$_" } @incpaths),
(map { "-L$_" } @libpaths),
"-l$lib",
);
}
warn "# @sys_cmd\n" if $args{debug};
local $ENV{LD_RUN_PATH} = join(":", @libpaths).":".$ENV{LD_RUN_PATH} unless $^O eq 'MSWin32';
local $ENV{PATH} = join(";", @libpaths).";".$ENV{PATH} if $^O eq 'MSWin32';
my $rv = $args{debug} ? system(@sys_cmd) : _quiet_system(@sys_cmd);
if ($rv != 0 || ! -x $exefile) {
push @missing, $lib;
}
else {
my $absexefile = File::Spec->rel2abs($exefile);
$absexefile = '"'.$absexefile.'"' if $absexefile =~ m/\s/;
if (system($absexefile) != 0) {
push @wrongresult, $lib;
}
else {
if ($analyze_binary) {
push @wronganalysis, $lib if !$analyze_binary->($lib, $exefile)
}
}
}
_cleanup_exe($exefile);
}
unlink $cfile;
my $miss_string = join( q{, }, map { qq{'$_'} } @missing );
die("Can't link/include C library $miss_string, aborting.\n") if @missing;
my $wrong_string = join( q{, }, map { qq{'$_'} } @wrongresult);
die("wrong result: $wrong_string\n") if @wrongresult;
my $analysis_string = join(q{, }, map { qq{'$_'} } @wronganalysis );
die("wrong analysis: $analysis_string") if @wronganalysis;
}
sub _cleanup_exe {
my ($exefile) = @_;
my $ofile = $exefile;
$ofile =~ s/$Config{_exe}$/$Config{_o}/;
# List of files to remove
my @rmfiles;
push @rmfiles, $exefile, $ofile, "$exefile\.manifest";
if ( $Config{cc} eq 'cl' ) {
# MSVC also creates foo.ilk and foo.pdb
my $ilkfile = $exefile;
$ilkfile =~ s/$Config{_exe}$/.ilk/;
my $pdbfile = $exefile;
$pdbfile =~ s/$Config{_exe}$/.pdb/;
push @rmfiles, $ilkfile, $pdbfile;
}
foreach (@rmfiles) {
if ( -f $_ ) {
unlink $_ or warn "Could not remove $_: $!";
}
}
return
}
# return ($cc, $ld)
# where $cc is an array ref of compiler name, compiler flags
# where $ld is an array ref of linker flags
sub _findcc {
my ($debug, $user_ccflags, $user_ldflags) = @_;
# Need to use $keep=1 to work with MSWin32 backslashes and quotes
my $Config_ccflags = $Config{ccflags}; # use copy so ASPerl will compile
my @Config_ldflags = ();
for my $config_val ( @Config{qw(ldflags)} ){
push @Config_ldflags, $config_val if ( $config_val =~ /\S/ );
}
my @ccflags = grep { length } quotewords('\s+', 1, $Config_ccflags||'', $user_ccflags||'');
my @ldflags = grep { length } quotewords('\s+', 1, @Config_ldflags, $user_ldflags||'');
my @paths = split(/$Config{path_sep}/, $ENV{PATH});
my @cc = split(/\s+/, $Config{cc});
if (check_compiler ($cc[0], $debug)) {
return ( [ @cc, @ccflags ], \@ldflags );
}
# Find the extension for executables.
my $exe = $Config{_exe};
if ($^O eq 'cygwin') {
$exe = '';
}
foreach my $path (@paths) {
# Look for "$path/$cc[0].exe"
my $compiler = File::Spec->catfile($path, $cc[0]) . $exe;
if (check_compiler ($compiler, $debug)) {
return ([ $compiler, @cc[1 .. $#cc], @ccflags ], \@ldflags)
}
next if ! $exe;
# Look for "$path/$cc[0]" without the .exe, if necessary.
$compiler = File::Spec->catfile($path, $cc[0]);
if (check_compiler ($compiler, $debug)) {
return ([ $compiler, @cc[1 .. $#cc], @ccflags ], \@ldflags)
AAC-Pvoice
view release on metacpan or search on metacpan
lib/AAC/Pvoice.pm view on Meta::CPAN
package AAC::Pvoice;
use strict;
use warnings;
use Wx qw(:everything);
use Wx::Perl::Carp;
use AAC::Pvoice::Bitmap;
use AAC::Pvoice::Input;
use AAC::Pvoice::Row;
use AAC::Pvoice::EditableRow;
use AAC::Pvoice::Panel;
use AAC::Pvoice::Dialog;
use Text::Wrap qw(wrap);
BEGIN {
use Exporter ();
use vars qw ($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
$VERSION = 0.91;
@ISA = qw (Exporter);
@EXPORT = qw (MessageBox);
@EXPORT_OK = qw ();
%EXPORT_TAGS = ();
}
sub MessageBox
{
my ($message, $caption, $style, $parent, $x, $y) = @_;
$caption ||= 'Message';
$style ||= wxOK;
$x ||= -1;
$y ||= -1;
$Text::Wrap::columns = 25;
$message = wrap('','',$message)."\n";
my $width = 0;
$width = 25 if $style & wxOK;
$width = 30 if $style & wxYES_NO;
$width = 60 if $style & wxCANCEL;
my $p = Wx::Frame->new(undef, -1, 'tmp');
my $m = Wx::StaticText->new($p, -1, $message, wxDefaultPosition, wxDefaultSize, wxALIGN_CENTRE);
$m->SetFont(Wx::Font->new( 10, # font size
wxDECORATIVE, # font family
wxNORMAL, # style
wxNORMAL, # weight
0,
'Comic Sans MS', # face name
wxFONTENCODING_SYSTEM));
my $h = $m->GetSize->GetHeight;
$p->Destroy;
my $d = AAC::Pvoice::Dialog->new(undef, -1, $caption, [$x,$y], [310,100+$h]);
my $messagectrl = Wx::StaticText->new($d->{panel},
-1,
$message,
wxDefaultPosition,
wxDefaultSize,
wxALIGN_CENTRE);
$messagectrl->SetBackgroundColour($d->{backgroundcolour});
$messagectrl->SetFont(Wx::Font->new(10, # font size
wxDECORATIVE, # font family
wxNORMAL, # style
wxNORMAL, # weight
0,
'Comic Sans MS', # face name
wxFONTENCODING_SYSTEM));
$d->Append($messagectrl,1);
my $ok = [Wx::NewId,AAC::Pvoice::Bitmap->new('',50,25,'OK', Wx::Colour->new(255, 230, 230)),sub{$d->SetReturnCode(wxOK); $d->Close()}];
my $yes = [Wx::NewId,AAC::Pvoice::Bitmap->new('',50,30,'Yes', Wx::Colour->new(255, 230, 230)),sub{$d->SetReturnCode(wxYES); $d->Close()}];
my $no = [Wx::NewId,AAC::Pvoice::Bitmap->new('',50,25,'No', Wx::Colour->new(255, 230, 230)),sub{$d->SetReturnCode(wxNO); $d->Close()}];
my $cancel = [Wx::NewId,AAC::Pvoice::Bitmap->new('',50,60,'Cancel',Wx::Colour->new(255, 230, 230)),sub{$d->SetReturnCode(wxCANCEL);$d->Close()}];
my $items = [];
push @$items, $ok if $style & wxOK;
push @$items, $yes if $style & wxYES_NO;
push @$items, $no if $style & wxYES_NO;
push @$items, $cancel if $style & wxCANCEL;
$d->Append(AAC::Pvoice::Row->new($d->{panel}, # parent
scalar(@$items), # max
$items, # items
wxDefaultPosition, # pos
wxDefaultSize,
$width,
25,
$d->{ITEMSPACING},
$d->{backgroundcolour}),
0); #selectable
return $d->ShowModal();
}
=pod
=head1 NAME
AAC::Pvoice - Create GUI software for disabled people
=head1 SYNOPSIS
use AAC::Pvoice
# this includes all AAC::Pvoice modules
=head1 DESCRIPTION
AAC::Pvoice is a set of modules to create software for people who can't
use a normal mouse and/or keyboard. To see an application that uses this
set of modules, take a look at pVoice (http://www.pvoice.org, or the
sources on http://opensource.pvoice.org).
AAC::Pvoice is in fact a wrapper around many wxPerl classes, to make it
easier to create applications like pVoice.
=head1 USAGE
=head2 AAC::Pvoice::MessageBox(message, caption, style, parent, x, y)
This function is similar to Wx::MessageBox. It uses the same parameters as
Wx::MessageBox does. Currently the style parameter doesn't support the
icons that can be set on Wx::MessageBox.
See the individual module's documentation
=head1 BUGS
probably a lot, patches welcome!
=head1 AUTHOR
Jouke Visser
jouke@pvoice.org
http://jouke.pvoice.org
=head1 COPYRIGHT
This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.
The full text of the license can be found in the
LICENSE file included with this module.
=head1 SEE ALSO
perl(1), Wx, AAC::Pvoice::Panel, AAC::Pvoice::Bitmap, AAC::Pvoice::Row
AAC::Pvoice::EditableRow, AAC::Pvoice::Input
=cut
1;
__END__
ABNF-Grammar
view release on metacpan or search on metacpan
lib/ABNF/Generator.pm view on Meta::CPAN
my $rx = eval { qr/$tail$/ };
croak "Bad tail" if $@;
return $prefix =~ $rx ? $prefix : $prefix . $tail;
}
=pod
=head1 $generator->C<hasCommand>($name)
Return 1 if there is a $name is command, 0 otherwise
=cut
method hasCommand(Str $name) {
$self->{_grammar}->hasCommand($name);
}
=pod
=head1 FUNCTIONS
=head1 C<_asStrings>($generated)
Return stringification of genereted sequences from C<_generateChain>.
Uses in generate call to stringify chains.
=cut
func _asStrings($generated) {
given ( $generated->{class} ) {
when ( "Atom" ) { return [ $generated->{value} ] }
when ( "Sequence" ) {
my $value = $generated->{value};
return [] unless @$value;
my $begin = _asStrings($value->[0]);
for ( my $pos = 1; $pos < @$value; $pos++ ) {
my @new_begin = ();
my $ends = _asStrings($value->[$pos]);
next unless @$ends;
my @ibegin = splice([shuffle(@$begin)], 0, $CHOICE_LIMIT);
my @iends = splice([shuffle(@$ends)], 0, $CHOICE_LIMIT);
foreach my $end ( @iends ) {
foreach my $begin ( @ibegin ) {
push(@new_begin, $begin . $end);
}
}
$begin = \@new_begin;
}
return $begin;
}
when ( "Choice" ) {
return [
map { @{_asStrings($_)} } @{$generated->{value}}
];
}
default { die "Unknown class " . $generated->{class} . Dumper $generated }
}
}
1;
=pod
=head1 AUTHOR / COPYRIGHT / LICENSE
Copyright (c) 2013 Arseny Krasikov <nyaapa@cpan.org>.
This module is licensed under the same terms as Perl itself.
=cut
AC-MrGamoo
view release on metacpan or search on metacpan
eg/filelist.pm view on Meta::CPAN
# -*- perl -*-
# example filelist
# $Id: filelist.pm,v 1.1 2010/11/01 19:04:21 jaw Exp $
package Local::MrMagoo::FileList;
use AC::ISOTime;
use AC::Yenta::Direct;
use JSON;
use strict;
my $YDBFILE = "/data/files.ydb";
sub get_file_list {
my $config = shift;
# get files + metadata from yenta
my $yenta = AC::Yenta::Direct->new( 'files', $YDBFILE );
# the job config is asking for files that match:
my $syst = $config->{system};
my $tmax = $config->{end}; # time_t
my $tmin = $config->{start}; # time_t
# the keys in yenta are of the form: 20100126150139_[...]
my $start = isotime($tmin); # 1286819830 => 20101011T175710Z
$start =~ s/^(\d+)T(\d+).*/$1$2/; # 20101011T175710Z => 20101011175710
my @files = grep {
# does this file match the request?
($_->{subsystem} eq $syst) &&
($_->{end_time} >= $tmin) &&
($_->{start_time} <= $tmax)
} map {
# get meta-data on this file. data is json encoded
my $d = $yenta->get($_);
$d = $d ? decode_json($d) : {};
# convert space seperated locations to arrayref
$d->{location} = [ (split /\s+/, $d->{location}) ];
$d;
} $yenta->getrange($start, undef); # get all files from $start to now
return \@files;
}
1;
AC-Yenta
view release on metacpan or search on metacpan
lib/AC/Yenta.pm view on Meta::CPAN
By default, yentas obtain their primary IP address by calling
C<gethostbyname( hostname() )>. If this either does not work on your
systems, or isn't the value you want to use,
you will need to write a custom C<MySelf> class and C<my_network_info>
function.
=head1 CONFIG FILE
various parameters need to be specified in a config file.
if you modify the file, it will be reloaded automagically.
=over 4
=item port
specify the TCP port to use
port 3503
=item environment
specify the environment or realm to run in, so you can run multiple
independent yenta networks, such as production, staging, and dev.
environment prod
=item allow
specify networks allowed to connect.
allow 127.0.0.1
allow 192.168.10.0/24
=item seedpeer
specify initial peers to contact when starting. the author generally
specifies 2 on the east coast, and 2 on the west coast.
seedpeer 192.168.10.11:3503
seedpeer 192.168.10.12:3503
=item secret
specify a secret key used to encrypt data transfered between
yentas in different datacenters.
secret squeamish-ossifrage
=item syslog
specify a syslog facility for log messages.
syslog local5
=item debug
enable debugging for a particular section
debug map
=item map
configure a map (a collection of key-value data). you do not need
to configure the same set of maps on all servers. maps should be
configured similarly on all servers that they are on.
map users {
backend bdb
dbfile /home/acdata/users.ydb
history 4
}
=back
=head1 BUGS
Too many to list here.
=head1 SEE ALSO
AC::Yenta::Client
Amazon Dynamo - http://www.allthingsdistributed.com/2007/10/amazons_dynamo.html
=head1 AUTHOR
Jeff Weisberg - http://www.solvemedia.com/
=cut
1;
ACH-Generator
view release on metacpan or search on metacpan
lib/ACH/Generator.pm view on Meta::CPAN
package ACH::Generator;
$VERSION = '0.01';
use strict;
use warnings;
use ACH;
sub _croak { require Carp; Carp::croak(@_) }
=head1 NAME
ACH::Generator - Generates an ACH formatted file from an ACH perl object
=head1 VERSION
Version: 0.01
May 2006
=head1 DESCRIPTION
ACH::Generator is a simple, generic subclass of ACH used to generate ACH files.
It's intentional use is for testing purposes ONLY. ACH-Generator will allow a
developer to create an ACH formatted file.
=head1 USING ACH-Generator
use ACH::Generator;
my $newACH = new ACH;
my $newACHfile = 'newACHFile.ACH'; # The name of the ACH file to be generated
...
$newACH->generate($newACHfile);
=head1 METHODS
=head2 generate
Generates an ACH file from the data in the ACH object
=cut
# Generate the ACH file
sub ACH::generate {
# Get the file name
my $self = shift;
my $file = shift or _croak "Need an ACH file";
# File data
my $data = "";
# Iterate through the ACH Data
foreach my $item (@{$self->{_achData}}) { # Array of ACH file Sections
my @achSections = map { defined $_ ? $_ : '' } @{$item};
my $sectionValue = 0;
for (my $y=0; $y < @achSections; $y++) { # Array of ACH file Section data
my %hash = map { defined $_ ? $_ : '' } %{$achSections[$y]};
# Use the appropriate file Format size for the appropriate ACH file section
foreach my $hashItem (keys (%hash)) { # Hash containing the ACH field name and value
chomp $hash{$hashItem};
my $dataValue = "";
# Get the section header in the first field, else get the data
if ($y == 0) { $dataValue = $sectionValue = $hash{$hashItem}; }
else {
# Get the field length and data
my $field = ${$self->{_achFormats}{$sectionValue}}[$y];
my ($field_length); while ( my ($key, $value) = each(%$field) ) { $field_length = $value; }
$dataValue = substr($hash{$hashItem}, 0, $field_length);
}
# Store the data in the file data variable
$data .= $dataValue;
}
}
}
# Open the file
if ( open(OUTPUT, ">$file") ) {}
else { print "Error: Couldn't open file $file\n"; die; }
# Print data out to ACH file
print OUTPUT "$data";
# Close the ACH file
close (OUTPUT);
}
=head2 CAVEATS
This package is created for testing purposes only. It shouldn't be used
for production programs or scripts. There are other commercial products
out there that may be a more efficient solution for accomplishing your
goals.
All records in an ACH file must be formatted in the following sequence
of records. IF the file is not formatted in this exact sequence, it
may be rejected.
ACH File Layout:
1 - File Header Record
5 - First Company/Batch Header Record
6 - First Entry Detail Record
7 - First Entry Detail Addenda Record (optional)
|
Multiples of Entry Detail Records
|
6 - Last Entry Detail Record
7 - Last Entry Detail Addenda Record (optional)
8 - First Company/Batch Control Record
|
Multiples of Company/Batches
|
5 - Last Company/Batch Header Record
6 - First Entry Detail Record
ACH
view release on metacpan or search on metacpan
# Detail Record fields and field sizes
my @detailFormat = ({'Entry Detail Record' => 1}, {'Transaction Code' => 2},
{'Individual Bank ID' => 8}, {'Check Digit' => 1}, {'Bank Acct. Number' => 17}, {'Amount' => 10},
{'Individual ID Number' => 15}, {'Individual Name' => 22}, {'Bank Discretionary Data' => 2},
{'Addenda Record Indicator' => 1}, {'Trace Number' => 15});
# Addenda Format fields and field sizes
my @addendaFormat = ({'Addenda Record' => 1}, {'Addenda Type Code' => 2},
{'Payment Related Information' => 80}, {'Special Addenda Sequence Number' => 4},
{'Entry Detail Sequence Number' => 7});
# Batch Control Format fields and field sizes
my @controlFormat = ({'Batch Control Record' => 1}, {'Service Class Codes' => 3},
{'Entry/Addenda Count' => 6}, {'Entry Hash' => 10}, {'Total Debit Entry Dollar Amount' => 12},
{'Total Credit Entry Dollar Amount' => 12}, {'Company Identification' => 10}, {'Blank' => 19},
{'Blank' => 6}, {'Originating Financial Institution' => 8}, {'Batch Number' => 7});
# File Control fields and field sizes
my @fileControl = ({'File Control Record' => 1}, {'Batch Count' => 6}, {'Block Count' => 6},
{'Entry/Addenda Count' => 8}, {'Entry Hash' => 10}, {'Total Debit Entry Dollar Amount' => 12},
{'Total Credit Entry Dollar Amount' => 12}, {'Reserved/Blank' => 39});
# All of the ACH File Formats
my %achFormats = (1 => \@fileFormat, 5 => \@batchFormat, 6 => \@detailFormat,
7 => \@addendaFormat, 8 => \@controlFormat, 9 => \@fileControl);
##
# ACH data
my @achData;
=head1 METHODS
=head2 new
Creates a new ACH object
=cut
# Create a new ACH object
sub new {
my $class = shift;
my $self = {}; # allocate new hash for object
bless {
_achData => [],
_achFormats => \%achFormats,
}, $class;
}
=head2 printAllData
Prints all the ACH data
=cut
# Print all data from the ACH object
sub printAllData {
my $self = shift;
foreach my $item (@{$self->{_achData}}) { # Array of ACH file Sections
my @achSections = map { defined $_ ? $_ : '' } @{$item};
foreach my $section (@achSections) { # Array of ACH file Section data
my %hash = map { defined $_ ? $_ : '' } %{$section};
foreach my $hashItem (keys (%hash)) { # Hash containing the ACH field name and value
print "$hashItem: $hash{$hashItem}\n";
}
}
}
}
=head2 getData
Returns the ACH data
=cut
# Get data
sub getData {
my $self = shift;
return \@{$self->{_achData}};
}
=head2 CAVEATS
This package is created for testing purposes only. It shouldn't be used
for production programs or scripts. There are other commercial products
out there that may be a more efficient solution for accomplishing your
goals.
All records in an ACH file must be formatted in the following sequence
of records. IF the file is not formatted in this exact sequence, it
may be rejected.
ACH File Layout:
1 - File Header Record
5 - First Company/Batch Header Record
6 - First Entry Detail Record
7 - First Entry Detail Addenda Record (optional)
|
Multiples of Entry Detail Records
|
6 - Last Entry Detail Record
7 - Last Entry Detail Addenda Record (optional)
8 - First Company/Batch Control Record
|
Multiples of Company/Batches
|
5 - Last Company/Batch Header Record
6 - First Entry Detail Record
7 - First Entry Detail Addenda Record (optional)
|
Multiples of Entry Detail Records
|
6 - Last Entry Detail Record
7 - Last Entry Detail Addenda Record (optional)
8 - Last Company/Batch Control Record
9 - File Control Record
9999...9999 (optional)
=head1 AUTHOR
Author: Christopher Kois
ACL-Regex
view release on metacpan or search on metacpan
examples/postifx-policy-server.pl view on Meta::CPAN
#!/usr/bin/perl
#
use IO::Socket;
use threads;
use Proc::Daemon;
use Sys::Syslog qw( :DEFAULT setlogsock);
use Data::Dumper;
use lib( "./" );
use ACL;
# Global config settings
my $TC = 1;
my $debug = 1;
my $port = 12345;
our $pidfile = "/var/run/postfix-policy-server.pid";
our %redirectmap;
# Param1: Client socket
# Param2: hash_ref
sub parse_postfix_input( $$ ) {
my ($socket,$hashref) = @_;
local $/ = "\r\n";
while( my $line = <$socket> ){
chomp( $line );
$line =~ s/\r//g;
$line =~ s/\n//g;
return if $line =~ /^(\r|\n)*$/;
#print "DEBUG: $line" if $debug;
if( $line =~ /^(\w+?)=(.+)$/ ){
$hashref->{$1} = $2;
}
}
}
sub convert_hashref_to_acl($){
my( $hash_ref ) = @_;
my @a;
for( sort( keys %$hash_ref ) ) {
my $str = "$_=\[$hash_ref->{$_}\]";
push( @a, $str );
}
return( join( " ", @a ) );
}
sub process_client($){
my ($socket) = @_;
# Create some stuff
my $accept_acl = ACL->new->generate_required( 'required.txt' )->parse_acl_from_file( { Filename => "acl.permit.txt" } );
my $reject_acl = ACL->new->generate_required( 'required.txt' )->parse_acl_from_file( { Filename => "acl.reject.txt" } );
ACCEPT: while( my $client = $socket->accept() ){
my $hash_ref = {};
parse_postfix_input( $client, $hash_ref );
my $action = convert_hashref_to_acl( $hash_ref );
print "Action: " . Dumper($action) . "\n";
my ($rc,$regex,$comment) = $reject_acl->match( $action );
print Dumper( $rc ) . Dumper( $regex ) . Dumper( $comment ) . "\n";
if( $rc ){
print $client "action=reject $comment\n\n";
next ACCEPT;
# Match
}
($rc,$regex,$comment) = $accept_acl->match( $action );
print Dumper( $rc ) . Dumper( $regex ) . Dumper( $comment ) . "\n";
if( $rc ){
ACME-CPANPLUS-Module-With-Core-PreReq
view release on metacpan or search on metacpan
t/00-compile.t view on Meta::CPAN
use 5.006;
use strict;
use warnings;
# this test was generated with Dist::Zilla::Plugin::Test::Compile 2.056
use Test::More;
plan tests => 1 + ($ENV{AUTHOR_TESTING} ? 1 : 0);
my @module_files = (
'ACME/CPANPLUS/Module/With/Core/PreReq.pm'
);
# no fake home requested
my @switches = (
-d 'blib' ? '-Mblib' : '-Ilib',
);
use File::Spec;
use IPC::Open3;
use IO::Handle;
open my $stdin, '<', File::Spec->devnull or die "can't open devnull: $!";
my @warnings;
for my $lib (@module_files)
{
# see L<perlfaq8/How can I capture STDERR from an external command?>
my $stderr = IO::Handle->new;
diag('Running: ', join(', ', map { my $str = $_; $str =~ s/'/\\'/g; q{'} . $str . q{'} }
$^X, @switches, '-e', "require q[$lib]"))
if $ENV{PERL_COMPILE_TEST_DEBUG};
my $pid = open3($stdin, '>&STDERR', $stderr, $^X, @switches, '-e', "require q[$lib]");
binmode $stderr, ':crlf' if $^O eq 'MSWin32';
my @_warnings = <$stderr>;
waitpid($pid, 0);
is($?, 0, "$lib loaded ok");
shift @_warnings if @_warnings and $_warnings[0] =~ /^Using .*\bblib/
and not eval { require blib; blib->VERSION('1.01') };
if (@_warnings)
{
warn @_warnings;
push @warnings, @_warnings;
}
}
is(scalar(@warnings), 0, 'no warnings found')
or diag 'got warnings: ', ( Test::More->can('explain') ? Test::More::explain(\@warnings) : join("\n", '', @warnings) ) if $ENV{AUTHOR_TESTING};
ACME-Dzil-Test-daemon
view release on metacpan or search on metacpan
t/00-report-prereqs.t view on Meta::CPAN
my @full_reports;
my @dep_errors;
my $req_hash = $HAS_CPAN_META ? $full_prereqs->as_string_hash : $full_prereqs;
# Add static includes into a fake section
for my $mod (@include) {
$req_hash->{other}{modules}{$mod} = 0;
}
for my $phase ( qw(configure build test runtime develop other) ) {
next unless $req_hash->{$phase};
next if ($phase eq 'develop' and not $ENV{AUTHOR_TESTING});
for my $type ( qw(requires recommends suggests conflicts modules) ) {
next unless $req_hash->{$phase}{$type};
my $title = ucfirst($phase).' '.ucfirst($type);
my @reports = [qw/Module Want Have/];
for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) {
next if $mod eq 'perl';
next if grep { $_ eq $mod } @exclude;
my $file = $mod;
$file =~ s{::}{/}g;
$file .= ".pm";
my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC;
my $want = $req_hash->{$phase}{$type}{$mod};
$want = "undef" unless defined $want;
$want = "any" if !$want && $want == 0;
my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required";
if ($prefix) {
my $have = MM->parse_version( File::Spec->catfile($prefix, $file) );
$have = "undef" unless defined $have;
push @reports, [$mod, $want, $have];
if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META && $type eq 'requires' ) {
if ( $have !~ /\A$lax_version_re\z/ ) {
push @dep_errors, "$mod version '$have' cannot be parsed ($req_string)";
}
elsif ( ! $full_prereqs->requirements_for( $phase, $type )->accepts_module( $mod => $have ) ) {
push @dep_errors, "$mod version '$have' is not in required range '$want'";
}
}
}
else {
push @reports, [$mod, $want, "missing"];
if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) {
push @dep_errors, "$mod is not installed ($req_string)";
}
}
}
if ( @reports ) {
push @full_reports, "=== $title ===\n\n";
my $ml = _max( map { length $_->[0] } @reports );
my $wl = _max( map { length $_->[1] } @reports );
my $hl = _max( map { length $_->[2] } @reports );
if ($type eq 'modules') {
splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl];
push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports;
}
else {
splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl];
push @full_reports, map { sprintf(" %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2]) } @reports;
}
push @full_reports, "\n";
}
}
}
if ( @full_reports ) {
diag "\nVersions for all modules listed in $source (including optional ones):\n\n", @full_reports;
}
if ( $cpan_meta_error || @dep_errors ) {
diag "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n";
}
if ( $cpan_meta_error ) {
my ($orig_source) = grep { -f } 'MYMETA.json', 'MYMETA.yml';
diag "\nCPAN::Meta->load_file('$orig_source') failed with: $cpan_meta_error\n";
}
if ( @dep_errors ) {
diag join("\n",
"\nThe following REQUIRED prerequisites were not satisfied:\n",
@dep_errors,
"\n"
);
}
pass('Reported prereqs');
# vim: ts=4 sts=4 sw=4 et:
ACME-Dzil-Test-daemon2
view release on metacpan or search on metacpan
t/00-report-prereqs.t view on Meta::CPAN
my @full_reports;
my @dep_errors;
my $req_hash = $HAS_CPAN_META ? $full_prereqs->as_string_hash : $full_prereqs;
# Add static includes into a fake section
for my $mod (@include) {
$req_hash->{other}{modules}{$mod} = 0;
}
for my $phase ( qw(configure build test runtime develop other) ) {
next unless $req_hash->{$phase};
next if ($phase eq 'develop' and not $ENV{AUTHOR_TESTING});
for my $type ( qw(requires recommends suggests conflicts modules) ) {
next unless $req_hash->{$phase}{$type};
my $title = ucfirst($phase).' '.ucfirst($type);
my @reports = [qw/Module Want Have/];
for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) {
next if $mod eq 'perl';
next if grep { $_ eq $mod } @exclude;
my $file = $mod;
$file =~ s{::}{/}g;
$file .= ".pm";
my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC;
my $want = $req_hash->{$phase}{$type}{$mod};
$want = "undef" unless defined $want;
$want = "any" if !$want && $want == 0;
my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required";
if ($prefix) {
my $have = MM->parse_version( File::Spec->catfile($prefix, $file) );
$have = "undef" unless defined $have;
push @reports, [$mod, $want, $have];
if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META && $type eq 'requires' ) {
if ( $have !~ /\A$lax_version_re\z/ ) {
push @dep_errors, "$mod version '$have' cannot be parsed ($req_string)";
}
elsif ( ! $full_prereqs->requirements_for( $phase, $type )->accepts_module( $mod => $have ) ) {
push @dep_errors, "$mod version '$have' is not in required range '$want'";
}
}
}
else {
push @reports, [$mod, $want, "missing"];
if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) {
push @dep_errors, "$mod is not installed ($req_string)";
}
}
}
if ( @reports ) {
push @full_reports, "=== $title ===\n\n";
my $ml = _max( map { length $_->[0] } @reports );
my $wl = _max( map { length $_->[1] } @reports );
my $hl = _max( map { length $_->[2] } @reports );
if ($type eq 'modules') {
splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl];
push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports;
}
else {
splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl];
push @full_reports, map { sprintf(" %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2]) } @reports;
}
push @full_reports, "\n";
}
}
}
if ( @full_reports ) {
diag "\nVersions for all modules listed in $source (including optional ones):\n\n", @full_reports;
}
if ( $cpan_meta_error || @dep_errors ) {
diag "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n";
}
if ( $cpan_meta_error ) {
my ($orig_source) = grep { -f } 'MYMETA.json', 'MYMETA.yml';
diag "\nCPAN::Meta->load_file('$orig_source') failed with: $cpan_meta_error\n";
}
if ( @dep_errors ) {
diag join("\n",
"\nThe following REQUIRED prerequisites were not satisfied:\n",
@dep_errors,
"\n"
);
}
pass('Reported prereqs');
# vim: ts=4 sts=4 sw=4 et:
ACME-Error-Translate
view release on metacpan or search on metacpan
Translate.pm view on Meta::CPAN
package ACME::Error::Translate;
use strict;
no strict 'refs';
use vars qw[$VERSION];
$VERSION = '0.01';
use Lingua::Translate;
{
my $translator = undef;
sub import {
my $class = shift;
$translator = Lingua::Translate->new( src => 'en', dest => shift );
}
*die_handler = *warn_handler = sub {
if ( $translator ) {
return map $translator->translate( $_ ), @_;
} else {
return @_;
}
};
}
1;
__END__
=head1 NAME
ACME::Error::Translate - Language Translating Backend for ACME::Error
=head1 SYNOPSIS
use ACME::Error Translate => de;
die "Stop!"; # Anschlag!
=head1 DESCRIPTION
Translates error messages from the default English to the language of your
choice using L<Lingua::Translate>. As long as the backend used by
L<Lingua::Translage> understands your two letter language code, you're ok.
By default the backend is Babelfish.
=head1 AUTHOR
Casey West <F<casey@geeknest.com>>
=head1 SEE ALSO
perl(1), ACME::Error, Lingua::Translate.
=cut
ACME-Error
view release on metacpan or search on metacpan
lib/ACME/Error/SHOUT.pm view on Meta::CPAN
package ACME::Error::SHOUT;
use strict;
no strict 'refs';
use vars qw[$VERSION];
$VERSION = '0.02';
*warn_handler = *die_handler = sub {
my @error = @_;
$error[$_] =~ s/.$/!/g for 0 .. $#error;
return map uc, @error;
};
1;
__END__
# Below is stub documentation for your module. You better edit it!
=head1 NAME
ACME::Error::SHOUT - ACME::Error Backend to Scream Errors
=head1 SYNOPSIS
use ACME::Error SHOUT;
=head1 DESCRIPTION
This backend converts your errors to screams.
=head1 AUTHOR
Casey West <F<casey@geeknest.com>>
=head1 COPYRIGHT
Copyright (c) 2002 Casey R. West <casey@geeknest.com>. All
rights reserved. This program is free software; you can
redistribute it and/or modify it under the same terms as
Perl itself.
=head1 SEE ALSO
perl(1).
=cut
ACME-QuoteDB
view release on metacpan or search on metacpan
lib/ACME/QuoteDB/LoadDB.pm view on Meta::CPAN
#$Id: LoadDB.pm,v 1.30 2009/09/30 07:37:09 dinosau2 Exp $
# /* vim:et: set ts=4 sw=4 sts=4 tw=78: */
package ACME::QuoteDB::LoadDB;
use 5.008005; # require perl 5.8.5, re: DBD::SQLite Unicode
use warnings;
use strict;
#use criticism 'brutal'; # use critic with a ~/.perlcriticrc
use version; our $VERSION = qv('0.1.1');
# with Text::CSV only use 'perl csv loader'
# 'one time' db load performance not a concern
BEGIN {local $ENV{PERL_TEXT_CSV} = 0}
use aliased 'ACME::QuoteDB::DB::Attribution' => 'Attr';
use aliased 'ACME::QuoteDB::DB::QuoteCatg' => 'QuoteCatg';
use aliased 'ACME::QuoteDB::DB::Category' => 'Catg';
use aliased 'ACME::QuoteDB::DB::Quote' => 'Quote';
use aliased 'ACME::QuoteDB::DB::DBI' => 'QDBI';
use File::Basename qw/dirname basename/;
use File::Glob qw(:globally :nocase);
use Encode qw/is_utf8 decode/;
use Data::Dumper qw/Dumper/;
use Carp qw/carp croak/;
use Text::CSV;
use Readonly;
use DBI;
# if not in utf8 latin1 is assumed
my $FILE_ENCODING = 'iso-8859-1';
Readonly my @QUOTE_FIELDS => qw/quote name source catg rating/;
# XXX refactor
sub new {
my ($class, $args) = @_;
# TODO encapsulation
my $self = bless {}, $class;
# store each record we extract - keys map to database fields
# TODO proper encapsulation
$self->{record} = {};
$self->{record}->{quote} = q{};
$self->{record}->{rating} = q{};
$self->{record}->{name} = q{};
$self->{record}->{source} = q{};
$self->{record}->{catg} = q{};
$self->{file} = $args->{file};
$self->{dir} = $args->{dir};
$self->{data} = $args->{data};
$self->{file_format} = $args->{file_format};
$FILE_ENCODING = $args->{file_encoding} || $FILE_ENCODING;
$self->{delim} = $args->{delimiter};
$self->{verbose} = $args->{verbose};
$self->{category} = $args->{category};
$self->{rating} = $args->{rating};
$self->{attr_source} = $args->{attr_source};
$self->{orig_args} = $args;
$self->{success} = undef;
# start with if set
$self->{record}->{rating} = $self->{rating};
$self->{record}->{name} = $self->{attr_source};
$self->{record}->{source} = $self->{attr_source};
if (ref $self->{category} eq 'ARRAY') {
$self->{record}->{catg} = ();
foreach my $c (@{$self->{category}}){
push @{$self->{record}->{catg}}, $c;
}
}
else {
$self->{record}->{catg} = $self->{category};
}
# db connection info
if ($ENV{ACME_QUOTEDB_DB}) {
$self->{db} = $ENV{ACME_QUOTEDB_DB};
$self->{host} = $ENV{ACME_QUOTEDB_HOST};
$self->{user} = $ENV{ACME_QUOTEDB_USER};
$self->{pass} = $ENV{ACME_QUOTEDB_PASS};
}
if (!$args->{dry_run}){$self->{write_db} = 1};
#if ($args->{create_db}) {$self->create_db};
if ($args->{create_db}) {$self->create_db_tables};
return $self;
}
sub set_record {
my ($self, $field, $value) = @_;
# TODO support mult-field simultanous loading
if ($value) {
$self->{record}->{$field} = $value;
}
return $self;
ADAMK-Release
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
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
#!/usr/bin/perl -w
use strict;
use AE::AdHoc;
use AnyEvent::Socket;
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
BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 }
my $VERSION = 3.35;
my %opt = (
quiet => 0,
diag => 1,
hints => 1,
changes => 1,
cplusplus => 0,
filter => 1,
strip => 0,
version => 0,
);
my($ppport) = $0 =~ /([\w.]+)$/;
my $LF = '(?:\r\n|[\r\n])'; # line feed
my $HS = "[ \t]"; # horizontal whitespace
# Never use C comments in this file!
my $ccs = '/'.'*';
my $cce = '*'.'/';
my $rccs = quotemeta $ccs;
my $rcce = quotemeta $cce;
eval {
require Getopt::Long;
Getopt::Long::GetOptions(\%opt, qw(
help quiet diag! filter! hints! changes! cplusplus strip version
patch=s copy=s diff=s compat-version=s
list-provided list-unsupported api-info=s
)) or usage();
};
if ($@ and grep /^-/, @ARGV) {
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 (exists $opt{'compat-version'}) {
my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) };
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;
}
my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/
? ( $1 => {
($2 ? ( base => $2 ) : ()),
($3 ? ( todo => $3 ) : ()),
(index($4, 'v') >= 0 ? ( varargs => 1 ) : ()),
(index($4, 'p') >= 0 ? ( provided => 1 ) : ()),
(index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()),
} )
: die "invalid spec: $_" } qw(
ASCII_TO_NEED||5.007001|n
AvFILLp|5.004050||p
AvFILL|||
BhkDISABLE||5.024000|
BhkENABLE||5.024000|
BhkENTRY_set||5.024000|
BhkENTRY|||
BhkFLAGS|||
CALL_BLOCK_HOOKS|||
CLASS|||n
CPERLscope|5.005000||p
CX_CURPAD_SAVE|||
CX_CURPAD_SV|||
C_ARRAY_END|5.013002||p
C_ARRAY_LENGTH|5.008001||p
CopFILEAV|5.006000||p
CopFILEGV_set|5.006000||p
CopFILEGV|5.006000||p
CopFILESV|5.006000||p
CopFILE_set|5.006000||p
CopFILE|5.006000||p
CopSTASHPV_set|5.006000||p
CopSTASHPV|5.006000||p
CopSTASH_eq|5.006000||p
CopSTASH_set|5.006000||p
CopSTASH|5.006000||p
CopyD|5.009002|5.004050|p
Copy|||
CvPADLIST||5.008001|
CvSTASH|||
CvWEAKOUTSIDE|||
DECLARATION_FOR_LC_NUMERIC_MANIPULATION||5.021010|n
DEFSV_set|5.010001||p
DEFSV|5.004050||p
DO_UTF8||5.006000|
END_EXTERN_C|5.005000||p
ENTER|||
ERRSV|5.004050||p
EXTEND|||
EXTERN_C|5.005000||p
F0convert|||n
FREETMPS|||
GIMME_V||5.004000|n
GIMME|||n
GROK_NUMERIC_RADIX|5.007002||p
G_ARRAY|||
G_DISCARD|||
G_EVAL|||
G_METHOD|5.006001||p
G_NOARGS|||
G_SCALAR|||
G_VOID||5.004000|
WARN_SEVERE|5.006000||p
WARN_SIGNAL|5.006000||p
WARN_SUBSTR|5.006000||p
WARN_SYNTAX|5.006000||p
WARN_TAINT|5.006000||p
WARN_THREADS|5.008000||p
WARN_UNINITIALIZED|5.006000||p
WARN_UNOPENED|5.006000||p
WARN_UNPACK|5.006000||p
WARN_UNTIE|5.006000||p
WARN_UTF8|5.006000||p
WARN_VOID|5.006000||p
WIDEST_UTYPE|5.015004||p
XCPT_CATCH|5.009002||p
XCPT_RETHROW|5.009002||p
XCPT_TRY_END|5.009002||p
XCPT_TRY_START|5.009002||p
XPUSHi|||
XPUSHmortal|5.009002||p
XPUSHn|||
XPUSHp|||
XPUSHs|||
XPUSHu|5.004000||p
XSPROTO|5.010000||p
XSRETURN_EMPTY|||
XSRETURN_IV|||
XSRETURN_NO|||
XSRETURN_NV|||
XSRETURN_PV|||
XSRETURN_UNDEF|||
XSRETURN_UV|5.008001||p
XSRETURN_YES|||
XSRETURN|||p
XST_mIV|||
XST_mNO|||
XST_mNV|||
XST_mPV|||
XST_mUNDEF|||
XST_mUV|5.008001||p
XST_mYES|||
XS_APIVERSION_BOOTCHECK||5.024000|
XS_EXTERNAL||5.024000|
XS_INTERNAL||5.024000|
XS_VERSION_BOOTCHECK||5.024000|
XS_VERSION|||
XSprePUSH|5.006000||p
XS|||
XopDISABLE||5.024000|
XopENABLE||5.024000|
XopENTRYCUSTOM||5.024000|
XopENTRY_set||5.024000|
XopENTRY||5.024000|
XopFLAGS||5.013007|
ZeroD|5.009002||p
Zero|||
_aMY_CXT|5.007003||p
_add_range_to_invlist|||
_append_range_to_invlist|||
_core_swash_init|||
_get_encoding|||
_get_regclass_nonbitmap_data|||
_get_swash_invlist|||
_invlistEQ|||
_invlist_array_init|||n
_invlist_contains_cp|||n
_invlist_dump|||
_invlist_intersection_maybe_complement_2nd|||
_invlist_intersection|||
_invlist_invert|||
_invlist_len|||n
_invlist_populate_swatch|||n
_invlist_search|||n
_invlist_subtract|||
_invlist_union_maybe_complement_2nd|||
_invlist_union|||
_is_cur_LC_category_utf8|||
_is_in_locale_category||5.021001|
_is_uni_FOO||5.017008|
_is_uni_perl_idcont||5.017008|
_is_uni_perl_idstart||5.017007|
_is_utf8_FOO||5.017008|
_is_utf8_char_slow||5.021001|n
_is_utf8_idcont||5.021001|
_is_utf8_idstart||5.021001|
_is_utf8_mark||5.017008|
_is_utf8_perl_idcont||5.017008|
_is_utf8_perl_idstart||5.017007|
_is_utf8_xidcont||5.021001|
_is_utf8_xidstart||5.021001|
_load_PL_utf8_foldclosures|||
_make_exactf_invlist|||
_new_invlist_C_array|||
_new_invlist|||
_pMY_CXT|5.007003||p
_setlocale_debug_string|||n
_setup_canned_invlist|||
_swash_inversion_hash|||
_swash_to_invlist|||
_to_fold_latin1|||
_to_uni_fold_flags||5.014000|
_to_upper_title_latin1|||
_to_utf8_case|||
_to_utf8_fold_flags||5.019009|
_to_utf8_lower_flags||5.019009|
_to_utf8_title_flags||5.019009|
_to_utf8_upper_flags||5.019009|
_warn_problematic_locale|||n
aMY_CXT_|5.007003||p
aMY_CXT|5.007003||p
aTHXR_|5.024000||p
aTHXR|5.024000||p
aTHX_|5.006000||p
aTHX|5.006000||p
add_above_Latin1_folds|||
add_cp_to_invlist|||
add_data|||n
add_multi_match|||
add_utf16_textfilter|||
adjust_size_and_find_bucket|||n
advance_one_LB|||
advance_one_SB|||
padname_free|||
padnamelist_dup|||
padnamelist_fetch||5.021007|n
padnamelist_free|||
padnamelist_store||5.021007|
parse_arithexpr||5.013008|
parse_barestmt||5.013007|
parse_block||5.013007|
parse_body|||
parse_fullexpr||5.013008|
parse_fullstmt||5.013005|
parse_gv_stash_name|||
parse_ident|||
parse_label||5.013007|
parse_listexpr||5.013008|
parse_lparen_question_flags|||
parse_stmtseq||5.013006|
parse_subsignature|||
parse_termexpr||5.013008|
parse_unicode_opts|||
parser_dup|||
parser_free_nexttoke_ops|||
parser_free|||
path_is_searchable|||n
peep|||
pending_ident|||
perl_alloc_using|||n
perl_alloc|||n
perl_clone_using|||n
perl_clone|||n
perl_construct|||n
perl_destruct||5.007003|n
perl_free|||n
perl_parse||5.006000|n
perl_run|||n
pidgone|||
pm_description|||
pmop_dump||5.006000|
pmruntime|||
pmtrans|||
pop_scope|||
populate_ANYOF_from_invlist|||
populate_isa|||v
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
ptr_table_free||5.009005|
ptr_table_new||5.009005|
ptr_table_split||5.009005|
ptr_table_store||5.009005|
push_scope|||
put_charclass_bitmap_innards_common|||
put_charclass_bitmap_innards_invlist|||
put_charclass_bitmap_innards|||
put_code_point|||
put_range|||
pv_display|5.006000||p
pv_escape|5.009004||p
pv_pretty|5.009004||p
pv_uni_display||5.007003|
qerror|||
qsortsvu|||
quadmath_format_needed|||n
quadmath_format_single|||n
re_compile||5.009005|
re_croak2|||
re_dup_guts|||
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|
ref_array_or_hash|||
refcounted_he_chain_2hv|||
refcounted_he_fetch_pvn|||
refcounted_he_fetch_pvs|||
refcounted_he_fetch_pv|||
refcounted_he_fetch_sv|||
refcounted_he_free|||
refcounted_he_inc|||
refcounted_he_new_pvn|||
refcounted_he_new_pvs|||
refcounted_he_new_pv|||
refcounted_he_new_sv|||
refcounted_he_value|||
refkids|||
refto|||
ref||5.024000|
reg2Lanode|||
reg_check_named_buff_matched|||n
reg_named_buff_all||5.009005|
reg_named_buff_exists||5.009005|
reg_named_buff_fetch||5.009005|
reg_named_buff_firstkey||5.009005|
reg_named_buff_iter|||
reg_named_buff_nextkey||5.009005|
reg_named_buff_scalar||5.009005|
reg_named_buff|||
reg_node|||
reg_numbered_buff_fetch|||
reg_numbered_buff_length|||
reg_numbered_buff_store|||
reg_qr_package|||
reg_recode|||
reg_scan_name|||
reg_skipcomment|||n
reg_temp_copy|||
reganode|||
{
my $code = shift;
$code =~ s{
/ (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*)
| "[^"\\]*(?:\\.[^"\\]*)*"
| '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx;
grep { exists $API{$_} } $code =~ /(\w+)/mg;
}
while (<DATA>) {
if ($hint) {
my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings;
if (m{^\s*\*\s(.*?)\s*$}) {
for (@{$hint->[1]}) {
$h->{$_} ||= ''; # suppress warning with older perls
$h->{$_} .= "$1\n";
}
}
else { undef $hint }
}
$hint = [$1, [split /,?\s+/, $2]]
if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$};
if ($define) {
if ($define->[1] =~ /\\$/) {
$define->[1] .= $_;
}
else {
if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) {
my @n = find_api($define->[1]);
push @{$depends{$define->[0]}}, @n if @n
}
undef $define;
}
}
$define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)};
if ($function) {
if (/^}/) {
if (exists $API{$function->[0]}) {
my @n = find_api($function->[1]);
push @{$depends{$function->[0]}}, @n if @n
}
undef $function;
}
else {
$function->[1] .= $_;
}
}
$function = [$1, ''] if m{^DPPP_\(my_(\w+)\)};
$replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$};
$replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)};
$replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce};
$replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$};
if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) {
my @deps = map { s/\s+//g; $_ } split /,/, $3;
my $d;
for $d (map { s/\s+//g; $_ } split /,/, $1) {
push @{$depends{$d}}, @deps;
}
}
$need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)};
}
for (values %depends) {
my %s;
$_ = [sort grep !$s{$_}++, @$_];
}
if (exists $opt{'api-info'}) {
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;
for $f (sort { lc $a cmp lc $b } keys %API) {
next unless $API{$f}{provided};
my @flags;
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;
my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc );
my $srcext = join '|', map { quotemeta $_ } @srcext;
if (@ARGV) {
my %seen;
for (@ARGV) {
if (-e) {
if (-f) {
push @files, $_ unless $seen{$_}++;
}
else { warn "'$_' is not a file.\n" }
}
else {
my @new = grep { -f } glob $_
or warn "'$_' does not exist.\n";
push @files, grep { !$seen{$_}++ } @new;
}
}
}
else {
eval {
require File::Find;
File::Find::find(sub {
$File::Find::name =~ /($srcext)$/i
and push @files, $File::Find::name;
}, '.');
};
if ($@) {
@files = map { glob "*$_" } @srcext;
}
}
if (!@ARGV || $opt{filter}) {
my(@in, @out);
my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files;
for (@files) {
my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i;
push @{ $out ? \@out : \@in }, $_;
}
if (@ARGV && @out) {
warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out);
}
@files = @in;
}
die "No input files given!\n" unless @files;
my(%files, %global, %revreplace);
%revreplace = reverse %replace;
my $filename;
my $patch_opened = 0;
for $filename (@files) {
unless (open IN, "<$filename") {
warn "Unable to read from $filename: $!\n";
next;
}
info("Scanning $filename ...");
my $c = do { local $/; <IN> };
close IN;
my %file = (orig => $c, changes => 0);
# Temporarily remove C/XS comments and strings from the code
my @ccom;
$c =~ s{
( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]*
| ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* )
| ( ^$HS*\#[^\r\n]*
| "[^"\\]*(?:\\.[^"\\]*)*"
| '[^'\\]*(?:\\.[^'\\]*)*'
| / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) )
}{ defined $2 and push @ccom, $2;
defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex;
$file{ccom} = \@ccom;
$file{code} = $c;
$file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m;
my $func;
for $func (keys %API) {
my $match = $func;
$match .= "|$revreplace{$func}" if exists $revreplace{$func};
if ($c =~ /\b(?:Perl_)?($match)\b/) {
$file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func};
$file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/;
if (exists $API{$func}{provided}) {
$file{uses_provided}{$func}++;
if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) {
$file{uses}{$func}++;
my @deps = rec_depend($func);
HEADER
}
if (!defined $diff) {
$diff = run_diff('diff -u', $file, $str);
}
if (!defined $diff) {
$diff = run_diff('diff', $file, $str);
}
if (!defined $diff) {
error("Cannot generate a diff. Please install Text::Diff or use --copy.");
return;
}
print F $diff;
}
sub run_diff
{
my($prog, $file, $str) = @_;
my $tmp = 'dppptemp';
my $suf = 'aaa';
my $diff = '';
local *F;
while (-e "$tmp.$suf") { $suf++ }
$tmp = "$tmp.$suf";
if (open F, ">$tmp") {
print F $str;
close F;
if (open F, "$prog $file $tmp |") {
while (<F>) {
s/\Q$tmp\E/$file.patched/;
$diff .= $_;
}
close F;
unlink $tmp;
return $diff;
}
unlink $tmp;
}
else {
error("Cannot open '$tmp' for writing: $!");
}
return undef;
}
sub rec_depend
{
my($func, $seen) = @_;
return () unless exists $depends{$func};
$seen = {%{$seen||{}}};
return () if $seen->{$func}++;
my %s;
grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}};
}
sub parse_version
{
my $ver = shift;
if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
return ($1, $2, $3);
}
elsif ($ver !~ /^\d+\.[\d_]+$/) {
die "cannot parse version '$ver'\n";
}
$ver =~ s/_//g;
$ver =~ s/$/000000/;
my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
$v = int $v;
$s = int $s;
if ($r < 5 || ($r == 5 && $v < 6)) {
if ($s % 10) {
die "cannot parse version '$ver'\n";
}
}
return ($r, $v, $s);
}
sub format_version
{
my $ver = shift;
$ver =~ s/$/000000/;
my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
$v = int $v;
$s = int $s;
if ($r < 5 || ($r == 5 && $v < 6)) {
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";
}
AFS-Command
view release on metacpan or search on metacpan
lib/AFS/Command/FS.pm view on Meta::CPAN
sub diskfree {
my $self = shift;
return $self->_paths_method('diskfree',@_);
}
sub examine {
my $self = shift;
return $self->_paths_method('examine',@_);
}
sub listquota {
my $self = shift;
return $self->_paths_method('listquota',@_);
}
sub quota {
my $self = shift;
return $self->_paths_method('quota',@_);
}
sub storebehind {
my $self = shift;
return $self->_paths_method('storebehind',@_);
}
sub whereis {
my $self = shift;
return $self->_paths_method('whereis',@_);
}
sub whichcell {
my $self = shift;
return $self->_paths_method('whichcell',@_);
}
sub listacl {
my $self = shift;
return $self->_paths_method('listacl',@_);
}
sub _paths_method {
my $self = shift;
my $operation = shift;
my (%args) = @_;
my $result = AFS::Object::CacheManager->new();
$self->{operation} = $operation;
my $pathkey = $operation eq 'storebehind' ? 'files' : 'path';
return unless $self->_parse_arguments(%args);
my $errors = 0;
$errors++ unless $self->_exec_cmds( stderr => 'stdout' );
my @paths = ref $args{$pathkey} eq 'ARRAY' ? @{$args{$pathkey}} : ($args{$pathkey});
my %paths = map { $_ => 1 } @paths;
my $default = undef; # Used by storebehind
while ( defined($_ = $self->{handle}->getline()) ) {
next if /^Volume Name/;
my $path = AFS::Object::Path->new();
if ( /fs: Invalid argument; it is possible that (.*) is not in AFS./ ||
/fs: no such cell as \'(.*)\'/ ||
/fs: File \'(.*)\' doesn\'t exist/ ||
/fs: You don\'t have the required access rights on \'(.*)\'/ ) {
$path->_setAttribute
(
path => $1,
error => $_,
);
delete $paths{$1};
@paths = grep($_ ne $1,@paths);
} else {
if ( $operation eq 'listacl' ) {
if ( /^Access list for (.*) is/ ) {
$path->_setAttribute( path => $1 );
delete $paths{$1};
my $normal = AFS::Object::ACL->new();
my $negative = AFS::Object::ACL->new();
my $type = 0;
while ( defined($_ = $self->{handle}->getline()) ) {
s/^\s+//g;
s/\s+$//g;
last if /^\s*$/;
$type = 1, next if /^Normal rights:/;
$type = -1, next if /^Negative rights:/;
my ($principal,$rights) = split;
if ( $type == 1 ) {
$normal->_addEntry( $principal => $rights );
} elsif ( $type == -1 ) {
$negative->_addEntry( $principal => $rights );
}
}
$path->_setACLNormal($normal);
$path->_setACLNegative($negative);
}
lib/AFS/Command/FS.pm view on Meta::CPAN
return if $errors;
return $result;
}
sub listcells {
my $self = shift;
my (%args) = @_;
my $result = AFS::Object::CacheManager->new();
$self->{operation} = "listcells";
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 ( /^Cell (\S+) on hosts (.*)\.$/ ) {
my $cell = AFS::Object::Cell->new
(
cell => $1,
servers => [split(/\s+/,$2)],
);
$result->_addCell($cell);
}
}
$errors++ unless $self->_reap_cmds();
$errors++ unless $self->_restore_stderr();
return if $errors;
return $result;
}
sub lsmount {
my $self = shift;
my (%args) = @_;
my $result = AFS::Object::CacheManager->new();
$self->{operation} = "lsmount";
return unless $self->_parse_arguments(%args);
my $errors = 0;
$errors++ unless $self->_exec_cmds( stderr => 'stdout' );
my @dirs = ref $args{dir} eq 'ARRAY' ? @{$args{dir}} : ($args{dir});
my %dirs = map { $_ => 1 } @dirs;
while ( defined($_ = $self->{handle}->getline()) ) {
my $current = shift @dirs;
delete $dirs{$current};
my $path = AFS::Object::Path->new( path => $current );
if ( /fs: Can.t read target name/ ) {
$path->_setAttribute( error => $_ );
} elsif ( /fs: File '.*' doesn't exist/ ) {
$path->_setAttribute( error => $_ );
} elsif ( /fs: you may not use \'.\'/ ) {
$_ .= $self->{handle}->getline();
$path->_setAttribute( error => $_ );
} elsif ( /\'(.*?)\' is not a mount point/ ) {
$path->_setAttribute( error => $_ );
} elsif ( /^\'(.*?)\'.*?\'(.*?)\'$/ ) {
my ($dir,$mount) = ($1,$2);
$path->_setAttribute( symlink => 1 ) if /symbolic link/;
$path->_setAttribute( readwrite => 1 ) if $mount =~ /^%/;
$mount =~ s/^(%|\#)//;
my ($volname,$cell) = reverse split(/:/,$mount);
$path->_setAttribute( volname => $volname );
$path->_setAttribute( cell => $cell) if $cell;
} else {
$self->_Carp("fs lsmount: Unrecognized output: '$_'");
$errors++;
next;
}
$result->_addPath($path);
}
foreach my $dir ( keys %dirs ) {
my $path = AFS::Object::Path->new
(
path => $dir,
error => "Unable to determine results",
);
$result->_addPath($path);
}
$errors++ unless $self->_reap_cmds( allowstatus => 1 );
return if $errors;
return $result;
}
#
# This is deprecated in newer versions of OpenAFS
AFS-Monitor
view release on metacpan or search on metacpan
MANIFEST
README
CHANGES
LICENCES/Artistic
LICENCES/IBM-LICENCE
LICENCES/COPYING
LICENCES/Stanford-LICENCE
Makefile.PL
examples/configs/configfile
examples/configs/badconfig
examples/Meltdown.pl
examples/scripts/HandlerScript
examples/udebug
examples/afsmonitor
examples/scout
examples/cmdebug
examples/rxdebug
examples/xstat_cm_test
examples/xstat_fs_test
pod/Makefile
pod/cmdebug.pod
pod/rxdebug.pod
pod/scout.pod
pod/afsmonitor.pod
pod/udebug.pod
pod/xstat_cm_test.pod
pod/xstat_fs_test.pod
pod/afsmon_stats.pod
pod/Monitor.pod
src/Monitor.xs
src/Makefile.PL
src/ppport.h
src/t/Monitor.t
src/afsmon-labels.h
src/Monitor.pm
src/typemap
AFS-PAG
view release on metacpan or search on metacpan
t/style/coverage.t view on Meta::CPAN
#!/usr/bin/perl
#
# Test Perl code for test coverage.
#
# The canonical version of this file is maintained in the rra-c-util package,
# which can be found at <http://www.eyrie.org/~eagle/software/rra-c-util/>.
#
# Written by Russ Allbery <eagle@eyrie.org>
# Copyright 2013, 2014
# The Board of Trustees of the Leland Stanford Junior University
#
# Permission is hereby granted, free of charge, to any person obtaining a
# copy of this software and associated documentation files (the "Software"),
# to deal in the Software without restriction, including without limitation
# the rights to use, copy, modify, merge, publish, distribute, sublicense,
# and/or sell copies of the Software, and to permit persons to whom the
# Software is furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
# DEALINGS IN THE SOFTWARE.
use 5.006;
use strict;
use warnings;
use lib 't/lib';
use File::Spec;
use Test::More;
use Test::RRA qw(skip_unless_author use_prereq);
use Test::RRA::Config qw($COVERAGE_LEVEL @COVERAGE_SKIP_TESTS);
# Skip code coverage unless author tests are enabled since it takes a long
# time, is sensitive to versions of various libraries, and does not detect
# functionality problems.
skip_unless_author('Coverage tests');
# Load prerequisite modules.
use_prereq('Devel::Cover');
use_prereq('Test::Strict');
# Build a list of test directories to use for coverage.
my %ignore = map { $_ => 1 } qw(data docs style), @COVERAGE_SKIP_TESTS;
opendir(my $testdir, 't') or BAIL_OUT("cannot open t: $!");
my @t_dirs = readdir($testdir) or BAIL_OUT("cannot read t: $!");
closedir($testdir) or BAIL_OUT("cannot close t: $!");
# Filter out ignored and system directories.
@t_dirs = grep { !$ignore{$_} } File::Spec->no_upwards(@t_dirs);
# Prepend the t directory name to the directories.
@t_dirs = map { File::Spec->catfile('t', $_) } @t_dirs;
# Disable POD coverage; that's handled separately and is confused by
# autoloading.
$Test::Strict::DEVEL_COVER_OPTIONS
= '-coverage,statement,branch,condition,subroutine';
# Do the coverage analysis.
all_cover_ok($COVERAGE_LEVEL, @t_dirs);
# Hack to suppress "used only once" warnings.
END { $Test::Strict::DEVEL_COVER_OPTIONS = q{} }
AFS
view release on metacpan or search on metacpan
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);
$CLASS->output(\*TESTOUT);
$CLASS->failure_output(\*TESTERR);
$CLASS->todo_output(\*TESTOUT);
}
sub _autoflush {
my($fh) = shift;
my $old_fh = select $fh;
$| = 1;
select $old_fh;
}
sub current_test {
my($self, $num) = @_;
lock($Curr_Test);
if( defined $num ) {
unless( $Have_Plan ) {
require Carp;
Carp::croak("Can't change the current test number without a plan!");
}
$Curr_Test = $num;
if( $num > @Test_Results ) {
my $start = @Test_Results ? $#Test_Results + 1 : 0;
for ($start..$num-1) {
my %result;
share(%result);
%result = ( ok => 1,
actual_ok => undef,
reason => 'incrementing test number',
type => 'unknown',
name => undef
);
$Test_Results[$_] = \%result;
}
}
}
return $Curr_Test;
}
sub summary {
my($self) = shift;
return map { $_->{'ok'} } @Test_Results;
}
sub details {
return @Test_Results;
}
sub todo {
my($self, $pack) = @_;
$pack = $pack || $self->exported_to || $self->caller(1);
no strict 'refs';
return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
: 0;
}
sub caller {
my($self, $height) = @_;
$height ||= 0;
my @caller = CORE::caller($self->level + $height + 1);
return wantarray ? @caller : $caller[0];
}
sub _sanity_check {
_whoa($Curr_Test < 0, 'Says here you ran a negative number of tests!');
_whoa(!$Have_Plan and $Curr_Test,
'Somehow your tests ran without a plan!');
_whoa($Curr_Test != @Test_Results,
'Somehow you got a different number of results than tests ran!');
}
sub _whoa {
my($check, $desc) = @_;
if( $check ) {
die <<WHOA;
WHOA! $desc
This should never happen! Please contact the author immediately!
WHOA
}
}
sub _my_exit {
$? = $_[0];
return 1;
}
$SIG{__DIE__} = sub {
# We don't want to muck with death in an eval, but $^S isn't
# totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
# with it. Instead, we use caller. This also means it runs under
# 5.004!
AHA
view release on metacpan or search on metacpan
package AHA;
use strict;
use LWP::UserAgent;
use AHA::Switch;
use Encode;
use Digest::MD5;
use Data::Dumper;
use vars qw($VERSION);
$VERSION = "0.55";
# Set to one if some debugging should be printed
my $DEBUG = 0;
=item $aha = new AHA({host => "fritz.box", password => "s!cr!t", user => "admin"})
=item $aha = new AHA("fritz.box","s!cr!t","admin")
Create a new AHA object for accessing a Fritz Box via the HTTP interface. The
parameters can be given as a hashref (for named parameters) or in a simple form
with host, password and user (optional) as unnamed arguments.
The named arguments which can be used:
=over
=item host
Name or IP of the Fritz box to access
=item port
Port to connect to. It's 80 by default
=item password
Password for connecting to the Fritz Box
=item user
User role for login. Only required if a role based login is configured for the
Fritz box
=back
If used without an hashref as argument, the first argument must be the host,
the second the password and the third optionally the user.
=cut
sub new {
my $class = shift;
my $self = {};
my $arg1 = shift;
if (ref($arg1) ne "HASH") {
$self->{host} = $arg1;
$self->{password} = shift;
$self->{user} = shift;
} else {
map { $self->{$_} = $arg1->{$_} } qw(host password user port);
}
die "No host given" unless $self->{host};
die "No password given" unless $self->{password};
my $base = $self->{port} ? $self->{host} . ":" . $self->{port} : $self->{host};
$self->{ua} = LWP::UserAgent->new;
$self->{login_url} = "http://" . $base . "/login_sid.lua";
$self->{ws_url} = "http://" . $base . "/webservices/homeautoswitch.lua";
$self->{ain_map} = {};
return bless $self,$class;
}
=item $switches = $aha->list()
List all switches know to AHA. An arrayref with L<AHA::Switch> objects is
returned, one for each device. When no switch is registered an empty arrayref
is returned.
=cut
sub list {
my $self = shift;
return [ map { new AHA::Switch($self,$_) } (split /\s*,\s*/,$self->_execute_cmd("getswitchlist")) ];
}
=item $aha->is_on($ain)
Check, whether the switch C<$ain> is in state "on", in which case this methods
returns 1. If it is "off", 0 is returned. If the switch is not connected,
C<undef> is returned.
=cut
sub is_on {
my $self = shift;
return &_inval_check($self->_execute_cmd("getswitchstate",$self->_ain(shift)));
}
=item $aha->on($ain)
Switch on the switch with the name or AIN C<$ain>.
=cut
sub on {
my $self = shift;
my $ain = $self->_ain(shift);
return $self->_execute_cmd("setswitchon",$ain);
}
=item $aha->off($ain)
Switch off the switch with the name or AIN C<$ain>.
=cut
sub off {
my $self = shift;
return $self->_execute_cmd("setswitchoff",$self->_ain(shift));
}
=item $is_present = $aha->is_present($ain)
Check whether the switch C<$ain> is present. This means, whether it is
registered at the Fritz Box at all in which case 1 is returned. If the switch
is not connected, 0 is returned.
=cut
sub is_present {
my $self = shift;
return $self->_execute_cmd("getswitchpresent",$self->_ain(shift));
}
=item $energy = $aha->energy($ain)
Get the amount of energy which has been consumed by the switch C<$ain> since
ever or since the reset of the energy statistics via the admin UI. The amount
is measured in Wh.
=cut
sub energy {
my $self = shift;
return $self->_execute_cmd("getswitchenergy",$self->_ain(shift));
}
=item $power = $aha->power($ain)
Get the current power consumption of the switch C<$ain> in mW.
If the switch is not connected, C<undef> is returned.
=cut
sub power {
my $self = shift;
return &_inval_check($self->_execute_cmd("getswitchpower",$self->_ain(shift)));
}
=item $name = $aha->name($ain)
Get the symbolic name for the AIN given. In this case C<$ain> must be an real
AIN.
=cut
sub name {
my $self = shift;
my $ain = shift || die "No AIN given for which to fetch the name";
return $self->_execute_cmd("getswitchname",$ain);
}
=item $ain = $aha->ain($name)
This is the inverse method to C<name()>. It takes a symbolic name C<$name> as
argument and returns the AIN. If no such name is registered, an error is
raised.
=cut
sub ain_by_name {
my $self = shift;
my $name = shift;
my $map = $self->{ain_map};
return $map->{$name} if $map->{$name};
$self->_init_ain_map();
my $ain = $self->{ain_map}->{$name};
die "No AIN for '$name' found" unless $ain;
return $ain;
}
=item $aha->logout()
Logout from the connected fritz.box in order to free up any resources. You
can still use any other method on this object, in which case it is
logs in again (which eats up some performance, of course)
=cut
sub logout {
my $self = shift;
return unless $self->{sid};
# Send a post request as defined in
# http://www.avm.de/de/Extern/files/session_id/AVM_Technical_Note_-_Session_ID.pdf
my $req = HTTP::Request->new(POST => $self->{login_url});
$req->content_type("application/x-www-form-urlencoded");
my $login = "sid=".$self->{sid}."&security:command/logout=fcn";
$req->content($login);
my $resp = $self->{ua}->request($req);
die "Cannot logout SID ",$self->{sid},": ",$resp->status_line unless $resp->is_success;
print "--- Logout ",$self->{sid} if $DEBUG;
delete $self->{sid};
}
=back
=cut
# ======================================================================
# Private methods
# Decide whether an AIN or a name is given
sub _ain {
my $self = shift;
my $ain = shift || die "No AIN or name given";
return $ain =~ /^\d{12}$/ ? $ain : $self->ain_by_name($ain);
}
# Execute a command as defined in
# http://www.avm.de/de/Extern/files/session_id/AHA-HTTP-Interface.pdf
sub _execute_cmd {
my $self = shift;
my $cmd = shift || die "No command given";
my $ain = shift;
my $url = $self->{ws_url} . "?sid=" . $self->_sid() . "&switchcmd=" . $cmd;
$url .= "&ain=" . $ain if $ain;
my $resp = $self->{ua}->get($url);
print ">>> $url\n" if $DEBUG;
die "Cannot execute ",$cmd,": ",$resp->status_line unless $resp->is_success;
my $c = $resp->content;
chomp $c;
print "<<< $c\n" if $DEBUG;
return $c;
}
# Return the cached SID or perform the login as described in
# http://www.avm.de/de/Extern/files/session_id/AVM_Technical_Note_-_Session_ID.pdf
sub _sid {
my $self = shift;
return $self->{sid} if $self->{sid};
# Get the challenge
my $resp = $self->{ua}->get($self->{login_url});
my $content = $resp->content();
my $challenge = ($content =~ /<Challenge>(.*?)<\/Challenge>/ && $1);
my $input = $challenge . '-' . $self->{password};
Encode::from_to($input, 'ascii', 'utf16le');
my $challengeresponse = $challenge . '-' . lc(Digest::MD5::md5_hex($input));
# Send the challenge back with encoded password
my $req = HTTP::Request->new(POST => $self->{login_url});
$req->content_type("application/x-www-form-urlencoded");
my $login = "response=$challengeresponse";
if ($self->{user}) {
$login .= "&username=" . $self->{user};
}
$req->content($login);
$resp = $self->{ua}->request($req);
if (! $resp->is_success()) {
die "Cannot login to ", $self->{host}, ": ",$resp->status_line();
}
$content = $resp->content();
$self->{sid} = ($content =~ /<SID>(.*?)<\/SID>/ && $1);
print "-- Login, received SID ",$self->{sid} if $DEBUG;
return $self->{sid};
}
# Initialize the reverse name -> AIN map
sub _init_ain_map {
my $self = shift;
my $devs = $self->list();
$self->{ain_map} = {};
for my $dev (@$devs) {
$self->{ain_map}->{$self->name($dev->ain())} = $dev->ain();
}
}
# Convert "inval" to undef
sub _inval_check {
my $ret = shift;
return $ret eq "inval" ? undef : $ret;
}
=head1 LICENSE
AHA is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 2 of the License, or
(at your option) any later version.
AHA is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with AHA. If not, see <http://www.gnu.org/licenses/>.
=head1 AUTHOR
roland@cpan.org
=cut
1;
AI-ANN
view release on metacpan or search on metacpan
lib/AI/ANN.pm view on Meta::CPAN
delete $net->[$i]->{'done'};
delete $net->[$i]->{'state'};
}
my $progress = 0;
do {
$progress = 0;
foreach my $i (0..$lastneuron) {
if ($net->[$i]->{'done'}) {next}
if ($net->[$i]->{'object'}->ready($inputs, \@neurons)) {
my $potential = $net->[$i]->{'object'}->execute($inputs, \@neurons);
$self->{'rawpotentials'}->[$i] = $potential;
$potential = $self->{'maxvalue'} if $potential > $self->{'maxvalue'};
$potential = $self->{'minvalue'} if $potential < $self->{'minvalue'};
$potential = &{$self->{'afunc'}}($potential);
$neurons[$i] = $net->[$i]->{'state'} = $potential;
$net->[$i]->{'done'} = 1;
$progress++;
}
}
} while ($progress); # If the network is feed-forward, we are now finished.
my @notdone = grep {not (defined $net->[$_]->{'done'} &&
$net->[$_]->{'done'} == 1)} 0..$lastneuron;
my @neuronstemp = ();
if ($#notdone > 0) { #This is the part where we deal with loops and bad things
my $maxerror = 0;
my $loopcounter = 1;
while (1) {
foreach my $i (@notdone) { # Only bother iterating over the
# ones we couldn't solve exactly
# We don't care if it's ready now, we're just going to interate
# until it stabilizes.
if (not defined $neurons[$i] && $i <= $lastneuron) {
# Fixes warnings about uninitialized values, but we make
# sure $i is valid first.
$neurons[$i] = 0;
}
my $potential = $net->[$i]->{'object'}->execute($inputs, \@neurons);
$self->{'rawpotentials'}->[$i] = $potential;
$potential = &{$self->{'afunc'}}($potential);
$potential = $self->{'maxvalue'} if $potential > $self->{'maxvalue'};
$potential = $self->{'minvalue'} if $potential < $self->{'minvalue'};
$neuronstemp[$i] = $net->[$i]->{'state'} = $potential;
# We want to know the absolute change
if (abs($neurons[$i]-$neuronstemp[$i])>$maxerror) {
$maxerror = abs($neurons[$i]-$neuronstemp[$i]);
}
}
foreach my $i (0..$lastneuron) {
# Update $neurons, since that is what gets passed to execute
$neurons[$i] = $neuronstemp[$i];
}
if (($maxerror < 0.0001 && $loopcounter >= 5) || $loopcounter > 250) {last}
$loopcounter++;
$maxerror=0;
}
}
# Ok, hopefully all the neurons have happy values by now.
# Get the output values for neurons corresponding to outputneurons
my @output = map {$neurons[$_]} @{$self->{'outputneurons'}};
return \@output;
}
sub get_state {
my $self = shift;
my $net = $self->{'network'}; # For less typing
my @neurons = map {$net->[$_]->{'state'}} 0..$#{$self->{'network'}};
my @output = map {$net->[$_]->{'state'}} @{$self->{'outputneurons'}};
return $self->{'inputs'}, \@neurons, \@output;
}
sub get_internals {
my $self = shift;
my $net = $self->{'network'}; # For less typing
my $retval = [];
for (my $i = 0; $i <= $#{$self->{'network'}}; $i++) {
$retval->[$i] = { iamanoutput => 0,
inputs => $net->[$i]->{'object'}->inputs(),
neurons => $net->[$i]->{'object'}->neurons(),
eta_inputs => $net->[$i]->{'object'}->eta_inputs(),
eta_neurons => $net->[$i]->{'object'}->eta_neurons()
};
}
foreach my $i (@{$self->{'outputneurons'}}) {
$retval->[$i]->{'iamanoutput'} = 1;
}
return dclone($retval); # Dclone for safety.
}
sub readable {
my $self = shift;
my $retval = "This network has ". $self->{'inputcount'} ." inputs and ".
scalar(@{$self->{'network'}}) ." neurons.\n";
for (my $i = 0; $i <= $#{$self->{'network'}}; $i++) {
$retval .= "Neuron $i\n";
while (my ($k, $v) = each %{$self->{'network'}->[$i]->{'object'}->inputs()}) {
$retval .= "\tInput from input $k, weight is $v\n";
}
while (my ($k, $v) = each %{$self->{'network'}->[$i]->{'object'}->neurons()}) {
$retval .= "\tInput from neuron $k, weight is $v\n";
}
if (map {$_ == $i} $self->{'outputneurons'}) {
$retval .= "\tThis neuron is a network output\n";
}
}
return $retval;
}
sub backprop {
my $self = shift;
my $inputs = shift;
my $desired = shift;
my $actual = $self->execute($inputs);
my $net = $self->{'network'};
my $lastneuron = $#{$net};
my $deltas = [];
my $i = 0;
foreach my $neuron (@{$self->outputneurons()}) {
$deltas->[$neuron] = $desired->[$i] - $actual->[$i];
$i++;
}
my $progress = 0;
foreach my $neuron (reverse 0..$lastneuron) {
foreach my $i (reverse $neuron..$lastneuron) {
my $weight = $net->[$i]->{'object'}->neurons()->[$neuron];
if (defined $weight && $weight != 0 && $deltas->[$i]) {
$deltas->[$neuron] += $weight * $deltas->[$i];
}
}
} # Finished generating deltas
foreach my $neuron (0..$lastneuron) {
my $inputinputs = $net->[$neuron]->{'object'}->inputs();
my $neuroninputs = $net->[$neuron]->{'object'}->neurons();
my $dafunc = &{$self->{'dafunc'}}($self->{'rawpotentials'}->[$neuron]);
my $delta = $deltas->[$neuron] || 0;
foreach my $i (0..$#{$inputinputs}) {
$inputinputs->[$i] += $inputs->[$i]*$self->{'backprop_eta'}*$delta*$dafunc;
}
foreach my $i (0..$#{$neuroninputs}) {
$neuroninputs->[$i] += $net->[$i]->{'state'}*$self->{'backprop_eta'}*$delta*$dafunc;
}
$net->[$neuron]->{'object'}->inputs($inputinputs);
$net->[$neuron]->{'object'}->neurons($neuroninputs);
} # Finished changing weights.
}
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=head1 NAME
AI::ANN - an artificial neural network simulator
=head1 VERSION
version 0.008
AI-CBR
view release on metacpan or search on metacpan
lib/AI/CBR/Retrieval.pm view on Meta::CPAN
sub compute_sims {
my ($self) = @_;
# pre-allocate variables used in loop
my ($sum_sims, $sum_weights, $att_key, $att, $weight, $x, $y);
my $num_queries = int @{$self->{queries}};
foreach my $candidate (@{$self->{candidates}}) {
$candidate->{_sim} = 1;
foreach my $query (@{$self->{queries}}) {
$sum_sims = 0;
$sum_weights = 0;
ATTRIBUTES:
while(($att_key, $att) = each(%{$query})) {
next ATTRIBUTES unless $weight = $att->{weight};
$sum_weights += $weight;
$x = $att->{value};
$y = $candidate->{$att_key};
$sum_sims += $weight * (
!defined $x && !defined $y ? 1
: !defined $x || !defined $y ? 0
: &{$att->{sim}}($x, $y, $att->{param} || 0)
);
}
$candidate->{_sim} *= _nrt($num_queries, $sum_sims / $sum_weights);
}
}
my @candidates_sorted = sort { $b->{_sim} <=> $a->{_sim} } @{$self->{candidates}};
$self->{candidates} = \@candidates_sorted;
}
=head2 RETRIEVAL METHODS
Use one of these methods to get the similar cases you are interested into.
=head3 most_similar_candidate
Returns the most similar candidate.
No parameters.
=cut
sub most_similar_candidate {
my ($self) = @_;
return $self->{candidates}->[0];
}
=head3 n_most_similar_candidates
Returns the n most similar candidates.
n is the only parameter.
=cut
sub n_most_similar_candidates {
my ($self, $n) = @_;
my $last_index = min($n - 1, int @{$self->{candidates}});
return map { $self->{candidates}->[$_] } (0 .. $last_index);
}
=head3 first_confirmed_candidate
Returns the first candidate that is confirmed by a later candidate.
Confirmation is based on an attribute value
whose key is passed as parameter.
In case there is no confirmed candidate at all,
simply returns the most similar one.
=cut
sub first_confirmed_candidate {
my ($self, $key) = @_;
my %candidate_with;
my $value;
foreach my $candidate (@{$self->{candidates}}) {
$value = $candidate->{$key};
if($candidate_with{$value}) {
return $candidate_with{$value};
} else {
$candidate_with{$value} = $candidate;
}
}
# no confirmed candidate found, fall back
return $self->most_similar_candidate();
}
# internal method for n-th root
sub _nrt {
return $_[1] ** (1 / $_[0]);
}
=head1 SEE ALSO
See L<AI::CBR> for an overview of the framework.
=head1 AUTHOR
Darko Obradovic, C<< <dobradovic at gmx.de> >>
=head1 BUGS
Please report any bugs or feature requests to C<bug-ai-cbr at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=AI-CBR>. 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::CBR::Retrieval
AI-Calibrate
view release on metacpan or search on metacpan
lib/AI/Calibrate.pm view on Meta::CPAN
package AI::Calibrate;
use 5.008008;
use strict;
use warnings;
use vars qw($VERSION);
$VERSION = "1.5";
require Exporter;
our @ISA = qw(Exporter);
# 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( );
use constant DEBUG => 0;
# Structure slot names
use constant SCORE => 0;
use constant PROB => 1;
=head1 NAME
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
calculations, but first they need to be I<calibrated>. Naive Bayes, for
example, is a very useful classifier, but the scores it produces are usually
"bunched" around 0 and 1, making these scores poor probability estimates.
Support vector machines have a similar problem. Both classifier types should
be calibrated before their scores are used as probability estimates.
This module calibrates classifier scores using a method called the Pool
Adjacent Violators (PAV) algorithm. After you train a classifier, you take a
(usually separate) set of test instances and run them through the classifier,
collecting the scores assigned to each. You then supply this set of instances
to the calibrate function defined here, and it will return a set of ranges
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.
=cut
=head1 FUNCTIONS
=over 4
=item B<calibrate>
This is the main calibration function. The calling form is:
my $calibrated = calibrate( $data, $sorted);
$data looks like: C<[ [score, class], [score, class], [score, class]...]>
Each score is a number. Each class is either 0 (negative class) or 1
(positive class).
$sorted is boolean (0 by default) indicating whether the data are already
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";
lib/AI/Calibrate.pm view on Meta::CPAN
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>
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
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
cases ordered by the scores assigned by the classifier, it first assigns a
probability of one to each positive instance and a probability of zero to each
negative instance, and puts each instance in its own group. It then looks, at
each iteration, for adjacent violators: adjacent groups whose probabilities
locally increase rather than decrease. When it finds such groups, it pools
them and replaces their probability estimates with the average of the group's
values. It continues this process of averaging and replacement until the
entire sequence is monotonically decreasing. The result is a sequence of
instances, each of which has a score and an associated probability estimate,
which can then be used to map scores into probability estimates.
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
known, and in a later version of this module I'll probably implement it.
=head1 SEE ALSO
The AI::NaiveBayes1 perl module.
My paper "PAV and the ROC Convex Hull" has a good discussion of the PAV
algorithm, including examples:
L<http://home.comcast.net/~tom.fawcett/public_html/papers/PAV-ROCCH-dist.pdf>
If you want to read more about the general issue of classifier calibration,
here are some good papers, which are freely available on the web:
I<"Transforming classifier scores into accurate multiclass probability estimates">
by Bianca Zadrozny and Charles Elkan
I<"Predicting Good Probabilities With Supervised Learning">
by A. Niculescu-Mizil and R. Caruana
=head1 AUTHOR
Tom Fawcett, E<lt>tom.fawcett@gmail.comE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2008-2012 by Tom Fawcett
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.8 or,
at your option, any later version of Perl 5 you may have available.
=cut
1;
AI-Categorizer
view release on metacpan or search on metacpan
lib/AI/Categorizer/Collection.pm view on Meta::CPAN
package AI::Categorizer::Collection;
use strict;
use Params::Validate qw(:types);
use Class::Container;
use base qw(Class::Container);
__PACKAGE__->valid_params
(
verbose => {type => SCALAR, default => 0},
stopword_file => { type => SCALAR, optional => 1 },
category_hash => { type => HASHREF, default => {} },
category_file => { type => SCALAR, optional => 1 },
);
__PACKAGE__->contained_objects
(
document => { class => 'AI::Categorizer::Document::Text',
delayed => 1 },
);
sub new {
my ($class, %args) = @_;
# Optimize so every document doesn't have to convert the stopword list to a hash
if ($args{stopwords} and UNIVERSAL::isa($args{stopwords}, 'ARRAY')) {
$args{stopwords} = { map {+$_ => 1} @{ $args{stopwords} } };
}
my $self = $class->SUPER::new(%args);
if ($self->{category_file}) {
local *FH;
open FH, $self->{category_file} or die "Can't open $self->{category_file}: $!";
while (<FH>) {
my ($doc, @cats) = split;
$self->{category_hash}{$doc} = \@cats;
}
close FH;
}
if (exists $self->{stopword_file}) {
my %stopwords;
local *FH;
open FH, "< $self->{stopword_file}" or die "$self->{stopword_file}: $!";
while (<FH>) {
chomp;
$stopwords{$_} = 1;
}
close FH;
$self->delayed_object_params('document', stopwords => \%stopwords);
}
return $self;
}
# This should usually be replaced in subclasses with a faster version that doesn't
# need to create actual documents each time through
sub count_documents {
my $self = shift;
return $self->{document_count} if exists $self->{document_count};
$self->rewind;
my $count = 0;
$count++ while $self->next;
$self->rewind;
return $self->{document_count} = $count;
}
# Abstract methods
sub next;
sub rewind;
1;
__END__
=head1 NAME
AI::Categorizer::Collection - Access stored documents
=head1 SYNOPSIS
my $c = new AI::Categorizer::Collection::Files
(path => '/tmp/docs/training',
category_file => '/tmp/docs/cats.txt');
print "Total number of docs: ", $c->count_documents, "\n";
while (my $document = $c->next) {
...
}
$c->rewind; # For further operations
=head1 DESCRIPTION
This abstract class implements an iterator for accessing documents in
their natively stored format. You cannot directly create an instance
of the Collection class, because it is abstract - see the
documentation for the C<Files>, C<SingleFile>, or C<InMemory>
subclasses for a concrete interface.
=head1 METHODS
=over 4
=item new()
Creates a new Collection object and returns it. Accepts the following
parameters:
=over 4
=item category_hash
Indicates a reference to a hash which maps document names to category
names. The keys of the hash are the document names, each value should
be a reference to an array containing the names of the categories to
which each document belongs.
=item category_file
Indicates a file which should be read in order to create the
C<category_hash>. Each line of the file should list a document's
name, followed by a list of category names, all separated by
whitespace.
=item stopword_file
Specifies a file containing a list of "stopwords", which are words
that should automatically be disregarded when scanning/reading
documents. The file should contain one word per line. The file will
be parsed and then fed as the C<stopwords> parameter to the
Document C<new()> method.
=item verbose
If true, some status/debugging information will be printed to
C<STDOUT> during operation.
=item document_class
The class indicating what type of Document object should be created.
This generally specifies the format that the documents are stored in.
The default is C<AI::Categorizer::Document::Text>.
=back
=item next()
Returns the next Document object in the Collection.
=item rewind()
Resets the iterator for further calls to C<next()>.
=item count_documents()
Returns the total number of documents in the Collection. Note that
this usually resets the iterator. This is because it may not be
possible to resume iterating where we left off.
=back
=head1 AUTHOR
Ken Williams, ken@mathforum.org
=head1 COPYRIGHT
Copyright 2002-2003 Ken Williams. All rights reserved.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 SEE ALSO
AI-Classifier
view release on metacpan or search on metacpan
use strict;
use Test::More tests => 6;
use AI::Classifier::Text;
use AI::NaiveBayes::Learner;
use File::Spec;
ok(1); # If we made it this far, we're loaded.
my $lr = AI::NaiveBayes::Learner->new(purge => 0);
$lr->add_example(attributes => _hash(qw(sheep very valuable farming)),
labels => ['farming'] );
is $lr->examples, 1;
my $nb = $lr->classifier;
ok $nb;
my $tp = AI::Classifier::Text->new( classifier => $nb );
# Save
my $file = File::Spec->catfile('t', 'model.dat');
$tp->store($file);
is -e $file, 1;
# Restore
$tp = AI::Classifier::Text->load($file);
ok $tp;
isa_ok( $tp, 'AI::Classifier::Text' );
################################################################
sub _hash { +{ map {$_,1} @_ } }
AI-ConfusionMatrix
view release on metacpan or search on metacpan
lib/AI/ConfusionMatrix.pm view on Meta::CPAN
package AI::ConfusionMatrix;
$AI::ConfusionMatrix::VERSION = '0.010';
use strict;
use warnings;
use Carp;
use Exporter 'import';
our @EXPORT= qw (getConfusionMatrix makeConfusionMatrix);
use strict;
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],
AI-DecisionTree
view release on metacpan or search on metacpan
eg/example.pl view on Meta::CPAN
#!/usr/bin/perl
use AI::DecisionTree;
my @attributes = qw(outlook temperature humidity wind play_tennis);
my @cases = qw(
sunny hot high weak no
sunny hot high strong no
overcast hot high weak yes
rain mild high weak yes
rain cool normal weak yes
rain cool normal strong no
overcast cool normal strong yes
sunny mild high weak no
sunny cool normal weak yes
rain mild normal weak yes
sunny mild normal strong yes
overcast mild high strong yes
overcast hot normal weak yes
rain mild high strong no
);
my $outcome = pop @attributes;
my $dtree = new AI::DecisionTree;
while (@cases) {
my @values = splice @cases, 0, 1 + scalar(@attributes);
my $result = pop @values;
my %pairs;
@pairs{@attributes} = @values;
$dtree->add_instance(attributes => \%pairs,
result => $result,
);
}
$dtree->train;
my $result;
# Try one of the training examples
$result = $dtree->get_result( attributes => {
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-Evolve-Befunge
view release on metacpan or search on metacpan
lib/AI/Evolve/Befunge/Blueprint.pm view on Meta::CPAN
use AI::Evolve::Befunge::Util;
# 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.
Other arguments are optional, and will be determined automatically if
not specified:
fitness - assign it a fitness score, default is 0.
id - assign it an id, default is to call new_popid() (see below).
host - the hostname, default is $ENV{HOST}.
=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) {
$$self{size} = int((length($$self{code})+1)**(1/$$self{dims}));
} else {
$$self{size} = length($$self{code});
}
croak("code has a non-orthogonal size!")
unless ($$self{size}**$$self{dims}) == length($$self{code});
$$self{size} = Language::Befunge::Vector->new(map { $$self{size} } (1..$$self{dims}));
$$self{fitness} = $args{fitness} // 0;
$$self{id} = $args{id} if exists $args{id};
$$self{host} = $args{host} if exists $args{host};
$$self{id} = $self->new_popid() unless defined $$self{id};
$$self{host} = $ENV{HOST} unless defined $$self{host};
$$self{name} = "$$self{host}-$$self{id}";
return $self;
}
=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
sub new_from_string {
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,
);
}
return undef;
}
=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 {
my ($package, $file) = @_;
return $package->new_from_string($file->getline);
}
=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
( run in 1.342 second using v1.01-cache-2.11-cpan-3b35f9de6a3 )