File Coverage

blib/lib/Decaptcha/TextCaptcha.pm
Criterion Covered Total %
statement 107 108 99.0
branch 74 76 97.3
condition 174 183 95.0
subroutine 21 21 100.0
pod 1 1 100.0
total 377 389 96.9


line stmt bran cond sub pod time code
1             package Decaptcha::TextCaptcha;
2              
3 2     2   91686 use 5.010;
  2         9  
  2         83  
4 2     2   12 use strict;
  2         5  
  2         75  
5 2     2   14 use warnings;
  2         99  
  2         132  
6 2     2   13 use Exporter qw(import);
  2         3  
  2         88  
7              
8 2     2   2081 use Lingua::EN::Words2Nums;
  2         6335  
  2         298  
9 2     2   18 use List::Util qw(first max min);
  2         13  
  2         1683  
10              
11             our $VERSION = '0.01';
12             $VERSION = eval $VERSION;
13              
14             our @EXPORT = qw(decaptcha);
15              
16             my %body_part = map { $_ => 1 } qw(
17             ankle arm brain chest chin ear elbow eye face finger foot hair hand head
18             heart knee leg nose stomach thumb toe tongue tooth waist
19             );
20             my %head_part = map { $_ => 1 } qw(
21             brain chin ear eye face hair head mouth nose tooth
22             );
23             my %multiple_part = map { $_ => 1 } qw(
24             ankle arm ear elbow eye finger foot hand knee leg thumb toe tooth
25             );
26             my %part_above_waist = map { $_ => 1 } qw(
27             arm brain chest chin ear elbow eye face finger foot hair hand head heart
28             mouth nose stomach thumb tongue tooth
29             );
30             my %part_below_waist = map {$_ => 1} qw( ankle foot knee leg toe );
31              
32             my %colors = map { $_ => 1 } qw(
33             black blue brown green pink purple red white yellow
34             );
35              
36             my @days = qw(sunday monday tuesday wednesday thursday friday saturday);
37             my %days; @days{@days} = (0 .. @days);
38             my %weekend = map { $_ => 1 } @days[0,6];
39              
40              
41             sub decaptcha {
42 120 100   120 1 106266 my $q = shift or return;
43 118         333 my $lq = lc $q;
44              
45             # Words and letters
46 118 100       273 if ($lq eq 'which word in this sentence is all in capitals?') {
47 2     11   43 my $word = first { ! tr/a-z// } split /\W+/, $q;
  11         20  
48 2 100       21 return $word ? lc $word : undef;
49             }
50 116 100 100     789 if ($lq =~ /^(?:the word )?"(.*?)" has how many letters\?$/
51             or $lq =~ /^how many letters in (?:the word )?"(.*?)"\?$/
52             ) {
53 2         16 return length $1;
54             }
55 114 100 100     1028 if ($q =~ /^The word in capitals from (.*?) is\?$/
      100        
56             or $q =~ /^Which word is all in capitals: (.*?)\?$/
57             or $q =~ /^Which of (.*?) is in capitals\?$/
58             ) {
59 4     8   120 my $word = first { ! tr/a-z// } split /(?:,\s*| or )/, $1;
  8         100  
60 4 100       33 return $word ? lc $word : undef;
61             }
62 110 100 100     1330 if ($lq =~ /^which word starts with "(?.)" from the list: (?.*?)\?$/
      100        
      100        
63             or $lq =~ /which word from list "(?.*?)" has "(?.)" as a first letter\?$/
64             or $lq =~ /^what word from "(?.*?)" begins with "(?.)"\?$/
65             or $lq =~ /^(?.*?): the word starting with "(?.)" is\?$/
66             ){
67 2     2   1929 return first { $+{c} eq substr $_, 0, 1 } split /,\s*/, $+{l};
  2     14   1206  
  2         6980  
  6         170  
  14         96  
68             }
69 104 100 100     1042 if ($lq =~ /^which word contains "(?[a-z])" from the list: (?.*?)\?$/
      100        
      100        
70             or $lq =~ /^(?.*?): the word containing the letter "(?[a-z])" is\?$/
71             or $lq =~ /^what word from "(?.*?)" contains the letter "(?[a-z])"\?$/
72             or $lq =~ /^which word from list "(?.*?)" contains the letter "(?[a-z])"\?$/
73             ) {
74 5     14   114 return first { 0 <= index $_, $+{c} } split /,\s*/, $+{l};
  14         86  
75             }
76 99 100 100     1512 return $1 if $lq =~ /^the word "(.).*?" starts with which letter\?$/
      100        
      100        
      100        
77             or $lq =~ /^the letter at the beginning of the word "(.).*?" is\?$/
78             or $lq =~ /^the word "(.).*?" has which letter at the start\?$/
79             or $lq =~ /^the (?:last|final) letter of word ".*?(.)" is\?$/
80             or $lq =~ /^the word ".*?(.)" has which letter at the end\?$/;
81 93 100 100     442 if ($lq =~ /^the (?

\d+)\S+ letter in (?:the word )?"(?.*?)" is\?$/

82             or $lq =~ /^the word "(?.*?)" has which letter in (?

\d+)\S+ position\?$/

83             ) {
84              
85 3 100       62 return $+{p} > length $+{w} ? undef : substr $+{w}, $+{p} - 1, 1;
86             }
87              
88             # Days of week
89 90 100 100     833 if ($lq =~ /^tomorrow is (\w+)\. if this is true, what day is today\?$/
      100        
90             or $lq =~ /^if tomorrow is (\w+), what day is today\?$/
91             or $lq =~ /^what day is today, if tomorrow is (\w+)\?$/
92             ) {
93 4 100       38 return exists $days{$1} ? $days[ ($days{$1} - 1) % 7 ] : undef;
94             }
95 86 100 100     981 if ($lq =~ /^yesterday was (\w+)\. if this is true, what day is today\?$/
      100        
96             or $lq =~ /^if yesterday was (\w+), what day is today\?$/
97             or $lq =~ /^what day is today, if yesterday was (\w+)\?$/
98             ) {
99 4 100       31 return exists $days{$1} ? $days[ ($days{$1} + 1) % 7 ] : undef;
100             }
101 82 100 100     1072 if ($lq =~ /^which of these is a day of the week: (.*?)\?$/
      100        
      100        
      100        
102             or $lq =~ /^which of (.*?) is a day of the week\?$/
103             or $lq =~ /^which of (.*?) is the name of a day\?$/
104             or $lq =~ /^the day of the week in (.*?) is\?$/
105             or $lq =~ /^(.*?): the day of the week is\?$/
106             ) {
107 6     18   69 return first { exists $days{$_} } split /\W+/, $1;
  18         44  
108             }
109 76 100       196 if ($lq =~ /^(.*?) is part of the weekend\?$/) {
110 4     17   48 return first { $weekend{$_} } split /\W+/, $1;
  17         98  
111             }
112              
113             # Names
114 72 100 100     1956 return $1 if $lq =~ /^(\w+)'s? name is\?$/
      100        
      100        
115             or $lq =~ /^what is (\w+)'s? name\?$/
116             or $lq =~ /^the name of (\w+) is\?$/
117             or $lq =~ /^if a person is called (\w+), what is their name\?$/;
118 68 100 100     830 if ($q =~ /^The person's firstname in (.*?) is\?$/
      100        
      66        
      100        
119             or $q =~ /^Which in this list is the name of a person: (.*?)\?$/
120             or $q =~ /^(.*?): the person's name is\?$/
121             or $q =~ /^Which of (.*?) is the name of a person\?$/
122             or $q =~ /^Which of (.*?) is a person's name\?$/
123             ) {
124 6     26   135 my $name = first { /^[A-Z][a-z]+$/ } reverse split /\W+/, $1;
  26         52  
125 6 100       49 return $name ? lc $name : undef;
126             }
127              
128             # Colors
129 62 100 100     614 return $1 if $lq =~ /^the colour of a (\w+) \S+ is\?$/
      100        
130             or $lq =~ /^the (\w+) \S+ is what colour\?$/
131             or $lq =~ /^if the \S+ is (\w+), what colour is it\?$/;
132 59 100 100     577 if ($lq =~ /^how many colours in the list (.*?)\?$/
      100        
133             or $lq =~ /^the list (.*?) contains how many colours\?$/
134             or $lq =~ /^(.*?): how many colours in the list\?$/
135             ) {
136 4         37 return 0 + grep { $colors{$_} } split /\W+/, $1;
  22         58  
137             }
138 55 100 100     1619 if ($lq =~ /^which of these is a colour: (.*?)\?$/
      100        
      100        
139             or $lq =~ /^which of (.*?) is a colour\?$/
140             or $lq =~ /^(.*?): the colour is\?$/
141             or $lq =~ /^the colour in the list (.*?) is\?$/
142             ) {
143 5     23   59 return first { $colors{$_} } split /\W+/, $1;
  23         44  
144             }
145 50 100 66     512 if ($lq =~ /^what is the (?

\d+)\S+ colour in the list (?.*?)\?$/

      100        
146             or $lq =~ /^the (?

\d+)\S+ colour in (?.*?) is\?$/

147             or $lq =~ /^(?.*?): the (?

\d+)\S+ colour is\?$/

148             ) {
149 4         74 return (grep { $colors{$_} } split /\W+/, $+{l})[ $+{p} - 1 ];
  20         52  
150             }
151              
152             # Body parts
153 46 100 100     310 if ($lq =~ /^the number of body parts in the list (.*?) is\?$/
      100        
154             or $lq =~ /^the list (.*?) contains how many body parts\?$/
155             or $lq =~ /^(.*?): how many body parts in the list\?$/
156             ) {
157 4         28 return 0 + grep { $body_part{$_} } split /\W+/, $1;
  17         46  
158             }
159 42 100 100     996 if ($lq =~ /^the body part in (.*?) is\?$/
      100        
      100        
      100        
160             or $lq =~ /^which of these is a body part: (.*?)\?$/
161             or $lq =~ /^which of (.*?) is a body part\?$/
162             or $lq =~ /^which of (.*?) is part of a person\?$/
163             or $lq =~ /^(.*?): the body part is\?$/
164             ) {
165 6     12   88 return first { $body_part{$_} } split /(?:,\s*| or )/, $1;
  12         41  
166             }
167 36 100       272 if ($lq =~ /^(.*?) is part of the head\?$/) {
168 3     11   61 return first { $head_part{$_} } split /\W+/, $1;
  11         27  
169             }
170 33 100       90 if ($lq =~ /^(.*?) is something each person has more than one of\?$/) {
171 3     15   37 return first { $multiple_part{$_} } split /\W+/, $1;
  15         31  
172             }
173 30 100       97 if ($lq =~ /^(.*?) is above the waist\?$/) {
174 3     13   40 return first { $part_above_waist{$_} } split /\W+/, $1;
  13         26  
175             }
176 27 100       80 if ($lq =~ /^(.*?) is below the waist\?$/) {
177 3     12   41 return first { $part_below_waist{$_} } split /\W+/, $1;
  12         26  
178             }
179              
180             # Numbers and digits
181 24 100 66     137 if ($lq =~ /^enter the number (.*?) in digits:$/
182             or $lq =~ /^what is (.*?) as (?:digits|a number)\?$/
183             ) {
184 1         8 return words2nums $1;
185             }
186 23 100 66     192 if ($lq =~ /^which digit is (?

\d+)\S+ in the number (?\d+)\?$/

      100        
187             or $lq =~ /^what is the (?

\d+)\S+ digit in (?\d+)\?$/

188             or $lq =~ /^in the number (?\d+), what is the (?

\d+)\S+ digit\?$/

189             ) {
190 4 100       124 return $+{p} > length $+{n} ? undef : substr $+{n}, $+{p} - 1, 1;
191             }
192 19 100 100     453 if ($lq =~ /^the (?

\d+)\S+ number from (?.*?) is\?$/

      100        
      100        
193             or $lq =~ /^what is the (?

\d+)\S+ number in the list (?.*?)\?$/

194             or $lq =~ /^what number is (?

\d+)\S+ in the series (?.*?)\?$/

195             or $lq =~ /^(?.*?): the (?

\d+)\S+ number is\?$/

196             ) {
197 5         92 my @nums = map { words2nums $_ } split /(?:,\s*| and )/, $+{l};
  19         430  
198 5         383 return $nums[ $+{p} - 1 ];
199             }
200 14         27 state $biggest_re = qr/(?:biggest | largest | highest)/x;
201 14 100 100     2004 if ($lq =~ /^enter the $biggest_re number of (.*?):$/
      100        
      100        
      100        
202             or $lq =~ /^of the numbers (.*?), which is the $biggest_re\?$/
203             or $lq =~ /^which of (.*?) is the $biggest_re\?$/
204             or $lq =~ /^(.*?): which of these is the $biggest_re\?$/
205             or $lq =~ /^(.*?): the $biggest_re is\?$/
206             ) {
207 5         59 return max map { words2nums $_ } split /(?:,\s*| or )/, $1;
  22         720  
208             }
209 9         20 state $smallest_re = qr/(?:smallest | lowest)/x;
210 9 100 100     939 if ($lq =~ /^enter the $smallest_re number of (.*?):$/
      100        
      100        
      100        
211             or $lq =~ /^of the numbers (.*?), which is the $smallest_re\?$/
212             or $lq =~ /^which of (.*?) is the $smallest_re\?$/
213             or $lq =~ /^(.*?): which of these is the $smallest_re\?$/
214             or $lq =~ /^(.*?): the $smallest_re is\?$/
215             ) {
216 5         55 return min map { words2nums $_ } split /(?:,\s*| or )/, $1;
  22         613  
217             }
218 4 50 33     37 if ($lq =~ /^(.*?) (?:= |equals |is what)\?$/
219             or $lq =~ /^what(?:'s| is) (.*?)\?$/
220             ) {
221 4         11 my $expr = $1;
222 4   66     36 s/\b(?:add|plus)\b/+/ or s/\bminus\b/-/ for $expr;
223 4   33     253 $expr =~ s{\b(\w+)\b}{ words2nums($1) // $1 }eg;
  8         688  
224 4 50       629 return eval $expr if $expr =~ /^[ \d+-]+$/;
225             }
226              
227 0           return;
228             }
229              
230              
231             1;
232              
233             __END__