File Coverage

blib/lib/Test/FormValidator.pm

Criterion	Covered	Total	%
statement	213	213	100.0
branch	85	86	98.8
condition	35	40	87.5
subroutine	24	24	100.0
pod	12	12	100.0
total	369	375	98.4

package Test::FormValidator;

use warnings;
use strict;
use Carp;
use Data::FormValidator;
use Test::Builder ();
use Test::More ();
use Data::Dumper ();
use HTML::TokeParser::Simple ();

my $Test = Test::Builder->new;

sub import {
    my($self) = shift;
    my $pack  = caller;

    $Test->exported_to($pack);
    $Test->plan(@_);
}

=head1 NAME

Test::FormValidator - Test framework for Data::FormValidator profiles

=head1 VERSION

Version 0.07

=cut

our $VERSION = '0.07';

=head1 SYNOPSIS

    use Test::FormValidator 'no_plan';

    my $tfv = Test::FormValidator->new;

    $tfv->profile(WebApp->_change_password_profile);

    # check that the profile detects missing retyped password
    $tfv->check(
        'email'     => 'someone-at-example.com',
        'old_pass'  => 'seekrit',
        'new_pass1' => 'foo',
    );
    $tfv->missing_ok(['new_pass2'], "caught missing retyped password");

    # and that it detects missing fields
    $tfv->check(
        'email'     => 'someone-at-example.com',
        'old_pass'  => 'seekrit',
        'new_pass1' => 'foo',
        'new_pass2' => 'bar',
    );
    $tfv->invalid_ok([qw(email new_pass1 new_pass2)], "caught bad email & passwd");


=head1 DESCRIPTION

This is a module for testing your C profiles. It uses
the standard Perl test protocol (TAP) and prints out the familiar
C<'ok/not ok'> stuff you expect.

Basically it lets you use a test script to quickly throw a lot of
different input scenarios at your profiles and make sure they work
properly.

You can test for missing fields:

    # Test a profile that requires an email address and a password - if we
    # provide only a name, then the password should be flagged as missing
    $tfv->check(
        'email'       => '[e-mail]',
    );
    $tfv->missing_ok(['password'], "caught missing passwd");

You can also test for invalid fields:

    # Test a profile that should catch a bad email address
    $tfv->check(
        'email'       => 'test-at-example.com',
    );
    $tfv->invalid_ok(['email'], "caught bad email address");

And if you have custom constraint methods, you can confirm that they
each work properly:

    # Test a profile that requires passwords longer than 5 characters and
    # they have to contain both letters and numbers
    $tfv->check(
        'new_pass1' => 'foo',
        'new_pass2' => 'foo',
    );
    $tfv->invalid_ok(
    {
        'new_pass1' => [qw(too_short need_alpha_num)],
    },
    "caught short, non-alpha-numeric password");

And you can also test that the form fields in your HTML form match the
list of fields in your profile:

    $tfv->html_ok('/path/to/template.html', 'Template matches profile');


=head1 EXAMPLE

Here's a more complete example.  Assume you have a signup form with
these fields:

    name
    email
    pass1
    pass2
    newsletter

The form (C) might look vaguely like this:


     Name:
     Email:
     Password:
     Retype Password:
     Yummy SPAM?


In your web application, you test the input generated by this form using
a C profile like this:

    package WebApp;
    use Data::FormValidator::Constraints qw(:closures);

    sub _signup_profile {
        return {
            required => [ qw(
                name
                email
                pass1
                pass2
            ) ],
            optional => [ qw(
                newsletter
            ) ],
            dependencies => {
                pass1 => 'pass2',
            },
            constraint_methods => {
                # passwords must be longer than 5 characters
                pass1 => [
                    sub {
                        my ($dfv, $val) = @_;
                        $dfv->name_this('too_short');
                        return $val if (length $val) > 5;
                        return;
                    },
                    # passwords must contain both letters and numbers
                    sub {
                        my ($dfv, $val) = @_;
                        $dfv->name_this('need_alpha_num');
                        return $val if $val =~ /\d/ and $val =~ /[[:alpha:]]/;
                        return;
                    },
                ],
                # passwords must match
                pass2 => sub {
                    my ($dfv, $val) = @_;
                    $dfv->name_this('mismatch');
                    my $data = $dfv->get_input_data('as_hashref' => 1);
                    return $data->{'pass1'} if ($data->{'pass1'} || '') eq ($data->{'pass2'} || '');
                    return;
                },
                # email must be valid
                email => valid_email(),
            },
        };
    }


