File Coverage

blib/lib/Acme/AsciiArtFarts.pm
Criterion Covered Total %
statement 9 69 13.0
branch 0 20 0.0
condition 0 6 0.0
subroutine 3 12 25.0
pod 6 6 100.0
total 18 113 15.9


line stmt bran cond sub pod time code
1             package Acme::AsciiArtFarts;
2              
3 1     1   37530 use warnings;
  1         2  
  1         25  
4 1     1   4 use strict;
  1         1  
  1         27  
5 1     1   2351 use LWP;
  1         55940  
  1         796  
6              
7             =head1 NAME
8              
9             Acme::AsciiArtFarts - Simple Object Interface to AsciiArtFarts
10              
11             =head1 VERSION
12              
13             Version 0.01
14              
15             =cut
16              
17             our $VERSION = '0.03';
18              
19             =head1 SYNOPSIS
20              
21             This package provides a simple object orientated interface to AsciiArtFarts - a
22             website focussed on Ascii Art humour.
23              
24             use Acme::AsciiArtFarts;
25              
26             my $aaf = Acme::AsciiArtFarts->new();
27              
28             my $current = $aaf->current();
29             print $current;
30              
31             =head1 METHODS
32              
33             =head2 new
34              
35             Constructor - creates a new Acme:AsciiArtFarts object. This method takes no arguments.
36              
37             =cut
38              
39             sub new {
40 0     0 1   my $class = shift;
41 0           my $self = {};
42 0           bless $self, $class;
43 0           $self->{ua} = LWP::UserAgent->new();
44 0           $self->{uri} = 'http://www.asciiartfarts.com';
45 0           $self->{req} = HTTP::Request->new(GET => $self->{uri});
46 0           $self->__get_keywords;
47 0           $self->{cur_key}= '';
48 0           $self->{cur_num}= 0;
49 0           $self->{key_arr}= ();
50 0           return $self
51             }
52              
53             =head2 current
54              
55             print $aaf->current();
56              
57             Returns the current strip.
58              
59             =cut
60              
61             sub current {
62 0     0 1   return $_[0]->__request('/today.txt')
63             }
64              
65             =head2 random
66              
67             print $aaf->random();
68              
69             Returns a random strip.
70              
71             =cut
72              
73             sub random {
74 0     0 1   return __parse($_[0]->__request('/random.cgi'));
75             }
76              
77             =head2 list_keywords
78              
79             print join " ", $aaf->list_keywords();
80              
81             Returns a list of all keywords by which strips are sorted.
82              
83             =cut
84              
85             sub list_keywords {
86 0     0 1   return sort keys %{$_[0]->{keywords}}
  0            
87             }
88              
89             =head2 list_by_keyword
90              
91             my @art = $aaf->list_by_keyword('matrix');
92              
93             Returns a list of strip numbers for the given keyword.
94              
95             =cut
96              
97             sub list_by_keyword {
98 0     0 1   my ($self,$keyword)= @_;
99 0 0         exists $self->{keywords}->{$keyword} or return 0;
100 0           return @{$self->{keywords}{$keyword}{strips}};
  0            
101             }
102              
103             =head2 get_by_num
104              
105             print $aaf->get_by_num($art[0]);
106              
107             print $aaf->get_by_num(int rand 1000);
108              
109             Given a strip number as returned by other methods, return the requested strip.
110              
111             Alternately, given an integer value that is a valid strip number, return the requested strip.
112              
113             =cut
114              
115             sub get_by_num {
116 0     0 1   my ($self,$num) =@_;
117 0 0         $num =~ /^#/ or $num = '#'.$num;
118 0           return __parse($self->__request("/$self->{strips}{$num}{page}"))
119             }
120              
121             sub __get_keywords {
122 0     0     my $self= shift;
123 0           my $itr = 0;
124 0           my @html= split /\n/, $self->__request('/keyword.html');
125              
126 0           for ($itr=0;$itr<@html;$itr++) {
127 0           $_ = $html[$itr];
128 0 0         next unless /^
  • 129
    		• 0           my($key,$page,$count) = /^ \((.*)\)/;
    130 0           $self->{keywords}{$key}{count} = $count;
    131 0           $self->{keywords}{$key}{page} = $page;
    132            
    133 0           while ($itr++) {
    134 0           $_ = $html[$itr];
    135 0 0         next if /^
      /;
    136 0 0         last if /^<\/ul>/;
    137 0 0         last if $itr > 1_000_000;
    138 0           my($num,$page,$name,$date) = /^
  • (.*?):.*ref="(.*?)">(.*?)<.*l>(.*)
    • 139 0           push @{$self->{keywords}{$key}{strips}}, $num;
      0            
    140 0           $self->{strips}{$num}{name} = $name;
    141 0           $self->{strips}{$num}{page} = $page;
    142 0           $self->{strips}{$num}{date} = $date;
    143 0           $self->{strips}{$num}{keyword} = $key;
    144             }
    145             }
    146             }
    147              
    148             sub __request {
    149 0     0     my($self,$rl) = @_;
    150 0           $rl |= '';
    151 0           my $res = $self->{ua}->get($self->{uri}.$rl);
    152 0 0         $res->is_success and return $res->content;
    153 0           $self->{error} = 'Unable to retrieve content: ' . $res->status_line;
    154 0           return 0
    155             }
    156              
    157             sub __parse {
    158 0     0     my @html = split /\n/, $_[0];
    159 0           my $found = 0;
    160 0           my $res;
    161              
    162 0           foreach (@html) {
    163 0 0 0       next unless /^/ or $found;
    164 0           $found = 1;
    165 0 0         next if /^
    166 0 0 0       return $res if /^<\/pre>/ and $found;
    167 0           s/</
    168 0           s/>/>/g;
    169 0           $res .= "$_\n";
    170             }
    171             }
    172              
    173             =head1 AUTHOR
    174              
    175             Luke Poskitt, C<< >>
    176              
    177             =head1 BUGS
    178              
    179             Please report any bugs or feature requests to C, or through
    180             the web interface at L. I will be notified, and then you'll
    181             automatically be notified of progress on your bug as I make changes.
    182              
    183              
    184              
    185              
    186             =head1 SUPPORT
    187              
    188             You can find documentation for this module with the perldoc command.
    189              
    190             perldoc Acme::AsciiArtFarts
    191              
    192              
    193             You can also look for information at:
    194              
    195             =over 4
    196              
    197             =item * RT: CPAN's request tracker
    198              
    199             L
    200              
    201             =item * AnnoCPAN: Annotated CPAN documentation
    202              
    203             L
    204              
    205             =item * CPAN Ratings
    206              
    207             L
    208              
    209             =item * Search CPAN
    210              
    211             L
    212              
    213             =back
    214              
    215              
    216             =head1 ACKNOWLEDGEMENTS
    217              
    218              
    219             =head1 LICENSE AND COPYRIGHT
    220              
    221             Copyright 2011 Luke Poskitt.
    222              
    223             This program is free software; you can redistribute it and/or modify it
    224             under the terms of either: the GNU General Public License as published
    225             by the Free Software Foundation; or the Artistic License.
    226              
    227             See http://dev.perl.org/licenses/ for more information.
    228              
    229              
    230             =cut
    231              
    232             1;
    233              
    234