view release on metacpan or  search on metacpan

bin/remote.pl  view on Meta::CPAN

package AI::MicroStructure::KnowHow;
use strict;
use AI::MicroStructure ();    # do not export metaname and friends
#use AI::MicroStructure::RemoteKnowledge;
use List::Util qw( shuffle );
use Carp;

#our @ISA = qw( AI::MicroStructure::RemoteKnowledge );

sub init {
    my $class = caller(0);
    my $data  = AI::MicroStructure->load_data($class);
    no strict 'refs';

    my $sep = ${"$class\::Separator"} ||= '/';
    my $tail = qr/$sep?[^$sep]*$/;

    # compute all categories
    my @categories = ( [ $data->{names}, '' ] );
    while ( my ( $h, $k ) = @{ shift @categories or []} ) {
        if ( ref $h eq 'HASH' ) {
            push @categories,
                map { [ $h->{$_}, ( $k ? "$k$sep$_" : $_ ) ] } keys %$h;
        }
        else {    # leaf
            my @items = split /\s+/, $h;
            while ($k) {
                push @{ ${"$class\::KnowHow"}{$k} }, @items;
                $k =~ s!$tail!!;
            }
        }
    }

    ${"$class\::Default"} = $data->{default} || ':all';
    ${"$class\::Theme"} = ( split /::/, $class )[-1];

    *{"$class\::import"} = sub {
        my $callpkg = caller(0);
        my $theme   = ${"$class\::Theme"};
        my $meta    = $class->new;
        *{"$callpkg\::meta$theme"} = sub { $meta->name(@_) };
    };

    ${"$class\::meta"} = $class->new();
}

sub name {
    my ( $self, $count ) = @_;
    my $class = ref $self;

    if ( !$class ) {    # called as a class method!
        $class = $self;
        no strict 'refs';
        $self = ${"$class\::meta"};
    }
  no strict 'refs';

    if ( defined $count && $count !~ /A-Za-z/ && $count == 0 ) {
        return wantarray
            ? shuffle @{ $self->{base} }
            : scalar @{ $self->{base} };
    }

    $count ||= 1;
    my $Knowledge = $self->{cache};
    if ( @{ $self->{base} } ) {
        push @$Knowledge, shuffle @{ $self->{base} } while @$Knowledge < $count;
    }
    splice( @$Knowledge, 0, $count );
}

sub new {
    my $class = shift;

    no strict 'refs';
    my $self = bless { @_, cache => [] }, $class;

    # compute some defaults
    $self->{category} ||= ${"$class\::Default"};

    # fall back to last resort (FIXME should we carp()?)
    $self->{category} = ${"$class\::Default"}
        if $self->{category} ne ':all'
        && !exists ${"$class\::KnowHow"}{ $self->{category} };

    $self->_compute_base();
    return $self;
}

sub _compute_base {
    my ($self) = @_;
    my $class = ref $self;

    # compute the base Knowledge for this category
    no strict 'refs';
    my %seen;
    $self->{base} = [
        grep { !$seen{$_}++ }
            map { @{ ${"$class\::KnowHow"}{$_} } }
            $self->{category} eq ':all'
        ? ( keys %{"$class\::KnowHow"} )
        : ( $self->{category} )
    ];
    return;
}

sub category { $_[0]->{category} }

sub categories {
    my $class = shift;
    $class = ref $class if ref $class;

    no strict 'refs';
    return keys %{"$class\::KnowHow"};
}

sub has_category {
    my ($class, $category) = @_;
    $class = ref $class if ref $class;

    no strict 'refs';
    return exists ${"$class\::KnowHow"}{$category};
}

sub theme {
    my $class = ref $_[0] || $_[0];
    no strict 'refs';
    return ${"$class\::Theme"};
}

1;


package AI::MicroStructure::KnowHow;
use strict;
use warnings;
use Carp;