In your test script, you test the profile against various input
scenarios.  First test that the fields listed in the profile match the
fields that are actually present in the HTML form:

    use Test::FormValidator 'no_plan';

    my $tfv = Test::FormValidator->new;
    $tfv->profile(WebApp->_signup_profile);

    $tfv->html_ok('signup.html', 'Template matches profile');

    # Check for missing fields
    $tfv->check(); # empty form
    $tfv->missing_ok([qw(name email pass1 pass2)], 'caught missing fields');

    # check for invalid email, password
    $tfv->check(
        name  => 'Foo',
        email => 'foo-at-example.com',
        pass1 => 'foo',
        pass2 => 'bar',
    );
    $tfv->invalid_ok(
    {
        email => 'invalid'
        pass1 => [qw(too_short need_alpha_num)],
        pass2 => 'mismatch',
    },
    'caught invalid fields');


=head1 METHODS

=head2 Seting up the Validator

=over 4

=item new

You set up C by calling C.  You can pass any
arguments to new that you can pass to C.

For instance, to use default profile settings, you would use:

    my $tfv = Test::FormValidator->new({}, \%defaults);

=cut

sub new {
    my $class = shift;

    my $dfv  = Data::FormValidator->new(@_);

    my $self  = {
        '__DFV'             => $dfv,
        '__CURRENT_PROFILE' => undef,
        '__DFV_RESULTS'     => undef,
    };

    bless $self, $class;


}

=item profile(\%profile)

This sets up the current profile for all subsequent tests

    $tfv->profile(\%profile);

Typically, you will fetch the profile from your web application:

    $tfv->profile(Webapp->_some_profile);

You can switch profiles in the same script:

    $tfv->profile(Webapp->_first_profile);

    # ... run some tests ...

    $tfv->profile(Webapp->_second_profile);

    # ... run some other tests ...

You can also explicitly pass a profile to L.

=cut

sub profile {
    my $self = shift;
    $self->{'__CURRENT_PROFILE'} = shift if @_;
    return $self->{'__CURRENT_PROFILE'};
}

=item prefix('some text')

This is a convenience function to set some text to be printed at the
start of every test description.

It's useful to save typing:

    $tfv->profile(WebApp->_login_profile);
    $tfv->prefix('[login form] ');

    $tfv->check({
        'email'    => 'test-at-example.com',
    });

    $tfv->missing_ok(['password'], 'password missing');
    $tfv->invalid_ok(['email'], 'email invalid');

This prints out:

    ok 1 - [login form] password missing
    ok 2 - [login form] email invalid

You can switch prefixes in the same script; just call C with a
new value:

    $tfv->profile(Webapp->_first_profile);
    $tfv->prefix('FIRST: ');

    # ... run some tests ...

    $tfv->profile(Webapp->_second_profile);
    $tfv->prefix('SECOND: ');

    # ... run some other tests ...

To remove the prefix either pass a value of C:

    $tfv->prefix(undef);

or the empty string (C<''>):

    $tfv->prefix('');


=back

=cut

sub prefix {
    my $self = shift;
    $self->{'__CURRENT_PREFIX'} = shift if @_;
    return $self->{'__CURRENT_PREFIX'};
}

sub _format_description {
    my $self        = shift;
    my $description = shift;

    my $prefix = $self->prefix;
    if (defined $prefix and $prefix ne '') {
        $description = $prefix . $description;
    }
    return $description;
}


