The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/env perl
use strict;
use warnings;
use Test::More qw/no_plan/;
use Data::FormValidator;

# Testing new support for 'qr'. -mls
my %FORM = (
  stick => 'big',
  speak => 'softly',

  bad_email  => 'doops',
  good_email => 'great@domain.com',

  'short_name' => 'tim',

  'not_oops' => 'hoops',

  'untainted_with_qr' => 'Slimy',
);

my $results = Data::FormValidator->check(
  \%FORM,
  {
    required_regexp       => qr/stick/,
    optional_regexp       => '/_email$/',
    constraint_regexp_map => {
      qr/email/ => 'email',

    },
    field_filter_regexp_map => {
      qr/_name$/ => 'ucfirst',
    },
    required    => 'speak',
    optional    => [qw/short_name not_oops untainted_with_qr/],
    constraints => {
      not_oops => {
        name       => 'start_with_oop',
        constraint => qr/^oop/,
      },
      untainted_with_qr => qr/(Slim)/,
      speak             => qr/quietly|softly/,
      stick             => qr/big|large/,

    },
    msgs => {
      constraints => {
        'start_with_oop' => 'testing named qr constraints',
        }

    },
    untaint_constraint_fields => [qw/untainted_with_qr/],
  } );

ok( $results->valid('stick') eq 'big', 'using qr for regexp quoting' );
ok( $results->valid('speak'),          'using alternation with qr works' );
ok( $results->valid('good_email'),     'expected to pass constraint' );
ok( $results->invalid('bad_email'),    'expected to fail constraint' );
is( $results->valid('short_name'), 'Tim', 'field_filter_regexp_map' );

my $msgs = $results->msgs;
like( $msgs->{not_oops}, qr/testing named/, 'named qr constraints' );

is( $results->valid('untainted_with_qr'), 'Slim', 'untainting with qr' );