# method that extracts the items from the remote content and returns them
sub extract {
    my $class = ref $_[0] || $_[0];
    no strict 'refs';
    my $func  = ${"$class\::Remote"}{extract};

    # provide a very basic default
    my $meth = ref $func eq 'CODE'
        ? sub { my %seen; return grep { !$seen{$_}++ } $func->( $_[1] ); }
        : sub { return $_[1] };    # very basic default

    # put the method in the subclass symbol table (at runtime)
    *{"$class\::extract"} = $meth;

    # now run the function^Wmethod
    goto &$meth;
}

# methods related to the source URL
sub source {
    my $class = ref $_[0] || $_[0];
    no strict 'refs';

    return ${"$class\::Remote"}{source};
}

sub sources {
    my $class = ref $_[0] || $_[0];
    no strict 'refs';

    my $src = ${"$class\::Remote"}{source};
    if ( ref $src eq 'ARRAY' ) {
        return @$src;
    }
    elsif ( ref $src eq 'HASH' ) {
        return
            map { ref $_ ? @$_ : $_ } $_[1] ? $src->{ $_[1] } : values %$src;
    }
    return $src;
}

sub has_remoteKnowledge { return defined $_[0]->source(); }

# main method: return the Knowledge from the remote source
sub remote_Knowledge {
    my $class = ref $_[0] || $_[0];
    return unless $class->has_remoteKnowledge();

    # check that we can access the network
    eval {
        require LWP::UserAgent;
        die "version 5.802 required ($LWP::VERSION installed)\n"
            if $LWP::VERSION < 5.802;
    };
    if ($@) {
        carp "LWP::UserAgent not available: $@";
        return;
    }

    # fetch the content
    my @items;
    my @srcs = $class->sources($_[1]);
    my $ua   = LWP::UserAgent->new( env_proxy => 1 );
    foreach my $src (@srcs) {
        my $res  = $ua->request( HTTP::Request->new( GET => $src ) );
        if ( ! $res->is_success() ) {
            carp "Failed to get content at $src (" . $res->status_line();
            return;
        }

        # extract, cleanup and return the data
        # if decoding the content fails, we just deal with the raw content
        push @items =>
            $class->extract( $res->decoded_content() || $res->content() );

    }

    # return unique items
    my %seen;
    return grep { !$seen{$_}++ } @items;
}

#
# transformation subroutines
#
sub tr_nonword {
    my $str = shift;
    $str =~ tr/a-zA-Z0-9_/_/c;
    $str;
}

sub tr_accent {
    my $str = shift;
    $str =~ tr{ÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÑÒÓÔÕÖØÙÚÛÜÝàáâãäåçèéêëìíîïñòóôõöøùúûüýÿ}
              {AAAAAACEEEEIIIINOOOOOOUUUUYaaaaaaceeeeiiiinoooooouuuuyy};
    return $str;
}

my %utf2asc = (
    "\xc3\x89" => 'E',
    "\xc3\xa0" => 'a',
    "\xc3\xa1" => 'a',
    "\xc3\xa9" => 'e',
    "\xc3\xaf" => 'i',
    "\xc3\xad" => 'i',
    "\xc3\xb6" => 'o',
    "\xc3\xb8" => 'o',
    "\xc5\xa0" => 'S',
    "\x{0160}" => 'S',
    # for pokemons
    "\x{0101}"     => 'a',
    "\x{012b}"     => 'i',
    "\x{014d}"     => 'o',
    "\x{016b}"     => 'u',
    "\xe2\x99\x80" => 'female',
    "\xe2\x99\x82" => 'male',
    "\x{2640}"     => 'female',
    "\x{2642}"     => 'male',
);
my $utf_re = qr/(@{[join( '|', sort keys %utf2asc )]})/;

sub tr_utf8_basic {
    my $str = shift;
    $str =~ s/$utf_re/$utf2asc{$1}/go;
    return $str;
}

1;

package main;

use Data::Printer;
my $ps = AI::MicroStructure::KnowHow->new();
my @go = $ps->remote_Knowledge();
print  @go;
p $ps;
1;


