File Coverage

blib/lib/ACME/QuoteDB.pm
Criterion Covered Total %
statement 285 300 95.0
branch 82 104 78.8
condition 28 36 77.7
subroutine 38 39 97.4
pod 12 12 100.0
total 445 491 90.6


line stmt bran cond sub pod time code
1             #$Id: QuoteDB.pm,v 1.36 2009/09/30 07:37:09 dinosau2 Exp $
2             # /* vim:et: set ts=4 sw=4 sts=4 tw=78: */
3              
4             package ACME::QuoteDB;
5              
6 7     7   191155 use 5.008005; # require perl 5.8.5, re: DBD::SQLite Unicode
  7         25  
  7         498  
7 7     7   44 use warnings;
  7         13  
  7         284  
8 7     7   41 use strict;
  7         21  
  7         250  
9              
10             #major-version.minor-revision.bugfix
11 7     7   6083 use version; our $VERSION = qv('0.1.2');
  7         15452  
  7         46  
12              
13             #use criticism 'brutal'; # use critic with a ~/.perlcriticrc
14              
15 7     7   717 use Exporter 'import';
  7         18  
  7         370  
16             our @EXPORT = qw/quote/; # support one liner
17              
18 7     7   42 use Carp qw/croak/;
  7         12  
  7         460  
19 7     7   7504 use Data::Dumper qw/Dumper/;
  7         74261  
  7         608  
20 7     7   4728 use ACME::QuoteDB::LoadDB;
  7         30  
  7         395  
21 7     7   57 use aliased 'ACME::QuoteDB::DB::Attribution' => 'Attr';
  7         15  
  7         65  
22 7     7   1105 use aliased 'ACME::QuoteDB::DB::QuoteCatg' => 'QuoteCatg';
  7         16  
  7         32  
23 7     7   894 use aliased 'ACME::QuoteDB::DB::Category' => 'Catg';
  7         17  
  7         47  
24 7     7   938 use aliased 'ACME::QuoteDB::DB::Quote' => 'Quote';
  7         16  
  7         31  
25              
26 7     7   6060 binmode STDOUT, ':encoding(utf8)';
  7         59  
  7         57  
