AI-ExpertSystem-Advanced
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
use Cwd ();
use File::Find ();
use File::Path ();
use FindBin;
sub autoload {
my $self = shift;
my $who = $self->_caller;
my $cwd = Cwd::cwd();
my $sym = "${who}::AUTOLOAD";
$sym->{$cwd} = sub {
my $pwd = Cwd::cwd();
if ( my $code = $sym->{$pwd} ) {
# Delegate back to parent dirs
goto &$code unless $cwd eq $pwd;
}
$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
my $method = $1;
if ( uc($method) eq $method ) {
# Do nothing
return;
inc/Module/Install.pm view on Meta::CPAN
# Dispatch to the root M:I class
return $self->$method(@_);
}
# Dispatch to the appropriate plugin
unshift @_, ( $self, $1 );
goto &{$self->can('call')};
};
}
sub import {
my $class = shift;
my $self = $class->new(@_);
my $who = $self->_caller;
unless ( -f $self->{file} ) {
require "$self->{path}/$self->{dispatch}.pm";
File::Path::mkpath("$self->{prefix}/$self->{author}");
$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
$self->{admin}->init;
@_ = ($class, _self => $self);
inc/Module/Install.pm view on Meta::CPAN
# Unregister loader and worker packages so subdirs can use them again
delete $INC{"$self->{file}"};
delete $INC{"$self->{path}.pm"};
# Save to the singleton
$MAIN = $self;
return 1;
}
sub preload {
my $self = shift;
unless ( $self->{extensions} ) {
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
);
}
my @exts = @{$self->{extensions}};
unless ( @exts ) {
@exts = $self->{admin}->load_all_extensions;
inc/Module/Install.pm view on Meta::CPAN
while (my ($method, $glob) = each %{ref($obj) . '::'}) {
next unless $obj->can($method);
next if $method =~ /^_/;
next if $method eq uc($method);
$seen{$method}++;
}
}
my $who = $self->_caller;
foreach my $name ( sort keys %seen ) {
*{"${who}::$name"} = sub {
${"${who}::AUTOLOAD"} = "${who}::$name";
goto &{"${who}::AUTOLOAD"};
};
}
}
sub new {
my ($class, %args) = @_;
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
delete $args{prefix};
}
return $args{_self} if $args{_self};
inc/Module/Install.pm view on Meta::CPAN
unless ( $args{path} ) {
$args{path} = $args{name};
$args{path} =~ s!::!/!g;
}
$args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
$args{wrote} = 0;
bless( \%args, $class );
}
sub call {
my ($self, $method) = @_;
my $obj = $self->load($method) or return;
splice(@_, 0, 2, $obj);
goto &{$obj->can($method)};
}
sub load {
my ($self, $method) = @_;
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
) unless $self->{extensions};
foreach my $obj (@{$self->{extensions}}) {
return $obj if $obj->can($method);
}
inc/Module/Install.pm view on Meta::CPAN
The '$method' method does not exist in the '$self->{prefix}' path!
Please remove the '$self->{prefix}' directory and run $0 again to load it.
END_DIE
my $obj = $admin->load($method, 1);
push @{$self->{extensions}}, $obj;
$obj;
}
sub load_extensions {
my ($self, $path, $top) = @_;
unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
unshift @INC, $self->{prefix};
}
foreach my $rv ( $self->find_extensions($path) ) {
my ($file, $pkg) = @{$rv};
next if $self->{pathnames}{$pkg};
inc/Module/Install.pm view on Meta::CPAN
warn $@ if $@;
next;
}
$self->{pathnames}{$pkg} = delete $INC{$file};
push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
}
$self->{extensions} ||= [];
}
sub find_extensions {
my ($self, $path) = @_;
my @found;
File::Find::find( sub {
my $file = $File::Find::name;
return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
my $subpath = $1;
return if lc($subpath) eq lc($self->{dispatch});
$file = "$self->{path}/$subpath.pm";
my $pkg = "$self->{name}::$subpath";
$pkg =~ s!/!::!g;
# If we have a mixed-case package name, assume case has been preserved
inc/Module/Install.pm view on Meta::CPAN
@found;
}
#####################################################################
# Common Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
sub _read {
local *FH;
if ( $] >= 5.006 ) {
open( FH, '<', $_[0] ) or die "open($_[0]): $!";
} else {
open( FH, "< $_[0]" ) or die "open($_[0]): $!";
}
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $string;
}
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;
}
sub _write {
local *FH;
if ( $] >= 5.006 ) {
open( FH, '>', $_[0] ) or die "open($_[0]): $!";
} else {
open( FH, "> $_[0]" ) or die "open($_[0]): $!";
}
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
close FH or die "close($_[0]): $!";
}
# _version is for processing module versions (eg, 1.03_05) not
# 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($_[0]) <=> _version($_[1]);
}
# Cloned from Params::Util::_CLASS
sub _CLASS ($) {
(
defined $_[0]
and
! ref $_[0]
and
$_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
) ? $_[0] : undef;
}
1;
inc/Module/Install/Base.pm view on Meta::CPAN
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
$VERSION = '0.91';
}
# Suspend handler for "redefined" warnings
BEGIN {
my $w = $SIG{__WARN__};
$SIG{__WARN__} = sub { $w };
}
#line 42
sub new {
my $class = shift;
unless ( defined &{"${class}::call"} ) {
*{"${class}::call"} = sub { shift->_top->call(@_) };
}
unless ( defined &{"${class}::load"} ) {
*{"${class}::load"} = sub { shift->_top->load(@_) };
}
bless { @_ }, $class;
}
#line 61
sub AUTOLOAD {
local $@;
my $func = eval { shift->_top->autoload } or return;
goto &$func;
}
#line 75
sub _top {
$_[0]->{_top};
}
#line 90
sub admin {
$_[0]->_top->{admin}
or
Module::Install::Base::FakeAdmin->new;
}
#line 106
sub is_admin {
$_[0]->admin->VERSION;
}
sub DESTROY {}
package Module::Install::Base::FakeAdmin;
my $fake;
sub new {
$fake ||= bless(\@_, $_[0]);
}
sub AUTOLOAD {}
sub DESTROY {}
# Restore warning handler
BEGIN {
$SIG{__WARN__} = $SIG{__WARN__}->();
}
1;
#line 154
inc/Module/Install/Can.pm view on Meta::CPAN
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '0.91';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
# check if we can load some module
### Upgrade this to not have to load the module if possible
sub can_use {
my ($self, $mod, $ver) = @_;
$mod =~ s{::|\\}{/}g;
$mod .= '.pm' unless $mod =~ /\.pm$/i;
my $pkg = $mod;
$pkg =~ s{/}{::}g;
$pkg =~ s{\.pm$}{}i;
local $@;
eval { require $mod; $pkg->VERSION($ver || 0); 1 };
}
# check if we can run some command
sub can_run {
my ($self, $cmd) = @_;
my $_cmd = $cmd;
return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
next if $dir eq '';
my $abs = File::Spec->catfile($dir, $_[1]);
return $abs if (-x $abs or $abs = MM->maybe_command($abs));
}
return;
}
# can we locate a (the) C compiler
sub can_cc {
my $self = shift;
my @chunks = split(/ /, $Config::Config{cc}) or return;
# $Config{cc} may contain args; try to find out the program part
while (@chunks) {
return $self->can_run("@chunks") || (pop(@chunks), next);
}
return;
}
# Fix Cygwin bug on maybe_command();
if ( $^O eq 'cygwin' ) {
require ExtUtils::MM_Cygwin;
require ExtUtils::MM_Win32;
if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) {
*ExtUtils::MM_Cygwin::maybe_command = sub {
my ($self, $file) = @_;
if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) {
ExtUtils::MM_Win32->maybe_command($file);
} else {
ExtUtils::MM_Unix->maybe_command($file);
}
}
}
}
inc/Module/Install/Fetch.pm view on Meta::CPAN
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '0.91';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
sub get_file {
my ($self, %args) = @_;
my ($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
$args{url} = $args{ftp_url}
or (warn("LWP support unavailable!\n"), return);
($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
}
inc/Module/Install/Makefile.pm view on Meta::CPAN
use ExtUtils::MakeMaker ();
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '0.91';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
sub Makefile { $_[0] }
my %seen = ();
sub prompt {
shift;
# Infinite loop protection
my @c = caller();
if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
}
# In automated testing, always use defaults
if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) {
local $ENV{PERL_MM_USE_DEFAULT} = 1;
goto &ExtUtils::MakeMaker::prompt;
} else {
goto &ExtUtils::MakeMaker::prompt;
}
}
sub makemaker_args {
my $self = shift;
my $args = ( $self->{makemaker_args} ||= {} );
%$args = ( %$args, @_ );
return $args;
}
# For mm args that take multiple space-seperated args,
# append an argument to the current list.
sub makemaker_append {
my $self = sShift;
my $name = shift;
my $args = $self->makemaker_args;
$args->{name} = defined $args->{$name}
? join( ' ', $args->{name}, @_ )
: join( ' ', @_ );
}
sub build_subdirs {
my $self = shift;
my $subdirs = $self->makemaker_args->{DIR} ||= [];
for my $subdir (@_) {
push @$subdirs, $subdir;
}
}
sub clean_files {
my $self = shift;
my $clean = $self->makemaker_args->{clean} ||= {};
%$clean = (
%$clean,
FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_),
);
}
sub realclean_files {
my $self = shift;
my $realclean = $self->makemaker_args->{realclean} ||= {};
%$realclean = (
%$realclean,
FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_),
);
}
sub libs {
my $self = shift;
my $libs = ref $_[0] ? shift : [ shift ];
$self->makemaker_args( LIBS => $libs );
}
sub inc {
my $self = shift;
$self->makemaker_args( INC => shift );
}
my %test_dir = ();
sub _wanted_t {
/\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1;
}
sub tests_recursive {
my $self = shift;
if ( $self->tests ) {
die "tests_recursive will not work if tests are already defined";
}
my $dir = shift || 't';
unless ( -d $dir ) {
die "tests_recursive dir '$dir' does not exist";
}
%test_dir = ();
require File::Find;
File::Find::find( \&_wanted_t, $dir );
$self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
}
sub write {
my $self = shift;
die "&Makefile->write() takes no arguments\n" if @_;
# Check the current Perl version
my $perl_version = $self->perl_version;
if ( $perl_version ) {
eval "use $perl_version; 1"
or die "ERROR: perl: Version $] is installed, "
. "but we need version >= $perl_version";
}
inc/Module/Install/Makefile.pm view on Meta::CPAN
if (my $preop = $self->admin->preop($user_preop)) {
foreach my $key ( keys %$preop ) {
$args{dist}->{$key} = $preop->{$key};
}
}
my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
$self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile');
}
sub fix_up_makefile {
my $self = shift;
my $makefile_name = shift;
my $top_class = ref($self->_top) || '';
my $top_version = $self->_top->VERSION || '';
my $preamble = $self->preamble
? "# Preamble by $top_class $top_version\n"
. $self->preamble
: '';
my $postamble = "# Postamble by $top_class $top_version\n"
inc/Module/Install/Makefile.pm view on Meta::CPAN
# XXX - This is currently unused; not sure if it breaks other MM-users
# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
print MAKEFILE "$preamble$makefile$postamble" or die $!;
close MAKEFILE or die $!;
1;
}
sub preamble {
my ($self, $text) = @_;
$self->{preamble} = $text . $self->{preamble} if defined $text;
$self->{preamble};
}
sub postamble {
my ($self, $text) = @_;
$self->{postamble} ||= $self->admin->postamble;
$self->{postamble} .= $text if defined $text;
$self->{postamble}
}
1;
__END__
inc/Module/Install/Metadata.pm view on Meta::CPAN
my @resource_keys = qw{
homepage
bugtracker
repository
};
my @array_keys = qw{
keywords
};
sub Meta { shift }
sub Meta_BooleanKeys { @boolean_keys }
sub Meta_ScalarKeys { @scalar_keys }
sub Meta_TupleKeys { @tuple_keys }
sub Meta_ResourceKeys { @resource_keys }
sub Meta_ArrayKeys { @array_keys }
foreach my $key ( @boolean_keys ) {
*$key = sub {
my $self = shift;
if ( defined wantarray and not @_ ) {
return $self->{values}->{$key};
}
$self->{values}->{$key} = ( @_ ? $_[0] : 1 );
return $self;
};
}
foreach my $key ( @scalar_keys ) {
*$key = sub {
my $self = shift;
return $self->{values}->{$key} if defined wantarray and !@_;
$self->{values}->{$key} = shift;
return $self;
};
}
foreach my $key ( @array_keys ) {
*$key = sub {
my $self = shift;
return $self->{values}->{$key} if defined wantarray and !@_;
$self->{values}->{$key} ||= [];
push @{$self->{values}->{$key}}, @_;
return $self;
};
}
foreach my $key ( @resource_keys ) {
*$key = sub {
my $self = shift;
unless ( @_ ) {
return () unless $self->{values}->{resources};
return map { $_->[1] }
grep { $_->[0] eq $key }
@{ $self->{values}->{resources} };
}
return $self->{values}->{resources}->{$key} unless @_;
my $uri = shift or die(
"Did not provide a value to $key()"
);
$self->resources( $key => $uri );
return 1;
};
}
foreach my $key ( grep { $_ ne "resources" } @tuple_keys) {
*$key = sub {
my $self = shift;
return $self->{values}->{$key} unless @_;
my @added;
while ( @_ ) {
my $module = shift or last;
my $version = shift || 0;
push @added, [ $module, $version ];
}
push @{ $self->{values}->{$key} }, @added;
return map {@$_} @added;
inc/Module/Install/Metadata.pm view on Meta::CPAN
}
# Resource handling
my %lc_resource = map { $_ => 1 } qw{
homepage
license
bugtracker
repository
};
sub resources {
my $self = shift;
while ( @_ ) {
my $name = shift or last;
my $value = shift or next;
if ( $name eq lc $name and ! $lc_resource{$name} ) {
die("Unsupported reserved lowercase resource '$name'");
}
$self->{values}->{resources} ||= [];
push @{ $self->{values}->{resources} }, [ $name, $value ];
}
$self->{values}->{resources};
}
# Aliases for build_requires that will have alternative
# meanings in some future version of META.yml.
sub test_requires { shift->build_requires(@_) }
sub install_requires { shift->build_requires(@_) }
# Aliases for installdirs options
sub install_as_core { $_[0]->installdirs('perl') }
sub install_as_cpan { $_[0]->installdirs('site') }
sub install_as_site { $_[0]->installdirs('site') }
sub install_as_vendor { $_[0]->installdirs('vendor') }
sub dynamic_config {
my $self = shift;
unless ( @_ ) {
warn "You MUST provide an explicit true/false value to dynamic_config\n";
return $self;
}
$self->{values}->{dynamic_config} = $_[0] ? 1 : 0;
return 1;
}
sub perl_version {
my $self = shift;
return $self->{values}->{perl_version} unless @_;
my $version = shift or die(
"Did not provide a value to perl_version()"
);
# Normalize the version
$version = $self->_perl_version($version);
# We don't support the reall old versions
inc/Module/Install/Metadata.pm view on Meta::CPAN
gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
mit => 'http://opensource.org/licenses/mit-license.php',
mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
open_source => undef,
unrestricted => undef,
restrictive => undef,
unknown => undef,
);
sub license {
my $self = shift;
return $self->{values}->{license} unless @_;
my $license = shift or die(
'Did not provide a value to license()'
);
$self->{values}->{license} = $license;
# Automatically fill in license URLs
if ( $license_urls{$license} ) {
$self->resources( license => $license_urls{$license} );
}
return 1;
}
sub all_from {
my ( $self, $file ) = @_;
unless ( defined($file) ) {
my $name = $self->name or die(
"all_from called with no args without setting name() first"
);
$file = join('/', 'lib', split(/-/, $name)) . '.pm';
$file =~ s{.*/}{} unless -e $file;
unless ( -e $file ) {
die("all_from cannot find $file from $name");
inc/Module/Install/Metadata.pm view on Meta::CPAN
$self->name_from($file) unless $self->name;
$self->version_from($file) unless $self->version;
$self->perl_version_from($file) unless $self->perl_version;
$self->author_from($pod) unless $self->author;
$self->license_from($pod) unless $self->license;
$self->abstract_from($pod) unless $self->abstract;
return 1;
}
sub provides {
my $self = shift;
my $provides = ( $self->{values}->{provides} ||= {} );
%$provides = (%$provides, @_) if @_;
return $provides;
}
sub auto_provides {
my $self = shift;
return $self unless $self->is_admin;
unless (-e 'MANIFEST') {
warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
return $self;
}
# Avoid spurious warnings as we are not checking manifest here.
local $SIG{__WARN__} = sub {1};
require ExtUtils::Manifest;
local *ExtUtils::Manifest::manicheck = sub { return };
require Module::Build;
my $build = Module::Build->new(
dist_name => $self->name,
dist_version => $self->version,
license => $self->license,
);
$self->provides( %{ $build->find_dist_packages || {} } );
}
sub feature {
my $self = shift;
my $name = shift;
my $features = ( $self->{values}->{features} ||= [] );
my $mods;
if ( @_ == 1 and ref( $_[0] ) ) {
# The user used ->feature like ->features by passing in the second
# argument as a reference. Accomodate for that.
$mods = $_[0];
} else {
inc/Module/Install/Metadata.pm view on Meta::CPAN
$name => [
map {
ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
} @$mods
]
);
return @$features;
}
sub features {
my $self = shift;
while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
$self->feature( $name, @$mods );
}
return $self->{values}->{features}
? @{ $self->{values}->{features} }
: ();
}
sub no_index {
my $self = shift;
my $type = shift;
push @{ $self->{values}->{no_index}->{$type} }, @_ if $type;
return $self->{values}->{no_index};
}
sub read {
my $self = shift;
$self->include_deps( 'YAML::Tiny', 0 );
require YAML::Tiny;
my $data = YAML::Tiny::LoadFile('META.yml');
# Call methods explicitly in case user has already set some values.
while ( my ( $key, $value ) = each %$data ) {
next unless $self->can($key);
if ( ref $value eq 'HASH' ) {
while ( my ( $module, $version ) = each %$value ) {
$self->can($key)->($self, $module => $version );
}
} else {
$self->can($key)->($self, $value);
}
}
return $self;
}
sub write {
my $self = shift;
return $self unless $self->is_admin;
$self->admin->write_meta;
return $self;
}
sub version_from {
require ExtUtils::MM_Unix;
my ( $self, $file ) = @_;
$self->version( ExtUtils::MM_Unix->parse_version($file) );
}
sub abstract_from {
require ExtUtils::MM_Unix;
my ( $self, $file ) = @_;
$self->abstract(
bless(
{ DISTNAME => $self->name },
'ExtUtils::MM_Unix'
)->parse_abstract($file)
);
}
# Add both distribution and module name
sub name_from {
my ($self, $file) = @_;
if (
Module::Install::_read($file) =~ m/
^ \s*
package \s*
([\w:]+)
\s* ;
/ixms
) {
my ($name, $module_name) = ($1, $1);
$name =~ s{::}{-}g;
$self->name($name);
unless ( $self->module_name ) {
$self->module_name($module_name);
}
} else {
die("Cannot determine name from $file\n");
}
}
sub perl_version_from {
my $self = shift;
if (
Module::Install::_read($_[0]) =~ m/
^
(?:use|require) \s*
v?
([\d_\.]+)
\s* ;
/ixms
) {
my $perl_version = $1;
$perl_version =~ s{_}{}g;
$self->perl_version($perl_version);
} else {
warn "Cannot determine perl version info from $_[0]\n";
return;
}
}
sub author_from {
my $self = shift;
my $content = Module::Install::_read($_[0]);
if ($content =~ m/
=head \d \s+ (?:authors?)\b \s*
([^\n]*)
|
=head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
.*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
([^\n]*)
/ixms) {
my $author = $1 || $2;
$author =~ s{E<lt>}{<}g;
$author =~ s{E<gt>}{>}g;
$self->author($author);
} else {
warn "Cannot determine author info from $_[0]\n";
}
}
sub license_from {
my $self = shift;
if (
Module::Install::_read($_[0]) =~ m/
(
=head \d \s+
(?:licen[cs]e|licensing|copyright|legal)\b
.*?
)
(=head\\d.*|=cut.*|)
\z
inc/Module/Install/Metadata.pm view on Meta::CPAN
$self->license($license);
return 1;
}
}
}
warn "Cannot determine license info from $_[0]\n";
return 'unknown';
}
sub _extract_bugtracker {
my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g;
my %links;
@links{@links}=();
@links=keys %links;
return @links;
}
sub bugtracker_from {
my $self = shift;
my $content = Module::Install::_read($_[0]);
my @links = _extract_bugtracker($content);
unless ( @links ) {
warn "Cannot determine bugtracker info from $_[0]\n";
return 0;
}
if ( @links > 1 ) {
warn "Found more than on rt.cpan.org link in $_[0]\n";
return 0;
}
# Set the bugtracker
bugtracker( $links[0] );
return 1;
}
sub requires_from {
my $self = shift;
my $content = Module::Install::_readperl($_[0]);
my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
while ( @requires ) {
my $module = shift @requires;
my $version = shift @requires;
$self->requires( $module => $version );
}
}
sub test_requires_from {
my $self = shift;
my $content = Module::Install::_readperl($_[0]);
my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
while ( @requires ) {
my $module = shift @requires;
my $version = shift @requires;
$self->test_requires( $module => $version );
}
}
# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
# numbers (eg, 5.006001 or 5.008009).
# Also, convert double-part versions (eg, 5.8)
sub _perl_version {
my $v = $_[-1];
$v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
$v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
$v =~ s/(\.\d\d\d)000$/$1/;
$v =~ s/_.+$//;
if ( ref($v) ) {
# Numify
$v = $v + 0;
}
return $v;
}
######################################################################
# MYMETA Support
sub WriteMyMeta {
die "WriteMyMeta has been deprecated";
}
sub write_mymeta_yaml {
my $self = shift;
# We need YAML::Tiny to write the MYMETA.yml file
unless ( eval { require YAML::Tiny; 1; } ) {
return 1;
}
# Generate the data
my $meta = $self->_write_mymeta_data or return 1;
# Save as the MYMETA.yml file
print "Writing MYMETA.yml\n";
YAML::Tiny::DumpFile('MYMETA.yml', $meta);
}
sub write_mymeta_json {
my $self = shift;
# We need JSON to write the MYMETA.json file
unless ( eval { require JSON; 1; } ) {
return 1;
}
# Generate the data
my $meta = $self->_write_mymeta_data or return 1;
# Save as the MYMETA.yml file
print "Writing MYMETA.json\n";
Module::Install::_write(
'MYMETA.json',
JSON->new->pretty(1)->canonical->encode($meta),
);
}
sub _write_mymeta_data {
my $self = shift;
# If there's no existing META.yml there is nothing we can do
return undef unless -f 'META.yml';
# We need Parse::CPAN::Meta to load the file
unless ( eval { require Parse::CPAN::Meta; 1; } ) {
return undef;
}
inc/Module/Install/Win32.pm view on Meta::CPAN
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '0.91';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
# determine if the user needs nmake, and download it if needed
sub check_nmake {
my $self = shift;
$self->load('can_run');
$self->load('get_file');
require Config;
return unless (
$^O eq 'MSWin32' and
$Config::Config{make} and
$Config::Config{make} =~ /^nmake\b/i and
! $self->can_run('nmake')
inc/Module/Install/WriteAll.pm view on Meta::CPAN
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '0.91';;
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
sub WriteAll {
my $self = shift;
my %args = (
meta => 1,
sign => 0,
inline => 0,
check_nmake => 1,
@_,
);
$self->sign(1) if $args{sign};
lib/AI/ExpertSystem/Advanced.pm view on Meta::CPAN
initial_facts => ['I', ['F', '-'], ['G', '+']);
As you can see if you want to provide the sign of a fact, just I<encapsulate>
it in an array, the first item should be the fact and the second one the
sign.
=cut
has 'initial_facts' => (
is => 'rw',
isa => 'ArrayRef[Str]',
default => sub { return []; });
=item B<initial_facts_dict>
This dictionary (see L<AI::ExpertSystem::Advanced::Dictionary> has the sasme
data of L<initial_facts> but with the additional feature(s) of proviing
iterators and a quick way to find elements.
=cut
has 'initial_facts_dict' => (
is => 'ro',
lib/AI/ExpertSystem/Advanced.pm view on Meta::CPAN
From our example of symptoms and diseases lets imagine we have the hypothesis
that a patient has flu, we don't know the symptoms it has, we want the
expert system to keep asking us for them to make sure that our hypothesis
is correct (or incorrect in case there's not enough information).
=cut
has 'goals_to_check' => (
is => 'rw',
isa => 'ArrayRef[Str]',
default => sub { return []; });
=item B<goals_to_check_dict>
Very similar to L<goals_to_check> (and indeed of L<initial_facts_dict>). We
want to make the job easier.
It will be a dictionary made of the data of L<goals_to_check>.
=cut
has 'goals_to_check_dict' => (
lib/AI/ExpertSystem/Advanced.pm view on Meta::CPAN
L<inference_facts> with a negative sign, otherwise a positive sign will be
used.
=item *
Will add the rule to the L<shot_rules> hash.
=back
=cut
sub shoot {
my ($self, $rule, $algorithm) = @_;
$self->{'shot_rules'}->{$rule} = gettimeofday;
my $rule_causes = $self->get_causes_by_rule($rule);
my $rule_goals = $self->get_goals_by_rule($rule);
my $any_negation = 0;
$rule_causes->populate_iterable_array();
while(my $caused_fact = $rule_causes->iterate) {
# Now, from the current rule fact, any of the facts were marked
lib/AI/ExpertSystem/Advanced.pm view on Meta::CPAN
my $sign = ($any_negation) ? FACT_SIGN_NEGATIVE : FACT_SIGN_POSITIVE;
# Copy the goal(s) of this rule to our "initial facts"
$self->copy_to_inference_facts($rule_goals, $sign, $algorithm, $rule);
}
=head2 B<is_rule_shot($rule)>
Verifies if the given C<$rule> has been shot.
=cut
sub is_rule_shot {
my ($self, $rule) = @_;
return defined $self->{'shot_rules'}->{$rule};
}
=head2 B<get_goals_by_rule($rule)>
Will ask the L<knowledge_db> for the goals of the given C<$rule>.
A L<AI::ExpertSystem::Advanced::Dictionary> will be returned.
=cut
sub get_goals_by_rule {
my ($self, $rule) = @_;
return $self->{'knowledge_db'}->rule_goals($rule);
}
=head2 B<get_causes_by_rule($rule)>
Will ask the L<knowledge_db> for the causes of the given C<$rule>.
A L<AI::ExpertSystem::Advanced::Dictionary> will be returned.
=cut
sub get_causes_by_rule {
my ($self, $rule) = @_;
return $self->{'knowledge_db'}->rule_causes($rule);
}
=head2 B<is_fact_negative($dict_name, $fact)>
Will check if the given C<$fact> of the given dictionary (C<$dict_name>) is
negative.
=cut
sub is_fact_negative {
my ($self, $dict_name, $fact) = @_;
my $sign = $self->{$dict_name}->get_value($fact, 'sign');
if (!defined $sign) {
confess "This fact ($fact) does not exists!";
}
return $sign eq FACT_SIGN_NEGATIVE;
}
=head2 B<copy_to_inference_facts($facts, $sign, $algorithm, $rule)>
Copies the given C<$facts> (a dictionary, usually goal(s) of a rule) to the
L<inference_facts> dictionary. All the given goals will be copied with the
given C<$sign>.
Additionally it will add the given C<$algorithm> and C<$rule> to the inference
facts. So later we can know how we got to a certain inference fact.
=cut
sub copy_to_inference_facts {
my ($self, $facts, $sign, $algorithm, $rule) = @_;
while(my $fact = $facts->iterate) {
$self->{'inference_facts'}->append(
$fact,
{
name => $fact,
sign => $sign,
factor => 0.0,
algorithm => $algorithm,
lib/AI/ExpertSystem/Advanced.pm view on Meta::CPAN
Asked facts
=back
It will be couting the matches of all of the above dictionaries, so for example
if we have four causes, two make match with initial facts, other with inference
and the remaining one with the asked facts, then it will evaluate to true since
we have a match of the four causes.
=cut
sub compare_causes_with_facts {
my ($self, $rule) = @_;
my $causes = $self->get_causes_by_rule($rule);
my $match_counter = 0;
my $causes_total = $causes->size();
while (my $cause = $causes->iterate) {
foreach my $dict (qw(initial_facts_dict inference_facts asked_facts)) {
if ($self->{$dict}->find($cause)) {
$match_counter++;
lib/AI/ExpertSystem/Advanced.pm view on Meta::CPAN
of causes (matched or not) that don't have a weight.
=item *
If no weight is found with all the causes of the given rule, then the total
number of matches will be divided by the total number of causes.
=back
=cut
sub get_causes_match_factor {
my ($self, $rule) = @_;
my $causes = $self->get_causes_by_rule($rule);
my $causes_total = $causes->size();
my ($factor_counter, $missing_factor, $match_counter, $nonfactor_match) =
(0, 0, 0, 0);
while (my $cause = $causes->iterate) {
my $factor = $causes->get_value($cause, 'factor');
lib/AI/ExpertSystem/Advanced.pm view on Meta::CPAN
The inference facts
=item 3
The asked facts
=back
=cut
sub is_goal_in_our_facts {
my ($self, $goal) = @_;
foreach my $dict (qw(initial_facts_dict inference_facts asked_facts)) {
if ($self->{$dict}->find($goal)) {
return 1;
}
}
return undef;
}
=head2 B<remove_last_ivisited_rule()>
Removes the last visited rule and return its number.
=cut
sub remove_last_visited_rule {
my ($self) = @_;
my $last = $self->{'visited_rules'}->iterate;
if (defined $last) {
$self->{'visited_rules'}->remove($last);
$self->{'visited_rules'}->populate_iterable_array();
}
return $last;
}
=head2 B<visit_rule($rule, $total_causes)>
Adds the given C<$rule> to the end of the L<visited_rules>.
=cut
sub visit_rule {
my ($self, $rule, $total_causes) = @_;
$self->{'visited_rules'}->prepend($rule,
{
causes_total => $total_causes,
causes_pending => $total_causes
});
$self->{'visited_rules'}->populate_iterable_array();
}
=head2 B<copy_to_goals_to_check($rule, $facts)>
Copies a list of facts (usually a list of causes of a rule) to
L<goals_to_check_dict>.
The rule ID of the goals that are being copied is also stored in the hahs.
=cut
sub copy_to_goals_to_check {
my ($self, $rule, $facts) = @_;
while(my $fact = $facts->iterate_reverse) {
$self->{'goals_to_check_dict'}->prepend(
$fact,
{
name => $fact,
sign => $facts->get_value($fact, 'sign'),
rule => $rule
});
lib/AI/ExpertSystem/Advanced.pm view on Meta::CPAN
In case user doesn't knows of it.
=item B<~> or L<FACT_SIGN_UNSURE>
In case user doesn't have any clue about the given fact.
=back
=cut
sub ask_about {
my ($self, $fact) = @_;
# The knowledge db has questions for this fact?
my $question = $self->{'knowledge_db'}->get_question($fact);
if (!defined $question) {
$question = "Do you have $fact?";
}
my @options = qw(Y N U);
my $answer = $self->{'viewer'}->ask($question, @options);
return $answer;
}
=head2 B<get_rule_by_goal($goal)>
Looks in the L<knowledge_db> for the rule that has the given goal. If a rule
is found its number is returned, otherwise undef.
=cut
sub get_rule_by_goal {
my ($self, $goal) = @_;
return $self->{'knowledge_db'}->find_rule_by_goal($goal);
}
=head2 B<forward()>
use AI::ExpertSystem::Advanced;
use AI::ExpertSystem::Advanced::KnowledgeDB::Factory;
lib/AI/ExpertSystem/Advanced.pm view on Meta::CPAN
The forward chaining algorithm is one of the main methods used in Expert
Systems. It starts with a set of variables (known as initial facts) and reads
the available rules.
It will be reading rule by rule and for each one it will compare its causes
with the initial, inference and asked facts. If all of these causes are in the
facts then the rule will be shoot and all of its goals will be copied/converted
to inference facts and will restart reading from the first rule.
=cut
sub forward {
my ($self) = @_;
confess "Can't do forward algorithm with no initial facts" unless
$self->{'initial_facts_dict'};
my ($more_rules, $current_rule) = (1, undef);
while($more_rules) {
$current_rule = $self->{'knowledge_db'}->get_next_rule($current_rule);
# No more rules?
lib/AI/ExpertSystem/Advanced.pm view on Meta::CPAN
will be added to the top of the L<goals_to_check_dict> and it will start
reading again all the goals.
If there's the case where the goal doesn't exist as a goal in the rules then
it will ask the user (via L<ask_about()>) for the existence of it. If user is
not sure about it then the algorithm ends.
=back
=cut
sub backward {
my ($self) = @_;
my ($more_goals, $current_goal, $total_goals) = (
1,
0,
scalar(@{$self->{'goals_to_check'}}));
WAIT_FOR_MORE_GOALS: while($more_goals) {
READ_GOAL: while(my $goal = $self->{'goals_to_check_dict'}->iterate) {
if ($self->is_goal_in_our_facts($goal)) {
lib/AI/ExpertSystem/Advanced.pm view on Meta::CPAN
a doctor and know some of the symptoms of a patient. Probably with the first
symptoms you have you can get to a positive conclusion (eg that a patient has
I<X> disease). However in case there's still no clue, then a set of questions
(done by the call of L<backward()>) of symptons related to the initial symptoms
will be asked to the user. For example, we know that that the patient has a
headache but that doesn't give us any positive answer, what if the patient has
flu or another disease? Then a set of these I<related> symptons will be asked
to the user.
=cut
sub mixed {
my ($self) = @_;
if (!$self->forward()) {
$self->{'viewer'}->print_error("The first execution of forward failed");
return 0;
}
use Data::Dumper;
while(1) {
lib/AI/ExpertSystem/Advanced.pm view on Meta::CPAN
the fatcs that were excluded and the ones that were used.
This method will use the L<viewer> (or return the result) in YAML format of all
the rules that were shot. It will explain how it got to each one of the causes
so a better explanation can be done by the L<viewer>.
If C<$return> is defined (eg, it got any parameter) then the result wont be
passed to the L<viewer>, instead it will be returned as a string.
=cut
sub summary {
my ($self, $return) = @_;
# any facts we found via inference?
if (scalar @{$self->{'inference_facts'}->{'stack'}} eq 0) {
$self->{'viewer'}->print_error("No inference was possible");
} else {
my $summary = {};
# How the rules started being shot?
my $order = 1;
# So, what rules we shot?
lib/AI/ExpertSystem/Advanced.pm view on Meta::CPAN
return $yaml_summary;
} else {
$self->{'viewer'}->explain($yaml_summary);
}
}
}
# No need to document this, this is an *internal* Moose method, used when an
# instance of the class has been created and all the verifications (of valid
# parameters) have been done.
sub BUILD {
my ($self) = @_;
if (!defined $self->{'viewer'}) {
if (defined $self->{'viewer_class'}) {
$self->{'viewer'} = AI::ExpertSystem::Advanced::Viewer::Factory->new(
$self->{'viewer_class'});
} else {
confess "Sorry, provide a viewer or a viewer_class";
}
}
lib/AI/ExpertSystem/Advanced/Dictionary.pm view on Meta::CPAN
=head2 B<find($look_for, $find_by)>
Looks for a given value (C<$look_for>). By default it will look for the value
by reading the C<id> of each item, however this can be changed by passing
a different hash key (C<$find_by>).
In case there's no match C<undef> is returned.
=cut
sub find {
my ($self, $look_for, $find_by) = @_;
if (!defined($find_by)) {
if (defined $self->{'stack_hash'}->{$look_for}) {
return $look_for;
}
return undef;
}
foreach my $key (keys %{$self->{'stack_hash'}}) {
lib/AI/ExpertSystem/Advanced/Dictionary.pm view on Meta::CPAN
The L<AI::ExpertSystem::Advanced::Dictionary> consists of a hash of elements,
each element has its own properties (eg, extra keys).
This method looks for the value of the given C<$key> of a given element C<id>.
It will return the value, but if element doesn't have the given C<$key> then
C<undef> will be returned.
=cut
sub get_value {
my ($self, $id, $key) = @_;
if (!defined $self->{'stack_hash'}->{$id}) {
return undef;
}
if (defined $self->{'stack_hash'}->{$id}->{$key}) {
return $self->{'stack_hash'}->{$id}->{$key};
} else {
return undef;
}
lib/AI/ExpertSystem/Advanced/Dictionary.pm view on Meta::CPAN
=head2 B<append($id, %extra_keys)>
Adds a new element to the C<stack_hash> and C<stack>. The element gets added to
the end of C<stack>.
The C<$id> parameter specifies the id of the new element and the next parameter
is a stack of I<extra> keys.
=cut
sub append {
my $self = shift;
my $id = shift;
return $self->_add($id, undef, @_);
}
=head2 B<prepend($id, %extra_keys)>
Same as C<append()>, but the element gets added to the top of the C<stack>.
=cut
sub prepend {
my $self = shift;
my $id = shift;
return $self->_add($id, 1, @_);
}
=head2 B<update($id, %extra_keys)>
Updates the I<extra> keys of the element that matches the given C<$id>.
Please note that it will only update or add new keys. So if the given element
already has a key and this is not provided in C<%extra_keys> then it wont
be modified.
=cut
sub update {
my ($self, $id, $properties) = @_;
if (defined $self->{'stack_hash'}->{$id}) {
foreach my $key (keys %$properties) {
$self->{'stack_hash'}->{$id}->{$key} = $properties->{$key};
}
} else {
warn "Not updating $id, does not exist!";
}
}
=head2 B<remove($id)>
Removes the element that matches the given C<$id> from C<stack_hash> and
C<stack>.
Returns true if the removal is successful, otherwise false is returned.
=cut
sub remove {
my ($self, $id) = @_;
if (defined $self->{'stack_hash'}->{$id}) {
delete($self->{'stack_hash'}->{$id});
# Find the index in the array, lets suppose our arrays are big
my $index = List::MoreUtils::first_index {
defined $_ and $_ eq $id
} @{$self->{'stack'}};
splice(@{$self->{'stack'}}, $index, 1);
return 1;
}
return 0;
}
=head2 B<size()>
Returns the size of C<stack>.
=cut
sub size {
my ($self) = @_;
return scalar(@{$self->{'stack'}});
}
=head2 B<iterate()>
Returns the first element of the C<iterable_array> and C<iterable_array> is
reduced by one.
If no more items are found in C<iterable_array> then C<undef> is returned.
=cut
sub iterate {
my ($self) = @_;
return shift(@{$self->{'iterable_array'}});
}
=head2 B<iterate_reverse()>
Same as C<iterate()>, but instead of returning the first element, it returns
the last element of C<iterable_array>.
=cut
sub iterate_reverse {
my ($self) = @_;
return pop(@{$self->{'iterable_array'}});
}
=head2 B<populate_iterable_array()>
The C<iterable_array> gets populated when a dictionary instance is created,
however if new items are added or removed then it's B<extremely> needed to call
this method so C<iterable_array> gets populated again.
=cut
sub populate_iterable_array {
my ($self) = @_;
@{$self->{'iterable_array'}} = @{$self->{'stack'}};
}
# No need to document it, used by L<Moose>.
sub BUILD {
my ($self) = @_;
foreach (@{$self->{'stack'}}) {
if (ref($_) eq 'ARRAY') {
$self->{'stack_hash'}->{$_->[0]} = {
name => $_->[0],
sign => $_->[1]
};
} else {
$self->{'stack_hash'}->{$_} = {
name => $_,
sign => '+'
};
}
}
$self->populate_iterable_array();
}
################# Private methods ######################
sub _add {
my ($self, $id, $prepend, $properties) = @_;
$self->{'stack_hash'}->{$id} = $properties;
if ($prepend) {
unshift(@{$self->{'stack'}}, $id);
} else {
push(@{$self->{'stack'}}, $id);
}
}
lib/AI/ExpertSystem/Advanced/KnowledgeDB/Base.pm view on Meta::CPAN
Similar and same concept of C<rules>, but this will have a list (if available)
of what questions should be done to certain facts.
=back
=cut
has 'questions' => (
is => 'ro',
isa => 'HashRef',
default => sub { return {}; });
=head1 Methods
=head2 B<read()>
This method reads the knowledge database. This is the only method you need to
define even if you are going to load the database in memory or if you are
going to query it.
=cut
sub read {
confess "You can't call KnowedgeDB::Base! (abstract method)";
}
=head2 B<rule_goals($rule)>
Returns all the goals (usually only one) of the given C<$rule>.
The goals B<should> be returned as a L<AI::ExpertSystem::Advanced::Dictionary>.
B<NOTE>: Rewrite this method if you are not going to use the C<rules> hash (eg,
you will use a database engine).
=cut
sub rule_goals {
my ($self, $rule) = @_;
if (!defined $self->{'rules'}->[$rule]) {
confess "Rule $rule does not exist";
}
my @facts;
# Get all the facts of this goal (usually only one)
foreach (@{$self->{'rules'}->[$rule]->{'goals'}}) {
my $id;
# it has an ID?
lib/AI/ExpertSystem/Advanced/KnowledgeDB/Base.pm view on Meta::CPAN
Returns all the causes of the given C<$rule>.
Same as C<rule_goals()>, the causes should be returned as a
L<AI::ExpertSystem::Advanced::Dictionary>.
B<NOTE>: Rewrite this method if you are not going to use the C<rules> hash (eg,
you will use a database engine).
=cut
sub rule_causes {
my ($self, $rule) = @_;
if (!defined $self->{'rules'}->[$rule]) {
confess "Rule $rule does not exist";
}
my @facts;
# Get all the facts of this cause
foreach (@{$self->{'rules'}->[$rule]->{'causes'}}) {
my $id;
# it has an ID?
lib/AI/ExpertSystem/Advanced/KnowledgeDB/Base.pm view on Meta::CPAN
Looks for the first rule that has the given C<goal> in its goals.
If a rule is found then its number is returned, otherwise C<undef> is
returned.
B<NOTE>: Rewrite this method if you are not going to use the C<rules> hash (eg,
you will use a database engine).
=cut
sub find_rule_by_goal {
my ($self, $goal) = @_;
my $rule_counter = 0;
foreach my $rule (@{$self->{'rules'}}) {
foreach my $rule_goal (@{$rule->{'goals'}}) {
# Look in id and name for the match
foreach my $look_in (qw(id name)) {
if (defined $rule_goal->{$look_in}) {
if ($rule_goal->{$look_in} eq $goal) {
return $rule_counter;
lib/AI/ExpertSystem/Advanced/KnowledgeDB/Base.pm view on Meta::CPAN
=head2 B<get_question($fact)>
Looks for a question about the given C<$fact>. If a question exists then this is
returned, otherwise C<undef> is returned.
B<NOTE>: Rewrite this method if you are not going to use the C<rules> hash (eg,
you will use a database engine).
=cut
sub get_question {
my ($self, $fact) = @_;
if (defined $self->{'questions'}->{$fact}) {
return $self->{'questions'}->{$fact};
}
return undef;
}
=head2 B<get_next_rule($current_rule)>
Returns the ID of the next rule. When there are no more rules to work then
C<undef> should be returned.
When it starts looking for the first rule, C<$current_rule> value will
be C<undef>.
B<NOTE>: Rewrite this method if you are not going to use the C<rules> hash (eg,
you will use a database engine).
=cut
sub get_next_rule {
my ($self, $current_rule) = @_;
my $next_rule;
if (defined $current_rule) {
$next_rule = $current_rule+1;
} else {
$next_rule = 0;
}
if (defined $self->{'rules'}->[$next_rule]) {
lib/AI/ExpertSystem/Advanced/KnowledgeDB/Factory.pm view on Meta::CPAN
});
=cut
use strict;
use warnings;
use Class::Factory;
use base qw(Class::Factory);
our $VERSION = '0.02';
sub new {
my ($pkg, $type, @params) = @_;
my $class = $pkg->get_factory_class($type);
return undef unless ($class);
my $self = "$class"->new(@params);
return $self;
}
__PACKAGE__->register_factory_type(yaml =>
'AI::ExpertSystem::Advanced::KnowledgeDB::YAML');
lib/AI/ExpertSystem/Advanced/KnowledgeDB/YAML.pm view on Meta::CPAN
=back
=cut
has 'filename' => (
is => 'rw',
isa => 'Str',
required => 1);
# Called when the object gets created
sub BUILD {
my ($self) = @_;
my $data = LoadFile($self->{'filename'});
if (defined $data->{'rules'}) {
$self->{'rules'} = $data->{'rules'}
} else {
confess "Couldn't find any rules in $self->{'filename'}";
}
if (defined $data->{'questions'}) {
lib/AI/ExpertSystem/Advanced/Viewer/Base.pm view on Meta::CPAN
use constant NO_ABSTRACT_CLASS_MSG =>
qq#Sorry, you can't call the abstract class!#;
=head2 B<debug($msg)>
Will be used to debug any task done by L<AI::ExpertSystem::Advanced>. It only
receives one parameter that is the message to print.
=cut
sub debug {
confess NO_ABSTRACT_CLASS_MSG;
}
=head2 B<print($msg)>
Will be used to print anything that is not a debug messages. It only receives
one parameter that is the message to print.
=cut
sub print {
confess NO_ABSTRACT_CLASS_MSG;
}
=head2 B<print_error($msg)>
Will be used to print any error of L<AI::ExpertSystem::Advanced>. It only
receives one parameter that is the message to print.
=cut
sub print_error {
confess NO_ABSTRACT_CLASS_MSG;
}
=head2 B<ask($message, @options)>
Will be used to ask the user for some information. It will receive a string,
the question to ask and an array of all the possible options.
Please return only one option and this should be any of the ones listed in
C<@options> cause otherwise L<AI::ExpertSystem::Advanced> will die.
=cut
sub ask {
confess NO_ABSTRACT_CLASS_MSG;
}
=head2 B<explain($yaml_summary)>
Used to explain what happened. The passed argument is a YAML string that has
all the information required to make a good explanation.
=cut
sub explain {
confess NO_ABSTRACT_CLASS_MSG;
}
=head1 AUTHOR
Pablo Fischer (pablo@pablo.com.mx).
=head1 COPYRIGHT
Copyright (C) 2010 by Pablo Fischer.
lib/AI/ExpertSystem/Advanced/Viewer/Factory.pm view on Meta::CPAN
useful (and required) to show data to the user.
=cut
use strict;
use warnings;
use Class::Factory;
use base qw(Class::Factory);
our $VERSION = '0.01';
sub new {
my ($pkg, $type, @params) = @_;
my $class = $pkg->get_factory_class($type);
return undef unless ($class);
my $self = "$class"->new(@params);
return $self;
}
__PACKAGE__->register_factory_type(terminal =>
'AI::ExpertSystem::Advanced::Viewer::Terminal');
lib/AI/ExpertSystem/Advanced/Viewer/Terminal.pm view on Meta::CPAN
is => 'ro',
isa => 'Term::ReadLine');
=head1 Methods
=head2 B<debug($msg)>
Basically just prints the given C<$msg> but prepends the "DEBUG" string to it.
=cut
sub debug {
my ($self, $msg) = @_;
print "DEBUG: $msg\n";
}
=head2 B<print($msg)>
Simply prints the given C<$msg>.
=cut
sub print {
my ($self, $msg) = @_;
print "$msg\n";
}
=head2 B<print_error($msg)>
Will prepend the "ERROR:" word to the given message and then will call
C<print()>.
=cut
sub print_error {
my ($self, $msg) = @_;
$self->print("ERROR: $msg");
}
=head2 B<ask($message, @options)>
Will be used to ask the user for some information. It will receive a string,
the question to ask and an array of all the possible options.
=cut
sub ask {
my ($self, $msg, $options) = @_;
my %valid_choices = (
'Y' => '+',
'N' => '-',
'U' => '~');
my $reply = $self->{'readline'}->get_reply(
prompt => $msg . ' ',
choices => [qw|Y N U|]);
return $valid_choices{$reply};
}
=head2 B<explain($yaml_summary)>
Explains what happened.
=cut
sub explain {
my ($self, $summary) = @_;
print $summary;
}
# Called when the object is created
sub BUILD {
my ($self) = @_;
$self->{'readline'} = Term::ReadLine->new('questions');
}
=head1 AUTHOR
Pablo Fischer (pablo@pablo.com.mx).
=head1 COPYRIGHT
( run in 0.312 second using v1.01-cache-2.11-cpan-a5abf4f5562 )