view release on metacpan or  search on metacpan

lib/ACME/QuoteDB.pm  view on Meta::CPAN

#$Id: QuoteDB.pm,v 1.36 2009/09/30 07:37:09 dinosau2 Exp $
# /* vim:et: set ts=4 sw=4 sts=4 tw=78: */

package ACME::QuoteDB;

use 5.008005;        # require perl 5.8.5, re: DBD::SQLite Unicode
use warnings;
use strict;

#major-version.minor-revision.bugfix
use version; our $VERSION = qv('0.1.2');

#use criticism 'brutal'; # use critic with a ~/.perlcriticrc

use Exporter 'import';
our @EXPORT = qw/quote/; # support one liner

use Carp qw/croak/;
use Data::Dumper qw/Dumper/;
use ACME::QuoteDB::LoadDB;
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';

binmode STDOUT, ':encoding(utf8)';
binmode STDERR, ':encoding(utf8)';

sub new {
    my $class = shift;
    my $self = bless {}, $class;
    return $self;
}

# provide 1 non OO method for one liners
sub quote {
    my ($arg_ref) = @_;
    return get_quote(q{}, $arg_ref);
}

# list of quote attributions (names) (makes searching easier)
sub list_attr_names {
   return _get_field_all_from('name', Attr->retrieve_all);
}

# list of quote categories
sub list_categories {
   return _get_field_all_from('catg', Catg->retrieve_all);
}

## list of quote sources
sub list_attr_sources {
   return _get_field_all_from('source', Quote->retrieve_all);
}

sub _get_field_all_from {
   my ($field, @all_stored) = @_;

    my $arr_ref = [];
    RECORDS:
    foreach my $f_obj (@all_stored){
        my $s = $f_obj->$field;
        # if doesn't exist and not a dup
        if (! $f_obj->$field || scalar grep {/$s/sm} @{$arr_ref}){
            next RECORDS;
        }
        push @{ $arr_ref }, $f_obj->$field;
    }
    return join "\n", sort @{$arr_ref};
}

sub _get_attribution_ids_from_name {
    my ($attr_name) = @_;

    my $c_ids = [];
    # a bug: what if string starts with what we specify
    #i.e. => %Griffin% doesn' match 'Griffin' (no quotes)
    RESULTS:
    foreach my $c_obj (Attr->search_like(name => "%$attr_name%")){
       next RESULTS unless $c_obj->attr_id;
       push @{ $c_ids }, $c_obj->attr_id;
    }

    if (not scalar @{$c_ids}) {
        croak 'attribution not found';
    }

    return $c_ids;

}

sub _get_quote_id_from_quote {
    my ($quote) = @_;

    my $q_ids = [];
    # a bug: what if string starts with what we specify
    #i.e. => %Griffin% doesn' match 'Griffin' (no quotes)
    RESULTS:
    foreach my $c_obj (Quote->search(quote => $quote)){
       next RESULTS unless $c_obj->quot_id;
       push @{ $q_ids }, $c_obj->quot_id;
    }

    if (not scalar @{$q_ids}) {
        croak 'quote not found';
    }

    return $q_ids;

}

# can handle scalar or array ref
sub _rm_beg_end_space {
    my ($v) = @_;
    return unless $v;
    if (ref $v eq 'ARRAY'){
      my $arr_ref = ();
      foreach my $vl (@{$v}){
          push @{$arr_ref}, _rm_beg_end_space($vl);
      }
      return $arr_ref;
    }
    else {
      $v =~ s/\A\s+//xmsg;
      $v =~ s/\s+\z//xmsg;
      return $v;
    }
  return;
}

sub _get_one_rand_quote_from_all {
    #my $quotes_ref = [];
    #foreach my $q_obj (Quote->retrieve_all){
    #    next unless $q_obj->quote;
    #    my $record = Attr->retrieve($q_obj->attr_id);
    #    my $attr_name = $record->name || q{};
    #    push @{ $quotes_ref }, $q_obj->quote . "\n-- $attr_name";
    #}
    my $quotes_ref = _get_quote_ref_from_all(Quote->retrieve_all);
    return $quotes_ref->[rand scalar @{$quotes_ref}];
}

sub _get_rating_params {
    my ($rating) = @_;
    return unless $rating;

    my ($lower, $upper) = (q{}, q{});
    ($lower, $upper) = split /-/sm, $rating;

    if ($upper && !$lower) { croak 'negative range not permitted'};

    return (_rm_beg_end_space($lower), _rm_beg_end_space($upper));
}

