File Coverage

blib/lib/Captcha/reCAPTCHA/V3.pm
Criterion Covered Total %
statement 63 88 71.5
branch 10 28 35.7
condition 14 37 37.8
subroutine 17 19 89.4
pod 7 9 77.7
total 111 181 61.3


line stmt bran cond sub pod time code
1             package Captcha::reCAPTCHA::V3;
2 4     4   484546 use 5.008001;
  4         11  
3 4     4   14 use strict;
  4         7  
  4         134  
4 4     4   13 use warnings;
  4         5  
  4         267  
5              
6             our $VERSION = "0.09";
7              
8 4     4   17 use Carp qw(carp croak);
  4         9  
  4         234  
9 4     4   1975 use JSON::PP qw(decode_json);
  4         45189  
  4         413  
10              
11             use overload(
12 3     3   8 '""' => sub { $_[0]->name() },
13 2     2   552 'cmp' => sub { $_[0]->name() cmp $_[1] },
14 4     4   23 );
  4         4  
  4         35  
15              
16             sub new {
17 4     4 1 381052 my $class = shift;
18 4   33     44 my $self = bless {}, ref $class || $class;
19 4         39 my %attr = @_;
20              
21             # Initialize the values for API
22 4   100     98 $self->{sitekey} = $attr{sitekey} || ''; # No need to set sitekey in server-side
23 4   33     19 $self->{secret} = $attr{secret} || croak "missing param 'secret'";
24 4   50     22 $self->{query_name} = $attr{query_name} || 'g-recaptcha-response';
25              
26 4         15 $self->{widget_api} = 'https://www.google.com/recaptcha/api.js';
27 4         11 $self->{verify_api} = 'https://www.google.com/recaptcha/api/siteverify';
28 4         12 return $self;
29             }
30              
31             sub name {
32 7     7 1 12 my $self = shift;
33 7 100       37 return $self->{query_name} unless my $value = shift;
34 1         2 $self->{query_name} = $value;
35             }
36              
37             sub sitekey {
38 1     1 1 2 my $self = shift;
39 1 50       4 return $self->{sitekey} unless my $value = shift;
40 1         3 $self->{sitekey} = $value;
41             }
42              
43             # verifiers =======================================================================
44             sub verify {
45 1     1 1 11 my $self = shift;
46 1         5 my $response = shift;
47 1 50       4 croak "Extra arguments have been set." if @_;
48              
49 1 50       11 if ( _has_curl() ) {
    0          
50             my $cmd = sprintf(
51             q{curl -sS -X POST %s -d secret=%s -d response=%s},
52             $self->{verify_api},
53 1         36 _shell_escape($self->{secret_key}),
54             _shell_escape($response),
55             );
56              
57 1 50       135340 my $json = `$cmd`or croak "Failed to execute curl command: $cmd";
58 1         39 return decode_json($json);
59             }elsif ( !_has_lwp_https() ) {
60 0         0 croak "LWP::UserAgent and LWP::Protocol::https are required to verify reCAPTCHA response.";
61             }
62              
63 0 0       0 eval {
64 0         0 require LWP::UserAgent;
65 0         0 require LWP::Protocol::https;
66             } or croak "LWP::UserAgent and LWP::Protocol::https are required to verify reCAPTCHA response.";
67              
68 0         0 my $ua = LWP::UserAgent->new;
69             my $res = $ua->post(
70             $self->{verify_api},{
71             secret => $self->{secret_key},
72 0         0 response => $response,
73             },
74             );
75              
76 0         0 my $json = $res->decoded_content;
77 0         0 return decode_json($json);
78             }
79              
80             sub deny_by_score {
81 0     0 1 0 my $self = shift;
82 0         0 my %attr = @_;
83 0   0     0 my $response = $attr{response} || croak "missing response token";
84 0   0     0 my $score = $attr{score} || 0.5;
85 0 0 0     0 croak "invalid score was set: $score" if $score < 0 or 1 < $score;
86              
87 0         0 my $content = $self->verify($response);
88 0 0 0     0 if ( $content->{success} and $content->{score} == 1 || $content->{score} < $score ) {
      0        
89 0         0 unshift @{ $content->{'error-codes'} }, 'too-low-score';
  0         0  
90 0         0 $content->{success} = 0;
91             }
92 0         0 return $content;
93             }
94              
95             sub verify_or_die {
96 0     0 1 0 my $self = shift;
97 0         0 my $content = $self->deny_by_score(@_);
98 0 0       0 return $content if $content->{success};
99 0         0 die 'fail to verify reCAPTCHA: ', $content->{'error-codes'}[0], "\n";
100             }
101              
102             # aroud javascript =======================================================================
103             sub scriptURL {
104 9     9 0 15 my $self = shift;
105 9         16 my %attr = @_;
106 9   66     263 my $sitekey = $attr{sitekey} || $self->{sitekey} || croak "missing 'sitekey'";
107 7         24 return $self->{widget_api} . "?render=$sitekey";
108             }
109              
110             sub scriptTag {
111 7     7 0 13 my $self = shift;
112 7         13 my %attr = @_;
113 7   66     194 my $sitekey = $attr{sitekey} || $self->{sitekey} || croak "missing 'sitekey'";
114 5         10 my $url = $self->scriptURL( sitekey => $sitekey );
115 5         14 return qq||;
116             }
117              
118             sub scripts {
119 5     5 1 8 my $self = shift;
120 5         17 my %attr = @_;
121 5   66     220 my $sitekey = $attr{sitekey} || $self->{sitekey} || croak "missing 'sitekey'";
122 3         20 my $simple = $self->scriptTag(@_);
123 3 50       9 my $id = $attr{'id'} or croak "missing the id for Form tag";
124 3   50     7 my $action = $attr{'action'} || 'homepage';
125 3 100       6 my $comment = $attr{'debug'} ? '' : '// ';
126 3         15 return <<"EOL";
127             $simple
128            
142             EOL
143             }
144              
145             # utils =======================================================================
146             sub _shell_escape {
147 2     2   13 my ($s) = @_;
148 2   100     28 $s //= '';
149 2         9 $s =~ s/'/'"'"'/g;
150 2         44 return "'$s'";
151             }
152              
153             sub _has_curl {
154 1 50   1   23538 return 1 if system("curl --version >nul 2>&1") == 0; # Windows
155 0 0         return 1 if system("curl --version >/dev/null 2>&1") == 0; # Unix
156 0           return 0;
157             }
158              
159             1;
160             __END__