=head2 Checking the input

=over 4

=item check(%input)

This runs %input through the current profile, and returns a
C results object.

If you want to use a new profile for this check only, you can do so:

    $tfv->check(\%input, WebApp->_some_profile);

=cut

sub check {
    my $self = shift;

    my $input;
    my $profile;
    if (ref $_[0]) {
        $input = shift;
        if (@_) {
            $profile = shift;
        }
    }
    else {
        $input = { @_ };
    }

    my $dfv     = $self->{'__DFV'};
    $profile  ||= $self->profile   or croak "Test::FormValidator you need to set a profile before calling check";

    my $results = $dfv->check($input, $profile);

    $self->{'__DFV_RESULTS'} = $results;
    return $results;
}

=item results

Returns the C results object corresponding to the
most recent C, C, or C.  Throws an error
if there has not yet been a check.

    $tfv->check_not_ok(\%input, 'some comment');
    my $results = $tfv->results;

=back

=cut

sub results {
    my $self = shift;
    if (not exists $self->{'__DFV_RESULTS'} or not defined $self->{'__DFV_RESULTS'}) {
        croak "Test::FormValidator you need to call check, check_ok or check_not_ok before calling results";
    }
    return $self->{'__DFV_RESULTS'};
}


=head2 Test Methods

Methods ending in C<_ok> do the standard C thing:  on success,
they print out C<'ok'> and return a true value.  On failure, they print
out C<'not ok'> and return false.

=over 4

=item check_ok(%input, 'description')

Checks that the given input is valid:

    $tfv->check_ok(\%input, 'some comment');

This is the equivalent of:

    ok($tfv->check(\%input), 'some comment') or $tfv->diag;

It returns a C results object which is overloaded
to be true or false depending on the check of the test.

=cut

sub check_ok {
    my $self        = shift;
    my $input       = shift;
    my $description = shift;

    if (!$input or !(ref $input)) {
        croak "Test::FV: usage \$tfv->check_ok(\\%input, 'description')";
    }

    my $results = $self->check($input);

    if (!$results) {
        $self->diag;
    }

    $Test->ok($results, $self->_format_description($description));

    return $results;
}

=item check_not_ok(%input)

Checks that the given input is not valid:

    $tfv->check_not_ok(\%input, 'some comment');

This is the equivalent of:

    ok(!$tfv->check(\%input), 'some comment') or $tfv->diag;

=cut

sub check_not_ok {
    my $self        = shift;
    my $input       = shift;
    my $description = shift;

    if (!$input or !(ref $input)) {
        croak "Test::FV: usage \$tfv->check_not_ok(\\%input, 'description')";
    }

    my $results = $self->check($input);

    if ($results) {
        $self->diag;
    }

    return $Test->ok(!$results, $self->_format_description($description));
}

=item missing_ok(\@fields, 'description')

Checks C<\%input> against the current profile, and verifies that
C<@fields> are all flagged as missing, and that no other fields are
flagged as mising.

For example:

    $tfv->check(
        email => '[e-mail]',
    );
    $tfv->missing_ok(['password'], "caught missing password");

=cut

sub missing_ok {
    my $self        = shift;
    my $fields      = shift;
    my $description = shift;

    if (!$fields or ref $fields ne 'ARRAY') {
        croak "Test::FV: usage \$tfv->missing_ok(\\\@fields, 'description')";
    }

    my $results = $self->{'__DFV_RESULTS'};
    if (!defined $results) {
        croak "Test::FV: call check before missing_ok";
    }

    my @missing  = sort $results->missing;
    my @expected = sort @$fields;

    my $success = Test::More::eq_array(\@missing, \@expected);
    if (!$success) {
        $self->diag;
    }

    return $Test->ok($success, $self->_format_description($description));
}

=item invalid_ok(\@fields, 'description');

