File: reCAPTCHA.pm

package info (click to toggle)
libhtml-formfu-perl 0.09007-1
  • links: PTS, VCS
  • area: main
  • in suites: wheezy
  • size: 4,184 kB
  • sloc: perl: 13,186; makefile: 9; sql: 5
file content (105 lines) | stat: -rw-r--r-- 2,580 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
package HTML::FormFu::Constraint::reCAPTCHA;

use Moose;
extends 'HTML::FormFu::Constraint';

use Captcha::reCAPTCHA;
use Scalar::Util qw( blessed );

has _recaptcha_response => ( is => 'rw' );

sub process {
    my ( $self, $params ) = @_;

    # check when condition
    return unless $self->_process_when($params);

    # we need the original query object, as the recaptcha fields aren't
    # real formfu fields, so they won't be in $params
    my $query = $self->form->query;

    my $challenge = $query->param('recaptcha_challenge_field');
    my $response  = $query->param('recaptcha_response_field');

    # constraints are only run if submitted() is true.
    # the recaptcha fields have an implicit Required constraint
    # so throw an error if either field is missing
    if ( !$challenge || !$response ) {
        return $self->mk_errors( {} );
    }

    # check if it's already been run - as a 2nd check to recaptcha.net
    # will otherwise always fail
    my $previous_response = $self->_recaptcha_response;

    if ($previous_response) {
        if ( $previous_response ne 'true' ) {
            return $self->mk_errors( { message => $previous_response, } );
        }
        else {

            # the previous response was OK, so return with no errors
            return;
        }
    }

    my $catalyst_compatible 
        = blessed($query)
        && $query->can('secure')
        && $query->can('address');

    my $captcha = Captcha::reCAPTCHA->new;
    my $privkey = $self->parent->private_key || $ENV{RECAPTCHA_PRIVATE_KEY};

    my $remoteip
        = $catalyst_compatible
        ? $query->address
        : $ENV{REMOTE_ADDR};

    my $result
        = $captcha->check_answer( $privkey, $remoteip, $challenge, $response, );

    # they're human!
    if ( $result->{is_valid} ) {
        $self->_recaptcha_response('true');
        return;
    }

    # response failed
    $self->_recaptcha_resonse( $result->{error} );

    return $self->mk_errors( { message => $result->{error}, } );
}

__PACKAGE__->meta->make_immutable;

1;

__END__

=head1 NAME

HTML::FormFu::Constraint::reCAPTCHA - not for direct use

=head1 DESCRIPTION

This constraint is automatically added by the
L<reCAPTCHA element|HTML::FormFu::Element::reCAPTCHA>, and should not be used
directly.

=head1 SEE ALSO

Is a sub-class of, and inherits methods from L<HTML::FormFu::Constraint>

L<HTML::FormFu>

=head1 AUTHOR

Carl Franks C<cfranks@cpan.org>

=head1 LICENSE

This library is free software, you can redistribute it and/or modify it under
the same terms as Perl itself.

=cut