sub _get_if_rating {
    my ($lower, $upper) = @_;

    if ($lower and $upper) { # a range, find within
        $lower =  qq/ AND rating >= '$lower' /;
        $upper =  qq/ AND rating <= '$upper' /;
    }
    elsif ($lower and not $upper) { # not a range, find exact rating
        $lower =  qq/ AND rating = '$lower' /
        #$upper = q{};
    }
    elsif ($upper and not $lower) {
        $upper =  qq/ AND rating = '$upper' /
        #$lower = q{};
    }

    return ($lower, $upper);
}

sub _get_ids_if_catgs_exist {
    my ($catgs) = @_;

    my $catg_ids = ();
    # get category id
    RECS:
    foreach my $c_obj (Catg->retrieve_all){
        next RECS if not $c_obj->catg;

        if (ref $catgs eq 'ARRAY'){
          foreach my $c (@{$catgs}){
            if ($c_obj->catg eq $c){
              # use cat_id if already exists
              push @{$catg_ids}, $c_obj->catg_id;
            }
          }
        }
        else {
          if ($c_obj->catg eq $catgs){
            # use cat_id if already exists
            push @{$catg_ids}, $c_obj->catg_id;
          }
        }
    }
    return $catg_ids;
}

sub _get_quote_id_from_catg_id {
    my ($catg_ids) = @_;

    my $quote_ids = ();
    RECS:
    foreach my $qc_obj (QuoteCatg->retrieve_all){
        next RECS if not $qc_obj->quot_id;

        if (ref $catg_ids eq 'ARRAY'){
          foreach my $c (@{$catg_ids}){
            if ($qc_obj->catg_id eq $c){
              # use cat_id if already exists
              push @{$quote_ids}, $qc_obj->quot_id;
            }
          }
        }
        else {
          if ($qc_obj->catg_id eq $catg_ids){
            # use cat_id if already exists
            push @{$quote_ids}, $qc_obj->quot_id;
          }
        }
    }
    return $quote_ids;
}

sub _untaint_data {
   my ($arr_ref) = @_;
   my $ut_ref = ();
   foreach my $q (@{$arr_ref}){
      if ($q =~ m{\A([0-9]+)\z}sm){
          push @{$ut_ref}, $1;
      }
   }
   return $ut_ref;
}