Checks C<\%input> against the current profile, and verifies that
C<@fields> are all flagged as invalid, and that no other fields are
flagged as invalid.

    $tfv->check(
        email => 'foo-at-example.com',
    );
    $tfv->invalid_ok(['email'], "caught invalid email address");


=item invalid_ok(\%fields_and_constraints, 'description');

Runs the current profile against C<\%input>, and verifies that specific
fields were invalid.  It also verifies that specific constraints failed:

    $tfv->check(
        email => 'foo-at-example.com',
        pass1 => 'foo',
        pass2 => 'bar',
    )
    $tfv->invalid_ok(
    {
        email => 'invalid',
        pass1 => [qw(too_short )],
        pass2 => 'mismatch',
    }
    "caught invalid email address, mismatched password and bad password");

C<@fields> are all flagged as invalid, and that no other fields are
flagged as invalid.

=cut

sub invalid_ok {
    my $self        = shift;
    my $expected    = shift;
    my $description = shift;

    if (!$expected or (ref $expected ne 'ARRAY' and ref $expected ne 'HASH')) {
        croak "Test::FV: usage \$tfv->missing_ok(\\\@expected, 'description') or \$tfv->missing_ok(\\%constraints, 'description') or ";
    }

    my $results = $self->{'__DFV_RESULTS'};
    if (!defined $results) {
        croak "Test::FV: call check before invalid_ok";
    }

    my $success;

    # Testing array of expected
    if (ref $expected eq 'ARRAY') {

        my @invalid  = sort $results->invalid;
        my @expected = sort @$expected;

        $success = Test::More::eq_array(\@invalid, \@expected);
    }
    if (ref $expected eq 'HASH') {
        my $invalid  = $results->invalid;

        if (scalar (keys %$expected) == scalar (keys %$invalid)) {

            $success = 1;

            foreach my $field (keys %$invalid) {

                my $constraints          = $invalid->{$field};
                my $expected_constraints = $expected->{$field};

                $constraints          = [$constraints]          unless ref $constraints eq 'ARRAY';
                $expected_constraints = [$expected_constraints] unless ref $expected_constraints eq 'ARRAY';

                # order of constraints doesn't matter
                $constraints          = [sort @$constraints];
                $expected_constraints = [sort @$expected_constraints];

                unless (Test::More::eq_array($constraints, $expected_constraints)) {
                    undef $success;
                    last;
                }
            }
        }

    }
    if (!$success) {
        $self->diag;
    }

    return $Test->ok($success, $self->_format_description($description));

}

=item valid_ok(\@fields, 'description');

Checks C<\%input> against the current profile, and verifies that
C<@fields> are all flagged as valid, and that no other fields are
flagged as valid.

    $tfv->check(
        email => '[e-mail]',
    );
    $tfv->valid_ok(['email'], "only email is valid");

=cut

sub valid_ok {
    my $self        = shift;
    my $fields      = shift;
    my $description = shift;

    if (!$fields or ref $fields ne 'ARRAY') {
        croak "Test::FV: usage \$tfv->missing_ok(\\\@fields, 'description')";
    }

    my $results = $self->{'__DFV_RESULTS'};
    if (!defined $results) {
        croak "Test::FV: call check before invalid_ok";
    }

    my @valid  = sort $results->valid;
    my @expected = sort @$fields;

    my $success = Test::More::eq_array(\@valid, \@expected);
    if (!$success) {
        $self->diag;
    }

    return $Test->ok($success, $self->_format_description($description));

}

=item html_ok($file, 'description');

=item html_ok($file, { ignore => [qw(foo bar)] }, 'description');

=item html_ok($file, { ignore => /^foo/ }, 'description');

This checks that the form fields in the given file match the fields
listed in the current profile (including both C and
C fields).

    $tfv->html_ok('/path/to/template.html');

If there are any extra fields in the HTML that aren't in the profile,
the test fails.  Similarly, if there are any extra fields in the profile
that aren't in the HTML, the test fails.