__DATA__
package AI::MicroStructure::Knowledge;
use strict;
use AI::MicroStructure (); # do not export metaname and friends
#use AI::MicroStructure::RemoteKnowledge;
use List::Util qw( shuffle );
use Carp;

our @ISA = qw( AI::MicroStructure::RemoteKnowledge );

sub init {
    my ($self, $data) = @_;
    my $class = caller(0);

    $data ||= AI::MicroStructure->load_data($class);
    croak "The optional argument to init() must be a hash reference"
      if ref $data ne 'HASH';

    no strict 'refs';
    no warnings;
    ${"$class\::Theme"} = ( split /::/, $class )[-1];
    @{"$class\::Knowledge"} = split /\s+/, $data->{names};
    *{"$class\::import"} = sub {
        my $callpkg = caller(0);
        my $theme   = ${"$class\::Theme"};
        my $meta    = $class->new();
        *{"$callpkg\::meta$theme"} = sub { $meta->name(@_) };
      };
    ${"$class\::meta"} = $class->new();
}

sub name {
    my ( $self, $count ) = @_;
    my $class = ref $self;

    if( ! $class ) { # called as a class method!
        $class = $self;
        no strict 'refs';
        $self = ${"$class\::meta"};
    }
  no strict 'refs';

    if( defined $count && $count == 0 ) {
        return
          wantarray ? shuffle @{"$class\::Knowledge"} : scalar @{"$class\::Knowledge"};
    }

    $count ||= 1;
    my $Knowledge = $self->{cache};
    {
      no strict 'refs';
      if (@{"$class\::Knowledge"}) {
          push @$Knowledge, shuffle @{"$class\::Knowledge"} while @$Knowledge < $count;
      }
    }
    splice( @$Knowledge, 0, $count );
}

sub new {
    my $class = shift;

    bless { cache => [] }, $class;
}

sub theme {
    my $class = ref $_[0] || $_[0];
    no strict 'refs';
    return ${"$class\::Theme"};
}

1;


package AI::MicroStructure::pornstars;
use strict;
#use AI::MicroStructure::KnowHow;
our @ISA = qw( AI::MicroStructure::KnowHow );
__PACKAGE__->init();

our %Remote = (
    source => {
        female => 'http://en.wikipedia.org/wiki/Knowledge_of_female_porn_stars',
        male   => 'http://en.wikipedia.org/wiki/Knowledge_of_male_porn_stars'
    },
    extract => sub {
        return
            map { AI::MicroStructure::RemoteKnowledge::tr_accent($_) }
            map { AI::MicroStructure::RemoteKnowledge::tr_utf8_basic($_) }
            grep { ! /^Knowledge_|_Groups$/ }
            map { s/[-\s']/_/g; s/[."]//g; $_ }
            $_[0]
            =~ m{^<li>(?:<[^>]*>)?(.*?)(?:(?: ?[-,(<]| aka | see ).*)?</li>}mig
    },
    ,
);

1;
package main;

use Data::Printer;
my $ps = AI::MicroStructure::pornstars->new();
my @go = $ps->extract();
p  @go;
p $ps;
1;
__DATA__
# names female
Abigail_Clayton
Adara_Michaels
Addison_Rose
Adele_Stevens
Adriana_Sage
Adrienne_Bellaire
Africa_Sexxx
Ai_Iijima
Aimee_Sweet
Aja
Akira_Fubuki
Alana_Evans
Alaura_Eden
Alex_Dane
Alex_Jordan
Alex_Taylor
Alexa_May
Alexa_Rae
Alexa_Weix
Alexandra_Nice
Alexandra_Silk
Alexis_Amore
Alexis_DeVell
Alexis_Malone
Alexis_May
Alicia_Alighatti
Alicia_Monet
Alicia_Rhodes
Alicia_Rio
Alisha_Klass
Alison_Angel
Aliyah_Yi
Allie
Allie_Sin
Allison_Wyte
Ally_Mac_Tyana
Allysin_Chaynes
Amber_Lynn