27             binmode STDERR, ':encoding(utf8)';
28              
29             sub new {
30 9     9 1 8707 my $class = shift;
31 9         810 my $self = bless {}, $class;
32 9         39 return $self;
33             }
34              
35             # provide 1 non OO method for one liners
36             sub quote {
37 0     0 1 0 my ($arg_ref) = @_;
38 0         0 return get_quote(q{}, $arg_ref);
39             }
40              
41             # list of quote attributions (names) (makes searching easier)
42             sub list_attr_names {
43 7     7 1 4479 return _get_field_all_from('name', Attr->retrieve_all);
44             }
45              
46             # list of quote categories
47             sub list_categories {
48 3     3 1 816 return _get_field_all_from('catg', Catg->retrieve_all);
49             }
50              
51             ## list of quote sources
52             sub list_attr_sources {
53 3     3 1 849 return _get_field_all_from('source', Quote->retrieve_all);
54             }
55              
56             sub _get_field_all_from {
57 13     13   46544 my ($field, @all_stored) = @_;
58              
59 13         46 my $arr_ref = [];
60             RECORDS:
61 13         45 foreach my $f_obj (@all_stored){
62 154         23294 my $s = $f_obj->$field;
63             # if doesn't exist and not a dup
64 154 100 50     142170 if (! $f_obj->$field || scalar grep {/$s/sm} @{$arr_ref}){
  1268         4897  
  154         10395  
65 70         269 next RECORDS;
66             }
67 84         207 push @{ $arr_ref }, $f_obj->$field;
  84         354  
68             }
69 13         1373 return join "\n", sort @{$arr_ref};
  13         326  
70             }
71              
72             sub _get_attribution_ids_from_name {
73 45     45   98 my ($attr_name) = @_;
74              
75 45         165 my $c_ids = [];
76             # a bug: what if string starts with what we specify
77             #i.e. => %Griffin% doesn' match 'Griffin' (no quotes)
78             RESULTS:
79 45         431 foreach my $c_obj (Attr->search_like(name => "%$attr_name%")){
80 114 50       96976 next RESULTS unless $c_obj->attr_id;
81 114         11194 push @{ $c_ids }, $c_obj->attr_id;
  114         730  
82             }
83              
84 45 100       6783 if (not scalar @{$c_ids}) {
  45         1634  
85 4         748 croak 'attribution not found';
86             }
87              
88 41         229 return $c_ids;
89              
90             }
91              
92             sub _get_quote_id_from_quote {
93 2     2   5 my ($quote) = @_;
94              
95 2         6 my $q_ids = [];
96             # a bug: what if string starts with what we specify
97             #i.e. => %Griffin% doesn' match 'Griffin' (no quotes)
98             RESULTS:
99 2         27 foreach my $c_obj (Quote->search(quote => $quote)){
100 2 50       2113 next RESULTS unless $c_obj->quot_id;
101 2         133 push @{ $q_ids }, $c_obj->quot_id;
  2         10  
102             }
103              
104 2 50       115 if (not scalar @{$q_ids}) {
  2         42  
105 0         0 croak 'quote not found';
106             }
107              
108 2         15 return $q_ids;
109              
110             }
111              
112             # can handle scalar or array ref
113             sub _rm_beg_end_space {
114 81     81   178 my ($v) = @_;
115 81 100       284 return unless $v;
116 73 100       240 if (ref $v eq 'ARRAY'){
117 3         8 my $arr_ref = ();
118 3         6 foreach my $vl (@{$v}){
  3         9  
119 11         16 push @{$arr_ref}, _rm_beg_end_space($vl);
  11         32  
120             }
121 3         11 return $arr_ref;
122             }
123             else {
124 70         247 $v =~ s/\A\s+//xmsg;
125 70         214 $v =~ s/\s+\z//xmsg;
126 70         260 return $v;
127             }
128 0         0 return;
129             }
130              
131             sub _get_one_rand_quote_from_all {
132             #my $quotes_ref = [];
133             #foreach my $q_obj (Quote->retrieve_all){
134             # next unless $q_obj->quote;
135             # my $record = Attr->retrieve($q_obj->attr_id);
136             # my $attr_name = $record->name || q{};
137             # push @{ $quotes_ref }, $q_obj->quote . "\n-- $attr_name";
138             #}
139 4     4   42 my $quotes_ref = _get_quote_ref_from_all(Quote->retrieve_all);
140 4         21 return $quotes_ref->[rand scalar @{$quotes_ref}];
  4         1168  
141             }
142              
143             sub _get_rating_params {
144 13     13   36 my ($rating) = @_;
145 13 50       57 return unless $rating;
146              
147 13         41 my ($lower, $upper) = (q{}, q{});
148 13         59 ($lower, $upper) = split /-/sm, $rating;
149              
150 13 100 100     86 if ($upper && !$lower) { croak 'negative range not permitted'};
  1         225  
151              
152 12         52 return (_rm_beg_end_space($lower), _rm_beg_end_space($upper));
153             }
154              
155             sub _get_if_rating {
156 41     41   106 my ($lower, $upper) = @_;
157              
158 41 100 100     893 if ($lower and $upper) { # a range, find within
    100 66        
    50 33        
159 4         11 $lower = qq/ AND rating >= '$lower' /;
160 4         13 $upper = qq/ AND rating <= '$upper' /;
161             }
162             elsif ($lower and not $upper) { # not a range, find exact rating
163 8         33 $lower = qq/ AND rating = '$lower' /
164             #$upper = q{};
165             }
166             elsif ($upper and not $lower) {
167 0         0 $upper = qq/ AND rating = '$upper' /
168             #$lower = q{};
169             }
170              
171 41         188 return ($lower, $upper);
172             }
173              
174             sub _get_ids_if_catgs_exist {
175 4     4   12 my ($catgs) = @_;
176              
177 4         10 my $catg_ids = ();
178             # get category id
179             RECS:
180 4         35 foreach my $c_obj (Catg->retrieve_all){
181 23 50       13106 next RECS if not $c_obj->catg;
182              
183 23 100       16708 if (ref $catgs eq 'ARRAY'){
184 21         36 foreach my $c (@{$catgs}){
  21         60  
185 77 100       3715 if ($c_obj->catg eq $c){
186             # use cat_id if already exists
187 11         736 push @{$catg_ids}, $c_obj->catg_id;
  11         41  
188             }
189             }
190             }
191             else {
192 2 100       9 if ($c_obj->catg eq $catgs){
193             # use cat_id if already exists
194 1         69 push @{$catg_ids}, $c_obj->catg_id;
  1         8  
195             }
196             }
197             }
198 4         280 return $catg_ids;
199             }
200              
201             sub _get_quote_id_from_catg_id {
202 4     4   12 my ($catg_ids) = @_;
203              
204 4         13 my $quote_ids = ();
205             RECS:
206 4         44 foreach my $qc_obj (QuoteCatg->retrieve_all){
207 156 50       36910 next RECS if not $qc_obj->quot_id;
208              
209 156 50       139921 if (ref $catg_ids eq 'ARRAY'){
210 156         243 foreach my $c (@{$catg_ids}){
  156         397  
211 492 100       24178 if ($qc_obj->catg_id eq $c){
212             # use cat_id if already exists
213 81         5942 push @{$quote_ids}, $qc_obj->quot_id;
  81         304  
214             }
215             }
216             }
217             else {
218 0 0       0 if ($qc_obj->catg_id eq $catg_ids){
219             # use cat_id if already exists
220 0         0 push @{$quote_ids}, $qc_obj->quot_id;
  0         0  
221             }
222             }
223             }
224 4         261 return $quote_ids;
225             }
226              
227             sub _untaint_data {
228 4     4   10 my ($arr_ref) = @_;
229 4         9 my $ut_ref = ();
230 4         8 foreach my $q (@{$arr_ref}){
  4         12  
231 81 50       310 if ($q =~ m{\A([0-9]+)\z}sm){
232 81         98 push @{$ut_ref}, $1;
  81         237  
233             }
234             }
235 4         26 return $ut_ref;
236             }
237              
238             # TODO fixme: arg list too long
239             sub _get_rand_quote_for_attribution {
240 45     45   152 my ($attr_name, $lower, $upper, $limit, $contain, $source, $catgs) = @_;
241              
242 45   100     200 $attr_name ||= q{};
243 45   100     273 $lower ||= q{};
244 45   100     344 $upper ||= q{};
245 45   100     239 $limit ||= q{};
246 45   100     206 $contain ||= q{};
247 45   100     210 $source ||= q{};
248 45   100     198 $catgs ||= q{};
249              
250 45         159 my $ids = _get_attribution_ids_from_name($attr_name);
251 41         162 my $phs = _make_correct_num_of_sql_placeholders($ids);
252              
253 41 100       151 if ($attr_name) {
254 27         88 $attr_name = qq/ attr_id IN ($phs) /;
255             }
256             else {
257             # why would we want this method without a attribution arg?
258             # still, let's handle gracefully
259 14         33 $attr_name = q/ attr_id IS NOT NULL /;
260 14         39 $ids = [];
261             }
262              
263 41 100       263 if ($source) {
264 2         7 $source =~ s{'}{''}gsm; # sql escape single quote
265 2         9 $source = qq/ AND source = '$source' /;
266             }
267 41         85 my $qids = q{};
268 41 100       132 if ($catgs) {
269 4         19 $catgs = _get_ids_if_catgs_exist($catgs);
270 4         266 my $qid_ref = _get_quote_id_from_catg_id($catgs);
271 4         1565 $qids = join ',', @{_untaint_data($qid_ref)};
  4         16  
272 4         34 $qids = qq/ AND quot_id IN ($qids) /;
273             }
274              
275 41         177 ($lower, $upper) = _get_if_rating($lower, $upper);
276              
277 41 100       234 if ($contain) { $contain = qq/ AND quote LIKE '%$contain%' / }
  3         12  
278 41 100       682 if ($limit) { $limit = qq/ LIMIT '$limit' / };
  5         19  
279              
280 41         731 my @q = Quote->retrieve_from_sql(
281             qq{ $attr_name $lower $upper $source $qids $contain $limit },
282 41         305 @{$ids}
283             );
284              
285             # XXX code duplication but smaller footprint
286             # choosing not less code duplication, we'll see,...
287             #my $quotes_ref = [];
288             #foreach my $q_obj ( @q ){
289             # next unless $q_obj->quote;
290             # my $record = Attr->retrieve($q_obj->attr_id);
291             # my $attr_name = $record->name || q{};
292             # push @{ $quotes_ref }, $q_obj->quote . "\n-- $attr_name";
293             #}
294             #return _get_quote_ref_from_all(\@q);
295             # XXX array_ref does not work here!
296 41         62196 return _get_quote_ref_from_all(@q);
297              
298             #return $quotes_ref;
299             }
300              
301             sub _get_quote_ref_from_all {
302 45     45   14056 my (@results) = @_;
303             #my ($results) = @_;
304              
305 45         112 my $quotes_ref = [];
306             #foreach my $q_obj ( @{$results} ){
307 45         131 foreach my $q_obj ( @results ){
308 236 50       17660 next unless $q_obj->quote;
309 236         231247 my $rec = Attr->retrieve($q_obj->attr_id);
310 236   50     259050 my $attr_name = $rec->name || q{};
311 236         200549 push @{ $quotes_ref }, $q_obj->quote . "\n-- $attr_name";
  236         1031  
312             }
313              
314 45         4228 return $quotes_ref;
315             }
316              
317             sub _args_are_valid {
318 58     58   136 my ( $arg_ref, $accepted ) = @_;
319              
320 58         126 my $arg_ok = 0;
321 58         137 foreach my $arg ( %{$arg_ref} ) {
  58         317  
322 178 100       366 if ( scalar grep { $arg =~ $_ } @{$accepted} ) {
  798         8579  
  178         410  
323 85         225 $arg_ok = 1;
324             }
325             }
326              
327 58 100       296 if (!$arg_ok) {croak 'unsupported argument option passed'}
  4         606  
328             }
329              
330             sub add_quote {
331 3     3 1 1650 my ( $self, $arg_ref ) = @_;
332              
333 3         20 _args_are_valid($arg_ref, [qw/Quote AttrName Source Rating Category/]);
334              
335 3         40 my $load_db = ACME::QuoteDB::LoadDB->new({
336             #verbose => 1,
337             });
338              
339 3         21 $load_db->set_record(quote => $arg_ref->{Quote});
340 3         15 $load_db->set_record(name => $arg_ref->{AttrName});
341 3         14 $load_db->set_record(source => $arg_ref->{Source});
342 3         13 $load_db->set_record(catg => $arg_ref->{Category});
343 3         13 $load_db->set_record(rating => $arg_ref->{Rating});
344              
345 3 100 66     19 if ($load_db->get_record('quote') and $load_db->get_record('name')) {
346 2         13 return $load_db->write_record;
347             }
348             else {
349 1         240 croak 'quote and attribution name are mandatory parameters';
350             }
351              
352 0         0 return;
353             }
354              
355             # XXX lame, can only get an id from exact quote
356             sub get_quote_id {
357 2     2 1 852 my ( $self, $arg_ref ) = @_;
358              
359 2 50       11 if (not $arg_ref) {croak 'Quote required'}
  0         0  
360              
361 2         12 _args_are_valid($arg_ref, [qw/Quote/]);
362              
363 2         10 my $ids = _get_quote_id_from_quote($arg_ref->{'Quote'});
364              
365 2         4 return join "\n", sort @{$ids};
  2         15  
366             }
367              
368             sub update_quote {
369 1     1 1 4 my ( $self, $arg_ref ) = @_;
370              
371 1 50       6 if (not $arg_ref) {croak 'QuoteId and Quote required'}
  0         0  
372              
373 1         7 _args_are_valid($arg_ref, [qw/Quote QuoteId Source
374             Category Rating AttrName/]);
375              
376 1         20 my $q = Quote->retrieve($arg_ref->{'QuoteId'});
377              
378 1         1108 my $atr = Attr->retrieve($q->attr_id);
379              
380             # XXX need to support multi categories
381             #my $ctg = Catg->retrieve($q->catg_id);
382 1         1994 my $qc = QuoteCatg->retrieve($q->quot_id);
383              
384 1         1232 my $ctg = Catg->retrieve($qc->catg_id);
385              
386 1         1850 $q->quote($arg_ref->{'Quote'});
387              
388 1 50       459 if ($arg_ref->{'Source'}){$q->source($arg_ref->{'Source'})}
  1         8  
389              
390 1 50       368 if ($arg_ref->{'Rating'}){$q->rating($arg_ref->{'Rating'})};
  1         7  
391              
392 1 50       340 if ($arg_ref->{'AttrName'}){$atr->name($arg_ref->{'AttrName'})};
  1         6  
393              
394             # XXX need to support multi categories
395 1 50       374 if ($arg_ref->{'Category'}){
396 1         7 $ctg->catg($arg_ref->{'Category'})
397             }
398              
399 1   33     379 return ($q->update && $atr->update && $ctg->update);
400             }
401              
402             sub delete_quote {
403 2     2 1 1375 my ( $self, $arg_ref ) = @_;
404              
405 2 50       11 if (not $arg_ref) {croak 'QuoteId required'}
  0         0  
406              
407 2         13 _args_are_valid($arg_ref, [qw/QuoteId/]);
408              
409 2         24 my $q = Quote->retrieve($arg_ref->{'QuoteId'});
410              
411             #$q->quote($arg_ref->{'QuoteId'});
412              
413 2         1873 return $q->delete;
414              
415             }
416              
417             sub get_quote {
418 28     28 1 6767 my ( $self, $arg_ref ) = @_;
419              
420             # default use case, return random quote from all
421 28 100       136 if (not $arg_ref) {
422 4         20 return _get_one_rand_quote_from_all;
423             }
424              
425 24         160 _args_are_valid($arg_ref, [qw/Rating AttrName Source Category/]);
426              
427 21         86 my ($lower, $upper) = (q{}, q{});
428 21 100       294 if ($arg_ref->{'Rating'}) {
429 5         30 ($lower, $upper) = _get_rating_params($arg_ref->{'Rating'});
430             }
431              
432 21         62 my $attr_name = q{};
433 21 100       88 if ( $arg_ref->{'AttrName'} ) {
434 13         61 $attr_name = _rm_beg_end_space($arg_ref->{'AttrName'});
435             }
436              
437 21         56 my $source = q{};
438 21 100       83 if ( $arg_ref->{'Source'} ) {
439 2         11 $source = _rm_beg_end_space($arg_ref->{'Source'});
440             }
441              
442 21         42 my $catg; # will become scalar or array ref
443 21 100       88 if ( $arg_ref->{'Category'} ) {
444 3         14 $catg = _rm_beg_end_space($arg_ref->{'Category'});
445             }
446              
447             # use case for attribution, return random quote
448 21         85 my $quotes_ref =
449             _get_rand_quote_for_attribution($attr_name, $lower,
450             $upper, q{}, q{}, $source, $catg);
451              
452             # one random from specified pool
453 19         560 return $quotes_ref->[rand scalar @{$quotes_ref}];
  19         304  
454              
455             }
456              
457             # XXX isn't there a method in DBI for this, bind something,...
458             # TODO follow up
459             sub _make_correct_num_of_sql_placeholders {
460 41     41   89 my ($ids) = @_;
461             # XXX a hack to make a list of '?' placeholders
462 41         95 my @qms = ();
463 41         94 for (1..scalar @{$ids}) {
  41         154  
464 114         281 push @qms, '?';
465             }
466 41         193 return join ',', @qms;
467             }
468              
469             sub get_quotes {
470 22     22 1 19647 my ( $self, $arg_ref ) = @_;
471              
472             # default use case, return random quote from all
473 22 50       105 if (not $arg_ref) {
474 0         0 return _get_one_rand_quote_from_all;
475             }
476              
477 22         145 _args_are_valid($arg_ref, [qw/Rating AttrName Limit Category Source/]);
478              
479 21         67 my ($lower, $upper) = (q{}, q{});
480 21 100       96 if ($arg_ref->{'Rating'}) {
481 6         30 ($lower, $upper) = _get_rating_params($arg_ref->{'Rating'});
482             }
483              
484 21         44 my $limit = q{};
485 21 100       89 if ($arg_ref->{'Limit'}) {
486             # specify 'n' amount of quotes to limit by
487 3         13 $limit = _rm_beg_end_space($arg_ref->{'Limit'});
488             }
489              
490 21         53 my $attribution = q{};
491 21 100       69 if ( $arg_ref->{'AttrName'} ) {
492 17         75 $attribution = _rm_beg_end_space($arg_ref->{'AttrName'});
493             }
494              
495 21         49 my $source = q{};
496 21 50       92 if ( $arg_ref->{'Source'} ) {
497 0         0 $source = _rm_beg_end_space($arg_ref->{'Source'});
498             }
499              
500 21         45 my $catg = q{};
501 21 100       75 if ( $arg_ref->{'Category'} ) {
502 1         5 $catg = _rm_beg_end_space($arg_ref->{'Category'});
503             }
504             # use case for attribution, return random quote
505 21         85 return _get_rand_quote_for_attribution($attribution, $lower,
506             $upper, $limit, q{}, $source, $catg);
507              
508             }
509              
510              
511             sub get_quotes_contain {
512 4     4 1 2408 my ( $self, $arg_ref ) = @_;
513              
514              
515 4         12 my $contain = q{};
516 4 50       18 if ($arg_ref->{'Contain'}) {
517 4         17 $contain = _rm_beg_end_space($arg_ref->{'Contain'});
518             }
519             else {
520 0         0 croak 'Contain is a mandatory parameter';
521             }
522              
523 4         19 _args_are_valid($arg_ref, [qw/Contain Rating AttrName Limit/]);
524              
525 4         13 my ($lower, $upper) = (q{}, q{});
526 4 100       16 if ($arg_ref->{'Rating'}) {
527 2         8 ($lower, $upper) = _get_rating_params($arg_ref->{'Rating'});
528             }
529              
530 3         9 my $limit = q{};
531 3 100       11 if ($arg_ref->{'Limit'}) {
532 2         7 $limit = _rm_beg_end_space($arg_ref->{'Limit'});
533             }
534              
535             # default use case for attribution, return random quote
536 3         6 my $attr_name = q{};
537 3 100       11 if ( $arg_ref->{'AttrName'} ) {
538             # return 'n' from random from specified pool
539 1         5 $attr_name = _rm_beg_end_space($arg_ref->{'AttrName'});
540             }
541              
542 3         11 return _get_rand_quote_for_attribution($attr_name, $lower, $upper, $limit, $contain);
543             }
544              
545             1 and 'Chief Wiggum: Uh, no, you got the wrong number. This is 9-1... 2.';
546              
547              
548             __END__