It's designed to catch typos and inconsistencies between the form and
the profile.

For example, given a form like this (login.html):


     Email:
     Password:


and a profile like this:

    package WebApp;

    sub _login_profile {
        return {
            required => [ qw(
                email
                passwd
            ) ],
        };
    }

and the following test script (login_profile.t):

    use Test::FormValidator 'no_plan';

    use WebApp;
    my $tfv = Test::FormValidator->new;
    $tfv->profile(Webapp->_login_profile);

    $tfv->html_ok('template.html');

in this scenario, the form contains the fields 'email' and 'passwd', and
the profile contains the fields 'email' and 'passwd'.  So running the
test would fail:

    $ prove login_profile.t
    t/login_profile....NOK 1
    #     Failed test (t/login_profile.t at line 7)
    # HTML Form does not match profile:
    #    field 'password' is in the HTML but not in the profile
    #    field 'passwd' is in the profile but not in the HTML
    #
    # Looks like you failed 1 test of 1.
    t/01-tfv....dubious
            Test returned status 1 (wstat 256, 0x100)
    DIED. FAILED test 1
            Failed 1/1 tests, 0.00% okay
    Failed Test Stat Wstat Total Fail  Failed  List of Failed
    -------------------------------------------------------------------------------
    t/login_profile.t    1   256     1    1 100.00%  1
    Failed 1/1 test scripts, 0.00% okay. 1/1 subtests failed, 0.00% okay.

If you want to ignore the presense or absense of certain fields, you can
do so by passing an C<'ignore'> option.  Its value is either a list of
fields to ignore or a regex to match all fields against.

    # ignore the fields 'foo' and 'bar'
    $tfv->html_ok($file, { ignore => [qw(foo bar)] }, 'form good!');

    # ignore the fields beginning with 'foo_'
    $tfv->html_ok($file, { ignore => /^foo_/ }, 'form good!');

=back

=cut

sub html_ok {
    my $self        = shift;
    my $filename    = shift;
    my $description = pop;

    my %ignore_list;
    my $ignore_match;

    my $options   = shift;
    if ($options and ref $options eq 'HASH') {
        my $ignore = $options->{'ignore'};
        if ($ignore) {
            if (ref $ignore eq 'ARRAY') {
                my $list     = $ignore;
                %ignore_list = map { $_ => 1 } @$list;
            }
            elsif (ref $ignore eq 'Regexp') {
                $ignore_match = $ignore;
            }
        }
    }

    if (!$filename) {
        croak "Test::FV: usage \$tfv->html_ok('/path/to/template.html', 'description')";
    }

    my $profile = $self->profile or croak "Test::FV: must set profile before calling html_ok";

    my $required = $profile->{'required'} || [];
    my $optional = $profile->{'optional'} || [];

    $required = [$required] unless ref $required eq 'ARRAY';
    $optional = [$optional] unless ref $optional eq 'ARRAY';

    my @profile_fields = sort (@$required, @$optional);
    my @html_fields    = $self->_extract_form_fields_from_html($filename);

    if (%ignore_list) {
        @profile_fields = grep { ! $ignore_list{$_} } @profile_fields;
        @html_fields    = grep { ! $ignore_list{$_} } @html_fields;
    }
    if ($ignore_match) {
        @profile_fields = grep { ! /$ignore_match/ } @profile_fields;
        @html_fields    = grep { ! /$ignore_match/ } @html_fields;
    }

    my $success = Test::More::eq_array(\@profile_fields, \@html_fields);
    if (!$success) {
        $Test->diag("Profile fields: ". (join ", ", @profile_fields));
        $Test->diag("HTML fields:    ".    (join ", ", @html_fields));
    }

    return $Test->ok($success, $self->_format_description($description));
}