# TODO fixme: arg list too long
sub _get_rand_quote_for_attribution {
    my ($attr_name, $lower, $upper, $limit, $contain, $source, $catgs) = @_;

    $attr_name ||= q{};
    $lower     ||= q{};
    $upper     ||= q{};
    $limit     ||= q{};
    $contain   ||= q{};
    $source    ||= q{};
    $catgs     ||= q{};

    my $ids = _get_attribution_ids_from_name($attr_name);
    my $phs = _make_correct_num_of_sql_placeholders($ids);

    if ($attr_name) {
        $attr_name =  qq/ attr_id IN ($phs) /;
    }
    else {
        # why would we want this method without a attribution arg?
        # still, let's handle gracefully
        $attr_name =  q/ attr_id IS NOT NULL /;
        $ids = [];
    }

    if ($source) {
        $source =~ s{'}{''}gsm; # sql escape single quote
        $source =  qq/ AND source = '$source' /;
    }
    my $qids =  q{};
    if ($catgs) {
        $catgs  = _get_ids_if_catgs_exist($catgs);
        my $qid_ref = _get_quote_id_from_catg_id($catgs);
        $qids =  join ',', @{_untaint_data($qid_ref)};
        $qids  =  qq/ AND quot_id IN ($qids) /;
    }

    ($lower, $upper) = _get_if_rating($lower, $upper);

    if ($contain) { $contain =  qq/ AND quote LIKE '%$contain%' / }
    if ($limit) { $limit =  qq/ LIMIT '$limit' / };

    my @q = Quote->retrieve_from_sql(
              qq{ $attr_name $lower $upper $source $qids $contain $limit },
              @{$ids}
            );

    # XXX code duplication but smaller footprint
    # choosing not less code duplication, we'll see,...
    #my $quotes_ref = [];
    #foreach my $q_obj ( @q ){
    #    next unless $q_obj->quote;
    #    my $record = Attr->retrieve($q_obj->attr_id);
    #    my $attr_name = $record->name || q{};
    #    push @{ $quotes_ref }, $q_obj->quote . "\n-- $attr_name";
    #}
    #return _get_quote_ref_from_all(\@q);
    # XXX array_ref does not work here!
    return _get_quote_ref_from_all(@q);

    #return $quotes_ref;
}

sub _get_quote_ref_from_all {
    my (@results) = @_;
    #my ($results) = @_;

    my $quotes_ref = [];
    #foreach my $q_obj ( @{$results} ){
    foreach my $q_obj ( @results ){
        next unless $q_obj->quote;
        my $rec = Attr->retrieve($q_obj->attr_id);
        my $attr_name = $rec->name || q{};
        push @{ $quotes_ref }, $q_obj->quote . "\n-- $attr_name";
    }

    return $quotes_ref;
}

sub _args_are_valid {
    my ( $arg_ref, $accepted ) = @_;

    my $arg_ok = 0;
    foreach my $arg ( %{$arg_ref} ) {
        if ( scalar grep { $arg =~ $_ } @{$accepted} ) {
            $arg_ok = 1;
        }
    }

   if (!$arg_ok) {croak 'unsupported argument option passed'}
}

sub add_quote {
    my ( $self, $arg_ref ) = @_;

    _args_are_valid($arg_ref, [qw/Quote AttrName Source Rating Category/]);

    my $load_db = ACME::QuoteDB::LoadDB->new({
                                #verbose => 1,
                  });

    $load_db->set_record(quote  => $arg_ref->{Quote});
    $load_db->set_record(name   => $arg_ref->{AttrName});
    $load_db->set_record(source => $arg_ref->{Source});
    $load_db->set_record(catg   => $arg_ref->{Category});
    $load_db->set_record(rating => $arg_ref->{Rating});

    if ($load_db->get_record('quote') and $load_db->get_record('name')) {
        return $load_db->write_record;
    }
    else {
        croak 'quote and attribution name are mandatory parameters';
    }

    return;
}

# XXX lame, can only get an id from exact quote
sub get_quote_id {
    my ( $self, $arg_ref ) = @_;

    if (not $arg_ref) {croak 'Quote required'}

    _args_are_valid($arg_ref, [qw/Quote/]);

    my $ids = _get_quote_id_from_quote($arg_ref->{'Quote'});

    return join "\n", sort @{$ids};
}

sub update_quote {
    my ( $self, $arg_ref ) = @_;

    if (not $arg_ref) {croak 'QuoteId and Quote required'}

    _args_are_valid($arg_ref, [qw/Quote QuoteId Source 
                                  Category Rating AttrName/]);

    my $q = Quote->retrieve($arg_ref->{'QuoteId'});

    my $atr = Attr->retrieve($q->attr_id);

    # XXX need to support multi categories
    #my $ctg = Catg->retrieve($q->catg_id);
    my $qc = QuoteCatg->retrieve($q->quot_id);

    my $ctg = Catg->retrieve($qc->catg_id);

    $q->quote($arg_ref->{'Quote'});

    if ($arg_ref->{'Source'}){$q->source($arg_ref->{'Source'})}

    if ($arg_ref->{'Rating'}){$q->rating($arg_ref->{'Rating'})};

    if ($arg_ref->{'AttrName'}){$atr->name($arg_ref->{'AttrName'})};

    # XXX need to support multi categories
    if ($arg_ref->{'Category'}){
       $ctg->catg($arg_ref->{'Category'})
    }

    return ($q->update && $atr->update && $ctg->update);
}

sub delete_quote {
    my ( $self, $arg_ref ) = @_;

    if (not $arg_ref) {croak 'QuoteId required'}

    _args_are_valid($arg_ref, [qw/QuoteId/]);

    my $q = Quote->retrieve($arg_ref->{'QuoteId'});

    #$q->quote($arg_ref->{'QuoteId'});

    return $q->delete;

}

sub get_quote {
    my ( $self, $arg_ref ) = @_;

    # default use case, return random quote from all
    if (not $arg_ref) {
        return _get_one_rand_quote_from_all;
    }

    _args_are_valid($arg_ref, [qw/Rating AttrName Source Category/]);

    my ($lower, $upper) = (q{}, q{});
    if ($arg_ref->{'Rating'}) {
        ($lower, $upper) = _get_rating_params($arg_ref->{'Rating'});
    }

    my $attr_name = q{};
    if ( $arg_ref->{'AttrName'} ) {
        $attr_name = _rm_beg_end_space($arg_ref->{'AttrName'});
    }

    my $source = q{};
    if ( $arg_ref->{'Source'} ) {
        $source = _rm_beg_end_space($arg_ref->{'Source'});
    }

    my $catg; # will become scalar or array ref
    if ( $arg_ref->{'Category'} ) {
       $catg = _rm_beg_end_space($arg_ref->{'Category'});
    }

    # use case for attribution, return random quote
    my $quotes_ref =
          _get_rand_quote_for_attribution($attr_name, $lower,
                     $upper, q{}, q{}, $source, $catg);

    # one random from specified pool
    return $quotes_ref->[rand scalar @{$quotes_ref}];

}

# XXX isn't there a method in DBI for this, bind something,...
# TODO follow up 
sub _make_correct_num_of_sql_placeholders {
    my ($ids) = @_;
    # XXX a hack to make a list of '?' placeholders
    my @qms = ();
    for (1..scalar @{$ids}) {
       push @qms, '?';
    }
    return join ',', @qms;
}

sub get_quotes {
    my ( $self, $arg_ref ) = @_;

    # default use case, return random quote from all
    if (not $arg_ref) {
        return _get_one_rand_quote_from_all;
    }

    _args_are_valid($arg_ref, [qw/Rating AttrName Limit Category Source/]);

    my ($lower, $upper) = (q{}, q{});
    if ($arg_ref->{'Rating'}) {
        ($lower, $upper) = _get_rating_params($arg_ref->{'Rating'});
    }

    my $limit = q{};
    if ($arg_ref->{'Limit'}) {
        # specify 'n' amount of quotes to limit by
        $limit = _rm_beg_end_space($arg_ref->{'Limit'});
    }

    my $attribution = q{};
    if ( $arg_ref->{'AttrName'} ) {
        $attribution = _rm_beg_end_space($arg_ref->{'AttrName'});
    }

    my $source = q{};
    if ( $arg_ref->{'Source'} ) {
        $source = _rm_beg_end_space($arg_ref->{'Source'});
    }

    my $catg = q{};
    if ( $arg_ref->{'Category'} ) {
        $catg = _rm_beg_end_space($arg_ref->{'Category'});
    }
    # use case for attribution, return random quote
    return _get_rand_quote_for_attribution($attribution, $lower,
                     $upper, $limit, q{}, $source, $catg);

}


sub get_quotes_contain {
    my ( $self, $arg_ref ) = @_;


    my $contain = q{};
    if ($arg_ref->{'Contain'}) {
        $contain = _rm_beg_end_space($arg_ref->{'Contain'});
    }
    else {
        croak 'Contain is a mandatory parameter';
    }

    _args_are_valid($arg_ref, [qw/Contain Rating AttrName Limit/]);

    my ($lower, $upper) = (q{}, q{});
    if ($arg_ref->{'Rating'}) {
        ($lower, $upper) = _get_rating_params($arg_ref->{'Rating'});
    }

    my $limit = q{};
    if ($arg_ref->{'Limit'}) {
        $limit = _rm_beg_end_space($arg_ref->{'Limit'});
    }

    # default use case for attribution, return random quote
    my $attr_name = q{};
    if ( $arg_ref->{'AttrName'} ) {
        # return 'n' from random from specified pool
        $attr_name = _rm_beg_end_space($arg_ref->{'AttrName'});
    }

    return _get_rand_quote_for_attribution($attr_name, $lower, $upper, $limit, $contain);
}

1 and 'Chief Wiggum: Uh, no, you got the wrong number. This is 9-1... 2.';


__END__

=head1 NAME

ACME::QuoteDB - API implements CRUD for a Collection of Quotes (adages/proverbs/sayings/epigrams, etc)


=head1 VERSION

Version 0.1.2


=head1 SYNOPSIS

Easy access to a collection of quotes (the 'Read' part)

As quick one liner:

    # randomly display one quote from all available. (like motd, 'fortune')
    perl -MACME::QuoteDB -le 'print quote()'

    # Say you have populated your quotes database with some quotes from 
    # 'The Simpsons'
    # randomly display one quote from all available for person 'Ralph'