Commit upstream/4.88 - libdata-formvalidator-perl

New upstream version 4.88 Damyan Ivanov 6 years ago

84 changed file(s) with 4326 addition(s) and 3111 deletion(s). Raw diff Collapse all Expand all

-66

~~Build.PL~~ less more

0		shift(@ARGV) if $ARGV[0] eq 'Build'; # accomodate with CPAN autoinstall
1		use Module::Build;
2
3		my $class = Module::Build->subclass(
4		class => 'Data::FormValidator::Builder',
5		code => q{
6		sub ACTION_dist {
7		my $self = shift;
8		`perldoc -t lib/Data/FormValidator.pm>README`;
9		$self->SUPER::ACTION_dist;
10		}
11
12		sub ACTION_cover {
13		my $self = shift;
14		$self->depends_on('build');
15
16		system qw( cover -delete );
17
18		# sometimes we get failing tests, which makes Test::Harness
19		# die. catch that
20		eval {
21		local $ENV{PERL5OPT} = "-MDevel::Cover=-summary,0";
22		$self->ACTION_test(@_);
23		};
24		system qw( cover -report html );
25		}
26		},
27		);
28
29
30		$class->new(
31		# Makefile.PL is maintained manually now because the 5.8 requirement wasn't getting
32		# translated automatically.
33		# create_makefile_pl => 'traditional',
34		dist_author => 'Mark Stosberg <mark@summersault.com>',
35		module_name => 'Data::FormValidator',
36		license => 'perl',
37		configure_requires => { 'Module::Build' => 0.38 },
38		requires => {
39		# In 5.6, t/upload* was failing.
40		# rjbs says "It relies on CGI relying on 5.008 glob stringification behavior"
41		perl => '5.008',
42		'Image::Size' => 0,
43		'Test::More' => 0,
44		'Date::Calc' => 5.0,
45		'File::MMagic' => 1.17,
46		'MIME::Types' => 1.005,
47		'Regexp::Common' => 0,
48		'overload' => 0,
49		'Perl6::Junction' => 1.10,
50		'Scalar::Util' => 0,
51		'Email::Valid' => 0,
52		},
53		build_requires => {
54		# For testing
55		'CGI' => 3.48,
56		},
57		meta_merge => {
58		resources =>
59		{ repository => 'http://mark.stosberg.com/darcs_hive/dfv/', },
60		no_index => {
61		'package' => ['Data::FormValidator::Constraints::RegexpCommon'],
62		},
63		},
64		)->create_build_script;
65

+46

-0

Changes less more

	0	4.88 August 28th, 2017
	1
	2	[MAINTENANCE]
	3	- Address "." being removed from @INC by using absolute filepaths - thanks Kent Fredric!
	4
	5	4.87 May 14th, 2017
	6
	7	[MAINTENANCE]
	8	- Update cc routine to recognize new 2 series Mastercards
	9
	10	4.86 March 26th, 2017
	11	[NEW FEATURES]
	12	- Add three new profile methods: depedencies_regexp, dependent_optional, dependent_require_some
	13
	14	[MAINTENANCE]
	15	- Bump VERSION in all classes to 5.85
	16
	17	4.85 Feb 25th, 2017
	18
	19	[MAINTENANCE]
	20	- Bump VERSION in all classes to 5.85
	21
	22	4.84 Feb 25th, 2017
	23
	24	[MAINTENANCE]
	25	- Various test file warning fixes
	26	- Change conditional loading of CGI to require version 4.35 or higher (4ce9ac9e)
	27
	28	4.83 Feb 23rd, 2017
	29
	30	[MAINTENANCE]
	31	- Re-release of 4.82: tarball was missing files as "make dist" errored when it didn't find MANIFEST
	32	- Deleted unused Perl6 files
	33
	34	4.82 Feb 23rd, 2017
	35
	36	[MAINTENANCE]
	37	- Made CGI dependency optional
	38	- Replaced Build.PL with Makefile.PL
	39	- Updated Makefile.PL constraints
	40	- Removed dependency on Perl6::Junctions
	41	- Moved the code to GitHub
	42	- Applied patches from: RT 77765, 78443, 10489
	43	- Added shebang, warnings pragma to all test scripts
	44	- Perltidied tests scripts
	45	- Replaced is_tainted() sub with Scalar::Util::tainted()
0	46
1	47	4.81 Jul 19th, 2013
2	48

-3

MANIFEST less more

0		Build.PL
1	0	Changes
2	1	lib/Data/FormValidator.pm
3	2	lib/Data/FormValidator/Constraints.pm

6	5	lib/Data/FormValidator/ConstraintsFactory.pm
7	6	lib/Data/FormValidator/Filters.pm
8	7	lib/Data/FormValidator/Results.pm
	8	Makefile.PL
9	9	MANIFEST This list of files
10	10	MANIFEST.SKIP
	11	README.pod
11	12	RELEASE_NOTES
12	13	t/00_base.t
13	14	t/02_code_ref.t

80	81	t/ValidatorPackagesTest2.pm
81	82	test/00_base.badformat
82	83	test/00_base.profile
83		META.yml
84		META.json
	84	META.yml Module YAML meta-data (added by MakeMaker)
	85	META.json Module JSON meta-data (added by MakeMaker)

-1

MANIFEST.SKIP less more

27	27	lib/Perl6
28	28	rejects
29	29	^Build$
30
	30	\.git
31	31
32	32	^MYMETA.yml$
33	33	^MYMETA\.json$

+19

-50

META.json less more

0	0	{
1		"abstract" : "Validates user input (usually from an HTML form) based\non input profile.",
	1	"abstract" : "Validates user input (usually from an HTML form) based on input profile.",
2	2	"author" : [
3		"Mark Stosberg <mark@summersault.com>"
	3	"David Farrell <dfarrell@cpan.org>"
4	4	],
5	5	"dynamic_config" : 1,
6		"generated_by" : "Module::Build version 0.38, CPAN::Meta::Converter version 2.120921",
	6	"generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150010",
7	7	"license" : [
8	8	"perl_5"
9	9	],

13	13	},
14	14	"name" : "Data-FormValidator",
15	15	"no_index" : {
	16	"directory" : [
	17	"t",
	18	"inc"
	19	],
16	20	"package" : [
17	21	"Data::FormValidator::Constraints::RegexpCommon"
18	22	]

20	24	"prereqs" : {
21	25	"build" : {
22	26	"requires" : {
23		"CGI" : "3.48"
	27	"ExtUtils::MakeMaker" : "0"
24	28	}
25	29	},
26	30	"configure" : {
27	31	"requires" : {
28		"Module::Build" : "0.38"
	32	"ExtUtils::MakeMaker" : "0"
29	33	}
30	34	},
31	35	"runtime" : {

33	37	"Date::Calc" : "5",
34	38	"Email::Valid" : "0",
35	39	"File::MMagic" : "1.17",
	40	"File::Spec" : "0",
36	41	"Image::Size" : "0",
37	42	"MIME::Types" : "1.005",
38		"Perl6::Junction" : "1.1",
39		"Regexp::Common" : "0",
	43	"Regexp::Common" : "0.03",
40	44	"Scalar::Util" : "0",
41	45	"Test::More" : "0",
42		"overload" : "0",
43	46	"perl" : "5.008"
44	47	}
45	48	}
46	49	},
47		"provides" : {
48		"Data::FormValidator" : {
49		"file" : "lib/Data/FormValidator.pm",
50		"version" : "4.81"
51		},
52		"Data::FormValidator::Constraints" : {
53		"file" : "lib/Data/FormValidator/Constraints.pm",
54		"version" : "4.81"
55		},
56		"Data::FormValidator::Constraints::Dates" : {
57		"file" : "lib/Data/FormValidator/Constraints/Dates.pm",
58		"version" : "4.81"
59		},
60		"Data::FormValidator::Constraints::RegexpCommon" : {
61		"file" : "lib/Data/FormValidator/Results.pm",
62		"version" : 0
63		},
64		"Data::FormValidator::Constraints::Upload" : {
65		"file" : "lib/Data/FormValidator/Constraints/Upload.pm",
66		"version" : "4.81"
67		},
68		"Data::FormValidator::ConstraintsFactory" : {
69		"file" : "lib/Data/FormValidator/ConstraintsFactory.pm",
70		"version" : "4.81"
71		},
72		"Data::FormValidator::Filters" : {
73		"file" : "lib/Data/FormValidator/Filters.pm",
74		"version" : "4.81"
75		},
76		"Data::FormValidator::Results" : {
77		"file" : "lib/Data/FormValidator/Results.pm",
78		"version" : "4.81"
	50	"release_status" : "stable",
	51	"resources" : {
	52	"repository" : {
	53	"type" : "git",
	54	"url" : "https://github.com/dnmfarrell/Data-FormValidator",
	55	"web" : "https://github.com/dnmfarrell/Data-FormValidator"
79	56	}
80	57	},
81		"release_status" : "stable",
82		"resources" : {
83		"license" : [
84		"http://dev.perl.org/licenses/"
85		],
86		"repository" : {
87		"url" : "http://mark.stosberg.com/darcs_hive/dfv/"
88		}
89		},
90		"version" : "4.81"
	58	"version" : 4.88,
	59	"x_serialization_backend" : "JSON::PP version 2.27400_02"
91	60	}

+22

-45

META.yml less more

0	0	---
1		abstract: "Validates user input (usually from an HTML form) based\non input profile."
	1	abstract: 'Validates user input (usually from an HTML form) based on input profile.'
2	2	author:
3		- 'Mark Stosberg <mark@summersault.com>'
	3	- 'David Farrell <dfarrell@cpan.org>'
4	4	build_requires:
5		CGI: 3.48
	5	ExtUtils::MakeMaker: '0'
6	6	configure_requires:
7		Module::Build: 0.38
	7	ExtUtils::MakeMaker: '0'
8	8	dynamic_config: 1
9		generated_by: 'Module::Build version 0.38, CPAN::Meta::Converter version 2.120921'
	9	generated_by: 'ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150010'
10	10	license: perl
11	11	meta-spec:
12	12	url: http://module-build.sourceforge.net/META-spec-v1.4.html
13		version: 1.4
	13	version: '1.4'
14	14	name: Data-FormValidator
15	15	no_index:
	16	directory:
	17	- t
	18	- inc
16	19	package:
17	20	- Data::FormValidator::Constraints::RegexpCommon
18		provides:
19		Data::FormValidator:
20		file: lib/Data/FormValidator.pm
21		version: 4.81
22		Data::FormValidator::Constraints:
23		file: lib/Data/FormValidator/Constraints.pm
24		version: 4.81
25		Data::FormValidator::Constraints::Dates:
26		file: lib/Data/FormValidator/Constraints/Dates.pm
27		version: 4.81
28		Data::FormValidator::Constraints::RegexpCommon:
29		file: lib/Data/FormValidator/Results.pm
30		version: 0
31		Data::FormValidator::Constraints::Upload:
32		file: lib/Data/FormValidator/Constraints/Upload.pm
33		version: 4.81
34		Data::FormValidator::ConstraintsFactory:
35		file: lib/Data/FormValidator/ConstraintsFactory.pm
36		version: 4.81
37		Data::FormValidator::Filters:
38		file: lib/Data/FormValidator/Filters.pm
39		version: 4.81
40		Data::FormValidator::Results:
41		file: lib/Data/FormValidator/Results.pm
42		version: 4.81
43	21	requires:
44		Date::Calc: 5
45		Email::Valid: 0
46		File::MMagic: 1.17
47		Image::Size: 0
48		MIME::Types: 1.005
49		Perl6::Junction: 1.1
50		Regexp::Common: 0
51		Scalar::Util: 0
52		Test::More: 0
53		overload: 0
54		perl: 5.008
	22	Date::Calc: '5'
	23	Email::Valid: '0'
	24	File::MMagic: '1.17'
	25	File::Spec: '0'
	26	Image::Size: '0'
	27	MIME::Types: '1.005'
	28	Regexp::Common: '0.03'
	29	Scalar::Util: '0'
	30	Test::More: '0'
	31	perl: '5.008'
55	32	resources:
56		license: http://dev.perl.org/licenses/
57		repository: http://mark.stosberg.com/darcs_hive/dfv/
58		version: 4.81
	33	repository: https://github.com/dnmfarrell/Data-FormValidator
	34	version: 4.88
	35	x_serialization_backend: 'CPAN::Meta::YAML version 0.018'

+39

-0

Makefile.PL less more

	0	use 5.008;
	1	use ExtUtils::MakeMaker;
	2
	3	WriteMakefile(
	4	NAME => 'Data::FormValidator',
	5	VERSION_FROM => 'lib/Data/FormValidator.pm',
	6	ABSTRACT_FROM => 'lib/Data/FormValidator.pm',
	7	AUTHOR => 'David Farrell <dfarrell@cpan.org>',
	8	LICENSE => 'perl',
	9	PREREQ_PM => {
	10	# In 5.6, t/upload* was failing.
	11	# rjbs says "It relies on CGI relying on 5.008 glob stringification behavior"
	12	'perl' => '5.008',
	13	'Image::Size' => 0,
	14	'Test::More' => 0,
	15	'Date::Calc' => 5.0,
	16	'File::MMagic' => 1.17,
	17	'MIME::Types' => 1.005,
	18	'Regexp::Common' => 0.03, # when ::whitespace was added
	19	'Scalar::Util' => 0,
	20	'Email::Valid' => 0,
	21	'File::Spec' => 0,
	22	},
	23	(eval { ExtUtils::MakeMaker->VERSION(6.46) } ? (META_MERGE => {
	24	'meta-spec' => { version => 2 },
	25	resources => {
	26	repository => {
	27	type => 'git',
	28	url => 'https://github.com/dnmfarrell/Data-FormValidator',
	29	web => 'https://github.com/dnmfarrell/Data-FormValidator',
	30	},
	31	},
	32	# this is a cuckoo package in Data::FormValidator::Results
	33	no_index => {
	34	package => ['Data::FormValidator::Constraints::RegexpCommon'],
	35	}})
	36	: ()
	37	),
	38	);

+1041

-0

README.pod less more

	0	=pod
	1
	2	=head1 NAME
	3
	4	Data::FormValidator - Validates user input (usually from an HTML form) based
	5	on input profile.
	6
	7	=head1 SYNOPSIS
	8
	9	use Data::FormValidator;
	10
	11	my $results = Data::FormValidator->check(\%input_hash, \%dfv_profile);
	12
	13	if ($results->has_invalid or $results->has_missing) {
	14	# do something with $results->invalid, $results->missing
	15	# or $results->msgs
	16	}
	17	else {
	18	# do something with $results->valid
	19	}
	20
	21
	22	=head1 DESCRIPTION
	23
	24	Data::FormValidator's main aim is to make input validation expressible in a
	25	simple format.
	26
	27	Data::FormValidator lets you define profiles which declare the
	28	required and optional fields and any constraints they might have.
	29
	30	The results are provided as an object, which makes it easy to handle
	31	missing and invalid results, return error messages about which constraints
	32	failed, or process the resulting valid data.
	33
	34
	35	=cut
	36
	37	=head1 VALIDATING INPUT
	38
	39	=head2 check()
	40
	41	my $results = Data::FormValidator->check(\%input_hash, \%dfv_profile);
	42
	43	C<check> is the recommended method to use to validate forms. It returns its results as a
	44	L<Data::FormValidator::Results\|Data::FormValidator::Results> object. A
	45	deprecated method C<validate> described below is also available, returning its results as an
	46	array.
	47
	48	use Data::FormValidator;
	49	my $results = Data::FormValidator->check(\%input_hash, \%dfv_profile);
	50
	51	Here, C<check()> is used as a class method, and takes two required parameters.
	52
	53	The first a reference to the data to be be validated. This can either be a hash
	54	reference, or a CGI.pm-like object. In particular, the object must have a param()
	55	method that works like the one in CGI.pm does. CGI::Simple and Apache::Request
	56	objects are known to work in particular. Note that if you use a hash reference,
	57	multiple values for a single key should be presented as an array reference.
	58
	59	The second argument is a reference to the profile you are validating.
	60
	61	=head2 validate()
	62
	63	my( $valids, $missings, $invalids, $unknowns ) =
	64	Data::FormValidator->validate( \%input_hash, \%dfv_profile);
	65
	66	C<validate()> provides a deprecated alternative to C<check()>. It has the same input
	67	syntax, but returns a four element array, described as follows
	68
	69	=over
	70
	71	=item valids
	72
	73	This is a hash reference to the valid fields which were submitted in
	74	the data. The data may have been modified by the various filters specified.
	75
	76	=item missings
	77
	78	This is a reference to an array which contains the name of the missing
	79	fields. Those are the fields that the user forget to fill or filled
	80	with spaces. These fields may comes from the I<required> list or the
	81	I<dependencies> list.
	82
	83	=item invalids
	84
	85	This is a reference to an array which contains the name of the fields which
	86	failed one or more of their constraint checks. If there are no invalid fields,
	87	an empty arrayref will be returned.
	88
	89	Fields defined with multiple constraints will have an array ref returned in the
	90	@invalids array instead of a string. The first element in this array is the
	91	name of the field, and the remaining fields are the names of the failed
	92	constraints.
	93
	94	=item unknowns
	95
	96	This is a list of fields which are unknown to the profile. Whether or
	97	not this indicates an error in the user input is application
	98	dependent.
	99
	100	=back
	101
	102	=head2 new()
	103
	104	Using C<new()> is only needed for advanced usage, including these cases:
	105
	106	=over
	107
	108	=item o
	109
	110	Loading more than one profile at a time. Then you can select the profile you
	111	want by name later with C<check()>. Here's an example:
	112
	113	my $dfv = Data::FormValidator->new({
	114	profile_1 => { # usual profile definition here },
	115	profile_2 => { # another profile definition },
	116	});
	117
	118
	119	As illustrated, multiple profiles are defined through a hash ref whose keys point
	120	to profile definitions.
	121
	122	You can also load several profiles from a file, by defining several profiles as shown above
	123	in an external file. Then just pass in the name of the file:
	124
	125	my $dfv = Data::FormValidator->new('/path/to/profiles.pl');
	126
	127	If the input profile is specified as a file name, the profiles will be reread
	128	each time that the disk copy is modified.
	129
	130	Now when calling C<check()>, you just need to supply the profile name:
	131
	132	my $results = $dfv->check(\%input_hash,'profile_1');
	133
	134	=item o
	135
	136	Applying defaults to more than one input profile. There are some parts
	137	of the validation profile that you might like to re-use for many form
	138	validations.
	139
	140	To facilitate this, C<new()> takes a second argument, a hash reference. Here
	141	the usual input profile definitions can be made. These will act as defaults for
	142	any subsequent calls to C<check()> on this object.
	143
	144	Currently the logic for this is very simple. Any definition of a key in your
	145	validation profile will completely overwrite your default value.
	146
	147	This means you can't define two keys for C<constraint_regexp_map> and expect
	148	they will always be there. This kind of feature may be added in the future.
	149
	150	The exception here is definitions for your C<msgs> key. You will safely be
	151	able to define some defaults for the top level keys within C<msgs> and not have
	152	them clobbered just because C<msgs> was defined in a validation profile.
	153
	154	One way to use this feature is to create your own sub-class that always provides
	155	your defaults to C<new()>.
	156
	157	Another option is to create your own wrapper routine which provides these defaults to
	158	C<new()>. Here's an example of a routine you might put in a
	159	L<CGI::Application\|CGI::Application> super-class to make use of this feature:
	160
	161	# Always use the built-in CGI object as the form data
	162	# and provide some defaults to new constructor
	163	sub check_form {
	164	my $self = shift;
	165	my $profile = shift
	166	\|\| die 'check_form: missing required profile';
	167
	168	require Data::FormValidator;
	169	my $dfv = Data::FormValidator->new({},{
	170	# your defaults here
	171	});
	172	return $dfv->check($self->query,$profile);
	173	}
	174
	175
	176	=back
	177
	178
	179	=cut
	180
	181	=head1 INPUT PROFILE SPECIFICATION
	182
	183	An input profile is a hash reference containing one or more of the following
	184	keys.
	185
	186	Here is a very simple input profile. Examples of more advanced options are
	187	described below.
	188
	189	use Data::FormValidator::Constraints qw(:closures);
	190
	191	my $profile = {
	192	optional => [qw( company
	193	fax
	194	country )],
	195
	196	required => [qw( fullname
	197	phone
	198	email
	199	address )],
	200
	201	constraint_methods => {
	202	email => email(),
	203	}
	204	};
	205
	206
	207	That defines some fields as optional, some as required, and defines that the
	208	field named 'email' must pass the constraint named 'email'.
	209
	210	Here is a complete list of the keys available in the input profile, with
	211	examples of each.
	212
	213	=head2 required
	214
	215	This is an array reference which contains the name of the fields which are
	216	required. Any fields in this list which are not present or contain only
	217	spaces will be reported as missing.
	218
	219	=head2 required_regexp
	220
	221	required_regexp => qr/city\|state\|zipcode/,
	222
	223	This is a regular expression used to specify additional field names for which values
	224	will be required.
	225
	226	=head2 require_some
	227
	228	require_some => {
	229	# require any two fields from this group
	230	city_or_state_or_zipcode => [ 2, qw/city state zipcode/ ],
	231	}
	232
	233	This is a reference to a hash which defines groups of fields where 1 or more
	234	fields from the group should be required, but exactly which fields doesn't
	235	matter. The keys in the hash are the group names. These are returned as
	236	"missing" unless the required number of fields from the group has been filled
	237	in. The values in this hash are array references. The first element in this
	238	array should be the number of fields in the group that is required. If the
	239	first field in the array is not an a digit, a default of "1" will be used.
	240
	241	=head2 optional
	242
	243	optional => [qw/meat coffee chocolate/],
	244
	245	This is an array reference which contains the name of optional fields.
	246	These are fields which MAY be present and if they are, they will be
	247	checked for valid input. Any fields not in optional or required list
	248	will be reported as unknown.
	249
	250	=head2 optional_regexp
	251
	252	optional_regexp => qr/_province$/,
	253
	254	This is a regular expression used to specify additional fields which are
	255	optional. For example, if you wanted all fields names that begin with I<user_>
	256	to be optional, you could use the regular expression, /^user_/
	257
	258	=head2 dependencies
	259
	260	dependencies => {
	261
	262	# If cc_no is entered, make cc_type and cc_exp required
	263	"cc_no" => [ qw( cc_type cc_exp ) ],
	264
	265	# if pay_type eq 'check', require check_no
	266	"pay_type" => {
	267	check => [ qw( check_no ) ],
	268	}
	269
	270	# if cc_type is VISA or MASTERCARD require CVV
	271	"cc_type" => sub {
	272	my $dfv = shift;
	273	my $type = shift;
	274
	275	return [ 'cc_cvv' ] if ($type eq "VISA" \|\| $type eq "MASTERCARD");
	276	return [ ];
	277	},
	278	},
	279
	280	This is for the case where an optional field has other requirements. The
	281	dependent fields can be specified with an array reference.
	282
	283	If the dependencies are specified with a hash reference then the additional
	284	constraint is added that the optional field must equal a key for the
	285	dependencies to be added.
	286
	287	If the dependencies are specified as a code reference then the code will be
	288	executed to determine the dependent fields. It is passed two parameters,
	289	the object and the value of the field, and it should return an array reference
	290	containing the list of dependent fields.
	291
	292	Any fields in the dependencies list that are missing when the target is present
	293	will be reported as missing.
	294
	295	=head2 dependency_groups
	296
	297	dependency_groups => {
	298	# if either field is filled in, they all become required
	299	password_group => [qw/password password_confirmation/],
	300	}
	301
	302	This is a hash reference which contains information about groups of
	303	interdependent fields. The keys are arbitrary names that you create and
	304	the values are references to arrays of the field names in each group.
	305
	306	=head2 dependencies_regexp
	307
	308	dependencies_regexp => {
	309	qr/Line\d+\_ItemType$/ => sub {
	310	my $dfv = shift;
	311	my $itemtype = shift;
	312	my $field = shift;
	313
	314	if ($type eq 'NeedsBatteries') {
	315	my ($prefix, $suffix) = split(/\_/, $field);
	316
	317	return([$prefix . '_add_batteries]);
	318	} else {
	319	return([]);
	320	}
	321	},
	322	},
	323
	324	This is a regular expression used to specify additional fields which are
	325	dependent. For example, if you wanted to add dependencies for all fields which
	326	meet a certain criteria (such as multiple items in a shopping cart) where you
	327	do not know before hand how many of such fields you may have.
	328
	329	=head2 dependent_optionals
	330
	331	dependent_optionals => {
	332	# If delivery_address is specified then delivery_notes becomes optional
	333	"delivery_address" => [ qw( delivery_notes ) ],
	334
	335	# if delivery_type eq 'collection', collection_notes becomes optional
	336	"delivery_type" => {
	337	collection => [ qw( collection_notes ) ],
	338	}
	339
	340	# if callback_type is "phone" or "email" then additional_notes becomes optional
	341	"callback_type" => sub {
	342	my $dfv = shift;
	343	my $type = shift;
	344
	345	if ($type eq 'phone' \|\| $type eq 'email') {
	346	return(['additional_notes']);
	347	} else {
	348	return([]);
	349	}
	350	},
	351	},
	352
	353	This is for the case where an optional field can trigger other optional fields.
	354	The dependent optional fields can be specified with an array reference.
	355
	356	If the dependent optional fields are specified with a hash reference, then an
	357	additional constraint is added that the optional field must equal a key for the
	358	additional optional fields to be added.
	359
	360	If the dependent optional fields are specified as a code reference then the
	361	code will be executed to determine the additional optional fields. It is passed
	362	two parameters, the object and the value of the field, and it should return an
	363	array reference containing the list of additional optional fields.
	364
	365	=head2 dependent_require_some
	366
	367	dependent_require_some => {
	368	# require any fields from this group if AddressID is "new"
	369	AddressID => sub {
	370	my $dfv = shift;
	371	my $value = shift;
	372
	373	if ($value eq 'new') {
	374	return({
	375	house_name_or_number => [ 1, 'HouseName', 'HouseNumber' ],
	376	});
	377	} else {
	378	return;
	379	}
	380	},
	381	}
	382
	383	Sometimes a field will need to trigger additional dependencies but you only
	384	require some of the fields. You cannot set them all to be dependent as you
	385	might only have some of them, and you cannot set them all to be optional as
	386	you must have some of them. This method allows you to specify this in a
	387	similar way to the equire_some method but dependent upon other values. In
	388	the example above if the AddressID submitted is "new" then at least 1 of
	389	HouseName and HouseNumber must also be supplied. See require_some for the
	390	valid options for the return.
	391
	392	=head2 defaults
	393
	394	defaults => {
	395	country => "USA",
	396	},
	397
	398	This is a hash reference where keys are field names and
	399	values are defaults to use if input for the field is missing.
	400
	401	The values can be code refs which will be used to calculate the
	402	value if needed. These code refs will be passed in the DFV::Results
	403	object as the only parameter.
	404
	405	The defaults are set shortly before the constraints are applied, and
	406	will be returned with the other valid data.
	407
	408	=head2 defaults_regexp_map
	409
	410	defaults_regexp_map => {
	411	qr/^opt_/ => 1,
	412	},
	413
	414	This is a hash reference that maps regular expressions to default values to
	415	use for matching optional or required fields.
	416
	417	It's useful if you have generated many checkbox fields with the similar names.
	418	Since checkbox fields submit nothing at all when they are not checked, it's
	419	useful to set defaults for them.
	420
	421	Note that it doesn't make sense to use a default for a field handled by
	422	C<optional_regexp> or C<required_regexp>. When the field is not submitted,
	423	there is no way to know that it should be optional or required, and thus there's
	424	no way to know that a default should be set for it.
	425
	426	=head2 filters
	427
	428	# trim leading and trailing whitespace on all fields
	429	filters => ['trim'],
	430
	431	This is a reference to an array of filters that will be applied to ALL optional
	432	and required fields, B<before> any constraints are applied.
	433
	434	This can be the name of a built-in filter
	435	(trim,digit,etc) or an anonymous subroutine which should take one parameter,
	436	the field value and return the (possibly) modified value.
	437
	438	Filters modify the data returned through the results object, so use them carefully.
	439
	440	See L<Data::FormValidator::Filters> for details on the built-in filters.
	441
	442	=head2 field_filters
	443
	444	field_filters => {
	445	cc_no => ['digit'],
	446	},
	447
	448	A hash ref with field names as keys. Values are array references of built-in
	449	filters to apply (trim,digit,etc) or an anonymous subroutine which should take
	450	one parameter, the field value and return the (possibly) modified value.
	451
	452	Filters are applied B<before> any constraints are applied.
	453
	454	See L<Data::FormValidator::Filters> for details on the built-in filters.
	455
	456	=head2 field_filter_regexp_map
	457
	458	field_filter_regexp_map => {
	459	# Upper-case the first letter of all fields that end in "_name"
	460	qr/_name$/ => ['ucfirst'],
	461	},
	462
	463	'field_filter_regexp_map' is used to apply filters to fields that match a
	464	regular expression. This is a hash reference where the keys are the regular
	465	expressions to use and the values are references to arrays of filters which
	466	will be applied to specific input fields. Just as with 'field_filters', you
	467	can you use a built-in filter or use a coderef to supply your own.
	468
	469	=head2 constraint_methods
	470
	471	use Data::FormValidator::Constraints qw(:closures);
	472
	473	constraint_methods => {
	474	cc_no => cc_number({fields => ['cc_type']}),
	475	cc_type => cc_type(),
	476	cc_exp => cc_exp(),
	477	},
	478
	479	A hash ref which contains the constraints that will be used to check whether or
	480	not the field contains valid data.
	481
	482	B<Note:> To use the built-in constraints, they need to first be loaded into your
	483	name space using the syntax above. (Unless you are using the old C<constraints> key,
	484	documented in L<BACKWARDS COMPATIBILITY>).
	485
	486	The keys in this hash are field names. The values can be any of the following:
	487
	488	=over
	489
	490	=item o
	491
	492	A named constraint.
	493
	494	B<Example>:
	495
	496	my_zipcode_field => zip(),
	497
	498	See L<Data::FormValidator::Constraints> for the details of which
	499	built-in constraints that are available.
	500
	501
	502	=item o
	503
	504	A perl regular expression
	505
	506	B<Example>:
	507
	508	my_zipcode_field => qr/^\d{5}$/, # match exactly 5 digits
	509
	510	If this field is named in C<untaint_constraint_fields> or C<untaint_regexp_map>,
	511	or C<untaint_all_constraints> is effective, be aware of the following: If you
	512	write your own regular expressions and only match part of the string then
	513	you'll only get part of the string in the valid hash. It is a good idea to
	514	write you own constraints like /^regex$/. That way you match the whole string.
	515
	516	=item o
	517
	518	a subroutine reference, to supply custom code
	519
	520	This will check the input and return true or false depending on the input's validity.
	521	By default, the constraint function receives a L<Data::FormValidator::Results>
	522	object as its first argument, and the value to be validated as the second. To
	523	validate a field based on more inputs than just the field itself, see
	524	L<VALIDATING INPUT BASED ON MULTIPLE FIELDS>.
	525
	526	B<Examples>:
	527
	528	# Notice the use of 'pop'--
	529	# the object is the first arg passed to the method
	530	# while the value is the second, and last arg.
	531	my_zipcode_field => sub { my $val = pop; return $val =~ '/^\d{5}$/' },
	532
	533	# OR you can reference a subroutine, which should work like the one above
	534	my_zipcode_field => \&my_validation_routine,
	535
	536	# An example of setting the constraint name.
	537	my_zipcode_field => sub {
	538	my ($dfv, $val) = @_;
	539	$dfv->set_current_constraint_name('my_constraint_name');
	540	return $val =~ '/^\d{5}$/'
	541	},
	542
	543	=item o
	544
	545	an array reference
	546
	547	An array reference is used to apply multiple constraints to a single
	548	field. Any of the above options are valid entries the array.
	549	See L<MULTIPLE CONSTRAINTS> below.
	550
	551	For more details see L<VALIDATING INPUT BASED ON MULTIPLE FIELDS>.
	552
	553	=back
	554
	555	=head2 constraint_method_regexp_map
	556
	557	use Data::FormValidator::Constraints qw(:closures);
	558
	559	# In your profile.
	560	constraint_method_regexp_map => {
	561	# All fields that end in _postcode have the 'postcode' constraint applied.
	562	qr/_postcode$/ => postcode(),
	563	},
	564
	565	A hash ref where the keys are the regular expressions to
	566	use and the values are the constraints to apply.
	567
	568	If one or more constraints have already been defined for a given field using
	569	C<constraint_methods>, C<constraint_method_regexp_map> will add an additional
	570	constraint for that field for each regular expression that matches.
	571
	572	=head2 untaint_all_constraints
	573
	574	untaint_all_constraints => 1,
	575
	576	If this field is set, all form data that passes a constraint will be untainted.
	577	The untainted data will be returned in the valid hash. Untainting is based on
	578	the pattern match used by the constraint. Note that some constraint routines
	579	may not provide untainting.
	580
	581	See L<Writing your own constraint routines\|Data::FormValidator::Constraints/"WRITING YOUR OWN CONSTRAINT ROUTINES"> for more information.
	582
	583	This is overridden by C<untaint_constraint_fields> and C<untaint_regexp_map>.
	584
	585	=head2 untaint_constraint_fields
	586
	587	untaint_constraint_fields => [qw(zipcode state)],
	588
	589	Specifies that one or more fields will be untainted if they pass their
	590	constraint(s). This can be set to a single field name or an array reference of
	591	field names. The untainted data will be returned in the valid hash.
	592
	593	This overrides the untaint_all_constraints flag.
	594
	595	=head2 untaint_regexp_map
	596
	597	untaint_regexp_map => [qr/some_field_\d/],
	598
	599	Specifies that certain fields will be untainted if they pass their constraints
	600	and match one of the regular expressions supplied. This can be set to a single
	601	regex, or an array reference of regexes. The untainted data will be returned
	602	in the valid hash.
	603
	604	The above example would untaint the fields named C<some_field_1>, and C<some_field_2>
	605	but not C<some_field>.
	606
	607	This overrides the untaint_all_constraints flag.
	608
	609	=head2 missing_optional_valid
	610
	611	missing_optional_valid => 1
	612
	613	This can be set to a true value to cause optional fields with empty values to
	614	be included in the valid hash. By default they are not included-- this is the
	615	historical behavior.
	616
	617	This is an important flag if you are using the contents of an "update" form to
	618	update a record in a database. Without using the option, fields that have been
	619	set back to "blank" may fail to get updated.
	620
	621	=head2 validator_packages
	622
	623	# load all the constraints and filters from these modules
	624	validator_packages => [qw(Data::FormValidator::Constraints::Upload)],
	625
	626	This key is used to define other packages which contain constraint routines or
	627	filters. Set this key to a single package name, or an arrayref of several. All
	628	of its constraint and filter routines beginning with 'match_', 'valid_' and
	629	'filter_' will be imported into Data::FormValidator. This lets you reference
	630	them in a constraint with just their name, just like built-in routines. You
	631	can even override the provided validators.
	632
	633	See L<Writing your own constraint routines\|Data::FormValidator::Constraints/"WRITING YOUR OWN CONSTRAINT ROUTINES">
	634	documentation for more information
	635
	636	=head2 msgs
	637
	638	This key is used to define parameters related to formatting error messages
	639	returned to the user.
	640
	641	By default, invalid fields have the message "Invalid" associated with them
	642	while missing fields have the message "Missing" associated with them.
	643
	644	In the simplest case, nothing needs to be defined here, and the default values
	645	will be used.
	646
	647	The default formatting applied is designed for display in an XHTML web page.
	648	That formatting is as followings:
	649
	650	<span style="color:red;font-weight:bold" class="dfv_errors">* %s</span>
	651
	652	The C<%s> will be replaced with the message. The effect is that the message
	653	will appear in bold red with an asterisk before it. This style can be overridden by simply
	654	defining "dfv_errors" appropriately in a style sheet, or by providing a new format string.
	655
	656	Here's a more complex example that shows how to provide your own default message strings, as well
	657	as providing custom messages per field, and handling multiple constraints:
	658
	659	msgs => {
	660
	661	# set a custom error prefix, defaults to none
	662	prefix=> 'error_',
	663
	664	# Set your own "Missing" message, defaults to "Missing"
	665	missing => 'Not Here!',
	666
	667	# Default invalid message, default's to "Invalid"
	668	invalid => 'Problematic!',
	669
	670	# message separator for multiple messages
	671	# Defaults to ' '
	672	invalid_separator => ' <br /> ',
	673
	674	# formatting string, default given above.
	675	format => 'ERROR: %s',
	676
	677	# Error messages, keyed by constraint name
	678	# Your constraints must be named to use this.
	679	constraints => {
	680	'date_and_time' => 'Not a valid time format',
	681	# ...
	682	},
	683
	684	# This token will be included in the hash if there are
	685	# any errors returned. This can be useful with templating
	686	# systems like HTML::Template
	687	# The 'prefix' setting does not apply here.
	688	# defaults to undefined
	689	any_errors => 'some_errors',
	690	}
	691
	692	The hash that's prepared can be retrieved through the C<msgs> method
	693	described in the L<Data::FormValidator::Results> documentation.
	694
	695	=head2 msgs - callback
	696
	697	I<This is a new feature. While it expected to be forward-compatible, it hasn't
	698	yet received the testing the rest of the API has.>
	699
	700	If the built-in message generation doesn't suit you, it is also possible to
	701	provide your own by specifying a code reference:
	702
	703	msgs => \&my_msgs_callback
	704
	705	This will be called as a L<Data::FormValidator::Results> method. It may
	706	receive as arguments an additional hash reference of control parameters,
	707	corresponding to the key names usually used in the C<msgs> area of the
	708	profile. You can ignore this information if you'd like.
	709
	710	If you have an alternative error message handler you'd like to share, stick in
	711	the C<Data::FormValidator::ErrMsgs> name space and upload it to CPAN.
	712
	713	=head2 debug
	714
	715	This method is used to print details about what is going on to STDERR.
	716
	717	Currently only level '1' is used. It provides information about which
	718	fields matched constraint_regexp_map.
	719
	720	=head2 A shortcut for array refs
	721
	722	A number of parts of the input profile specification include array references
	723	as their values. In any of these places, you can simply use a string if you
	724	only need to specify one value. For example, instead of
	725
	726	filters => [ 'trim' ]
	727
	728	you can simply say
	729
	730	filters => 'trim'
	731
	732	=head2 A note on regular expression formats
	733
	734	In addition to using the preferred method of defining regular expressions
	735	using C<qr>, a deprecated style of defining them as strings is also supported.
	736
	737	Preferred:
	738
	739	qr/this is great/
	740
	741	Deprecated, but supported
	742
	743	'm/this still works/'
	744
	745	=head1 VALIDATING INPUT BASED ON MULTIPLE FIELDS
	746
	747	You can pass more than one value into a constraint routine. For that, the
	748	value of the constraint should be a hash reference. If you are creating your
	749	own routines, be sure to read the section labeled
	750	L<WRITING YOUR OWN CONSTRAINT ROUTINES>,
	751	in the Data::FormValidator::Constraints documentation. It describes
	752	a newer and more flexible syntax.
	753
	754	Using the original syntax, one key should be named C<constraint> and should
	755	have a value set to the reference of the subroutine or the name of a built-in
	756	validator. Another required key is C<params>. The value of the C<params> key
	757	is a reference to an array of the other elements to use in the validation. If
	758	the element is a scalar, it is assumed to be a field name. The field is known
	759	to Data::FormValidator, the value will be filtered through any defined filters
	760	before it is passed in. If the value is a reference, the reference is passed
	761	directly to the routine. Don't forget to include the name of the field to
	762	check in that list, if you are using this syntax.
	763
	764	B<Example>:
	765
	766	cc_no => {
	767	constraint => "cc_number",
	768	params => [ qw( cc_no cc_type ) ],
	769	},
	770
	771
	772	=head1 MULTIPLE CONSTRAINTS
	773
	774	Multiple constraints can be applied to a single field by defining the value of
	775	the constraint to be an array reference. Each of the values in this array can
	776	be any of the constraint types defined above.
	777
	778	When using multiple constraints it is important to return the name of the
	779	constraint that failed so you can distinguish between them. To do that,
	780	either use a named constraint, or use the hash ref method of defining a
	781	constraint and include a C<name> key with a value set to the name of your
	782	constraint. Here's an example:
	783
	784	my_zipcode_field => [
	785	'zip',
	786	{
	787	constraint_method => '/^406/',
	788	name => 'starts_with_406',
	789	}
	790	],
	791
	792	You can use an array reference with a single constraint in it if you just want
	793	to have the name of your failed constraint returned in the above fashion.
	794
	795	Read about the C<validate()> function above to see how multiple constraints
	796	are returned differently with that method.
	797
	798
	799	=cut
	800
	801	=pod
	802
	803	=head1 ADVANCED VALIDATION
	804
	805	For even more advanced validation, you will likely want to read the
	806	documentation for other modules in this distribution, linked below. Also keep
	807	in mind that the Data::FormValidator profile structure is just another data
	808	structure. There is no reason why it needs to be defined statically. The
	809	profile could also be built on the fly with custom Perl code.
	810
	811	=head1 BACKWARDS COMPATIBILITY
	812
	813	=head2 validate()
	814
	815	my( $valids, $missings, $invalids, $unknowns ) =
	816	Data::FormValidator->validate( \%input_hash, \%dfv_profile);
	817
	818	C<validate()> provides a deprecated alternative to C<check()>. It has the same input
	819	syntax, but returns a four element array, described as follows
	820
	821	=over
	822
	823	=item valids
	824
	825	This is a hash reference to the valid fields which were submitted in
	826	the data. The data may have been modified by the various filters specified.
	827
	828	=item missings
	829
	830	This is a reference to an array which contains the name of the missing
	831	fields. Those are the fields that the user forget to fill or filled
	832	with spaces. These fields may comes from the I<required> list or the
	833	I<dependencies> list.
	834
	835	=item invalids
	836
	837	This is a reference to an array which contains the name of the fields
	838	which failed one or more of their constraint checks.
	839
	840	Fields defined with multiple constraints will have an array ref returned in the
	841	@invalids array instead of a string. The first element in this array is the
	842	name of the field, and the remaining fields are the names of the failed
	843	constraints.
	844
	845	=item unknowns
	846
	847	This is a list of fields which are unknown to the profile. Whether or
	848	not this indicates an error in the user input is application
	849	dependent.
	850
	851	=back
	852
	853	=head2 constraints (profile key)
	854
	855	This is a supported but deprecated profile key. Using C<constraint_methods> is
	856	recommended instead, which provides a simpler, more versatile interface.
	857
	858	constraints => {
	859	cc_no => {
	860	constraint => "cc_number",
	861	params => [ qw( cc_no cc_type ) ],
	862	},
	863	cc_type => "cc_type",
	864	cc_exp => "cc_exp",
	865	},
	866
	867	A hash ref which contains the constraints that
	868	will be used to check whether or not the field contains valid data.
	869
	870	The keys in this hash are field names. The values can be any of the following:
	871
	872	=over
	873
	874	=item o
	875
	876	A named constraint.
	877
	878	B<Example>:
	879
	880	my_zipcode_field => 'zip',
	881
	882	See L<Data::FormValidator::Constraints> for the details of which
	883	built-in constraints that are available.
	884
	885	=back
	886
	887	=head2 hashref style of specifying constraints
	888
	889	Using a hash reference to specify a constraint is an older technique
	890	used to name a constraint or supply multiple parameters.
	891
	892	Both of these interface issues are now better addressed with C<constraint_methods>
	893	and C<$self-\>name_this('foo')>.
	894
	895	# supply multiple parameters
	896	cc_no => {
	897	constraint => "cc_number",
	898	params => [ qw( cc_no cc_type ) ],
	899	},
	900
	901	# name a constraint, useful for returning error messages
	902	last_name => {
	903	name => "ends_in_name",
	904	constraint => qr/_name$/,
	905	},
	906
	907	Using a hash reference for a constraint permits the passing of multiple
	908	arguments. Required arguments are C<constraint> or C<constraint_method>.
	909	Optional arguments are C<name> and C<params>.
	910
	911	A C<name> on a constraints 'glues' the constraint to its error message
	912	in the validator profile (refer C<msgs> section below). If no C<name> is
	913	given then it will default to the value of C<constraint> or
	914	C<constraint_method> IF they are NOT a CODE ref or a RegExp ref.
	915
	916	The C<params> value is a reference to an array of the parameters to pass
	917	to the constraint method.
	918	If an element of the C<params> list is a scalar, it is assumed to be naming
	919	a key of the %input_hash and that value is passed to the routine.
	920	If the parameter is a reference, then it is treated literally and passed
	921	unchanged to the routine.
	922
	923	If you are using the older C<constraint> over
	924	the new C<constraint_method> then don't forget to include the name of the
	925	field to check in the C<params> list. C<constraint_method> provides access
	926	to this value via the C<get_current_*> methods
	927	(refer L<Data::FormValidator::Constraints>)
	928
	929	For more details see L<VALIDATING INPUT BASED ON MULTIPLE FIELDS>.
	930
	931	=head2 constraint_regexp_map (profile key)
	932
	933	This is a supported but deprecated profile key. Using
	934	C<constraint_methods_regexp_map> is recommended instead.
	935
	936	constraint_regexp_map => {
	937	# All fields that end in _postcode have the 'postcode' constraint applied.
	938	qr/_postcode$/ => 'postcode',
	939	},
	940
	941	A hash ref where the keys are the regular expressions to
	942	use and the values are the constraints to apply.
	943
	944	If one or more constraints have already been defined for a given field using
	945	"constraints", constraint_regexp_map will add an additional constraint for that
	946	field for each regular expression that matches.
	947
	948	=head1 SEE ALSO
	949
	950	B<Other modules in this distribution:>
	951
	952	L<Data::FormValidator::Constraints\|Data::FormValidator::Constraints>
	953
	954	L<Data::FormValidator::Constraints::Dates\|Data::FormValidator::Constraints::Dates>
	955
	956	L<Data::FormValidator::Constraints::Upload\|Data::FormValidator::Constraints::Upload>
	957
	958	L<Data::FormValidator::ConstraintsFactory\|Data::FormValidator::ConstraintsFactory>
	959
	960	L<Data::FormValidator::Filters\|Data::FormValidator::Filters>
	961
	962	L<Data::FormValidator::Results\|Data::FormValidator::Results>
	963
	964	B<A sample application by the maintainer:>
	965
	966	Validating Web Forms with Perl, L<http://mark.stosberg.com/Tech/perl/form-validation/>
	967
	968	B<Related modules:>
	969
	970	L<Data::FormValidator::Tutorial\|Data::FormValidator::Tutorial>
	971
	972	L<Data::FormValidator::Util::HTML\|Data::FormValidator::Util::HTML>
	973
	974	L<CGI::Application::ValidateRM\|CGI::Application::ValidateRM>, a
	975	CGI::Application & Data::FormValidator glue module
	976
	977	L<HTML::Template::Associate::FormValidator\|HTML::Template::Associate::FormValidator> is designed
	978	to make some kinds of integration with HTML::Template easier.
	979
	980	L<Params::Validate\|Params::Validate> is useful for validating function parameters.
	981
	982	L<Regexp::Common\|Regexp::Common>,
	983	L<Data::Types\|Data::Types>,
	984	L<Data::Verify\|Data::Verify>,
	985	L<Email::Valid\|Email::Valid>,
	986	L<String::Checker\|String::Checker>,
	987	L<CGI::ArgChecker\|CGI::ArgChecker>,
	988	L<CGI::FormMagick::Validator\|CGI::FormMagick::Validator>,
	989	L<CGI::Validate\|CGI::Validate>
	990
	991	B<Document Translations:>
	992
	993	Japanese: L<http://perldoc.jp/docs/modules/>
	994
	995	B<Distributions which include Data::FormValidator>
	996
	997	FreeBSD includes a port named B<p5-Data-FormValidator>
	998
	999	Debian GNU/Linux includes a port named B<libdata-formvalidator-perl>
	1000
	1001	=head1 CREDITS
	1002
	1003	Some of these input validation functions have been taken from MiniVend
	1004	by Michael J. Heins.
	1005
	1006	The credit card checksum validation was taken from contribution by Bruce
	1007	Albrecht to the MiniVend program.
	1008
	1009	=head1 BUGS
	1010
	1011	Bug reports and patches are welcome. Reports which include a failing Test::More
	1012	style test are helpful and will receive priority.
	1013
	1014	L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Data-FormValidator>
	1015
	1016	=head1 CONTRIBUTING
	1017
	1018	This project is maintained on L<Github\|https://github.com/dnmfarrell/Data-FormValidator>.
	1019
	1020	=head1 AUTHOR
	1021
	1022	Currently maintained by David Farrell <dfarrell@cpan.org>
	1023
	1024	Parts Copyright 2001-2006 by Mark Stosberg <mark at summersault.com>, (previous maintainer)
	1025
	1026	Copyright (c) 1999 Francis J. Lacoste and iNsu Innovations Inc. All rights reserved.
	1027	(Original Author)
	1028
	1029	Parts Copyright 1996-1999 by Michael J. Heins <mike@heins.net>
	1030
	1031	Parts Copyright 1996-1999 by Bruce Albrecht <bruce.albrecht@seag.fingerhut.com>
	1032
	1033	=head1 LICENSE
	1034
	1035	This program is free software; you can redistribute it and/or modify
	1036	it under the terms as perl itself.
	1037
	1038
	1039	=cut
	1040

-1

lib/Data/FormValidator/Constraints/Dates.pm less more

13	13	match_date_and_time
14	14	);
15	15
16		our $VERSION = '4.81';
	16	our $VERSION = 4.88;
17	17
18	18	sub date_and_time {
19	19	my $fmt = shift;

-2

lib/Data/FormValidator/Constraints/Upload.pm less more

23	23	image_min_dimensions
24	24	);
25	25
26		our $VERSION = 4.81;
	26	our $VERSION = 4.88;
27	27
28	28	sub file_format {
29	29	my %params = @_;

310	310	else {
311	311	return IO::File->new_from_fd(fileno($q->{$field}), 'r');
312	312	}
313
314	313	}
315	314
316	315	## returns mime type if included as part of the send

+22

-9

lib/Data/FormValidator/Constraints.pm less more

23	23	use strict;
24	24	our $AUTOLOAD;
25	25
26		our $VERSION = 4.81;
	26	our $VERSION = 4.88;
27	27
28	28	BEGIN {
29	29	use Carp;

411	411	my $param = $dfv->get_current_constraint_field();
412	412	my $value = $dfv->get_filtered_data()->{$param};
413	413
414		my $num_values = scalar @$value;
415
416		return ($num_values >= $min) && ($num_values <= $max) if ref $value eq 'ARRAY';
417		return 1 if $min == 0 && $max >= 2; # scalar, size could be 1
418		return 0; # scalar, size can't be 1
	414	if (ref($value) eq 'ARRAY') {
	415	my $num_values = scalar @$value;
	416
	417	return(
	418	(
	419	$num_values >= $min
	420	&& $num_values <= $max
	421	) ? 1 : 0
	422	);
	423	} else {
	424	if ($min <= 1 && $max >= 1) {
	425	# Single value is allowed
	426	return 1;
	427	} else {
	428	return 0;
	429	}
	430	}
419	431	}
420	432	}
421	433

642	654	return undef unless $card_type =~ /^[admv]/i;
643	655
644	656	return undef if ($card_type =~ /^v/i && substr($the_card, 0, 1) ne "4") \|\|
645		($card_type =~ /^m/i && substr($the_card, 0, 1) ne "5") \|\|
	657	($card_type =~ /^m/i && substr($the_card, 0, 1) ne "5" &&
	658	substr($the_card, 0, 1) ne "2") \|\|
646	659	($card_type =~ /^d/i && substr($the_card, 0, 4) ne "6011") \|\|
647	660	($card_type =~ /^a/i && substr($the_card, 0, 2) ne "34" &&
648	661	substr($the_card, 0, 2) ne "37");

1068	1081
1069	1082	=item L<Data::FormValidator::Filters> - transform data before constraints are applied
1070	1083
1071		=item L<Data::FormValidator::ConstraintsFactory> - This is a historical collection of constraints that suffer from cumbersome names. They are worth reviewing though-- C<make_and_constraint> will allow to validate against a list of constraints and shortcircuit if the first one fails. That's perfect if the second constraint depends on the first one having passed.
1072		For a modern version of this toolkit, see L<Data::FormValidator::Constraints::MethodsFactory>.
	1084	=item L<Data::FormValidator::ConstraintsFactory> - This is a historical collection of constraints that suffer from cumbersome names. They are worth reviewing though-- C<make_and_constraint> will allow one to validate against a list of constraints and shortcircuit if the first one fails. That's perfect if the second constraint depends on the first one having passed.
	1085	For a modern version of this toolkit, see L<Data::FormValidator::Constraints::MethodsFactory>.
1073	1086
1074	1087	=item L<Data::FormValidator>
1075	1088

-1

lib/Data/FormValidator/ConstraintsFactory.pm less more

44	44	=cut
45	45
46	46	BEGIN {
47		our $VERSION = 4.81;
	47	our $VERSION = 4.88;
48	48	our @EXPORT = ();
49	49	our @EXPORT_OK = (qw/make_length_constraint/);
50	50

-1

lib/Data/FormValidator/Filters.pm less more

12	12	use Exporter 'import';
13	13	use strict;
14	14
15		our $VERSION = 4.81;
	15	our $VERSION = 4.88;
16	16
17	17	our @EXPORT_OK = qw(
18	18	filter_alphanum

+101

-5

lib/Data/FormValidator/Results.pm less more

13	13	use strict;
14	14
15	15	package Data::FormValidator::Results;
16		use Perl6::Junction 'any';
17	16	use Carp;
18	17	use Symbol;
19	18	use Data::FormValidator::Filters ':filters';

22	21	'bool' => \&_bool_overload_based_on_success,
23	22	fallback => 1;
24	23
25		our $VERSION = 4.81;
	24	our $VERSION = 4.88;
26	25
27	26	=pod
28	27

188	187	}
189	188
190	189	# handle "require_some"
	190	while (my ($field, $dependent_require_some) = each %{$profile->{dependent_require_some}}) {
	191	if (defined $valid{$field}) {
	192	if (ref $dependent_require_some eq "CODE") {
	193	for my $value (_arrayify($valid{$field})) {
	194	my $returned_require_some = $dependent_require_some->($self, $value);
	195
	196	if (ref($returned_require_some) eq 'HASH') {
	197	foreach my $key (keys %$returned_require_some) {
	198	$profile->{require_some}->{$key} = $returned_require_some->{$key};
	199	}
	200	}
	201	}
	202	} else {
	203	if (ref($dependent_require_some) eq 'HASH') {
	204	foreach my $key (keys %$dependent_require_some) {
	205	$profile->{require_some}->{$key} = $dependent_require_some->{$key};
	206	}
	207	}
	208	}
	209	}
	210	}
	211
191	212	my %require_some;
192	213	while ( my ( $field, $deps) = each %{$profile->{require_some}} ) {
193	214	for my $dep (_arrayify($deps)){

264	285	}
265	286	}
266	287
	288	my $dependency_re;
	289
	290	foreach my $re (keys %{$profile->{dependencies_regexp}}) {
	291	my $sub = _create_sub_from_RE($re);
	292
	293	$dependency_re->{$re} = {
	294	sub => $sub,
	295	value => $profile->{dependencies_regexp}->{$re},
	296	};
	297	}
	298
	299	if ($dependency_re) {
	300	foreach my $k (keys %valid) {
	301	foreach my $re (keys %$dependency_re) {
	302	if ($dependency_re->{$re}->{sub}->($k)) {
	303	my $deps = $dependency_re->{$re}->{value};
	304
	305	if (ref($deps) eq 'HASH') {
	306	for my $key (keys %$deps) {
	307	# Handle case of a key with a single value given as an arrayref
	308	# There is probably a better, more general solution to this problem.
	309	my $val_to_compare;
	310
	311	if ((ref $valid{$k} eq 'ARRAY') and (scalar @{ $valid{$k} } == 1)) {
	312	$val_to_compare = $valid{$k}->[0];
	313	} else {
	314	$val_to_compare = $valid{$k}
	315	}
	316
	317	if($val_to_compare eq $key){
	318	for my $dep (_arrayify($deps->{$key})){
	319	$required{$dep} = 1;
	320	}
	321	}
	322	}
	323	} elsif (ref $deps eq "CODE") {
	324	for my $val (_arrayify($valid{$k})) {
	325	my $returned_deps = $deps->($self, $val, $k);
	326
	327	for my $dep (_arrayify($returned_deps)) {
	328	$required{$dep} = 1;
	329	}
	330	}
	331	} else {
	332	for my $dep (_arrayify($deps)){
	333	$required{$dep} = 1;
	334	}
	335	}
	336	}
	337	}
	338	}
	339	}
	340
	341	# Check if the presence of some fields makes other fields optional.
	342	while (my ($field, $dependent_optional) = each %{$profile->{dependent_optionals}} ) {
	343	if (defined $valid{$field}) {
	344	if (ref $dependent_optional eq "CODE") {
	345	for my $value (_arrayify($valid{$field})) {
	346	my $returned_optionals = $dependent_optional->($self, $value);
	347
	348
	349
	350	foreach my $optional (_arrayify($returned_optionals)) {
	351	$optional{$optional} = 1;
	352	}
	353	}
	354	} else {
	355	foreach my $optional (_arrayify($dependent_optional)){
	356	$optional{$optional} = 1;
	357	}
	358	}
	359	}
	360	}
	361
267	362	# Find unknown
268	363	@unknown =
269	364	grep { not (exists $optional{$_} or exists $required{$_} or exists $require_some{$_} ) } keys %valid;

851	946
852	947	# if it's a reference, return an array unless it points to an empty array. -mls
853	948	if ( ref $val eq 'ARRAY' ) {
854		$^W = 0; # turn off warnings about undef
855		return ( any(@$val) ne undef ) ? @$val : ();
	949	local $^W = 0; # turn off warnings about undef
	950	return grep(defined, @$val) ? @$val : ();
856	951	}
857	952	# if it's a string, return an array unless the string is missing or empty. -mls
858	953	else {

1070	1165	@v = $data->upload($k) \|\| $data->param($k);
1071	1166	}
1072	1167	else {
1073		@v = $data->param($k);
	1168	# insecure
	1169	@v = $data->multi_param($k);
1074	1170	}
1075	1171
1076	1172	# we expect param to return an array if there are multiple values

+116

-36

lib/Data/FormValidator.pm less more

3	3	# This file is part of Data::FormValidator.
4	4	#
5	5	# Author: Francis J. Lacoste
6		# Maintainer: Mark Stosberg <mark@stosberg.com>
	6	# Previous Maintainer: Mark Stosberg <mark@stosberg.com>
	7	# Maintainer: David Farrell <dfarrell@cpan.org>
7	8	#
8	9	# Copyright (C) 1999 Francis J. Lacoste, iNsu Innovations
9	10	# Parts Copyright 1996-1999 by Michael J. Heins

22	23
23	24	package Data::FormValidator;
24	25	use Exporter 'import';
	26	use File::Spec qw();
25	27	use 5.008;
26	28
27		use Perl6::Junction qw(any none);
28	29	use Data::FormValidator::Results;
29	30	*_arrayify = \&Data::FormValidator::Results::_arrayify;
30	31	use Data::FormValidator::Filters ':filters';
31	32	use Data::FormValidator::Constraints qw(:validators :matchers);
32	33
33		our $VERSION = '4.81';
	34	our $VERSION = 4.88;
34	35
35	36	our %EXPORT_TAGS = (
36	37	filters => [qw/

122	123	Data::FormValidator lets you define profiles which declare the
123	124	required and optional fields and any constraints they might have.
124	125
125		The results are provided as an object which makes it easy to handle
	126	The results are provided as an object, which makes it easy to handle
126	127	missing and invalid results, return error messages about which constraints
127	128	failed, or process the resulting valid data.
128	129

146	147	$profiles = $profiles_or_file;
147	148	}
148	149	else {
149		$file = $profiles_or_file;
	150	$file = File::Spec->rel2abs( $profiles_or_file );
150	151	}
151	152
152	153

165	166
166	167	C<check> is the recommended method to use to validate forms. It returns its results as a
167	168	L<Data::FormValidator::Results\|Data::FormValidator::Results> object. A
168		deprecated method C<validate> is also available, returning its results as an
169		array described below.
	169	deprecated method C<validate> described below is also available, returning its results as an
	170	array.
170	171
171	172	use Data::FormValidator;
172	173	my $results = Data::FormValidator->check(\%input_hash, \%dfv_profile);

474	475	interdependent fields. The keys are arbitrary names that you create and
475	476	the values are references to arrays of the field names in each group.
476	477
	478	=head2 dependencies_regexp
	479
	480	dependencies_regexp => {
	481	qr/Line\d+\_ItemType$/ => sub {
	482	my $dfv = shift;
	483	my $itemtype = shift;
	484	my $field = shift;
	485
	486	if ($type eq 'NeedsBatteries') {
	487	my ($prefix, $suffix) = split(/\_/, $field);
	488
	489	return([$prefix . '_add_batteries]);
	490	} else {
	491	return([]);
	492	}
	493	},
	494	},
	495
	496	This is a regular expression used to specify additional fields which are
	497	dependent. For example, if you wanted to add dependencies for all fields which
	498	meet a certain criteria (such as multiple items in a shopping cart) where you
	499	do not know before hand how many of such fields you may have.
	500
	501	=head2 dependent_optionals
	502
	503	dependent_optionals => {
	504	# If delivery_address is specified then delivery_notes becomes optional
	505	"delivery_address" => [ qw( delivery_notes ) ],
	506
	507	# if delivery_type eq 'collection', collection_notes becomes optional
	508	"delivery_type" => {
	509	collection => [ qw( collection_notes ) ],
	510	}
	511
	512	# if callback_type is "phone" or "email" then additional_notes becomes optional
	513	"callback_type" => sub {
	514	my $dfv = shift;
	515	my $type = shift;
	516
	517	if ($type eq 'phone' \|\| $type eq 'email') {
	518	return(['additional_notes']);
	519	} else {
	520	return([]);
	521	}
	522	},
	523	},
	524
	525	This is for the case where an optional field can trigger other optional fields.
	526	The dependent optional fields can be specified with an array reference.
	527
	528	If the dependent optional fields are specified with a hash reference, then an
	529	additional constraint is added that the optional field must equal a key for the
	530	additional optional fields to be added.
	531
	532	If the dependent optional fields are specified as a code reference then the
	533	code will be executed to determine the additional optional fields. It is passed
	534	two parameters, the object and the value of the field, and it should return an
	535	array reference containing the list of additional optional fields.
	536
	537	=head2 dependent_require_some
	538
	539	dependent_require_some => {
	540	# require any fields from this group if AddressID is "new"
	541	AddressID => sub {
	542	my $dfv = shift;
	543	my $value = shift;
	544
	545	if ($value eq 'new') {
	546	return({
	547	house_name_or_number => [ 1, 'HouseName', 'HouseNumber' ],
	548	});
	549	} else {
	550	return;
	551	}
	552	},
	553	}
	554
	555	Sometimes a field will need to trigger additional dependencies but you only
	556	require some of the fields. You cannot set them all to be dependent as you
	557	might only have some of them, and you cannot set them all to be optional as
	558	you must have some of them. This method allows you to specify this in a
	559	similar way to the equire_some method but dependent upon other values. In
	560	the example above if the AddressID submitted is "new" then at least 1 of
	561	HouseName and HouseNumber must also be supplied. See require_some for the
	562	valid options for the return.
	563
477	564	=head2 defaults
478	565
479	566	defaults => {

866	953	constraint and include a C<name> key with a value set to the name of your
867	954	constraint. Here's an example:
868	955
869		my_zipcode_field => [
870		'zip',
871		{
872		constraint => '/^406/',
873		name => 'starts_with_406',
874		}
875		],
	956	my_zipcode_field => [
	957	'zip',
	958	{
	959	constraint_method => '/^406/',
	960	name => 'starts_with_406',
	961	}
	962	],
876	963
877	964	You can use an array reference with a single constraint in it if you just want
878	965	to have the name of your failed constraint returned in the above fashion.

922	1009	defaults
923	1010	defaults_regexp_map
924	1011	dependencies
	1012	dependencies_regexp
925	1013	dependency_groups
	1014	dependent_optionals
	1015	dependent_require_some
926	1016	field_filter_regexp_map
927	1017	field_filters
928	1018	filters

943	1033	# If any of the keys in the profile are not listed as
944	1034	# valid keys here, we die with an error
945	1035	for my $key (keys %$profile) {
946		push @invalid, $key unless ($key eq any(@valid_profile_keys));
	1036	push @invalid, $key unless grep $key eq $_, @valid_profile_keys;
947	1037	}
948	1038
949	1039	local $" = ', ';

964	1054	# Could be improved by also naming the associated key for the bad value.
965	1055	for my $key (grep { $profile->{$_} } qw/constraint_methods constraint_method_regexp_map/) {
966	1056	for my $val (map { _arrayify($_) } values %{ $profile->{$key} }) {
967		if ((ref $val eq 'HASH') and ref $val->{constraint_method} eq none('CODE','Regexp')) {
	1057	if (ref $val eq 'HASH' && !grep(ref $val->{constraint_method} eq $_, 'CODE','Regexp')) {
968	1058	die "Value for constraint_method within hashref '$val->{constraint_method}' not a code reference or Regexp . Do you need func(), not 'func'?";
969	1059	}
970	1060	# Cases 1 through 4.
971		elsif (ref $val eq none('HASH','CODE','Regexp')) {
	1061	elsif (!grep(ref $val eq $_, 'HASH','CODE','Regexp')) {
972	1062	die "Value for constraint_method '$val' not a code reference or Regexp . Do you need func(), not 'func'?";
973	1063	}
974	1064	# Case 5.

995	1085
996	1086	for my $href (@constraint_hashrefs) {
997	1087	for my $key (keys %$href) {
998		push @invalid, $key unless ($key eq any(@valid_constraint_hash_keys));
	1088	push @invalid, $key unless grep $key eq $_, @valid_constraint_hash_keys;
999	1089	}
1000	1090	}
1001	1091

1018	1108	/);
1019	1109	if (ref $profile->{msgs} eq 'HASH') {
1020	1110	for my $key (keys %{ $profile->{msgs} }) {
1021		push @invalid, $key unless ($key eq any(@valid_msgs_hash_keys));
	1111	push @invalid, $key unless grep $key eq $_, @valid_msgs_hash_keys;
1022	1112	}
1023	1113	}
1024	1114	if (@invalid) {

1165	1255
1166	1256	=head2 constraint_regexp_map (profile key)
1167	1257
1168		This is a supported by deprecated profile key. Using
	1258	This is a supported but deprecated profile key. Using
1169	1259	C<constraint_methods_regexp_map> is recommended instead.
1170	1260
1171	1261	constraint_regexp_map => {

1235	1325
1236	1326	=head1 CREDITS
1237	1327
1238		Some of those input validation functions have been taken from MiniVend
	1328	Some of these input validation functions have been taken from MiniVend
1239	1329	by Michael J. Heins.
1240	1330
1241	1331	The credit card checksum validation was taken from contribution by Bruce

1244	1334	=head1 BUGS
1245	1335
1246	1336	Bug reports and patches are welcome. Reports which include a failing Test::More
1247		style test are helpful will receive priority.
	1337	style test are helpful and will receive priority.
1248	1338
1249	1339	L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Data-FormValidator>
1250	1340
1251	1341	=head1 CONTRIBUTING
1252	1342
1253		This project is managed using the darcs source control system (
1254		http://www.darcs.net/ ). You can browse, pull and fork the repo here:
1255
1256		http://hub.darcs.net/markstos/Data--FormValidator
1257
1258		B<Support Mailing List>
1259
1260		If you have any questions, comments, or feature suggestions, post them to the
1261		support mailing list! To join the mailing list, visit
1262
1263		L<http://lists.sourceforge.net/lists/listinfo/cascade-dataform>
1264
1265		Messages about DFV sent directly to the maintainer may be redirected here.
	1343	This project is maintained on L<Github\|https://github.com/dnmfarrell/Data-FormValidator>.
1266	1344
1267	1345	=head1 AUTHOR
1268	1346
1269		Parts Copyright 2001-2006 by Mark Stosberg <mark at summersault.com>, (Current Maintainer)
	1347	Currently maintained by David Farrell <dfarrell@cpan.org>
	1348
	1349	Parts Copyright 2001-2006 by Mark Stosberg <mark at summersault.com>, (previous maintainer)
1270	1350
1271	1351	Copyright (c) 1999 Francis J. Lacoste and iNsu Innovations Inc. All rights reserved.
1272	1352	(Original Author)

+17

-20

t/00_base.t less more

0
	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
1	3	use Test::More tests => 5;
2	4
3		BEGIN {
	5	BEGIN
	6	{
4	7	use_ok('Data::FormValidator');
5	8	}
6	9
7	10	my $dfv;
8		eval { $dfv = Data::FormValidator->new({}, 'wrong'); };
9		like ($@, qr/must be a hash ref/, 'second argument must be a hash ref or die');
	11	eval { $dfv = Data::FormValidator->new( {}, 'wrong' ); };
	12	like( $@, qr/must be a hash ref/, 'second argument must be a hash ref or die' );
10	13
11		eval {
12		$dfv = Data::FormValidator->new('test/00_base.WRONG');
13		my $results = $dfv->check({}, 'profile1');
	14	eval {
	15	$dfv = Data::FormValidator->new('test/00_base.WRONG');
	16	my $results = $dfv->check( {}, 'profile1' );
14	17	};
15		like($@, qr/no such file/i, 'bad profile file names should cause death');
	18	like( $@, qr/no such file/i, 'bad profile file names should cause death' );
16	19
17		eval {
18		$dfv = Data::FormValidator->new('test/00_base.badformat');
19		my $results = $dfv->check({}, 'profile1');
	20	eval {
	21	$dfv = Data::FormValidator->new('test/00_base.badformat');
	22	my $results = $dfv->check( {}, 'profile1' );
20	23	};
21		like($@, qr/return a hash ref/, 'profile files should return a hash ref');
	24	like( $@, qr/return a hash ref/, 'profile files should return a hash ref' );
22	25
23	26	eval { $dfv = Data::FormValidator->new('test/00_base.profile'); };
24	27
25		my $results = $dfv->check({}, 'profile1');
	28	my $results = $dfv->check( {}, 'profile1' );
26	29
27		ok(scalar $results->missing, 'loading a profile from a file works');
28
29
30
31
32
33
	30	ok( scalar $results->missing, 'loading a profile from a file works' );

+42

-40

t/02_code_ref.t less more

0
	0	#!/usr/bin/env perl
1	1	use strict;
2
3		$^W = 1;
4
	2	use warnings;
5	3	use Test::More tests => 8;
6
7	4	use Data::FormValidator;
8	5
9	6	my $input_profile = {
10		required => [ qw( email phone likes ) ],
11		optional => [ qq( toppings ) ],
12		constraints => {
13		email => "email",
14		phone => "phone",
15		likes => { constraint => sub {return 1;},
16		params => [ qw( likes email ) ],
17		},
18		},
19		dependencies => {
20		animal => [qw( species no_legs )],
21		plant => {
22		tree => [qw( trunk root )],
23		flower => [qw( petals stem )],
24		},
25		},
26		field_filters => {
27		email => sub {return $_[0];},
28		},
29		};
	7	required => [qw( email phone likes )],
	8	optional => [qq( toppings )],
	9	constraints => {
	10	email => "email",
	11	phone => "phone",
	12	likes => {
	13	constraint => sub { return 1; },
	14	params => [qw( likes email )],
	15	},
	16	},
	17	dependencies => {
	18	animal => [qw( species no_legs )],
	19	plant => {
	20	tree => [qw( trunk root )],
	21	flower => [qw( petals stem )],
	22	},
	23	},
	24	field_filters => {
	25	email => sub { return $_[0]; },
	26	},
	27	};
30	28
31		my $validator = new Data::FormValidator({default => $input_profile});
	29	my $validator = new Data::FormValidator( { default => $input_profile } );
32	30
33		my $input_hashref = {email => 'invalidemail',
34		phone => '201-999-9999',
35		likes => ['a','b'],
36		toppings => 'foo',
37		animal => 'goat',
38		plant => 'flower'};
	31	my $input_hashref = {
	32	email => 'invalidemail',
	33	phone => '201-999-9999',
	34	likes => [ 'a', 'b' ],
	35	toppings => 'foo',
	36	animal => 'goat',
	37	plant => 'flower'
	38	};
39	39
40		my ($valids, $missings, $invalids, $unknowns);
	40	my ( $valids, $missings, $invalids, $unknowns );
41	41
42		eval{ ($valids, $missings, $invalids, $unknowns) = $validator->validate($input_hashref, 'default') };
	42	eval
	43	{
	44	( $valids, $missings, $invalids, $unknowns ) =
	45	$validator->validate( $input_hashref, 'default' );
	46	};
43	47	is $@, '', 'survives';
44	48
45		ok(exists $valids->{'phone'}, "phone is valid");
	49	ok( exists $valids->{'phone'}, "phone is valid" );
46	50
47		is($invalids->[0], 'email', 'email is invalid');
	51	is( $invalids->[0], 'email', 'email is invalid' );
48	52
49	53	my %missings;
50	54	@missings{@$missings} = ();
51		#print "@$missings\n";
52		ok(exists $missings{$_}) for (qw(species no_legs petals stem));
53		is(@$missings, 4);
54
	55	ok( exists $missings{$_} ) for (qw(species no_legs petals stem));
	56	is( @$missings, 4 );

+56

-68

t/03_dependency.t less more

	0	#!/usr/bin/env perl
0	1	use strict;
1
2		$^W = 1;
3
4		use Test::More tests => 23;
	2	use warnings;
	3	use Test::More;
5	4	use Data::FormValidator;
6	5
7	6	# test profile
8	7	my $input_profile = {
9		dependencies => {
10		pay_type => {
11		Check => [qw( cc_num )],
12		# Value of Zero is used for test for a specific bug
13		0 => [qw( cc_num cc_exp cc_name )],
14		},
15		},
	8	dependencies => {
	9	pay_type => {
	10	Check => [qw( cc_num )],
	11
	12	# Value of Zero is used for test for a specific bug
	13	0 => [qw( cc_num cc_exp cc_name )],
	14	},
	15	},
16	16	};
17		my $input_hashref = {pay_type=>'0'};
18
	17	my $input_hashref = { pay_type => '0' };
19	18
20	19	##
21	20	## Validate a complex dependency

24	23	##
25	24	## validate()
26	25
27		my ($valids, $missings, $invalids, $unknowns);
28		my $validator = Data::FormValidator->new({default => $input_profile});
29		eval{
30		($valids, $missings, $invalids, $unknowns) = $validator->validate($input_hashref, 'default');
	26	my ( $valids, $missings, $invalids, $unknowns );
	27	my $validator = Data::FormValidator->new( { default => $input_profile } );
	28	eval {
	29	( $valids, $missings, $invalids, $unknowns ) =
	30	$validator->validate( $input_hashref, 'default' );
31	31	};
32		ok(!$@, "no eval problems");
	32	ok( !$@, "no eval problems" );
33	33
34		my %missings = map {$_ => 1} @$missings;
35		ok($missings{cc_num}, "missing cc_num");
36		ok($missings{cc_exp}, "missing cc_exp");
37		ok($missings{cc_name}, "missing cc_name");
38
	34	my %missings = map { $_ => 1 } @$missings;
	35	ok( $missings{cc_num}, "missing cc_num" );
	36	ok( $missings{cc_exp}, "missing cc_exp" );
	37	ok( $missings{cc_name}, "missing cc_name" );
39	38
40	39	##
41	40	## check()
42	41
43	42	my $result;
44		eval {
45		$result = $validator->check($input_hashref, 'default');
46		};
	43	eval { $result = $validator->check( $input_hashref, 'default' ); };
47	44
48		ok(!$@, "no eval problems");
49		isa_ok($result, "Data::FormValidator::Results", "returned object");
	45	ok( !$@, "no eval problems" );
	46	isa_ok( $result, "Data::FormValidator::Results", "returned object" );
50	47
51		ok($result->has_missing, "has_missing returned true");
52		ok($result->missing('cc_num'), "missing('cc_num') returned true");
53		ok($result->missing('cc_exp'), "missing('cc_exp') returned true");
54		ok($result->missing('cc_name'), "missing('cc_name') returned true");
55
56
	48	ok( $result->has_missing, "has_missing returned true" );
	49	ok( $result->missing('cc_num'), "missing('cc_num') returned true" );
	50	ok( $result->missing('cc_exp'), "missing('cc_exp') returned true" );
	51	ok( $result->missing('cc_name'), "missing('cc_name') returned true" );
57	52
58	53	##
59	54	## validate()
60	55
61		$input_hashref = {pay_type=>'Check'
62		};
	56	$input_hashref = { pay_type => 'Check' };
63	57
64		eval{
65		($valids, $missings, $invalids, $unknowns) = $validator->validate($input_hashref, 'default');
	58	eval {
	59	( $valids, $missings, $invalids, $unknowns ) =
	60	$validator->validate( $input_hashref, 'default' );
66	61	};
67		ok(!$@, "no eval problems");
	62	ok( !$@, "no eval problems" );
68	63
69		%missings = map {$_ => 1} @$missings;
70		ok($missings{cc_num}, 'missing cc_num');
71		ok(!$missings{cc_exp}, 'not missing cc_exp');
72		ok(!$missings{cc_name}, 'not missing cc_name');
73
	64	%missings = map { $_ => 1 } @$missings;
	65	ok( $missings{cc_num}, 'missing cc_num' );
	66	ok( !$missings{cc_exp}, 'not missing cc_exp' );
	67	ok( !$missings{cc_name}, 'not missing cc_name' );
74	68
75	69	##
76	70	## check()
77	71
78	72	$result = undef;
79		eval {
80		$result = $validator->check($input_hashref, 'default');
81		};
	73	eval { $result = $validator->check( $input_hashref, 'default' ); };
82	74
83		ok(!$@, "no eval problems");
84		isa_ok($result, "Data::FormValidator::Results", "returned object");
	75	ok( !$@, "no eval problems" );
	76	isa_ok( $result, "Data::FormValidator::Results", "returned object" );
85	77
86		ok($result->has_missing, "has_missing returned true");
87		ok($result->missing('cc_num'), "missing('cc_num') returned true");
88		is($result->missing('cc_exp'), undef, "missing('cc_exp') returned false");
89		is($result->missing('cc_name'), undef, "missing('cc_name') returned false");
	78	ok( $result->has_missing, "has_missing returned true" );
	79	ok( $result->missing('cc_num'), "missing('cc_num') returned true" );
	80	is( $result->missing('cc_exp'), undef, "missing('cc_exp') returned false" );
	81	is( $result->missing('cc_name'), undef, "missing('cc_name') returned false" );
90	82
	83	eval { require CGI;CGI->VERSION(4.35); };
	84	SKIP:
	85	{
	86	skip 'CGI 4.35 or higher not found', 3 if $@;
91	87
92
93		## Now, some tests using a CGI.pm object as input
94		use CGI;
95		my $q = CGI->new('pay_type=0');
96		my $results;
97		eval {
98		$results = $validator->check($q, 'default');
99		};
100		ok($results->missing('cc_num'), 'using CGI.pm object for input');
101		is($result->missing('cc_exp'), undef, "missing('cc_exp') returned false");
102		is($result->missing('cc_name'), undef, "missing('cc_name') returned false");
103
104
105
106
	88	my $q = CGI->new('pay_type=0');
	89	my $results = $validator->check( $q, 'default' );
	90	ok( $results->missing('cc_num'), 'using CGI.pm object for input' );
	91	is( $result->missing('cc_exp'), undef, "missing('cc_exp') returned false" );
	92	is( $result->missing('cc_name'), undef, "missing('cc_name') returned false" );
	93	}
	94	done_testing;

+22

-19

t/04_arrayify_undef.t less more

	0	#!/usr/bin/env perl
0	1	use strict;
1		$^W = 1;
2
	2	use warnings;
3	3	use Test::More tests => 4;
4	4
5	5	{
6		my $test_name =
7		"checks for correct behavior when 'required'
	6	my $test_name = "checks for correct behavior when 'required'
8	7	is not specified; fails if _arrayify() does not return an empty list";
9	8
10		use Data::FormValidator;
11		my $input_profile = { optional => [ qw( email ) ] };
12		my $validator = Data::FormValidator->new({default => $input_profile});
	9	use Data::FormValidator;
	10	my $input_profile = { optional => [qw( email )] };
	11	my $validator = Data::FormValidator->new( { default => $input_profile } );
13	12
14		my $input_hashref = {email => 'bob@example.com' };
	13	my $input_hashref = { email => 'bob@example.com' };
15	14
16		my ($valids, $missings, $invalids, $unknowns);
17		eval{ ($valids, $missings, $invalids, $unknowns) = $validator->validate($input_hashref, 'default') };
18		is($@, '', $test_name);
19		is(@$missings, 0, $test_name);
	15	my ( $valids, $missings, $invalids, $unknowns );
	16	eval
	17	{
	18	( $valids, $missings, $invalids, $unknowns ) =
	19	$validator->validate( $input_hashref, 'default' );
	20	};
	21	is( $@, '', $test_name );
	22	is( @$missings, 0, $test_name );
20	23	}
21	24
22	25	{
23		my $test_name = "arrayref with first element undef";
24		use Data::FormValidator::Results;
	26	my $test_name = "arrayref with first element undef";
	27	use Data::FormValidator::Results;
25	28
26		my $inputs = [ undef, 1, 2, 3, "Echo", "Foxtrot" ];
27		my $retval = Data::FormValidator::Results::_arrayify($inputs);
28		my @retval = Data::FormValidator::Results::_arrayify($inputs);
	29	my $inputs = [ undef, 1, 2, 3, "Echo", "Foxtrot" ];
	30	my $retval = Data::FormValidator::Results::_arrayify($inputs);
	31	my @retval = Data::FormValidator::Results::_arrayify($inputs);
29	32
30		is($retval, 6, "$test_name... in scalar context");
31		is_deeply(\@retval, $inputs, "$test_name..in list context");
	33	is( $retval, 6, "$test_name... in scalar context" );
	34	is_deeply( \@retval, $inputs, "$test_name..in list context" );
32	35
33	36	}

+23

-26

t/05_valid_ip_address.t less more

	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
	3	use Test::More tests => 2;
	4	use Data::FormValidator;
	5
0	6	# performs a basic check to make sure valid_ip_address routine
1	7	# succeeds and fails when it should.
2	8	# by Mark Stosberg <mark@stosberg.com>
3	9
4		use strict;
	10	my $input_profile = {
	11	required => [qw( good_ip bad_ip )],
	12	constraints => {
	13	good_ip => 'ip_address',
	14	bad_ip => 'ip_address',
	15	} };
5	16
6		$^W = 1;
7
8		use Test::More tests => 2;
9
10		use Data::FormValidator;
11
12		my $input_profile = {
13		required => [ qw( good_ip bad_ip ) ],
14		constraints => {
15		good_ip => 'ip_address',
16		bad_ip => 'ip_address',
17		}
18		};
19
20		my $validator = new Data::FormValidator({default => $input_profile});
	17	my $validator = new Data::FormValidator( { default => $input_profile } );
21	18
22	19	my $input_hashref = {
23		'good_ip' => '127.0.0.1',
24		'bad_ip' => '300.23.1.1',
25		};
26
27		my ($valids, $missings, $invalids, $unknowns);
28
29		eval{
30		($valids, $missings, $invalids, $unknowns) = $validator->validate($input_hashref, 'default');
	20	'good_ip' => '127.0.0.1',
	21	'bad_ip' => '300.23.1.1',
31	22	};
32	23
33		ok(exists $valids->{'good_ip'});
	24	my ( $valids, $missings, $invalids, $unknowns );
34	25
35		is($invalids->[0], 'bad_ip');
	26	eval {
	27	( $valids, $missings, $invalids, $unknowns ) =
	28	$validator->validate( $input_hashref, 'default' );
	29	};
36	30
	31	ok( exists $valids->{'good_ip'} );
	32
	33	is( $invalids->[0], 'bad_ip' );

+59

-55

t/06_regexp_map.t less more

	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
0	3	use Test::More tests => 5;
1		use strict;
2
3		$^W = 1;
4
5	4	use Data::FormValidator;
6	5
7	6	my $input_profile = {
8		required => [ qw( email_1 email_ok) ],
9		optional => [qw/ extra first_name last_name /],
10		constraint_regexp_map => {
11		'/^email/' => "email",
12		},
13		field_filter_regexp_map => {
14		'/_name$/' => 'ucfirst',
15		}
16		};
	7	required => [qw( email_1 email_ok)],
	8	optional => [qw/ extra first_name last_name /],
	9	constraint_regexp_map => {
	10	'/^email/' => "email",
	11	},
	12	field_filter_regexp_map => {
	13	'/_name$/' => 'ucfirst',
	14	} };
17	15
18		my $validator = new Data::FormValidator({default => $input_profile});
	16	my $validator = new Data::FormValidator( { default => $input_profile } );
19	17
20	18	my $input_hashref = {
21		email_1 => 'invalidemail',
22		email_ok => 'mark@stosberg.com',
23		extra => 'unrelated field',
24		first_name => 'mark',
25		last_name => 'stosberg',
	19	email_1 => 'invalidemail',
	20	email_ok => 'mark@stosberg.com',
	21	extra => 'unrelated field',
	22	first_name => 'mark',
	23	last_name => 'stosberg',
26	24	};
27	25
28		my ($valids, $missings, $invalids, $unknowns);
	26	my ( $valids, $missings, $invalids, $unknowns );
29	27
30		eval{
31		($valids, $missings, $invalids, $unknowns) = $validator->validate($input_hashref, 'default');
	28	eval {
	29	( $valids, $missings, $invalids, $unknowns ) =
	30	$validator->validate( $input_hashref, 'default' );
32	31	};
33		ok (not $@);
34		ok ($invalids->[0] eq 'email_1');
	32	ok( not $@ );
	33	ok( $invalids->[0] eq 'email_1' );
35	34
36		ok ($valids->{'email_ok'}) ;
37		ok ($valids->{'extra'});
38		ok ($valids->{'first_name'} eq 'Mark' and $valids->{'last_name'} eq 'Stosberg');
	35	ok( $valids->{'email_ok'} );
	36	ok( $valids->{'extra'} );
	37	ok( $valids->{'first_name'} eq 'Mark'
	38	and $valids->{'last_name'} eq 'Stosberg' );
39	39
40		# Tests below added 04/24/03 to test adding constraints to fields with existing constraints
	40	# Tests below added 04/24/03 to test adding constraints to fields with existing constraints
41	41	eval {
42		my ($valids,$missings,$invalids) = Data::FormValidator->validate(
43		# input
44		{
45		with_no_constraint => 'f1 text',
46		with_one_constraint => 'f2 text',
47		with_mult_constraint => 'f2 text',
48		},
49		# profile
50		{
51		required=>[qw/with_no_constraint with_one_constraint with_mult_constraint/],
52		constraints=> {
53		with_one_constraint => 'email',
54		with_mult_constraint => ['email','american_phone'],
55		},
56		constraint_regexp_map => {
57		'/^with/' => 'state',
58		},
59		msgs=>{},
60		}
61		)
	42	my ( $valids, $missings, $invalids ) = Data::FormValidator->validate(
	43
	44	# input
	45	{
	46	with_no_constraint => 'f1 text',
	47	with_one_constraint => 'f2 text',
	48	with_mult_constraint => 'f2 text',
	49	},
	50
	51	# profile
	52	{
	53	required =>
	54	[qw/with_no_constraint with_one_constraint with_mult_constraint/],
	55	constraints => {
	56	with_one_constraint => 'email',
	57	with_mult_constraint => [ 'email', 'american_phone' ],
	58	},
	59	constraint_regexp_map => {
	60	'/^with/' => 'state',
	61	},
	62	msgs => {},
	63	} );
62	64	};
63	65
64		TODO: {
65		local $TODO = 'rewrite when message system is rebuilt';
66		#ok (not $@) ir diag $@;
67		#like($invalids->{with_no_constraint}, qr/Invalid/ , '...with no existing constraints');
68		#ok(scalar @{ $invalids->{with_one_constraint} } eq 2, '...with one existing constraint');
69		#ok(scalar @{ $invalids->{with_mult_constraint} } eq 3,'...with two existing constraints');
70		};
	66	TODO:
	67	{
	68	local $TODO = 'rewrite when message system is rebuilt';
	69
	70	#ok (not $@) ir diag $@;
	71	#like($invalids->{with_no_constraint}, qr/Invalid/ , '...with no existing constraints');
	72	#ok(scalar @{ $invalids->{with_one_constraint} } eq 2, '...with one existing constraint');
	73	#ok(scalar @{ $invalids->{with_mult_constraint} } eq 3,'...with two existing constraints');
	74	}

+20

-24

t/09_require_some.t less more

0
	0	#!/usr/bin/env perl
1	1	use strict;
2
3		$^W = 1;
4
	2	use warnings;
5	3	use Test::More tests => 4;
6
7	4	use Data::FormValidator;
8	5
9	6	my $input_profile = {
10		require_some => {
11		testing_default_to_1 => [qw/one missing1 missing2/],
12		'2_of_3_success' => [2,qw/blue green red/],
13		'2_of_3_fail' => [2,qw/foo bar zar/],
14		},
15		};
	7	require_some => {
	8	testing_default_to_1 => [qw/one missing1 missing2/],
	9	'2_of_3_success' => [ 2, qw/blue green red/ ],
	10	'2_of_3_fail' => [ 2, qw/foo bar zar/ ],
	11	},
	12	};
16	13
17		my $validator = new Data::FormValidator({default => $input_profile});
	14	my $validator = new Data::FormValidator( { default => $input_profile } );
18	15
19	16	my $input_hashref = {
20		one => 1,
21		blue => 1,
22		green => 1,
	17	one => 1,
	18	blue => 1,
	19	green => 1,
23	20	};
24	21
25		my ($valids, $missings, $invalids, $unknowns);
	22	my ( $valids, $missings, $invalids, $unknowns );
26	23
27		eval{
28		($valids, $missings, $invalids, $unknowns) = $validator->validate($input_hashref, 'default');
	24	eval {
	25	( $valids, $missings, $invalids, $unknowns ) =
	26	$validator->validate( $input_hashref, 'default' );
29	27	};
30	28
31		ok($valids->{blue});
32		ok($valids->{green});
33		ok($valids->{one});
	29	ok( $valids->{blue} );
	30	ok( $valids->{green} );
	31	ok( $valids->{one} );
34	32
35		ok(grep {/2_of_3_fail/} @$missings);
36
37
	33	ok( grep { /2_of_3_fail/ } @$missings );

+36

-38

t/11_procedural_match.t less more

	0	#!/usr/bin/env perl
0	1	use strict;
1		#Check that the match_* routines are nominally working.
2
3		$^W = 1;
4
	2	use warnings;
5	3	use Test::More tests => 26;
6
7
8	4	use Data::FormValidator qw(:validators :matchers);
9	5
	6	#Check that the match_* routines are nominally working.
10	7	my $invalid = "fake value";
11	8
12	9	#For CC Exp test
13	10	my @time = localtime(time);
14	11
15		my %tests = (
16		match_american_phone => "555-555-5555",
17		match_cc_exp => "10/" . sprintf("%.2d", ($time[5] - 99)),
18		match_cc_type => "MasterCard",
19		match_email => 'foo@domain.com',
20		match_ip_address => "64.58.79.230",
21		match_phone => "123-456-7890",
22		match_postcode => "T2N 0E6",
23		match_province => "NB",
24		match_state => "CA",
25		match_state_or_province => "QC",
26		match_zip => "94112",
27		match_zip_or_postcode => "50112",
	12	my %tests = (
	13	match_american_phone => "555-555-5555",
	14	match_cc_exp => "10/" . sprintf( "%.2d", ( $time[5] - 99 ) ),
	15	match_cc_type => "MasterCard",
	16	match_email => 'foo@domain.com',
	17	match_ip_address => "64.58.79.230",
	18	match_phone => "123-456-7890",
	19	match_postcode => "T2N 0E6",
	20	match_province => "NB",
	21	match_state => "CA",
	22	match_state_or_province => "QC",
	23	match_zip => "94112",
	24	match_zip_or_postcode => "50112",
28	25	);
29	26
30	27	my $i = 1;
31	28
32		foreach my $function (keys(%tests)) {
33		my $rv;
34		my $val = $tests{$function};
35		my $is_valid = "\$rv = $function('$val');";
36		my $not_valid = "\$rv = $function('$invalid');";
37
38		eval $is_valid;
39		ok(not $@ and ($rv eq $val)) or
40		diag sprintf("%-25s using %-16s", $function, "valid value. ");
41		$i++;
	29	foreach my $function ( keys(%tests) )
	30	{
	31	my $rv;
	32	my $val = $tests{$function};
	33	my $is_valid = "\$rv = $function('$val');";
	34	my $not_valid = "\$rv = $function('$invalid');";
42	35
43		eval $not_valid;
44		ok(not $@ and not $rv) or
45		diag sprintf("%-25s using %-16s", $function, "invalid value. ");
46		$i++;
	36	eval $is_valid;
	37	ok( not $@ and ( $rv eq $val ) )
	38	or diag sprintf( "%-25s using %-16s", $function, "valid value. " );
	39	$i++;
	40
	41	eval $not_valid;
	42	ok( not $@ and not $rv )
	43	or diag sprintf( "%-25s using %-16s", $function, "invalid value. " );
	44	$i++;
47	45	}
48
	46
49	47	#Test cc_number separately since it takes multiple parameters
50	48	my $rv;
51	49	my $num = '4111111111111111';
52	50	eval "\$rv = match_cc_number('$num', 'v')";
53		ok(not $@ and ($rv eq $num)) or
54		diag sprintf("%-25s using %-16s", "match_cc_number", "valid value. ");
	51	ok( not $@ and ( $rv eq $num ) )
	52	or diag sprintf( "%-25s using %-16s", "match_cc_number", "valid value. " );
55	53
56	54	eval "\$rv = match_cc_number('$invalid', 'm')";
57		ok(not $@ and not $rv) or
58		diag sprintf("%-25s using %-16s", "match_cc_number", "invalid value. ");
	55	ok( not $@ and not $rv )
	56	or diag sprintf( "%-25s using %-16s", "match_cc_number", "invalid value. " );

+49

-51

t/13_validator_packages.t less more

0
	0	#!/usr/bin/env perl
1	1	use strict;
2		use lib ('.','../t','t/');
3
4		$^W = 1;
5
	2	use warnings;
	3	use lib ( '.', '../t', 't/' );
6	4	use Test::More tests => 8;
7
8	5	use Data::FormValidator;
9	6
10	7	my $input_profile = {
11		validator_packages => 'ValidatorPackagesTest1',
12		required => ['required_1','required_2','required_3'],
13		constraints => {
14		required_1 => 'single_validator_success_expected',
15		required_2 => 'single_validator_failure_expected',
16		},
17		field_filters => {
18		required_3 => 'single_filter_remove_whitespace',
19		},
20		};
	8	validator_packages => 'ValidatorPackagesTest1',
	9	required => [ 'required_1', 'required_2', 'required_3' ],
	10	constraints => {
	11	required_1 => 'single_validator_success_expected',
	12	required_2 => 'single_validator_failure_expected',
	13	},
	14	field_filters => {
	15	required_3 => 'single_filter_remove_whitespace',
	16	},
	17	};
21	18
22		my $validator = new Data::FormValidator({default => $input_profile});
	19	my $validator = new Data::FormValidator( { default => $input_profile } );
23	20
24	21	my $input_hashref = {
25		required_1 => 123,
26		required_2 => 'testing',
27		required_3 => ' has whitespace ',
	22	required_1 => 123,
	23	required_2 => 'testing',
	24	required_3 => ' has whitespace ',
28	25	};
29	26
30		my ($valids, $missings, $invalids, $unknowns);
	27	my ( $valids, $missings, $invalids, $unknowns );
31	28
32		eval{
33		($valids, $missings, $invalids, $unknowns) = $validator->validate($input_hashref, 'default');
	29	eval {
	30	( $valids, $missings, $invalids, $unknowns ) =
	31	$validator->validate( $input_hashref, 'default' );
34	32	};
35		ok(not $@) or
36		diag "eval error: $@";
	33	ok( not $@ )
	34	or diag "eval error: $@";
37	35
38		ok(defined $valids->{required_1});
	36	ok( defined $valids->{required_1} );
39	37
40	38	# Test to make sure that the field failed imported validator
41		ok(grep /required_2/, @$invalids);
	39	ok( grep /required_2/, @$invalids );
42	40
43		ok(defined $valids->{required_3});
	41	ok( defined $valids->{required_3} );
44	42
45		is($valids->{required_3}, 'has whitespace');
	43	is( $valids->{required_3}, 'has whitespace' );
46	44
47	45	#### Now test importing from multiple packages
48	46
49	47	$input_profile = {
50		validator_packages => ['ValidatorPackagesTest1','ValidatorPackagesTest2'],
51		required => ['required_1','required_2'],
52		constraints => {
53		required_1 => 'single_validator_success_expected',
54		required_2 => 'multi_validator_success_expected',
55		},
56		};
	48	validator_packages => [ 'ValidatorPackagesTest1', 'ValidatorPackagesTest2' ],
	49	required => [ 'required_1', 'required_2' ],
	50	constraints => {
	51	required_1 => 'single_validator_success_expected',
	52	required_2 => 'multi_validator_success_expected',
	53	},
	54	};
57	55
58		$validator = new Data::FormValidator({default => $input_profile});
	56	$validator = new Data::FormValidator( { default => $input_profile } );
59	57
60	58	$input_hashref = {
61		required_1 => 123,
62		required_2 => 'testing',
	59	required_1 => 123,
	60	required_2 => 'testing',
63	61	};
64	62
65		eval{
66		($valids, $missings, $invalids, $unknowns) = $validator->validate($input_hashref, 'default');
	63	eval {
	64	( $valids, $missings, $invalids, $unknowns ) =
	65	$validator->validate( $input_hashref, 'default' );
67	66	};
68	67
	68	ok( defined $valids->{required_1} );
69	69
70		ok(defined $valids->{required_1});
71
72		ok(defined $valids->{required_2});
	70	ok( defined $valids->{required_2} );
73	71
74	72	# Now test calling 'validate' as a class method
75	73	use Data::FormValidator;
76	74
77	75	eval {
78		my ($valid,$missing,$invalid) = Data::FormValidator->validate($input_hashref,{
79		required=>[qw/required_1/],
80		validator_packages=> 'Data::FormValidator',
81		});
	76	my ( $valid, $missing, $invalid ) = Data::FormValidator->validate(
	77	$input_hashref,
	78	{
	79	required => [qw/required_1/],
	80	validator_packages => 'Data::FormValidator',
	81	} );
82	82	};
83		ok(not $@);
84
85
	83	ok( not $@ );

+22

-27

t/15_literal_param_constraints.t less more

0
	0	#!/usr/bin/env perl
1	1	use strict;
2		use lib ('.','../t');
3
4		$^W = 1;
5
	2	use warnings;
	3	use lib ( '.', '../t' );
6	4	use Test::More tests => 1;
7
8	5	use Data::FormValidator;
9	6
10	7	my $input_profile = {
11		required => ['my_zipcode_field'],
12		constraints => {
13		my_zipcode_field => {
14		constraint => \&starts_with_402,
15		params => ['my_zipcode_field', \'cow'],
16		},
17		},
18		untaint_all_constraints=>1,
	8	required => ['my_zipcode_field'],
	9	constraints => {
	10	my_zipcode_field => {
	11	constraint => \&starts_with_402,
	12	params => [ 'my_zipcode_field', \'cow' ],
	13	},
	14	},
	15	untaint_all_constraints => 1,
19	16
20	17	};
21	18
22		my $validator = new Data::FormValidator({default => $input_profile});
	19	my $validator = new Data::FormValidator( { default => $input_profile } );
23	20
24		my $input_hashref = {
25		my_zipcode_field => 'big brown',
26		};
	21	my $input_hashref = { my_zipcode_field => 'big brown', };
27	22
28		sub starts_with_402 {
29		my ($zip, $cow) = @_;
30		return "$zip $$cow";
	23	sub starts_with_402
	24	{
	25	my ( $zip, $cow ) = @_;
	26	return "$zip $$cow";
31	27	}
32	28
33		my ($valids, $missings, $invalids, $unknowns);
34		eval{
35		($valids, $missings, $invalids, $unknowns) = $validator->validate($input_hashref, 'default');
	29	my ( $valids, $missings, $invalids, $unknowns );
	30	eval {
	31	( $valids, $missings, $invalids, $unknowns ) =
	32	$validator->validate( $input_hashref, 'default' );
36	33	};
37	34
38	35	# Test to make sure that the constraint receives a literal value of an element passed by reference
39		is($valids->{my_zipcode_field}, 'big brown cow');
40
41
	36	is( $valids->{my_zipcode_field}, 'big brown cow' );

+22

-25

t/16_cgi_object.t less more

	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
	3	use lib ( '.', '../t' );
	4	use Test::More;
	5	use Data::FormValidator;
	6
0	7	# This script tests whether a CGI.pm object can be used to provide the input data
1		# Mark Stosberg 02/16/03
	8	# Mark Stosberg 02/16/03
2	9
3		use strict;
4		use lib ('.','../t');
5
6		$^W = 1;
7
8		use Test::More tests => 2;
	10	eval { require CGI;CGI->VERSION(4.35); };
	11	plan skip_all => 'CGI 4.35 or higher not found' if $@;
9	12
10	13	my $q;
	14	eval { $q = CGI->new( { my_zipcode_field => 'big brown' } ); };
	15	ok( not $@ );
	16
	17	my $input_profile = { required => ['my_zipcode_field'], };
	18
	19	my $validator = new Data::FormValidator( { default => $input_profile } );
	20
	21	my ( $valids, $missings, $invalids, $unknowns );
11	22	eval {
12		use CGI;
13		$q = CGI->new({ my_zipcode_field => 'big brown' });
14		};
15		ok(not $@);
16
17		use Data::FormValidator;
18
19		my $input_profile = {
20		required => ['my_zipcode_field'],
	23	( $valids, $missings, $invalids, $unknowns ) =
	24	$validator->validate( $q, 'default' );
21	25	};
22	26
23		my $validator = new Data::FormValidator({default => $input_profile});
24
25		my ($valids, $missings, $invalids, $unknowns);
26		eval{
27		($valids, $missings, $invalids, $unknowns) = $validator->validate($q, 'default');
28		};
29
30		is($valids->{my_zipcode_field}, 'big brown');
31
	27	is( $valids->{my_zipcode_field}, 'big brown' );
	28	done_testing;

+67

-65

t/17_multi_valued_keys.t less more

	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
	3	use lib ( '.', '../t' );
	4	use Test::More tests => 8;
	5	use Data::FormValidator;
	6
0	7	# This script tests validating keys with multiple data
1		use strict;
2		use lib ('.','../t');
3
4		$^W = 1;
5
6		use Test::More tests => 8;
7
8		my $input_hash = {
9		single_value => ' Just One ',
10		multi_values => [' One ', ' Big ', ' Happy ', ' Family '],
11		re_multi_test => [qw/at the circus/],
12		constraint_multi_test => [qw/12345 22234 oops/],
	8	my $input_hash = {
	9	single_value => ' Just One ',
	10	multi_values => [ ' One ', ' Big ', ' Happy ', ' Family ' ],
	11	re_multi_test => [qw/at the circus/],
	12	constraint_multi_test => [qw/12345 22234 oops/],
	13	};
	14	my $input_profile = {
	15	required =>
	16	[qw/single_value multi_values re_multi_test constraint_multi_test/],
	17	filters => [qw/trim/],
	18	field_filters => {
	19	single_value => 'lc',
	20	multi_values => 'uc',
	21	},
	22	field_filter_regexp_map => {
	23	'/_multi_test$/' => 'ucfirst',
	24	},
	25	constraints => {
	26	constraint_multi_test => 'zip',
	27	},
13	28	};
14	29
	30	my $validator = new Data::FormValidator( { default => $input_profile } );
15	31
16		use Data::FormValidator;
17
18		my $input_profile = {
19		required => [qw/single_value multi_values re_multi_test constraint_multi_test/],
20		filters => [qw/trim/],
21		field_filters => {
22		single_value => 'lc',
23		multi_values => 'uc',
24		},
25		field_filter_regexp_map => {
26		'/_multi_test$/' => 'ucfirst',
27		},
28		constraints => {
29		constraint_multi_test => 'zip',
30		},
	32	my ( $valids, $missings, $invalids, $unknowns );
	33	eval {
	34	( $valids, $missings, $invalids, $unknowns ) =
	35	$validator->validate( $input_hash, 'default' );
31	36	};
32	37
33		my $validator = new Data::FormValidator({default => $input_profile});
	38	is( $valids->{single_value},
	39	'just one', 'inconditional filters still work with single values' );
34	40
35		my ($valids, $missings, $invalids, $unknowns);
36		eval{
37		($valids, $missings, $invalids, $unknowns) = $validator->validate($input_hash, 'default');
38		};
	41	is( lc $valids->{multi_values}->[0],
	42	lc 'one', 'inconditional filters work with multi values' );
39	43
40		is($valids->{single_value},'just one',
41		'inconditional filters still work with single values'
42		);
	44	is( $valids->{multi_values}->[0],
	45	'ONE', 'field filters work with multiple values' );
43	46
44		is(lc $valids->{multi_values}->[0],lc 'one',
45		'inconditional filters work with multi values'
46		);
	47	is( $valids->{re_multi_test}->[0],
	48	'At', 'Test the filters applied to multiple values by RE work' );
47	49
48		is($valids->{multi_values}->[0],'ONE',
49		'field filters work with multiple values'
50		);
51
52		is($valids->{re_multi_test}->[0] ,'At',
53		'Test the filters applied to multiple values by RE work'
54		);
55
56		ok(!$valids->{constraint_multi_test},
57		'If any of the values fail the constraint, the field becomes invalid'
58		);
	50	ok( !$valids->{constraint_multi_test},
	51	'If any of the values fail the constraint, the field becomes invalid' );
59	52
60	53	my $r;
61		eval { $r = Data::FormValidator->check({ undef_multi => [undef] }, { required => 'undef_multi' }) };
	54	eval
	55	{
	56	$r = Data::FormValidator->check( { undef_multi => [undef] },
	57	{ required => 'undef_multi' } );
	58	};
62	59	diag "error: $@" if $@;
63		ok($r->missing('undef_multi'), 'multi-valued field containing only undef should be missing');
	60	ok( $r->missing('undef_multi'),
	61	'multi-valued field containing only undef should be missing' );
64	62
65	63	my $v;
66	64	eval { $v = $r->valid('undef_multi'); };
67	65	diag "error: $@" if $@;
68		ok(!$v, 'multiple valued fields containing only undefined values should not be valid');
69
	66	ok( !$v,
	67	'multiple valued fields containing only undefined values should not be valid'
	68	);
70	69
71	70	###
72	71
73		eval { $r = Data::FormValidator->check({
74		cc_type => ['Check'],
	72	eval {
	73	$r = Data::FormValidator->check( {
	74	cc_type => ['Check'],
	75	},
	76	{
	77	required => 'cc_type',
	78	dependencies => {
	79	cc_type => {
	80	Check => [qw( cc_num )],
	81	Visa => [qw( cc_num cc_exp cc_name )],
75	82	},
76		{
77		required => 'cc_type',
78		dependencies => {
79		cc_type => {
80		Check => [qw( cc_num )],
81		Visa => [qw( cc_num cc_exp cc_name )],
82		},
83		},
84		}) };
	83	},
	84	} );
	85	};
85	86	diag "error: $@" if $@;
86	87
87		ok($r->missing('cc_num'), 'a single valued array should still trigger the dependency check');
	88	ok( $r->missing('cc_num'),
	89	'a single valued array should still trigger the dependency check' );

+31

-44

t/18_constraint_refs.t less more

	0	#!/usr/bin/env perl
0	1	#!/usr/bin/perl -w
	2	use strict;
	3	use warnings;
	4	use lib ( '.', '../t' );
	5	use Test::More tests => 4;
	6	use Data::FormValidator;
1	7
2	8	# This tests for some constraint related bugs found by Chris Spiegel
	9	my $input_profile = {
	10	required => [qw( email subroutine )],
	11	constraints => {
	12	subroutine => sub { 0 },
	13	} };
3	14
4		use lib ('.','../t');
5
6		$^W = 1;
7
8		use Test::More tests => 4;
9
10		use strict;
11		use Data::FormValidator;
12
13		my $input_profile =
14		{
15		required => [ qw( email subroutine ) ],
16		constraints =>
17		{
18		subroutine => sub { 0 },
19		}
20		};
21
22		my $validator = new Data::FormValidator({default => $input_profile});
	15	my $validator = new Data::FormValidator( { default => $input_profile } );
23	16
24	17	my $input_hashref = { subroutine => 'anything' };
25	18
26		my ($valids, $missings, $invalids, $unknowns) = ({},[],[],[]);
	19	my ( $valids, $missings, $invalids, $unknowns ) = ( {}, [], [], [] );
27	20
28		($valids, $missings, $invalids, $unknowns) = $validator->validate($input_hashref, 'default');
	21	( $valids, $missings, $invalids, $unknowns ) =
	22	$validator->validate( $input_hashref, 'default' );
29	23
30	24	# We need to make sure we do not get a reference back here
31		ok(not ref $invalids->[0]);
	25	ok( not ref $invalids->[0] );
32	26
33		$input_profile =
34		{
35		required => [ qw( email) ],
36		constraints =>
37		{
38		email =>
39		[
40		{
41		constraint => 'email',
42		name => 'Your email address is invalid.',
43		}
44		],
45		}
46		};
	27	$input_profile = {
	28	required => [qw( email)],
	29	constraints => {
	30	email => [ {
	31	constraint => 'email',
	32	name => 'Your email address is invalid.',
	33	}
	34	],
	35	} };
47	36
48		$validator = new Data::FormValidator({default => $input_profile});
	37	$validator = new Data::FormValidator( { default => $input_profile } );
49	38
50	39	eval {
51		($valids, $missings, $invalids, $unknowns) = $validator->validate({ email => 'invalid'}, 'default');
	40	( $valids, $missings, $invalids, $unknowns ) =
	41	$validator->validate( { email => 'invalid' }, 'default' );
52	42	};
53		is($@,'','survived eval');
	43	is( $@, '', 'survived eval' );
54	44
55		is($invalids->[0]->[0], 'email');
56		is($invalids->[0]->[1], 'Your email address is invalid.');
57
58
59
	45	is( $invalids->[0]->[0], 'email' );
	46	is( $invalids->[0]->[1], 'Your email address is invalid.' );

+18

-28

t/19_refs_as_values.t less more

0		#!/usr/bin/perl -w
	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
	3	use lib ( '.', '../t' );
	4	use Test::More tests => 3;
	5	use Data::FormValidator;
1	6
2	7	# This tests to make sure that we can use hashrefs and code refs as OK values in the input hash
3	8	# inspired by a patch from Boris Zentner
	9	my $input_profile = { required => [qw( arrayref hashref coderef )], };
4	10
5		use lib ('.','../t');
	11	my $validator = new Data::FormValidator( { default => $input_profile } );
6	12
7		$^W = 1;
8
9		use Test::More tests => 3;
10
11		use strict;
12		use Data::FormValidator;
13
14		my $input_profile =
15		{
16		required => [ qw( arrayref hashref coderef ) ],
	13	my $input_hashref = {
	14	arrayref => [ '', 1, 2 ],
	15	hashref => { tofu => 'good' },
	16	coderef => sub { return 'the answer is 42' },
17	17	};
18	18
19		my $validator = new Data::FormValidator({default => $input_profile});
	19	my ( $valids, $missings, $invalids, $unknowns ) = ( {}, [], [], [] );
20	20
21		my $input_hashref = {
22		arrayref => ['', 1,2],
23		hashref => {tofu => 'good'},
24		coderef => sub { return 'the answer is 42' },
25		};
26
27		my ($valids, $missings, $invalids, $unknowns) = ({},[],[],[]);
28
29		($valids, $missings, $invalids, $unknowns) = $validator->validate($input_hashref, 'default');
	21	( $valids, $missings, $invalids, $unknowns ) =
	22	$validator->validate( $input_hashref, 'default' );
30	23
31	24	# empty strings in arrays should be set to "undef"
32		ok(not defined $valids->{arrayref}->[0]);
	25	ok( not defined $valids->{arrayref}->[0] );
33	26
34	27	# hash refs and code refs should be ok.
35		is(ref $valids->{hashref}, 'HASH');
36		is(ref $valids->{coderef}, 'CODE');
37
38
39
	28	is( ref $valids->{hashref}, 'HASH' );
	29	is( ref $valids->{coderef}, 'CODE' );

+17

-23

t/20_careful_exception_handling.t less more

0		#!/usr/bin/perl -w
1
2		# This tests to make sure that when we test $@, we are testing the right thing.
3		# inspired by a patch from dom@semantico.com
4		use lib ('.','../t');
5
6		$^W = 1;
7
	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
	3	use lib ( '.', '../t' );
8	4	use Test::More tests => 1;
9
10		use strict;
11	5	use Data::FormValidator;
12	6
13	7	# So as to not trigger a require later on in the code.
14	8	require UNIVERSAL;
15	9
16		my $input_profile =
17		{
18		required => 'nothing',
19		};
	10	# This tests to make sure that when we test $@, we are testing the right thing.
	11	# inspired by a patch from dom@semantico.com
	12	my $input_profile = { required => 'nothing', };
20	13
21		my $validator = new Data::FormValidator({default => $input_profile});
	14	my $validator = new Data::FormValidator( { default => $input_profile } );
22	15
23		my $input_hashref = {
24		'1_required' => 1,
25		'1_optional' => 1,
	16	my $input_hashref = {
	17	'1_required' => 1,
	18	'1_optional' => 1,
26	19	};
27	20
28	21	eval {
29		# populate $@ to see if D::FV dies when it shouldn't
30		$@ = 'exceptional value';
31		my ($valids, $missings, $invalids, $unknowns) = ({},[],[],[]);
32		($valids, $missings, $invalids, $unknowns) = $validator->validate($input_hashref, 'default');
	22	# populate $@ to see if D::FV dies when it shouldn't
	23	$@ = 'exceptional value';
	24	my ( $valids, $missings, $invalids, $unknowns ) = ( {}, [], [], [] );
	25	( $valids, $missings, $invalids, $unknowns ) =
	26	$validator->validate( $input_hashref, 'default' );
33	27	};
34	28
35		unlike($@, qr/Error compiling regular expression/);
	29	unlike( $@, qr/Error compiling regular expression/ );
36	30
37	31	# vim: set ai et sw=8 syntax=perl :

+35

-39

t/21_multiple_fields.t less more

	0	#!/usr/bin/env perl
0	1	use strict;
	2	use warnings;
1	3	use Test::More tests => 3;
2		use lib ('.','../t');
	4	use lib ( '.', '../t' );
	5	use Data::FormValidator;
3	6
4	7	# Verify that multiple params passed to a constraint are being handled correctly
	8	my $validator = new Data::FormValidator( {
	9	default => {
	10	required => [qw/my_zipcode_field my_other_field/],
	11	constraints => {
	12	my_zipcode_field => {
	13	constraint => \&zipcode_check,
	14	name => 'zipcode',
	15	params => [ 'my_zipcode_field', 'my_other_field' ],
	16	},
	17	},
	18	},
	19	} );
5	20
6		$^W = 1;
	21	my @args_for_check; # to control which args were given
7	22
8
9		use Data::FormValidator;
10
11		my $validator = new Data::FormValidator({
12		default =>
13		{
14		required => [ qw/my_zipcode_field my_other_field/],
15		constraints => {
16		my_zipcode_field => {
17		constraint => \&zipcode_check,
18		name => 'zipcode',
19		params => [ 'my_zipcode_field', 'my_other_field' ],
20		},
21		},
22		},
23		});
24
25		my @args_for_check; # to control which args were given
26
27		sub zipcode_check {
	23	sub zipcode_check
	24	{
28	25	@args_for_check = @_;
29		if ($_[0] == 402015 and $_[1] eq 'mapserver_rulez') {
	26	if ( $_[0] == 402015 and $_[1] eq 'mapserver_rulez' )
	27	{
30	28	return 1;
31	29	}
32	30	return 0;
33	31	}
34	32
35		my $input_hashref =
36		{
37		my_zipcode_field => '402015',
38		my_other_field => 'mapserver_rulez',
39		};
40
41		my ($valids, $missings, $invalids, $unknowns);
42
43		eval{
44		($valids, $missings, $invalids, $unknowns) =
45		$validator->validate($input_hashref, 'default');
	33	my $input_hashref = {
	34	my_zipcode_field => '402015',
	35	my_other_field => 'mapserver_rulez',
46	36	};
47	37
48		ok(not $@) or
49		diag "eval error: $@";
	38	my ( $valids, $missings, $invalids, $unknowns );
50	39
51		ok(not grep { (ref $_) eq 'ARRAY' } @$invalids) or
52		diag $#{$invalids};
	40	eval {
	41	( $valids, $missings, $invalids, $unknowns ) =
	42	$validator->validate( $input_hashref, 'default' );
	43	};
53	44
	45	ok( not $@ )
	46	or diag "eval error: $@";
54	47
55		is_deeply(\@args_for_check, [402015,'mapserver_rulez']);
	48	ok( not grep { ( ref $_ ) eq 'ARRAY' } @$invalids )
	49	or diag $#{$invalids};
	50
	51	is_deeply( \@args_for_check, [ 402015, 'mapserver_rulez' ] );
56	52
57	53	# Local variables:
58	54	# compile-command: "cd .. && make test"

+34

-27

t/25_results.t less more

	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
0	3	use Test::More tests => 7;
1
2		use Data::FormValidator;
	4	use Data::FormValidator;
3	5
4	6	my %FORM = (
5		stick => 'big',
6		speak => 'softly',
7		mv => ['first','second'],
	7	stick => 'big',
	8	speak => 'softly',
	9	mv => [ 'first', 'second' ],
8	10	);
9	11
10		my $results = Data::FormValidator->check(\%FORM,
11		{
12		required => [ 'stick', 'fromsub', 'whoami' ],
13		optional => ['mv', 'opt_1', 'opt_2', ],
14		defaults => {
15		fromsub => sub { return "got value from a subroutine"; },
16		},
17		defaults_regexp_map => {
18		qr/^opt_/ => 2,
19		},
20		}
	12	my $results = Data::FormValidator->check(
	13	\%FORM,
	14	{
	15	required => [ 'stick', 'fromsub', 'whoami' ],
	16	optional => [ 'mv', 'opt_1', 'opt_2', ],
	17	defaults => {
	18	fromsub => sub { return "got value from a subroutine"; },
	19	},
	20	defaults_regexp_map => {
	21	qr/^opt_/ => 2,
	22	},
	23	} );
	24
	25	ok( $results->valid('stick') eq 'big', 'using check() as class method' );
	26	is( $results->valid('stick'),
	27	$FORM{stick}, 'valid() returns single value in scalar context' );
	28	my @mv = $results->valid('mv');
	29	is_deeply( \@mv, $FORM{mv}, 'valid() returns multi-valued results' );
	30	my @stick = $results->valid('stick');
	31	is_deeply(
	32	\@stick,
	33	[ $FORM{stick} ],
	34	'valid() returns single value in list context'
21	35	);
22
23		ok($results->valid('stick') eq 'big','using check() as class method');
24		is($results->valid('stick'),$FORM{stick}, 'valid() returns single value in scalar context');
25		my @mv = $results->valid('mv');
26		is_deeply(\@mv,$FORM{mv}, 'valid() returns multi-valued results');
27		my @stick = $results->valid('stick');
28		is_deeply(\@stick,[ $FORM{stick} ], 'valid() returns single value in list context');
29		ok($results->valid('fromsub') eq "got value from a subroutine", 'usg CODE references as default values');
	36	ok( $results->valid('fromsub') eq "got value from a subroutine",
	37	'usg CODE references as default values' );
30	38
31	39	{
32		is( $results->valid('opt_1'), 2, "defaults_regexp works (case 1)");
33		is( $results->valid('opt_2'), 2, "defaults_regexp works (case 1)");
	40	is( $results->valid('opt_1'), 2, "defaults_regexp works (case 1)" );
	41	is( $results->valid('opt_2'), 2, "defaults_regexp works (case 1)" );
34	42
35	43	}
36

+50

-52

t/26_qr.t less more

	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
	3	use Test::More qw/no_plan/;
	4	use Data::FormValidator;
	5
0	6	# Testing new support for 'qr'. -mls
	7	my %FORM = (
	8	stick => 'big',
	9	speak => 'softly',
1	10
2		use Test::More qw/no_plan/;
	11	bad_email => 'doops',
	12	good_email => 'great@domain.com',
3	13
4		use Data::FormValidator;
	14	'short_name' => 'tim',
5	15
6		my %FORM = (
7		stick => 'big',
8		speak => 'softly',
	16	'not_oops' => 'hoops',
9	17
10		bad_email => 'doops',
11		good_email => 'great@domain.com',
12
13		'short_name' => 'tim',
14
15		'not_oops' => 'hoops',
16
17		'untainted_with_qr' => 'Slimy',
	18	'untainted_with_qr' => 'Slimy',
18	19	);
19	20
20		my $results = Data::FormValidator->check(\%FORM, {
21		required_regexp => qr/stick/,
22		optional_regexp => '/_email$/',
23		constraint_regexp_map => {
24		qr/email/ => 'email',
	21	my $results = Data::FormValidator->check(
	22	\%FORM,
	23	{
	24	required_regexp => qr/stick/,
	25	optional_regexp => '/_email$/',
	26	constraint_regexp_map => {
	27	qr/email/ => 'email',
25	28
26		},
27		field_filter_regexp_map => {
28		qr/_name$/ => 'ucfirst',
29		},
30		required => 'speak',
31		optional => [qw/short_name not_oops untainted_with_qr/],
32		constraints => {
33		not_oops => {
34		name => 'start_with_oop',
35		constraint => qr/^oop/,
36		},
37		untainted_with_qr => qr/(Slim)/,
38		speak => qr/quietly\|softly/,
39		stick => qr/big\|large/,
	29	},
	30	field_filter_regexp_map => {
	31	qr/_name$/ => 'ucfirst',
	32	},
	33	required => 'speak',
	34	optional => [qw/short_name not_oops untainted_with_qr/],
	35	constraints => {
	36	not_oops => {
	37	name => 'start_with_oop',
	38	constraint => qr/^oop/,
	39	},
	40	untainted_with_qr => qr/(Slim)/,
	41	speak => qr/quietly\|softly/,
	42	stick => qr/big\|large/,
40	43
41		},
42		msgs => {
43		constraints => {
44		'start_with_oop' => 'testing named qr constraints',
45		}
	44	},
	45	msgs => {
	46	constraints => {
	47	'start_with_oop' => 'testing named qr constraints',
	48	}
46	49
47		},
48		untaint_constraint_fields => [qw/untainted_with_qr/],
49		});
	50	},
	51	untaint_constraint_fields => [qw/untainted_with_qr/],
	52	} );
50	53
51		ok ($results->valid('stick') eq 'big','using qr for regexp quoting');
52		ok ($results->valid('speak'),'using alternation with qr works');
53		ok ($results->valid('good_email'), 'expected to pass constraint');
54		ok ($results->invalid('bad_email'), 'expected to fail constraint');
55		is($results->valid('short_name'),'Tim', 'field_filter_regexp_map');
	54	ok( $results->valid('stick') eq 'big', 'using qr for regexp quoting' );
	55	ok( $results->valid('speak'), 'using alternation with qr works' );
	56	ok( $results->valid('good_email'), 'expected to pass constraint' );
	57	ok( $results->invalid('bad_email'), 'expected to fail constraint' );
	58	is( $results->valid('short_name'), 'Tim', 'field_filter_regexp_map' );
56	59
57	60	my $msgs = $results->msgs;
58		like($msgs->{not_oops},qr/testing named/, 'named qr constraints');
	61	like( $msgs->{not_oops}, qr/testing named/, 'named qr constraints' );
59	62
60		is($results->valid('untainted_with_qr'),'Slim', 'untainting with qr');
61
62
63
64
65
	63	is( $results->valid('untainted_with_qr'), 'Slim', 'untainting with qr' );

+52

-44

t/27_qualify_ref_happy_death.t less more

0		# Friendy error messages when quality_to_ref fails due to a typo. -mls 05/03/03
	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
	3	use Test::More tests => 5;
	4	use Data::FormValidator;
1	5
2		use Test::More tests => 5;
	6	# Friendy error messages when quality_to_ref fails due to a typo. -mls 05/03/03
	7	my %FORM = (
	8	bad_email => 'oops',
	9	good_email => 'great@domain.com',
3	10
4		use Data::FormValidator;
5
6		my %FORM = (
7		bad_email => 'oops',
8		good_email => 'great@domain.com',
9
10		'short_name' => 'tim',
	11	'short_name' => 'tim',
11	12	);
12	13
13	14	my $results;
14	15
15	16	eval {
16		$results = Data::FormValidator->check(\%FORM, {
17		required => 'good_email',
18		filters => 'grim', # testing filter typo
19		});
	17	$results = Data::FormValidator->check(
	18	\%FORM,
	19	{
	20	required => 'good_email',
	21	filters => 'grim', # testing filter typo
	22	} );
20	23	};
21		like($@,qr/found named/, 'happy filters typo failure');
	24	like( $@, qr/found named/, 'happy filters typo failure' );
22	25
23	26	eval {
24		$results = Data::FormValidator->check(\%FORM, {
25		required => 'good_email',
26		field_filters => {
27		'good_email' => 'grim', # testing filter typo
28		},
29		});
	27	$results = Data::FormValidator->check(
	28	\%FORM,
	29	{
	30	required => 'good_email',
	31	field_filters => {
	32	'good_email' => 'grim', # testing filter typo
	33	},
	34	} );
30	35	};
31		like($@,qr/found named/, 'happy field_filters typo failure');
	36	like( $@, qr/found named/, 'happy field_filters typo failure' );
32	37
33	38	eval {
34		$results = Data::FormValidator->check(\%FORM, {
35		required => 'good_email',
36		field_filter_regexp_map => {
37		qr/_email$/ => 'grim', # testing filter typo
38		},
39		});
	39	$results = Data::FormValidator->check(
	40	\%FORM,
	41	{
	42	required => 'good_email',
	43	field_filter_regexp_map => {
	44	qr/_email$/ => 'grim', # testing filter typo
	45	},
	46	} );
40	47	};
41		like($@,qr/found named/, 'happy field_filter_regexp_map typo failure');
	48	like( $@, qr/found named/, 'happy field_filter_regexp_map typo failure' );
42	49
43	50	eval {
44		$results = Data::FormValidator->check(\%FORM, {
45		required => 'good_email',
46		constraints => {
47		good_email => 'e-mail', # typo in constraint name
48		}
49		});
	51	$results = Data::FormValidator->check(
	52	\%FORM,
	53	{
	54	required => 'good_email',
	55	constraints => {
	56	good_email => 'e-mail', # typo in constraint name
	57	} } );
50	58	};
51		like($@,qr/found named/, 'happy constraints typo failure');
	59	like( $@, qr/found named/, 'happy constraints typo failure' );
52	60
53	61	eval {
54		$results = Data::FormValidator->check(\%FORM, {
55		required => 'good_email',
56		untaint_all_constraints => 1,
57		constraints => {
58		good_email => 'e-mail', # typo in constraint name
59		}
60		});
	62	$results = Data::FormValidator->check(
	63	\%FORM,
	64	{
	65	required => 'good_email',
	66	untaint_all_constraints => 1,
	67	constraints => {
	68	good_email => 'e-mail', # typo in constraint name
	69	} } );
61	70	};
62		like($@,qr/found named/, 'happy untainted constraints typo failure');
63
	71	like( $@, qr/found named/, 'happy untainted constraints typo failure' );

+22

-26

t/28_defaults_for_new.t less more

0		# testing passing defaults to the new constructor. -mls 05/03/03
	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
	3	use Test::More tests => 3;
	4	use Data::FormValidator;
1	5
2		use Test::More tests => 3;
3		use strict;
	6	# testing passing defaults to the new constructor. -mls 05/03/03
	7	my %FORM = (
	8	bad_email => 'oops',
	9	good_email => 'great@domain.com',
4	10
5		use Data::FormValidator;
6
7		my %FORM = (
8		bad_email => 'oops',
9		good_email => 'great@domain.com',
10
11		'short_name' => 'tim',
	11	'short_name' => 'tim',
12	12	);
13	13
14		my $dfv = Data::FormValidator->new({},{ missing_optional_valie => 1 });
	14	my $dfv = Data::FormValidator->new( {}, { missing_optional_valie => 1 } );
15	15
16		eval {
17		my $results = $dfv->check(\%FORM, {});
18		};
19		like($@,qr/Invalid input profile/, 'defaults are checked for syntax');
	16	eval { my $results = $dfv->check( \%FORM, {} ); };
	17	like( $@, qr/Invalid input profile/, 'defaults are checked for syntax' );
20	18
	19	$dfv = Data::FormValidator->new( {}, { missing_optional_valid => 1 } );
	20	my $results = $dfv->check( \%FORM, {} );
	21	ok(
	22	$results->{profile}->{missing_optional_valid},
	23	'testing defaults appearing in profile'
	24	);
21	25
22		$dfv = Data::FormValidator->new({},{ missing_optional_valid=>1 });
23		my $results = $dfv->check(\%FORM, {});
24		ok ($results->{profile}->{missing_optional_valid}, 'testing defaults appearing in profile');
	26	$results = $dfv->check( \%FORM, { missing_optional_valid => 0 } );
25	27
26		$results = $dfv->check(\%FORM, { missing_optional_valid=>0});
27
28		ok (!$results->{profile}->{missing_optional_valid}, 'testing overriding defaults');
29
30
31
32
33
	28	ok( !$results->{profile}->{missing_optional_valid},
	29	'testing overriding defaults' );

+21

-28

t/30_filter_definedness.t less more

0		#!/usr/bin/perl -w
	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
	3	use Test::More qw/no_plan/;
	4	use Data::FormValidator;
	5
1	6	# to test definedness of built-in filters and general functions, as reported: http://rt.cpan.org/Ticket/Display.html?id=2751
2	7
3		use Test::More qw/no_plan/;
4		use strict;
5
6		# Basic definedness testing
7		use Data::FormValidator;
8
9	8	# upgrade warn to die so we can catch it.
10		$SIG{__WARN__} = sub {die $_[0]};
	9	$SIG{__WARN__} = sub { die $_[0] };
11	10
12	11	eval {
13		my $results = Data::FormValidator->check(
14		{
15		empty_array => [undef,undef],
16		very_empty => undef ,
17
18		},
19		{
20		required => [qw/very_empty empty_array/],
	12	my $results = Data::FormValidator->check( {
	13	empty_array => [ undef, undef ],
	14	very_empty => undef,
21	15
22		}
23		);
	16	},
	17	{
	18	required => [qw/very_empty empty_array/],
	19
	20	} );
24	21	};
25		ok(!$@, 'basic validation generates no warnings with -w') or diag $@;
26
	22	ok( !$@, 'basic validation generates no warnings with -w' ) or diag $@;
27	23
28	24	use Data::FormValidator::Filters (qw/:filters/);
29	25
30		for my $filter (grep {/^filter_/} keys %::) {
31		eval { $::{$filter}->(undef) };
32		ok(!$@, "uninitialized value in $filter filter generates no warning") or diag $@;
	26	for my $filter ( grep { /^filter_/ } keys %:: )
	27	{
	28	eval { $::{$filter}->(undef) };
	29	ok( !$@, "uninitialized value in $filter filter generates no warning" )
	30	or diag $@;
33	31	}
34
35
36
37
38

+99

-92

t/FV_length.t less more

0		#!/usr/bin/perl
	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
1	3	use Test::More 'no_plan';
2		use strict;
3		BEGIN {
4		use_ok('Data::FormValidator');
	4
	5	BEGIN
	6	{
	7	use_ok('Data::FormValidator');
5	8	}
6	9
7		use Data::FormValidator::Constraints qw(
8		FV_max_length
9		FV_min_length
10		FV_length_between
	10	use Data::FormValidator::Constraints qw(
	11	FV_max_length
	12	FV_min_length
	13	FV_length_between
11	14	);
12	15
13		my $result = Data::FormValidator->check({
14		first_names => 'Too long',
15		keywords => 'a',
16		ok => 'Good',
	16	my $result = Data::FormValidator->check( {
	17	first_names => 'Too long',
	18	keywords => 'a',
	19	ok => 'Good',
	20	},
	21	{
	22	required => [qw/first_names keywords ok/],
	23	constraint_methods => {
	24	first_names => FV_max_length(3),
	25	keywords => FV_length_between( 5, 8 ),
	26	too_long => FV_min_length(3),
	27	ok => {
	28	constraint_method => FV_length_between( 3, 6 ),
	29	name => 'ok_length',
	30	}
	31
17	32	},
18		{
19		required => [qw/first_names keywords ok/],
20		constraint_methods => {
21		first_names => FV_max_length(3),
22		keywords => FV_length_between(5,8),
23		too_long => FV_min_length(3),
24		ok => {
25		constraint_method => FV_length_between(3,6),
26		name => 'ok_length',
27		}
	33	msgs => {
	34	constraints => {
	35	ok_length => 'Not an OK length',
	36	length => 'Wrong Length',
	37	}
	38	},
	39	} );
28	40
29		},
30		msgs => {
31		constraints => {
32		ok_length => 'Not an OK length',
33		length => 'Wrong Length',
34		}
35		},
36		});
37
38		ok(defined $result);
	41	ok( defined $result );
39	42
40	43	# Test multi-line input: someone might be using this for a textarea or somesuch
41	44
42	45	my $multiline_result = Data::FormValidator->check(
43		my $expect = {
44		alpha => "apple\naeroplane\n", # 16 char
45		beta => "bus\nbuffalo\n", # 12 char
46		charlie => "cat\ncoconut\ncoffee\n", # 19 char
47		delta => "dog\ndinosaur\n", # 13 char
48		echo => "egg\nelephant\nemu\n", # 17 char
49		foxtrot => "flan\nfrog\n", # 10 char
50		golf => "giraffe\ngrapefruit\n", # 19 char
	46	my $expect = {
	47	alpha => "apple\naeroplane\n", # 16 char
	48	beta => "bus\nbuffalo\n", # 12 char
	49	charlie => "cat\ncoconut\ncoffee\n", # 19 char
	50	delta => "dog\ndinosaur\n", # 13 char
	51	echo => "egg\nelephant\nemu\n", # 17 char
	52	foxtrot => "flan\nfrog\n", # 10 char
	53	golf => "giraffe\ngrapefruit\n", # 19 char
	54	},
	55	{
	56	required => [qw/alpha beta charlie delta echo foxtrot golf/],
	57	untaint_all_constraints => 1,
	58	constraint_methods => {
	59	alpha => FV_max_length(16), # max length
	60	beta => FV_max_length(11), # too long
	61	charlie => FV_min_length(19), # just long enough
	62	delta => FV_min_length(14), # too short
	63	echo => FV_length_between( 16, 18 ), # just right
	64	foxtrot => FV_length_between( 11, 13 ), # too short
	65	golf => FV_length_between( 16, 18 ), # too long
51	66	},
52		{
53		required => [qw/alpha beta charlie delta echo foxtrot golf/],
54		untaint_all_constraints => 1,
55		constraint_methods => {
56		alpha => FV_max_length(16), # max length
57		beta => FV_max_length(11), # too long
58		charlie => FV_min_length(19), # just long enough
59		delta => FV_min_length(14), # too short
60		echo => FV_length_between(16,18), # just right
61		foxtrot => FV_length_between(11,13), # too short
62		golf => FV_length_between(16,18), # too long
63		},
64		},
	67	},
65	68	);
66	69
67		ok( $multiline_result->valid('alpha'), 'multiline FV_max_length in bounds' );
68		ok( $multiline_result->invalid('beta'), 'multiline FV_max_length too long' );
69		ok( $multiline_result->valid('charlie'), 'multiline FV_min_length in bounds' );
70		ok( $multiline_result->invalid('delta'), 'multiline FV_min_length too short' );
71		ok( $multiline_result->valid('echo'), 'multiline FV_length_between in bounds');
72		ok( $multiline_result->invalid('foxtrot'), 'multiline FV_length_between too short');
73		ok( $multiline_result->invalid('golf'), 'multiline FV_length_between too long' );
	70	ok( $multiline_result->valid('alpha'), 'multiline FV_max_length in bounds' );
	71	ok( $multiline_result->invalid('beta'), 'multiline FV_max_length too long' );
	72	ok( $multiline_result->valid('charlie'), 'multiline FV_min_length in bounds' );
	73	ok( $multiline_result->invalid('delta'), 'multiline FV_min_length too short' );
	74	ok( $multiline_result->valid('echo'), 'multiline FV_length_between in bounds' );
	75	ok(
	76	$multiline_result->invalid('foxtrot'),
	77	'multiline FV_length_between too short'
	78	);
	79	ok( $multiline_result->invalid('golf'),
	80	'multiline FV_length_between too long' );
74	81
75	82	# check expected values for valid untainted fields
76		for my $field (qw( alpha charlie echo )) {
77		is( $multiline_result->valid($field), $expect->{$field}, "identity $field");
	83	for my $field (qw( alpha charlie echo ))
	84	{
	85	is( $multiline_result->valid($field), $expect->{$field}, "identity $field" );
78	86	}
79	87
80	88	# Test "long" results. Early implementations checked length with
81	89	# regular expressions which limit length options to 32kb.
82	90	# The 80000 char test string is an arbitrary length.
83		# good a value as any other. And it's pretty long.
	91	# good a value as any other. And it's pretty long.
84	92	# Just for good measure we'll use the unicode smiley character (as seen in
85	93	# perluniintro) in our test string.
86	94
87		my $smiley = "\x{263a}"; # Thats "smiling face, white" folks!
88		my $long_string = "x$smiley" x 40000; # results in a 80000 length string
89		my $long_result = Data::FormValidator->check(
90		{
91		alpha => $long_string,
92		beta => $long_string,
93		charlie => $long_string,
94		delta => $long_string,
95		echo => $long_string,
96		foxtrot => $long_string,
97		golf => $long_string,
	95	my $smiley = "\x{263a}"; # Thats "smiling face, white" folks!
	96	my $long_string = "x$smiley" x 40000; # results in a 80000 length string
	97	my $long_result = Data::FormValidator->check( {
	98	alpha => $long_string,
	99	beta => $long_string,
	100	charlie => $long_string,
	101	delta => $long_string,
	102	echo => $long_string,
	103	foxtrot => $long_string,
	104	golf => $long_string,
	105	},
	106	{
	107	required => [qw/alpha beta charlie delta echo foxtrot golf/],
	108	constraint_methods => {
	109	alpha => FV_max_length(80000), # max length
	110	beta => FV_max_length(79999), # too long
	111	charlie => FV_min_length(80000), # just long enough
	112	delta => FV_min_length(80001), # too short
	113	echo => FV_length_between( 79999, 80001 ), # just right
	114	foxtrot => FV_length_between( 80001, 80000 ), # too short
	115	golf => FV_length_between( 70000, 79999 ), # too long
98	116	},
99		{
100		required => [qw/alpha beta charlie delta echo foxtrot golf/],
101		constraint_methods => {
102		alpha => FV_max_length(80000), # max length
103		beta => FV_max_length(79999), # too long
104		charlie => FV_min_length(80000), # just long enough
105		delta => FV_min_length(80001), # too short
106		echo => FV_length_between(79999,80001), # just right
107		foxtrot => FV_length_between(80001,80000), # too short
108		golf => FV_length_between(70000,79999), # too long
109		},
110		},
	117	},
111	118	);
112	119
113		ok( $long_result->valid('alpha'), 'long FV_max_length in bounds' );
114		ok( $long_result->invalid('beta'), 'long FV_max_length too long' );
115		ok( $long_result->valid('charlie'), 'long FV_min_length in bounds' );
116		ok( $long_result->invalid('delta'), 'long FV_min_length too short' );
117		ok( $long_result->valid('echo'), 'long FV_length_between in bounds');
118		ok( $long_result->invalid('foxtrot'), 'long FV_length_between too short');
	120	ok( $long_result->valid('alpha'), 'long FV_max_length in bounds' );
	121	ok( $long_result->invalid('beta'), 'long FV_max_length too long' );
	122	ok( $long_result->valid('charlie'), 'long FV_min_length in bounds' );
	123	ok( $long_result->invalid('delta'), 'long FV_min_length too short' );
	124	ok( $long_result->valid('echo'), 'long FV_length_between in bounds' );
	125	ok( $long_result->invalid('foxtrot'), 'long FV_length_between too short' );
119	126	ok( $long_result->invalid('golf'), 'long FV_length_between too long' );

-0

t/ValidatorPackagesTest1.pm less more

(No changes)

-0

t/ValidatorPackagesTest2.pm less more

(No changes)

+30

-38

t/any_errors.t less more

0		#!/usr/bin/perl
	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
	3	use Test::More 'no_plan';
	4	use Data::FormValidator;
1	5
2		use strict;
3		use Test::More 'no_plan';
	6	my $dfv_standard_any_errors = Data::FormValidator->new( {} );
	7	my $dfv_custom_any_errors =
	8	Data::FormValidator->new( {}, { msgs => { any_errors => 'some_errors' } } );
4	9
5		use Data::FormValidator;
6		my $dfv_standard_any_errors = Data::FormValidator->new({});
7		my $dfv_custom_any_errors = Data::FormValidator->new({},{msgs => { any_errors => 'some_errors' }});
	10	my %profile = ( required => 'foo', );
8	11
9		my %profile = (
10		required => 'foo',
11		);
	12	my %good_input = ( 'foo' => 1, );
	13	my %bad_input = ( 'bar' => 1, );
12	14
13		my %good_input = (
14		'foo' => 1,
15		);
16		my %bad_input = (
17		'bar' => 1,
18		);
19
20		my ($results, $msgs);
	15	my ( $results, $msgs );
21	16
22	17	# standard 'any_errors', good input
23		$results = $dfv_standard_any_errors->check(\%good_input, \%profile);
24		$msgs = $results->msgs;
	18	$results = $dfv_standard_any_errors->check( \%good_input, \%profile );
	19	$msgs = $results->msgs;
25	20
26		ok($results, "[standard any_errors] good input passed");
27		ok(!keys %$msgs, "[standard any_errors] no error messages");
	21	ok( $results, "[standard any_errors] good input passed" );
	22	ok( !keys %$msgs, "[standard any_errors] no error messages" );
28	23
29	24	# standard 'any_errors', bad input
30		$results = $dfv_standard_any_errors->check(\%bad_input, \%profile);
31		$msgs = $results->msgs;
	25	$results = $dfv_standard_any_errors->check( \%bad_input, \%profile );
	26	$msgs = $results->msgs;
32	27
33		ok(!$results, "[standard any_errors] bad input caught");
34		ok(keys %$msgs, "[standard any_errors] error messages reported");
35
	28	ok( !$results, "[standard any_errors] bad input caught" );
	29	ok( keys %$msgs, "[standard any_errors] error messages reported" );
36	30
37	31	# custom 'any_errors', good input
38		$results = $dfv_custom_any_errors->check(\%good_input, \%profile);
39		$msgs = $results->msgs;
	32	$results = $dfv_custom_any_errors->check( \%good_input, \%profile );
	33	$msgs = $results->msgs;
40	34
41		ok($results, "[custom any_errors] good input passed");
42		ok(!keys %$msgs, "[custom any_errors] no error messages");
43		ok(!$msgs->{'some_errors'}, "[custom any_errors] 'some_errors' not reported");
	35	ok( $results, "[custom any_errors] good input passed" );
	36	ok( !keys %$msgs, "[custom any_errors] no error messages" );
	37	ok( !$msgs->{'some_errors'}, "[custom any_errors] 'some_errors' not reported" );
44	38
45	39	# custom 'any_errors', bad input
46		$results = $dfv_custom_any_errors->check(\%bad_input, \%profile);
47		$msgs = $results->msgs;
	40	$results = $dfv_custom_any_errors->check( \%bad_input, \%profile );
	41	$msgs = $results->msgs;
48	42
49		ok(!$results, "[custom any_errors] bad input caught");
50		ok(keys %$msgs, "[custom any_errors] error messages reported");
51		ok($msgs->{'some_errors'}, "[custom any_errors] 'some_errors' reported");
	43	ok( !$results, "[custom any_errors] bad input caught" );
	44	ok( keys %$msgs, "[custom any_errors] error messages reported" );
	45	ok( $msgs->{'some_errors'}, "[custom any_errors] 'some_errors' reported" );
52	46
53
54

+33

-32

t/check_profile_syntax.t less more

	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
0	3	use Test::More qw/no_plan/;
1	4	use Data::FormValidator;
2		use strict;
3	5
4	6	{
5		local $@ = undef;
6		eval {
7		my $results = Data::FormValidator->check({},
8		{
9		msgs => {
10		my_field => 'foo',
11		},
12		}
13		);
14		};
15		like($@, qr/Invalid/, 'checking syntax of unknown msgs fields works');
	7	local $@ = undef;
	8	eval {
	9	my $results = Data::FormValidator->check(
	10	{},
	11	{
	12	msgs => {
	13	my_field => 'foo',
	14	},
	15	} );
	16	};
	17	like( $@, qr/Invalid/, 'checking syntax of unknown msgs fields works' );
16	18	}
17	19
18	20	my $results;
19	21	eval {
20		$results = Data::FormValidator->check({},
	22	$results = Data::FormValidator->check(
	23	{},
21	24	{
22		constraints => {
23		key => {
24		oops => 1,
25		},
	25	constraints => {
	26	key => {
	27	oops => 1,
	28	},
26	29
27		},
28		}
29		);
	30	},
	31	} );
30	32	};
31	33
32		like($@, qr/Invalid/, 'checking syntax of constraint hashrefs works');
33
	34	like( $@, qr/Invalid/, 'checking syntax of constraint hashrefs works' );
34	35
35	36	eval {
36		$results = Data::FormValidator->check({},
	37	$results = Data::FormValidator->check(
	38	{},
37	39	{
38		constraint_regexp_map => {
39		qr/key/ => {
40		oops => 1,
41		},
	40	constraint_regexp_map => {
	41	qr/key/ => {
	42	oops => 1,
	43	},
42	44
43		},
44		}
45		);
	45	},
	46	} );
46	47	};
47		like($@, qr/Invalid/, 'checking syntax of constraint_regexp_map hashrefs works');
48
	48	like( $@, qr/Invalid/,
	49	'checking syntax of constraint_regexp_map hashrefs works' );

+30

-26

t/closure_msgs.t less more

	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
0	3	use Test::More;
1		use strict;
	4	use Data::FormValidator;
	5	use Data::FormValidator::Constraints qw(
	6	email
	7	FV_eq_with
	8	);
2	9
3	10	# Test that closures and custom messages work in combination.
4	11	# Addresses this reported bug: #73235: msgs lookup doesn't work for built in closures
5	12	# https://rt.cpan.org/Ticket/Display.html?id=73235
6
7		use Data::FormValidator;
8		use Data::FormValidator::Constraints qw(
9		email
10		FV_eq_with
	13	my $result = Data::FormValidator->check(
	14	{ email => 'a', email_confirm => 'b' },
	15	{
	16	required => [qw( email email_confirm )],
	17	constraint_methods => {
	18	email => [ email(), FV_eq_with('email_confirm') ],
	19	},
	20	msgs => {
	21	constraints => {
	22	email => 'Invalid Email Address',
	23	eq_with => 'Must match confirmation'
	24	},
	25	} } );
	26	like(
	27	$result->msgs->{email},
	28	qr/Email Address/,
	29	"custom message for email() works"
	30	);
	31	like(
	32	$result->msgs->{email},
	33	qr/Must Match/i,
	34	"custom message for FV_eq_with() works"
11	35	);
12	36
13
14		my $result = Data::FormValidator->check(
15		{ email => 'a', email_confirm => 'b'},
16		{
17		required => [qw( email email_confirm )],
18		constraint_methods => {
19		email => [ email(), FV_eq_with('email_confirm') ],
20		},
21		msgs => {
22		constraints => {
23		email => 'Invalid Email Address',
24		eq_with => 'Must match confirmation'
25		},
26		}
27		}
28		);
29		like($result->msgs->{email}, qr/Email Address/, "custom message for email() works");
30		like($result->msgs->{email}, qr/Must Match/i, "custom message for FV_eq_with() works");
31
32	37	done_testing();
33

+48

-39

t/constraint_method.t less more

0		#!/usr/bin/perl
1	0
	1	use strict;
	2	use warnings;
2	3	use Test::More qw/no_plan/;
3
4	4	use Data::FormValidator;
5	5
6		my $result = Data::FormValidator->check({ field => 'value' }, {
7		required => 'field',
8		constraints => {
9		field => {
10		constraint_method => sub {
11		my $dfv = shift;
12		my $name = $dfv->get_current_constraint_name;
13		is($name, 'test_name', "get_current_constraint_name works");
14		},
15		name => 'test_name',
16		}
	6	my $result = Data::FormValidator->check(
	7	{ field => 'value' },
	8	{
	9	required => 'field',
	10	constraints => {
	11	field => {
	12	constraint_method => sub {
	13	my $dfv = shift;
	14	my $name = $dfv->get_current_constraint_name;
	15	is( $name, 'test_name', "get_current_constraint_name works" );
17	16	},
18		});
	17	name => 'test_name',
	18	}
	19	},
	20	} );
19	21
20	22	{
21		my $result = Data::FormValidator->check({
22		to_pass => 'value',
23		to_fail => 'value',
24		map_to_pass => 'value',
25		map_to_fail => 'value',
26		}, {
27		required => [qw/
28		to_pass
29		to_fail
30		map_to_pass
31		map_to_fail
32		/],
33		constraint_methods => {
34		to_pass => qr/value/,
35		to_fail => qr/wrong/,
36		},
37		constraint_method_regexp_map => {
38		qr/map_to_p.*/ => qr/value/,
39		qr/map_to_f.*/ => qr/fail/,
	23	my $result = Data::FormValidator->check( {
	24	to_pass => 'value',
	25	to_fail => 'value',
	26	map_to_pass => 'value',
	27	map_to_fail => 'value',
	28	},
	29	{
	30	required => [
	31	qw/
	32	to_pass
	33	to_fail
	34	map_to_pass
	35	map_to_fail
	36	/
	37	],
	38	constraint_methods => {
	39	to_pass => qr/value/,
	40	to_fail => qr/wrong/,
	41	},
	42	constraint_method_regexp_map => {
	43	qr/map_to_p.*/ => qr/value/,
	44	qr/map_to_f.*/ => qr/fail/,
40	45
41		},
42		});
	46	},
	47	} );
43	48
44		ok ( $result->invalid('to_fail'), "using qr with constraint_method fails as expected");
45		ok ( $result->valid('to_pass'), "using qr with constraint_method succeeds as expected");
46		ok ( $result->invalid('map_to_fail'), "using qr with constraint_method_regexp_map fails as expected");
47		ok ( $result->valid('map_to_pass'), "using qr with constraint_method_regexp_map succeeds as expected");
	49	ok( $result->invalid('to_fail'),
	50	"using qr with constraint_method fails as expected" );
	51	ok( $result->valid('to_pass'),
	52	"using qr with constraint_method succeeds as expected" );
	53	ok( $result->invalid('map_to_fail'),
	54	"using qr with constraint_method_regexp_map fails as expected" );
	55	ok( $result->valid('map_to_pass'),
	56	"using qr with constraint_method_regexp_map succeeds as expected" );
48	57	}

+29

-36

t/constraint_method_string.t less more

0		#!/usr/bin/perl
1		#
	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
	3	use Test::More tests => 4;
	4	use_ok('Data::FormValidator');
	5
2	6	# in response to bug report 2006/10/25 by Brian E. Lozier <brian@massassi.net>
3	7	# test script by Evan A. Zacks <zackse@cpan.org>
4	8	#
5	9	# The problem was that when specifying constraint_methods in a profile and
6	10	# using the name of a built-in (e.g., "zip") as the constraint, the built-in
7	11	# (match_zip or valid_zip) ended up being called as a method rather than a
8		# function.
	12	# function.
9	13	#
10	14	# So now we throw an error if a non-code-ref is used with a constraint method.
11
12		use strict;
13
14		use Test::More tests => 4;
15
16		use_ok('Data::FormValidator');
17
18	15	my $err_re = qr/not a code ref/;
19	16
20	17	{
21	18	my %profile = (
22		required => ['zip'],
23		constraint_methods => {
24		zip => 'zip',
25		}
26		);
	19	required => ['zip'],
	20	constraint_methods => {
	21	zip => 'zip',
	22	} );
27	23
28		my %data = (
29		zip => 56567
30		);
	24	my %data = ( zip => 56567 );
31	25
32		eval { my $r = Data::FormValidator->check(\%data, \%profile) };
33		like($@, $err_re,
34		"error thrown when given a string to constraint_method");
	26	eval { my $r = Data::FormValidator->check( \%data, \%profile ) };
	27	like( $@, $err_re, "error thrown when given a string to constraint_method" );
35	28	}
36	29
37	30	{
38	31	my %profile = (
39		required => ['zip'],
40		constraint_methods => {
41		zip => ['zip'],
42		}
43		);
	32	required => ['zip'],
	33	constraint_methods => {
	34	zip => ['zip'],
	35	} );
44	36
45	37	my %data = ( zip => 56567 );
46	38
47		eval { my $r = Data::FormValidator->check(\%data, \%profile) };
48		like($@, $err_re,
49		"error thrown when given a string to constraint_method...even as part of a list.");
	39	eval { my $r = Data::FormValidator->check( \%data, \%profile ) };
	40	like( $@, $err_re,
	41	"error thrown when given a string to constraint_method...even as part of a list."
	42	);
50	43	}
51	44
52	45	{
53	46	my %profile = (
54		required => ['zip'],
55		untaint_all_constraints => 1,
56		constraint_methods => { zip => {} }
57		);
	47	required => ['zip'],
	48	untaint_all_constraints => 1,
	49	constraint_methods => { zip => {} } );
58	50
59	51	my %data = ( zip => 56567 );
60	52
61		eval { my $r = Data::FormValidator->check(\%data, \%profile) };
62		like($@, $err_re,
63		"error thrown when given a string to constraint_method...even as hash declaration.");
	53	eval { my $r = Data::FormValidator->check( \%data, \%profile ) };
	54	like( $@, $err_re,
	55	"error thrown when given a string to constraint_method...even as hash declaration."
	56	);
64	57	}

+70

-52

t/constraint_method_zero.t less more

0		#!perl
1		# For RT#45177
2
	0	#!/usr/bin/env perl
3	1	use strict;
4	2	use warnings;
5
6	3	use Test::More 'no_plan';
7	4	use Data::FormValidator;
8	5
	6	# For RT#45177
9	7	{
10		my $results = Data::FormValidator->check({ nine_is_ok => 9 }, {
11		required => [ 'nine_is_ok' ],
12		constraint_methods => { 'nine_is_ok' => qr/^(9)$/ },
13		untaint_all_constraints => 1,
14		});
15		is($results->valid('nine_is_ok'),9, "nine should be valid for 9 with capturing parens (untainted)");
	8	my $results = Data::FormValidator->check(
	9	{ nine_is_ok => 9 },
	10	{
	11	required => ['nine_is_ok'],
	12	constraint_methods => { 'nine_is_ok' => qr/^(9)$/ },
	13	untaint_all_constraints => 1,
	14	} );
	15	is( $results->valid('nine_is_ok'),
	16	9, "nine should be valid for 9 with capturing parens (untainted)" );
16	17	}
17	18	{
18		my $results = Data::FormValidator->check({ nine_is_ok => 9 }, {
19		required => [ 'nine_is_ok' ],
20		constraint_methods => { 'nine_is_ok' => qr/^9$/ },
21		untaint_all_constraints => 1,
22		});
23		is($results->valid('nine_is_ok'),9, "nine should be valid for 9 without capturing parens (untainted)");
	19	my $results = Data::FormValidator->check(
	20	{ nine_is_ok => 9 },
	21	{
	22	required => ['nine_is_ok'],
	23	constraint_methods => { 'nine_is_ok' => qr/^9$/ },
	24	untaint_all_constraints => 1,
	25	} );
	26	is( $results->valid('nine_is_ok'),
	27	9, "nine should be valid for 9 without capturing parens (untainted)" );
24	28	}
25	29	{
26		my $results = Data::FormValidator->check({ zero_is_ok => 0 }, {
27		required => [ 'zero_is_ok' ],
28		constraint_methods => { 'zero_is_ok' => qr/^0$/ },
29		untaint_all_constraints => 1,
30		});
31		is($results->valid('zero_is_ok'),0, "zero should be valid without capturing parens (untainted)");
	30	my $results = Data::FormValidator->check(
	31	{ zero_is_ok => 0 },
	32	{
	33	required => ['zero_is_ok'],
	34	constraint_methods => { 'zero_is_ok' => qr/^0$/ },
	35	untaint_all_constraints => 1,
	36	} );
	37	is( $results->valid('zero_is_ok'),
	38	0, "zero should be valid without capturing parens (untainted)" );
32	39	}
33	40	{
34		my $results = Data::FormValidator->check({ zero_is_ok => 0 }, {
35		required => [ 'zero_is_ok' ],
36		constraint_methods => { 'zero_is_ok' => qr/^(0)$/ },
37		untaint_all_constraints => 1,
38		});
39		is($results->valid('zero_is_ok'),0, "zero should be valid with capturing parens (untainted)");
	41	my $results = Data::FormValidator->check(
	42	{ zero_is_ok => 0 },
	43	{
	44	required => ['zero_is_ok'],
	45	constraint_methods => { 'zero_is_ok' => qr/^(0)$/ },
	46	untaint_all_constraints => 1,
	47	} );
	48	is( $results->valid('zero_is_ok'),
	49	0, "zero should be valid with capturing parens (untainted)" );
40	50	}
41	51	{
42		my $results = Data::FormValidator->check({ nine_is_ok => 9 }, {
43		required => [ 'nine_is_ok' ],
44		constraint_methods => { 'nine_is_ok' => qr/^(9)$/ },
45		});
46		is($results->valid('nine_is_ok'),9, "nine should be valid for 9 with capturing parens");
	52	my $results = Data::FormValidator->check(
	53	{ nine_is_ok => 9 },
	54	{
	55	required => ['nine_is_ok'],
	56	constraint_methods => { 'nine_is_ok' => qr/^(9)$/ },
	57	} );
	58	is( $results->valid('nine_is_ok'),
	59	9, "nine should be valid for 9 with capturing parens" );
47	60	}
48	61	{
49		my $results = Data::FormValidator->check({ nine_is_ok => 9 }, {
50		required => [ 'nine_is_ok' ],
51		constraint_methods => { 'nine_is_ok' => qr/^9$/ },
52		});
53		is($results->valid('nine_is_ok'),9, "nine should be valid for 9 without capturing parens");
	62	my $results = Data::FormValidator->check(
	63	{ nine_is_ok => 9 },
	64	{
	65	required => ['nine_is_ok'],
	66	constraint_methods => { 'nine_is_ok' => qr/^9$/ },
	67	} );
	68	is( $results->valid('nine_is_ok'),
	69	9, "nine should be valid for 9 without capturing parens" );
54	70	}
55	71	{
56		my $results = Data::FormValidator->check({ zero_is_ok => 0 }, {
57		required => [ 'zero_is_ok' ],
58		constraint_methods => { 'zero_is_ok' => qr/^0$/ },
59		});
60		is($results->valid('zero_is_ok'),0, "zero should be valid without capturing parens");
	72	my $results = Data::FormValidator->check(
	73	{ zero_is_ok => 0 },
	74	{
	75	required => ['zero_is_ok'],
	76	constraint_methods => { 'zero_is_ok' => qr/^0$/ },
	77	} );
	78	is( $results->valid('zero_is_ok'),
	79	0, "zero should be valid without capturing parens" );
61	80	}
62	81	{
63		my $results = Data::FormValidator->check({ zero_is_ok => 0 }, {
64		required => [ 'zero_is_ok' ],
65		constraint_methods => { 'zero_is_ok' => qr/^(0)$/ },
66		});
67		is($results->valid('zero_is_ok'),0, "zero should be valid with capturing parens");
	82	my $results = Data::FormValidator->check(
	83	{ zero_is_ok => 0 },
	84	{
	85	required => ['zero_is_ok'],
	86	constraint_methods => { 'zero_is_ok' => qr/^(0)$/ },
	87	} );
	88	is( $results->valid('zero_is_ok'),
	89	0, "zero should be valid with capturing parens" );
68	90	}
69
70
71
72

+35

-29

t/constraint_regexp_map_profile_reuse.t less more

	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
0	3	use Test::More (qw/no_plan/);
1	4	use Data::FormValidator;
2	5
3	6	my $profile = {
4		required => [qw( test1 )],
5		constraint_regexp_map => {
6		qr/^test/ => 'email',
7		},
	7	required => [qw( test1 )],
	8	constraint_regexp_map => {
	9	qr/^test/ => 'email',
	10	},
8	11	};
9	12
10		my $data = {
11		test1 => 'not an email',
12		};
	13	my $data = { test1 => 'not an email', };
13	14
14		my $results1 = Data::FormValidator->check($data, $profile);
15		my $c1 = {%{ $profile->{constraints} }};
16		my $results2 = Data::FormValidator->check($data, $profile);
17		my $c2 = {%{ $profile->{constraints} }};
	15	my $results1 = Data::FormValidator->check( $data, $profile );
	16	my $c1 = { %{ $profile->{constraints} } };
	17	my $results2 = Data::FormValidator->check( $data, $profile );
	18	my $c2 = { %{ $profile->{constraints} } };
18	19
19		is_deeply($results1->{profile},$results2->{profile}, "constraints aren't duped when profile with constraint_regexp_map is reused");
20		is_deeply($c1,$c2, "constraints aren't duped when profile with constraint_regexp_map is reused");
	20	is_deeply( $results1->{profile}, $results2->{profile},
	21	"constraints aren't duped when profile with constraint_regexp_map is reused"
	22	);
	23	is_deeply( $c1, $c2,
	24	"constraints aren't duped when profile with constraint_regexp_map is reused"
	25	);
21	26
22	27	{
23		my $profile = {
24		required => [qw( test1 )],
25		field_filter_regexp_map => {
26		qr/^test/ => 'trim',
27		},
28		};
	28	my $profile = {
	29	required => [qw( test1 )],
	30	field_filter_regexp_map => {
	31	qr/^test/ => 'trim',
	32	},
	33	};
29	34
30		my $data = {
31		test1 => ' not an email ',
32		};
	35	my $data = { test1 => ' not an email ', };
33	36
34		my $results1 = Data::FormValidator->check($data, $profile);
35		my $c1 = {%{ $profile->{constraints} }};
36		my $results2 = Data::FormValidator->check($data, $profile);
37		my $c2 = {%{ $profile->{constraints} }};
38		is_deeply($results1->{profile},$results2->{profile}, "field_filters aren't duped when profile with field_filter_regexp_map is reused");
39		is_deeply($c1,$c2, "field_filters aren't duped when profile with field_filter_regexp_map is reused");
	37	my $results1 = Data::FormValidator->check( $data, $profile );
	38	my $c1 = { %{ $profile->{constraints} } };
	39	my $results2 = Data::FormValidator->check( $data, $profile );
	40	my $c2 = { %{ $profile->{constraints} } };
	41	is_deeply( $results1->{profile}, $results2->{profile},
	42	"field_filters aren't duped when profile with field_filter_regexp_map is reused"
	43	);
	44	is_deeply( $c1, $c2,
	45	"field_filters aren't duped when profile with field_filter_regexp_map is reused"
	46	);
40	47
41	48	}
42

+18

-22

t/constraints_builtin.t less more

0		#!/usr/bin/perl
1
	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
2	3	use Test::More qw/no_plan/;
3		use strict;
4
5	4	use Data::FormValidator;
6	5
7	6	my $input_profile = {
8		required => [ qw( number_field ) ],
9		constraints => {
10		number_field => {
11		name => 'number',
12		constraint => qr/^\d+$/,
13		}
14		}
	7	required => [qw( number_field )],
	8	constraints => {
	9	number_field => {
	10	name => 'number',
	11	constraint => qr/^\d+$/,
	12	} } };
	13
	14	my $input_hashref = { number_field => 0, };
	15
	16	my $results;
	17	eval {
	18	$results = Data::FormValidator->check( $input_hashref, $input_profile );
15	19	};
16	20
17		my $input_hashref = {
18		number_field => 0,
19		};
	21	ok( !$@, 'survived validate' );
20	22
21		my $results;
22		eval{
23		$results = Data::FormValidator->check($input_hashref, $input_profile);
24		};
25
26		ok(!$@, 'survived validate');
27
28		is($results->valid->{number_field},0, 'using 0 in a constraint regexp works');
	23	is( $results->valid->{number_field}, 0,
	24	'using 0 in a constraint regexp works' );

+47

-39

t/constraints_builtin_closure.t less more

0		#!/usr/bin/perl
1
	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
2	3	use Test::More;
3		use strict;
4
5	4	use Data::FormValidator;
6	5	use Data::FormValidator::Constraints qw(:closures);
7	6
8	7	my $input_profile = {
9		required => [ qw( number_field nan nan_typo ) ],
10		optional => [ qw( nan_name_this ) ],
11		constraint_methods => {
12		number_field => sub {
13		my ($self,$v) = @_;
14		#$self->set_current_constraint_name('number');
15		return ($v =~ m/^\d+$/);
16		},
17		nan => sub {
18		my ($self,$v) = @_;
19		$self->name_this('number');
20		return ($v =~ m/^\d+$/);
21		},
22		nan_typo => sub {
23		my ($self,$v) = @_;
24		$self->name_this('numer');
25		return ($v =~ m/^\d+$/);
26		},
27		nan_name_this => sub { my ($d,$v) = @_; $d->name_this('number'); return ($v =~ m/^\d+$/); },
	8	required => [qw( number_field nan nan_typo )],
	9	optional => [qw( nan_name_this )],
	10	constraint_methods => {
	11	number_field => sub {
	12	my ( $self, $v ) = @_;
28	13
	14	#$self->set_current_constraint_name('number');
	15	return ( $v =~ m/^\d+$/ );
29	16	},
30		msgs => {
31		constraints => {
32		number => 'Must be a digit',
33		}
34		}
35		};
	17	nan => sub {
	18	my ( $self, $v ) = @_;
	19	$self->name_this('number');
	20	return ( $v =~ m/^\d+$/ );
	21	},
	22	nan_typo => sub {
	23	my ( $self, $v ) = @_;
	24	$self->name_this('numer');
	25	return ( $v =~ m/^\d+$/ );
	26	},
	27	nan_name_this => sub {
	28	my ( $d, $v ) = @_;
	29	$d->name_this('number');
	30	return ( $v =~ m/^\d+$/ );
	31	},
	32
	33	},
	34	msgs => {
	35	constraints => {
	36	number => 'Must be a digit',
	37	} } };
36	38
37	39	my $input_hashref = {
38		number_field => 0,
39		nan => 'infinity',
40		nan_name_this => 'infinity',
	40	number_field => 0,
	41	nan => 'infinity',
	42	nan_name_this => 'infinity',
41	43	};
42	44
43	45	my $results;
44		eval{
45		$results = Data::FormValidator->check($input_hashref, $input_profile);
	46	eval {
	47	$results = Data::FormValidator->check( $input_hashref, $input_profile );
46	48	};
47		is($@,'','survived eval');
48		is($results->valid()->{number_field},0, 'using 0 in a constraint regexp works');
	49	is( $@, '', 'survived eval' );
	50	is( $results->valid()->{number_field},
	51	0, 'using 0 in a constraint regexp works' );
49	52	my $msgs = $results->msgs();
50		like($msgs->{nan},qr/Must be a digit/, 'set_current_contraint_name succeeds');
51		like($msgs->{nan_name_this},qr/Must be a digit/, 'name_this succeeds');
	53	like( $msgs->{nan}, qr/Must be a digit/,
	54	'set_current_contraint_name succeeds' );
	55	like( $msgs->{nan_name_this}, qr/Must be a digit/, 'name_this succeeds' );
52	56
53		unlike($msgs->{nan_typo},qr/Must be a digit/, 'set_current_contraint_name doesn\'t work if you typo it');
	57	unlike(
	58	$msgs->{nan_typo},
	59	qr/Must be a digit/,
	60	'set_current_contraint_name doesn\'t work if you typo it'
	61	);
54	62
55	63	done_testing();

+17

-17

t/constraints_factory.t less more

	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
0	3	use Test::More 'no_plan';
1
2	4	use Data::FormValidator;
3	5	use Data::FormValidator::ConstraintsFactory 'make_length_constraint';
4	6
5	7	{
6		my $results = Data::FormValidator->check(
7		{
8		short_enough => 'doh',
9		too_long => "So long she's happy",
10		},
11		{
12		required => [qw/too_long short_enough/],
13		constraints => {
14		too_long => make_length_constraint(5),
15		short_enough => make_length_constraint(5),
16		}
17		}
18		);
	8	my $results = Data::FormValidator->check( {
	9	short_enough => 'doh',
	10	too_long => "So long she's happy",
	11	},
	12	{
	13	required => [qw/too_long short_enough/],
	14	constraints => {
	15	too_long => make_length_constraint(5),
	16	short_enough => make_length_constraint(5),
	17	} } );
19	18
20		ok($results->valid('short_enough'), 'positive test for make_length_constraint()');
21		ok(! $results->valid('too_long'),'negative test for make_length_constraint()');
	19	ok( $results->valid('short_enough'),
	20	'positive test for make_length_constraint()' );
	21	ok( !$results->valid('too_long'),
	22	'negative test for make_length_constraint()' );
22	23
23	24	}
24

+37

-33

t/constraints_invalid_once_only.t less more

0		#!/usr/bin/perl
	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
	3	use Test::More tests => 1;
	4	use Data::FormValidator;
1	5
2	6	# this test checks that a failing constraint is only marked as invalid once
3	7
4		use Test::More tests => 1;
5		use Data::FormValidator;
6		use strict;
7
8		sub check_passwords {
9		my ( $dfv, $val ) = @_;
10		my $passwords = $dfv->{__INPUT_DATA}->{password};
11		if( ref( $passwords ) eq 'ARRAY' ) {
12		if( $$passwords[0] eq $$passwords[1] ) {
13		return 1;
14		}
15		return 0;
16		}
17		return 1;
	8	sub check_passwords
	9	{
	10	my ( $dfv, $val ) = @_;
	11	my $passwords = $dfv->{__INPUT_DATA}->{password};
	12	if ( ref($passwords) eq 'ARRAY' )
	13	{
	14	if ( $$passwords[0] eq $$passwords[1] )
	15	{
	16	return 1;
	17	}
	18	return 0;
	19	}
	20	return 1;
18	21	}
19	22
20		my %data = (
21		'password' => ['123456','123457'],
	23	my %data = ( 'password' => [ '123456', '123457' ], );
	24
	25	my %profile = (
	26	optional => [qw/password/],
	27	constraint_methods => {
	28	password => \&check_passwords,
	29	},
22	30	);
23	31
24		my %profile = (
25		optional => [qw/password/],
26		constraint_methods => {
27		password => \&check_passwords,
28		},
29		);
	32	my $results = Data::FormValidator->check( \%data, \%profile );
30	33
31		my $results = Data::FormValidator->check(\%data, \%profile);
32
33		my $invalid = $results->{invalid};
	34	my $invalid = $results->{invalid};
34	35	my $duplicated = {};
35	36	my $has_duplicates;
36		foreach ( @{$invalid->{password}} ) {
37		if( exists $duplicated->{$_} ) {
38		$has_duplicates = 1;
39		last;
40		}
41		$duplicated->{$_} = 1;
	37	foreach ( @{ $invalid->{password} } )
	38	{
	39	next unless $_;
	40	if ( exists $duplicated->{$_} )
	41	{
	42	$has_duplicates = 1;
	43	last;
	44	}
	45	$duplicated->{$_} = 1;
42	46	}
43		ok(!$has_duplicates, 'constraint marked as invalid only once');
	47	ok( !$has_duplicates, 'constraint marked as invalid only once' );

+21

-23

t/constraints_num_values.t less more

0		#!/usr/bin/perl
1
	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
2	3	use Test::More;
3		use strict;
	4	use Data::FormValidator;
	5	use Data::FormValidator::Constraints qw(:closures);
4	6
5	7	# Test FV_num_values and FV_num_values_between
6	8
7		use Data::FormValidator;
8		use Data::FormValidator::Constraints qw(:closures);
9
10		my $results = Data::FormValidator->check(
11		{
12		num_values_pass => [qw(a b)],
13		num_values_fail => [qw(a b)],
	9	my $results = Data::FormValidator->check( {
	10	num_values_pass => [qw(a b)],
	11	num_values_fail => [qw(a b)],
14	12	num_values_between_pass => [qw(a)],
15	13	num_values_between_fail => [qw(a b)],
16		},
17		{
18		optional_regexp => qr/.*/,
	14	},
	15	{
	16	optional_regexp => qr/.*/,
19	17	constraint_methods => {
20		num_values_pass => FV_num_values(2),
21		num_values_fail => FV_num_values(1),
22		num_values_between_pass => FV_num_values_between(1,2),
23		num_values_between_fail => FV_num_values_between(3,4),
24		}
25		});
	18	num_values_pass => FV_num_values(2),
	19	num_values_fail => FV_num_values(1),
	20	num_values_between_pass => FV_num_values_between( 1, 2 ),
	21	num_values_between_fail => FV_num_values_between( 3, 4 ),
	22	} } );
26	23
27	24	my $valid = $results->valid;
28		ok($valid->{num_values_pass}, 'FV_num_values pass');
29		ok($valid->{num_values_between_pass}, 'FV_num_values_between pass');
	25	ok( $valid->{num_values_pass}, 'FV_num_values pass' );
	26	ok( $valid->{num_values_between_pass}, 'FV_num_values_between pass' );
30	27
31	28	my $invalid = $results->invalid;
32		ok($invalid->{num_values_fail}, 'FV_num_values fail - one value requested, two found');
33		ok($invalid->{num_values_between_fail}, 'FV_num_values_between fail');
	29	ok( $invalid->{num_values_fail},
	30	'FV_num_values fail - one value requested, two found' );
	31	ok( $invalid->{num_values_between_fail}, 'FV_num_values_between fail' );
34	32
35	33	done_testing();

+23

-29

t/constraints_regexp_map_interaction.t less more

0		#!/usr/bin/perl
1
	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
	3	use lib 'perllib';
2	4	use Test::More qw/no_plan/;
3		use strict;
4
5		use lib 'perllib';
6
7	5	use Data::FormValidator;
8	6
9	7	my $input_profile = {
10		required => [ 'email_field' ],
11		constraints => {
12		email_field => [ 'email' ],
13		}
14		};
	8	required => ['email_field'],
	9	constraints => {
	10	email_field => ['email'],
	11	} };
15	12
16		my $input_hashref = {
17		email_field => 'test@bad_email',
18		};
19
20
	13	my $input_hashref = { email_field => 'test@bad_email', };
21	14
22	15	my $results;
23		eval{
24		$results = Data::FormValidator->check($input_hashref, $input_profile);
	16	eval {
	17	$results = Data::FormValidator->check( $input_hashref, $input_profile );
25	18	};
26		is($@, '', "Survived validate");
	19	is( $@, '', "Survived validate" );
27	20
28	21	my @invalids = $results->invalid;
29		is(scalar @invalids, 1, "Correctly catches the bad field");
30		is($invalids[0], 'email_field', "The invalid field is listed correctly as 'email_field'");
31
32
	22	is( scalar @invalids, 1, "Correctly catches the bad field" );
	23	is( $invalids[0], 'email_field',
	24	"The invalid field is listed correctly as 'email_field'" );
33	25
34	26	# Now add constraint_regexp_map to the profile, and we'll get a weird interaction...
35	27
36	28	my $regex = qr/^test/;
37	29	$input_profile->{constraint_regexp_map} = { qr/email_/ => $regex };
38	30
39		eval{
40		$results = Data::FormValidator->check($input_hashref, $input_profile);
	31	eval {
	32	$results = Data::FormValidator->check( $input_hashref, $input_profile );
41	33	};
42		is($@, '', "Survived validate");
	34	is( $@, '', "Survived validate" );
43	35
44	36	@invalids = $results->invalid;
45		is(scalar @invalids, 1, "Still correctly catches the bad field");
46		is($invalids[0], 'email_field', "The invalid field is still listed correctly as 'email_field'");
	37	is( scalar @invalids, 1, "Still correctly catches the bad field" );
	38	is( $invalids[0], 'email_field',
	39	"The invalid field is still listed correctly as 'email_field'" );
47	40
48		ok($input_hashref->{email_field} =~ $regex, "But perl agrees that the email address does match the regex");
	41	ok( $input_hashref->{email_field} =~ $regex,
	42	"But perl agrees that the email address does match the regex" );

+58

-57

t/constraints_reuse.t less more

0		#!/usr/bin/perl
	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
	3	use Test::More tests => 7;
	4	use Data::FormValidator;
1	5
2	6	# This test is to confirm that values are preserved
3	7	# for input data when used with multiple constraints

8	12	# relies on the order on which perl returns the keys
9	13	# from each %{ $profile->{constraints} }
10	14
11		use Test::More tests => 7;
12		use Data::FormValidator;
13		use strict;
14
15	15	my %data = (
16		'depart_date' => '2004',
17		'return_date' => '2005',
	16	'depart_date' => '2004',
	17	'return_date' => '2005',
18	18	);
19	19
20	20	my %profile = (
21		required => [qw/
22		depart_date
23		return_date
24		/],
	21	required => [
	22	qw/
	23	depart_date
	24	return_date
	25	/
	26	],
25	27	field_filters => {
26		depart_date => sub { my $v = shift; $v =~ s/XXX//; $v; }
	28	depart_date => sub { my $v = shift; $v =~ s/XXX//; $v; }
27	29	},
28	30	constraints => {
29		depart_date => {
30		name => 'expected_to_succeed',
31		params => [qw/depart_date return_date/],
32		constraint => sub {
33		my ($depart,$return) = @_;
34		Test::More::is($depart, '2004');
35		Test::More::is($return, '2005');
36		return ($depart < $return);
37		},
	31	depart_date => {
	32	name => 'expected_to_succeed',
	33	params => [qw/depart_date return_date/],
	34	constraint => sub {
	35	my ( $depart, $return ) = @_;
	36	Test::More::is( $depart, '2004' );
	37	Test::More::is( $return, '2005' );
	38	return ( $depart < $return );
38	39	},
39		return_date => {
40		name => 'built_to_fail',
41		params => [qw/depart_date return_date/],
42		constraint => sub {
43		my ($depart,$return) = @_;
44		Test::More::is($depart, '2004');
45		Test::More::is($return, '2005');
46		return ($depart > $return);
47		},
	40	},
	41	return_date => {
	42	name => 'built_to_fail',
	43	params => [qw/depart_date return_date/],
	44	constraint => sub {
	45	my ( $depart, $return ) = @_;
	46	Test::More::is( $depart, '2004' );
	47	Test::More::is( $return, '2005' );
	48	return ( $depart > $return );
48	49	},
	50	},
49	51	},
50	52	missing_optional_valid => 1,
51		msgs => {
52		format => 'error(%s)',
	53	msgs => {
	54	format => 'error(%s)',
53	55	constraints => {
54		'valid_date' => 'bad date',
55		'depart_le_return' => 'depart is greater than return',
56		},
	56	'valid_date' => 'bad date',
	57	'depart_le_return' => 'depart is greater than return',
	58	},
57	59	},
58	60	);
59	61
	62	my $results = Data::FormValidator->check( \%data, \%profile );
60	63
61		my $results = Data::FormValidator->check(\%data, \%profile);
62
63		ok(!$results->valid('return_date'), 'first constraint applied intentionally fails');
64		ok($results->valid('depart_date'),
65		'second constraint still has access to value of field used in first failed constraint.');
66
	64	ok( !$results->valid('return_date'),
	65	'first constraint applied intentionally fails' );
	66	ok( $results->valid('depart_date'),
	67	'second constraint still has access to value of field used in first failed constraint.'
	68	);
67	69
68	70	# The next test are to confirm when a constraint method returns 'undef'
69	71	# that it causes no warnings to be issued
70	72	{
71		my %profile = (
72		required => ['foo'],
73		constraints => {
74		foo => {
75		constraint => sub {
76		return;
77		},
78		},
	73	my %profile = (
	74	required => ['foo'],
	75	constraints => {
	76	foo => {
	77	constraint => sub {
	78	return;
79	79	},
80		untaint_all_constraints => 1,
81		);
	80	},
	81	},
	82	untaint_all_constraints => 1,
	83	);
82	84
83		my $err = '';
84		local *STDERR;
85		open STDERR, '>', \$err;
86		my $results = Data::FormValidator->check({ foo => 1}, \%profile);
87		is($err, '', 'no warnings emitted');
	85	my $err = '';
	86	local *STDERR;
	87	open STDERR, '>', \$err;
	88	my $results = Data::FormValidator->check( { foo => 1 }, \%profile );
	89	is( $err, '', 'no warnings emitted' );
88	90
89	91	}
90

+40

-35

t/credit_card.t less more

	0	#!/usr/bin/env perl
0	1	use strict;
	2	use warnings;
	3	use Test::More tests => 25;
	4	use Data::FormValidator;
	5	use Data::FormValidator::Constraints qw(:closures);
	6
1	7	# check credit card number validation (the cc_number constraint).
2	8	# note: this constraint is checked directly in 11_procedural_match.t and
3	9	# procedural_valid.t, but here we will test it indirectly through a profile
4
5		$^W = 1;
6
7		use Data::FormValidator;
8		use Data::FormValidator::Constraints qw(:closures);
9		use Test::More tests => 25;
10	10
11	11	my $dfv_profile_old = {
12	12	required => [qw(credit_card_type credit_card_number)],
13	13	constraints => {
14	14	credit_card_number => {
15	15	constraint => 'cc_number',
16		params => [ qw(credit_card_number credit_card_type) ],
	16	params => [qw(credit_card_number credit_card_type)],
17	17	},
18	18	},
19	19	};

22	22	# http://www.verisign.com/support/payflow/manager/selfHelp/testCardNum.html
23	23	# maps type => [ [ invalids ... ], [ valids ... ] ]
24	24	my %cc_numbers = (
25		Visa => [ [ '4000111122223333', ],
26		[ '4111111111111111', '4012888888881881', ] ],
	25	Visa =>
	26	[ [ '4000111122223333', ], [ '4111111111111111', '4012888888881881', ] ],
27	27
28		Mastercard => [ [ '5424111122223333', ],
29		[ '5105105105105100', '5555555555554444', ] ],
	28	Mastercard =>
	29	[ [ '5424111122223333', ], [ '5105105105105100', '5555555555554444', ] ],
30	30
31		Discover => [ [ '6000111122223333', ],
32		[ '6011111111111117', '6011000990139424', ] ],
	31	Discover =>
	32	[ [ '6000111122223333', ], [ '6011111111111117', '6011000990139424', ] ],
33	33
34		Amex => [ [ '371500001111222', ],
35		[ '378282246310005', '371449635398431', ] ],
	34	Amex => [ [ '371500001111222', ], [ '378282246310005', '371449635398431', ] ],
36	35	);
37	36
38		while ( my ($card_type, $numbers) = each %cc_numbers ) {
39		foreach my $is_valid ( 0..1 ) {
40		foreach my $n ( @{ $numbers->[$is_valid] } ) {
41		my $msg = ($is_valid ? "Valid" : "Invalid") . ": $card_type/$n";
	37	while ( my ( $card_type, $numbers ) = each %cc_numbers )
	38	{
	39	foreach my $is_valid ( 0 .. 1 )
	40	{
	41	foreach my $n ( @{ $numbers->[$is_valid] } )
	42	{
	43	my $msg = ( $is_valid ? "Valid" : "Invalid" ) . ": $card_type/$n";
42	44	my $input = {
43	45	credit_card_type => $card_type,
44	46	credit_card_number => $n,

49	51	}
50	52	}
51	53
52		my $dfv_profile_new = eval {
53		{
	54	my $dfv_profile_new = eval { {
54	55	required => [qw(credit_card_type credit_card_number)],
55	56	constraint_methods => {
56		credit_card_number => cc_number({fields => ['credit_card_type']}),
	57	credit_card_number => cc_number( { fields => ['credit_card_type'] } ),
57	58	},
58		}
	59	};
59	60	};
60	61
61		ok( ! $@, "cc_number subroutine runs without error" );
	62	ok( !$@, "cc_number subroutine runs without error" );
62	63
63	64	# broken cc_number subroutine in older dfv
64		SKIP: {
	65	SKIP:
	66	{
65	67	skip "(Older DFV has broken cc_number subroutine)", 12 if $@;
66	68
67		while ( my ($card_type, $numbers) = each %cc_numbers ) {
68		foreach my $is_valid ( 0..1 ) {
69		foreach my $n ( @{ $numbers->[$is_valid] } ) {
70		my $msg = ($is_valid ? "Valid" : "Invalid") . ": $card_type/$n";
	69	while ( my ( $card_type, $numbers ) = each %cc_numbers )
	70	{
	71	foreach my $is_valid ( 0 .. 1 )
	72	{
	73	foreach my $n ( @{ $numbers->[$is_valid] } )
	74	{
	75	my $msg = ( $is_valid ? "Valid" : "Invalid" ) . ": $card_type/$n";
71	76	my $input = {
72	77	credit_card_type => $card_type,
73	78	credit_card_number => $n,

81	86
82	87	##
83	88
84		sub validate_q {
	89	sub validate_q
	90	{
85	91	my ( $data, $profile ) = @_;
86	92
87		my $dfv_result = eval {
88		Data::FormValidator->check($data, $profile);
89		};
	93	my $dfv_result = eval { Data::FormValidator->check( $data, $profile ); };
90	94
91		if( $@ ) {
	95	if ($@)
	96	{
92	97	diag "Failed check [$@]";
93	98	return;
94	99	}
95	100
96		return ($dfv_result->has_invalid \|\| $dfv_result->has_missing) ? 0 : 1;
	101	return ( $dfv_result->has_invalid \|\| $dfv_result->has_missing ) ? 0 : 1;
97	102	}

+72

-59

t/dates.t less more

0		#!/usr/bin/perl -w
	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
1	3	use Test::More;
2	4
3	5	eval { require Date::Calc; };
4	6
5		if( $@ ) {
6		plan skip_all => 'Date::Calc required for date testing';
	7	if ($@)
	8	{
	9	plan skip_all => 'Date::Calc required for date testing';
7	10	}
8		else {
9		plan 'no_plan';
	11	else
	12	{
	13	plan 'no_plan';
10	14	}
11	15
12	16	require Data::FormValidator::Constraints::Dates;
13	17
14	18	use strict;
15	19
16		my $format = Data::FormValidator::Constraints::Dates::_prepare_date_format('MM/DD/YYYY hh?:mm:ss pp');
	20	my $format = Data::FormValidator::Constraints::Dates::_prepare_date_format(
	21	'MM/DD/YYYY hh?:mm:ss pp');
17	22
18		my ($date,$year, $month, $day, $hour, $min, $sec) = Data::FormValidator::Constraints::Dates::_parse_date_format($format, '12/02/2003 1:01:03 PM');
19		ok ($date eq '12/02/2003 1:01:03 PM','returning untainted date');
20		ok ($year == 2003, 'basic date prepare and parse test');
21		ok ($month == 12);
22		ok ($day == 2);
23		ok ($hour == 13);
24		ok ($min == 1);
25		ok ($sec == 3);
	23	my ( $date, $year, $month, $day, $hour, $min, $sec ) =
	24	Data::FormValidator::Constraints::Dates::_parse_date_format( $format,
	25	'12/02/2003 1:01:03 PM' );
	26	ok( $date eq '12/02/2003 1:01:03 PM', 'returning untainted date' );
	27	ok( $year == 2003, 'basic date prepare and parse test' );
	28	ok( $month == 12 );
	29	ok( $day == 2 );
	30	ok( $hour == 13 );
	31	ok( $min == 1 );
	32	ok( $sec == 3 );
26	33
27	34	# Now try again, leaving out PM, which may trigger a warning when it shouldn't
28		$format = Data::FormValidator::Constraints::Dates::_prepare_date_format('MM/DD/YYYY hh?:mm:ss');
29		($date,$year, $month, $day, $hour, $min, $sec) = Data::FormValidator::Constraints::Dates::_parse_date_format($format, '12/02/2003 1:01:03');
30		is($date,'12/02/2003 1:01:03','returning untainted date');
31		ok ($year == 2003, 'basic date prepare and parse test');
32		ok ($month == 12, 'month');
33		ok ($day == 2,'day');
34		ok ($hour == 1,'hour');
35		ok ($min == 1,'min');
36		ok ($sec == 3,'sec');
	35	$format = Data::FormValidator::Constraints::Dates::_prepare_date_format(
	36	'MM/DD/YYYY hh?:mm:ss');
	37	( $date, $year, $month, $day, $hour, $min, $sec ) =
	38	Data::FormValidator::Constraints::Dates::_parse_date_format( $format,
	39	'12/02/2003 1:01:03' );
	40	is( $date, '12/02/2003 1:01:03', 'returning untainted date' );
	41	ok( $year == 2003, 'basic date prepare and parse test' );
	42	ok( $month == 12, 'month' );
	43	ok( $day == 2, 'day' );
	44	ok( $hour == 1, 'hour' );
	45	ok( $min == 1, 'min' );
	46	ok( $sec == 3, 'sec' );
37	47
38	48	use Data::FormValidator;
39	49
40	50	my $simple_profile = {
41		required => [qw/date_and_time_field_bad date_and_time_field_good/],
42		validator_packages => [qw/Data::FormValidator::Constraints::Dates/],
43		constraints => {
44		'date_and_time_field_good' => {
45		constraint_method => 'date_and_time',
46		params=>[\'MM/DD/YYYY hh:mm pp'],
47		},
48		'date_and_time_field_bad' => {
49		constraint_method => 'date_and_time',
50		params=>[\'MM/DD/YYYY hh:mm pp'],
51		},
52		},
53		untaint_constraint_fields=>[qw/date_and_time_field/],
	51	required => [qw/date_and_time_field_bad date_and_time_field_good/],
	52	validator_packages => [qw/Data::FormValidator::Constraints::Dates/],
	53	constraints => {
	54	'date_and_time_field_good' => {
	55	constraint_method => 'date_and_time',
	56	params => [ \'MM/DD/YYYY hh:mm pp' ],
	57	},
	58	'date_and_time_field_bad' => {
	59	constraint_method => 'date_and_time',
	60	params => [ \'MM/DD/YYYY hh:mm pp' ],
	61	},
	62	},
	63	untaint_constraint_fields => [qw/date_and_time_field/],
54	64	};
55	65
56	66	my $simple_data = {
57		date_and_time_field_good => '12/04/2003 02:00 PM',
58		date_and_time_field_bad => 'slug',
59		};
	67	date_and_time_field_good => '12/04/2003 02:00 PM',
	68	date_and_time_field_bad => 'slug',
	69	};
60	70
	71	my $validator = new Data::FormValidator( {
	72	simple => $simple_profile,
	73	} );
61	74
62		my $validator = new Data::FormValidator({
63		simple => $simple_profile,
64		});
	75	my ( $valids, $missings, $invalids, $unknowns ) = ( {}, [], {}, [] );
	76	eval {
	77	( $valids, $missings, $invalids, $unknowns ) =
	78	$validator->validate( $simple_data, 'simple' );
	79	};
	80	ok( ( not $@ ), 'eval' )
	81	or diag $@;
	82	ok( $valids->{date_and_time_field_good}, 'expecting date_and_time success' );
	83	ok( ( grep /date_and_time_field_bad/, @$invalids ),
	84	'expecting date_and_time failure' );
65	85
66		my ($valids, $missings, $invalids, $unknowns) = ({},[],{},[]);
67		eval{
68		($valids, $missings, $invalids, $unknowns) = $validator->validate($simple_data, 'simple');
69		};
70		ok ((not $@), 'eval') or
71		diag $@;
72		ok ($valids->{date_and_time_field_good}, 'expecting date_and_time success');
73		ok ((grep /date_and_time_field_bad/, @$invalids), 'expecting date_and_time failure');
74
75		{
76		my $format = Data::FormValidator::Constraints::Dates::_prepare_date_format('MMDDYYYY');
77		my ($date,$year, $month, $day, $hour, $min, $sec) =
78		Data::FormValidator::Constraints::Dates::_parse_date_format($format, '12022003');
79		ok ($date eq '12022003','returning date');
80		ok ($year == 2003, 'basic date prepare and parse test');
81		ok ($month == 12);
82		ok ($day == 2);
	86	{
	87	my $format =
	88	Data::FormValidator::Constraints::Dates::_prepare_date_format('MMDDYYYY');
	89	my ( $date, $year, $month, $day, $hour, $min, $sec ) =
	90	Data::FormValidator::Constraints::Dates::_parse_date_format( $format,
	91	'12022003' );
	92	ok( $date eq '12022003', 'returning date' );
	93	ok( $year == 2003, 'basic date prepare and parse test' );
	94	ok( $month == 12 );
	95	ok( $day == 2 );
83	96	}

+94

-83

t/dates_closure.t less more

0		#!/usr/bin/perl -w
	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
1	3	use Test::More;
2
3		eval { require Date::Calc; };
4		if( $@ ) {
5		plan skip_all => 'Date::Calc required for date testing';
6		}
7		else {
8		plan 'no_plan';
9		}
10
11		require Data::FormValidator::Constraints::Dates;
12
13		use strict;
14
15		use strict;
16
17		my $format = Data::FormValidator::Constraints::Dates::_prepare_date_format('MM/DD/YYYY hh?:mm:ss pp');
18
19		my ($date,$year, $month, $day, $hour, $min, $sec) = Data::FormValidator::Constraints::Dates::_parse_date_format($format, '12/02/2003 1:01:03 PM');
20		ok ($date eq '12/02/2003 1:01:03 PM','returning untainted date');
21		ok ($year == 2003, 'basic date prepare and parse test');
22		ok ($month == 12);
23		ok ($day == 2);
24		ok ($hour == 13);
25		ok ($min == 1);
26		ok ($sec == 3);
27
28		# Now try again, leaving out PM, which may trigger a warning when it shouldn't
29		$format = Data::FormValidator::Constraints::Dates::_prepare_date_format('MM/DD/YYYY hh?:mm:ss');
30		($date,$year, $month, $day, $hour, $min, $sec) = Data::FormValidator::Constraints::Dates::_parse_date_format($format, '12/02/2003 1:01:03');
31		is($date,'12/02/2003 1:01:03','returning untainted date');
32		ok ($year == 2003, 'basic date prepare and parse test');
33		ok ($month == 12, 'month');
34		ok ($day == 2,'day');
35		ok ($hour == 1,'hour');
36		ok ($min == 1,'min');
37		ok ($sec == 3,'sec');
38
39	4	use Data::FormValidator;
40	5	use Data::FormValidator::Constraints::Dates qw( date_and_time );
41	6
	7	eval { require Date::Calc; };
	8	if ($@)
	9	{
	10	plan skip_all => 'Date::Calc required for date testing';
	11	}
	12	else
	13	{
	14	plan 'no_plan';
	15	}
	16
	17	my $format = Data::FormValidator::Constraints::Dates::_prepare_date_format(
	18	'MM/DD/YYYY hh?:mm:ss pp');
	19
	20	my ( $date, $year, $month, $day, $hour, $min, $sec ) =
	21	Data::FormValidator::Constraints::Dates::_parse_date_format( $format,
	22	'12/02/2003 1:01:03 PM' );
	23	ok( $date eq '12/02/2003 1:01:03 PM', 'returning untainted date' );
	24	ok( $year == 2003, 'basic date prepare and parse test' );
	25	ok( $month == 12 );
	26	ok( $day == 2 );
	27	ok( $hour == 13 );
	28	ok( $min == 1 );
	29	ok( $sec == 3 );
	30
	31	# Now try again, leaving out PM, which may trigger a warning when it shouldn't
	32	$format = Data::FormValidator::Constraints::Dates::_prepare_date_format(
	33	'MM/DD/YYYY hh?:mm:ss');
	34	( $date, $year, $month, $day, $hour, $min, $sec ) =
	35	Data::FormValidator::Constraints::Dates::_parse_date_format( $format,
	36	'12/02/2003 1:01:03' );
	37	is( $date, '12/02/2003 1:01:03', 'returning untainted date' );
	38	ok( $year == 2003, 'basic date prepare and parse test' );
	39	ok( $month == 12, 'month' );
	40	ok( $day == 2, 'day' );
	41	ok( $hour == 1, 'hour' );
	42	ok( $min == 1, 'min' );
	43	ok( $sec == 3, 'sec' );
	44
42	45	my $simple_profile = {
43		required => [qw/date_and_time_field_bad date_and_time_field_good/],
44		validator_packages => [qw/Data::FormValidator::Constraints::Dates/],
45		constraint_methods => {
46		'date_and_time_field_good' => date_and_time('MM/DD/YYYY hh:mm pp'),
47		'date_and_time_field_bad' => date_and_time('MM/DD/YYYY hh:mm pp'),
48		},
49		untaint_constraint_fields=>[qw/date_and_time_field/],
	46	required => [qw/date_and_time_field_bad date_and_time_field_good/],
	47	validator_packages => [qw/Data::FormValidator::Constraints::Dates/],
	48	constraint_methods => {
	49	'date_and_time_field_good' => date_and_time('MM/DD/YYYY hh:mm pp'),
	50	'date_and_time_field_bad' => date_and_time('MM/DD/YYYY hh:mm pp'),
	51	},
	52	untaint_constraint_fields => [qw/date_and_time_field/],
50	53	};
51	54
52	55	my $simple_data = {
53		date_and_time_field_good => '12/04/2003 02:00 PM',
54		date_and_time_field_bad => 'slug',
55		};
	56	date_and_time_field_good => '12/04/2003 02:00 PM',
	57	date_and_time_field_bad => 'slug',
	58	};
56	59
	60	my $validator = new Data::FormValidator( {
	61	simple => $simple_profile,
	62	} );
57	63
58		my $validator = new Data::FormValidator({
59		simple => $simple_profile,
60		});
61
62		my ($valids, $missings, $invalids, $unknowns) = ({},[],{},[]);
63		eval{
64		($valids, $missings, $invalids, $unknowns) = $validator->validate($simple_data, 'simple');
	64	my ( $valids, $missings, $invalids, $unknowns ) = ( {}, [], {}, [] );
	65	eval {
	66	( $valids, $missings, $invalids, $unknowns ) =
	67	$validator->validate( $simple_data, 'simple' );
65	68	};
66		ok ((not $@), 'eval') or
67		diag $@;
68		ok ($valids->{date_and_time_field_good}, 'expecting date_and_time success');
69		ok ((grep /date_and_time_field_bad/, @$invalids), 'expecting date_and_time failure');
	69	ok( ( not $@ ), 'eval' )
	70	or diag $@;
	71	ok( $valids->{date_and_time_field_good}, 'expecting date_and_time success' );
	72	ok( ( grep /date_and_time_field_bad/, @$invalids ),
	73	'expecting date_and_time failure' );
70	74
71	75	{
72		my $r = Data::FormValidator->check({
73		# Testing leap years
74		date_and_time_field_good => '02/29/2008',
75		date_and_time_field_bad_pat => '02/29/2008',
76		leap_seventy_six => '02/29/1976',
77		},
	76	my $r = Data::FormValidator->check( {
	77	# Testing leap years
	78	date_and_time_field_good => '02/29/2008',
	79	date_and_time_field_bad_pat => '02/29/2008',
	80	leap_seventy_six => '02/29/1976',
	81	},
78	82	{
79		required => [qw/date_and_time_field_good date_and_time_field_bad_pat/],
80		constraint_methods => {
81		'date_and_time_field_good' => date_and_time('MM/DD/YY(?:YY)?'),
82		# This pattern actually tests with a 3 digit year, not a four digit year, and fails
83		# on the date 02/29/2008, because 02/29/200 doesn't exist.
84		'date_and_time_field_bad_pat' => date_and_time('MM/DD/YYY?Y?'),
85		'leap_seventy_six' => date_and_time('MM/DD/YY(?:YY)?'),
86		},
87		});
88		my $valid = $r->valid;
89		ok ($valid->{date_and_time_field_good}, '02/29/2008 should pass MM/DD/YY(?:YY)?');
	83	required => [qw/date_and_time_field_good date_and_time_field_bad_pat/],
	84	constraint_methods => {
	85	'date_and_time_field_good' => date_and_time('MM/DD/YY(?:YY)?'),
90	86
91		TODO: {
92		local $TODO = "leap year bug?";
93		ok ($valid->{leap_seventy_six}, '02/29/1976 should pass MM/DD/YY(?:YY)?');
94		};
	87	# This pattern actually tests with a 3 digit year, not a four digit year, and fails
	88	# on the date 02/29/2008, because 02/29/200 doesn't exist.
	89	'date_and_time_field_bad_pat' => date_and_time('MM/DD/YYY?Y?'),
	90	'leap_seventy_six' => date_and_time('MM/DD/YY(?:YY)?'),
	91	},
	92	} );
	93	my $valid = $r->valid;
	94	ok(
	95	$valid->{date_and_time_field_good},
	96	'02/29/2008 should pass MM/DD/YY(?:YY)?'
	97	);
95	98
96		# This one fails not because the date is bad, but because the pattern is not sensible
97		# It would be better to detect that the pattern was bad and fail that way, of course.
98		ok ( $r->invalid('date_and_time_field_bad_pat'), "02/29/2008 should fail MM/DD/YYY?Y?" );
	99	TODO:
	100	{
	101	local $TODO = "leap year bug?";
	102	ok( $valid->{leap_seventy_six}, '02/29/1976 should pass MM/DD/YY(?:YY)?' );
	103	}
99	104
	105	# This one fails not because the date is bad, but because the pattern is not sensible
	106	# It would be better to detect that the pattern was bad and fail that way, of course.
	107	ok(
	108	$r->invalid('date_and_time_field_bad_pat'),
	109	"02/29/2008 should fail MM/DD/YYY?Y?"
	110	);
100	111	}

+44

-50

t/dependency_coderef.t less more

	0	#!/usr/bin/env perl
0	1	use strict;
1
2		$^W = 1;
3
	2	use warnings;
4	3	use Test::More tests => 18;
5	4	use Data::FormValidator;
6	5
7		my %code_results = ( );
8		my $input_hashref = { };
	6	my %code_results = ();
	7	my $input_hashref = {};
9	8	my $input_profile = {
10		dependencies => {
11		cc_type => sub {
12		my $dfv = shift;
13		my $type = shift;
14
15		return [ 'cc_cvv' ] if ($type eq "VISA" \|\| $type eq "MASTERCARD");
16		return [ ];
17		},
	9	dependencies => {
	10	cc_type => sub {
	11	my $dfv = shift;
	12	my $type = shift;
18	13
19		code_checker => sub {
20		my($dfv, $val) = @_;
	14	return ['cc_cvv'] if ( $type eq "VISA" \|\| $type eq "MASTERCARD" );
	15	return [];
	16	},
21	17
22		$code_results{'code_called'} = 1;
23		$code_results{'num_args'} = @_;
24		$code_results{'value'} = $val;
25		$code_results{'dfv_obj'} = $dfv;
	18	code_checker => sub {
	19	my ( $dfv, $val ) = @_;
26	20
27		return [ ];
28		},
	21	$code_results{'code_called'} = 1;
	22	$code_results{'num_args'} = @_;
	23	$code_results{'value'} = $val;
	24	$code_results{'dfv_obj'} = $dfv;
	25
	26	return [];
29	27	},
	28	},
30	29	};
31	30
32		my $validator = Data::FormValidator->new({default => $input_profile});
	31	my $validator = Data::FormValidator->new( { default => $input_profile } );
33	32	my $result;
34
35	33
36	34	##
37	35	## Validate a coderef dependency
38	36	##
39
40	37
41	38	## Check that the code actually gets called.
42	39	#############################################################################
43	40
44	41	$input_hashref->{code_checker} = 'test';
45	42	$result = undef;
46		eval { $result = $validator->check($input_hashref, 'default'); };
	43	eval { $result = $validator->check( $input_hashref, 'default' ); };
47	44
48		ok(!$@, "checking that dependency coderef is called");
49		ok($code_results{code_called}, " code was called");
50		is($code_results{num_args}, 2, " code received 2 args");
51		is($code_results{value}, 'test', " received correct value");
52		ok($code_results{dfv_obj}, " received dfv object");
53		isa_ok($code_results{dfv_obj}, 'Data::FormValidator::Results',
54		" dfv object");
	45	ok( !$@, "checking that dependency coderef is called" );
	46	ok( $code_results{code_called}, " code was called" );
	47	is( $code_results{num_args}, 2, " code received 2 args" );
	48	is( $code_results{value}, 'test', " received correct value" );
	49	ok( $code_results{dfv_obj}, " received dfv object" );
	50	isa_ok( $code_results{dfv_obj}, 'Data::FormValidator::Results',
	51	" dfv object" );
55	52
56	53	delete $input_hashref->{code_checker};
57
58	54
59	55	## Value that should cause a missing dependency.
60	56	#############################################################################
61	57
62	58	$input_hashref->{cc_type} = 'VISA';
63	59	$result = undef;
64		eval { $result = $validator->check($input_hashref, 'default'); };
	60	eval { $result = $validator->check( $input_hashref, 'default' ); };
65	61
66		ok(!$@, "checking a value that has a depenency");
67		isa_ok($result, "Data::FormValidator::Results", " returned object");
68		ok($result->has_missing, " has_missing returned true");
69		ok($result->missing('cc_cvv'), " missing('cc_cvv') returned true");
70
	62	ok( !$@, "checking a value that has a depenency" );
	63	isa_ok( $result, "Data::FormValidator::Results", " returned object" );
	64	ok( $result->has_missing, " has_missing returned true" );
	65	ok( $result->missing('cc_cvv'), " missing('cc_cvv') returned true" );
71	66
72	67	## Value that should NOT cause a missing dependency.
73	68	#############################################################################
74	69
75	70	$input_hashref->{cc_type} = 'AMEX';
76	71	$result = undef;
77		eval { $result = $validator->check($input_hashref, 'default'); };
	72	eval { $result = $validator->check( $input_hashref, 'default' ); };
78	73
79		ok(!$@, "checking a value that has no dependencies");
80		isa_ok($result, "Data::FormValidator::Results", " returned object");
81		ok(!$result->has_missing, " has_missing returned false");
82		is($result->missing('cc_cvv'), undef, " missing('cc_cvv') returned false");
83
	74	ok( !$@, "checking a value that has no dependencies" );
	75	isa_ok( $result, "Data::FormValidator::Results", " returned object" );
	76	ok( !$result->has_missing, " has_missing returned false" );
	77	is( $result->missing('cc_cvv'), undef, " missing('cc_cvv') returned false" );
84	78
85	79	## Test with multiple values
86	80	#############################################################################
87	81
88	82	$input_hashref->{cc_type} = [ 'AMEX', 'VISA' ];
89	83	$result = undef;
90		eval { $result = $validator->check($input_hashref, 'default'); };
	84	eval { $result = $validator->check( $input_hashref, 'default' ); };
91	85
92		ok(!$@, "checking multiple values");
93		isa_ok($result, "Data::FormValidator::Results", " returned object");
94		ok($result->has_missing, " has_missing returned true");
95		is($result->missing('cc_cvv'), 1, " missing('cc_cvv') returned true");
	86	ok( !$@, "checking multiple values" );
	87	isa_ok( $result, "Data::FormValidator::Results", " returned object" );
	88	ok( $result->has_missing, " has_missing returned true" );
	89	is( $result->missing('cc_cvv'), 1, " missing('cc_cvv') returned true" );

+41

-42

t/dependency_groups.t less more

	0	#!/usr/bin/env perl
0	1	use strict;
	2	use warnings;
	3	use Test::More;
	4	use Data::FormValidator;
1	5
2		$^W = 1;
3
4		use Test::More 'no_plan'; #tests => 23;
5		use Data::FormValidator;
6		use CGI;
7
	6	eval { require CGI;CGI->VERSION(4.35); };
	7	plan skip_all => 'CGI 4.35 or higher not found' if $@;
8	8
9	9	# test profile
10	10	my $input_profile = {
11		dependency_groups => {
12		password => [qw/pass1 pass2/],
13		},
	11	dependency_groups => {
	12	password => [qw/pass1 pass2/],
	13	},
14	14	};
15		my $input_hashref = {pass1=>'foo'};
	15	my $input_hashref = { pass1 => 'foo' };
16	16
17		my ($valids, $missings, $invalids, $unknowns);
	17	my ( $valids, $missings, $invalids, $unknowns );
18	18	my $result;
19	19	my @fields = (qw/pass1 pass2/);
20		my $validator = Data::FormValidator->new({default => $input_profile});
	20	my $validator = Data::FormValidator->new( { default => $input_profile } );
21	21
	22	foreach my $fields ( [qw/pass1 pass2/], [qw/pass2 pass1/] )
	23	{
	24	my ( $good, $bad ) = @$fields;
	25	$input_hashref = { $good => 'foo' };
22	26
	27	##
	28	## validate()
23	29
24		foreach my $fields ([qw/pass1 pass2/], [qw/pass2 pass1/]) {
25		my ($good, $bad) = @$fields;
26		$input_hashref = {$good => 'foo'};
	30	eval {
	31	( $valids, $missings, $invalids, $unknowns ) =
	32	$validator->validate( $input_hashref, 'default' );
	33	};
	34	ok( !$@, "no eval problems" );
27	35
28		##
29		## validate()
	36	my %missings = map { $_ => 1 } @$missings;
	37	is( $valids->{$good}, $input_hashref->{$good}, "[$good] valid" );
	38	ok( $missings{$bad}, "missing [$bad]" );
30	39
31		eval{
32		($valids, $missings, $invalids, $unknowns) = $validator->validate($input_hashref, 'default');
33		};
34		ok(!$@, "no eval problems");
	40	##
	41	## check()
35	42
36		my %missings = map {$_ => 1} @$missings;
37		is($valids->{$good}, $input_hashref->{$good}, "[$good] valid");
38		ok($missings{$bad}, "missing [$bad]");
	43	my $q = CGI->new("$good=foo");
	44	foreach my $input ( $input_hashref, $q )
	45	{
	46	eval { $result = $validator->check( $input, 'default' ); };
39	47
	48	ok( !$@, "no eval problems" );
	49	isa_ok( $result, "Data::FormValidator::Results", "returned object" );
40	50
41		##
42		## check()
43
44		my $q = CGI->new("$good=foo");
45		foreach my $input ($input_hashref, $q) {
46		eval {
47		$result = $validator->check($input, 'default');
48		};
49
50		ok(!$@, "no eval problems");
51		isa_ok($result, "Data::FormValidator::Results", "returned object");
52
53		ok($result->has_missing, "has_missing returned true");
54		ok($result->missing($bad), "missing($bad) returned true");
55		ok(!$result->missing($good), "missing($good) returned false");
56		ok($result->valid($good), "valid($good) returned true");
57		ok(!$result->valid($bad), "valid($bad) returned true");
58		}
	51	ok( $result->has_missing, "has_missing returned true" );
	52	ok( $result->missing($bad), "missing($bad) returned true" );
	53	ok( !$result->missing($good), "missing($good) returned false" );
	54	ok( $result->valid($good), "valid($good) returned true" );
	55	ok( !$result->valid($bad), "valid($bad) returned true" );
	56	}
59	57	}
	58	done_testing;

+113

-104

t/filter_constraints.t less more

	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
	3	use lib ( '.', '../t' );
	4	use Test::More tests => 4;
	5	use Data::FormValidator;
	6
0	7	# This test is a for a bug where a value doesn't get filtered when it should
1		# The bug was discovered by Jeff Till, and he contributed this test, too.
	8	# The bug was discovered by Jeff Till, and he contributed this test, too.
	9	# Verify that multiple params passed to a constraint are being filtered
	10	my $validator = new Data::FormValidator( {
	11	default => {
	12	filters => ['trim'],
	13	required => [qw/my_junk_field my_other_field/],
	14	constraints => {
	15	my_junk_field => {
	16	constraint => \&letters_2_var,
	17	name => 'zipcode',
2	18
3		use strict;
4		use Test::More tests => 4;
5		use lib ('.','../t');
6
7		# Verify that multiple params passed to a constraint are being filtered
	19	},
	20	my_other_field => \&letters,
	21	},
	22	},
	23	} );
8	24
9		$^W = 1;
10
11
12		use Data::FormValidator;
13
14		my $validator = new Data::FormValidator({
15		default =>
16		{
17		filters => [ 'trim' ],
18		required => [ qw/my_junk_field my_other_field/],
19		constraints => {
20		my_junk_field => {
21		constraint => \&letters_2_var,
22		name => 'zipcode',
23
24		},
25		my_other_field => \&letters,
26		},
27		},
28		});
29
30		sub letters_2_var {
31		if ($_[0] =~ /^[a-z]+$/i) {
32		return 1;
33		}
34		return 0;
35		}
36
37		sub letters{
38		if($_[0] =~ /^[a-z]+$/i){
	25	sub letters_2_var
	26	{
	27	if ( $_[0] =~ /^[a-z]+$/i )
	28	{
39	29	return 1;
40	30	}
41	31	return 0;
42	32	}
43	33
44		my $input_hashref =
	34	sub letters
	35	{
	36	if ( $_[0] =~ /^[a-z]+$/i )
45	37	{
46		my_junk_field => 'foo ',
47		my_other_field => ' bar',
48		};
49
50		my ($valids, $missings, $invalids, $unknowns) =
51		$validator->validate($input_hashref, 'default');
52
53		is_deeply($invalids, [], "all fields are valid");
54
55		{ # RT#13078
56		my $res;
57		eval {
58		$res = Data::FormValidator->check({
59		local_filter => ' needs@trimmed.com ',
60		global_filter_field => ' needs@trimmed.com ',
61		},
62		{
63		required => [ 'local_filter', 'global_filter_field' ],
64		filters => [ sub { my $v = shift; $v =~ s/needs/global/g; $v }, ],
65		field_filters => {
66		local_filter => 'trim',
67		},
68		constraints => {
69		local_filter => [
70		'email',
71		{
72		constraint => sub {
73		my $val = shift;
74		return ($val eq 'global@trimmed.com');
75		},
76		params => ['local_filter'],
77		}
78		],
79		global_filter_field => [
80		sub {
81		my $val = shift;
82		if ($val eq ' global@trimmed.com ') {
83		return 1;
84		}
85		else {
86		warn "without param got: '$val', expected 'global\@trimmed.com'";
87		return undef;
88		}
89		},
90		{
91		constraint => sub {
92		my $val = shift;
93		if ($val eq ' global@trimmed.com ') {
94		return 1;
95		}
96		else {
97		warn " using param got: '$val', expected 'global\@trimmed.com'";
98		return undef;
99		}
100		},
101		params => ['global_filter_field'],
102		},
103		]
104		},
105		});
106		};
107		is($@,'', 'survived eval');
108
109		eval { ok($res->valid('local_filter')," when passed through param, local filters are applied."); };
110		eval { ok($res->valid('global_filter_field')," when passed through param, global filters are applied."); };
111
112
	38	return 1;
	39	}
	40	return 0;
113	41	}
114	42
	43	my $input_hashref = {
	44	my_junk_field => 'foo ',
	45	my_other_field => ' bar',
	46	};
	47
	48	my ( $valids, $missings, $invalids, $unknowns ) =
	49	$validator->validate( $input_hashref, 'default' );
	50
	51	is_deeply( $invalids, [], "all fields are valid" );
	52
	53	{ # RT#13078
	54	my $res;
	55	eval {
	56	$res = Data::FormValidator->check( {
	57	local_filter => ' needs@trimmed.com ',
	58	global_filter_field => ' needs@trimmed.com ',
	59	},
	60	{
	61	required => [ 'local_filter', 'global_filter_field' ],
	62	filters => [ sub { my $v = shift; $v =~ s/needs/global/g; $v }, ],
	63	field_filters => {
	64	local_filter => 'trim',
	65	},
	66	constraints => {
	67	local_filter => [
	68	'email',
	69	{
	70	constraint => sub {
	71	my $val = shift;
	72	return ( $val eq 'global@trimmed.com' );
	73	},
	74	params => ['local_filter'],
	75	}
	76	],
	77	global_filter_field => [
	78	sub {
	79	my $val = shift;
	80	if ( $val eq ' global@trimmed.com ' )
	81	{
	82	return 1;
	83	}
	84	else
	85	{
	86	warn
	87	"without param got: '$val', expected 'global\@trimmed.com'";
	88	return undef;
	89	}
	90	},
	91	{
	92	constraint => sub {
	93	my $val = shift;
	94	if ( $val eq ' global@trimmed.com ' )
	95	{
	96	return 1;
	97	}
	98	else
	99	{
	100	warn
	101	" using param got: '$val', expected 'global\@trimmed.com'";
	102	return undef;
	103	}
	104	},
	105	params => ['global_filter_field'],
	106	},
	107	]
	108	},
	109	} );
	110	};
	111	is( $@, '', 'survived eval' );
	112
	113	eval
	114	{
	115	ok( $res->valid('local_filter'),
	116	" when passed through param, local filters are applied." );
	117	};
	118	eval
	119	{
	120	ok( $res->valid('global_filter_field'),
	121	" when passed through param, global filters are applied." );
	122	};
	123	}

+33

-39

t/filters_builtin.t less more

	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
0	3	use Test::More 'no_plan';
1	4	use Data::FormValidator::Filters (qw/:filters/);
2		use strict;
3	5
4		{
5		my $comma_splitter = FV_split(',');
6		is_deeply( $comma_splitter->('a,b'), [qw/a b/], "FV_split with two values");
7		is_deeply( $comma_splitter->('a'), [qw/a/], "FV_split with one value");
8		is_deeply( $comma_splitter->(),undef, "FV_split with no values");
	6	{
	7	my $comma_splitter = FV_split(',');
	8	is_deeply( $comma_splitter->('a,b'), [qw/a b/], "FV_split with two values" );
	9	is_deeply( $comma_splitter->('a'), [qw/a/], "FV_split with one value" );
	10	is_deeply( $comma_splitter->(), undef, "FV_split with no values" );
9	11	}
10	12
11	13	{
12		my $replacer = FV_replace(qr/^a/,'b');
13		is( $replacer->('aa'), 'ba', 'FV_replace positive test');
14		is( $replacer->('XX'), 'XX', 'FV_replace negative test');
	14	my $replacer = FV_replace( qr/^a/, 'b' );
	15	is( $replacer->('aa'), 'ba', 'FV_replace positive test' );
	16	is( $replacer->('XX'), 'XX', 'FV_replace negative test' );
15	17
16		my $replacer = FV_replace(qr/^a/i,'b');
17		is( $replacer->('AA'), 'bA', 'FV_replace positive test');
	18	$replacer = FV_replace( qr/^a/i, 'b' );
	19	is( $replacer->('AA'), 'bA', 'FV_replace positive test' );
18	20	}
19	21
	22	is( filter_dollars('There is $0.11e money in here somewhere'),
	23	'0.11', "filter_dollars works as expected" );
20	24
	25	TODO:
	26	{
	27	local $TODO = 'all these broken filters need to be dealt with.';
	28	is( filter_dollars('0.111'), '0.11',
	29	"filter_dollars removes trailing numbers" );
21	30
22		is( filter_dollars('There is $0.11e money in here somewhere'),
23		'0.11',
24		"filter_dollars works as expected");
	31	is( filter_neg_integer('9-'), 'a9-',
	32	"filter_neg_integer should leave string without a negative integer alone."
	33	);
25	34
26		TODO: {
27		local $TODO = 'all these broken filters need to be dealt with.';
28		is( filter_dollars('0.111'),
29		'0.11',
30		"filter_dollars removes trailing numbers");
	35	is( filter_pos_integer('a9+'),
	36	'9', "filter_pos_integer should care which side a + is on." );
31	37
32		is( filter_neg_integer('9-'),
33		'a9-',
34		"filter_neg_integer should leave string without a negative integer alone.");
	38	is( filter_integer('a9+'), '9',
	39	"filter_integer should care which side a + is on." );
35	40
36		is( filter_pos_integer('a9+'),
37		'9',
38		"filter_pos_integer should care which side a + is on.");
	41	is( filter_decimal('1,000.23'),
	42	'1000.23', "filter_decimal should handle commas correctly" );
39	43
40		is( filter_integer('a9+'),
41		'9',
42		"filter_integer should care which side a + is on.");
	44	is( filter_pos_decimal('1,000.23'),
	45	'1000.23', "filter_pos_decimal should handle commas correctly" );
43	46
44		is( filter_decimal('1,000.23'),
45		'1000.23',
46		"filter_decimal should handle commas correctly");
47
48		is( filter_pos_decimal('1,000.23'),
49		'1000.23',
50		"filter_pos_decimal should handle commas correctly");
51
52		is( filter_neg_decimal('-1,000.23'),
53		'-1000.23',
54		"filter_neg_decimal should handle commas correctly");
	47	is( filter_neg_decimal('-1,000.23'),
	48	'-1000.23', "filter_neg_decimal should handle commas correctly" );
55	49	}

+13

-14

t/filters_shouldnt_modify.t less more

	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
0	3	use Test::More qw/no_plan/;
1	4	use Data::FormValidator;
2	5

4	7
5	8	# Testing an internal function here, so it's OK if this test starts
6	9	# to fail because the API changes
7		my %out = Data::FormValidator::Results::_get_input_as_hash({},\%h);
	10	my %out = Data::FormValidator::Results::_get_input_as_hash( {}, \%h );
8	11
9		isnt($h{key},$out{key},"after copying structure, values should have different memory addresses");
10
	12	isnt( $h{key}, $out{key},
	13	"after copying structure, values should have different memory addresses" );
11	14
12	15	{
13		Data::FormValidator->check(
14		\%h,
15		{ required => [ 'key' ],
16		filters => [ 'trim' ],
17		});
	16	Data::FormValidator->check(
	17	\%h,
	18	{
	19	required => ['key'],
	20	filters => ['trim'],
	21	} );
18	22
19		is($h{key}[0], ' value1 ', "filters shouldn't modify data in arrayrefs");
	23	is( $h{key}[0], ' value1 ', "filters shouldn't modify data in arrayrefs" );
20	24	}
21
22
23
24
25

+41

-35

t/get_filtered_data.t less more

	0	#!/usr/bin/env perl
0	1	use strict;
	2	use warnings;
1	3	use Test::More tests => 4;
2	4	use Data::FormValidator;
3	5	use Data::FormValidator::Constraints qw(FV_eq_with);
4	6
5	7	# Empty data/empty results; make sure fcn call works fine
6		access_filtered_data_no_data: {
7		my $results = Data::FormValidator->check( {}, {} );
8		my $filtered = $results->get_filtered_data();
9		is_deeply( $filtered, {}, 'get_filtered_data works for empty hashref' );
	8	access_filtered_data_no_data:
	9	{
	10	my $results = Data::FormValidator->check( {}, {} );
	11	my $filtered = $results->get_filtered_data();
	12	is_deeply( $filtered, {}, 'get_filtered_data works for empty hashref' );
10	13	}
11	14
12	15	# Test to make sure that we can access filtered data and that it looks right.
13		access_filtered_data: {
14		my $data = {
15		'password' => ' foo ',
16		'confirm' => ' foo ',
17		};
18		my $expect_filtered_data = {
19		'password' => 'foo',
20		'confirm' => 'foo',
21		};
22		my $profile = {
23		'required' => [qw( password confirm )],
24		'filters' => 'trim',
25		};
26		my $results = Data::FormValidator->check( $data, $profile );
27		my $filtered = $results->get_filtered_data();
28		is_deeply( $filtered, $expect_filtered_data, 'get_filtered_data returns correct filtered data' );
	16	access_filtered_data:
	17	{
	18	my $data = {
	19	'password' => ' foo ',
	20	'confirm' => ' foo ',
	21	};
	22	my $expect_filtered_data = {
	23	'password' => 'foo',
	24	'confirm' => 'foo',
	25	};
	26	my $profile = {
	27	'required' => [qw( password confirm )],
	28	'filters' => 'trim',
	29	};
	30	my $results = Data::FormValidator->check( $data, $profile );
	31	my $filtered = $results->get_filtered_data();
	32	is_deeply( $filtered, $expect_filtered_data,
	33	'get_filtered_data returns correct filtered data' );
29	34	}
30	35
31	36	# RT#22589; FV_eq_with uses 'get_filtered_data()'
32		rt22589: {
33		my $data = {
34		'password' => ' foo ',
35		'confirm' => ' foo ',
36		};
37		my $profile = {
38		'required' => [qw( password confirm )],
39		'filters' => 'trim',
40		'constraint_methods' => {
41		'confirm' => FV_eq_with('password'),
42		},
43		};
44		my $results = Data::FormValidator->check( $data, $profile );
45		ok( $results->valid('password'), 'password valid' );
46		ok( $results->valid('confirm'), 'confirm valid' );
	37	rt22589:
	38	{
	39	my $data = {
	40	'password' => ' foo ',
	41	'confirm' => ' foo ',
	42	};
	43	my $profile = {
	44	'required' => [qw( password confirm )],
	45	'filters' => 'trim',
	46	'constraint_methods' => {
	47	'confirm' => FV_eq_with('password'),
	48	},
	49	};
	50	my $results = Data::FormValidator->check( $data, $profile );
	51	ok( $results->valid('password'), 'password valid' );
	52	ok( $results->valid('confirm'), 'confirm valid' );
47	53	}

+21

-13

t/get_input_data.t less more

0		use Test::More qw/no_plan/;
1
	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
	3	use Test::More;
2	4	use Data::FormValidator;
3	5
	6	eval { require CGI;CGI->VERSION(4.35); };
	7	plan skip_all => 'CGI 4.35 or higher not found' if $@;
	8
4	9	{
5		my $results = Data::FormValidator->check({},{});
6		is_deeply($results->get_input_data, {}, 'get_input_data works for empty hashref' );
	10	my $results = Data::FormValidator->check( {}, {} );
	11	is_deeply( $results->get_input_data, {},
	12	'get_input_data works for empty hashref' );
7	13	}
8	14
9		use CGI;
10		my $q = CGI->new( { key => 'value' });
11		my $results = Data::FormValidator->check($q,{});
	15	my $q = CGI->new( { key => 'value' } );
	16	my $results = Data::FormValidator->check( $q, {} );
12	17
13		is_deeply($results->get_input_data, $q, 'get_input_data works for CGI object' );
	18	is_deeply( $results->get_input_data, $q,
	19	'get_input_data works for CGI object' );
14	20
15	21	{
16		my $href = $results->get_input_data(as_hashref => 1);
17		is_deeply($href , { key => 'value' }, 'get_input_data( as_hashref => 1 ) works for CGI object' );
	22	my $href = $results->get_input_data( as_hashref => 1 );
	23	is_deeply(
	24	$href,
	25	{ key => 'value' },
	26	'get_input_data( as_hashref => 1 ) works for CGI object'
	27	);
18	28	}
19
20
21
	29	done_testing;

+72

-71

t/missing_optional.t less more

0		# Tests for missing_optional_valid
	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
1	3	use Test::More 'no_plan';
2		use strict;
3
4		$^W = 1;
5
6	4	use Data::FormValidator;
7	5
	6	# Tests for missing_optional_valid
8	7	my $input_profile = {
9		required => [ qw( email_1 email_ok) ],
10		optional => ['filled','not_filled'],
11		constraint_regexp_map => {
12		'/^email/' => "email",
13		},
14		constraints => {
15		not_filled => 'phone',
16		},
17		missing_optional_valid => 1,
18		};
	8	required => [qw( email_1 email_ok)],
	9	optional => [ 'filled', 'not_filled' ],
	10	constraint_regexp_map => {
	11	'/^email/' => "email",
	12	},
	13	constraints => {
	14	not_filled => 'phone',
	15	},
	16	missing_optional_valid => 1,
	17	};
19	18
20		my $validator = new Data::FormValidator({default => $input_profile});
	19	my $validator = new Data::FormValidator( { default => $input_profile } );
21	20
22	21	my $input_hashref = {
23		email_1 => 'invalidemail',
24		email_ok => 'mark@stosberg.com',
25		filled => 'dog',
26		not_filled => '',
27		should_be_unknown => 1,
	22	email_1 => 'invalidemail',
	23	email_ok => 'mark@stosberg.com',
	24	filled => 'dog',
	25	not_filled => '',
	26	should_be_unknown => 1,
28	27	};
29	28
30		my ($valids, $missings, $invalids, $unknowns);
	29	my ( $valids, $missings, $invalids, $unknowns );
31	30
32		eval{
33		($valids, $missings, $invalids, $unknowns) = $validator->validate($input_hashref, 'default');
	31	eval {
	32	( $valids, $missings, $invalids, $unknowns ) =
	33	$validator->validate( $input_hashref, 'default' );
34	34	};
35		is($@,'',"survived eval");
	35	is( $@, '', "survived eval" );
36	36
37		# "not_filled" should appear valids now.
38		ok (exists $valids->{'not_filled'});
39
	37	# "not_filled" should appear valids now.
	38	ok( exists $valids->{'not_filled'} );
40	39
41	40	# "should_be_unknown" should be still be unknown
42		ok($unknowns->[0] eq 'should_be_unknown');
	41	ok( $unknowns->[0] eq 'should_be_unknown' );
43	42
44		eval {
45		require CGI;
46		};
47		SKIP: {
48		skip 'CGI.pm not found', 3 if $@;
	43	eval { require CGI;CGI->VERSION(4.35); };
	44	SKIP:
	45	{
	46	skip 'CGI 4.35 or higher not found', 3 if $@;
49	47
50		my $q = CGI->new($input_hashref);
51		my ($valids, $missings, $invalids, $unknowns);
52		eval{
53		($valids, $missings, $invalids, $unknowns) = $validator->validate($q, 'default');
54		};
	48	my $q = CGI->new($input_hashref);
	49	my ( $valids, $missings, $invalids, $unknowns );
	50	eval {
	51	( $valids, $missings, $invalids, $unknowns ) =
	52	$validator->validate( $q, 'default' );
	53	};
55	54
56		ok (not $@);
	55	ok( not $@ );
57	56
58		# "not_filled" should appear valids now.
59		ok (exists $valids->{'not_filled'});
	57	# "not_filled" should appear valids now.
	58	ok( exists $valids->{'not_filled'} );
60	59
61		# "should_be_unknown" should be still be unknown
62		ok($unknowns->[0] eq 'should_be_unknown');
	60	# "should_be_unknown" should be still be unknown
	61	ok( $unknowns->[0] eq 'should_be_unknown' );
63	62
64		};
65
66		{
67		my $res = Data::FormValidator->check(
68		{ a => 1,
69		b => undef,
70		# c is completely missing
71		},
72		{ optional => [ qw/a b c/ ],
73		missing_optional_valid => 1 } );
74
75		is(join(',',sort $res->valid()),'a,b', "optional fields have to at least exist to be valid" );
76	63	}
77	64
78	65	{
79		my $data = {
80		optional_invalid => 'invalid'
81		};
	66	my $res = Data::FormValidator->check( {
	67	a => 1,
	68	b => undef,
82	69
83		my $profile = {
84		optional => [qw/optional_invalid/],
85		constraints => {
86		optional_invalid => qr/^valid$/
87		},
88		missing_optional_valid => 1
89		};
	70	# c is completely missing
	71	},
	72	{
	73	optional => [qw/a b c/],
	74	missing_optional_valid => 1
	75	} );
90	76
91		my $results = Data::FormValidator->check($data, $profile);
92		my $valid = $results->valid();
93		my $invalid = $results->invalid();
94		ok( exists $invalid->{'optional_invalid'}, 'optional_invalid is invalid');
95		ok( !exists $valid->{'optional_invalid'}, 'optional_invalid is not valid');
	77	is( join( ',', sort $res->valid() ),
	78	'a,b', "optional fields have to at least exist to be valid" );
96	79	}
	80
	81	{
	82	my $data = { optional_invalid => 'invalid' };
	83
	84	my $profile = {
	85	optional => [qw/optional_invalid/],
	86	constraints => {
	87	optional_invalid => qr/^valid$/
	88	},
	89	missing_optional_valid => 1
	90	};
	91
	92	my $results = Data::FormValidator->check( $data, $profile );
	93	my $valid = $results->valid();
	94	my $invalid = $results->invalid();
	95	ok( exists $invalid->{'optional_invalid'}, 'optional_invalid is invalid' );
	96	ok( !exists $valid->{'optional_invalid'}, 'optional_invalid is not valid' );
	97	}

+188

-195

t/msgs.t less more

	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
0	3	use Test::More qw/no_plan/;
1		use strict;
2
3	4	use Data::FormValidator;
4	5
5	6	my $simple_profile = {
6		required => [qw/req_1 req_2/],
7		optional => [qw/opt_1/],
8		constraints => {
9		req_1 => 'email'
10		},
11		msgs=>{},
	7	required => [qw/req_1 req_2/],
	8	optional => [qw/opt_1/],
	9	constraints => {
	10	req_1 => 'email'
	11	},
	12	msgs => {},
12	13	};
13	14
14		my $simple_data = {
15		req_1 => 'not_an_email',
16		};
	15	my $simple_data = { req_1 => 'not_an_email', };
17	16
18	17	my $prefix_profile = {
19		required => [qw/req_1 req_2/],
20		optional => [qw/opt_1/],
21		constraints => {
22		req_1 => 'email'
23		},
24		msgs=>{
25		prefix=>'',
26		any_errors=>'err__',
27		},
	18	required => [qw/req_1 req_2/],
	19	optional => [qw/opt_1/],
	20	constraints => {
	21	req_1 => 'email'
	22	},
	23	msgs => {
	24	prefix => '',
	25	any_errors => 'err__',
	26	},
28	27	};
29	28
30	29	my $input_profile = {
31		required => [ qw(admin prefork sleep rounds) ],
32		constraints => {
33		admin => "email",
34		prefork => sub {
35		my $val = shift;
36		if ($val =~ /^\d$/) {
37		if ($val > 1 and $val <9) {
38		return $val;
39		}
40		}
41		return 0;
42		},
43		sleep => [
44		'email',
45		{
46		name => 'min',
47		constraint => sub {
48		my $val = shift;
49		if ($val > 0) {
50		return $val;
51		} else {
52		return 0;
53		}
54		}
55		},
56		{
57		name => 'max',
58		constraint => sub {
59		my $val = shift;
60		if ($val < 11) {
61		return $val;
62		} else {
63		return 0;
64		}
65		}
66		}
67		],
68		rounds => [
69		{
70		name => 'min',
71		constraint => sub {
72		my $val = shift;
73		if ($val > 19) {
74		return $val;
75		} else {
76		return 0;
77		}
78		}
79		},
80		{
81		name => 'max',
82		constraint => sub {
83		my $val = shift;
84		if ($val < 101) {
85		return $val;
86		} else {
87		return 0;
88		}
89		}
90		}
91		]
92		},
93		msgs => {
94		missing => 'Test-Missing',
95		invalid => 'Test-Invalid',
96		invalid_seperator=> ' ## ',
97
98		constraints => {
99		max => 'needs to be lesser than 11',
100		min => 'needs to be greater than 0'
101		},
102		format => 'ERROR: %s',
103		prefix => 'error_',
104		}
105		};
106
107		my $validator = new Data::FormValidator({
108		simple => $simple_profile,
109		default => $input_profile,
110		prefix => $prefix_profile,
111		});
112
113		my $input_hashref = {admin=> 'invalidemail', prefork=> 9, sleep => 11, rounds=>8};
	30	required => [qw(admin prefork sleep rounds)],
	31	constraints => {
	32	admin => "email",
	33	prefork => sub {
	34	my $val = shift;
	35	if ( $val =~ /^\d$/ )
	36	{
	37	if ( $val > 1 and $val < 9 )
	38	{
	39	return $val;
	40	}
	41	}
	42	return 0;
	43	},
	44	sleep => [
	45	'email',
	46	{
	47	name => 'min',
	48	constraint => sub {
	49	my $val = shift;
	50	if ( $val > 0 )
	51	{
	52	return $val;
	53	}
	54	else
	55	{
	56	return 0;
	57	}
	58	}
	59	},
	60	{
	61	name => 'max',
	62	constraint => sub {
	63	my $val = shift;
	64	if ( $val < 11 )
	65	{
	66	return $val;
	67	}
	68	else
	69	{
	70	return 0;
	71	}
	72	}
	73	}
	74	],
	75	rounds => [ {
	76	name => 'min',
	77	constraint => sub {
	78	my $val = shift;
	79	if ( $val > 19 )
	80	{
	81	return $val;
	82	}
	83	else
	84	{
	85	return 0;
	86	}
	87	}
	88	},
	89	{
	90	name => 'max',
	91	constraint => sub {
	92	my $val = shift;
	93	if ( $val < 101 )
	94	{
	95	return $val;
	96	}
	97	else
	98	{
	99	return 0;
	100	}
	101	}
	102	} ]
	103	},
	104	msgs => {
	105	missing => 'Test-Missing',
	106	invalid => 'Test-Invalid',
	107	invalid_seperator => ' ## ',
	108
	109	constraints => {
	110	max => 'needs to be lesser than 11',
	111	min => 'needs to be greater than 0'
	112	},
	113	format => 'ERROR: %s',
	114	prefix => 'error_',
	115	} };
	116
	117	my $validator = new Data::FormValidator( {
	118	simple => $simple_profile,
	119	default => $input_profile,
	120	prefix => $prefix_profile,
	121	} );
	122
	123	my $input_hashref =
	124	{ admin => 'invalidemail', prefork => 9, sleep => 11, rounds => 8 };
114	125
115	126	my $results;
116		eval{
117		$results = $validator->check($simple_data, 'simple');
118		};
119		ok (not $@);
120
121		TODO: {
122		local $TODO= 'need to test for msgs() called before validate';
123		# msgs() should return emit a warning and return undef if the hash
124		# structure it points to is undefined. However, if it points to an
125		# empty hash, then maybe there are just no messages.
126		};
	127	eval { $results = $validator->check( $simple_data, 'simple' ); };
	128	ok( not $@ );
	129
	130	TODO:
	131	{
	132	local $TODO = 'need to test for msgs() called before validate';
	133
	134	# msgs() should return emit a warning and return undef if the hash
	135	# structure it points to is undefined. However, if it points to an
	136	# empty hash, then maybe there are just no messages.
	137	}
127	138
128	139	# testing simple msg definition, $self->msgs should be returned as a hash ref
129	140	my $msgs;
130		eval {
131		$msgs = $results->msgs;
132		};
133		ok((not $@), 'existence of msgs method' ) or
134		diag $@;
135
136
137		ok (ref $msgs eq 'HASH', 'invalid fields returned as hash in simple case');
138
139
140		like ($msgs->{req_1}, qr/Invalid/, 'default invalid message');
141		like ($msgs->{req_2}, qr/Missing/, 'default missing message');
142		like ($msgs->{req_1}, qr/span/, 'default formatting');
143
	141	eval { $msgs = $results->msgs; };
	142	ok( ( not $@ ), 'existence of msgs method' )
	143	or diag $@;
	144
	145	ok( ref $msgs eq 'HASH', 'invalid fields returned as hash in simple case' );
	146
	147	like( $msgs->{req_1}, qr/Invalid/, 'default invalid message' );
	148	like( $msgs->{req_2}, qr/Missing/, 'default missing message' );
	149	like( $msgs->{req_1}, qr/span/, 'default formatting' );
144	150
145	151	# testing single constraints and single error case
146		eval{
147		$results = $validator->check($input_hashref, 'default');
148		};
149		is($@,'', 'survived eval');
	152	eval { $results = $validator->check( $input_hashref, 'default' ); };
	153	is( $@, '', 'survived eval' );
150	154	$msgs = $results->msgs;
151	155
152		like($msgs->{error_sleep} ,qr/lesser.Test\|Test.lesser/, 'multiple constraints constraint definition');
153
154		eval{
155		$results = $validator->check($simple_data, 'prefix');
156		};
157		is($@,'','survived eval');
158
159		$msgs = $results->msgs({format => 'Control-Test: %s'});
160
161		ok(defined $msgs->{req_1}, 'using default prefix');
162		is(keys %$msgs, 3, 'size of msgs hash'); # 2 errors plus 1 prefix
163		ok(defined $msgs->{err__}, 'any_errors');
164		like($msgs->{req_1},qr/Control/,'passing controls to method');
	156	like( $msgs->{error_sleep}, qr/lesser.Test\|Test.lesser/,
	157	'multiple constraints constraint definition' );
	158
	159	eval { $results = $validator->check( $simple_data, 'prefix' ); };
	160	is( $@, '', 'survived eval' );
	161
	162	$msgs = $results->msgs( { format => 'Control-Test: %s' } );
	163
	164	ok( defined $msgs->{req_1}, 'using default prefix' );
	165	is( keys %$msgs, 3, 'size of msgs hash' ); # 2 errors plus 1 prefix
	166	ok( defined $msgs->{err__}, 'any_errors' );
	167	like( $msgs->{req_1}, qr/Control/, 'passing controls to method' );
165	168
166	169	# See what happens when msgs is called with it does not appeare in the profile
167		my @basic_input = (
168		{
169		field_1 => 'email',
170		},
171		{
172		required => 'field_1',
173
174		});
	170	my @basic_input = ( {
	171	field_1 => 'email',
	172	},
	173	{
	174	required => 'field_1',
	175
	176	} );
175	177	$results = Data::FormValidator->check(@basic_input);
176	178	eval { $results->msgs };
177		ok ((not $@), 'calling msgs method without hash definition');
	179	ok( ( not $@ ), 'calling msgs method without hash definition' );
178	180
179	181	###
180		{
181		my $test_name = 'Spelling "separator" correctly should work OK.';
182		my $results = Data::FormValidator->check(
183		{
184		field => 'value',
185		},
186		{
187		required => [qw/field/],
188		constraints => {
189		field => ['email','province'],
190		},
191		msgs => {
192		invalid_separator=> ' ## ',
193		},
194		}
195		);
196
197		my $msgs = $results->msgs;
198		like($msgs->{field},qr/##/,$test_name);
	182	{
	183	my $test_name = 'Spelling "separator" correctly should work OK.';
	184	my $results = Data::FormValidator->check( {
	185	field => 'value',
	186	},
	187	{
	188	required => [qw/field/],
	189	constraints => {
	190	field => [ 'email', 'province' ],
	191	},
	192	msgs => {
	193	invalid_separator => ' ## ',
	194	},
	195	} );
	196
	197	my $msgs = $results->msgs;
	198	like( $msgs->{field}, qr/##/, $test_name );
199	199	}
200	200
201		###
	201	###
202	202	{
203		my $test_name = 'A callback can be used for msgs';
204		my $results = Data::FormValidator->check(
205		{
206		field => 'value',
207		},
208		{
209		required => [qw/field/],
210		constraints => {
211		field => ['email','province'],
212		},
213		msgs => sub { { field => 'callback!' } },
214		}
215		);
216
217		my $msgs = $results->msgs;
218		like($msgs->{field},qr/callback/,$test_name);
	203	my $test_name = 'A callback can be used for msgs';
	204	my $results = Data::FormValidator->check( {
	205	field => 'value',
	206	},
	207	{
	208	required => [qw/field/],
	209	constraints => {
	210	field => [ 'email', 'province' ],
	211	},
	212	msgs => sub { { field => 'callback!' } },
	213	} );
	214
	215	my $msgs = $results->msgs;
	216	like( $msgs->{field}, qr/callback/, $test_name );
219	217
220	218	}
221
222
223
224
225

+54

-48

t/multiple_constraints.t less more

0
	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
1	3	use Data::FormValidator;
2	4	use Test::More tests => 8;
3		use strict;
4		use lib ('.','../t');
	5	use lib ( '.', '../t' );
5	6
6	7	my $input_profile = {
7		required => ['my_zipcode_field'],
8		constraints => {
9		my_zipcode_field => [
10		'zip',
11		{
12		constraint => '/^406/',
13		name => 'starts_with_406',
14		}
15		],
16		},
	8	required => ['my_zipcode_field'],
	9	constraints => {
	10	my_zipcode_field => [
	11	'zip',
	12	{
	13	constraint => '/^406/',
	14	name => 'starts_with_406',
	15	}
	16	],
	17	},
17	18	};
18	19
19		my $validator = new Data::FormValidator({default => $input_profile});
	20	my $validator = new Data::FormValidator( { default => $input_profile } );
20	21
21	22	my $input_hashref = {
22		my_zipcode_field => '402015', # born to lose
	23	my_zipcode_field => '402015', # born to lose
23	24	};
24	25
25		my ($valids, $missings, $invalids, $unknowns);
	26	my ( $valids, $missings, $invalids, $unknowns );
26	27
27		eval{
28		($valids, $missings, $invalids, $unknowns) = $validator->validate($input_hashref, 'default');
	28	eval {
	29	( $valids, $missings, $invalids, $unknowns ) =
	30	$validator->validate( $input_hashref, 'default' );
29	31	};
30	32
31		ok(!$@, 'survived eval');
	33	ok( !$@, 'survived eval' );
32	34
33		ok((grep { (ref $_) eq 'ARRAY' } @$invalids));
34
	35	ok( ( grep { ( ref $_ ) eq 'ARRAY' } @$invalids ) );
35	36
36	37	# Test that the array ref in the invalids array contains three elements,
37	38	my @zip_failures;
38		for (@$invalids) {
39		if (ref $_ eq 'ARRAY') {
40		if (scalar @$_ == 3) {
41		@zip_failures = @$_;
42		# This is cheesy, and could be further refactored.
43		ok(1);
44		last;
45		}
46		}
	39	for (@$invalids)
	40	{
	41	if ( ref $_ eq 'ARRAY' )
	42	{
	43	if ( scalar @$_ == 3 )
	44	{
	45	@zip_failures = @$_;
	46
	47	# This is cheesy, and could be further refactored.
	48	ok(1);
	49	last;
	50	}
	51	}
47	52	}
48	53
49	54	# Test that the first element of the array is 'my_zipcode_field'
50	55	my $t = shift @zip_failures;
51	56
52		ok($t eq 'my_zipcode_field');
	57	ok( $t eq 'my_zipcode_field' );
53	58
54	59	# Test that the two elements are 'zip' and 'starts_with_406'
55		ok(eq_set(\@zip_failures, [qw/zip starts_with_406/]));
56
57
	60	ok( eq_set( \@zip_failures, [qw/zip starts_with_406/] ) );
58	61
59	62	# The next three tests are to confirm that an input field is deleted
60	63	# from the valids under the following conditions

64	67
65	68	my %data = (
66	69	multiple => 'to fail',
	70
67	71	#multiple => [qw{this multi-value input will fail on the constraint below}],
68		single => 'to pass',
	72	single => 'to pass',
69	73	);
70	74
71	75	my %profile = (
72		required => [qw/
73		multiple
74		single
75		/],
	76	required => [
	77	qw/
	78	multiple
	79	single
	80	/
	81	],
76	82	constraints => {
77		multiple => [
78		{ name => 'constraint_1', constraint => qr/\w/ }, # pass
79		{ name => 'constraint_2', constraint => qr/\d/ }, # force fail
80		],
	83	multiple => [
	84	{ name => 'constraint_1', constraint => qr/\w/ }, # pass
	85	{ name => 'constraint_2', constraint => qr/\d/ }, # force fail
	86	],
81	87	},
82	88	);
83	89
	90	my $results = Data::FormValidator->check( \%data, \%profile );
84	91
85		my $results = Data::FormValidator->check(\%data, \%profile);
86
87		ok(!$results->valid('multiple'), "expect 'multiple' not to appear in valid");
88		is_deeply($results->invalid('multiple'), ['constraint_2'], "list of failed constraints for 'multiple'");
89		is($results->valid('single'), 'to pass', "single is valid");
	92	ok( !$results->valid('multiple'), "expect 'multiple' not to appear in valid" );
	93	is_deeply( $results->invalid('multiple'),
	94	['constraint_2'], "list of failed constraints for 'multiple'" );
	95	is( $results->valid('single'), 'to pass', "single is valid" );

+35

-28

t/params_not_mentioned.t less more

	0	#!/usr/bin/env perl
0	1	use strict;
	2	use warnings;
1	3	use Test::More;
2	4	use Data::FormValidator;
3		plan(tests => 5);
	5
	6	eval { require CGI;CGI->VERSION(4.35); };
	7	plan skip_all => 'CGI 4.35 or higher not found' if $@;
4	8
5	9	# Test that constrants can refer to fields that are not mentioned
6	10	# in 'required' or 'optional'
7	11
8	12	my $profile = {
9		required => [qw(foo)],
10		optional => [qw(bar)],
11		constraints => {
12		foo => {
13		constraint => sub {
14		if( defined $_[0] && defined $_[1] ) {
15		return $_[0] eq $_[1];
16		} else {
17		return;
18		}
19		},
20		params => [qw(foo baz)],
21		},
	13	required => [qw(foo)],
	14	optional => [qw(bar)],
	15	constraints => {
	16	foo => {
	17	constraint => sub {
	18	if ( defined $_[0] && defined $_[1] )
	19	{
	20	return $_[0] eq $_[1];
	21	}
	22	else
	23	{
	24	return;
	25	}
	26	},
	27	params => [qw(foo baz)],
22	28	},
	29	},
23	30	};
24	31	my $input = {
25		foo => 'stuff',
26		bar => 'other stuff',
27		baz => 'stuff',
	32	foo => 'stuff',
	33	bar => 'other stuff',
	34	baz => 'stuff',
28	35	};
29	36
30		my $results = Data::FormValidator->check($input, $profile);
31		ok(! $results->has_invalid(), 'no_invalids' );
32		ok( $results->valid('foo'), 'foo valid');
	37	my $results = Data::FormValidator->check( $input, $profile );
	38	ok( !$results->has_invalid(), 'no_invalids' );
	39	ok( $results->valid('foo'), 'foo valid' );
33	40
34	41	{
35		# with CGI object as input.
36		use CGI;
37		my $q = CGI->new($input);
38		my $results;
39		eval { $results = Data::FormValidator->check($q, $profile); };
40		is ($@, '', 'survived eval');
41		ok(! $results->has_invalid(), 'no_invalids' );
42		ok( $results->valid('foo'), 'foo valid');
	42	# with CGI object as input.
	43	my $q = CGI->new($input);
	44	my $results;
	45	eval { $results = Data::FormValidator->check( $q, $profile ); };
	46	is( $@, '', 'survived eval' );
	47	ok( !$results->has_invalid(), 'no_invalids' );
	48	ok( $results->valid('foo'), 'foo valid' );
43	49
44	50	}
45	51
	52	done_testing;

+16

-10

t/pod.t less more

	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
0	3	use Test::More;
	4	use File::Spec;
	5	use File::Find;
1	6
2	7	# Check our Pod
3	8	# The test was provided by Andy Lester,
4	9	# who stole it from Brian D. Foy
5	10	# Thanks to both !
6
7		use File::Spec;
8		use File::Find;
9		use strict;
10	11
11	12	eval {
12	13	require Test::Pod;

15	16
16	17	my @files;
17	18
18		if ($@) {
	19	if ($@)
	20	{
19	21	plan skip_all => "Test::Pod required for testing POD";
20	22	}
21		elsif ($Test::Pod::VERSION < 0.95) {
	23	elsif ( $Test::Pod::VERSION < 0.95 )
	24	{
22	25	plan skip_all => "Test::Pod 0.95 required for testing POD";
23	26	}
24		else {
	27	else
	28	{
25	29	my $blib = File::Spec->catfile(qw(blib lib));
26		find(\&wanted, $blib, 'lib');
	30	find( \&wanted, $blib, 'lib' );
27	31	plan tests => scalar @files;
28		foreach my $file (@files) {
	32	foreach my $file (@files)
	33	{
29	34	pod_file_ok($file);
30	35	}
31	36	}
32	37
33		sub wanted {
	38	sub wanted
	39	{
34	40	push @files, $File::Find::name if /\.p(l\|m\|od)$/;
35	41	}

+63

-65

t/procedural_valid.t less more

	0	#!/usr/bin/env perl
0	1	use strict;
1		#Check that the valid_* routines are nominally working.
2
3		$^W = 1;
4
	2	use warnings;
5	3	use Test::More qw/no_plan/;
6
7	4	use Data::FormValidator qw(:validators :matchers);
8	5
9
10
	6	#Check that the valid_* routines are nominally working.
11	7	my $invalid = "fake value";
12	8
13	9	#For CC Exp test
14	10	my @time = localtime(time);
15	11
16		my %tests = (
17		valid_american_phone => "555-555-5555",
18		valid_cc_exp => "10/" . sprintf("%.2d", ($time[5] - 99)),
19		valid_cc_type => "MasterCard",
20		valid_email => 'foo@domain.com',
21		valid_ip_address => "64.58.79.230",
22		valid_phone => "123-456-7890",
23		valid_postcode => "T2N 0E6",
24		valid_province => "NB",
25		valid_state => "CA",
26		valid_state_or_province => "QC",
27		valid_zip => "94112",
28		valid_zip_or_postcode => "50112",
	12	my %tests = (
	13	valid_american_phone => "555-555-5555",
	14	valid_cc_exp => "10/" . sprintf( "%.2d", ( $time[5] - 99 ) ),
	15	valid_cc_type => "MasterCard",
	16	valid_email => 'foo@domain.com',
	17	valid_ip_address => "64.58.79.230",
	18	valid_phone => "123-456-7890",
	19	valid_postcode => "T2N 0E6",
	20	valid_province => "NB",
	21	valid_state => "CA",
	22	valid_state_or_province => "QC",
	23	valid_zip => "94112",
	24	valid_zip_or_postcode => "50112",
29	25	);
30	26
31	27	my $i = 1;
32	28
33		foreach my $function (keys(%tests)) {
34		my $rv;
35		my $val = $tests{$function};
36		my $is_valid = "\$rv = $function('$val');";
37		my $not_valid = "\$rv = $function('$invalid');";
38
39		eval $is_valid;
40		ok(not $@ and $rv == 1) or
41		diag $@;
42		#diag sprintf("%-25s using %-16s", $function, "(valid value)");
43		$i++;
	29	foreach my $function ( keys(%tests) )
	30	{
	31	my $rv;
	32	my $val = $tests{$function};
	33	my $is_valid = "\$rv = $function('$val');";
	34	my $not_valid = "\$rv = $function('$invalid');";
44	35
45		eval $not_valid;
46		ok(not $@ and not $rv) or
47		diag sprintf("%-25s using %-16s", $function, "(invalid value)");
48		$i++;
	36	eval $is_valid;
	37	ok( not $@ and $rv == 1 )
	38	or diag $@;
	39
	40	#diag sprintf("%-25s using %-16s", $function, "(valid value)");
	41	$i++;
	42
	43	eval $not_valid;
	44	ok( not $@ and not $rv )
	45	or diag sprintf( "%-25s using %-16s", $function, "(invalid value)" );
	46	$i++;
49	47	}
50
	48
51	49	#Test cc_number separately since it takes multiple parameters
52	50	{
53		my $rv;
54		my $num = '4111111111111111';
	51	my $rv;
	52	my $num = '4111111111111111';
55	53
56		eval "\$rv = match_cc_number('$num', 'v')";
57		ok(not $@ and ($rv eq $num)) or
58		diag sprintf("%-25s using %-16s", "match_cc_number", "valid value. ");
	54	eval "\$rv = match_cc_number('$num', 'v')";
	55	ok( not $@ and ( $rv eq $num ) )
	56	or diag sprintf( "%-25s using %-16s", "match_cc_number", "valid value. " );
59	57
60		eval "\$rv = valid_cc_number('$invalid', 'm')";
61		ok(not $@ and not $rv) or
62		diag sprintf("%-25s using %-16s", "valid_cc_number", "(invalid value)");
	58	eval "\$rv = valid_cc_number('$invalid', 'm')";
	59	ok( not $@ and not $rv )
	60	or diag sprintf
	61	( "%-25s using %-16s", "valid_cc_number", "(invalid value)" );
63	62	}
64	63
65	64	$i++;

67	66
68	67	#Test fake validation routine
69	68	{
70		my $rv;
71		eval "\$rv = valid_foobar('$invalid', 'm')";
	69	my $rv;
	70	eval "\$rv = valid_foobar('$invalid', 'm')";
72	71
73		ok($@) or
74		diag sprintf("%-25s", "Fake Valid Routine");
	72	ok($@)
	73	or diag sprintf( "%-25s", "Fake Valid Routine" );
75	74	}
76	75
77		ok(! valid_email('pretty_b;ue_eyes16@cpan.org'), 'semi-colons in e-mail aren\'t valid');
78		ok(! valid_email('Ollie 102@cpan.org'), 'spaces in e-mail aren\'t valid');
	76	ok(
	77	!valid_email('pretty_b;ue_eyes16@cpan.org'),
	78	'semi-colons in e-mail aren\'t valid'
	79	);
	80	ok( !valid_email('Ollie 102@cpan.org'), 'spaces in e-mail aren\'t valid' );
79	81
80		ok(! valid_email('mark@summersualt.com\0mark@summersault.com'), "including a null in an e-mail is not valid.");
81
	82	ok(
	83	!valid_email('mark@summersualt.com\0mark@summersault.com'),
	84	"including a null in an e-mail is not valid."
	85	);
82	86
83	87	my $address_1 = 'mark';
84		isnt($address_1, valid_email($address_1), "'$address_1' is not a valid e-mail");
	88	isnt( $address_1, valid_email($address_1),
	89	"'$address_1' is not a valid e-mail" );
85	90
86	91	my $address_2 = 'Mark Stosberg <mark@summersault.com>';
87		ok(! valid_email($address_2), "'$address_2' is not a valid e-mail");
	92	ok( !valid_email($address_2), "'$address_2' is not a valid e-mail" );
88	93
89	94	my $address_3 = 'mark@summersault.com';
90		ok(valid_email($address_3), "'$address_3' is a valid e-mail");
	95	ok( valid_email($address_3), "'$address_3' is a valid e-mail" );
91	96
92	97	my $address_6 = 'Mark.Stosberg@summersault.com';
93		ok(valid_email($address_6), "'$address_6' is a valid e-mail");
	98	ok( valid_email($address_6), "'$address_6' is a valid e-mail" );
94	99
95	100	my $address_7 = 'Mark_Stosberg@summersault.com';
96		ok(valid_email($address_7), "'$address_7' is a valid e-mail");
	101	ok( valid_email($address_7), "'$address_7' is a valid e-mail" );
97	102
98	103	my $addr_8 = "Mark_O'Doul\@summersault.com";
99		ok(valid_email($addr_8), "'$addr_8' is a valid e-mail");
100
101
102
103
104
105
106
	104	ok( valid_email($addr_8), "'$addr_8' is a valid e-mail" );

+31

-33

t/profile_checking.t less more

0
	0	#!/usr/bin/env perl
1	1	use strict;
2
3		$^W = 1;
4
	2	use warnings;
5	3	use Test::More tests => 1;
6
7	4	use Data::FormValidator;
8	5
9	6	my $input_profile = {
10		required => [ qw( email_1 email_ok) ],
11		optional => ['filled','not_filled'],
12		constraint_regexp_map => {
13		'/^email/' => "email",
14		},
15		constraints => {
16		not_filled => 'phone',
17		},
18		missing_optional_valid => 1,
19		bad_key_which_should_trigger_error=>1,
20		another_bad_key_which_should_trigger_error=>1,
21		};
	7	required => [qw( email_1 email_ok)],
	8	optional => [ 'filled', 'not_filled' ],
	9	constraint_regexp_map => {
	10	'/^email/' => "email",
	11	},
	12	constraints => {
	13	not_filled => 'phone',
	14	},
	15	missing_optional_valid => 1,
	16	bad_key_which_should_trigger_error => 1,
	17	another_bad_key_which_should_trigger_error => 1,
	18	};
22	19
23		my $validator = new Data::FormValidator({default => $input_profile});
	20	my $validator = new Data::FormValidator( { default => $input_profile } );
24	21
25	22	my $input_hashref = {
26		email_1 => 'invalidemail',
27		email_ok => 'mark@stosberg.com',
28		filled => 'dog',
29		not_filled => '',
30		should_be_unknown => 1,
	23	email_1 => 'invalidemail',
	24	email_ok => 'mark@stosberg.com',
	25	filled => 'dog',
	26	not_filled => '',
	27	should_be_unknown => 1,
31	28	};
32	29
33		my ($valids, $missings, $invalids, $unknowns);
	30	my ( $valids, $missings, $invalids, $unknowns );
34	31
35		eval{
36		($valids, $missings, $invalids, $unknowns) = $validator->validate($input_hashref, 'default');
	32	eval {
	33	( $valids, $missings, $invalids, $unknowns ) =
	34	$validator->validate( $input_hashref, 'default' );
37	35	};
38	36
39		ok(not $@
40		or
41		$@ =~ qr/\QInvalid input profile: keys not recognised [bad_key_which_should_trigger_error, another_bad_key_which_should_trigger_error]/
42		or
43		$@ =~ qr/\QInvalid input profile: keys not recognised [another_bad_key_which_should_trigger_error, bad_key_which_should_trigger_error]/
44		) \|\| warn $@;
	37	ok(
	38	not $@
	39	or $@ =~
	40	qr/\QInvalid input profile: keys not recognised [bad_key_which_should_trigger_error, another_bad_key_which_should_trigger_error]/
	41	or $@ =~
	42	qr/\QInvalid input profile: keys not recognised [another_bad_key_which_should_trigger_error, bad_key_which_should_trigger_error]/
	43	) \|\| warn $@;
45	44
46

+50

-50

t/regexp_common.t less more

	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
	3	use Test::More tests => 10;
	4	use Data::FormValidator;
	5
0	6	# Integration with Regexp::Common;
1
2		use Test::More tests => 10;
3
4		use Data::FormValidator;
5
6	7	my %FORM = (
7		bad_ip => '127 0 0 1',
8		good_ip => '127.0.0.1',
9		embedded_ip => 'The address is 127.0.0.1 or something close to that',
	8	bad_ip => '127 0 0 1',
	9	good_ip => '127.0.0.1',
	10	embedded_ip => 'The address is 127.0.0.1 or something close to that',
10	11	);
11	12
12	13	my $results;
13	14
14	15	eval {
15		$results = Data::FormValidator->check(\%FORM, {
16		required => [qw/good_ip bad_ip/],
17		constraint_regexp_map => {
18		qr/_ip$/ => 'RE_net_IPv4',
	16	$results = Data::FormValidator->check(
	17	\%FORM,
	18	{
	19	required => [qw/good_ip bad_ip/],
	20	constraint_regexp_map => {
	21	qr/_ip$/ => 'RE_net_IPv4',
19	22
20		}
21		});
	23	} } );
22	24	};
23		ok((not $@), 'runtime errors') or diag $@;
24		ok($results->valid->{good_ip}, 'good ip');
25		ok($results->invalid->{bad_ip}, 'bad ip');
	25	ok( ( not $@ ), 'runtime errors' ) or diag $@;
	26	ok( $results->valid->{good_ip}, 'good ip' );
	27	ok( $results->invalid->{bad_ip}, 'bad ip' );
26	28
	29	$results = Data::FormValidator->check(
	30	\%FORM,
	31	{
	32	untaint_all_constraints => 1,
	33	required => [qw/good_ip bad_ip/],
	34	constraint_regexp_map => {
	35	qr/_ip$/ => 'RE_net_IPv4',
27	36
28		$results = Data::FormValidator->check(\%FORM, {
29		untaint_all_constraints => 1,
30		required => [qw/good_ip bad_ip/],
31		constraint_regexp_map => {
32		qr/_ip$/ => 'RE_net_IPv4',
	37	} } );
33	38
34		}
35		});
36
37
38		ok((not $@), 'runtime errors') or diag $@;
39		ok($results->valid->{good_ip}, 'good ip with tainting');
40		ok($results->invalid->{bad_ip}, 'bad ip with tainting');
	39	ok( ( not $@ ), 'runtime errors' ) or diag $@;
	40	ok( $results->valid->{good_ip}, 'good ip with tainting' );
	41	ok( $results->invalid->{bad_ip}, 'bad ip with tainting' );
41	42
42	43	# Test passing flags
43		$results = Data::FormValidator->check(\%FORM, {
44		required => [qw/good_ip bad_ip/],
45		constraint_regexp_map => {
46		qr/_ip$/ => {
47		constraint => 'RE_net_IPv4_dec',
48		params => [ \'-sep'=> \' ' ],
49		}
50		}
51		});
	44	$results = Data::FormValidator->check(
	45	\%FORM,
	46	{
	47	required => [qw/good_ip bad_ip/],
	48	constraint_regexp_map => {
	49	qr/_ip$/ => {
	50	constraint => 'RE_net_IPv4_dec',
	51	params => [ \'-sep' => \' ' ],
	52	} } } );
52	53
	54	ok( ( not $@ ), 'runtime errors' ) or diag $@;
53	55
54		ok((not $@), 'runtime errors') or diag $@;
55	56	# Here we are trying passing a parameter which should reverse
56	57	# the notion of which one expect to succeed.
57		ok($results->valid->{bad_ip}, 'expecting success with params');
58		ok($results->invalid->{good_ip}, 'expecting failure with params');
59
	58	ok( $results->valid->{bad_ip}, 'expecting success with params' );
	59	ok( $results->invalid->{good_ip}, 'expecting failure with params' );
60	60
61	61	# Testing end-to-end matching
62		$results = Data::FormValidator->check(\%FORM, {
63		required => [qw/embedded_ip/],
64		constraint_regexp_map => {
65		qr/_ip$/ => 'RE_net_IPv4',
66		}
67		});
	62	$results = Data::FormValidator->check(
	63	\%FORM,
	64	{
	65	required => [qw/embedded_ip/],
	66	constraint_regexp_map => {
	67	qr/_ip$/ => 'RE_net_IPv4',
	68	} } );
68	69	my $invalid = scalar $results->invalid \|\| {};
69		ok($invalid->{embedded_ip}, 'testing that the RE must match from end-to-end');
70
	70	ok( $invalid->{embedded_ip}, 'testing that the RE must match from end-to-end' );

+58

-56

t/regexp_common_closure.t less more

	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
	3	use Test::More tests => 13;
	4	use Data::FormValidator;
	5
0	6	# Integration with Regexp::Common;
1	7
2		use Test::More tests => 13;
3
4		use Data::FormValidator;
5
6	8	my %FORM = (
7		bad_ip => '127 0 0 1',
8		good_ip => '127.0.0.1',
9		embedded_ip => 'The address is 127.0.0.1 or something close to that',
10		valid_int => 0,
	9	bad_ip => '127 0 0 1',
	10	good_ip => '127.0.0.1',
	11	embedded_ip => 'The address is 127.0.0.1 or something close to that',
	12	valid_int => 0,
11	13	);
12	14
13	15	my $results;
14	16
15		BEGIN { use_ok('Data::FormValidator::Constraints', qw/:regexp_common/) }
	17	BEGIN { use_ok( 'Data::FormValidator::Constraints', qw/:regexp_common/ ) }
16	18
17	19	eval {
18		$results = Data::FormValidator->check(\%FORM, {
19		required => [qw/good_ip bad_ip valid_int/],
20		constraint_method_regexp_map => {
21		qr/_ip$/ => FV_net_IPv4(),
22		},
23		constraint_methods => {
24		valid_int => FV_num_int(),
25		}
26		});
	20	$results = Data::FormValidator->check(
	21	\%FORM,
	22	{
	23	required => [qw/good_ip bad_ip valid_int/],
	24	constraint_method_regexp_map => {
	25	qr/_ip$/ => FV_net_IPv4(),
	26	},
	27	constraint_methods => {
	28	valid_int => FV_num_int(),
	29	} } );
27	30	};
28		is($@,'', 'survived eval');
29		ok($results->valid->{good_ip}, 'good ip');
30		ok($results->invalid->{bad_ip}, 'bad ip');
31		is($results->valid->{valid_int},0, 'zero is valid int');
	31	is( $@, '', 'survived eval' );
	32	ok( $results->valid->{good_ip}, 'good ip' );
	33	ok( $results->invalid->{bad_ip}, 'bad ip' );
	34	is( $results->valid->{valid_int}, 0, 'zero is valid int' );
32	35
	36	$results = Data::FormValidator->check(
	37	\%FORM,
	38	{
	39	untaint_all_constraints => 1,
	40	required => [qw/good_ip bad_ip valid_int/],
	41	constraint_method_regexp_map => {
	42	qr/_ip$/ => FV_net_IPv4(),
	43	},
	44	constraint_methods => {
	45	valid_int => FV_num_int(),
	46	} } );
33	47
34		$results = Data::FormValidator->check(\%FORM, {
35		untaint_all_constraints => 1,
36		required => [qw/good_ip bad_ip valid_int/],
37		constraint_method_regexp_map => {
38		qr/_ip$/ => FV_net_IPv4(),
39		},
40		constraint_methods => {
41		valid_int => FV_num_int(),
42		}
43		});
44
45
46		is($@,'', 'survived eval');
47		ok($results->valid->{good_ip}, 'good ip with tainting');
48		ok($results->invalid->{bad_ip}, 'bad ip with tainting');
49		is($results->valid->{valid_int},0, 'zero is valid int with untainting');
	48	is( $@, '', 'survived eval' );
	49	ok( $results->valid->{good_ip}, 'good ip with tainting' );
	50	ok( $results->invalid->{bad_ip}, 'bad ip with tainting' );
	51	is( $results->valid->{valid_int}, 0, 'zero is valid int with untainting' );
50	52
51	53	# Test passing flags
52		$results = Data::FormValidator->check(\%FORM, {
53		required => [qw/good_ip bad_ip/],
54		constraint_method_regexp_map => {
55		qr/_ip$/ => FV_net_IPv4_dec(-sep => ' '),
56		}
57		});
	54	$results = Data::FormValidator->check(
	55	\%FORM,
	56	{
	57	required => [qw/good_ip bad_ip/],
	58	constraint_method_regexp_map => {
	59	qr/_ip$/ => FV_net_IPv4_dec( -sep => ' ' ),
	60	} } );
58	61
	62	ok( ( not $@ ), 'runtime errors' ) or diag $@;
59	63
60		ok((not $@), 'runtime errors') or diag $@;
61	64	# Here we are trying passing a parameter which should reverse
62	65	# the notion of which one expect to succeed.
63		ok($results->valid->{bad_ip}, 'expecting success with params');
64		ok($results->invalid->{good_ip}, 'expecting failure with params');
65
	66	ok( $results->valid->{bad_ip}, 'expecting success with params' );
	67	ok( $results->invalid->{good_ip}, 'expecting failure with params' );
66	68
67	69	# Testing end-to-end matching
68		$results = Data::FormValidator->check(\%FORM, {
69		required => [qw/embedded_ip/],
70		constraint_method_regexp_map => {
71		qr/_ip$/ => FV_net_IPv4(),
72		}
73		});
	70	$results = Data::FormValidator->check(
	71	\%FORM,
	72	{
	73	required => [qw/embedded_ip/],
	74	constraint_method_regexp_map => {
	75	qr/_ip$/ => FV_net_IPv4(),
	76	} } );
74	77	my $invalid = scalar $results->invalid \|\| {};
75		ok($invalid->{embedded_ip}, 'testing that the RE must match from end-to-end');
76
	78	ok( $invalid->{embedded_ip}, 'testing that the RE must match from end-to-end' );

+26

-23

t/rename_builtin_constraints.t less more

0		#!perl
	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
1	3	use Test::More 'no_plan';
2
3	4	use Data::FormValidator;
4		use Data::FormValidator::Constraints qw(
5		FV_max_length
	5	use Data::FormValidator::Constraints qw(
	6	FV_max_length
6	7	);
7	8
8		my $result = Data::FormValidator->check({
9		first_names => 'Too long',
	9	my $result = Data::FormValidator->check( {
	10	first_names => 'Too long',
	11	},
	12	{
	13	required => [qw/first_names/],
	14	constraint_methods => {
	15	first_names => {
	16	constraint_method => FV_max_length(3),
	17	name => 'custom_length',
	18	}
10	19	},
11		{
12		required => [qw/first_names/],
13		constraint_methods => {
14		first_names => {
15		constraint_method => FV_max_length(3),
16		name => 'custom_length',
17		}
18		},
19		msgs => {
20		constraints => {
21		custom_length => 'Custom length msg',
22		}
23		},
24		});
	20	msgs => {
	21	constraints => {
	22	custom_length => 'Custom length msg',
	23	}
	24	},
	25	} );
25	26
26		like( $result->msgs->{'first_names'}, qr/Custom length msg/, "built-ins can have custom names" );
27
28
	27	like(
	28	$result->msgs->{'first_names'},
	29	qr/Custom length msg/,
	30	"built-ins can have custom names"
	31	);

+26

-24

t/results_success.t less more

	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
0	3	use Test::More tests => 4;
1	4	use Data::FormValidator;
2	5
3	6	my %FORM = (
4		good => '1',
5		extra => '2',
	7	good => '1',
	8	extra => '2',
6	9	);
7	10
8		my $results = Data::FormValidator->check(\%FORM,
9		{
10		required => 'good',
11		}
12		);
	11	my $results = Data::FormValidator->check(
	12	\%FORM,
	13	{
	14	required => 'good',
	15	} );
13	16
14		ok($results->success, 'success with unknown');
	17	ok( $results->success, 'success with unknown' );
15	18
16	19	{
17		my $false;
18		$results \|\| ($false = 1);
19		ok(!$false, "returns true in bool context on success");
	20	my $false;
	21	$results \|\| ( $false = 1 );
	22	ok( !$false, "returns true in bool context on success" );
20	23	}
21	24
22	25	# test an unsuccessful success
23	26	$FORM{bad} = -1;
24	27	$results = Data::FormValidator->check(
25		\%FORM,
26		{
27		required => [qw(good bad)],
28		optional => [qw(extra)],
29		constraints => {
30		good => sub { return shift > 0 },
31		bad => sub { return shift > 0 },
32		},
	28	\%FORM,
	29	{
	30	required => [qw(good bad)],
	31	optional => [qw(extra)],
	32	constraints => {
	33	good => sub { return shift > 0 },
	34	bad => sub { return shift > 0 },
33	35	},
	36	},
34	37	);
35	38
36		ok(!$results->success, 'not success()');
	39	ok( !$results->success, 'not success()' );
37	40
38	41	{
39		my $false;
40		$results \|\| ($false = 1);
41		ok($false, "returns false in bool context on not success");
	42	my $false;
	43	$results \|\| ( $false = 1 );
	44	ok( $false, "returns false in bool context on not success" );
42	45	}
43

+22

-25

t/simple.t less more

0
	0	#!/usr/bin/env perl
1	1	use strict;
2
3		$^W = 1;
4
	2	use warnings;
5	3	use Test::More tests => 3;
6
7	4	use Data::FormValidator;
8	5
9	6	my $input_profile = {
10		required => [ qw( email phone likes ) ],
11		optional => [ qq( toppings ) ],
12		constraints => {
13		email => "email",
14		phone => "phone",
15		}
16		};
	7	required => [qw( email phone likes )],
	8	optional => [qq( toppings )],
	9	constraints => {
	10	email => "email",
	11	phone => "phone",
	12	} };
17	13
18		my $validator = new Data::FormValidator({default => $input_profile});
	14	my $validator = new Data::FormValidator( { default => $input_profile } );
19	15
20		my $input_hashref = {email => 'invalidemail',
21		phone => '201-999-9999',
22		likes => ['a','b'],
23		toppings => 'foo'};
	16	my $input_hashref = {
	17	email => 'invalidemail',
	18	phone => '201-999-9999',
	19	likes => [ 'a', 'b' ],
	20	toppings => 'foo'
	21	};
24	22
25		my ($valids, $missings, $invalids, $unknowns) = ({},[],[],[]);
	23	my ( $valids, $missings, $invalids, $unknowns ) = ( {}, [], [], [] );
26	24
27		eval{
28		($valids, $missings, $invalids, $unknowns) = $validator->validate($input_hashref, 'default');
	25	eval {
	26	( $valids, $missings, $invalids, $unknowns ) =
	27	$validator->validate( $input_hashref, 'default' );
29	28	};
30		is($@,'', 'survived eval');
	29	is( $@, '', 'survived eval' );
31	30
32		ok(exists $valids->{'phone'}, "phone is valid" );
	31	ok( exists $valids->{'phone'}, "phone is valid" );
33	32
34		is($invalids->[0], 'email')
35
36
	33	is( $invalids->[0], 'email' )

-5

t/tt_and_overload.t less more

	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
0	3	use Test::More;
1	4	use Data::FormValidator;
2	5
3		eval { require Template; require Template::Stash; };
	6	eval { require Template; require Template::Stash; };
4	7	plan skip_all => 'Template Toolkit required' if $@;
5	8	plan tests => 1;
6	9
7		my $results = Data::FormValidator->check( {}, {required => 1} );
	10	my $results = Data::FormValidator->check( {}, { required => 1 } );
8	11
9	12	my $tt = Template->new( STASH => Template::Stash->new );
10	13
11		$tt->process( \'[% form.missing %]', {form => $results}, \my $out );
	14	$tt->process( \'[% form.missing %]', { form => $results }, \my $out );
12	15
13		ok(not $tt->error);
14
	16	ok( not $tt->error );

-4

t/undefined_arrayref.t less more

	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
0	3	use Test::More tests => 1;
1	4	use Data::FormValidator;
2		use strict;
3	5
4		my ( $valid, $missing, $invalid, $unknown ) = Data::FormValidator->validate({}, {} );
5		ok( (ref $invalid eq 'ARRAY'), "no invalid fields are returned as an arrayref");
6
	6	my ( $valid, $missing, $invalid, $unknown ) =
	7	Data::FormValidator->validate( {}, {} );
	8	ok( ( ref $invalid eq 'ARRAY' ),
	9	"no invalid fields are returned as an arrayref" );

+22

-16

t/unknown.t less more

	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
0	3	use Test::More tests => 4;
1
2		use Data::FormValidator;
	4	use Data::FormValidator;
3	5
4	6	my %FORM = (
5		stick => 'big',
6		speak => 'softly',
7		mv => ['first','second'],
	7	stick => 'big',
	8	speak => 'softly',
	9	mv => [ 'first', 'second' ],
8	10	);
9	11
10		my $results = Data::FormValidator->check(\%FORM,
11		{
12		# required => 'stick',
13		# optional => 'mv',
	12	my $results = Data::FormValidator->check(
	13	\%FORM,
	14	{
	15	# required => 'stick',
	16	# optional => 'mv',
14	17
15		}
16		);
	18	} );
17	19
18		ok($results->unknown('stick') eq 'big','using check() as class method');
	20	ok( $results->unknown('stick') eq 'big', 'using check() as class method' );
19	21
20		is($results->unknown('stick'),$FORM{stick}, 'unknown() returns single value in scalar context');
	22	is( $results->unknown('stick'),
	23	$FORM{stick}, 'unknown() returns single value in scalar context' );
21	24
22	25	my @mv = $results->unknown('mv');
23		is_deeply(\@mv,$FORM{mv}, 'unknown() returns multi-valued results');
	26	is_deeply( \@mv, $FORM{mv}, 'unknown() returns multi-valued results' );
24	27
25	28	my @stick = $results->unknown('stick');
26		is_deeply(\@stick,[ $FORM{stick} ], 'unknown() returns single value in list context');
27
	29	is_deeply(
	30	\@stick,
	31	[ $FORM{stick} ],
	32	'unknown() returns single value in list context'
	33	);

+23

-30

t/untaint.pl less more

0		#!/usr/bin/perl -wT
1
	0	#!/usr/bin/env perl -wT
2	1	use strict;
3
4	2	use Test::More (tests => 55);
5	3	use Data::FormValidator;
6	4	use Data::FormValidator::Constraints qw/
7	5	:closures
8	6	FV_max_length
9	7	/;
10
11		# A gift from Andy Lester, this trick shows me where eval's die.
	8	use Scalar::Util 'tainted';
	9
	10	# A gift from Andy Lester, this trick shows me where eval's die.
12	11	use Carp;
13	12	$SIG{__WARN__} = \&carp;
14	13	$SIG{__DIE__} = \&confess;
15	14
16	15	$ENV{PATH} = "/bin/";
17
18		sub is_tainted {
19		my $val = shift;
20		# What does kill do here? -mls
21		return !eval { $val++, kill 0; 1; };
22		}
23	16
24	17	my $data1 = {
25	18	firstname => $ARGV[0], #Jim

147	140
148	141	is($@,'','avoided eval error');
149	142	ok($valid->{firstname}, 'found firstname');
150		ok(! is_tainted($valid->{firstname}), 'firstname is untainted');
	143	ok(! tainted($valid->{firstname}), 'firstname is untainted');
151	144	is($valid->{firstname},$data1->{firstname}, 'firstname has expected value');
152	145
153	146

158	151
159	152	is($@,'','avoided eval error');
160	153	ok($valid->{lastname});
161		ok(!is_tainted($valid->{lastname}));
	154	ok(!tainted($valid->{lastname}));
162	155	is($valid->{lastname},$data2->{lastname});
163	156
164	157	ok($valid->{email1});
165		ok(!is_tainted($valid->{email1}));
	158	ok(!tainted($valid->{email1}));
166	159	is($valid->{email1},$data2->{email1});
167	160
168	161	ok($valid->{email2});
169		ok(is_tainted($valid->{email2}), 'email2 is tainted');
	162	ok(tainted($valid->{email2}), 'email2 is tainted');
170	163	is($valid->{email2},$data2->{email2});
171	164
172	165	# Rules2 with closures

177	170	$valid = $result->valid();
178	171
179	172	ok($valid->{email1}, "found email1 in \%valid") \|\| warn Dumper ($data2,$result);
180		ok(!is_tainted($valid->{email1}), "email one is not tainted");
	173	ok(!tainted($valid->{email1}), "email one is not tainted");
181	174	is($valid->{email1},$data2->{email1}, "email1 identity");
182	175	}
183	176

188	181	ok(!$@);
189	182
190	183	ok($valid->{ip_address});
191		ok(!is_tainted($valid->{ip_address}));
	184	ok(!tainted($valid->{ip_address}));
192	185	is($valid->{ip_address},$data3->{ip_address});
193	186
194	187	#in this case we're expecting no match

196	189	is($invalid->[0], 'cats_name', 'cats_name fails constraint');
197	190
198	191	ok($valid->{dogs_name});
199		ok(!is_tainted($valid->{dogs_name}));
	192	ok(!tainted($valid->{dogs_name}));
200	193	is($valid->{dogs_name},$data3->{dogs_name});
201	194
202	195	# Rules # 4
203	196	eval { ( $valid, $missing, $invalid, $unknown ) = $validator->validate( $data4, "rules4"); };
204	197	ok(!$@, 'avoided eval error');
205	198
206		ok(!is_tainted($valid->{zip_field1}->[0]),
	199	ok(!tainted($valid->{zip_field1}->[0]),
207	200	'zip_field1 should be untainted');
208	201
209		ok(is_tainted($valid->{zip_field2}->[0]),
	202	ok(tainted($valid->{zip_field2}->[0]),
210	203	'zip_field2 should be tainted');
211	204
212	205

232	225	eval { ( $valid, $missing, $invalid, $unknown ) = $validator->validate( $data5, "rules5"); };
233	226	ok(!$@, 'avoided eval error');
234	227	ok($valid->{zip_field1}, "zip_field1 should be valid");
235		ok(!is_tainted($valid->{zip_field1}->[0]), 'zip_field1 should be untainted');
	228	ok(!tainted($valid->{zip_field1}->[0]), 'zip_field1 should be untainted');
236	229	ok($valid->{zip_field2}, "zip_field2 should be valid");
237		ok(!is_tainted($valid->{zip_field2}->[0]), 'zip_field2 should be untainted');
	230	ok(!tainted($valid->{zip_field2}->[0]), 'zip_field2 should be untainted');
238	231
239	232	# Rules #6
240	233	eval { ( $valid, $missing, $invalid, $unknown ) = $validator->validate( $data6, "rules6"); };
241	234	ok(!$@, 'avoided eval error');
242	235	ok($valid->{zip_field1}, "zip_field1 should be valid");
243		ok(!is_tainted($valid->{zip_field1}->[0]), 'zip_field1 should be untainted');
	236	ok(!tainted($valid->{zip_field1}->[0]), 'zip_field1 should be untainted');
244	237	ok($valid->{zip_field2}, "zip_field2 should be valid");
245		ok(!is_tainted($valid->{zip_field2}->[0]), 'zip_field2 should be untainted');
	238	ok(!tainted($valid->{zip_field2}->[0]), 'zip_field2 should be untainted');
246	239	ok($valid->{email1}, "email1 should be valid");
247		ok(!is_tainted($valid->{email1}), 'email1 should be untainted');
	240	ok(!tainted($valid->{email1}), 'email1 should be untainted');
248	241	ok($valid->{email2}, "email2 should be valid");
249		ok(!is_tainted($valid->{email2}), 'email2 should be untainted');
	242	ok(!tainted($valid->{email2}), 'email2 should be untainted');
250	243
251	244	# Rules #7
252	245	eval { ( $valid, $missing, $invalid, $unknown ) = $validator->validate( $data7, "rules7"); };
253	246	ok(!$@, 'avoided eval error');
254	247	ok($valid->{zip_field1}, "zip_field1 should be valid");
255		ok(!is_tainted($valid->{zip_field1}->[0]), 'zip_field1 should be untainted');
	248	ok(!tainted($valid->{zip_field1}->[0]), 'zip_field1 should be untainted');
256	249	ok($valid->{zip_field2}, "zip_field2 should be valid");
257		ok(!is_tainted($valid->{zip_field2}->[0]), 'zip_field2 should be untainted');
	250	ok(!tainted($valid->{zip_field2}->[0]), 'zip_field2 should be untainted');
258	251	ok($valid->{email1}, "email1 should be valid");
259		ok(!is_tainted($valid->{email1}), 'email1 should be untainted');
	252	ok(!tainted($valid->{email1}), 'email1 should be untainted');
260	253	ok($valid->{email2}, "email2 should be valid");
261		ok(!is_tainted($valid->{email2}), 'email2 should be untainted');
	254	ok(!tainted($valid->{email2}), 'email2 should be untainted');

+18

-14

t/untaint.t less more

0		# A gift from Andy Lester, this trick shows me where eval's die.
	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
1	3	use Carp;
	4	use Config;
2	5	$SIG{__WARN__} = \&carp;
3		$SIG{__DIE__} = \&confess;
	6	$SIG{__DIE__} = \&confess;
4	7
5		use Config;
6
7		my @args = ('-I./lib',
8		( (defined($ENV{PERL5LIB}) && length($ENV{PERL5LIB}))
9		?(map { "-I$_" } split(/$Config{path_sep}/, $ENV{PERL5LIB}))
10		: ()
11		),
12		'-T',
13		'./t/untaint.pl',
14		qw(Jim Beam jim@foo.bar james@bar.foo 132.10.10.2 Monroe Rufus 12345 oops 0)
	8	# A gift from Andy Lester, this trick shows me where eval's die.
	9	my @args = (
	10	'-I./lib',
	11	(
	12	( defined( $ENV{PERL5LIB} ) && length( $ENV{PERL5LIB} ) )
	13	? ( map { "-I$_" } split( /$Config{path_sep}/, $ENV{PERL5LIB} ) )
	14	: ()
	15	),
	16	'-T',
	17	'./t/untaint.pl',
	18	qw(Jim Beam jim@foo.bar james@bar.foo 132.10.10.2 Monroe Rufus 12345 oops 0)
15	19	);
16	20
17		# We use $^X to make it easier to test with different versions of Perl.
18		system($^X, @args);
	21	# We use $^X to make it easier to test with different versions of Perl.
	22	system( $^X, @args );

+264

-269

t/upload.t less more

	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
	3	use Test::More;
	4
	5	BEGIN
	6	{
	7	eval { require CGI;CGI->VERSION(4.35); };
	8	plan skip_all => 'CGI 4.35 or higher not found' if $@;
	9	use_ok('CGI');
	10	use_ok('Data::FormValidator::Constraints::Upload');
	11	}
	12
	13	my $cgi_simple_test = 0;
	14
	15	eval { require CGI::Simple; };
	16
	17	if ($@)
	18	{
	19	diag "Skipping CGI::Simple Tests";
	20	}
	21	else
	22	{
	23	diag "Adding CGI::Simple tests";
	24	$cgi_simple_test = 1;
	25	}
	26
0	27	#########################
1	28
2		use Test::More 'no_plan';
3		use strict;
4
5		BEGIN {
6		use_ok('CGI');
7		use_ok('Data::FormValidator::Constraints::Upload')
8		};
9
10		my $cgi_simple_test = 0;
11
12		eval {
13		require CGI::Simple;
14		};
15
16		if ($@) {
17		diag "Skipping CGI::Simple Tests";
18		}
19		else {
20		diag "Adding CGI::Simple tests";
21		$cgi_simple_test = 1;
22		}
23
24		#########################
25
26	29	%ENV = (
27		%ENV,
28		'SCRIPT_NAME' => '/test.cgi',
29		'SERVER_NAME' => 'perl.org',
30		'HTTP_CONNECTION' => 'TE, close',
31		'REQUEST_METHOD' => 'POST',
32		'SCRIPT_URI' => 'http://www.perl.org/test.cgi',
33		'CONTENT_LENGTH' => 3129,
34		'SCRIPT_FILENAME' => '/home/usr/test.cgi',
35		'SERVER_SOFTWARE' => 'Apache/1.3.27 (Unix) ',
36		'HTTP_TE' => 'deflate,gzip;q=0.3',
37		'QUERY_STRING' => '',
38		'REMOTE_PORT' => '1855',
39		'HTTP_USER_AGENT' => 'Mozilla/5.0 (compatible; Konqueror/2.1.1; X11)',
40		'SERVER_PORT' => '80',
41		'REMOTE_ADDR' => '127.0.0.1',
42		'CONTENT_TYPE' => 'multipart/form-data; boundary=xYzZY',
43		'SERVER_PROTOCOL' => 'HTTP/1.1',
44		'PATH' => '/usr/local/bin:/usr/bin:/bin',
45		'REQUEST_URI' => '/test.cgi',
46		'GATEWAY_INTERFACE' => 'CGI/1.1',
47		'SCRIPT_URL' => '/test.cgi',
48		'SERVER_ADDR' => '127.0.0.1',
49		'DOCUMENT_ROOT' => '/home/develop',
50		'HTTP_HOST' => 'www.perl.org'
	30	%ENV,
	31	'SCRIPT_NAME' => '/test.cgi',
	32	'SERVER_NAME' => 'perl.org',
	33	'HTTP_CONNECTION' => 'TE, close',
	34	'REQUEST_METHOD' => 'POST',
	35	'SCRIPT_URI' => 'http://www.perl.org/test.cgi',
	36	'CONTENT_LENGTH' => 3129,
	37	'SCRIPT_FILENAME' => '/home/usr/test.cgi',
	38	'SERVER_SOFTWARE' => 'Apache/1.3.27 (Unix) ',
	39	'HTTP_TE' => 'deflate,gzip;q=0.3',
	40	'QUERY_STRING' => '',
	41	'REMOTE_PORT' => '1855',
	42	'HTTP_USER_AGENT' => 'Mozilla/5.0 (compatible; Konqueror/2.1.1; X11)',
	43	'SERVER_PORT' => '80',
	44	'REMOTE_ADDR' => '127.0.0.1',
	45	'CONTENT_TYPE' => 'multipart/form-data; boundary=xYzZY',
	46	'SERVER_PROTOCOL' => 'HTTP/1.1',
	47	'PATH' => '/usr/local/bin:/usr/bin:/bin',
	48	'REQUEST_URI' => '/test.cgi',
	49	'GATEWAY_INTERFACE' => 'CGI/1.1',
	50	'SCRIPT_URL' => '/test.cgi',
	51	'SERVER_ADDR' => '127.0.0.1',
	52	'DOCUMENT_ROOT' => '/home/develop',
	53	'HTTP_HOST' => 'www.perl.org'
51	54	);
52	55
53	56	diag "testing with CGI.pm version: $CGI::VERSION";
54		diag "testing with CGI::Simple version: $CGI::Simple::VERSION" if $cgi_simple_test;
	57	diag "testing with CGI::Simple version: $CGI::Simple::VERSION"
	58	if $cgi_simple_test;
55	59
56	60	## testing vars
57	61	my $cgi_pm_q;
58	62	my $cgi_simple_q;
59	63
60	64	## setup input (need cleaner way)
61		open(IN,'<t/upload_post_text.txt') \|\| die 'missing test file';
	65	open( IN, '<t/upload_post_text.txt' ) \|\| die 'missing test file';
62	66	binmode(IN);
63	67
64		STDIN = IN;
	68	STDIN = IN;
65	69	$cgi_pm_q = CGI->new;
66	70	close(IN);
67	71
68	72	## setup CGI::Simple testing
69		if ($cgi_simple_test) {
70		open(IN,'<t/upload_post_text.txt') \|\| die 'missing test file';
71		binmode(IN);
72		STDIN = IN;
73		## annoying context
74		$CGI::Simple::DISABLE_UPLOADS = 0;
75		# Repeat to avoid warning..
76		$CGI::Simple::DISABLE_UPLOADS = 0;
77		$cgi_simple_q = CGI::Simple->new();
78		close(IN);
	73	if ($cgi_simple_test)
	74	{
	75	open( IN, '<t/upload_post_text.txt' ) \|\| die 'missing test file';
	76	binmode(IN);
	77	STDIN = IN;
	78	## annoying context
	79	$CGI::Simple::DISABLE_UPLOADS = 0;
	80
	81	# Repeat to avoid warning..
	82	$CGI::Simple::DISABLE_UPLOADS = 0;
	83	$cgi_simple_q = CGI::Simple->new();
	84	close(IN);
79	85	}
80	86
81	87	use Data::FormValidator;
82	88	my $default = {
83		required=>[qw/hello_world does_not_exist_gif 100x100_gif 300x300_gif/],
84		validator_packages=> 'Data::FormValidator::Constraints::Upload',
85		constraints => {
86		'hello_world' => {
87		constraint_method => 'file_format',
88		params=>[],
89		},
90		'does_not_exist_gif' => {
91		constraint_method => 'file_format',
92		params=>[],
93		},
94		'100x100_gif' => [
95		{
96		constraint_method => 'file_format',
97		params=>[],
98		},
99		{
100		constraint_method => 'file_max_bytes',
101		params=>[],
102		}
103		],
104		'300x300_gif' => {
105		constraint_method => 'file_max_bytes',
106		params => [\100],
107		},
108		},
109		};
	89	required => [qw/hello_world does_not_exist_gif 100x100_gif 300x300_gif/],
	90	validator_packages => 'Data::FormValidator::Constraints::Upload',
	91	constraints => {
	92	'hello_world' => {
	93	constraint_method => 'file_format',
	94	params => [],
	95	},
	96	'does_not_exist_gif' => {
	97	constraint_method => 'file_format',
	98	params => [],
	99	},
	100	'100x100_gif' => [ {
	101	constraint_method => 'file_format',
	102	params => [],
	103	},
	104	{
	105	constraint_method => 'file_max_bytes',
	106	params => [],
	107	}
	108	],
	109	'300x300_gif' => {
	110	constraint_method => 'file_max_bytes',
	111	params => [ \100 ],
	112	},
	113	},
	114	};
110	115
111	116	## same set of tests with each one (does this work?)
112		for my $q ($cgi_pm_q, $cgi_simple_q) {
113		next unless $q;
114		diag "Running tests with ", ref $q;
115
116		my $dfv = Data::FormValidator->new({ default => $default });
117		my $results;
118		eval { $results = $dfv->check($q, 'default'); };
119		is($@,'','survived eval');
120
121		my $valid = $results->valid;
122		my $invalid = $results->invalid; # as hash ref
123		my @invalids = $results->invalid;
124		my $missing = $results->missing;
125
126
127		# Test to make sure hello world fails because it is the wrong type
128		ok((grep {m/hello_world/} @invalids), 'expect format failure');
129
130		# should fail on empty/missing source file data
131		ok((grep {m/does_not_exist_gif/} @invalids), 'expect non-existent failure');
132
133		ok(
134		(exists $valid->{'100x100_gif'}, "valid")
135		, 'Make sure 100x100 passes because it is the right type and size'
136		);
137
138		my $meta = $results->meta('100x100_gif');
139		is(ref $meta, 'HASH', 'meta() returns hash ref');
140
141		ok($meta->{extension}, 'setting extension meta data');
142		ok($meta->{mime_type}, 'setting mime_type meta data');
143
144		ok((grep {m/300x300/} @invalids)
145		, '300x300 should fail because it exceeds max_bytes');
146
147		ok(($results->meta('100x100_gif')->{bytes} > 0), (ref $q).': setting bytes meta data') ;
148
149
150		# Revalidate to usefully re-use the same fields
151		my $profile_2 = {
152		required=>[qw/hello_world 100x100_gif 300x300_gif/],
153		validator_packages=> 'Data::FormValidator::Constraints::Upload',
154		constraints => {
155		'100x100_gif' => {
156		constraint_method => 'image_max_dimensions',
157		params => [\200,\200],
158		},
159		'300x300_gif' => {
160		constraint_method => 'image_max_dimensions',
161		params => [\200,\200],
162		},
163		},
164		};
165
166		$dfv = Data::FormValidator->new({ profile_2 => $profile_2});
167		eval {
168		$results = $dfv->check($q, 'profile_2');
169		};
170		ok(not $@) or diag $@;
171
172		$valid = $results->valid;
173		$invalid = $results->invalid; # as hash ref
174		@invalids = $results->invalid;
175		$missing = $results->missing;
176
177		ok(exists $valid->{'100x100_gif'}, 'expecting success with max_dimensions');
178		ok((grep /300x300/, @invalids), 'expecting failure with max_dimensions');
179
180		ok( $results->meta('100x100_gif')->{width} > 0, 'setting width as meta data');
181		ok( $results->meta('100x100_gif')->{width} > 0, 'setting height as meta data');
182
183		# Now test trying constraint_regxep_map
184		my $profile_3 = {
185		required=>[qw/hello_world 100x100_gif 300x300_gif/],
186		validator_packages=> 'Data::FormValidator::Constraints::Upload',
187		constraint_regexp_map => {
188		'/[13]00x[13]00_gif/' => {
189		constraint_method => 'image_max_dimensions',
190		params => [\200,\200],
191		}
192		}
193		};
194
195		$dfv = Data::FormValidator->new({ profile_3 => $profile_3});
196		($valid,$missing,$invalid) = $dfv->validate($q, 'profile_3');
197
198		ok(exists $valid->{'100x100_gif'}, 'expecting success with max_dimensions using constraint_regexp_map');
199		ok((grep {m/300x300/} @$invalid), 'expecting failure with max_dimensions using constraint_regexp_map');
200
201		## min test
202		my $profile_4 = {
203		required=>[qw/hello_world 100x100_gif 300x300_gif/],
204		validator_packages=> 'Data::FormValidator::Constraints::Upload',
205		constraints => {
206		'100x100_gif' => {
207		constraint_method => 'image_min_dimensions',
208		params => [\200,\200],
209		},
210		'300x300_gif' => {
211		constraint_method => 'image_min_dimensions',
212		params => [\200,\200],
213		},
214		},
215		};
216
217		$dfv = Data::FormValidator->new({ profile_4 => $profile_4});
218		eval {
219		$results = $dfv->check($q, 'profile_4');
220		};
221		ok(not $@) or diag $@;
222
223		$valid = $results->valid;
224		$invalid = $results->invalid; # as hash ref
225		@invalids = $results->invalid;
226		$missing = $results->missing;
227
228		ok(exists $valid->{'300x300_gif'}, 'expecting success with min_dimensions');
229		ok((grep /100x100/, @invalids), 'expecting failure with min_dimensions');
230
231		## file type tests
232		## with new interface
233		{
234		use Data::FormValidator::Constraints::Upload qw(file_format);
235
236		my $profile_5 = {
237		required=> [qw/hello_world 100x100_gif 300x300_gif/],
238		constraint_methods => {
239		'100x100_gif' => [ file_format( mime_types => [ qw(image/gif) ] ) ],
240		'300x300_gif' => [ file_format( mime_types => [ qw(image/png) ] ) ]
241		}
242		};
243
244		$dfv = Data::FormValidator->new({ profile_5 => $profile_5});
245		eval {
246		$results = $dfv->check($q, 'profile_5');
247		};
248
249		ok(not $@) or diag $@;
250
251		$valid = $results->valid;
252		$invalid = $results->invalid; # as hash ref
253		@invalids = $results->invalid;
254		$missing = $results->missing;
255
256		ok(exists $valid->{'100x100_gif'}, 'expecting success with mime_type');
257		ok((grep /300x300/, @invalids), 'expecting failure with mime_type');
258		}
259
260		## range checks with new format
261		{
262		use Data::FormValidator::Constraints::Upload qw(image_max_dimensions image_min_dimensions);
263		my $profile_6 = {
264		required => [ qw/hello_world 100x100_gif 300x300_gif/ ],
265		constraint_methods => {
266		'100x100_gif' => [
267		image_max_dimensions(200, 200),
268		image_min_dimensions(110, 100)
269		],
270		'300x300_gif' => [
271		image_max_dimensions(400, 400),
272		image_min_dimensions(245, 100)
273		]
274		}
275		};
276
277		$dfv = Data::FormValidator->new({ profile_6 => $profile_6});
278		eval {
279		$results = $dfv->check($q, 'profile_6');
280		};
281		is($@,'','survived eval');
282
283		$valid = $results->valid;
284		$invalid = $results->invalid; # as hash ref
285		@invalids = $results->invalid;
286		$missing = $results->missing;
287
288		ok((grep /100x100/, @invalids), 'expecting failure with size range');
289		ok(exists $valid->{'300x300_gif'}, 'expecting success with size range');
290
291		}
	117	for my $q ( $cgi_pm_q, $cgi_simple_q )
	118	{
	119	next unless $q;
	120	diag "Running tests with ", ref $q;
	121
	122	my $dfv = Data::FormValidator->new( { default => $default } );
	123	my $results;
	124	eval { $results = $dfv->check( $q, 'default' ); };
	125	is( $@, '', 'survived eval' );
	126
	127	my $valid = $results->valid;
	128	my $invalid = $results->invalid; # as hash ref
	129	my @invalids = $results->invalid;
	130	my $missing = $results->missing;
	131
	132	# Test to make sure hello world fails because it is the wrong type
	133	ok( ( grep { m/hello_world/ } @invalids ), 'expect format failure' );
	134
	135	# should fail on empty/missing source file data
	136	ok( ( grep { m/does_not_exist_gif/ } @invalids ),
	137	'expect non-existent failure' );
	138
	139	ok( ( exists $valid->{'100x100_gif'}, "valid" ),
	140	'Make sure 100x100 passes because it is the right type and size' );
	141
	142	my $meta = $results->meta('100x100_gif');
	143	is( ref $meta, 'HASH', 'meta() returns hash ref' );
	144
	145	ok( $meta->{extension}, 'setting extension meta data' );
	146	ok( $meta->{mime_type}, 'setting mime_type meta data' );
	147
	148	ok( ( grep { m/300x300/ } @invalids ),
	149	'300x300 should fail because it exceeds max_bytes' );
	150
	151	ok(
	152	( $results->meta('100x100_gif')->{bytes} > 0 ),
	153	( ref $q ) . ': setting bytes meta data'
	154	);
	155
	156	# Revalidate to usefully re-use the same fields
	157	my $profile_2 = {
	158	required => [qw/hello_world 100x100_gif 300x300_gif/],
	159	validator_packages => 'Data::FormValidator::Constraints::Upload',
	160	constraints => {
	161	'100x100_gif' => {
	162	constraint_method => 'image_max_dimensions',
	163	params => [ \200, \200 ],
	164	},
	165	'300x300_gif' => {
	166	constraint_method => 'image_max_dimensions',
	167	params => [ \200, \200 ],
	168	},
	169	},
	170	};
	171
	172	$dfv = Data::FormValidator->new( { profile_2 => $profile_2 } );
	173	eval { $results = $dfv->check( $q, 'profile_2' ); };
	174	ok( not $@ ) or diag $@;
	175
	176	$valid = $results->valid;
	177	$invalid = $results->invalid; # as hash ref
	178	@invalids = $results->invalid;
	179	$missing = $results->missing;
	180
	181	ok( exists $valid->{'100x100_gif'}, 'expecting success with max_dimensions' );
	182	ok( ( grep /300x300/, @invalids ), 'expecting failure with max_dimensions' );
	183
	184	ok( $results->meta('100x100_gif')->{width} > 0,
	185	'setting width as meta data' );
	186	ok( $results->meta('100x100_gif')->{width} > 0,
	187	'setting height as meta data' );
	188
	189	# Now test trying constraint_regxep_map
	190	my $profile_3 = {
	191	required => [qw/hello_world 100x100_gif 300x300_gif/],
	192	validator_packages => 'Data::FormValidator::Constraints::Upload',
	193	constraint_regexp_map => {
	194	'/[13]00x[13]00_gif/' => {
	195	constraint_method => 'image_max_dimensions',
	196	params => [ \200, \200 ],
	197	} } };
	198
	199	$dfv = Data::FormValidator->new( { profile_3 => $profile_3 } );
	200	( $valid, $missing, $invalid ) = $dfv->validate( $q, 'profile_3' );
	201
	202	ok( exists $valid->{'100x100_gif'},
	203	'expecting success with max_dimensions using constraint_regexp_map' );
	204	ok( ( grep { m/300x300/ } @$invalid ),
	205	'expecting failure with max_dimensions using constraint_regexp_map' );
	206
	207	## min test
	208	my $profile_4 = {
	209	required => [qw/hello_world 100x100_gif 300x300_gif/],
	210	validator_packages => 'Data::FormValidator::Constraints::Upload',
	211	constraints => {
	212	'100x100_gif' => {
	213	constraint_method => 'image_min_dimensions',
	214	params => [ \200, \200 ],
	215	},
	216	'300x300_gif' => {
	217	constraint_method => 'image_min_dimensions',
	218	params => [ \200, \200 ],
	219	},
	220	},
	221	};
	222
	223	$dfv = Data::FormValidator->new( { profile_4 => $profile_4 } );
	224	eval { $results = $dfv->check( $q, 'profile_4' ); };
	225	ok( not $@ ) or diag $@;
	226
	227	$valid = $results->valid;
	228	$invalid = $results->invalid; # as hash ref
	229	@invalids = $results->invalid;
	230	$missing = $results->missing;
	231
	232	ok( exists $valid->{'300x300_gif'}, 'expecting success with min_dimensions' );
	233	ok( ( grep /100x100/, @invalids ), 'expecting failure with min_dimensions' );
	234
	235	## file type tests
	236	## with new interface
	237	{
	238	use Data::FormValidator::Constraints::Upload qw(file_format);
	239
	240	my $profile_5 = {
	241	required => [qw/hello_world 100x100_gif 300x300_gif/],
	242	constraint_methods => {
	243	'100x100_gif' => [ file_format( mime_types => [qw(image/gif)] ) ],
	244	'300x300_gif' => [ file_format( mime_types => [qw(image/png)] ) ] } };
	245
	246	$dfv = Data::FormValidator->new( { profile_5 => $profile_5 } );
	247	eval { $results = $dfv->check( $q, 'profile_5' ); };
	248
	249	ok( not $@ ) or diag $@;
	250
	251	$valid = $results->valid;
	252	$invalid = $results->invalid; # as hash ref
	253	@invalids = $results->invalid;
	254	$missing = $results->missing;
	255
	256	ok( exists $valid->{'100x100_gif'}, 'expecting success with mime_type' );
	257	ok( ( grep /300x300/, @invalids ), 'expecting failure with mime_type' );
	258	}
	259
	260	## range checks with new format
	261	{
	262	use Data::FormValidator::Constraints::Upload
	263	qw(image_max_dimensions image_min_dimensions);
	264	my $profile_6 = {
	265	required => [qw/hello_world 100x100_gif 300x300_gif/],
	266	constraint_methods => {
	267	'100x100_gif' => [
	268	image_max_dimensions( 200, 200 ), image_min_dimensions( 110, 100 )
	269	],
	270	'300x300_gif' => [
	271	image_max_dimensions( 400, 400 ), image_min_dimensions( 245, 100 ) ] }
	272	};
	273
	274	$dfv = Data::FormValidator->new( { profile_6 => $profile_6 } );
	275	eval { $results = $dfv->check( $q, 'profile_6' ); };
	276	is( $@, '', 'survived eval' );
	277
	278	$valid = $results->valid;
	279	$invalid = $results->invalid; # as hash ref
	280	@invalids = $results->invalid;
	281	$missing = $results->missing;
	282
	283	ok( ( grep /100x100/, @invalids ), 'expecting failure with size range' );
	284	ok( exists $valid->{'300x300_gif'}, 'expecting success with size range' );
	285
	286	}
292	287
293	288	} ## end of for loop
294	289
295		## end of tests
	290	done_testing;

+93

-97

t/upload_closure.t less more

0		#########################
	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
	3	use Test::More;
1	4
2		use Test::More 'no_plan';
3		use strict;
4		BEGIN {
5		use_ok('CGI');
6		use_ok('Data::FormValidator::Constraints::Upload')
7		};
	5	BEGIN
	6	{
	7	eval { require CGI;CGI->VERSION(4.35); };
	8	plan skip_all => 'CGI 4.35 or higher not found' if $@;
	9	use_ok('CGI');
	10	use_ok('Data::FormValidator::Constraints::Upload');
	11	}
8	12
9	13	#########################
10	14
11	15	%ENV = (
12		%ENV,
13		'SCRIPT_NAME' => '/test.cgi',
14		'SERVER_NAME' => 'perl.org',
15		'HTTP_CONNECTION' => 'TE, close',
16		'REQUEST_METHOD' => 'POST',
17		'SCRIPT_URI' => 'http://www.perl.org/test.cgi',
18		'CONTENT_LENGTH' => 3129,
19		'SCRIPT_FILENAME' => '/home/usr/test.cgi',
20		'SERVER_SOFTWARE' => 'Apache/1.3.27 (Unix) ',
21		'HTTP_TE' => 'deflate,gzip;q=0.3',
22		'QUERY_STRING' => '',
23		'REMOTE_PORT' => '1855',
24		'HTTP_USER_AGENT' => 'Mozilla/5.0 (compatible; Konqueror/2.1.1; X11)',
25		'SERVER_PORT' => '80',
26		'REMOTE_ADDR' => '127.0.0.1',
27		'CONTENT_TYPE' => 'multipart/form-data; boundary=xYzZY',
28		'SERVER_PROTOCOL' => 'HTTP/1.1',
29		'PATH' => '/usr/local/bin:/usr/bin:/bin',
30		'REQUEST_URI' => '/test.cgi',
31		'GATEWAY_INTERFACE' => 'CGI/1.1',
32		'SCRIPT_URL' => '/test.cgi',
33		'SERVER_ADDR' => '127.0.0.1',
34		'DOCUMENT_ROOT' => '/home/develop',
35		'HTTP_HOST' => 'www.perl.org'
	16	%ENV,
	17	'SCRIPT_NAME' => '/test.cgi',
	18	'SERVER_NAME' => 'perl.org',
	19	'HTTP_CONNECTION' => 'TE, close',
	20	'REQUEST_METHOD' => 'POST',
	21	'SCRIPT_URI' => 'http://www.perl.org/test.cgi',
	22	'CONTENT_LENGTH' => 3129,
	23	'SCRIPT_FILENAME' => '/home/usr/test.cgi',
	24	'SERVER_SOFTWARE' => 'Apache/1.3.27 (Unix) ',
	25	'HTTP_TE' => 'deflate,gzip;q=0.3',
	26	'QUERY_STRING' => '',
	27	'REMOTE_PORT' => '1855',
	28	'HTTP_USER_AGENT' => 'Mozilla/5.0 (compatible; Konqueror/2.1.1; X11)',
	29	'SERVER_PORT' => '80',
	30	'REMOTE_ADDR' => '127.0.0.1',
	31	'CONTENT_TYPE' => 'multipart/form-data; boundary=xYzZY',
	32	'SERVER_PROTOCOL' => 'HTTP/1.1',
	33	'PATH' => '/usr/local/bin:/usr/bin:/bin',
	34	'REQUEST_URI' => '/test.cgi',
	35	'GATEWAY_INTERFACE' => 'CGI/1.1',
	36	'SCRIPT_URL' => '/test.cgi',
	37	'SERVER_ADDR' => '127.0.0.1',
	38	'DOCUMENT_ROOT' => '/home/develop',
	39	'HTTP_HOST' => 'www.perl.org'
36	40	);
37	41
38	42	diag "testing with CGI.pm version: $CGI::VERSION";
39	43
40		open(IN,'<t/upload_post_text.txt') \|\| die 'missing test file';
	44	open( IN, '<t/upload_post_text.txt' ) \|\| die 'missing test file';
41	45	binmode(IN);
42	46
43	47	STDIN = IN;

45	49
46	50	use Data::FormValidator;
47	51	use Data::FormValidator::Constraints::Upload qw(
48		&file_format
49		&file_max_bytes
50		&image_max_dimensions
	52	&file_format
	53	&file_max_bytes
	54	&image_max_dimensions
51	55	);
52	56
53	57	my $default = {
54		required=>[qw/hello_world does_not_exist_gif 100x100_gif 300x300_gif/],
55		validator_packages=> 'Data::FormValidator::Constraints::Upload',
56		constraint_methods => {
57		'hello_world' => file_format(),
58		'does_not_exist_gif' => file_format(),
59		'100x100_gif' => [
60		file_format(),
61		file_max_bytes(),
62		],
63		'300x300_gif' => file_max_bytes(100),
64		},
65		};
	58	required => [qw/hello_world does_not_exist_gif 100x100_gif 300x300_gif/],
	59	validator_packages => 'Data::FormValidator::Constraints::Upload',
	60	constraint_methods => {
	61	'hello_world' => file_format(),
	62	'does_not_exist_gif' => file_format(),
	63	'100x100_gif' => [ file_format(), file_max_bytes(), ],
	64	'300x300_gif' => file_max_bytes(100),
	65	},
	66	};
66	67
67		my $dfv = Data::FormValidator->new({ default => $default});
	68	my $dfv = Data::FormValidator->new( { default => $default } );
68	69	my ($results);
69		eval {
70		$results = $dfv->check($q, 'default');
71		};
72		is($@, '', 'survived eval');
	70	eval { $results = $dfv->check( $q, 'default' ); };
	71	is( $@, '', 'survived eval' );
73	72
74		my $valid = $results->valid;
75		my $invalid = $results->invalid; # as hash ref
	73	my $valid = $results->valid;
	74	my $invalid = $results->invalid; # as hash ref
76	75	my @invalids = $results->invalid;
77		my $missing = $results->missing;
78
	76	my $missing = $results->missing;
79	77
80	78	# Test to make sure hello world fails because it is the wrong type
81		ok((grep {m/hello_world/} @invalids), 'expect format failure');
	79	ok( ( grep { m/hello_world/ } @invalids ), 'expect format failure' );
82	80
83	81	# should fail on empty/missing source file data
84		ok((grep {m/does_not_exist_gif/} @invalids), 'expect non-existent failure');
85
	82	ok( ( grep { m/does_not_exist_gif/ } @invalids ),
	83	'expect non-existent failure' );
86	84
87	85	# Make sure 100x100 passes because it is the right type and size
88		ok(exists $valid->{'100x100_gif'});
	86	ok( exists $valid->{'100x100_gif'} );
89	87
90	88	my $meta = $results->meta('100x100_gif');
91		is(ref $meta, 'HASH', 'meta() returns hash ref');
	89	is( ref $meta, 'HASH', 'meta() returns hash ref' );
92	90
93		ok($meta->{extension}, 'setting extension meta data');
94		ok($meta->{mime_type}, 'setting mime_type meta data');
	91	ok( $meta->{extension}, 'setting extension meta data' );
	92	ok( $meta->{mime_type}, 'setting mime_type meta data' );
95	93
96	94	# 300x300 should fail because it is too big
97		ok((grep {m/300x300/} @invalids), 'max_bytes');
	95	ok( ( grep { m/300x300/ } @invalids ), 'max_bytes' );
98	96
99		ok($results->meta('100x100_gif')->{bytes}>0, 'setting bytes meta data');
100
	97	ok( $results->meta('100x100_gif')->{bytes} > 0, 'setting bytes meta data' );
101	98
102	99	# Revalidate to usefully re-use the same fields
103		my $profile_2 = {
104		required=>[qw/hello_world 100x100_gif 300x300_gif/],
105		validator_packages=> 'Data::FormValidator::Constraints::Upload',
106		constraint_methods => {
107		'100x100_gif' => image_max_dimensions(200,200),
108		'300x300_gif' => image_max_dimensions(200,200),
109		},
	100	my $profile_2 = {
	101	required => [qw/hello_world 100x100_gif 300x300_gif/],
	102	validator_packages => 'Data::FormValidator::Constraints::Upload',
	103	constraint_methods => {
	104	'100x100_gif' => image_max_dimensions( 200, 200 ),
	105	'300x300_gif' => image_max_dimensions( 200, 200 ),
	106	},
110	107	};
111	108
112		$dfv = Data::FormValidator->new({ profile_2 => $profile_2});
113		eval {
114		$results = $dfv->check($q, 'profile_2');
115		};
116		is($@,'', 'survived eval');
	109	$dfv = Data::FormValidator->new( { profile_2 => $profile_2 } );
	110	eval { $results = $dfv->check( $q, 'profile_2' ); };
	111	is( $@, '', 'survived eval' );
117	112
118		$valid = $results->valid;
119		$invalid = $results->invalid; # as hash ref
	113	$valid = $results->valid;
	114	$invalid = $results->invalid; # as hash ref
120	115	@invalids = $results->invalid;
121		$missing = $results->missing;
	116	$missing = $results->missing;
122	117
123		ok(exists $valid->{'100x100_gif'}, 'expecting success with max_dimensions');
124		ok((grep /300x300/, @invalids), 'expecting failure with max_dimensions');
	118	ok( exists $valid->{'100x100_gif'}, 'expecting success with max_dimensions' );
	119	ok( ( grep /300x300/, @invalids ), 'expecting failure with max_dimensions' );
125	120
126		ok( $results->meta('100x100_gif')->{width} > 0, 'setting width as meta data');
127		ok( $results->meta('100x100_gif')->{width} > 0, 'setting height as meta data');
	121	ok( $results->meta('100x100_gif')->{width} > 0, 'setting width as meta data' );
	122	ok( $results->meta('100x100_gif')->{width} > 0, 'setting height as meta data' );
128	123
129	124	# Now test trying constraint_regxep_map
130		my $profile_3 = {
131		required=>[qw/hello_world 100x100_gif 300x300_gif/],
132		validator_packages=> 'Data::FormValidator::Constraints::Upload',
133		constraint_method_regexp_map => {
134		'/[13]00x[13]00_gif/' => image_max_dimensions(200,200),
135		}
136		};
	125	my $profile_3 = {
	126	required => [qw/hello_world 100x100_gif 300x300_gif/],
	127	validator_packages => 'Data::FormValidator::Constraints::Upload',
	128	constraint_method_regexp_map => {
	129	'/[13]00x[13]00_gif/' => image_max_dimensions( 200, 200 ),
	130	} };
137	131
138		$dfv = Data::FormValidator->new({ profile_3 => $profile_3});
139		($valid,$missing,$invalid) = $dfv->validate($q, 'profile_3');
	132	$dfv = Data::FormValidator->new( { profile_3 => $profile_3 } );
	133	( $valid, $missing, $invalid ) = $dfv->validate( $q, 'profile_3' );
140	134
141		ok(exists $valid->{'100x100_gif'}, 'expecting success with max_dimensions using constraint_regexp_map');
142		ok((grep {m/300x300/} @$invalid), 'expecting failure with max_dimensions using constraint_regexp_map');
	135	ok( exists $valid->{'100x100_gif'},
	136	'expecting success with max_dimensions using constraint_regexp_map' );
	137	ok( ( grep { m/300x300/ } @$invalid ),
	138	'expecting failure with max_dimensions using constraint_regexp_map' );
143	139
144
	140	done_testing;

+14

-21

t/upload_mime_types.t less more

	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
	3	use Test::More tests => 5;
	4	use_ok('Data::FormValidator::Constraints::Upload');
	5
0	6	# Exercise the _is_allowed_type() helper function
1	7
2		use Test::More tests => 5;
3		use strict;
4		use_ok('Data::FormValidator::Constraints::Upload');
5
6	8	# Test the negative case
7		isnt(
8		Data::FormValidator::Constraints::Upload::_is_allowed_type('foo'),
9		1, "'foo' not considered an allowed mime type"
10		);
	9	isnt( Data::FormValidator::Constraints::Upload::_is_allowed_type('foo'),
	10	1, "'foo' not considered an allowed mime type" );
11	11
12	12	# Reality check that a simple jpeg is allowed
13		is(
14		Data::FormValidator::Constraints::Upload::_is_allowed_type('image/jpeg'),
15		1, "'image/jpeg' is considered an allowed mime type"
16		);
	13	is( Data::FormValidator::Constraints::Upload::_is_allowed_type('image/jpeg'),
	14	1, "'image/jpeg' is considered an allowed mime type" );
17	15
18	16	# Check that we handle case insensitivity
19		is(
20		Data::FormValidator::Constraints::Upload::_is_allowed_type('image/JPEG'),
21		1, "'image/JPEG' is considered an allowed mime type"
22		);
	17	is( Data::FormValidator::Constraints::Upload::_is_allowed_type('image/JPEG'),
	18	1, "'image/JPEG' is considered an allowed mime type" );
23	19
24	20	# Also ensure progressive jpegs are allowed
25		is(
26		Data::FormValidator::Constraints::Upload::_is_allowed_type('image/pjpeg'),
27		1, "'image/pjpeg' is considered an allowed mime type"
28		);
29
	21	is( Data::FormValidator::Constraints::Upload::_is_allowed_type('image/pjpeg'),
	22	1, "'image/pjpeg' is considered an allowed mime type" );

t/upload_post_text.txt less more

Binary diff not shown