sub _extract_form_fields_from_html {
    my ($self, $file) = @_;

    my $p = HTML::TokeParser::Simple->new($file) or die "Test::FV: Can't parse HTML file $file: $!\n";

    my %fields;
    while (my $token = $p->get_token) {
        if ($token->is_start_tag('input')
        or $token->is_start_tag('textarea')
        or $token->is_start_tag('select') ) {
            my $name = $token->return_attr->{'name'};
            $fields{$name}++;
        }
    }
    return sort keys %fields;
}

=head2 Utility Methods

These functions do not print out C<'ok'> or C<'not ok'>.

=over 4

=item diag()

All of the test methods (the methods ending in C<'_ok'>) print out
diagnostic information on failure.  However, if you are using other test
functions (such as C C<'ok'>), calling C<< $dfv->diag >>
will display the same diagnostics.

For instance:

    use Test::More 'no_plan';
    use Test::FormValidator;

    my $results = $tfv->check(
        email => 'foo-at-example.com',
        pass1 => 'foo',
        pass2 => 'bar',
    );

    ok($results, 'form was perfect!') or $tfv->diag;

Running this test would produce the following output:

    $ prove profile.t
    t/profile....NOK 1
    #     Failed test (t/profile.t at line 10)
    # Validation results:
    #   missing:  name, phone
    #   invalid:
    #      email   => invalid
    #      pass1   => too_short, need_alpha_num
    #      pass2   => password_mismatch
    #   msgs:
    #     {
    #       'email' => '* Invalid',
    #       'pass1' => '* Invalid',
    #       'pass2' => '* Invalid'
    #     }
    # Looks like you failed 1 test of 1.
    t/profile....dubious
            Test returned status 1 (wstat 256, 0x100)
    DIED. FAILED test 1
            Failed 1/1 tests, 0.00% okay
    Failed Test Stat Wstat Total Fail  Failed  List of Failed
    -------------------------------------------------------------------------------
    t/profile.t    1   256     1    1 100.00%  1
    Failed 1/1 test scripts, 0.00% okay. 1/1 subtests failed, 0.00% okay.

=back

=cut

sub diag {
    my $self = shift;
    $Test->diag($self->_results_diagnostics);
}

sub _results_diagnostics {
    my $self = shift;

    my $results = $self->{'__DFV_RESULTS'};
    if (!defined $results) {
        croak "Test::FV: no results to diagnose!";
    }

    my $indent = "    ";
    my @output = "Validation Results:";

    if ($results) {
        push @output, $indent . "input is valid!";
        return join "\n", @output;
    }

    my $missing = join ", ", sort $results->missing;

    my @invalid_lines;
    foreach my $field (sort $results->invalid) {
        my $pad = abs(length($indent) * 2 - length $field);

        my $line  = $indent . "$field" . (' ' x $pad) . '=>  ';

        $line .= join ", ", sort @{ $results->invalid($field) };

        push @invalid_lines, $line;
    }

    my $dumper = Data::Dumper->new([$results->msgs]);
    $dumper->Terse(1);
    $dumper->Sortkeys(1);
    my $messages_dump = $dumper->Dump;

    if ($missing) {
        push @output, $indent . "missing: $missing";
    }
    if (@invalid_lines) {
        push @output, $indent . "invalid:";
        push @output, (($indent x 2) . $_) for @invalid_lines;
    }
    push @output, $indent . "msgs:";
    push @output, $messages_dump;

    return join "\n", @output;
}

=head1 AUTHOR

Michael Graham, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to
C, or through the web interface at
L.  I will be notified, and then you'll automatically
be notified of progress on your bug as I make changes.

=head1 SOURCE

The source code repository for this module can be found at http://github.com/mgraham/Test-FormValidator

=head1 ACKNOWLEDGEMENTS

Thanks to Mark Stosberg for input, including the crucially sensible
suggestion to go with an object oriented approach.  He also provided the
code that extracts form fields from an HTML file.


=head1 COPYRIGHT & LICENSE

Copyright 2005 Michael Graham, All Rights Reserved.

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

=cut

1; # End of Test::FormValidator