Data-FormValidator-4.88/0000755000175000017500000000000013151007442015242 5ustar dfarrelldfarrellData-FormValidator-4.88/test/0000755000175000017500000000000013151007442016221 5ustar dfarrelldfarrellData-FormValidator-4.88/test/00_base.profile0000644000175000017500000000020113150655017021013 0ustar dfarrelldfarrell{ profile1 => { required => [qw/billy bob/], }, profile2 => { required => [qw/susie may/], }, } Data-FormValidator-4.88/test/00_base.badformat0000644000175000017500000000010513150655017021315 0ustar dfarrelldfarrell# This file is to test returning the wrong kind of profile format [] Data-FormValidator-4.88/MANIFEST0000644000175000017500000000402613151007442016375 0ustar dfarrelldfarrellChanges lib/Data/FormValidator.pm lib/Data/FormValidator/Constraints.pm lib/Data/FormValidator/Constraints/Dates.pm lib/Data/FormValidator/Constraints/Upload.pm lib/Data/FormValidator/ConstraintsFactory.pm lib/Data/FormValidator/Filters.pm lib/Data/FormValidator/Results.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP README.pod RELEASE_NOTES t/00_base.t t/02_code_ref.t t/03_dependency.t t/04_arrayify_undef.t t/05_valid_ip_address.t t/06_regexp_map.t t/09_require_some.t t/11_procedural_match.t t/13_validator_packages.t t/15_literal_param_constraints.t t/16_cgi_object.t t/17_multi_valued_keys.t t/18_constraint_refs.t t/19_refs_as_values.t t/20_careful_exception_handling.t t/21_multiple_fields.t t/25_results.t t/26_qr.t t/27_qualify_ref_happy_death.t t/28_defaults_for_new.t t/30_filter_definedness.t t/any_errors.t t/check_profile_syntax.t t/closure_msgs.t t/constraint_method.t t/constraint_method_string.t t/constraint_method_zero.t t/constraint_regexp_map_profile_reuse.t t/constraints_builtin.t t/constraints_builtin_closure.t t/constraints_factory.t t/constraints_invalid_once_only.t t/constraints_num_values.t t/constraints_regexp_map_interaction.t t/constraints_reuse.t t/credit_card.t t/dates.t t/dates_closure.t t/dependency_coderef.t t/dependency_groups.t t/filter_constraints.t t/filters_builtin.t t/filters_shouldnt_modify.t t/FV_length.t t/get_filtered_data.t t/get_input_data.t t/missing_optional.t t/msgs.t t/multiple_constraints.t t/params_not_mentioned.t t/pod.t t/procedural_valid.t t/profile_checking.t t/regexp_common.t t/regexp_common_closure.t t/rename_builtin_constraints.t t/results_success.t t/simple.t t/tt_and_overload.t t/undefined_arrayref.t t/unknown.t t/untaint.pl t/untaint.t t/upload.t t/upload_closure.t t/upload_mime_types.t t/upload_post_text.txt t/ValidatorPackagesTest1.pm t/ValidatorPackagesTest2.pm test/00_base.badformat test/00_base.profile META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Data-FormValidator-4.88/META.yml0000664000175000017500000000163513151007442016522 0ustar dfarrelldfarrell--- abstract: 'Validates user input (usually from an HTML form) based on input profile.' author: - 'David Farrell ' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Data-FormValidator no_index: directory: - t - inc package: - Data::FormValidator::Constraints::RegexpCommon requires: Date::Calc: '5' Email::Valid: '0' File::MMagic: '1.17' File::Spec: '0' Image::Size: '0' MIME::Types: '1.005' Regexp::Common: '0.03' Scalar::Util: '0' Test::More: '0' perl: '5.008' resources: repository: https://github.com/dnmfarrell/Data-FormValidator version: 4.88 x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Data-FormValidator-4.88/MANIFEST.SKIP0000644000175000017500000000067013150655017017151 0ustar dfarrelldfarrell# This is a list of regular expressions of files to skip when rebuilding # the MANIFEST file. See the documention for the ExtUtils::Manifest module for more detail. -mls \bCVS\b ^MANIFEST\.bak$ ^Makefile$ ~$ \.old$ \.bak$ ^blib/ ^pm_to_blib$ ^MakeMaker-\d .tar.gz$ ^notes ^releases \.tgz$ \.tmp$ \.swp$ \.swm$ \.swn$ \.swo$ \.patch$ \.orig$ \.diff$ \.rej$ _darcs _build patches lib/Perl6 rejects ^Build$ \.git ^MYMETA.yml$ ^MYMETA\.json$ Data-FormValidator-4.88/META.json0000664000175000017500000000310013151007442016657 0ustar dfarrelldfarrell{ "abstract" : "Validates user input (usually from an HTML form) based on input profile.", "author" : [ "David Farrell " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Data-FormValidator", "no_index" : { "directory" : [ "t", "inc" ], "package" : [ "Data::FormValidator::Constraints::RegexpCommon" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Date::Calc" : "5", "Email::Valid" : "0", "File::MMagic" : "1.17", "File::Spec" : "0", "Image::Size" : "0", "MIME::Types" : "1.005", "Regexp::Common" : "0.03", "Scalar::Util" : "0", "Test::More" : "0", "perl" : "5.008" } } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "https://github.com/dnmfarrell/Data-FormValidator", "web" : "https://github.com/dnmfarrell/Data-FormValidator" } }, "version" : 4.88, "x_serialization_backend" : "JSON::PP version 2.27400_02" } Data-FormValidator-4.88/lib/0000755000175000017500000000000013151007442016010 5ustar dfarrelldfarrellData-FormValidator-4.88/lib/Data/0000755000175000017500000000000013151007442016661 5ustar dfarrelldfarrellData-FormValidator-4.88/lib/Data/FormValidator.pm0000644000175000017500000012470313151006761022002 0ustar dfarrelldfarrell # FormValidator.pm - Object that validates form input data. # # This file is part of Data::FormValidator. # # Author: Francis J. Lacoste # Previous Maintainer: Mark Stosberg # Maintainer: David Farrell # # Copyright (C) 1999 Francis J. Lacoste, iNsu Innovations # Parts Copyright 1996-1999 by Michael J. Heins # Parts Copyright 1996-1999 by Bruce Albrecht # Parts Copyright 2001-2005 by Mark Stosberg # # Parts of this module are based on work by # Bruce Albrecht, contributed to # MiniVend. # # Parts also based on work by Michael J. Heins # # This program is free software; you can redistribute it and/or modify # it under the terms same terms as perl itself. package Data::FormValidator; use Exporter 'import'; use File::Spec qw(); use 5.008; use Data::FormValidator::Results; *_arrayify = \&Data::FormValidator::Results::_arrayify; use Data::FormValidator::Filters ':filters'; use Data::FormValidator::Constraints qw(:validators :matchers); our $VERSION = 4.88; our %EXPORT_TAGS = ( filters => [qw/ filter_alphanum filter_decimal filter_digit filter_dollars filter_integer filter_lc filter_neg_decimal filter_neg_integer filter_phone filter_pos_decimal filter_pos_integer filter_quotemeta filter_sql_wildcard filter_strip filter_trim filter_uc filter_ucfirst /], validators => [qw/ valid_american_phone valid_cc_exp valid_cc_number valid_cc_type valid_email valid_ip_address valid_phone valid_postcode valid_province valid_state valid_state_or_province valid_zip valid_zip_or_postcode /], matchers => [qw/ match_american_phone match_cc_exp match_cc_number match_cc_type match_email match_ip_address match_phone match_postcode match_province match_state match_state_or_province match_zip match_zip_or_postcode /], ); our @EXPORT_OK = (@{ $EXPORT_TAGS{filters} }, @{ $EXPORT_TAGS{validators} }, @{ $EXPORT_TAGS{matchers} }); use strict; use Symbol; sub DESTROY {} =pod =head1 NAME Data::FormValidator - Validates user input (usually from an HTML form) based on input profile. =head1 SYNOPSIS use Data::FormValidator; my $results = Data::FormValidator->check(\%input_hash, \%dfv_profile); if ($results->has_invalid or $results->has_missing) { # do something with $results->invalid, $results->missing # or $results->msgs } else { # do something with $results->valid } =head1 DESCRIPTION Data::FormValidator's main aim is to make input validation expressible in a simple format. Data::FormValidator lets you define profiles which declare the required and optional fields and any constraints they might have. The results are provided as an object, which makes it easy to handle missing and invalid results, return error messages about which constraints failed, or process the resulting valid data. =cut sub new { my $proto = shift; my $profiles_or_file = shift; my $defaults = shift; my $class = ref $proto || $proto; if ($defaults) { ref $defaults eq 'HASH' or die 'second argument to new must be a hash ref'; } my ($file, $profiles); if (ref $profiles_or_file) { $profiles = $profiles_or_file; } else { $file = File::Spec->rel2abs( $profiles_or_file ); } bless { profile_file => $file, profiles => $profiles, defaults => $defaults, }, $class; } =head1 VALIDATING INPUT =head2 check() my $results = Data::FormValidator->check(\%input_hash, \%dfv_profile); C is the recommended method to use to validate forms. It returns its results as a L object. A deprecated method C described below is also available, returning its results as an array. use Data::FormValidator; my $results = Data::FormValidator->check(\%input_hash, \%dfv_profile); Here, C is used as a class method, and takes two required parameters. The first a reference to the data to be be validated. This can either be a hash reference, or a CGI.pm-like object. In particular, the object must have a param() method that works like the one in CGI.pm does. CGI::Simple and Apache::Request objects are known to work in particular. Note that if you use a hash reference, multiple values for a single key should be presented as an array reference. The second argument is a reference to the profile you are validating. =head2 validate() my( $valids, $missings, $invalids, $unknowns ) = Data::FormValidator->validate( \%input_hash, \%dfv_profile); C provides a deprecated alternative to C. It has the same input syntax, but returns a four element array, described as follows =over =item valids This is a hash reference to the valid fields which were submitted in the data. The data may have been modified by the various filters specified. =item missings This is a reference to an array which contains the name of the missing fields. Those are the fields that the user forget to fill or filled with spaces. These fields may comes from the I list or the I list. =item invalids This is a reference to an array which contains the name of the fields which failed one or more of their constraint checks. If there are no invalid fields, an empty arrayref will be returned. Fields defined with multiple constraints will have an array ref returned in the @invalids array instead of a string. The first element in this array is the name of the field, and the remaining fields are the names of the failed constraints. =item unknowns This is a list of fields which are unknown to the profile. Whether or not this indicates an error in the user input is application dependent. =back =head2 new() Using C is only needed for advanced usage, including these cases: =over =item o Loading more than one profile at a time. Then you can select the profile you want by name later with C. Here's an example: my $dfv = Data::FormValidator->new({ profile_1 => { # usual profile definition here }, profile_2 => { # another profile definition }, }); As illustrated, multiple profiles are defined through a hash ref whose keys point to profile definitions. You can also load several profiles from a file, by defining several profiles as shown above in an external file. Then just pass in the name of the file: my $dfv = Data::FormValidator->new('/path/to/profiles.pl'); If the input profile is specified as a file name, the profiles will be reread each time that the disk copy is modified. Now when calling C, you just need to supply the profile name: my $results = $dfv->check(\%input_hash,'profile_1'); =item o Applying defaults to more than one input profile. There are some parts of the validation profile that you might like to re-use for many form validations. To facilitate this, C takes a second argument, a hash reference. Here the usual input profile definitions can be made. These will act as defaults for any subsequent calls to C on this object. Currently the logic for this is very simple. Any definition of a key in your validation profile will completely overwrite your default value. This means you can't define two keys for C and expect they will always be there. This kind of feature may be added in the future. The exception here is definitions for your C key. You will safely be able to define some defaults for the top level keys within C and not have them clobbered just because C was defined in a validation profile. One way to use this feature is to create your own sub-class that always provides your defaults to C. Another option is to create your own wrapper routine which provides these defaults to C. Here's an example of a routine you might put in a L super-class to make use of this feature: # Always use the built-in CGI object as the form data # and provide some defaults to new constructor sub check_form { my $self = shift; my $profile = shift || die 'check_form: missing required profile'; require Data::FormValidator; my $dfv = Data::FormValidator->new({},{ # your defaults here }); return $dfv->check($self->query,$profile); } =back =cut sub validate { my ($self,$data,$name) = @_; my $data_set = $self->check( $data,$name ); my $valid = $data_set->valid(); my $missing = $data_set->missing(); my $invalid = $data_set->{validate_invalid} || []; my $unknown = [ $data_set->unknown ]; return ( $valid, $missing, $invalid, $unknown ); } sub check { my ( $self, $data, $name ) = @_; # check can be used as a class method for simple cases if (not ref $self) { my $class = $self; $self = {}; bless $self, $class; } my $profile; if ( ref $name ) { $profile = $name; } else { $self->load_profiles; $profile = $self->{profiles}{$name}; die "No such profile $name\n" unless $profile; } die "input profile must be a hash ref" unless ref $profile eq "HASH"; # add in defaults from new(), if any if ($self->{defaults}) { $profile = { %{$self->{defaults}}, %$profile }; } # check the profile syntax or die with an error. _check_profile_syntax($profile); my $results = Data::FormValidator::Results->new( $profile, $data ); # As a special case, pass through any defaults for the 'msgs' key. $results->msgs($self->{defaults}->{msgs}) if $self->{defaults}->{msgs}; return $results; } =head1 INPUT PROFILE SPECIFICATION An input profile is a hash reference containing one or more of the following keys. Here is a very simple input profile. Examples of more advanced options are described below. use Data::FormValidator::Constraints qw(:closures); my $profile = { optional => [qw( company fax country )], required => [qw( fullname phone email address )], constraint_methods => { email => email(), } }; That defines some fields as optional, some as required, and defines that the field named 'email' must pass the constraint named 'email'. Here is a complete list of the keys available in the input profile, with examples of each. =head2 required This is an array reference which contains the name of the fields which are required. Any fields in this list which are not present or contain only spaces will be reported as missing. =head2 required_regexp required_regexp => qr/city|state|zipcode/, This is a regular expression used to specify additional field names for which values will be required. =head2 require_some require_some => { # require any two fields from this group city_or_state_or_zipcode => [ 2, qw/city state zipcode/ ], } This is a reference to a hash which defines groups of fields where 1 or more fields from the group should be required, but exactly which fields doesn't matter. The keys in the hash are the group names. These are returned as "missing" unless the required number of fields from the group has been filled in. The values in this hash are array references. The first element in this array should be the number of fields in the group that is required. If the first field in the array is not an a digit, a default of "1" will be used. =head2 optional optional => [qw/meat coffee chocolate/], This is an array reference which contains the name of optional fields. These are fields which MAY be present and if they are, they will be checked for valid input. Any fields not in optional or required list will be reported as unknown. =head2 optional_regexp optional_regexp => qr/_province$/, This is a regular expression used to specify additional fields which are optional. For example, if you wanted all fields names that begin with I to be optional, you could use the regular expression, /^user_/ =head2 dependencies dependencies => { # If cc_no is entered, make cc_type and cc_exp required "cc_no" => [ qw( cc_type cc_exp ) ], # if pay_type eq 'check', require check_no "pay_type" => { check => [ qw( check_no ) ], } # if cc_type is VISA or MASTERCARD require CVV "cc_type" => sub { my $dfv = shift; my $type = shift; return [ 'cc_cvv' ] if ($type eq "VISA" || $type eq "MASTERCARD"); return [ ]; }, }, This is for the case where an optional field has other requirements. The dependent fields can be specified with an array reference. If the dependencies are specified with a hash reference then the additional constraint is added that the optional field must equal a key for the dependencies to be added. If the dependencies are specified as a code reference then the code will be executed to determine the dependent fields. It is passed two parameters, the object and the value of the field, and it should return an array reference containing the list of dependent fields. Any fields in the dependencies list that are missing when the target is present will be reported as missing. =head2 dependency_groups dependency_groups => { # if either field is filled in, they all become required password_group => [qw/password password_confirmation/], } This is a hash reference which contains information about groups of interdependent fields. The keys are arbitrary names that you create and the values are references to arrays of the field names in each group. =head2 dependencies_regexp dependencies_regexp => { qr/Line\d+\_ItemType$/ => sub { my $dfv = shift; my $itemtype = shift; my $field = shift; if ($type eq 'NeedsBatteries') { my ($prefix, $suffix) = split(/\_/, $field); return([$prefix . '_add_batteries]); } else { return([]); } }, }, This is a regular expression used to specify additional fields which are dependent. For example, if you wanted to add dependencies for all fields which meet a certain criteria (such as multiple items in a shopping cart) where you do not know before hand how many of such fields you may have. =head2 dependent_optionals dependent_optionals => { # If delivery_address is specified then delivery_notes becomes optional "delivery_address" => [ qw( delivery_notes ) ], # if delivery_type eq 'collection', collection_notes becomes optional "delivery_type" => { collection => [ qw( collection_notes ) ], } # if callback_type is "phone" or "email" then additional_notes becomes optional "callback_type" => sub { my $dfv = shift; my $type = shift; if ($type eq 'phone' || $type eq 'email') { return(['additional_notes']); } else { return([]); } }, }, This is for the case where an optional field can trigger other optional fields. The dependent optional fields can be specified with an array reference. If the dependent optional fields are specified with a hash reference, then an additional constraint is added that the optional field must equal a key for the additional optional fields to be added. If the dependent optional fields are specified as a code reference then the code will be executed to determine the additional optional fields. It is passed two parameters, the object and the value of the field, and it should return an array reference containing the list of additional optional fields. =head2 dependent_require_some dependent_require_some => { # require any fields from this group if AddressID is "new" AddressID => sub { my $dfv = shift; my $value = shift; if ($value eq 'new') { return({ house_name_or_number => [ 1, 'HouseName', 'HouseNumber' ], }); } else { return; } }, } Sometimes a field will need to trigger additional dependencies but you only require some of the fields. You cannot set them all to be dependent as you might only have some of them, and you cannot set them all to be optional as you must have some of them. This method allows you to specify this in a similar way to the equire_some method but dependent upon other values. In the example above if the AddressID submitted is "new" then at least 1 of HouseName and HouseNumber must also be supplied. See require_some for the valid options for the return. =head2 defaults defaults => { country => "USA", }, This is a hash reference where keys are field names and values are defaults to use if input for the field is missing. The values can be code refs which will be used to calculate the value if needed. These code refs will be passed in the DFV::Results object as the only parameter. The defaults are set shortly before the constraints are applied, and will be returned with the other valid data. =head2 defaults_regexp_map defaults_regexp_map => { qr/^opt_/ => 1, }, This is a hash reference that maps regular expressions to default values to use for matching optional or required fields. It's useful if you have generated many checkbox fields with the similar names. Since checkbox fields submit nothing at all when they are not checked, it's useful to set defaults for them. Note that it doesn't make sense to use a default for a field handled by C or C. When the field is not submitted, there is no way to know that it should be optional or required, and thus there's no way to know that a default should be set for it. =head2 filters # trim leading and trailing whitespace on all fields filters => ['trim'], This is a reference to an array of filters that will be applied to ALL optional and required fields, B any constraints are applied. This can be the name of a built-in filter (trim,digit,etc) or an anonymous subroutine which should take one parameter, the field value and return the (possibly) modified value. Filters modify the data returned through the results object, so use them carefully. See L for details on the built-in filters. =head2 field_filters field_filters => { cc_no => ['digit'], }, A hash ref with field names as keys. Values are array references of built-in filters to apply (trim,digit,etc) or an anonymous subroutine which should take one parameter, the field value and return the (possibly) modified value. Filters are applied B any constraints are applied. See L for details on the built-in filters. =head2 field_filter_regexp_map field_filter_regexp_map => { # Upper-case the first letter of all fields that end in "_name" qr/_name$/ => ['ucfirst'], }, 'field_filter_regexp_map' is used to apply filters to fields that match a regular expression. This is a hash reference where the keys are the regular expressions to use and the values are references to arrays of filters which will be applied to specific input fields. Just as with 'field_filters', you can you use a built-in filter or use a coderef to supply your own. =head2 constraint_methods use Data::FormValidator::Constraints qw(:closures); constraint_methods => { cc_no => cc_number({fields => ['cc_type']}), cc_type => cc_type(), cc_exp => cc_exp(), }, A hash ref which contains the constraints that will be used to check whether or not the field contains valid data. B To use the built-in constraints, they need to first be loaded into your name space using the syntax above. (Unless you are using the old C key, documented in L). The keys in this hash are field names. The values can be any of the following: =over =item o A named constraint. B: my_zipcode_field => zip(), See L for the details of which built-in constraints that are available. =item o A perl regular expression B: my_zipcode_field => qr/^\d{5}$/, # match exactly 5 digits If this field is named in C or C, or C is effective, be aware of the following: If you write your own regular expressions and only match part of the string then you'll only get part of the string in the valid hash. It is a good idea to write you own constraints like /^regex$/. That way you match the whole string. =item o a subroutine reference, to supply custom code This will check the input and return true or false depending on the input's validity. By default, the constraint function receives a L object as its first argument, and the value to be validated as the second. To validate a field based on more inputs than just the field itself, see L. B: # Notice the use of 'pop'-- # the object is the first arg passed to the method # while the value is the second, and last arg. my_zipcode_field => sub { my $val = pop; return $val =~ '/^\d{5}$/' }, # OR you can reference a subroutine, which should work like the one above my_zipcode_field => \&my_validation_routine, # An example of setting the constraint name. my_zipcode_field => sub { my ($dfv, $val) = @_; $dfv->set_current_constraint_name('my_constraint_name'); return $val =~ '/^\d{5}$/' }, =item o an array reference An array reference is used to apply multiple constraints to a single field. Any of the above options are valid entries the array. See L below. For more details see L. =back =head2 constraint_method_regexp_map use Data::FormValidator::Constraints qw(:closures); # In your profile. constraint_method_regexp_map => { # All fields that end in _postcode have the 'postcode' constraint applied. qr/_postcode$/ => postcode(), }, A hash ref where the keys are the regular expressions to use and the values are the constraints to apply. If one or more constraints have already been defined for a given field using C, C will add an additional constraint for that field for each regular expression that matches. =head2 untaint_all_constraints untaint_all_constraints => 1, If this field is set, all form data that passes a constraint will be untainted. The untainted data will be returned in the valid hash. Untainting is based on the pattern match used by the constraint. Note that some constraint routines may not provide untainting. See L for more information. This is overridden by C and C. =head2 untaint_constraint_fields untaint_constraint_fields => [qw(zipcode state)], Specifies that one or more fields will be untainted if they pass their constraint(s). This can be set to a single field name or an array reference of field names. The untainted data will be returned in the valid hash. This overrides the untaint_all_constraints flag. =head2 untaint_regexp_map untaint_regexp_map => [qr/some_field_\d/], Specifies that certain fields will be untainted if they pass their constraints and match one of the regular expressions supplied. This can be set to a single regex, or an array reference of regexes. The untainted data will be returned in the valid hash. The above example would untaint the fields named C, and C but not C. This overrides the untaint_all_constraints flag. =head2 missing_optional_valid missing_optional_valid => 1 This can be set to a true value to cause optional fields with empty values to be included in the valid hash. By default they are not included-- this is the historical behavior. This is an important flag if you are using the contents of an "update" form to update a record in a database. Without using the option, fields that have been set back to "blank" may fail to get updated. =head2 validator_packages # load all the constraints and filters from these modules validator_packages => [qw(Data::FormValidator::Constraints::Upload)], This key is used to define other packages which contain constraint routines or filters. Set this key to a single package name, or an arrayref of several. All of its constraint and filter routines beginning with 'match_', 'valid_' and 'filter_' will be imported into Data::FormValidator. This lets you reference them in a constraint with just their name, just like built-in routines. You can even override the provided validators. See L documentation for more information =head2 msgs This key is used to define parameters related to formatting error messages returned to the user. By default, invalid fields have the message "Invalid" associated with them while missing fields have the message "Missing" associated with them. In the simplest case, nothing needs to be defined here, and the default values will be used. The default formatting applied is designed for display in an XHTML web page. That formatting is as followings: * %s The C<%s> will be replaced with the message. The effect is that the message will appear in bold red with an asterisk before it. This style can be overridden by simply defining "dfv_errors" appropriately in a style sheet, or by providing a new format string. Here's a more complex example that shows how to provide your own default message strings, as well as providing custom messages per field, and handling multiple constraints: msgs => { # set a custom error prefix, defaults to none prefix=> 'error_', # Set your own "Missing" message, defaults to "Missing" missing => 'Not Here!', # Default invalid message, default's to "Invalid" invalid => 'Problematic!', # message separator for multiple messages # Defaults to ' ' invalid_separator => '
', # formatting string, default given above. format => 'ERROR: %s', # Error messages, keyed by constraint name # Your constraints must be named to use this. constraints => { 'date_and_time' => 'Not a valid time format', # ... }, # This token will be included in the hash if there are # any errors returned. This can be useful with templating # systems like HTML::Template # The 'prefix' setting does not apply here. # defaults to undefined any_errors => 'some_errors', } The hash that's prepared can be retrieved through the C method described in the L documentation. =head2 msgs - callback I If the built-in message generation doesn't suit you, it is also possible to provide your own by specifying a code reference: msgs => \&my_msgs_callback This will be called as a L method. It may receive as arguments an additional hash reference of control parameters, corresponding to the key names usually used in the C area of the profile. You can ignore this information if you'd like. If you have an alternative error message handler you'd like to share, stick in the C name space and upload it to CPAN. =head2 debug This method is used to print details about what is going on to STDERR. Currently only level '1' is used. It provides information about which fields matched constraint_regexp_map. =head2 A shortcut for array refs A number of parts of the input profile specification include array references as their values. In any of these places, you can simply use a string if you only need to specify one value. For example, instead of filters => [ 'trim' ] you can simply say filters => 'trim' =head2 A note on regular expression formats In addition to using the preferred method of defining regular expressions using C, a deprecated style of defining them as strings is also supported. Preferred: qr/this is great/ Deprecated, but supported 'm/this still works/' =head1 VALIDATING INPUT BASED ON MULTIPLE FIELDS You can pass more than one value into a constraint routine. For that, the value of the constraint should be a hash reference. If you are creating your own routines, be sure to read the section labeled L, in the Data::FormValidator::Constraints documentation. It describes a newer and more flexible syntax. Using the original syntax, one key should be named C and should have a value set to the reference of the subroutine or the name of a built-in validator. Another required key is C. The value of the C key is a reference to an array of the other elements to use in the validation. If the element is a scalar, it is assumed to be a field name. The field is known to Data::FormValidator, the value will be filtered through any defined filters before it is passed in. If the value is a reference, the reference is passed directly to the routine. Don't forget to include the name of the field to check in that list, if you are using this syntax. B: cc_no => { constraint => "cc_number", params => [ qw( cc_no cc_type ) ], }, =head1 MULTIPLE CONSTRAINTS Multiple constraints can be applied to a single field by defining the value of the constraint to be an array reference. Each of the values in this array can be any of the constraint types defined above. When using multiple constraints it is important to return the name of the constraint that failed so you can distinguish between them. To do that, either use a named constraint, or use the hash ref method of defining a constraint and include a C key with a value set to the name of your constraint. Here's an example: my_zipcode_field => [ 'zip', { constraint_method => '/^406/', name => 'starts_with_406', } ], You can use an array reference with a single constraint in it if you just want to have the name of your failed constraint returned in the above fashion. Read about the C function above to see how multiple constraints are returned differently with that method. =cut sub load_profiles { my $self = shift; my $file = $self->{profile_file}; return unless $file; die "No such file: $file\n" unless -f $file; die "Can't read $file\n" unless -r _; my $mtime = (stat _)[9]; return if $self->{profiles} and $self->{profiles_mtime} <= $mtime; $self->{profiles} = do $file; die "Input profiles didn't return a hash ref: $@\n" unless ref $self->{profiles} eq "HASH"; $self->{profiles_mtime} = $mtime; } # check the profile syntax and die if we have an error sub _check_profile_syntax { my $profile = shift; (ref $profile eq 'HASH') or die "Invalid input profile: needs to be a hash reference\n"; my @invalid; # check top level keys { my @valid_profile_keys = (qw/ constraint_methods constraint_method_regexp_map constraint_regexp_map constraints defaults defaults_regexp_map dependencies dependencies_regexp dependency_groups dependent_optionals dependent_require_some field_filter_regexp_map field_filters filters missing_optional_valid msgs optional optional_regexp require_some required required_regexp untaint_all_constraints validator_packages untaint_constraint_fields untaint_regexp_map debug /); # If any of the keys in the profile are not listed as # valid keys here, we die with an error for my $key (keys %$profile) { push @invalid, $key unless grep $key eq $_, @valid_profile_keys; } local $" = ', '; if (@invalid) { die "Invalid input profile: keys not recognised [@invalid]\n"; } } # Check that constraint_methods are always code refs or REs { # Cases: # 1. constraint_methods => { field => func() } # 2. constraint_methods => { field => [ func() ] } # 3. constraint_method_regex_map => { qr/^field/ => func() } # 4. constraint_method_regex_map => { qr/^field/ => [ func() ] } # 5. constraint_methods => { field => { constraint_method => func() } } # Could be improved by also naming the associated key for the bad value. for my $key (grep { $profile->{$_} } qw/constraint_methods constraint_method_regexp_map/) { for my $val (map { _arrayify($_) } values %{ $profile->{$key} }) { if (ref $val eq 'HASH' && !grep(ref $val->{constraint_method} eq $_, 'CODE','Regexp')) { die "Value for constraint_method within hashref '$val->{constraint_method}' not a code reference or Regexp . Do you need func(), not 'func'?"; } # Cases 1 through 4. elsif (!grep(ref $val eq $_, 'HASH','CODE','Regexp')) { die "Value for constraint_method '$val' not a code reference or Regexp . Do you need func(), not 'func'?"; } # Case 5. else { # We're cool. Nothing to do. } } } } # Check constraint hash keys { my @valid_constraint_hash_keys = (qw/ constraint constraint_method name params /); my @constraint_hashrefs = grep { ref $_ eq 'HASH' } values %{ $profile->{constraints} } if $profile->{constraints}; push @constraint_hashrefs, grep { ref $_ eq 'HASH' } values %{ $profile->{constraint_regexp_map} } if $profile->{constraint_regexp_map}; for my $href (@constraint_hashrefs) { for my $key (keys %$href) { push @invalid, $key unless grep $key eq $_, @valid_constraint_hash_keys; } } if (@invalid) { die "Invalid input profile: constraint hashref keys not recognised [@invalid]\n"; } } # Check msgs keys { my @valid_msgs_hash_keys = (qw/ prefix missing invalid invalid_separator invalid_seperator format constraints any_errors /); if (ref $profile->{msgs} eq 'HASH') { for my $key (keys %{ $profile->{msgs} }) { push @invalid, $key unless grep $key eq $_, @valid_msgs_hash_keys; } } if (@invalid) { die "Invalid input profile: msgs keys not recognized: [@invalid]\n"; } } } 1; __END__ =pod =head1 ADVANCED VALIDATION For even more advanced validation, you will likely want to read the documentation for other modules in this distribution, linked below. Also keep in mind that the Data::FormValidator profile structure is just another data structure. There is no reason why it needs to be defined statically. The profile could also be built on the fly with custom Perl code. =head1 BACKWARDS COMPATIBILITY =head2 validate() my( $valids, $missings, $invalids, $unknowns ) = Data::FormValidator->validate( \%input_hash, \%dfv_profile); C provides a deprecated alternative to C. It has the same input syntax, but returns a four element array, described as follows =over =item valids This is a hash reference to the valid fields which were submitted in the data. The data may have been modified by the various filters specified. =item missings This is a reference to an array which contains the name of the missing fields. Those are the fields that the user forget to fill or filled with spaces. These fields may comes from the I list or the I list. =item invalids This is a reference to an array which contains the name of the fields which failed one or more of their constraint checks. Fields defined with multiple constraints will have an array ref returned in the @invalids array instead of a string. The first element in this array is the name of the field, and the remaining fields are the names of the failed constraints. =item unknowns This is a list of fields which are unknown to the profile. Whether or not this indicates an error in the user input is application dependent. =back =head2 constraints (profile key) This is a supported but deprecated profile key. Using C is recommended instead, which provides a simpler, more versatile interface. constraints => { cc_no => { constraint => "cc_number", params => [ qw( cc_no cc_type ) ], }, cc_type => "cc_type", cc_exp => "cc_exp", }, A hash ref which contains the constraints that will be used to check whether or not the field contains valid data. The keys in this hash are field names. The values can be any of the following: =over =item o A named constraint. B: my_zipcode_field => 'zip', See L for the details of which built-in constraints that are available. =back =head2 hashref style of specifying constraints Using a hash reference to specify a constraint is an older technique used to name a constraint or supply multiple parameters. Both of these interface issues are now better addressed with C and C<$self-\>name_this('foo')>. # supply multiple parameters cc_no => { constraint => "cc_number", params => [ qw( cc_no cc_type ) ], }, # name a constraint, useful for returning error messages last_name => { name => "ends_in_name", constraint => qr/_name$/, }, Using a hash reference for a constraint permits the passing of multiple arguments. Required arguments are C or C. Optional arguments are C and C. A C on a constraints 'glues' the constraint to its error message in the validator profile (refer C section below). If no C is given then it will default to the value of C or C IF they are NOT a CODE ref or a RegExp ref. The C value is a reference to an array of the parameters to pass to the constraint method. If an element of the C list is a scalar, it is assumed to be naming a key of the %input_hash and that value is passed to the routine. If the parameter is a reference, then it is treated literally and passed unchanged to the routine. If you are using the older C over the new C then don't forget to include the name of the field to check in the C list. C provides access to this value via the C methods (refer L) For more details see L. =head2 constraint_regexp_map (profile key) This is a supported but deprecated profile key. Using C is recommended instead. constraint_regexp_map => { # All fields that end in _postcode have the 'postcode' constraint applied. qr/_postcode$/ => 'postcode', }, A hash ref where the keys are the regular expressions to use and the values are the constraints to apply. If one or more constraints have already been defined for a given field using "constraints", constraint_regexp_map will add an additional constraint for that field for each regular expression that matches. =head1 SEE ALSO B L L L L L L B Validating Web Forms with Perl, L B L L L, a CGI::Application & Data::FormValidator glue module L is designed to make some kinds of integration with HTML::Template easier. L is useful for validating function parameters. L, L, L, L, L, L, L, L B Japanese: L B FreeBSD includes a port named B Debian GNU/Linux includes a port named B =head1 CREDITS Some of these input validation functions have been taken from MiniVend by Michael J. Heins. The credit card checksum validation was taken from contribution by Bruce Albrecht to the MiniVend program. =head1 BUGS Bug reports and patches are welcome. Reports which include a failing Test::More style test are helpful and will receive priority. L =head1 CONTRIBUTING This project is maintained on L. =head1 AUTHOR Currently maintained by David Farrell Parts Copyright 2001-2006 by Mark Stosberg , (previous maintainer) Copyright (c) 1999 Francis J. Lacoste and iNsu Innovations Inc. All rights reserved. (Original Author) Parts Copyright 1996-1999 by Michael J. Heins Parts Copyright 1996-1999 by Bruce Albrecht =head1 LICENSE This program is free software; you can redistribute it and/or modify it under the terms as perl itself. =cut Data-FormValidator-4.88/lib/Data/FormValidator/0000755000175000017500000000000013151007442021432 5ustar dfarrelldfarrellData-FormValidator-4.88/lib/Data/FormValidator/Filters.pm0000644000175000017500000002215113151006761023404 0ustar dfarrelldfarrell# Filters.pm - Common filters for use in Data::FormValidator. # This file is part of Data::FormValidator. # # Author: Francis J. Lacoste # Maintainer: Mark Stosberg # # Copyright (C) 1999,2000 iNsu Innovations Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms same terms as perl itself. package Data::FormValidator::Filters; use Exporter 'import'; use strict; our $VERSION = 4.88; our @EXPORT_OK = qw( filter_alphanum filter_decimal filter_digit filter_dollars filter_integer filter_lc filter_neg_decimal filter_neg_integer filter_phone filter_pos_decimal filter_pos_integer filter_quotemeta filter_sql_wildcard filter_strip filter_trim filter_uc filter_ucfirst FV_split FV_replace ); our %EXPORT_TAGS = ( filters => \@EXPORT_OK, ); sub DESTROY {} =pod =head1 NAME Data::FormValidator::Filters - Basic set of filters available in an Data::FormValidator profile. =head1 SYNOPSIS use Data::FormValidator; %profile = ( filters => 'trim', ... ); my $results = Data::FormValidator->check( \%data, \%profile ); =head1 DESCRIPTION These are the builtin filters which may be specified as a name in the I, I, and I parameters of the input profile. Filters are applied as the first step of validation, possibly modifying a copy of the validation before any constraints are checked. =head1 RECOMMENDED USE As a long time maintainer and user of Data::FormValidator, I recommend that filters be used with caution. They are immediately modifying the input provided, so the original data is lost. The few I recommend include C, which removes leading and trailing whitespace. I have this turned on by default by using L. It's also generally safe to use the C and C filters if you need that kind of data transformation. Beyond simple filters, I recommend transforming the C<"valid"> hash returned from validation if further changes are needed. =head1 PROCEDURAL INTERFACE You may also call these functions directly through the procedural interface by either importing them directly or importing the whole I<:filters> group. For example, if you want to access the I function directly, you could either do: use Data::FormValidator::Filters (qw/filter_trim/); # or use Data::FormValidator::Filters (qw/:filters/); $string = filter_trim($string); Notice that when you call filters directly, you'll need to prefix the filter name with "filter_". =head1 THE FILTERS =head2 FV_split use Data::FormValidator::Filters qw(FV_split); # Validate every e-mail in a comma separated list field_filters => { several_emails => FV_split(qr/\s*,\s*/), # Any pattern that can be used by the 'split' builtin works. tab_sep_field => FV_split('\t'), }, constraint_methods => { several_emails => email(), }, With this filter, you can split a field into multiple values. The constraint for the field will then be applied to every value. This filter has a different naming convention because it is a higher-order function. Rather than returning a value directly, it returns a code reference to a standard Data::FormValidator filter. After successfully being validated the values will appear as an arrayref. =cut sub FV_split { my $splitter = shift || die "nothing to split on!"; return sub { my $value = shift; return undef unless defined $value; my @a = split $splitter, $value; return \@a; }; } =head2 FV_replace use Data::FormValidator::Filters qw(FV_replace); field_filters => { first_name => FV_replace(qr/Mark/,'Don'), }, FV_replace is a shorthand for writing simple find-and-replace filters. The above filter would be translated to this: sub { my $v = shift; $v =~ s/Mark/Don/; $v } For more complex filters, just write your own. =cut sub FV_replace { my ($find,$replace) = @_; return sub { my $v = shift; $v =~ s/$find/$replace/; return $v; }; } =head2 trim Remove white space at the front and end of the fields. =cut sub filter_trim { my $value = shift; return unless defined $value; # Remove whitespace at the front $value =~ s/^\s+//o; # Remove whitespace at the end $value =~ s/\s+$//o; return $value; } =pod =head2 strip Runs of white space are replaced by a single space. =cut sub filter_strip { my $value = shift; return unless defined $value; # Strip whitespace $value =~ s/\s+/ /g; return $value; } =pod =head2 digit Remove non digits characters from the input. =cut sub filter_digit { my $value = shift; return unless defined $value; $value =~ s/\D//g; return $value; } =pod =head2 alphanum Remove non alphanumeric characters from the input. =cut sub filter_alphanum { my $value = shift; return unless defined $value; $value =~ s/\W//g; return $value; } =pod =head2 integer Extract from its input a valid integer number. =cut sub filter_integer { my $value = shift; return unless defined $value; $value =~ tr/0-9+-//dc; ($value) =~ m/([-+]?\d+)/; return $value; } =pod =head2 pos_integer Extract from its input a valid positive integer number. Bugs: This filter won't extract "9" from "a9+", it will instead extract "9+" =cut sub filter_pos_integer { my $value = shift; return unless defined $value; $value =~ tr/0-9+//dc; ($value) =~ m/(\+?\d+)/; return $value; } =pod =head2 neg_integer Extract from its input a valid negative integer number. Bugs: This filter will currently filter the case of "a9-" to become "9-", which it should leave it alone. =cut sub filter_neg_integer { my $value = shift; return unless defined $value; $value =~ tr/0-9-//dc; ($value) =~ m/(-\d+)/; return $value; } =pod =head2 decimal Extract from its input a valid decimal number. Bugs: Given "1,000.23", it will currently return "1.000.23" =cut sub filter_decimal { my $value = shift; return unless defined $value; # This is a localization problem, but anyhow... $value =~ tr/,/./; $value =~ tr/0-9.+-//dc; ($value) =~ m/([-+]?\d+\.?\d*)/; return $value; } =pod =head2 pos_decimal Extract from its input a valid positive decimal number. Bugs: Given "1,000.23", it will currently return "1.000.23" =cut sub filter_pos_decimal { my $value = shift; return unless defined $value; # This is a localization problem, but anyhow... $value =~ tr/,/./; $value =~ tr/0-9.+//dc; ($value) =~ m/(\+?\d+\.?\d*)/; return $value; } =pod =head2 neg_decimal Extract from its input a valid negative decimal number. Bugs: Given "1,000.23", it will currently return "1.000.23" =cut sub filter_neg_decimal { my $value = shift; return unless defined $value; # This is a localization problem, but anyhow... $value =~ tr/,/./; $value =~ tr/0-9.-//dc; ($value) =~ m/(-\d+\.?\d*)/; return $value; } =pod =head2 dollars Extract from its input a valid number to express dollars like currency. Bugs: This filter won't currently remove trailing numbers like "1.234". =cut sub filter_dollars { my $value = shift; return unless defined $value; $value =~ tr/,/./; $value =~ tr/0-9.+-//dc; ($value) =~ m/(\d+\.?\d?\d?)/; return $value; } =pod =head2 phone Filters out characters which aren't valid for an phone number. (Only accept digits [0-9], space, comma, minus, parenthesis, period and pound [#].) =cut sub filter_phone { my $value = shift; return unless defined $value; $value =~ s/[^\d,\(\)\.\s,\-#]//g; return $value; } =pod =head2 sql_wildcard Transforms shell glob wildcard (*) to the SQL like wildcard (%). =cut sub filter_sql_wildcard { my $value = shift; return unless defined $value; $value =~ tr/*/%/; return $value; } =pod =head2 quotemeta Calls the quotemeta (quote non alphanumeric character) builtin on its input. =cut sub filter_quotemeta { return unless defined $_[0]; quotemeta $_[0]; } =pod =head2 lc Calls the lc (convert to lowercase) builtin on its input. =cut sub filter_lc { return unless defined $_[0]; lc $_[0]; } =pod =head2 uc Calls the uc (convert to uppercase) builtin on its input. =cut sub filter_uc { return unless defined $_[0]; uc $_[0]; } =pod =head2 ucfirst Calls the ucfirst (Uppercase first letter) builtin on its input. =cut sub filter_ucfirst { return unless defined $_[0]; ucfirst $_[0]; } 1; __END__ =head1 SEE ALSO =over 4 =item o L =item o L =item o L - shrink incoming image uploads =back =head1 AUTHOR Author: Francis J. Lacoste Maintainer: Mark Stosberg =head1 COPYRIGHT Copyright (c) 1999,2000 iNsu Innovations Inc. All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms as perl itself. =cut Data-FormValidator-4.88/lib/Data/FormValidator/ConstraintsFactory.pm0000644000175000017500000001616513151006761025643 0ustar dfarrelldfarrell# # ConstraintsFactory.pm - Module to create constraints for Data::FormValidator. # # This file is part of Data::FormValidator. # # Author: Francis J. Lacoste # Maintainer: Mark Stosberg # # Copyright (C) 2000 iNsu Innovations Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms as perl itself. # use strict; package Data::FormValidator::ConstraintsFactory; use Exporter 'import'; =pod =head1 NAME Data::FormValidator::ConstraintsFactory - Module to create constraints for HTML::FormValidator. =head1 DESCRIPTION This module contains functions to help generate complex constraints. If you are writing new code, take a look at L instead. It's a modern alternative to what's here, offering improved names and syntax. =head1 SYNOPSIS use Data::FormValidator::ConstraintsFactory qw( :set :bool ); constraints => { param1 => make_or_constraint( make_num_set_constraint( -1, ( 1 .. 10 ) ), make_set_constraint( 1, ( 20 .. 30 ) ), ), province => make_word_set_constraint( 1, "AB QC ON TN NU" ), bid => make_range_constraint( 1, 1, 10 ), } =cut BEGIN { our $VERSION = 4.88; our @EXPORT = (); our @EXPORT_OK = (qw/make_length_constraint/); our %EXPORT_TAGS = ( bool => [ qw( make_not_constraint make_or_constraint make_and_constraint ) ], set => [ qw( make_set_constraint make_num_set_constraint make_word_set_constraint make_cmp_set_constraint ) ], num => [ qw( make_clamp_constraint make_lt_constraint make_le_constraint make_gt_constraint make_ge_constraint ) ], ); Exporter::export_ok_tags( 'bool' ); Exporter::export_ok_tags( 'set' ); Exporter::export_ok_tags( 'num' ); } =pod =head1 BOOLEAN CONSTRAINTS Those constraints are available by using the C<:bool> tag. =head2 make_not_constraint( $c1 ) This will create a constraint that will return the negation of the result of constraint $c1. =cut sub make_not_constraint { my $c1 = $_[0]; # Closure return sub { ! $c1->( @_ ) }; } =head2 make_or_constraint( @constraints ) This will create a constraint that will return the result of the first constraint that return an non false result. =cut sub make_or_constraint { my @c = @_; # Closure return sub { my $res; for my $c ( @c ) { $res = $c->( @_ ); return $res if $res; } return $res; }; } =head2 make_and_constraint( @constraints ) This will create a constraint that will return the result of the first constraint that return an non false result only if all constraints returns a non-false results. =cut sub make_and_constraint { my @c = @_; # Closure return sub { my $res; for my $c ( @c ) { $res = $c->( @_ ); return $res if ! $res; $res ||= $res; } return $res; }; } =pod =head1 SET CONSTRAINTS Those constraints are available by using the C<:set> tag. =head2 make_set_constraint( $res, @elements ) This will create a constraint that will return $res if the value is one of the @elements set, or the negation of $res otherwise. The C operator is used for comparison. =cut sub make_set_constraint { my $res = shift; my @values = @_; # Closure return sub { my $v = $_[0]; for my $t ( @values ) { return $res if $t eq $v; } return ! $res; } } =head2 make_num_set_constraint( $res, @elements ) This will create a constraint that will return $res if the value is one of the @elements set, or the negation of $res otherwise. The C<==> operator is used for comparison. =cut sub make_num_set_constraint { my $res = shift; my @values = @_; # Closure return sub { my $v = $_[0]; for my $t ( @values ) { return $res if $t == $v; } return ! $res; } } =head2 make_word_set_constraint( $res, $set ) This will create a constraint that will return $res if the value is a word in $set, or the negation of $res otherwise. =cut sub make_word_set_constraint { my ($res,$set) = @_; # Closure return sub { my $v = $_[0]; if ( $set =~ /\b$v\b/i ) { return $res; } else { return ! $res; } } } =head2 make_cmp_set_constraint( $res, $cmp, @elements ) This will create a constraint that will return $res if the value is one of the @elements set, or the negation of $res otherwise. $cmp is a function which takes two argument and should return true or false depending if the two elements are equal. =cut sub make_match_set_constraint { my $res = shift; my $cmp = shift; my @values = @_; # Closure return sub { my $v = $_[0]; for my $t ( @values ) { return $res if $cmp->($v, $t ); } return ! $res; } } =pod =head1 NUMERICAL LOGICAL CONSTRAINTS Those constraints are available by using the C<:num> tag. =head2 make_clamp_constraint( $res, $low, $high ) This will create a constraint that will return $res if the value is between $low and $high bounds included or its negation otherwise. =cut sub make_clamp_constraint { my ( $res, $low, $high ) = @_; return sub { my $v = $_[0]; $v < $low || $v > $high ? ! $res : $res; } } =head2 make_lt_constraint( $res, $bound ) This will create a constraint that will return $res if the value is lower than $bound, or the negation of $res otherwise. =cut sub make_lt_constraint { my ( $res, $bound ) = @_; return sub { $_[0] < $bound ? $res : ! $res; } } =head2 make_le_constraint( $res, $bound ) This will create a constraint that will return $res if the value is lower or equal than $bound, or the negation of $res otherwise. =cut sub make_le_constraint { my ( $res, $bound ) = @_; return sub { $_[0] <= $bound ? $res : ! $res; } } =head2 make_gt_constraint( $res, $bound ) This will create a constraint that will return $res if the value is greater than $bound, or the negation of $res otherwise. =cut sub make_gt_constraint { my ( $res, $bound ) = @_; return sub { $_[0] >= $bound ? $res : ! $res; } } =head2 make_ge_constraint( $res, $bound ) This will create a constraint that will return $res if the value is greater or equal than $bound, or the negation of $res otherwise. =cut sub make_ge_constraint { my ( $res, $bound ) = @_; return sub { $_[0] >= $bound ? $res : ! $res; } } =head1 OTHER CONSTRAINTS =head2 make_length_constraint($max_length) This will create a constraint that will return true if the value has a length of less than or equal to $max_length =cut sub make_length_constraint { my $max_length = shift; return sub { length(shift) <= $max_length }; } 1; __END__ =pod =head1 SEE ALSO Data::FormValidator(3) =head1 AUTHOR Author: Francis J. Lacoste Maintainer: Mark Stosberg =head1 COPYRIGHT Copyright (c) 2000 iNsu Innovations Inc. All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms as perl itself. =cut Data-FormValidator-4.88/lib/Data/FormValidator/Constraints/0000755000175000017500000000000013151007442023741 5ustar dfarrelldfarrellData-FormValidator-4.88/lib/Data/FormValidator/Constraints/Upload.pm0000644000175000017500000003555113151006761025537 0ustar dfarrelldfarrellpackage Data::FormValidator::Constraints::Upload; use Exporter 'import'; use strict; # Items to export into callers namespace by default. Note: do not export # names by default without a very good reason. Use EXPORT_OK instead. # Do not simply export all your public functions/methods/constants. # This allows declaration use Data::FormValidator::Constraints::Upload ':all'; # If you do not need this, moving things directly into @EXPORT or @EXPORT_OK # will save memory. our @EXPORT = qw( valid_file_format valid_image_max_dimensions valid_file_max_bytes valid_image_min_dimensions ); our @EXPORT_OK = qw( file_format image_max_dimensions file_max_bytes image_min_dimensions ); our $VERSION = 4.88; sub file_format { my %params = @_; return sub { my $self = shift; $self->set_current_constraint_name('file_format'); valid_file_format($self,\%params); } } sub image_max_dimensions { my $w = shift || die 'image_max_dimensions: missing maximum width value'; my $h = shift || die 'image_max_dimensions: missing maximum height value'; return sub { my $self = shift; $self->set_current_constraint_name('image_max_dimensions'); valid_image_max_dimensions($self,\$w,\$h); } } sub file_max_bytes { my ($max_bytes) = @_; return sub { my $self = shift; $self->set_current_constraint_name('file_max_bytes'); valid_file_max_bytes($self,\$max_bytes); } } sub image_min_dimensions { my $w = shift || die 'image_min_dimensions: missing minimum width value'; my $h = shift || die 'image_min_dimensions: missing minimum height value'; return sub { my $self = shift; $self->set_current_constraint_name('image_min_dimensions'); valid_image_min_dimensions($self,\$w,\$h); } } sub valid_file_format { my $self = shift; $self->isa('Data::FormValidator::Results') || die "file_format: first argument is not a Data::FormValidator::Results object. "; my $params = shift || {}; # if (ref $params ne 'HASH' ) { # die "format: hash reference expected. Make sure you have # included 'params => []' in your constraint definition, even if there # are no additional arguments"; # } my $q = $self->get_filtered_data; my $field = $self->get_current_constraint_field; my $fh = _get_upload_fh($self); ## load filehandle if (!$fh) { warn "$0: can't get filehandle for field named $field" and return undef; } ## load file magic stuff require File::MMagic; my $mm = File::MMagic->new; my $fm_mt; ## only use filehandle bits for magic data $fm_mt = $mm->checktype_filehandle($fh) || (warn "$0: can't get filehandle for field named $field" and return undef); # Work around a bug in File::MMagic (RT#12074) seek($fh,0,0); # File::MMagic returns 'application/octet-stream" as a punt # for "I don't know, here's a generic binary MIME type. # In some cases that is has indicated a bug in File::MMagic, # but it's a generally worthless response for identifying the file type. # so, we throw away the response in that case. The uploaded MIME type # will be used instead later, if present $fm_mt = undef if ($fm_mt eq 'application/octet-stream'); ## fetch mime type universally (or close) my $uploaded_mt = _get_upload_mime_type($self); # try the File::MMagic, then the uploaded field, then return undef we find neither my $mt = ($fm_mt || $uploaded_mt) or return undef; # figure out an extension use MIME::Types; my $mimetypes = MIME::Types->new; my MIME::Type $t = $mimetypes->type($mt); my @mt_exts = $t ? $t->extensions : (); ## setup filename to retrieve extension my $fn = $self->get_input_data->param($field); my ($uploaded_ext) = ($fn =~ m/\.([\w\d]*)?$/); my $ext; if (scalar @mt_exts) { # If the upload extension is one recognized by MIME::Type, use it. if (grep {/^$uploaded_ext$/} @mt_exts) { $ext = $uploaded_ext; } # otherwise, use one from MIME::Type, just to be safe else { $ext = $mt_exts[0]; } } else { # If is a provided extension but no MIME::Type extension, use that. # It's possible that there no extension uploaded or found) $ext = $uploaded_ext; } # Add the mime_type and extension to the valid data set my $info = $self->meta($field) || {}; $info = { %$info, mime_type => $mt, extension => ".$ext" }; $self->meta($field,$info); return _is_allowed_type($mt, $params); } ## Returns true if the passed-in mime-type matches our allowed types sub _is_allowed_type { my $mt = shift; my $params = shift; # XXX perhaps this should be in a global variable so it's easier # for other apps to change the defaults; $params->{mime_types} ||= [qw!image/jpeg image/pjpeg image/gif image/png!]; my %allowed_types = map { $_ => 1 } @{ $params->{mime_types} }; return $allowed_types{lc $mt}; } sub valid_image_max_dimensions { my $self = shift; $self->isa('Data::FormValidator::Results') || die "image_max_dimensions: first argument is not a Data::FormValidator::Results object. "; my $max_width_ref = shift || die 'image_max_dimensions: missing maximum width value'; my $max_height_ref = shift || die 'image_max_dimensions: missing maximum height value'; my $max_width = $$max_width_ref; my $max_height = $$max_height_ref; ($max_width > 0) || die 'image_max_dimensions: maximum width must be > 0'; ($max_height > 0) || die 'image_max_dimensions: maximum height must be > 0'; my $q = $self->get_filtered_data; my $field = $self->get_current_constraint_field; my ($width,$height) = _get_img_size($self); unless ($width) { warn "$0: imgsize test failed"; return undef; } # Add the dimensions to the valid hash my $info = $self->meta($field) || {}; $info = { %$info, width => $width, height => $height }; $self->meta($field,$info); return (($width <= $$max_width_ref) and ($height <= $$max_height_ref)); } sub valid_file_max_bytes { my $self = shift; $self->isa('Data::FormValidator::Results') || die "first argument is not a Data::FormValidator::Results object."; my $max_bytes_ref = shift; my $max_bytes; if ((ref $max_bytes_ref) and defined $$max_bytes_ref) { $max_bytes = $$max_bytes_ref; } else { $max_bytes = 1024*1024; # default to 1 Meg } my $q = $self->get_filtered_data; my $field = $self->get_current_constraint_field; ## retrieve upload fh for field my $fh = _get_upload_fh($self); if (!$fh) { warn "Failed to load filehandle for $field" && return undef; } ## retrieve size my $file_size = (stat ($fh))[7]; # Add the size to the valid hash my $info = $self->meta($field) || {}; $info = { %$info, bytes => $file_size }; $self->meta($field,$info); return ($file_size <= $max_bytes); } sub valid_image_min_dimensions { my $self = shift; $self->isa('Data::FormValidator::Results') || die "image_min_dimensions: first argument is not a Data::FormValidator::Results object. "; my $min_width_ref = shift || die 'image_min_dimensions: missing minimum width value'; my $min_height_ref = shift || die 'image_min_dimensions: missing minimum height value'; my $min_width = $$min_width_ref; my $min_height = $$min_height_ref; ## do these matter? ($min_width > 0) || die 'image_min_dimensions: minimum width must be > 0'; ($min_height > 0) || die 'image_min_dimensions: minimum height must be > 0'; my $q = $self->get_filtered_data; my $field = $self->get_current_constraint_field; my ($width, $height) = _get_img_size($self); unless ($width) { warn "image failed processing"; return undef; } # Add the dimensions to the valid hash my $info = $self->meta($field) || {}; $info = { %$info, width => $width, height => $height }; $self->meta($field,$info); return (($width >= $min_width) and ($height >= $min_height)); } sub _get_img_size { my $self = shift; my $q = $self->get_filtered_data; ## setup caller to make can errors more useful my $caller = (caller(1))[3]; my $pkg = __PACKAGE__ . "::"; $caller =~ s/$pkg//g; my $field = $self->get_current_constraint_field; ## retrieve filehandle from query object. my $fh = _get_upload_fh($self); ## check error if (not $fh) { warn "Unable to load filehandle"; return undef; } require Image::Size; import Image::Size; ## check size my ($width, $height, $err) = imgsize($fh); unless ($width) { warn "$caller: imgsize test failed: $err"; return undef; } return ($width, $height); } ## fetch filehandle for use with various file type checking ## call it with (_get_upload_fh($self)) since kind of mock object sub _get_upload_fh { my $self = shift; my $q = $self->get_filtered_data; my $field = $self->get_current_constraint_field; # convert the FH for the filtered data into a -seekable- handle; # depending on whether we're using CGI::Simple, CGI, or Apache::Request # we might not have something -seekable-. use IO::File; # If we we already have an IO::File object, return it, otherwise create one. require Scalar::Util; if ( Scalar::Util::blessed($q->{$field}) && $q->{$field}->isa('IO::File') ) { return $q->{$field}; } else { return IO::File->new_from_fd(fileno($q->{$field}), 'r'); } } ## returns mime type if included as part of the send ## ## NOTE: retrieves from original uploaded, -UNFILTERED- data sub _get_upload_mime_type { my $self = shift; my $q = $self->get_input_data; my $field = $self->get_current_constraint_field; if ($q->isa('CGI')) { my $fn = $q->param($field); ## nicely check for info if ($q->uploadInfo($fn)) { return $q->uploadInfo($fn)->{'Content-Type'} } return undef; } if ($q->isa('CGI::Simple')) { my $fn = $q->param($field); return $q->upload_info($fn, 'mime'); } if ($q->isa('Apache::Request')) { my $upload = $q->upload($field); return $upload->info('Content-type'); } return undef; } 1; __END__ =head1 NAME Data::FormValidator::Constraints::Upload - Validate File Uploads =head1 SYNOPSIS # Be sure to use a CGI.pm or CGI::Simple object as the form # input when using this constraint my $q = CGI->new; use Data::FormValidator::Constraints::Upload qw( file_format file_max_bytes image_max_dimensions image_min_dimensions ); my $dfv = Data::FormValidator->check($q,$my_profile); # In a Data::FormValidator Profile: constraint_methods => { image_name => [ file_format(), file_max_bytes(10), image_max_dimensions(200,200), image_min_dimensions(100,100), ], } =head1 DESCRIPTION B This is a new module is a new addition to Data::FormValidator and is should be considered "Beta". These module is meant to be used in conjunction with the Data::FormValidator module to automate the task of validating uploaded files. The following validation routines are supplied. To use any of them, the input data passed to Data::FormValidator must be a CGI.pm object. =over 4 =item file_format This function checks the format of the file, based on the MIME type if it's available, and a case-insensitive version of the file extension otherwise. By default, it tries to validate JPEG, GIF and PNG images. The params are: optional hash reference of parameters. A key named I points to array references of valid values. file_format( mime_types => [qw!image/jpeg image/gif image/png!] ); Calling this function sets some meta data which can be retrieved through the C method of the Data::FormValidator::Results object. The meta data added is C and C. The MIME type of the file will first be tried to figured out by using the module to examine the file. If that doesn't turn up a result, we'll use a MIME type from the browser if one has been provided. Otherwise, we give up. The extension we return is based on the MIME type we found, rather than trusting the one that was uploaded. B if we have to fall back to using the MIME type provided by the browser, we access it from the original I data and not the I data. This should only cause issue when you have used a filter to alter the type of file that was uploaded (e.g. image conversion). =item file_max_bytes This function checks the maximum size of an uploaded file. By default, it checks to make sure files are smaller than 1 Meg. The params are: reference to max file size in bytes file_max_bytes(1024), # 1 k Calling this function sets some meta data which can be retrieved through the C method of the Data::FormValidator::Results object. The meta data added is C. =item image_max_dimensions This function checks to make sure an uploaded image is no longer than some maximum dimensions. The params are: reference to max pixel width reference to max pixel height image_max_dimensions(200,200), Calling this function sets some meta data which can be retrieved through the C method of the Data::FormValidator::Results object. The meta data added is C and C. =item image_min_dimensions This function checks to make sure an uploaded image is longer than some minimum dimensions. The params are: reference to min pixel width reference to min pixel height image_min_dimensions(100,100), Calling this function sets some meta data which can be retrieved through the C method of the Data::FormValidator::Results object. The meta data added is C and C. =back =head2 BACKWARDS COMPATIBILITY An older more awkward interface to the constraints in this module is still supported. To use it, you have to load the package with 'validator_packages', and call each constraint in a hashref style, passing the parameters by reference. It looks like this: validator_packages => [qw(Data::FormValidator::Constraints::Upload)], constraints => { image_name => [ { constraint_method => 'image_max_dimensions', params => [\200,\200], } ], } I told you it was more awkward. That was before I grokked the magic of closures, which is what drives the current interface. =head1 SEE ALSO L, L, L, L =head1 AUTHOR Mark Stosberg, Emark@summersault.comE =head1 COPYRIGHT AND LICENSE Copyright 2003-2005 by Mark Stosberg This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Data-FormValidator-4.88/lib/Data/FormValidator/Constraints/Dates.pm0000644000175000017500000001104013151006761025336 0ustar dfarrelldfarrellpackage Data::FormValidator::Constraints::Dates; use Exporter 'import'; use 5.005; use strict; our %EXPORT_TAGS = ( 'all' => [ qw() ] ); our @EXPORT_OK = ( 'date_and_time', @{ $EXPORT_TAGS{'all'} } ); our @EXPORT = qw( match_date_and_time ); our $VERSION = 4.88; sub date_and_time { my $fmt = shift; return sub { my $self = shift; $self->set_current_constraint_name('date_and_time'); return match_date_and_time($self,\$fmt); } } sub match_date_and_time { my $self = shift; my $fmt_ref = shift || die q!date_and_time: need format parameter. Be sure to pass it by reference, like this: \'MM/DD/YYYY'!; my $fmt = $$fmt_ref; require Date::Calc; import Date::Calc (qw/check_date check_time/); my $format = _prepare_date_format($fmt); my ($date,$Y,$M,$D,$h,$m,$s) = _parse_date_format($format,$self->get_current_constraint_value); return if not defined $date; # We need to check the date if we find any in the format string, otherwise, it succeeds my $date_test = 1; $date_test = check_date($Y,$M,$D) if ($fmt =~ /[YMD]/) ; # If we find a time, check that my $time_test = 1; $time_test = check_time($h,$m,$s) if ($fmt =~ /[hms]/) ; # If either the time or date fails, it all fails return ($date_test && $time_test) ? $date : undef; } sub _prepare_date_format { my $format = shift; # Originally by Jan Krynicky # TODO: check that only valid characters appear in the format # The logic should be: for any character A-Z in the format string, # die if it's not one of: Y M D h m s p my ($i, @order) = 0; $format =~ s{(Y+|M+|D+|h+|m+|s+|pp)(\?)?}{ my ($chr,$q) = ($1,$2); $chr = '' if not defined $chr; $q = '' if not defined $chr; $order[$i++] = substr($chr,0,1); if ($chr eq 'pp') { "(AM|PM|am|pm)" } else { '(' . ('\d' x length($chr)) . ($q ? $q : "") . ")" } }ge; $format = qr/^((?:$format))$/; return [$format, \@order]; } sub _parse_date_format { # Originally by Jan Krynicky my ($format, $date) = @_; my ($untainted_date,@data) = ($date =~ $format->[0]) or return; my %result; for(my $i = 0; $i <= $#data; $i++) { $result{$format->[1]->[$i]} ||= $data[$i]; } if (exists $result{p}) { $result{h} += 12 if ($result{p} eq 'PM' and $result{h} != 12); $result{h} = 0 if ($result{p} eq 'AM' and $result{h} == 12); } return $untainted_date, map {defined $result{$_} ? $result{$_} : 0} qw(Y M D h m s); } 1; __END__ =head1 NAME Data::FormValidator::Constraints::Dates - Validate Dates and Times =head1 SYNOPSIS use Data::FormValidator::Constraints::Dates qw(date_and_time); # In a DFV profile... constraint_methods => { # 'pp' denotes AM|PM for 12 hour representation my_time_field => date_and_time('MM/DD/YYYY hh:mm:ss pp'), } =head1 DESCRIPTION =head2 date_and_time B This is a new module is a new addition to Data::FormValidator and is should be considered "Beta". This constraint creates a regular expression based on the format string passed in to validate your date against. It understands the following symbols: Y year (numeric) M month (numeric) D day (numeric) h hour m minute s second p AM|PM Other parts of the string become part of the regular expression, so you can do perlish things like this to create more complex expressions: 'MM?/DD?/YYYY|YYYY-MM?-DD?' Internally L is used to test the functions. =head1 BACKWARDS COMPATIBILITY This older, more awkward interface is supported: # In a Data::FormValidator Profile: validator_packages => [qw(Data::FormValidator::Constraints::Dates)], constraints => { date_and_time_field => { constraint_method => 'date_and_time', params=>[\'MM/DD/YYYY hh:mm:ss pp'], # 'pp' denotes AM|PM for 12 hour representation }, } =head1 SEE ALSO =over =item o L =item o L - This alternative features returning dates as DateTime objects and validating against the date formats required for the MySQL and PostgreSQL databases. =back =head1 AUTHOR Mark Stosberg, Emark@summersault.comE Featuring clever code by Jan Krynicky. =head1 COPYRIGHT AND LICENSE Copyright 2003-2005 by Mark Stosberg This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Data-FormValidator-4.88/lib/Data/FormValidator/Results.pm0000644000175000017500000012750613151006761023447 0ustar dfarrelldfarrell# # Results.pm - Object which contains validation result. # # This file is part of FormValidator. # # Author: Francis J. Lacoste # Maintainer: Mark Stosberg # # Copyright (C) 2000 iNsu Innovations Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms same terms as perl itself. # use strict; package Data::FormValidator::Results; use Carp; use Symbol; use Data::FormValidator::Filters ':filters'; use Data::FormValidator::Constraints qw(:validators :matchers); use overload 'bool' => \&_bool_overload_based_on_success, fallback => 1; our $VERSION = 4.88; =pod =head1 NAME Data::FormValidator::Results - results of form input validation. =head1 SYNOPSIS my $results = Data::FormValidator->check(\%input_hash, \%dfv_profile); # Print the name of missing fields if ( $results->has_missing ) { for my $f ( $results->missing ) { print $f, " is missing\n"; } } # Print the name of invalid fields if ( $results->has_invalid ) { for my $f ( $results->invalid ) { print $f, " is invalid: ", $results->invalid( $f ), "\n"; } } # Print unknown fields if ( $results->has_unknown ) { for my $f ( $results->unknown ) { print $f, " is unknown\n"; } } # Print valid fields for my $f ( $results->valid() ) { print $f, " = ", $results->valid( $f ), "\n"; } =head1 DESCRIPTION This object is returned by the L C method. It can be queried for information about the validation results. =cut sub new { my $proto = shift; my $class = ref $proto || $proto; my ($profile, $data) = @_; my $self = bless {}, $class; $self->_process( $profile, $data ); $self; } sub _process { my ($self, $profile, $data) = @_; # Copy data and assumes that all is valid to start with my %data = $self->_get_input_as_hash($data); my %valid = %data; my @missings = (); my @unknown = (); # msgs() method will need access to the profile $self->{profile} = $profile; my %imported_validators; # import valid_* subs from requested packages for my $package (_arrayify($profile->{validator_packages})) { if ( !exists $imported_validators{$package} ) { local $SIG{__DIE__} = \&confess; eval "require $package"; if ($@) { die "Couldn't load validator package '$package': $@"; } # Perl will die with a nice error message if the package can't be found # No need to go through extra effort here. -mls :) my $package_ref = qualify_to_ref("${package}::"); my @subs = grep(/^(valid_|match_|filter_)/, keys(%{*{$package_ref}})); for my $sub (@subs) { # is it a sub? (i.e. make sure it's not a scalar, hash, etc.) my $subref = *{qualify_to_ref("${package}::$sub")}{CODE}; if (defined $subref) { *{qualify_to_ref($sub)} = $subref; } } $imported_validators{$package} = 1; } } # Apply unconditional filters for my $filter (_arrayify($profile->{filters})) { if (defined $filter) { # Qualify symbolic references $filter = (ref $filter eq 'CODE' ? $filter : *{qualify_to_ref("filter_$filter")}{CODE}) || die "No filter found named: '$filter'"; for my $field ( keys %valid ) { # apply filter, modifying %valid by reference, skipping undefined values _filter_apply(\%valid,$field,$filter); } } } # Apply specific filters while ( my ($field,$filters) = each %{$profile->{field_filters} }) { for my $filter ( _arrayify($filters)) { if (defined $filter) { # Qualify symbolic references $filter = (ref $filter eq 'CODE' ? $filter : *{qualify_to_ref("filter_$filter")}{CODE}) || die "No filter found named '$filter'"; # apply filter, modifying %valid by reference _filter_apply(\%valid,$field,$filter); } } } # add in specific filters from the regexp map while ( my ($re,$filters) = each %{$profile->{field_filter_regexp_map} }) { my $sub = _create_sub_from_RE($re); for my $filter ( _arrayify($filters)) { if (defined $filter) { # Qualify symbolic references $filter = (ref $filter eq 'CODE' ? $filter : *{qualify_to_ref("filter_$filter")}{CODE}) || die "No filter found named '$filter'"; no strict 'refs'; # find all the keys that match this RE and apply filters to them for my $field (grep { $sub->($_) } (keys %valid)) { # apply filter, modifying %valid by reference _filter_apply(\%valid,$field,$filter); } } } } # store the filtered data away for later use $self->{__FILTERED_DATA} = \%valid; my %required = map { $_ => 1 } _arrayify($profile->{required}); my %optional = map { $_ => 1 } _arrayify($profile->{optional}); # loop through and add fields to %required and %optional based on regular expressions my $required_re = _create_sub_from_RE($profile->{required_regexp}); my $optional_re = _create_sub_from_RE($profile->{optional_regexp}); for my $k (keys %valid) { if ($required_re && $required_re->($k)) { $required{$k} = 1; } if ($optional_re && $optional_re->($k)) { $optional{$k} = 1; } } # handle "require_some" while (my ($field, $dependent_require_some) = each %{$profile->{dependent_require_some}}) { if (defined $valid{$field}) { if (ref $dependent_require_some eq "CODE") { for my $value (_arrayify($valid{$field})) { my $returned_require_some = $dependent_require_some->($self, $value); if (ref($returned_require_some) eq 'HASH') { foreach my $key (keys %$returned_require_some) { $profile->{require_some}->{$key} = $returned_require_some->{$key}; } } } } else { if (ref($dependent_require_some) eq 'HASH') { foreach my $key (keys %$dependent_require_some) { $profile->{require_some}->{$key} = $dependent_require_some->{$key}; } } } } } my %require_some; while ( my ( $field, $deps) = each %{$profile->{require_some}} ) { for my $dep (_arrayify($deps)){ $require_some{$dep} = 1; } } # Remove all empty fields for my $field (keys %valid) { if (ref $valid{$field}) { if ( ref $valid{$field} eq 'ARRAY' ) { for (my $i = 0; $i < scalar @{ $valid{$field} }; $i++) { $valid{$field}->[$i] = undef unless (defined $valid{$field}->[$i] and length $valid{$field}->[$i] and $valid{$field}->[$i] !~ /^\x00$/); } # If all fields are empty, we delete it. delete $valid{$field} unless grep { defined $_ } @{$valid{$field}}; } } else { delete $valid{$field} unless (defined $valid{$field} and length $valid{$field} and $valid{$field} !~ /^\x00$/); } } # Check if the presence of some fields makes other optional fields required. while ( my ( $field, $deps) = each %{$profile->{dependencies}} ) { if (defined $valid{$field}) { if (ref($deps) eq 'HASH') { for my $key (keys %$deps) { # Handle case of a key with a single value given as an arrayref # There is probably a better, more general solution to this problem. my $val_to_compare; if ((ref $valid{$field} eq 'ARRAY') and (scalar @{ $valid{$field} } == 1)) { $val_to_compare = $valid{$field}->[0]; } else { $val_to_compare = $valid{$field} } if($val_to_compare eq $key){ for my $dep (_arrayify($deps->{$key})){ $required{$dep} = 1; } } } } elsif (ref $deps eq "CODE") { for my $val (_arrayify($valid{$field})) { my $returned_deps = $deps->($self, $val); for my $dep (_arrayify($returned_deps)) { $required{$dep} = 1; } } } else { for my $dep (_arrayify($deps)){ $required{$dep} = 1; } } } } # check dependency groups # the presence of any member makes them all required for my $group (values %{ $profile->{dependency_groups} }) { my $require_all = 0; for my $field (_arrayify($group)) { $require_all = 1 if $valid{$field}; } if ($require_all) { map { $required{$_} = 1 } _arrayify($group); } } my $dependency_re; foreach my $re (keys %{$profile->{dependencies_regexp}}) { my $sub = _create_sub_from_RE($re); $dependency_re->{$re} = { sub => $sub, value => $profile->{dependencies_regexp}->{$re}, }; } if ($dependency_re) { foreach my $k (keys %valid) { foreach my $re (keys %$dependency_re) { if ($dependency_re->{$re}->{sub}->($k)) { my $deps = $dependency_re->{$re}->{value}; if (ref($deps) eq 'HASH') { for my $key (keys %$deps) { # Handle case of a key with a single value given as an arrayref # There is probably a better, more general solution to this problem. my $val_to_compare; if ((ref $valid{$k} eq 'ARRAY') and (scalar @{ $valid{$k} } == 1)) { $val_to_compare = $valid{$k}->[0]; } else { $val_to_compare = $valid{$k} } if($val_to_compare eq $key){ for my $dep (_arrayify($deps->{$key})){ $required{$dep} = 1; } } } } elsif (ref $deps eq "CODE") { for my $val (_arrayify($valid{$k})) { my $returned_deps = $deps->($self, $val, $k); for my $dep (_arrayify($returned_deps)) { $required{$dep} = 1; } } } else { for my $dep (_arrayify($deps)){ $required{$dep} = 1; } } } } } } # Check if the presence of some fields makes other fields optional. while (my ($field, $dependent_optional) = each %{$profile->{dependent_optionals}} ) { if (defined $valid{$field}) { if (ref $dependent_optional eq "CODE") { for my $value (_arrayify($valid{$field})) { my $returned_optionals = $dependent_optional->($self, $value); foreach my $optional (_arrayify($returned_optionals)) { $optional{$optional} = 1; } } } else { foreach my $optional (_arrayify($dependent_optional)){ $optional{$optional} = 1; } } } } # Find unknown @unknown = grep { not (exists $optional{$_} or exists $required{$_} or exists $require_some{$_} ) } keys %valid; # and remove them from the list for my $field ( @unknown ) { delete $valid{$field}; } # Add defaults from defaults_regexp_map my %private_defaults; my @all_possible = keys %optional, keys %required, keys %require_some; while ( my ($re,$value) = each %{$profile->{defaults_regexp_map}} ) { # We only add defaults for known fields. for (@all_possible) { $private_defaults{$_} = $value if m/$re/; } } # Fill defaults my %combined_defaults = ( %private_defaults, %{ $profile->{defaults} || {} } ); while ( my ($field,$value) = each %combined_defaults ) { unless(exists $valid{$field}) { if (ref($value) && ref($value) eq "CODE") { $valid{$field} = $value->($self); } else { $valid{$field} = $value; } } } # Check for required fields for my $field ( keys %required ) { push @missings, $field unless exists $valid{$field}; } # Check for the absence of require_some fields while ( my ( $field, $deps) = each %{$profile->{require_some}} ) { my $enough_required_fields = 0; my @deps = _arrayify($deps); # num fields to require is first element in array if looks like a digit, 1 otherwise. my $num_fields_to_require = ($deps[0] =~ m/^\d+$/) ? $deps[0] : 1; for my $dep (@deps){ $enough_required_fields++ if exists $valid{$dep}; } push @missings, $field unless ($enough_required_fields >= $num_fields_to_require); } # add in the constraints from the regexp maps # We don't want to modify the profile, so we use a new variable. $profile->{constraints} ||= {}; my $private_constraints = { %{ $profile->{constraints} }, _add_constraints_from_map($profile,'constraint',\%valid), }; $profile->{constraint_methods} ||= {}; my $private_constraint_methods = { %{ $profile->{constraint_methods} }, _add_constraints_from_map($profile,'constraint_method',\%valid), }; #Decide which fields to untaint my ($untaint_all, %untaint_hash); if (defined $profile->{untaint_regexp_map} or defined $profile->{untaint_constraint_fields} ) { # first deal with untaint_constraint_fields if (defined($profile->{untaint_constraint_fields})) { if (ref $profile->{untaint_constraint_fields} eq "ARRAY") { for my $field (@{$profile->{untaint_constraint_fields}}) { $untaint_hash{$field} = 1; } } elsif ($valid{$profile->{untaint_constraint_fields}}) { $untaint_hash{$profile->{untaint_constraint_fields}} = 1; } } # now look at untaint_regexp_map if(defined($profile->{untaint_regexp_map})) { my @untaint_regexes; if(ref $profile->{untaint_regexp_map} eq "ARRAY") { @untaint_regexes = @{$profile->{untaint_regexp_map}}; } else { push(@untaint_regexes, $profile->{untaint_regexp_map}); } for my $regex (@untaint_regexes) { # look at both constraints and constraint_methods for my $field (keys %$private_constraints, keys %$private_constraint_methods) { next if($untaint_hash{$field}); $untaint_hash{$field} = 1 if( $field =~ $regex ); } } } } elsif ((defined($profile->{untaint_all_constraints})) && ($profile->{untaint_all_constraints} == 1)) { $untaint_all = 1; } $self->_check_constraints($private_constraints,\%valid,$untaint_all,\%untaint_hash); my $force_method_p = 1; $self->_check_constraints($private_constraint_methods,\%valid,$untaint_all,\%untaint_hash, $force_method_p); # add back in missing optional fields from the data hash if we need to for my $field ( keys %data ) { if ($profile->{missing_optional_valid} and $optional{$field} and (not exists $valid{$field})) { $valid{$field} = undef; } } # all invalid fields are removed from valid hash for my $field (keys %{ $self->{invalid} }) { delete $valid{$field}; } my ($missing,$invalid); $self->{valid} ||= {}; $self->{valid} = { %valid , %{$self->{valid}} }; $self->{missing} = { map { $_ => 1 } @missings }; $self->{unknown} = { map { $_ => $data{$_} } @unknown }; } =pod =head1 success(); This method returns true if there were no invalid or missing fields, else it returns false. As a shorthand, When the $results object is used in boolean context, it is overloaded to use the value of success() instead. That allows creation of a syntax like this one used in C: my $results = $self->check_rm('form_display','_form_profile') || return $self->dfv_error_page; =cut sub success { my $self = shift; return !($self->has_invalid || $self->has_missing); } =head1 valid( [[field] [, value]] ); In list context with no arguments, it returns the list of fields which contain valid values: @all_valid_field_names = $r->valid; In a scalar context with no arguments, it returns an hash reference which contains the valid fields as keys and their input as values: $all_valid_href = $r->valid; If called with one argument in scalar context, it returns the value of that C if it contains valid data, C otherwise. The value will be an array ref if the field had multiple values: $value = $r->valid('field'); If called with one argument in list context, it returns the values of C as an array: @values = $r->valid('field'); If called with two arguments, it sets C to C and returns C. This form is useful to alter the results from within some constraints. See the L documentation. $new_value = $r->valid('field',$new_value); =cut sub valid { my $self = shift; my $key = shift; my $val = shift; $self->{valid}{$key} = $val if defined $val; if (defined $key) { return wantarray ? _arrayify($self->{valid}{$key}) : $self->{valid}{$key}; } # If we got this far, there were no arguments passed. return wantarray ? keys %{ $self->{valid} } : $self->{valid}; } =pod =head1 has_missing() This method returns true if the results contain missing fields. =cut sub has_missing { return scalar keys %{$_[0]{missing}}; } =pod =head1 missing( [field] ) In list context it returns the list of fields which are missing. In a scalar context, it returns an array reference to the list of missing fields. If called with an argument, it returns true if that C is missing, undef otherwise. =cut sub missing { return $_[0]{missing}{$_[1]} if (defined $_[1]); wantarray ? keys %{$_[0]{missing}} : [ keys %{$_[0]{missing}} ]; } =pod =head1 has_invalid() This method returns true if the results contain fields with invalid data. =cut sub has_invalid { return scalar keys %{$_[0]{invalid}}; } =pod =head1 invalid( [field] ) In list context, it returns the list of fields which contains invalid value. In a scalar context, it returns an hash reference which contains the invalid fields as keys, and references to arrays of failed constraints as values. If called with an argument, it returns the reference to an array of failed constraints for C. =cut sub invalid { my $self = shift; my $field = shift; return $self->{invalid}{$field} if defined $field; wantarray ? keys %{$self->{invalid}} : $self->{invalid}; } =pod =head1 has_unknown() This method returns true if the results contain unknown fields. =cut sub has_unknown { return scalar keys %{$_[0]{unknown}}; } =pod =head1 unknown( [field] ) In list context, it returns the list of fields which are unknown. In a scalar context, it returns an hash reference which contains the unknown fields and their values. If called with an argument, it returns the value of that C if it is unknown, undef otherwise. =cut sub unknown { return (wantarray ? _arrayify($_[0]{unknown}{$_[1]}) : $_[0]{unknown}{$_[1]}) if (defined $_[1]); wantarray ? keys %{$_[0]{unknown}} : $_[0]{unknown}; } =pod =head1 msgs([config parameters]) This method returns a hash reference to error messages. The exact format is determined by parameters in the C area of the validation profile, described in the L documentation. B the C parameter in the profile can take a code reference as a value, allowing complete control of how messages are generated. If such a code reference was provided there, it will be called here instead of the usual processing, described below. It will receive as arguments the L object and a hash reference of control parameters. The hashref passed in should contain the same options that you can define in the validation profile. This allows you to separate the controls for message display from the rest of the profile. While validation profiles may be different for every form, you may wish to format messages the same way across many projects. Controls passed into the method will be applied first, followed by ones applied in the profile. This allows you to keep the controls you pass to C as "global" and override them in a specific profile if needed. =cut sub msgs { my $self = shift; my $msgs = $self->{profile}{msgs} || {}; if ((ref $msgs eq 'CODE')) { return $msgs->($self,@_); } else { return $self->_generate_msgs(@_); } } sub _generate_msgs { my $self = shift; my $controls = shift || {}; if (defined $controls and ref $controls ne 'HASH') { die "$0: parameter passed to msgs must be a hash ref"; } # Allow msgs to be called more than one to accumulate error messages $self->{msgs} ||= {}; $self->{profile}{msgs} ||= {}; $self->{msgs} = { %{ $self->{msgs} }, %$controls }; # Legacy typo support. for my $href ($self->{msgs}, $self->{profile}{msgs}) { if ( (not defined $href->{invalid_separator}) && (defined $href->{invalid_seperator}) ) { $href->{invalid_separator} = $href->{invalid_seperator}; } } my %profile = ( prefix => '', missing => 'Missing', invalid => 'Invalid', invalid_separator => ' ', format => '* %s', %{ $self->{msgs} }, %{ $self->{profile}{msgs} }, ); my %msgs = (); # Add invalid messages to hash # look at all the constraints, look up their messages (or provide a default) # add field + formatted constraint message to hash if ($self->has_invalid) { my $invalid = $self->invalid; for my $i ( keys %$invalid ) { $msgs{$i} = join $profile{invalid_separator}, map { _error_msg_fmt($profile{format},($profile{constraints}{$_} || $profile{invalid})) } @{ $invalid->{$i} }; } } # Add missing messages, if any if ($self->has_missing) { my $missing = $self->missing; for my $m (@$missing) { $msgs{$m} = _error_msg_fmt($profile{format},$profile{missing}); } } my $msgs_ref = prefix_hash($profile{prefix},\%msgs); if (! $self->success) { $msgs_ref->{ $profile{any_errors} } = 1 if defined $profile{any_errors}; } return $msgs_ref; } =pod =head1 meta() In a few cases, a constraint may discover meta data that is useful to access later. For example, when using L, several bits of meta data are discovered about files in the process of validating. These can include "bytes", "width", "height" and "extension". The C function is used by constraint methods to set this data. It's also used to access this data. Here are some examples. # return all field names that have meta data my @fields = $results->meta(); # To retrieve all meta data for a field: $meta_href = $results->meta('img'); # Access a particular piece: $width = $results->meta('img')->{width}; Here's how to set some meta data. This is useful to know if you are writing your own complex constraint. $self->meta('img', { width => '50', height => '60', }); This function does not currently support multi-valued fields. If it does in the future, the above syntax will still work. =cut sub meta { my $self = shift; my $field = shift; my $data = shift; # initialize if it's the first call $self->{__META} ||= {}; if ($data) { (ref $data eq 'HASH') or die 'meta: data passed not a hash ref'; $self->{__META}{$field} = $data; } # If we are passed a field, return data for that field if ($field) { return $self->{__META}{$field}; } # Otherwise return a list of all fields that have meta data else { return keys %{ $self->{__META} }; } } # These are documented in ::Constraints, in the section # on writing your own routines. It was more intuitive # for the user to look there. sub get_input_data { my $self = shift; my %p = @_; if ($p{as_hashref}) { my %hash = $self->_get_input_as_hash( $self->{__INPUT_DATA} ); return \%hash; } else { return $self->{__INPUT_DATA}; } } sub get_filtered_data { my $self = shift; return $self->{__FILTERED_DATA}; } sub get_current_constraint_field { my $self = shift; return $self->{__CURRENT_CONSTRAINT_FIELD}; } sub get_current_constraint_value { my $self = shift; return $self->{__CURRENT_CONSTRAINT_VALUE}; } sub get_current_constraint_name { my $self = shift; return $self->{__CURRENT_CONSTRAINT_NAME}; } sub untainted_constraint_value { my $self = shift; my $match = shift; return undef unless defined $match; return $self->{__UNTAINT_THIS} ? $match : length $match; } sub set_current_constraint_name { my $self = shift; my $value = shift; $self->{__CURRENT_CONSTRAINT_NAME} = $value; } # same as above sub name_this { my $self = shift; my $value = shift; $self->{__CURRENT_CONSTRAINT_NAME} = $value; } # INPUT: prefix_string, hash reference # Copies the hash and prefixes all keys with prefix_string # OUTPUT: hash reference sub prefix_hash { my ($pre,$href) = @_; die "prefix_hash: need two arguments" unless (scalar @_ == 2); die "prefix_hash: second argument must be a hash ref" unless (ref $href eq 'HASH'); my %out; for (keys %$href) { $out{$pre.$_} = $href->{$_}; } return \%out; } # We tolerate two kinds of regular expression formats # First, the preferred format made with "qr", matched using a leading paren # Also, we accept the deprecated format given as strings: 'm/old/' # (which must start with a slash or "m", not a paren) sub _create_sub_from_RE { my $re = shift || return undef; my $untaint_this = shift; my $force_method_p = shift; my $sub; # If it's "qr" style if (substr($re,0,1) eq '(') { $sub = sub { # With methods, the value is the second argument my $val = $force_method_p ? $_[1] : $_[0]; my ($match) = scalar ($val =~ $re); if ($untaint_this && defined $match) { # pass the value through a RE that matches anything to untaint it. my ($untainted) = ($& =~ m/(.*)/s); return $untainted; } else { return $match; } }; } else { local $SIG{__DIE__} = \&confess; my $return_code = ($untaint_this) ? '; return ($& =~ m/(.*)/s)[0] if defined($`);' : ''; # With methods, the value is the second argument if ($force_method_p) { $sub = eval 'sub { $_[1] =~ '.$re.$return_code. '}'; } else { $sub = eval 'sub { $_[0] =~ '.$re.$return_code. '}'; } die "Error compiling regular expression $re: $@" if $@; } return $sub; } sub _error_msg_fmt { my ($fmt,$msg) = @_; $fmt ||= '* %s'; ($fmt =~ m/%s/) || die 'format must contain %s'; return sprintf $fmt, $msg; } # takes string or array ref as input # returns array sub _arrayify { # if the input is undefined, return an empty list my $val = shift; defined $val or return (); # if it's a reference, return an array unless it points to an empty array. -mls if ( ref $val eq 'ARRAY' ) { local $^W = 0; # turn off warnings about undef return grep(defined, @$val) ? @$val : (); } # if it's a string, return an array unless the string is missing or empty. -mls else { return (length $val) ? ($val) : (); } } # apply filter, modifying %valid by reference # We don't bother trying to filter undefined fields. # This prevents warnings from Perl. sub _filter_apply { my ($valid,$field,$filter) = @_; die 'wrong number of arguments passed to _filter_apply' unless (scalar @_ == 3); if (ref $valid->{$field} eq 'ARRAY') { for (my $i = 0; $i < @{ $valid->{$field} }; $i++) { $valid->{$field}->[$i] = $filter->( $valid->{$field}->[$i] ) if defined $valid->{$field}->[$i]; } } else { $valid->{$field} = $filter->( $valid->{$field} ) if defined $valid->{$field}; } } # =head2 _constraint_hash_build() # # $constraint_href = $self->_constraint_hash_build($spec,$untaint_p) # # Input: # - $spec # Any constraint valid in the profile # - $untaint # bool for whether we could try to untaint the field. # - $force_method_p # bool for if it's a method ? # # Output: # - $constraint_hashref # Keys are as follows: # constraint - the constraint as coderef # name - the constraint name, if we know it. # params - 'params', as given in the hashref style of specifying a constraint # is_method - bool for whether this was a 'constraint' or 'constraint_method' sub _constraint_hash_build { my ($self,$constraint_spec,$untaint_this,$force_method_p) = @_; die "_constraint_hash_build received wrong number of arguments" unless (scalar @_ == 4); my $c = { name => undef, constraint => $constraint_spec, }; $c->{name} = $constraint_spec if not ref $constraint_spec; # constraints can be passed in directly via hash if (ref $c->{constraint} eq 'HASH') { $c->{constraint} = ($constraint_spec->{constraint_method} || $constraint_spec->{constraint}); $c->{name} = $constraint_spec->{name}; $c->{params} = $constraint_spec->{params}; $c->{is_method} = 1 if $constraint_spec->{constraint_method}; } # Check for regexp constraint if ((ref $c->{constraint} eq 'Regexp') or ( $c->{constraint} =~ m@^\s*(/.+/|m(.).+\2)[cgimosx]*\s*$@ )) { $c->{constraint} = _create_sub_from_RE($c->{constraint},$untaint_this,$force_method_p); } # check for code ref elsif (ref $c->{constraint} eq 'CODE') { # do nothing, it's already a code ref } else { # provide a default name for the constraint if we don't have one already if (not $c->{name} and not ref $c->{constraint}) { $c->{name} ||= $c->{constraint}; } #If untaint is turned on call match_* sub directly. if ($untaint_this) { my $routine = 'match_'.$c->{constraint}; my $match_sub = *{qualify_to_ref($routine)}{CODE}; if ($match_sub) { $c->{constraint} = $match_sub; } # If the constraint name starts with RE_, try looking for it in the Regexp::Common package elsif ($c->{constraint} =~ m/^RE_/) { local $SIG{__DIE__} = \&confess; $c->{is_method} = 1; $c->{constraint} = eval 'sub { &_create_regexp_common_constraint(@_)}' || die "could not create Regexp::Common constraint: $@"; } else { die "No untainting constraint found named $c->{constraint}"; } } else { # try to use match_* first my $routine = 'match_'.$c->{constraint}; if (defined *{qualify_to_ref($routine)}{CODE}) { local $SIG{__DIE__} = \&confess; $c->{constraint} = eval 'sub { no strict qw/refs/; return defined &{"match_'.$c->{constraint}.'"}(@_)}'; } # match_* doesn't exist; if it is supposed to be from the # validator_package(s) there may be only valid_* defined elsif (my $valid_sub = *{qualify_to_ref('valid_'.$c->{constraint})}{CODE}) { $c->{constraint} = $valid_sub; } # Load it from Regexp::Common elsif ($c->{constraint} =~ m/^RE_/) { local $SIG{__DIE__} = \&confess; $c->{is_method} = 1; $c->{constraint} = eval 'sub { return defined &_create_regexp_common_constraint(@_)}' || die "could not create Regexp::Common constraint: $@"; } else { die "No constraint found named '$c->{name}'"; } } } # Save the current constraint name for later $self->{__CURRENT_CONSTRAINT_NAME} = $c->{name}; return $c; } # =head2 _constraint_input_build() # # @params = $self->constraint_input_build($c,$value,$data); # # Build in the input that passed into the constraint. # # =cut sub _constraint_input_build { my ($self,$c,$value,$data) = @_; die "_constraint_input_build received wrong number of arguments" unless (scalar @_ == 4); my @params; if (defined $c->{params}) { for my $fname (_arrayify($c->{params})) { # If the value is passed by reference, we treat it literally push @params, (ref $fname) ? $fname : $data->{$fname} } } else { push @params, $value; } unshift @params, $self if $c->{is_method}; return @params; } # =head2 _constraint_check_match() # # ($value,$failed_href) = $self->_constraint_check_match($c,\@params,$untaint_this); # # This is the routine that actually, finally, checks if a constraint passes or fails. # # Input: # - $c, a constraint hash, as returned by C<_constraint_hash_build()>. # - \@params, params to pass to the constraint, as prepared by C<_constraint_input_build()>. # - $untaint_this bool if we untaint successful constraints. # # Output: # - $value the value if successful # - $failed_href a hashref with the following keys: # - failed bool for failure or not # - name name of the failed constraint, if known. sub _constraint_check_match { my ($self,$c,$params,$untaint_this) = @_; die "_constraint_check_match received wrong number of arguments" unless (scalar @_ == 4); # Store whether or not we want untainting in the object so that constraints # can do the right thing conditionally. $self->{__UNTAINT_THIS} = $untaint_this; my $match = $c->{constraint}->( @$params ); # We need to make this distinction when untainting, # to allow untainting values that are defined but not true, # such as zero. my $success; if (defined $match) { $success = ($untaint_this) ? length $match : $match; } my $failed = 1 unless $success; return ( $match, { failed => $failed, name => $self->{__CURRENT_CONSTRAINT_NAME}, }, ); } # Figure out whether the data is a hash reference of a param-capable object and return it has a hash sub _get_input_as_hash { my ($self,$data) = @_; $self->{__INPUT_DATA} = $data; require Scalar::Util; # This checks whether we have an object that supports param if ( Scalar::Util::blessed($data) && $data->can('param') ) { my %return; for my $k ($data->param()){ # we expect param to return an array if there are multiple values my @v; # CGI::Simple requires us to call 'upload()' to get upload data, # while CGI/Apache::Request return it on calling 'param()'. # # This seems quirky, but there isn't a way for us to easily check if # "this field contains a file upload" or not. if ($data->isa('CGI::Simple')) { @v = $data->upload($k) || $data->param($k); } else { # insecure @v = $data->multi_param($k); } # we expect param to return an array if there are multiple values $return{$k} = scalar(@v)>1 ? \@v : $v[0]; } return %return; } # otherwise, it's already a hash reference elsif (ref $data eq 'HASH') { # be careful to actually copy array references my %copy = %$data; for (grep { ref $data->{$_} eq 'ARRAY' } keys %$data) { my @array_copy = @{ $data->{$_} }; $copy{$_} = \@array_copy; } return %copy; } else { die "Data::FormValidator->validate() or check() called with invalid input data structure."; } } # A newer version of this logic now exists in Constraints.pm in the AUTOLOADing section # This is is used to support the older param passing style. Eg: # # { # constraint => 'RE_foo_bar', # params => [ \'zoo' ] # } # # Still, it's possible, the two bits of logic could be refactored into one location if you cared # to do that. sub _create_regexp_common_constraint { # this should work most of the time and is useful for preventing warnings # prevent name space clashes package Data::FormValidator::Constraints::RegexpCommon; require Regexp::Common; import Regexp::Common 'RE_ALL'; my $self = shift; my $re_name = $self->get_current_constraint_name; # deference all input my @params = map {$_ = $$_ if ref $_ } @_; no strict "refs"; my $re = &$re_name(-keep=>1,@params) || die 'no matching Regexp::Common routine found'; return ($self->get_current_constraint_value =~ qr/^$re$/) ? $1 : undef; } # _add_constraints_from_map($profile,'constraint',\%valid); # Returns: # - a hash to add to either 'constraints' or 'constraint_methods' sub _add_constraints_from_map { die "_add_constraints_from_map: need 3 arguments" unless (scalar @_ == 3); my ($profile, $name, $valid) = @_; ($name =~ m/^constraint(_method)?$/) || die "unexpected input."; my $key_name = $name.'s'; my $map_name = $name.'_regexp_map'; my %result = (); for my $re (keys %{ $profile->{$map_name} }) { my $sub = _create_sub_from_RE($re); # find all the keys that match this RE and add a constraint for them for my $key (keys %$valid) { if ($sub->($key)) { my $cur = $profile->{$key_name}{$key}; my $new = $profile->{$map_name}{$re}; # If they already have an arrayref of constraints, add to the list if (ref $cur eq 'ARRAY') { push @{ $result{$key} }, @$cur, $new; } # If they have a single constraint defined, create an array ref with with this plus the new one elsif ($cur) { $result{$key} = [$cur,$new]; } # otherwise, a new constraint is created with this as the single constraint else { $result{$key} = $new; } warn "$map_name: $key matches\n" if $profile->{debug}; } } } return %result; } sub _bool_overload_based_on_success { my $results = shift; return $results->success() } # =head2 _check_constraints() # # $self->_check_constraints( # $profile->{constraint_methods}, # \%valid, # $untaint_all # \%untaint_hash # $force_method_p #); # # Input: # - 'constraints' or 'constraint_methods' hashref # - hashref of valid data # - bool to try to untaint everything # - hashref of things to untaint # - bool if all constraints should be treated as methods. sub _check_constraints { my ($self, $constraint_href, $valid, $untaint_all, $untaint_href, $force_method_p) = @_; while ( my ($field,$constraint_list) = each %$constraint_href ) { next unless exists $valid->{$field}; my $is_constraint_list = 1 if (ref $constraint_list eq 'ARRAY'); my $untaint_this = ($untaint_all || $untaint_href->{$field} || 0); my @invalid_list; # used to insure we only bother recording each failed constraint once my %constraints_seen; for my $constraint_spec (_arrayify($constraint_list)) { # set current constraint field for use by get_current_constraint_field $self->{__CURRENT_CONSTRAINT_FIELD} = $field; # Initialize the current constraint name to undef, to prevent it # from being accidently shared $self->{__CURRENT_CONSTRAINT_NAME} = undef; my $c = $self->_constraint_hash_build($constraint_spec,$untaint_this, $force_method_p); $c->{is_method} = 1 if $force_method_p; my $is_value_list = 1 if (ref $valid->{$field} eq 'ARRAY'); my %param_data = ( $self->_get_input_as_hash($self->get_input_data) , %$valid ); if ($is_value_list) { for (my $i = 0; $i < scalar @{ $valid->{$field}} ; $i++) { if( !exists $constraints_seen{\$c} ) { my @params = $self->_constraint_input_build($c,$valid->{$field}->[$i],\%param_data); # set current constraint field for use by get_current_constraint_value $self->{__CURRENT_CONSTRAINT_VALUE} = $valid->{$field}->[$i]; my ($match,$failed) = $self->_constraint_check_match($c,\@params,$untaint_this); if ($failed->{failed}) { push @invalid_list, $failed; $constraints_seen{\$c} = 1; } else { $valid->{$field}->[$i] = $match if $untaint_this; } } } } else { my @params = $self->_constraint_input_build($c,$valid->{$field},\%param_data); # set current constraint field for use by get_current_constraint_value $self->{__CURRENT_CONSTRAINT_VALUE} = $valid->{$field}; my ($match,$failed) = $self->_constraint_check_match($c,\@params,$untaint_this); if ($failed->{failed}) { push @invalid_list, $failed } else { $valid->{$field} = $match if $untaint_this; } } } if (@invalid_list) { my @failed = map { $_->{name} } @invalid_list; push @{ $self->{invalid}{$field} }, @failed; # the older interface to validate returned things differently push @{ $self->{validate_invalid} }, $is_constraint_list ? [$field, @failed] : $field; } } } 1; __END__ =pod =head1 SEE ALSO Data::FormValidator, Data::FormValidator::Filters, Data::FormValidator::Constraints, Data::FormValidator::ConstraintsFactory =head1 AUTHOR Author: Francis J. Lacoste Maintainer: Mark Stosberg =head1 COPYRIGHT Copyright (c) 1999,2000 iNsu Innovations Inc. All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms as perl itself. =cut Data-FormValidator-4.88/lib/Data/FormValidator/Constraints.pm0000644000175000017500000007534113151006761024314 0ustar dfarrelldfarrell# # Constraints.pm - Standard constraints for use in Data::FormValidator. # # This file is part of Data::FormValidator. # # Author: Francis J. Lacoste # Maintainer: Mark Stosberg # # Copyright (C) 1999,2000 iNsu Innovations Inc. # Copyright (C) 2001 Francis J. Lacoste # Parts Copyright 1996-1999 by Michael J. Heins # Parts Copyright 1996-1999 by Bruce Albrecht # # Parts of this module are based on work by # Bruce Albrecht, contributed to MiniVend. # # Parts also based on work by Michael J. Heins # # This program is free software; you can redistribute it and/or modify # it under the terms same terms as perl itself. # package Data::FormValidator::Constraints; use base 'Exporter'; use strict; our $AUTOLOAD; our $VERSION = 4.88; BEGIN { use Carp; my @closures = (qw/ american_phone cc_exp cc_number cc_type email ip_address phone postcode province state state_or_province zip zip_or_postcode/); # This be optimized with some of the voodoo that CGI.pm # uses to AUTOLOAD dynamic functions. for my $func (@closures) { # cc_number is defined statically unless ($func eq 'cc_number') { # Notice we have to escape some characters # in the subroutine, which is really a string here. local $SIG{__DIE__} = \&confess; my $code = qq! sub $func { return sub { my \$dfv = shift; use Scalar::Util (); die "first arg to $func was not an object. Must be called as a constraint_method." unless ( Scalar::Util::blessed(\$dfv) && \$dfv->can('name_this') ); \$dfv->name_this('$func') unless \$dfv->get_current_constraint_name(); no strict 'refs'; return &{"match_$func"}(\@_); } } !; eval "package Data::FormValidator::Constraints; $code"; die "couldn't create $func: $@" if $@; } } my @FVs = (qw/ FV_length_between FV_min_length FV_max_length FV_eq_with FV_num_values FV_num_values_between /); our @EXPORT_OK = ( @closures, @FVs, qw( valid_american_phone valid_cc_exp valid_cc_number valid_cc_type valid_email valid_ip_address valid_phone valid_postcode valid_province valid_state valid_state_or_province valid_zip valid_zip_or_postcode match_american_phone match_cc_exp match_cc_number match_cc_type match_email match_ip_address match_phone match_postcode match_province match_state match_state_or_province match_zip match_zip_or_postcode) ); our %EXPORT_TAGS = ( # regexp common is correctly empty here, because we handle the case on the fly with the import function below. regexp_common => [], closures => [ @closures, @FVs ], validators => [qw/ valid_american_phone valid_cc_exp valid_cc_number valid_cc_type valid_email valid_ip_address valid_phone valid_postcode valid_province valid_state valid_state_or_province valid_zip valid_zip_or_postcode /], matchers => [qw/ match_american_phone match_cc_exp match_cc_number match_cc_type match_email match_ip_address match_phone match_postcode match_province match_state match_state_or_province match_zip match_zip_or_postcode /], ); sub import { # This is Regexp::Common support. # Here we are handling cases that look like this: # # my_field => FV_foo_bar(-zoo=>'queue'), if (grep { m/^:regexp_common$/ } @_) { require Regexp::Common; import Regexp::Common 'RE_ALL'; for my $sub (grep { m/^RE_/} keys %Data::FormValidator::Constraints:: ) { no strict 'refs'; my $new_name = $sub; $new_name =~ s/^RE_/FV_/; *{caller() . "::$new_name"} = sub { my @params = @_; return sub { my $dfv = shift; $dfv->name_this($new_name) unless $dfv->get_current_constraint_name(); no strict "refs"; my $re = &$sub(-keep=>1,@params); my ($match) = ($dfv->get_current_constraint_value =~ qr/^($re)$/); return $dfv->untainted_constraint_value($match); } } } } Data::FormValidator::Constraints->export_to_level(1,@_); } } # sub DESTROY {} =pod =head1 NAME Data::FormValidator::Constraints - Basic sets of constraints on input profile. =head1 SYNOPSIS use Data::FormValidator::Constraints qw(:closures); In an Data::FormValidator profile: constraint_methods => { email => email(), phone => american_phone(), first_names => { constraint_method => FV_max_length(3), name => 'my_custom_name', }, }, msgs => { constraints => { my_custom_name => 'My message', }, }, =head1 DESCRIPTION These are the builtin constraints that can be specified by name in the input profiles. Be sure to check out the SEE ALSO section for even more pre-packaged constraints you can use. =cut sub AUTOLOAD { my $name = $AUTOLOAD; no strict qw/refs/; $name =~ m/^(.*::)(valid_|RE_)(.*)/; my ($pkg,$prefix,$sub) = ($1,$2,$3); #warn "hello! my ($pkg,$prefix,$sub) = ($1,$2,$3);"; # Since all the valid_* routines are essentially identical we're # going to generate them dynamically from match_ routines with the same names. if ((defined $prefix) and ($prefix eq 'valid_')) { return defined &{$pkg.'match_' . $sub}(@_); } } =head2 FV_length_between(1,23) =head2 FV_max_length(23) =head2 FV_min_length(1) use Data::FormValidator::Constraints qw( FV_length_between FV_min_length FV_max_length ); constraint_methods => { # specify a min and max, inclusive last_name => FV_length_between(1,23), } Specify a length constraint for a field. These constraints have a different naming convention because they are higher-order functions. They take input and return a code reference to a standard constraint method. A constraint name of C, C, or C will be set, corresponding to the function name you choose. The checks are all inclusive, so a max length of '100' will allow the length 100. Length is measured in perl characters as opposed to bytes or anything else. This constraint I untaint your data if you have untainting turned on. However, a length check alone may not be enough to insure the safety of the data you are receiving. Using additional constraints to check the data is encouraged. =cut sub FV_length_between { my ($min,$max) = @_; if (not (defined $min and defined $max)) { croak "min and max are required"; } return sub { my ($dfv,$value) = @_; $dfv->name_this('length_between') unless $dfv->get_current_constraint_name(); return undef if ( ( length($value) > $max ) || ( length($value) < $min) ); # Use a regexp to untaint $value=~/(.*)/s; return $dfv->untainted_constraint_value($1); } } sub FV_max_length { my ($max) = @_; croak "max is required" unless defined $max; return sub { my ($dfv,$value) = @_; $dfv->name_this('max_length') unless $dfv->get_current_constraint_name(); return undef if ( length($value) > $max ); # Use a regexp to untaint $value=~/(.*)/s; return $dfv->untainted_constraint_value($1); } } sub FV_min_length { my ($min) = @_; croak "min is required" unless defined $min; return sub { my ($dfv,$value) = @_; $dfv->name_this('min_length') unless $dfv->get_current_constraint_name(); return undef if ( length($value) < $min ); # Use a regexp to untaint $value=~/(.*)/s; return $dfv->untainted_constraint_value($1); } } =head2 FV_eq_with use Data::FormValidator::Constraints qw( FV_eq_with ); constraint_methods => { password => FV_eq_with('password_confirm'), } Compares the current field to another field. A constraint name of C will be set. =cut sub FV_eq_with { my ($other_field) = @_; return sub { my $dfv = shift; $dfv->name_this('eq_with') unless $dfv->get_current_constraint_name(); my $curr_val = $dfv->get_current_constraint_value; my $data = $dfv->get_filtered_data; # Sometimes the data comes through both ways... my $other_val = (ref $data->{$other_field}) ? $data->{$other_field}[0] : $data->{$other_field}; return ($curr_val eq $other_val); } } =head2 FV_num_values use Data::FormValidator::Constraints qw ( FV_num_values ); constraint_methods => { attachments => FV_num_values(4), } Checks the number of values in the array named by this param. Note that this is useful for making sure that only one value was passed for a given param (by supplying a size argument of 1). A constraint name of C will be set. =cut sub FV_num_values { my $size = shift || croak 'size argument is required'; return sub { my $dfv = shift; $dfv->name_this('num_values'); my $param = $dfv->get_current_constraint_field(); my $value = $dfv->get_filtered_data()->{$param}; # If there's an arrayref of values provided, test the number of them found # against the number of them of required if (defined $value and ref $value eq 'ARRAY') { my $num_values_found = scalar @$value; return ($num_values_found == $size); } # If a size of 1 was requested, there was not an arrayref of values, # there must be exactly one value. elsif ($size == 1) { return 1; } # Any other case is failure. else { return 0; } } } =head2 FV_num_values_between use Data::FormValidator::Constraints qw ( FV_num_values_between ); constraint_methods => { attachments => FV_num_values_between(1,4), } Checks that the number of values in the array named by this param is between the supplied bounds (inclusively). A constraint name of C will be set. =cut sub FV_num_values_between { my ($min, $max) = @_; croak 'min and max arguments are required' unless $min && $max; return sub { my $dfv = shift; $dfv->name_this('num_values_between'); my $param = $dfv->get_current_constraint_field(); my $value = $dfv->get_filtered_data()->{$param}; if (ref($value) eq 'ARRAY') { my $num_values = scalar @$value; return( ( $num_values >= $min && $num_values <= $max ) ? 1 : 0 ); } else { if ($min <= 1 && $max >= 1) { # Single value is allowed return 1; } else { return 0; } } } } =head2 email Checks if the email LOOKS LIKE an email address. This should be sufficient 99% of the time. Look elsewhere if you want something super fancy that matches every possible variation that is valid in the RFC, or runs out and checks some MX records. =cut # Many of the following validators are taken from # MiniVend 3.14. (http://www.minivend.com) # Copyright 1996-1999 by Michael J. Heins sub match_email { my $in_email = shift; require Email::Valid; my $valid_email; # The extra check that the result matches the input prevents # an address like this from being considered valid: Joe Smith if ( ($valid_email = Email::Valid->address($in_email) ) and ($valid_email eq $in_email)) { return $valid_email; } else { return undef; } } my $state = < { cc_no => cc_number({fields => ['cc_type']}), } The number is checked only for plausibility, it checks if the number could be valid for a type of card by checking the checksum and looking at the number of digits and the number of digits of the number. This functions is only good at catching typos. IT DOESN'T CHECK IF THERE IS AN ACCOUNT ASSOCIATED WITH THE NUMBER. =cut # This one is taken from the contributed program to # MiniVend by Bruce Albrecht # XXX raise exception on bad/missing params? sub cc_number { my $attrs = shift; return undef unless $attrs && ref($attrs) eq 'HASH' && exists $attrs->{fields} && ref($attrs->{fields}) eq 'ARRAY'; my ($cc_type_field) = @{ $attrs->{fields} }; return undef unless $cc_type_field; return sub { my $dfv = shift; my $data = $dfv->get_filtered_data; return match_cc_number( $dfv->get_current_constraint_value, $data->{$cc_type_field} ); }; } sub match_cc_number { my ( $the_card, $card_type ) = @_; my $orig_card = $the_card; #used for return match at bottom my ($index, $digit, $product); my $multiplier = 2; # multiplier is either 1 or 2 my $the_sum = 0; return undef if length($the_card) == 0; # check card type return undef unless $card_type =~ /^[admv]/i; return undef if ($card_type =~ /^v/i && substr($the_card, 0, 1) ne "4") || ($card_type =~ /^m/i && substr($the_card, 0, 1) ne "5" && substr($the_card, 0, 1) ne "2") || ($card_type =~ /^d/i && substr($the_card, 0, 4) ne "6011") || ($card_type =~ /^a/i && substr($the_card, 0, 2) ne "34" && substr($the_card, 0, 2) ne "37"); # check for valid number of digits. $the_card =~ s/\s//g; # strip out spaces return undef if $the_card !~ /^\d+$/; $digit = substr($the_card, 0, 1); $index = length($the_card)-1; return undef if ($digit == 3 && $index != 14) || ($digit == 4 && $index != 12 && $index != 15) || ($digit == 5 && $index != 15) || ($digit == 6 && $index != 13 && $index != 15); # calculate checksum. for ($index--; $index >= 0; $index --) { $digit=substr($the_card, $index, 1); $product = $multiplier * $digit; $the_sum += $product > 9 ? $product - 9 : $product; $multiplier = 3 - $multiplier; } $the_sum %= 10; $the_sum = 10 - $the_sum if $the_sum; # return whether checksum matched. if ($the_sum == substr($the_card, -1)) { if ($orig_card =~ /^([\d\s]*)$/) { return $1; } else { return undef; } } else { return undef; } } =head2 cc_exp This one checks if the input is in the format MM/YY or MM/YYYY and if the MM part is a valid month (1-12) and if that date is not in the past. =cut sub match_cc_exp { my $val = shift; my ($matched_month, $matched_year); my ($month, $year) = split('/', $val); return undef if $month !~ /^(\d+)$/; $matched_month = $1; return undef if $year !~ /^(\d+)$/; $matched_year = $1; return undef if $month <1 || $month > 12; $year += ($year < 70) ? 2000 : 1900 if $year < 1900; my @now=localtime(); $now[5] += 1900; return undef if ($year < $now[5]) || ($year == $now[5] && $month <= $now[4]); return "$matched_month/$matched_year"; } =head2 cc_type This one checks if the input field starts by M(asterCard), V(isa), A(merican express) or D(iscovery). =cut sub match_cc_type { my $val = shift; if ($val =~ /^([MVAD].*)$/i) { return $1; } else { return undef; } } =head2 ip_address This checks if the input is formatted like a dotted decimal IP address (v4). For other kinds of IP address method, See L which provides several more options. L explains how we easily integrate with Regexp::Common. =cut # contributed by Juan Jose Natera Abreu sub match_ip_address { my $val = shift; if ($val =~ m/^((\d+)\.(\d+)\.(\d+)\.(\d+))$/) { if (($2 >= 0 && $2 <= 255) && ($3 >= 0 && $3 <= 255) && ($4 >= 0 && $4 <= 255) && ($5 >= 0 && $5 <= 255)) { return $1; } else { return undef; } } else { return undef; } } 1; __END__ =head1 RENAMING BUILT-IN CONSTAINTS If you'd like, you can rename any of the built-in constraints. Just define the constraint_method and name in a hashref, like this: constraint_methods => { first_names => { constraint_method => FV_max_length(3), name => 'custom_length', } }, =head1 REGEXP::COMMON SUPPORT Data::FormValidator also includes built-in support for using any of regular expressions in L as named constraints. Simply use the name of regular expression you want. This works whether you want to untaint the data or not. For example: use Data::FormValidator::Constraints qw(:regexp_common); constraint_methods => { my_ip_address => FV_net_IPv4(), # An example with parameters other_ip => FV_net_IPv4(-sep=>' '), } Notice that the routines are named with the prefix "FV_" instead of "RE_" now. This is simply a visual cue that these are slightly modified versions. We've made a wrapper for each Regexp::Common routine so that it can be used as a named constraint like this. Be sure to check out the L syntax for how its syntax works. It will make more sense to add future regular expressions to Regexp::Common rather than to Data::FormValidator. =head1 PROCEDURAL INTERFACE You may also call these functions directly through the procedural interface by either importing them directly or importing the whole I<:validators> group. This is useful if you want to use the built-in validators out of the usual profile specification interface. For example, if you want to access the I validator directly, you could either do: use Data::FormValidator::Constraints (qw/valid_email/); or use Data::FormValidator::Constraints (:validators); if (valid_email($email)) { # do something with the email address } Notice that when you call validators directly, you'll need to prefix the validator name with "valid_" Each validator also has a version that returns the untainted value if the validation succeeded. You may call these functions directly through the procedural interface by either importing them directly or importing the I<:matchers> group. For example if you want to untaint a value with the I validator directly you may: if ($email = match_email($email)) { system("echo $email"); } else { die "Unable to validate email"; } Notice that when you call validators directly and want them to return an untainted value, you'll need to prefix the validator name with "match_" =pod =head1 WRITING YOUR OWN CONSTRAINT ROUTINES =head2 New School Constraints Overview This is the current recommended way to write constraints. See also L. The most flexible way to create constraints to use closures-- a normal seeming outer subroutine which returns a customized DFV method subroutine as a result. It's easy to do. These "constraint methods" can be named whatever you like, and imported normally into the name space where the profile is located. Let's look at an example. # Near your profile # Of course, you don't have to export/import if your constraints are in the same # package as the profile. use My::Constraints 'coolness'; # In your profile constraint_methods => { email => email(), prospective_date => coolness( 40, 60, {fields => [qw/personality smarts good_looks/]} ), } Let's look at how this complex C constraint method works. The interface asks for users to define minimum and maximum coolness values, as well as declaring three data field names that we should peek into to look their values. Here's what the code might look like: sub coolness { my ($min_cool,$max_cool, $attrs) = @_; my ($personality,$smarts,$looks) = @{ $attrs->{fields} } if $attrs->{fields}; return sub { my $dfv = shift; # Name it to refer to in the 'msgs' system. $dfv->name_this('coolness'); # value of 'prospective_date' parameter my $val = $dfv->get_current_constraint_value(); # get other data to refer to my $data = $dfv->get_filtered_data; my $has_all_three = ($data->{$personality} && $data->{$smarts} && $data->{$looks}); return ( ($val >= $min_cool) && ($val <= $max_cool) && $has_all_three ); } } =head2 Old School Constraints Here is documentation on how old school constraints are created. These are supported, but the new school style documented above is recommended. See also the C option in the input profile, for loading sets of old school constraints from other packages. Old school constraint routines are named two ways. Some are named with the prefix C while others start with C. The difference is that the C routines are built to untaint the data and return a safe version of it if it validates, while C routines simply return a true value if the validation succeeds and false otherwise. It is preferable to write C routines that untaint data for the extra security benefits. Plus, Data::FormValidator will AUTOLOAD a C version if anyone tries to use it, so you only need to write one routine to cover both cases. Usually constraint routines only need one input, the value being specified. However, sometimes more than one value is needed. B: image_field => { constraint_method => 'max_image_dimensions', params => [\100,\200], }, Using that syntax, the first parameter that will be passed to the routine is the Data::FormValidator object. The remaining parameters will come from the C array. Strings will be replaced by the values of fields with the same names, and references will be passed directly. In addition to C, there is also an even older technique using the name C instead. Routines that are designed to work with C I have access to Data::FormValidator object, which means users need to pass in the name of the field being validated. Besides adding unnecessary syntax to the user interface, it won't work in conjunction with C. =head2 Methods available for use inside of constraints A few useful methods to use on the Data::FormValidator::Results object are available to you to use inside of your routine. =head3 get_input_data() Returns the raw input data. This may be a CGI object if that's what was used in the constraint routine. B # Raw and uncensored my $data = $self->get_input_data; # tamed to be a hashref, if it wasn't already my $data = $self->get_input_data( as_hashref => 1 ); =head3 get_filtered_data() my $data = $self->get_filtered_data; Returns the valid filtered data as a hashref, regardless of whether it started out as a CGI.pm compatible object. Multiple values are expressed as array references. =head3 get_current_constraint_field() Returns the name of the current field being tested in the constraint. B: my $field = $self->get_current_constraint_field; This reduces the number of parameters that need to be passed into the routine and allows multi-valued constraints to be used with C. For complete examples of multi-valued constraints, see L =head3 get_current_constraint_value() Returns the name of the current value being tested in the constraint. B: my $value = $self->get_current_constraint_value; This reduces the number of parameters that need to be passed into the routine and allows multi-valued constraints to be used with C. =head3 get_current_constraint_name() Returns the name of the current constraint being applied B: my $value = $self->get_current_constraint_name; This is useful for building a constraint on the fly based on its name. It's used internally as part of the interface to the L regular expressions. =head3 untainted_constraint_value() return $dfv->untainted_constraint_value($match); If you have written a constraint which untaints, use this method to return the untainted result. It will prepare the right result whether the user has requested untainting or not. =head3 name_this() =head3 set_current_constraint_name() Sets the name of the current constraint being applied. B: sub my_constraint { my @outer_params = @_; return sub { my $dfv = shift; $dfv->set_current_constraint_name('my_constraint'); my @params = @outer_params; # do something constraining here... } } By returning a closure which uses this method, you can build an advanced named constraint in your profile, before you actually have access to the DFV object that will be used later. See Data::FormValidator::Constraints::Upload for an example. C is a provided as a shorter synonym. The C method may also be useful to communicate meta data that may have been found. See L for documentation of that method. =head1 BACKWARDS COMPATIBILITY Prior to Data::FormValidator 4.00, constraints were specified a bit differently. This older style is still supported. It was not necessary to explicitly load some constraints into your name space, and the names were given as strings, like this: constraints => { email => 'email', fax => 'american_phone', phone => 'american_phone', state => 'state', my_ip_address => 'RE_net_IPv4', other_ip => { constraint => 'RE_net_IPv4', params => [ \'-sep'=> \' ' ], }, my_cc_no => { constraint => 'cc_number', params => [qw/cc_no cc_type/], } }, =head1 SEE ALSO =head2 Constraints available in other modules =over =item L - validate the bytes, format and dimensions of file uploads =item L - A newer DateTime constraint module. May save you a step of transforming the date into a more useful format after it's validated. =item L - the original DFV date constraint module. Try the newer one first! =item L - Japan-specific constraints =item L - a useful collection of tools generate more complex constraints. Recommended! =back =head2 Related modules in this package =over =item L - transform data before constraints are applied =item L - This is a historical collection of constraints that suffer from cumbersome names. They are worth reviewing though-- C 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. For a modern version of this toolkit, see L. =item L =back =head1 CREDITS Some of those input validation functions have been taken from MiniVend by Michael J. Heins The credit card checksum validation was taken from contribution by Bruce Albrecht to the MiniVend program. =head1 AUTHORS Francis J. Lacoste Michael J. Heins Bruce Albrecht Mark Stosberg =head1 COPYRIGHT Copyright (c) 1999 iNsu Innovations Inc. All rights reserved. Parts Copyright 1996-1999 by Michael J. Heins Parts Copyright 1996-1999 by Bruce Albrecht Parts Copyright 2005-2009 by Mark Stosberg This program is free software; you can redistribute it and/or modify it under the terms as perl itself. =cut Data-FormValidator-4.88/Makefile.PL0000644000175000017500000000235713150655251017231 0ustar dfarrelldfarrelluse 5.008; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Data::FormValidator', VERSION_FROM => 'lib/Data/FormValidator.pm', ABSTRACT_FROM => 'lib/Data/FormValidator.pm', AUTHOR => 'David Farrell ', LICENSE => 'perl', PREREQ_PM => { # In 5.6, t/upload* was failing. # rjbs says "It relies on CGI relying on 5.008 glob stringification behavior" 'perl' => '5.008', 'Image::Size' => 0, 'Test::More' => 0, 'Date::Calc' => 5.0, 'File::MMagic' => 1.17, 'MIME::Types' => 1.005, 'Regexp::Common' => 0.03, # when ::whitespace was added 'Scalar::Util' => 0, 'Email::Valid' => 0, 'File::Spec' => 0, }, (eval { ExtUtils::MakeMaker->VERSION(6.46) } ? (META_MERGE => { 'meta-spec' => { version => 2 }, resources => { repository => { type => 'git', url => 'https://github.com/dnmfarrell/Data-FormValidator', web => 'https://github.com/dnmfarrell/Data-FormValidator', }, }, # this is a cuckoo package in Data::FormValidator::Results no_index => { package => ['Data::FormValidator::Constraints::RegexpCommon'], }}) : () ), ); Data-FormValidator-4.88/Changes0000644000175000017500000010371213151007375016546 0ustar dfarrelldfarrell4.88 August 28th, 2017 [MAINTENANCE] - Address "." being removed from @INC by using absolute filepaths - thanks Kent Fredric! 4.87 May 14th, 2017 [MAINTENANCE] - Update cc routine to recognize new 2 series Mastercards 4.86 March 26th, 2017 [NEW FEATURES] - Add three new profile methods: depedencies_regexp, dependent_optional, dependent_require_some [MAINTENANCE] - Bump VERSION in all classes to 5.85 4.85 Feb 25th, 2017 [MAINTENANCE] - Bump VERSION in all classes to 5.85 4.84 Feb 25th, 2017 [MAINTENANCE] - Various test file warning fixes - Change conditional loading of CGI to require version 4.35 or higher (4ce9ac9e) 4.83 Feb 23rd, 2017 [MAINTENANCE] - Re-release of 4.82: tarball was missing files as "make dist" errored when it didn't find MANIFEST - Deleted unused Perl6 files 4.82 Feb 23rd, 2017 [MAINTENANCE] - Made CGI dependency optional - Replaced Build.PL with Makefile.PL - Updated Makefile.PL constraints - Removed dependency on Perl6::Junctions - Moved the code to GitHub - Applied patches from: RT 77765, 78443, 10489 - Added shebang, warnings pragma to all test scripts - Perltidied tests scripts - Replaced is_tainted() sub with Scalar::Util::tainted() 4.81 Jul 19th, 2013 [DOCUMENTATION] - There is no such thing as "array context". The documentation now refers to "list context" instead. - Fix "the the" typos. (Thanks to dsteinbrunner, RT#77901) [INTERNALS] - Somewhat modernizer Exporter usage. 4.80 Nov 1st, 2012 [NEW FEATURES] - New built-in constraint_methods to test the number of values submitted for a particular field: FV_num_values(1), FV_num_values_between(1,2), # inclusive One way that garbage can get through a Data::FormValidator profile is when two values are submitted when only one is intended. In this case, this application could end up with a values like this: ARRAY(0x841214c) Using these new constraints, you can precisely control how many values are allowed for each field. [INTERNAL] - Source control hosting has been moved to http://hub.darcs.net You can now browse, pull and fork the darcs repo through this website. 4.71 Oct 2nd, 2012 [BUG FIXES] - Custom messages for built-in constraints work again. It appears that this was broken in 4.70, which triggered a sleeper bug. (Thanks to Lee Carmichael, Mark Stosberg, RT#73235) 4.70 11/11/11 [NEW FEATURES] - Built-in constraints in Constraints.pm can now be renamed: constraint_methods => { first_names => { constraint_method => FV_max_length(3), name => 'custom_length', } }, (Thanks to heinst@arqs.com.br for the suggestion, RT#49477) [INTERNALS] - modernize Constraints.pm and Results.pm a bit. - Module::Build added to configure_requires in Build.PL 4.67 11/11/11 [INTERNALS] - modernize FormValidator.pm internals a bit - Update META.yml to exclude an internal package from getting indexed. 4.66 Wed Feb 24 09:30:17 EST 2010 [DOCUMENTATION] - Typo fixes (Jonathan Yu) [INTERNALS] - Test suite fix for 5.11.1 and newer. 4.65 Wed Dec 30 22:17:33 EST 2009 [NEW FEATURES] - New FV_replace() filter to simplify basic find-and-replace filters: field_filters => { first_name => FV_replace(qr/Mark/,'Don'), }, [BUG FIXES] - Untainted multi-line fields are no longer truncated after the first newline. (RT#44004, Thanks to Matthew Lawrence) - Fix bug when the constraint_method contains a capturing parens and 0 is a valid value. (RT#45177, Thanks to Junior Medina and Mark Stosberg) [DOCUMENTATION] - Typo fixes (Lyle) [INTERNALS] - Best Practice: Redundant tag was removed from default error message formatting (RT#42926), Thanks to girlwithglasses) - Best Practice: eliminated some indirect object notation in the tests (Mark Stosberg) - Now require a new CGI.pm for the build stage (RT#49912, thanks to dsteinbrunner) - White space improvements (RT#30205, Thanks to Peter Liscovius) - Fixed a warning in the test suite (RT#42251, Thanks to Frank Wiegand) 4.63 Sat Jan 3 12:46:15 EST 2009 [DOCUMENTATION] - Improve docs for writing your own constraints (girlwithglasses) 4.62 Sat Jan 3 12:10:14 EST 2009 [DOCUMENTATION] - Fix typo in ConstraintsFactory docs (Geraint A. Edwards) - Clarified docs for get_filtered_data (Lisa Hagemann) - Clarify that 'field_filter_regexp_map' can take coderefs as values (Ron Savage) [INTERNALS] - Better diagnostics when load_profiles fails (Thoralf Klein) - Improved portability of t/untaint.t (Alexandr Ciornii) - Make some tests conditional on Date::Calc being installed (Frank Wiles) 4.61 Mon Jun 16 14:37:31 EDT 2008 [INTERNALS] - packaging issue from Perl 4.60 resolved. 4.60 Mon Jun 16 14:10:14 EDT 2008 [NEW FEATURES] - Dependencies can now be specified using a code ref. Thanks to Bradley C Bailey, via RT#24935. [BUG FIXES] - length constraints for min, max and 'between' now work for lengths of 32k and longer. (Carl Vincent). - We now use Email::Valid to validate e-mail addresses instead of our own regrex. Email::Valid passed all our our existing regression tests for e-mail addresses that should pass and fail. Email::Valid also correctly recognizes emails with single quote characters in them. These are valid, but our regex didn't recognize them. (Mark Stosberg) [INTERNALS] - Typo in Constraints documentation corrected by K B Shiv Kumar (RT#32358) - Add some tests and docs for "date_and_time" constraint, from Data::FormValidator:::Constraints::Dates. It appears there may still exist a leap-year bug with the date parser. See the TODO test in t/dates_closure.t for details. An alternative is to use Data::FormValidator::Constraints::DateTime (Mark Stosberg, Matt Christian) 4.57 Thu Nov 1 22:47:13 EDT 2007 [BUG FIXES] - The min max and length_between constraints now allow multi-line input, Thanks to Carl Vincent. RT##30221. If we had only used the Regex style prescribed by the Perl Best Practices book in the first place, this wouldn't have been a problem! [INTERNALS] - Makefile.PL to updated to explicitly require 5.008; - Fix doc link to "Old School Constraints", thanks to rjbs. 4.56 Wed Oct 31 12:34:32 EDT 2007 [INTERNALS] - declare that we rely on 5.8, because some 5.6 tests were failing. A patch for 5.6 compatibility would be welcome. Thanks to rjbs for the prod. 4.55 Sun Oct 21 11:41:41 EDT 2007 [BUG FIXES] - Constraints in Upload.pm now apply to filtered data, not raw data. (Graham TerMarsch, Mark Stosberg, RT#24702) 4.54 Sun Oct 21 09:27:07 EDT 2007 [INTERNALS] - It looks like 4.53 got uploaded wrong, appearing as the code for 4.50. 4.53 Sat Oct 20 15:57:56 EDT 2007 [BUG FIXES] - Invalid fields should still be invalid, even when missing_optional_valid is true. Patch thanks to Robert Juliano. [RT#28860] [INTERNALS] - Improve documentation link, thanks to Robert Stockdale [RT#29510] - Give a plug to Data::FormValidator::Constraints::MethodsFactory. Recommended! - s/foreach /for /g throughout the code, per Perl Best Practices 4.52 Fri Oct 19 15:39:14 EDT 2007 No code changes. [INTERNALS] - Fix PERL5LIB issue with untaint.t, Thanks to Matt Trout and others [RT#30126] 4.51 Fri Jul 13 23:31:43 EDT 2007 [BUG FIXES] - Quit assuming that because the first element of an array is undef, the the whole thing is undef. (RT#24703, GTERMARS, Paul Blair) - For the "file_format" file upload constraint, File::MMagic sometimes wrongly returns the generic "application/octet-stream" MIME type instead of the correct MIME type. We now this return value as meaning "I don't know" and try the MIME type sent by the browser if this happens. (Mark Stosberg) - for the "file_format" file upload constraint, we now do a case-insensitive comparison of the MIME type provided by the browser, following the MIME standard. This bug was masked because we check the returned MIME type by File::MMagic first. Because it generally works and returns a lower-case result, it didn't matter. However, it some cases File::MMagic misbehaves under mod_perl, causing the issue to matter. (Matt Christian, Mark Stosberg) [INTERNALS] - Start requiring and using Scalar::Util, which prevents UNIVERSAL::can() form generating warnings. (RT#25873, Dave O'Neill) - Start requiring Perl6::Junction, which we had previously copy/pasted a bit of into DFV. (Unlike some of the other Perl6 namespace modules, this one does /not/ use a source filter, and is addictively simple and useful. 4.50 Mon Dec 4 21:28:09 EST 2006 [ENHANCEMENTS] - New method for constraint writing: get_filtered_data(). (Graham TerMarsch, Mark Stosberg, RT#22589) - Stronger profile checking, to insure that all constraint_method values are code references. Note: This explicitly simplifies things compared to the 'constraints' system. Bare strings declarations are not allowed with 'constraint_methods'. (Mark Stosberg) - Numerous documentation and comment typo fixes (Evan Zacks) - Clarified the docs for overriding msgs (RT#18050) [BUG FIXES] - ':all' was documented as a group of constraints to import, but it didn't work. The documentation was updated to recommend ':closures' instead. (PURDY, RT#21052) - FV_eq_with now works with CGI.pm-style objects as input. (Jason Crummack) - Fix documented example of using constraint methods. (Brian Lozier) - When a constraint and a constraint_regexp_map matched the same field, only the ones from the map where being used in one case. This was a regression since the 4.0 release. A new regression test was also added for this case. (Matt Christian) 4.49_01 Tue Oct 3 14:13:59 EDT 2006 [ENHANCEMENTS] - New defaults_regexp_map profile key, useful for dynamically generated checkbox fields. (Mark Stosberg) 4.40 Mon Aug 21 19:41:24 EDT 2006 [BUG FIXES] - All FV_ closures are now exported with ":closures". (Ed Pigg, Mark Stosberg) [ENHANCEMENTS] - Added new constraint for the common case of comparing one field with another, such as a word confirmation field. Example: constraint_methods => { password => FV_eq_with('password_confirm'), } (Mark Stosberg) 4.30 Mon Jul 10 21:41:37 EDT 2006 [ENHANCEMENTS] - A new method for constraint writers has been added: untainted_constraint_value(). If you have written a constraint which untaints, use this method to return the untainted result. It will prepare the right result whether the user has requested untainting or not. (Mark Stosberg) - New built-in constraints added: FV_min_length(3), FV_max_length(100), FV_length_between(3,100), These constraints can optionally perform untainting. (Mark Stosberg) - We now work around a bug in File::MMagic which could cause some filehandles to be corrupted after after the file_format constraint was used. [BUG FIXES] - Regexp::Common regular expressions which accepted zero as a valid input would have wrongly failed their constraints unless untainting was enabled. (Mark Stosberg) [INTERNALS] - Improved documentation for built-in constraints. (Mark Stosberg) 4.20 Mon Jun 12 20:44:36 EDT 2006 [ENHANCEMENTS] - Documentation in Data::FormValidator::Filters has been improved. (Mark Stosberg} - Added FV_split() a new filter that makes it super-easy to apply the same constraint to a list of values passed in a single field, such as a comma separated list of e-mail addresses. (Mark Stosberg). [BUG FIXES] - For input given as a hashref containing array references, values could have been mistakenly modified by reference through filters. We now explicitly copy elements in these case, to avoid modifying the input. (RT#19592) 4.14 Fri Feb 17 08:59:40 EST 2006 [ENHANCEMENTS] - Consider a field with only a null character to be invalid (Jamie Krasnoo) [BUG FIXES] - Fix bug in cc_number constraint, which was only present when used as a "constraint_method". (Evan A. Zacks) 4.13 [BUG FIXES] - Updated overloading syntax to work with Template::Stash (frank) 4.12 Thu Jan 5 21:07:50 EST 2006 [INTERNALS] - Fix test suite to pass when CGI::Simple is not installed (Lee Carmichael, Davide Dente) 4.11 Tue Jan 3 18:38:23 EST 2006 [ENHANCEMENTS] - A new constraint for minimum image dimensions was added in Data::FormValidator::Constraints::Upload (Lee Carmichael) [INTERNALS] - refactoring of Upload.pm and t/upload.t (Lee Carmichael) 4.10 Thu Dec 22 19:55:34 EST 2005 [ENHANCEMENTS] - The msgs key can now take a callback, allow users to override how error message generation is done. Some alternative message generate routines will hopefully be published soon. (Cees Hek, Chris Laco and others) - New profile key: untaint_regexp_map (Michael Peters) [BUG FIXES] - bug was fixed for dependent fields that had false values, but were valid (Emanuele Zeppieri) - Failed constraints for multiple fields with the same name no longer return duplicate error messages (Will Hawes) - value of any_errors was wrongly added to msgs even when there are no errors (RT#14942, report and test script by Michael Graham) [INTERNALS] - bump Date::Calc requirement (RT#15715) 4.02 Wed Aug 31 21:22:58 EST 2005 [ENHANCEMENTS] - the use of custom signal handers for "die" has now been localized to avoid interfering with other applications. (Josh Miller). - initial support for qr in constraint_method profile key [BUG FIXES] - Updated ::Constraints example docs to be accurate: recommend :closures, not :all [INTERNALS] - provide a more accurate debugging message for constraint_method_regexp_map 4.01 Sat Aug 20 13:16:47 EST 2005 [ENHANCEMENTS] - get_input_data() now supports the parameters "as_hashref => 1" to return the input data in a uniform way. [INTERNALS] - Constraints may refer to fields that are 'unknown' to Data::FormValidator. These unknown values will remain unfiltered as before. (Michael Peters). - _get_data() was renamed to _get_input_as_hash(). You shouldn't care. 4.00 Sun Aug 14 10:57:25 EST 2005 *** NOTE *** This a major update with a significant code changes. While the test suite indicates we have 100% compatibility with 3.x, you are encouraged to test this release with your own applications before deploying it in a production environment. [ENHANCEMENTS] - The constraints interface has been overhauled to be more intuitive to use with parameterized constraints. This included added new two new profile keys: 'constraint_methods' and 'constraint_method_regexp_map'. All of the old syntax is still supported, but de-emphasized in the documentation. See RELEASE_NOTES for details. - A new method has been added to help building custom constraints: "set_current_constraint_name('foo')" will set the name of a constraint from within itself. An alias named 'name_this()' is provided for brevity. See the section on "Writing your own constraints" in DFV::Constraints for details. - success() method added to Results object. This is an easy way to check that there were no missing or invalid fields. (Michael Peters). - 'separator' was misspelled consistently in the docs, code and tests. The proper spelling as well as the legacy typo spelling are now supported, although the typo'ed version is no longer documented, except for here. :) Thanks to Terrence Brannon for spotting this. - The 'msgs' hash in the profile is now validated to make sure it includes only valid keys. This should help to spot some errors faster. - ::Constraints::Upload now supports CGI::Simple, thanks to David Emery. - Documentation for required_regexp has been improved. (William McKee) - support for coderefs as default values (Marcello) - Improved field_filters documentation, thanks to Andrew Brosnan. [BUG FIXES] - RT#12220: Canadian Province RE were updated. (Steve Simms). - The preferred MIME type was not being returned by the 'file_format' constraint for file uploads. This would have only affected cases where the mime type sent by the browser differed from the one detected by DFV. Thanks to Randal Schwartz for spotting this. (RT#12744). - Profile re-use when constraint_regexp_map is used is now fixed (Thanks to Cees Hek). - The date_and_time constraint now understands this format: MMDDYYYY. (RT#12111, thanks to JMAY) - This one is worth a brief explanation. When this old syntax was used: my ( $valid, $missing, $invalid, $unknown ) = Data::FormValidator->validate({}, {} ); $invalid would be returned as an empty arrayref if there were no invalids. This return value was undocumented, and was later changed to be 'undef' sometime between 3.50 and 3.70. However, I found that some applications, including Cascade, depended on the undocumented return value (which they shouldn't have). I have now reverted the behavior to returning an empty arrayref in this case, added a test for it, and updated the docs to be explicit about the return value. This will save some people unexpected breakages when upgrading DFV from a very old version with very old applications. Those who use the $results object are unaffected. [INTERALS] - Add many failing TODO tests for built-in filters. See t/filters_builtin.t - A new test was added to check that no warnings are emitted when an untainted constraint returns undef (Michael Peters) * 3.x releases after 3.63 happened on a different branch. All of the improvements there should be reflected above. 3.63 [BUG FIXES] - email validation was beefed up to not permit spaces with e-mails or semi-colons to get through. Thanks to Jason Crome for some tests to this, and the Mail::VRFY module, which was the source of the improved RE. [INTERNALS] - Added a couple more test to the distribution which were missing in the MANIFEST 3.62 Fri Oct 8 22:55:49 EST 2004 [INTERNALS] - Removed experimental label from 'msgs' functionality. - Beefed up test suite for dependencies and dependency_groups (Drew Taylor) 3.61 Mon Sep 20 18:10:23 EST 2004 [BUG FIXES] - file_format from ::Constraints::Upload now handles non-existent files more gracefully. (Evan A. Zacks) 3.60 Mon Sep 20 18:10:23 EST 2004 [BUG FIXES] - file_max_bytes seemed to never be reporting failure. 3.59 Thu Jul 02 2004 [ENHANCEMENTS] - Added more tests for Date constraints, and removed some more warnings (Michael Dorman) [BUG FIXES] - Fixed failing dependency check happening sometimes with a CGI object as input. (Drew Taylor) 3.58 Wed May 05 2004 [ENHANCEMENTS] - Test suite has been migrated further to 'Test::More' style, and all tests should complete without any warnings. A big thanks goes to Gabor Szabo for this work. 3.57 Wed Apr 21 2004 [ENHANCEMENTS] - 'validator_packages' now handles the importing of filters as well as constraints. (Ronald Kimball) - Added profile validation check for hashref style constraints. This will make typos in key names easier to find. (Barry Hoggard, for demonstrating the need.) [BUG FIXES] - no longer try to use a Carp module method without having it loaded. Instead, we just call "die" now. (Gunnar Wolf) 3.56 Fri Apr 16 2004 [BUG FIXES] - Fixed a mis-handling of unknown variables. Functionality brought inline with documented behaviour (Richard Clarke) - fixed bug image dimensions test in DFV::Constraints::Upload (Barry Hoggard) [ENHANCEMENTS] - added mention of HTML::Template::Associate::FormValidator to SEE ALSO 3.55 Wed Mar 25 2004 - better diagnostics when a filters fail. 3.54 Wed Mar 24 2004 [BUG FIXES] - Fixed a mis-handling of invalid constraints introduced in 3.53 (Kevin Baker). [ENHANCEMENTS] - Refactored and improved some contraint related tests (Kevin Baker) - clarified documentation for uploading constraints to mention that a CGI.pm object is needed for input. 3.53 Mon Mar 22 2004 [BUG FIXES] - Removed bug introduced in 3.52 that would have mis-handled files that had some filters applied, and were then used as parameters in constraints for multiple fields. (Kevin Baker) - Possibly fixed t/24_upload.t test on Windows platforms (podmaster) 3.52 Sun Mar 21 2004 [BUG FIXES] - After a constraint failed, future constraints relying on the same input parameters may have falsely failed. (Kevin Baker) - Untainting of false values (such as '0') was broken, and has been fixed. (Kato Atsushi) [ENHANCEMENTS] - the profile syntax checker now reports all invalid keys, instead of just the first one. Also, this code was refactored to be a bit faster. (Kevin Baker). 3.51 Thu Feb 26 2004 [THINGS THAT MIGHT BREAK YOUR CODE] - The default formatting now uses the 'class' attribute in the tag instead of the 'id' attribute. This shouldn't be a big deal and may actually make CSS styling easier, but it is a change. (Drew Taylor) [BUG FIXES] - In some cases empty fields were marked as 'valid' under mod_perl when they shouldn't be. (Drew Taylor) - Prevent unnecessary death due to $@ being set. (Kevin Baker) - Fixed documentation typo related to writing your own constraints (Stewart Russell) [ENHANCEMENTS] - valid() can now return multiple values in list context. - Mention Data::FormValidator::Util::HTML - Added new t/constraints_builtin.t as a beginning of more through testing of the built-in constraints. - Several documentation updates (Kevin Baker) 3.50 Mon Jan 12 2004 - No functionality changes since 3.49_1, I'm just declaring it stable. - I did sneak in the addition of a $VERSION in a couple included modules where none had been provided before. 3.49_1 [THINGS THAT MIGHT BREAK YOUR CODE] - A change has been made to Data::FormValidator::Constraints::Upload, and only affects constraints in that module. Meta data will no longer be provided by adding additional "_info" fields to the valid hash. The same data is now available through the new meta() method of the Data::FormValidator::Results object. [NEW FEATURES] - A new meta() method has been added to the Data::FormValidator::Results class. This function allows constraints to communicate meta data they discover about the values during the validation process. For example, a file size may be discovered while checking to see if the file size is too large. This is only currently being used in Data::FormValidator::Constraints::Upload. 3.15 Sun Nov 03 2003 - Instead of explictly supporting CGI and Apache::Request objects, now any object which has a param() method can be used. In particular, this allows CGI::Simple to be used. Before, if you used an object which was not CGI or Apache::Request, it would treat the object as a hash reference and possibly work. Now it will die with a diagnostic message in this case. (Cees Hek) - Many documentation typo fixes (Cees Hek and Timothy Appnel) - The dependency on Module::Build to install the distribution has been removed. Now either Module::Build or the traditional MakeMaker system can be used. 3.14 [BUG FIXES] - fixed POD syntax issue in Constraints.pm that was causing a 'make test' failure with Test::Pod >.96 3.13 Sun Nov 02 2003 [THINGS THAT MAY BREAK YOUR CODE] - How the Regexp::Common integration has changed. The old functionality was to match the regular expression as a substring of the field being testing. Now it is more restrictive and only matches the entire string. This is how all the other filters worked, and is probably how you expected the Regexp::Common filters to work as well. [BUG FIXES] - uninitialized values in filters no longer cause warnings. (addresses bug #2751). - documentation typo fixes [ENHANCEMENTS] - improved syntax to be compatible with Perl 5.005 - Added "cover" method to "Build" script. This uses Devel::Cover to generate a coverage report for the script - About 5 new tests for loading profiles from a file 3.12 Tue Jun 22 2003 - don't die in ::Upload if we can't find the tmp file. Instead, the constraint fails and a warning is emitted. - Added "image/pjpeg" to list of default mime types to use with file_format. This is for the "progressive JPEG" format. - Several documentation improvements, thanks to Mike Fragassi. 3.11 Tue May 27 2003 - Bug Fix: "qr" support now works better with older versions of Perl (Mike Fragassi) 3.10 Mon May 26 2003 - New Feature: Any regular expression from Regexp::Common can now be used directly as a named constraint. See Data::FormValidator::Constraints documentation for an example syntax. - Bug Fix: fixed imported_validators error that could occur if the same profile was used more than once with the same DFV object. - improved support and testing of 'qr' a bit. 3.01 Thu May 15 2003 This release fixes addresses a couple of issues related to the new support for error message handling through msgs() and "qr" support. If you aren't using these features, there's no need to upgrade. - New Feature: Updated msgs() documentation and removed the requirement that 'msgs' be defined in profile for default formatting to be used with msgs() method call. - Bug Fix: Using named constraints wtih the new "qr" support now works. 3.00 Sun May 11 2003 - New Feature: added debug option - Make default msgs in "new" constructor work as it was supposed it 2.11_04 - Bug Fix: missing_optional_valid now works better when the input data comes from a CGI.pm or Apache::Request object (David Ranney) - Upload.pm syntax updated to no longer require Perl 5.6+ syntax - New Feature: Upload.pm now first tries to use File::MMagic and MIME::Type to more intelligently determine the file type and an appropriate extension. 2.11_04 - Major documentation overhaul. It should now be easier to browse and grok. - New Feature: defaults can be passed to new() that will be used for all forms made from that object. - New Feature: Added support for quoting regular expressions using "qr" instead of defining them as strings. This is now the preferred method. Defining regular expressions as strings is deprecated but supported. - New Feature: Friendly die statements when you have typos in filter and constraint names. (Instead of mysterious suicide). - Fixed syntax error in Upload.pm documentation - Bug Fix: error checking in valid_file_format in Upload.pm - Bug Fix: fixed bug related to returning constraint names introduced in 2.11_03. 2.11_03 - The code has now been reorganized, following the module of HTML::FormValidator. Filters, Constraints, and Results are now all handled in their own modules. - The "msgs" error functional has now been re-designed, and is not backwards compatible. Feedback on this experimental addition is encouraged. - New Feature: Added ConstraintsFactory.pm module to distribution 2.11_02 - New Feature: Support for Apache::Request objects - New Feature: Now when constraint_regexp_map is used and one or more constraints is already defined, the new matching constraint is added to the list of constraints applied, rather than superceding the old one. 2.11_01 (A BETA release) - New Feature: Added Data::FormValidator::Constraints::Upload to the distribution. - New Feature: Added Data::FormValidator::Constraints::Dates to the distribution. - The functionality of returning errors with the experimental msgs feature has changed a bit. Now if you define multiple constraints, the messages will always be returned as an array reference, instead of when only there was more than one message. This should improve integration with HTML::Template. - New Feature: When using multiple constraints defined as hash references, the "name" attribute will default to name of the constraint, if it is being called by name. - added documentation for writing your own validation routines. - New Feature: Added 'valid' accessor/mutator method to manage and manipulate the result set. This can be useful to modify the result set from within a constraint. - New Feature: Added "constraint_method" as an alternative to "constraint" in the hash-based constraint definition. Related to this, there are new accessor methods for use inside of custom constraints: get_input_data(); get_current_constraint_field(); get_current_constraint_value(); This whole arrangement brings support for multi-valued constraints with constraint_regexp_map - various documentation clean ups 2.10 Sun Apr 20 2003 - New Feature: (EXPERIMENTAL) Added support for returning error messages for missing and invalid fields (Juan Jose Natera Abreu). This piece of functionality is marked as experimental because the interface may change in the near future, and it has not been tested as well as rest of the module. Search in the documentation for "msgs" for the details. - New Feature: added support for building with Module::Build. For more information on Module::Build, read this: http://magnonel.guild.net/~schwern/talks/MakeMaker_Is_DOOMED/slides/ - New Feature: included SIGNATURE file in distribution for verification with Module::Signature 2.04 Fri Apr 11 2003 - Bug Fix: multiple parameters passed to a constraint were not being handled appropriately in some cases. (Markus) - Bug Fix: Calling "validate" as a class method in combination with using "validator_packages no longer causes a problem. 2.03 Thu Apr 10 2003 - Bug Fix: use of "delete" syntax with multiple values updated to be backwards compatible with Perl 5.005 (Jonathan Buhacoff) 2.02 Wed Apr 09 2003 - Bug Fix: fixed bug with required_regexp and optional_regexp triggered if there is no required_regexp or optional_regexp in the profile *and* something exists in $@ (Dom) 2.01 Wed Apr 02 2003 - Bug Fix: Fix bug introduced in 1.93 which didn't handle input values appropriately that were references to other things besides arrays. (Boris Zentner) 2.00 Sat Mar 22 2003 - Bug Fix: Fixed bug where all code references were treated as if the were using the 'multiple constraints' feature. This bug was likely introduced in 1.93 (Chris Spiegel) - Bug Fix: Fixed bug which caused a failllure when using some sides of subroutine constraints within the "multiple constraints" syntax. (Chris Spiegal} 1.93 Sun Mar 09 2003 - New Feature: Keys with multiple values are now supported - New Feature: A CGI.pm object can now be used to provide the input data - Bug Fix: pattern matching is faster in some cases now by not using $& (Tony Stubblebine) - Bug Fix: better support for using valid_* packages imported from other packages. (Alexander Solovey) - added link to demo site in documentation - fixed typo in documentation example (Kato Atsushi) - added link to Japanese translatation of the documents (Kato Atsushi) 1.92 Sun Dec 22 2002 - support for untainting data (Tony Stubblebine) - documentation typo fixes (Charlie Garrison) - validator_packages added to profile specification allowing import of validation routine from other packages (Jeremy Muhlich) - support for multiple constraints per field added (Jeremy Muhlich) - support for literal values in constraint param field (Jeremy Muhlich) 1.91 Sun Oct 05 2002 - Added feature to require some fields in a group. (Brad Smithart) - Bumped version to be greater than 1.9 to make CPAN.pm fetching work again 1.11 Sat Jun 29 2002 - Fixed small bug where constraint arrays were tested with truth rather than length. (Maurice Aubrey) - Fixed documentation bug for american_phone validation (Dan Puro) - Added documentation for simplified syntax using a class method - Added profile syntax checking to help catch misspelled keys faster 1.10 Sun Apr 21 2002 - Added code for field_filter_regexp_map (Tim Noll) 1.9 Sun Feb 17 2002 - Fixed bug introduced in 1.8 which caused missing optional fields to wrongly subjected to constraint checking 1.8 Thu Feb 14 2002 - Added link to Data::FormValidator::Tutorial in SEE ALSO section - Added "missing_optional_valid" flag to profiles to allow missing optional fields to be considered valid 1.7 Sat Nov 03 2001 - Fixed broken constraint_regexp_map implementation. If you followed the example syntax in the documentation your regular expression could have failed to match when it should have succeeded. This feature now works as advertised in the documentation. - Updated documentation to reflect new mailing list and public CVS server. 1.6 Sun Sep 23 2001 - Fixed bug with undefined lists by using empty lists instead (Ronald Kimball) - added IP address validation routine (Juan Jose Natera Abreu) 1.5.1 Wed Jul 18 2001 - Updated version number to circumvent CPAN issue. No code changes. 1.5 Thu Jun 28 2001 - Added more flexible dependency system (Ade Olonoh) 1.4 Fri Jun 22 2001 - Fixed bug with code references (T.J. Mather) 1.3 Tue Jun 19 2001 - Now maintained by Mark Stosberg - Added constraint_regexp_map, required_regexp, optional_regexp - filter functions are exported - Renamed to Data::FormValidator from HTML::FormValidator # arch-tag: Mark_Stosberg_--2004-03-20_18:34:51 Data-FormValidator-4.88/README.pod0000644000175000017500000010324513151006761016713 0ustar dfarrelldfarrell=pod =head1 NAME Data::FormValidator - Validates user input (usually from an HTML form) based on input profile. =head1 SYNOPSIS use Data::FormValidator; my $results = Data::FormValidator->check(\%input_hash, \%dfv_profile); if ($results->has_invalid or $results->has_missing) { # do something with $results->invalid, $results->missing # or $results->msgs } else { # do something with $results->valid } =head1 DESCRIPTION Data::FormValidator's main aim is to make input validation expressible in a simple format. Data::FormValidator lets you define profiles which declare the required and optional fields and any constraints they might have. The results are provided as an object, which makes it easy to handle missing and invalid results, return error messages about which constraints failed, or process the resulting valid data. =cut =head1 VALIDATING INPUT =head2 check() my $results = Data::FormValidator->check(\%input_hash, \%dfv_profile); C is the recommended method to use to validate forms. It returns its results as a L object. A deprecated method C described below is also available, returning its results as an array. use Data::FormValidator; my $results = Data::FormValidator->check(\%input_hash, \%dfv_profile); Here, C is used as a class method, and takes two required parameters. The first a reference to the data to be be validated. This can either be a hash reference, or a CGI.pm-like object. In particular, the object must have a param() method that works like the one in CGI.pm does. CGI::Simple and Apache::Request objects are known to work in particular. Note that if you use a hash reference, multiple values for a single key should be presented as an array reference. The second argument is a reference to the profile you are validating. =head2 validate() my( $valids, $missings, $invalids, $unknowns ) = Data::FormValidator->validate( \%input_hash, \%dfv_profile); C provides a deprecated alternative to C. It has the same input syntax, but returns a four element array, described as follows =over =item valids This is a hash reference to the valid fields which were submitted in the data. The data may have been modified by the various filters specified. =item missings This is a reference to an array which contains the name of the missing fields. Those are the fields that the user forget to fill or filled with spaces. These fields may comes from the I list or the I list. =item invalids This is a reference to an array which contains the name of the fields which failed one or more of their constraint checks. If there are no invalid fields, an empty arrayref will be returned. Fields defined with multiple constraints will have an array ref returned in the @invalids array instead of a string. The first element in this array is the name of the field, and the remaining fields are the names of the failed constraints. =item unknowns This is a list of fields which are unknown to the profile. Whether or not this indicates an error in the user input is application dependent. =back =head2 new() Using C is only needed for advanced usage, including these cases: =over =item o Loading more than one profile at a time. Then you can select the profile you want by name later with C. Here's an example: my $dfv = Data::FormValidator->new({ profile_1 => { # usual profile definition here }, profile_2 => { # another profile definition }, }); As illustrated, multiple profiles are defined through a hash ref whose keys point to profile definitions. You can also load several profiles from a file, by defining several profiles as shown above in an external file. Then just pass in the name of the file: my $dfv = Data::FormValidator->new('/path/to/profiles.pl'); If the input profile is specified as a file name, the profiles will be reread each time that the disk copy is modified. Now when calling C, you just need to supply the profile name: my $results = $dfv->check(\%input_hash,'profile_1'); =item o Applying defaults to more than one input profile. There are some parts of the validation profile that you might like to re-use for many form validations. To facilitate this, C takes a second argument, a hash reference. Here the usual input profile definitions can be made. These will act as defaults for any subsequent calls to C on this object. Currently the logic for this is very simple. Any definition of a key in your validation profile will completely overwrite your default value. This means you can't define two keys for C and expect they will always be there. This kind of feature may be added in the future. The exception here is definitions for your C key. You will safely be able to define some defaults for the top level keys within C and not have them clobbered just because C was defined in a validation profile. One way to use this feature is to create your own sub-class that always provides your defaults to C. Another option is to create your own wrapper routine which provides these defaults to C. Here's an example of a routine you might put in a L super-class to make use of this feature: # Always use the built-in CGI object as the form data # and provide some defaults to new constructor sub check_form { my $self = shift; my $profile = shift || die 'check_form: missing required profile'; require Data::FormValidator; my $dfv = Data::FormValidator->new({},{ # your defaults here }); return $dfv->check($self->query,$profile); } =back =cut =head1 INPUT PROFILE SPECIFICATION An input profile is a hash reference containing one or more of the following keys. Here is a very simple input profile. Examples of more advanced options are described below. use Data::FormValidator::Constraints qw(:closures); my $profile = { optional => [qw( company fax country )], required => [qw( fullname phone email address )], constraint_methods => { email => email(), } }; That defines some fields as optional, some as required, and defines that the field named 'email' must pass the constraint named 'email'. Here is a complete list of the keys available in the input profile, with examples of each. =head2 required This is an array reference which contains the name of the fields which are required. Any fields in this list which are not present or contain only spaces will be reported as missing. =head2 required_regexp required_regexp => qr/city|state|zipcode/, This is a regular expression used to specify additional field names for which values will be required. =head2 require_some require_some => { # require any two fields from this group city_or_state_or_zipcode => [ 2, qw/city state zipcode/ ], } This is a reference to a hash which defines groups of fields where 1 or more fields from the group should be required, but exactly which fields doesn't matter. The keys in the hash are the group names. These are returned as "missing" unless the required number of fields from the group has been filled in. The values in this hash are array references. The first element in this array should be the number of fields in the group that is required. If the first field in the array is not an a digit, a default of "1" will be used. =head2 optional optional => [qw/meat coffee chocolate/], This is an array reference which contains the name of optional fields. These are fields which MAY be present and if they are, they will be checked for valid input. Any fields not in optional or required list will be reported as unknown. =head2 optional_regexp optional_regexp => qr/_province$/, This is a regular expression used to specify additional fields which are optional. For example, if you wanted all fields names that begin with I to be optional, you could use the regular expression, /^user_/ =head2 dependencies dependencies => { # If cc_no is entered, make cc_type and cc_exp required "cc_no" => [ qw( cc_type cc_exp ) ], # if pay_type eq 'check', require check_no "pay_type" => { check => [ qw( check_no ) ], } # if cc_type is VISA or MASTERCARD require CVV "cc_type" => sub { my $dfv = shift; my $type = shift; return [ 'cc_cvv' ] if ($type eq "VISA" || $type eq "MASTERCARD"); return [ ]; }, }, This is for the case where an optional field has other requirements. The dependent fields can be specified with an array reference. If the dependencies are specified with a hash reference then the additional constraint is added that the optional field must equal a key for the dependencies to be added. If the dependencies are specified as a code reference then the code will be executed to determine the dependent fields. It is passed two parameters, the object and the value of the field, and it should return an array reference containing the list of dependent fields. Any fields in the dependencies list that are missing when the target is present will be reported as missing. =head2 dependency_groups dependency_groups => { # if either field is filled in, they all become required password_group => [qw/password password_confirmation/], } This is a hash reference which contains information about groups of interdependent fields. The keys are arbitrary names that you create and the values are references to arrays of the field names in each group. =head2 dependencies_regexp dependencies_regexp => { qr/Line\d+\_ItemType$/ => sub { my $dfv = shift; my $itemtype = shift; my $field = shift; if ($type eq 'NeedsBatteries') { my ($prefix, $suffix) = split(/\_/, $field); return([$prefix . '_add_batteries]); } else { return([]); } }, }, This is a regular expression used to specify additional fields which are dependent. For example, if you wanted to add dependencies for all fields which meet a certain criteria (such as multiple items in a shopping cart) where you do not know before hand how many of such fields you may have. =head2 dependent_optionals dependent_optionals => { # If delivery_address is specified then delivery_notes becomes optional "delivery_address" => [ qw( delivery_notes ) ], # if delivery_type eq 'collection', collection_notes becomes optional "delivery_type" => { collection => [ qw( collection_notes ) ], } # if callback_type is "phone" or "email" then additional_notes becomes optional "callback_type" => sub { my $dfv = shift; my $type = shift; if ($type eq 'phone' || $type eq 'email') { return(['additional_notes']); } else { return([]); } }, }, This is for the case where an optional field can trigger other optional fields. The dependent optional fields can be specified with an array reference. If the dependent optional fields are specified with a hash reference, then an additional constraint is added that the optional field must equal a key for the additional optional fields to be added. If the dependent optional fields are specified as a code reference then the code will be executed to determine the additional optional fields. It is passed two parameters, the object and the value of the field, and it should return an array reference containing the list of additional optional fields. =head2 dependent_require_some dependent_require_some => { # require any fields from this group if AddressID is "new" AddressID => sub { my $dfv = shift; my $value = shift; if ($value eq 'new') { return({ house_name_or_number => [ 1, 'HouseName', 'HouseNumber' ], }); } else { return; } }, } Sometimes a field will need to trigger additional dependencies but you only require some of the fields. You cannot set them all to be dependent as you might only have some of them, and you cannot set them all to be optional as you must have some of them. This method allows you to specify this in a similar way to the equire_some method but dependent upon other values. In the example above if the AddressID submitted is "new" then at least 1 of HouseName and HouseNumber must also be supplied. See require_some for the valid options for the return. =head2 defaults defaults => { country => "USA", }, This is a hash reference where keys are field names and values are defaults to use if input for the field is missing. The values can be code refs which will be used to calculate the value if needed. These code refs will be passed in the DFV::Results object as the only parameter. The defaults are set shortly before the constraints are applied, and will be returned with the other valid data. =head2 defaults_regexp_map defaults_regexp_map => { qr/^opt_/ => 1, }, This is a hash reference that maps regular expressions to default values to use for matching optional or required fields. It's useful if you have generated many checkbox fields with the similar names. Since checkbox fields submit nothing at all when they are not checked, it's useful to set defaults for them. Note that it doesn't make sense to use a default for a field handled by C or C. When the field is not submitted, there is no way to know that it should be optional or required, and thus there's no way to know that a default should be set for it. =head2 filters # trim leading and trailing whitespace on all fields filters => ['trim'], This is a reference to an array of filters that will be applied to ALL optional and required fields, B any constraints are applied. This can be the name of a built-in filter (trim,digit,etc) or an anonymous subroutine which should take one parameter, the field value and return the (possibly) modified value. Filters modify the data returned through the results object, so use them carefully. See L for details on the built-in filters. =head2 field_filters field_filters => { cc_no => ['digit'], }, A hash ref with field names as keys. Values are array references of built-in filters to apply (trim,digit,etc) or an anonymous subroutine which should take one parameter, the field value and return the (possibly) modified value. Filters are applied B any constraints are applied. See L for details on the built-in filters. =head2 field_filter_regexp_map field_filter_regexp_map => { # Upper-case the first letter of all fields that end in "_name" qr/_name$/ => ['ucfirst'], }, 'field_filter_regexp_map' is used to apply filters to fields that match a regular expression. This is a hash reference where the keys are the regular expressions to use and the values are references to arrays of filters which will be applied to specific input fields. Just as with 'field_filters', you can you use a built-in filter or use a coderef to supply your own. =head2 constraint_methods use Data::FormValidator::Constraints qw(:closures); constraint_methods => { cc_no => cc_number({fields => ['cc_type']}), cc_type => cc_type(), cc_exp => cc_exp(), }, A hash ref which contains the constraints that will be used to check whether or not the field contains valid data. B To use the built-in constraints, they need to first be loaded into your name space using the syntax above. (Unless you are using the old C key, documented in L). The keys in this hash are field names. The values can be any of the following: =over =item o A named constraint. B: my_zipcode_field => zip(), See L for the details of which built-in constraints that are available. =item o A perl regular expression B: my_zipcode_field => qr/^\d{5}$/, # match exactly 5 digits If this field is named in C or C, or C is effective, be aware of the following: If you write your own regular expressions and only match part of the string then you'll only get part of the string in the valid hash. It is a good idea to write you own constraints like /^regex$/. That way you match the whole string. =item o a subroutine reference, to supply custom code This will check the input and return true or false depending on the input's validity. By default, the constraint function receives a L object as its first argument, and the value to be validated as the second. To validate a field based on more inputs than just the field itself, see L. B: # Notice the use of 'pop'-- # the object is the first arg passed to the method # while the value is the second, and last arg. my_zipcode_field => sub { my $val = pop; return $val =~ '/^\d{5}$/' }, # OR you can reference a subroutine, which should work like the one above my_zipcode_field => \&my_validation_routine, # An example of setting the constraint name. my_zipcode_field => sub { my ($dfv, $val) = @_; $dfv->set_current_constraint_name('my_constraint_name'); return $val =~ '/^\d{5}$/' }, =item o an array reference An array reference is used to apply multiple constraints to a single field. Any of the above options are valid entries the array. See L below. For more details see L. =back =head2 constraint_method_regexp_map use Data::FormValidator::Constraints qw(:closures); # In your profile. constraint_method_regexp_map => { # All fields that end in _postcode have the 'postcode' constraint applied. qr/_postcode$/ => postcode(), }, A hash ref where the keys are the regular expressions to use and the values are the constraints to apply. If one or more constraints have already been defined for a given field using C, C will add an additional constraint for that field for each regular expression that matches. =head2 untaint_all_constraints untaint_all_constraints => 1, If this field is set, all form data that passes a constraint will be untainted. The untainted data will be returned in the valid hash. Untainting is based on the pattern match used by the constraint. Note that some constraint routines may not provide untainting. See L for more information. This is overridden by C and C. =head2 untaint_constraint_fields untaint_constraint_fields => [qw(zipcode state)], Specifies that one or more fields will be untainted if they pass their constraint(s). This can be set to a single field name or an array reference of field names. The untainted data will be returned in the valid hash. This overrides the untaint_all_constraints flag. =head2 untaint_regexp_map untaint_regexp_map => [qr/some_field_\d/], Specifies that certain fields will be untainted if they pass their constraints and match one of the regular expressions supplied. This can be set to a single regex, or an array reference of regexes. The untainted data will be returned in the valid hash. The above example would untaint the fields named C, and C but not C. This overrides the untaint_all_constraints flag. =head2 missing_optional_valid missing_optional_valid => 1 This can be set to a true value to cause optional fields with empty values to be included in the valid hash. By default they are not included-- this is the historical behavior. This is an important flag if you are using the contents of an "update" form to update a record in a database. Without using the option, fields that have been set back to "blank" may fail to get updated. =head2 validator_packages # load all the constraints and filters from these modules validator_packages => [qw(Data::FormValidator::Constraints::Upload)], This key is used to define other packages which contain constraint routines or filters. Set this key to a single package name, or an arrayref of several. All of its constraint and filter routines beginning with 'match_', 'valid_' and 'filter_' will be imported into Data::FormValidator. This lets you reference them in a constraint with just their name, just like built-in routines. You can even override the provided validators. See L documentation for more information =head2 msgs This key is used to define parameters related to formatting error messages returned to the user. By default, invalid fields have the message "Invalid" associated with them while missing fields have the message "Missing" associated with them. In the simplest case, nothing needs to be defined here, and the default values will be used. The default formatting applied is designed for display in an XHTML web page. That formatting is as followings: * %s The C<%s> will be replaced with the message. The effect is that the message will appear in bold red with an asterisk before it. This style can be overridden by simply defining "dfv_errors" appropriately in a style sheet, or by providing a new format string. Here's a more complex example that shows how to provide your own default message strings, as well as providing custom messages per field, and handling multiple constraints: msgs => { # set a custom error prefix, defaults to none prefix=> 'error_', # Set your own "Missing" message, defaults to "Missing" missing => 'Not Here!', # Default invalid message, default's to "Invalid" invalid => 'Problematic!', # message separator for multiple messages # Defaults to ' ' invalid_separator => '
', # formatting string, default given above. format => 'ERROR: %s', # Error messages, keyed by constraint name # Your constraints must be named to use this. constraints => { 'date_and_time' => 'Not a valid time format', # ... }, # This token will be included in the hash if there are # any errors returned. This can be useful with templating # systems like HTML::Template # The 'prefix' setting does not apply here. # defaults to undefined any_errors => 'some_errors', } The hash that's prepared can be retrieved through the C method described in the L documentation. =head2 msgs - callback I If the built-in message generation doesn't suit you, it is also possible to provide your own by specifying a code reference: msgs => \&my_msgs_callback This will be called as a L method. It may receive as arguments an additional hash reference of control parameters, corresponding to the key names usually used in the C area of the profile. You can ignore this information if you'd like. If you have an alternative error message handler you'd like to share, stick in the C name space and upload it to CPAN. =head2 debug This method is used to print details about what is going on to STDERR. Currently only level '1' is used. It provides information about which fields matched constraint_regexp_map. =head2 A shortcut for array refs A number of parts of the input profile specification include array references as their values. In any of these places, you can simply use a string if you only need to specify one value. For example, instead of filters => [ 'trim' ] you can simply say filters => 'trim' =head2 A note on regular expression formats In addition to using the preferred method of defining regular expressions using C, a deprecated style of defining them as strings is also supported. Preferred: qr/this is great/ Deprecated, but supported 'm/this still works/' =head1 VALIDATING INPUT BASED ON MULTIPLE FIELDS You can pass more than one value into a constraint routine. For that, the value of the constraint should be a hash reference. If you are creating your own routines, be sure to read the section labeled L, in the Data::FormValidator::Constraints documentation. It describes a newer and more flexible syntax. Using the original syntax, one key should be named C and should have a value set to the reference of the subroutine or the name of a built-in validator. Another required key is C. The value of the C key is a reference to an array of the other elements to use in the validation. If the element is a scalar, it is assumed to be a field name. The field is known to Data::FormValidator, the value will be filtered through any defined filters before it is passed in. If the value is a reference, the reference is passed directly to the routine. Don't forget to include the name of the field to check in that list, if you are using this syntax. B: cc_no => { constraint => "cc_number", params => [ qw( cc_no cc_type ) ], }, =head1 MULTIPLE CONSTRAINTS Multiple constraints can be applied to a single field by defining the value of the constraint to be an array reference. Each of the values in this array can be any of the constraint types defined above. When using multiple constraints it is important to return the name of the constraint that failed so you can distinguish between them. To do that, either use a named constraint, or use the hash ref method of defining a constraint and include a C key with a value set to the name of your constraint. Here's an example: my_zipcode_field => [ 'zip', { constraint_method => '/^406/', name => 'starts_with_406', } ], You can use an array reference with a single constraint in it if you just want to have the name of your failed constraint returned in the above fashion. Read about the C function above to see how multiple constraints are returned differently with that method. =cut =pod =head1 ADVANCED VALIDATION For even more advanced validation, you will likely want to read the documentation for other modules in this distribution, linked below. Also keep in mind that the Data::FormValidator profile structure is just another data structure. There is no reason why it needs to be defined statically. The profile could also be built on the fly with custom Perl code. =head1 BACKWARDS COMPATIBILITY =head2 validate() my( $valids, $missings, $invalids, $unknowns ) = Data::FormValidator->validate( \%input_hash, \%dfv_profile); C provides a deprecated alternative to C. It has the same input syntax, but returns a four element array, described as follows =over =item valids This is a hash reference to the valid fields which were submitted in the data. The data may have been modified by the various filters specified. =item missings This is a reference to an array which contains the name of the missing fields. Those are the fields that the user forget to fill or filled with spaces. These fields may comes from the I list or the I list. =item invalids This is a reference to an array which contains the name of the fields which failed one or more of their constraint checks. Fields defined with multiple constraints will have an array ref returned in the @invalids array instead of a string. The first element in this array is the name of the field, and the remaining fields are the names of the failed constraints. =item unknowns This is a list of fields which are unknown to the profile. Whether or not this indicates an error in the user input is application dependent. =back =head2 constraints (profile key) This is a supported but deprecated profile key. Using C is recommended instead, which provides a simpler, more versatile interface. constraints => { cc_no => { constraint => "cc_number", params => [ qw( cc_no cc_type ) ], }, cc_type => "cc_type", cc_exp => "cc_exp", }, A hash ref which contains the constraints that will be used to check whether or not the field contains valid data. The keys in this hash are field names. The values can be any of the following: =over =item o A named constraint. B: my_zipcode_field => 'zip', See L for the details of which built-in constraints that are available. =back =head2 hashref style of specifying constraints Using a hash reference to specify a constraint is an older technique used to name a constraint or supply multiple parameters. Both of these interface issues are now better addressed with C and C<$self-\>name_this('foo')>. # supply multiple parameters cc_no => { constraint => "cc_number", params => [ qw( cc_no cc_type ) ], }, # name a constraint, useful for returning error messages last_name => { name => "ends_in_name", constraint => qr/_name$/, }, Using a hash reference for a constraint permits the passing of multiple arguments. Required arguments are C or C. Optional arguments are C and C. A C on a constraints 'glues' the constraint to its error message in the validator profile (refer C section below). If no C is given then it will default to the value of C or C IF they are NOT a CODE ref or a RegExp ref. The C value is a reference to an array of the parameters to pass to the constraint method. If an element of the C list is a scalar, it is assumed to be naming a key of the %input_hash and that value is passed to the routine. If the parameter is a reference, then it is treated literally and passed unchanged to the routine. If you are using the older C over the new C then don't forget to include the name of the field to check in the C list. C provides access to this value via the C methods (refer L) For more details see L. =head2 constraint_regexp_map (profile key) This is a supported but deprecated profile key. Using C is recommended instead. constraint_regexp_map => { # All fields that end in _postcode have the 'postcode' constraint applied. qr/_postcode$/ => 'postcode', }, A hash ref where the keys are the regular expressions to use and the values are the constraints to apply. If one or more constraints have already been defined for a given field using "constraints", constraint_regexp_map will add an additional constraint for that field for each regular expression that matches. =head1 SEE ALSO B L L L L L L B Validating Web Forms with Perl, L B L L L, a CGI::Application & Data::FormValidator glue module L is designed to make some kinds of integration with HTML::Template easier. L is useful for validating function parameters. L, L, L, L, L, L, L, L B Japanese: L B FreeBSD includes a port named B Debian GNU/Linux includes a port named B =head1 CREDITS Some of these input validation functions have been taken from MiniVend by Michael J. Heins. The credit card checksum validation was taken from contribution by Bruce Albrecht to the MiniVend program. =head1 BUGS Bug reports and patches are welcome. Reports which include a failing Test::More style test are helpful and will receive priority. L =head1 CONTRIBUTING This project is maintained on L. =head1 AUTHOR Currently maintained by David Farrell Parts Copyright 2001-2006 by Mark Stosberg , (previous maintainer) Copyright (c) 1999 Francis J. Lacoste and iNsu Innovations Inc. All rights reserved. (Original Author) Parts Copyright 1996-1999 by Michael J. Heins Parts Copyright 1996-1999 by Bruce Albrecht =head1 LICENSE This program is free software; you can redistribute it and/or modify it under the terms as perl itself. =cut Data-FormValidator-4.88/RELEASE_NOTES0000644000175000017500000001003613150655017017223 0ustar dfarrelldfarrell The 4.0 release addresses several lingering concerns I've had with the interface but didn't now how to address until now. Here's a summary of the parts of the interface that now have updated alternatives. The old syntax will still work. * Using 'validator_packages' re-invents module loading and importing. 'constraint_methods' can be loaded normally: use My::Constraints qw(my_constraint); * Custom constraint_methods don't need to be named "valid_" or "match_". * Passing parameters to constraints was awkward. It looked like this: my_field => { constraint => 'my_constraint', params => [\'string',\'bling'], } constraint_methods allows normal looking parameter passing: my_field => FV_length_between(10,20); * Using a 'constraint_method' as a hash was awkward, because you had to use a hashref to pass it in: constraints => my_date_field => { constraint_method => 'date_and_time' } } Now these kinds of constraints can be used with less effort with the 'constraint_methods' profile key: constraint_methods => { my_date_field => 'date_and_time', } All of the built-in constraints have been updated to support this alternate interface in which constraint subroutines actually look and work like normal subroutines. Where there is no need to convert old code, here is an example difference of using a built-in constraint with the new syntax: BEFORE: constraints => { my_email => 'email', } AFTER: constraint_methods => { my_email => email(), } As well, the Regexp::Common support has been improved so that you can call these routines through the normal subroutine interface provided, and DFV will keep track of the name of the constraint for later use in the 'msgs' error message system. BEFORE: constraints => { my_ip => { constraint => 'RE_net_IPv4', params => [ \'-sep'=> \' ' ], }, } AFTER: constraint_methods => { my_ip => FV_net_IPv4Z('-sep'=> ' '); } The 'filter' code has not yet been updated. It has been less of an issue since I've never seen a filter that took parameters. If someone wants to work on this update, feel free. * Writing your own constraints is easier. This is where the secret lies for making all of these improvements possible. Here are the fundamental problems that had to be solved: When declaring a constraint, you are really declaring a function that needs to be called, but you can't actually call the function then, because you don't have the value to validate yet, or the DFV object, or the other data which you might want to refer to. However, you might have /some/ parameters you want to provide, such as minimum and maximum value on a coolness() constraint you've written. The solution? Closures. This is the concept that took me years to understand the value of. The subroutine called in the profile will take the parameters that you know at that time. It then returns a customized anonymous subroutine. When this is called, it will have everything that's needed to complete job. Let's look at an example. sub coolness { my ($min_cool,$max_cool) = @_; return sub { my $dfv = shift; # Name it to refer to in the 'msgs' system. $dfv->name_this('coolness'); my $val = $dfv->get_current_constraint_value(); return ( ($val >= $min_cool) && ($val <= $max_cool) ); } } Getting this far leaves one wrinkle left to work out. How can we refer to values of other fields that have been submitted? This is partly solved by the C<$dfv->get_input_data()> method that lets you get at the hash of input data from within the constraint method. The following is recommended (but not required) for refering to other fields. I suggest making the final parameter a hashref that names a 'fields' arrayref. Like this: coolness(1,10,{fields => [qw/personality smarts good_looks/]}); This would indicate that you are going to use the values of these three fields as factors in your C constraint method. Data-FormValidator-4.88/t/0000755000175000017500000000000013151007442015505 5ustar dfarrelldfarrellData-FormValidator-4.88/t/unknown.t0000755000175000017500000000134613150655017017406 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More tests => 4; use Data::FormValidator; my %FORM = ( stick => 'big', speak => 'softly', mv => [ 'first', 'second' ], ); my $results = Data::FormValidator->check( \%FORM, { # required => 'stick', # optional => 'mv', } ); ok( $results->unknown('stick') eq 'big', 'using check() as class method' ); is( $results->unknown('stick'), $FORM{stick}, 'unknown() returns single value in scalar context' ); my @mv = $results->unknown('mv'); is_deeply( \@mv, $FORM{mv}, 'unknown() returns multi-valued results' ); my @stick = $results->unknown('stick'); is_deeply( \@stick, [ $FORM{stick} ], 'unknown() returns single value in list context' ); Data-FormValidator-4.88/t/dependency_coderef.t0000755000175000017500000000562213150655017021515 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More tests => 18; use Data::FormValidator; my %code_results = (); my $input_hashref = {}; my $input_profile = { dependencies => { cc_type => sub { my $dfv = shift; my $type = shift; return ['cc_cvv'] if ( $type eq "VISA" || $type eq "MASTERCARD" ); return []; }, code_checker => sub { my ( $dfv, $val ) = @_; $code_results{'code_called'} = 1; $code_results{'num_args'} = @_; $code_results{'value'} = $val; $code_results{'dfv_obj'} = $dfv; return []; }, }, }; my $validator = Data::FormValidator->new( { default => $input_profile } ); my $result; ## ## Validate a coderef dependency ## ## Check that the code actually gets called. ############################################################################# $input_hashref->{code_checker} = 'test'; $result = undef; eval { $result = $validator->check( $input_hashref, 'default' ); }; ok( !$@, "checking that dependency coderef is called" ); ok( $code_results{code_called}, " code was called" ); is( $code_results{num_args}, 2, " code received 2 args" ); is( $code_results{value}, 'test', " received correct value" ); ok( $code_results{dfv_obj}, " received dfv object" ); isa_ok( $code_results{dfv_obj}, 'Data::FormValidator::Results', " dfv object" ); delete $input_hashref->{code_checker}; ## Value that should cause a missing dependency. ############################################################################# $input_hashref->{cc_type} = 'VISA'; $result = undef; eval { $result = $validator->check( $input_hashref, 'default' ); }; ok( !$@, "checking a value that has a depenency" ); isa_ok( $result, "Data::FormValidator::Results", " returned object" ); ok( $result->has_missing, " has_missing returned true" ); ok( $result->missing('cc_cvv'), " missing('cc_cvv') returned true" ); ## Value that should NOT cause a missing dependency. ############################################################################# $input_hashref->{cc_type} = 'AMEX'; $result = undef; eval { $result = $validator->check( $input_hashref, 'default' ); }; ok( !$@, "checking a value that has no dependencies" ); isa_ok( $result, "Data::FormValidator::Results", " returned object" ); ok( !$result->has_missing, " has_missing returned false" ); is( $result->missing('cc_cvv'), undef, " missing('cc_cvv') returned false" ); ## Test with multiple values ############################################################################# $input_hashref->{cc_type} = [ 'AMEX', 'VISA' ]; $result = undef; eval { $result = $validator->check( $input_hashref, 'default' ); }; ok( !$@, "checking multiple values" ); isa_ok( $result, "Data::FormValidator::Results", " returned object" ); ok( $result->has_missing, " has_missing returned true" ); is( $result->missing('cc_cvv'), 1, " missing('cc_cvv') returned true" ); Data-FormValidator-4.88/t/results_success.t0000755000175000017500000000150213150655017021132 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More tests => 4; use Data::FormValidator; my %FORM = ( good => '1', extra => '2', ); my $results = Data::FormValidator->check( \%FORM, { required => 'good', } ); ok( $results->success, 'success with unknown' ); { my $false; $results || ( $false = 1 ); ok( !$false, "returns true in bool context on success" ); } # test an unsuccessful success $FORM{bad} = -1; $results = Data::FormValidator->check( \%FORM, { required => [qw(good bad)], optional => [qw(extra)], constraints => { good => sub { return shift > 0 }, bad => sub { return shift > 0 }, }, }, ); ok( !$results->success, 'not success()' ); { my $false; $results || ( $false = 1 ); ok( $false, "returns false in bool context on not success" ); } Data-FormValidator-4.88/t/26_qr.t0000755000175000017500000000322513150655017016636 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More qw/no_plan/; use Data::FormValidator; # Testing new support for 'qr'. -mls my %FORM = ( stick => 'big', speak => 'softly', bad_email => 'doops', good_email => 'great@domain.com', 'short_name' => 'tim', 'not_oops' => 'hoops', 'untainted_with_qr' => 'Slimy', ); my $results = Data::FormValidator->check( \%FORM, { required_regexp => qr/stick/, optional_regexp => '/_email$/', constraint_regexp_map => { qr/email/ => 'email', }, field_filter_regexp_map => { qr/_name$/ => 'ucfirst', }, required => 'speak', optional => [qw/short_name not_oops untainted_with_qr/], constraints => { not_oops => { name => 'start_with_oop', constraint => qr/^oop/, }, untainted_with_qr => qr/(Slim)/, speak => qr/quietly|softly/, stick => qr/big|large/, }, msgs => { constraints => { 'start_with_oop' => 'testing named qr constraints', } }, untaint_constraint_fields => [qw/untainted_with_qr/], } ); ok( $results->valid('stick') eq 'big', 'using qr for regexp quoting' ); ok( $results->valid('speak'), 'using alternation with qr works' ); ok( $results->valid('good_email'), 'expected to pass constraint' ); ok( $results->invalid('bad_email'), 'expected to fail constraint' ); is( $results->valid('short_name'), 'Tim', 'field_filter_regexp_map' ); my $msgs = $results->msgs; like( $msgs->{not_oops}, qr/testing named/, 'named qr constraints' ); is( $results->valid('untainted_with_qr'), 'Slim', 'untainting with qr' ); Data-FormValidator-4.88/t/get_input_data.t0000755000175000017500000000130013150655017020664 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More; use Data::FormValidator; eval { require CGI;CGI->VERSION(4.35); }; plan skip_all => 'CGI 4.35 or higher not found' if $@; { my $results = Data::FormValidator->check( {}, {} ); is_deeply( $results->get_input_data, {}, 'get_input_data works for empty hashref' ); } my $q = CGI->new( { key => 'value' } ); my $results = Data::FormValidator->check( $q, {} ); is_deeply( $results->get_input_data, $q, 'get_input_data works for CGI object' ); { my $href = $results->get_input_data( as_hashref => 1 ); is_deeply( $href, { key => 'value' }, 'get_input_data( as_hashref => 1 ) works for CGI object' ); } done_testing; Data-FormValidator-4.88/t/tt_and_overload.t0000755000175000017500000000065713150655017021057 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More; use Data::FormValidator; eval { require Template; require Template::Stash; }; plan skip_all => 'Template Toolkit required' if $@; plan tests => 1; my $results = Data::FormValidator->check( {}, { required => 1 } ); my $tt = Template->new( STASH => Template::Stash->new ); $tt->process( \'[% form.missing %]', { form => $results }, \my $out ); ok( not $tt->error ); Data-FormValidator-4.88/t/03_dependency.t0000755000175000017500000000513213150655017020324 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More; use Data::FormValidator; # test profile my $input_profile = { dependencies => { pay_type => { Check => [qw( cc_num )], # Value of Zero is used for test for a specific bug 0 => [qw( cc_num cc_exp cc_name )], }, }, }; my $input_hashref = { pay_type => '0' }; ## ## Validate a complex dependency ## ## ## validate() my ( $valids, $missings, $invalids, $unknowns ); my $validator = Data::FormValidator->new( { default => $input_profile } ); eval { ( $valids, $missings, $invalids, $unknowns ) = $validator->validate( $input_hashref, 'default' ); }; ok( !$@, "no eval problems" ); my %missings = map { $_ => 1 } @$missings; ok( $missings{cc_num}, "missing cc_num" ); ok( $missings{cc_exp}, "missing cc_exp" ); ok( $missings{cc_name}, "missing cc_name" ); ## ## check() my $result; eval { $result = $validator->check( $input_hashref, 'default' ); }; ok( !$@, "no eval problems" ); isa_ok( $result, "Data::FormValidator::Results", "returned object" ); ok( $result->has_missing, "has_missing returned true" ); ok( $result->missing('cc_num'), "missing('cc_num') returned true" ); ok( $result->missing('cc_exp'), "missing('cc_exp') returned true" ); ok( $result->missing('cc_name'), "missing('cc_name') returned true" ); ## ## validate() $input_hashref = { pay_type => 'Check' }; eval { ( $valids, $missings, $invalids, $unknowns ) = $validator->validate( $input_hashref, 'default' ); }; ok( !$@, "no eval problems" ); %missings = map { $_ => 1 } @$missings; ok( $missings{cc_num}, 'missing cc_num' ); ok( !$missings{cc_exp}, 'not missing cc_exp' ); ok( !$missings{cc_name}, 'not missing cc_name' ); ## ## check() $result = undef; eval { $result = $validator->check( $input_hashref, 'default' ); }; ok( !$@, "no eval problems" ); isa_ok( $result, "Data::FormValidator::Results", "returned object" ); ok( $result->has_missing, "has_missing returned true" ); ok( $result->missing('cc_num'), "missing('cc_num') returned true" ); is( $result->missing('cc_exp'), undef, "missing('cc_exp') returned false" ); is( $result->missing('cc_name'), undef, "missing('cc_name') returned false" ); eval { require CGI;CGI->VERSION(4.35); }; SKIP: { skip 'CGI 4.35 or higher not found', 3 if $@; my $q = CGI->new('pay_type=0'); my $results = $validator->check( $q, 'default' ); ok( $results->missing('cc_num'), 'using CGI.pm object for input' ); is( $result->missing('cc_exp'), undef, "missing('cc_exp') returned false" ); is( $result->missing('cc_name'), undef, "missing('cc_name') returned false" ); } done_testing; Data-FormValidator-4.88/t/constraint_regexp_map_profile_reuse.t0000755000175000017500000000260013150655017025217 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More (qw/no_plan/); use Data::FormValidator; my $profile = { required => [qw( test1 )], constraint_regexp_map => { qr/^test/ => 'email', }, }; my $data = { test1 => 'not an email', }; my $results1 = Data::FormValidator->check( $data, $profile ); my $c1 = { %{ $profile->{constraints} } }; my $results2 = Data::FormValidator->check( $data, $profile ); my $c2 = { %{ $profile->{constraints} } }; is_deeply( $results1->{profile}, $results2->{profile}, "constraints aren't duped when profile with constraint_regexp_map is reused" ); is_deeply( $c1, $c2, "constraints aren't duped when profile with constraint_regexp_map is reused" ); { my $profile = { required => [qw( test1 )], field_filter_regexp_map => { qr/^test/ => 'trim', }, }; my $data = { test1 => ' not an email ', }; my $results1 = Data::FormValidator->check( $data, $profile ); my $c1 = { %{ $profile->{constraints} } }; my $results2 = Data::FormValidator->check( $data, $profile ); my $c2 = { %{ $profile->{constraints} } }; is_deeply( $results1->{profile}, $results2->{profile}, "field_filters aren't duped when profile with field_filter_regexp_map is reused" ); is_deeply( $c1, $c2, "field_filters aren't duped when profile with field_filter_regexp_map is reused" ); } Data-FormValidator-4.88/t/upload_mime_types.t0000755000175000017500000000156113150655017021425 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More tests => 5; use_ok('Data::FormValidator::Constraints::Upload'); # Exercise the _is_allowed_type() helper function # Test the negative case isnt( Data::FormValidator::Constraints::Upload::_is_allowed_type('foo'), 1, "'foo' not considered an allowed mime type" ); # Reality check that a simple jpeg is allowed is( Data::FormValidator::Constraints::Upload::_is_allowed_type('image/jpeg'), 1, "'image/jpeg' is considered an allowed mime type" ); # Check that we handle case insensitivity is( Data::FormValidator::Constraints::Upload::_is_allowed_type('image/JPEG'), 1, "'image/JPEG' is considered an allowed mime type" ); # Also ensure progressive jpegs are allowed is( Data::FormValidator::Constraints::Upload::_is_allowed_type('image/pjpeg'), 1, "'image/pjpeg' is considered an allowed mime type" ); Data-FormValidator-4.88/t/04_arrayify_undef.t0000755000175000017500000000207513150655017021221 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More tests => 4; { my $test_name = "checks for correct behavior when 'required' is not specified; fails if _arrayify() does not return an empty list"; use Data::FormValidator; my $input_profile = { optional => [qw( email )] }; my $validator = Data::FormValidator->new( { default => $input_profile } ); my $input_hashref = { email => 'bob@example.com' }; my ( $valids, $missings, $invalids, $unknowns ); eval { ( $valids, $missings, $invalids, $unknowns ) = $validator->validate( $input_hashref, 'default' ); }; is( $@, '', $test_name ); is( @$missings, 0, $test_name ); } { my $test_name = "arrayref with first element undef"; use Data::FormValidator::Results; my $inputs = [ undef, 1, 2, 3, "Echo", "Foxtrot" ]; my $retval = Data::FormValidator::Results::_arrayify($inputs); my @retval = Data::FormValidator::Results::_arrayify($inputs); is( $retval, 6, "$test_name... in scalar context" ); is_deeply( \@retval, $inputs, "$test_name..in list context" ); } Data-FormValidator-4.88/t/09_require_some.t0000755000175000017500000000133513150655017020714 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More tests => 4; use Data::FormValidator; my $input_profile = { require_some => { testing_default_to_1 => [qw/one missing1 missing2/], '2_of_3_success' => [ 2, qw/blue green red/ ], '2_of_3_fail' => [ 2, qw/foo bar zar/ ], }, }; my $validator = new Data::FormValidator( { default => $input_profile } ); my $input_hashref = { one => 1, blue => 1, green => 1, }; my ( $valids, $missings, $invalids, $unknowns ); eval { ( $valids, $missings, $invalids, $unknowns ) = $validator->validate( $input_hashref, 'default' ); }; ok( $valids->{blue} ); ok( $valids->{green} ); ok( $valids->{one} ); ok( grep { /2_of_3_fail/ } @$missings ); Data-FormValidator-4.88/t/missing_optional.t0000755000175000017500000000451313150655017021264 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More 'no_plan'; use Data::FormValidator; # Tests for missing_optional_valid my $input_profile = { required => [qw( email_1 email_ok)], optional => [ 'filled', 'not_filled' ], constraint_regexp_map => { '/^email/' => "email", }, constraints => { not_filled => 'phone', }, missing_optional_valid => 1, }; my $validator = new Data::FormValidator( { default => $input_profile } ); my $input_hashref = { email_1 => 'invalidemail', email_ok => 'mark@stosberg.com', filled => 'dog', not_filled => '', should_be_unknown => 1, }; my ( $valids, $missings, $invalids, $unknowns ); eval { ( $valids, $missings, $invalids, $unknowns ) = $validator->validate( $input_hashref, 'default' ); }; is( $@, '', "survived eval" ); # "not_filled" should appear valids now. ok( exists $valids->{'not_filled'} ); # "should_be_unknown" should be still be unknown ok( $unknowns->[0] eq 'should_be_unknown' ); eval { require CGI;CGI->VERSION(4.35); }; SKIP: { skip 'CGI 4.35 or higher not found', 3 if $@; my $q = CGI->new($input_hashref); my ( $valids, $missings, $invalids, $unknowns ); eval { ( $valids, $missings, $invalids, $unknowns ) = $validator->validate( $q, 'default' ); }; ok( not $@ ); # "not_filled" should appear valids now. ok( exists $valids->{'not_filled'} ); # "should_be_unknown" should be still be unknown ok( $unknowns->[0] eq 'should_be_unknown' ); } { my $res = Data::FormValidator->check( { a => 1, b => undef, # c is completely missing }, { optional => [qw/a b c/], missing_optional_valid => 1 } ); is( join( ',', sort $res->valid() ), 'a,b', "optional fields have to at least exist to be valid" ); } { my $data = { optional_invalid => 'invalid' }; my $profile = { optional => [qw/optional_invalid/], constraints => { optional_invalid => qr/^valid$/ }, missing_optional_valid => 1 }; my $results = Data::FormValidator->check( $data, $profile ); my $valid = $results->valid(); my $invalid = $results->invalid(); ok( exists $invalid->{'optional_invalid'}, 'optional_invalid is invalid' ); ok( !exists $valid->{'optional_invalid'}, 'optional_invalid is not valid' ); } Data-FormValidator-4.88/t/06_regexp_map.t0000755000175000017500000000375013150655017020344 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More tests => 5; use Data::FormValidator; my $input_profile = { required => [qw( email_1 email_ok)], optional => [qw/ extra first_name last_name /], constraint_regexp_map => { '/^email/' => "email", }, field_filter_regexp_map => { '/_name$/' => 'ucfirst', } }; my $validator = new Data::FormValidator( { default => $input_profile } ); my $input_hashref = { email_1 => 'invalidemail', email_ok => 'mark@stosberg.com', extra => 'unrelated field', first_name => 'mark', last_name => 'stosberg', }; my ( $valids, $missings, $invalids, $unknowns ); eval { ( $valids, $missings, $invalids, $unknowns ) = $validator->validate( $input_hashref, 'default' ); }; ok( not $@ ); ok( $invalids->[0] eq 'email_1' ); ok( $valids->{'email_ok'} ); ok( $valids->{'extra'} ); ok( $valids->{'first_name'} eq 'Mark' and $valids->{'last_name'} eq 'Stosberg' ); # Tests below added 04/24/03 to test adding constraints to fields with existing constraints eval { my ( $valids, $missings, $invalids ) = Data::FormValidator->validate( # input { with_no_constraint => 'f1 text', with_one_constraint => 'f2 text', with_mult_constraint => 'f2 text', }, # profile { required => [qw/with_no_constraint with_one_constraint with_mult_constraint/], constraints => { with_one_constraint => 'email', with_mult_constraint => [ 'email', 'american_phone' ], }, constraint_regexp_map => { '/^with/' => 'state', }, msgs => {}, } ); }; TODO: { local $TODO = 'rewrite when message system is rebuilt'; #ok (not $@) ir diag $@; #like($invalids->{with_no_constraint}, qr/Invalid/ , '...with no existing constraints'); #ok(scalar @{ $invalids->{with_one_constraint} } eq 2, '...with one existing constraint'); #ok(scalar @{ $invalids->{with_mult_constraint} } eq 3,'...with two existing constraints'); } Data-FormValidator-4.88/t/rename_builtin_constraints.t0000755000175000017500000000121713150655017023330 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More 'no_plan'; use Data::FormValidator; use Data::FormValidator::Constraints qw( FV_max_length ); my $result = Data::FormValidator->check( { first_names => 'Too long', }, { required => [qw/first_names/], constraint_methods => { first_names => { constraint_method => FV_max_length(3), name => 'custom_length', } }, msgs => { constraints => { custom_length => 'Custom length msg', } }, } ); like( $result->msgs->{'first_names'}, qr/Custom length msg/, "built-ins can have custom names" ); Data-FormValidator-4.88/t/filters_builtin.t0000755000175000017500000000306113150655017021101 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More 'no_plan'; use Data::FormValidator::Filters (qw/:filters/); { my $comma_splitter = FV_split(','); is_deeply( $comma_splitter->('a,b'), [qw/a b/], "FV_split with two values" ); is_deeply( $comma_splitter->('a'), [qw/a/], "FV_split with one value" ); is_deeply( $comma_splitter->(), undef, "FV_split with no values" ); } { my $replacer = FV_replace( qr/^a/, 'b' ); is( $replacer->('aa'), 'ba', 'FV_replace positive test' ); is( $replacer->('XX'), 'XX', 'FV_replace negative test' ); $replacer = FV_replace( qr/^a/i, 'b' ); is( $replacer->('AA'), 'bA', 'FV_replace positive test' ); } is( filter_dollars('There is $0.11e money in here somewhere'), '0.11', "filter_dollars works as expected" ); TODO: { local $TODO = 'all these broken filters need to be dealt with.'; is( filter_dollars('0.111'), '0.11', "filter_dollars removes trailing numbers" ); is( filter_neg_integer('9-'), 'a9-', "filter_neg_integer should leave string without a negative integer alone." ); is( filter_pos_integer('a9+'), '9', "filter_pos_integer should care which side a + is on." ); is( filter_integer('a9+'), '9', "filter_integer should care which side a + is on." ); is( filter_decimal('1,000.23'), '1000.23', "filter_decimal should handle commas correctly" ); is( filter_pos_decimal('1,000.23'), '1000.23', "filter_pos_decimal should handle commas correctly" ); is( filter_neg_decimal('-1,000.23'), '-1000.23', "filter_neg_decimal should handle commas correctly" ); } Data-FormValidator-4.88/t/ValidatorPackagesTest2.pm0000755000175000017500000000026013150655017022360 0ustar dfarrelldfarrellpackage ValidatorPackagesTest2; sub valid_multi_validator_success_expected { my $val = shift; return 1; } sub valid_multi_validator_failure_expected { return undef; } 1; Data-FormValidator-4.88/t/dates_closure.t0000755000175000017500000000704513150655017020545 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More; use Data::FormValidator; use Data::FormValidator::Constraints::Dates qw( date_and_time ); eval { require Date::Calc; }; if ($@) { plan skip_all => 'Date::Calc required for date testing'; } else { plan 'no_plan'; } my $format = Data::FormValidator::Constraints::Dates::_prepare_date_format( 'MM/DD/YYYY hh?:mm:ss pp'); my ( $date, $year, $month, $day, $hour, $min, $sec ) = Data::FormValidator::Constraints::Dates::_parse_date_format( $format, '12/02/2003 1:01:03 PM' ); ok( $date eq '12/02/2003 1:01:03 PM', 'returning untainted date' ); ok( $year == 2003, 'basic date prepare and parse test' ); ok( $month == 12 ); ok( $day == 2 ); ok( $hour == 13 ); ok( $min == 1 ); ok( $sec == 3 ); # Now try again, leaving out PM, which may trigger a warning when it shouldn't $format = Data::FormValidator::Constraints::Dates::_prepare_date_format( 'MM/DD/YYYY hh?:mm:ss'); ( $date, $year, $month, $day, $hour, $min, $sec ) = Data::FormValidator::Constraints::Dates::_parse_date_format( $format, '12/02/2003 1:01:03' ); is( $date, '12/02/2003 1:01:03', 'returning untainted date' ); ok( $year == 2003, 'basic date prepare and parse test' ); ok( $month == 12, 'month' ); ok( $day == 2, 'day' ); ok( $hour == 1, 'hour' ); ok( $min == 1, 'min' ); ok( $sec == 3, 'sec' ); my $simple_profile = { required => [qw/date_and_time_field_bad date_and_time_field_good/], validator_packages => [qw/Data::FormValidator::Constraints::Dates/], constraint_methods => { 'date_and_time_field_good' => date_and_time('MM/DD/YYYY hh:mm pp'), 'date_and_time_field_bad' => date_and_time('MM/DD/YYYY hh:mm pp'), }, untaint_constraint_fields => [qw/date_and_time_field/], }; my $simple_data = { date_and_time_field_good => '12/04/2003 02:00 PM', date_and_time_field_bad => 'slug', }; my $validator = new Data::FormValidator( { simple => $simple_profile, } ); my ( $valids, $missings, $invalids, $unknowns ) = ( {}, [], {}, [] ); eval { ( $valids, $missings, $invalids, $unknowns ) = $validator->validate( $simple_data, 'simple' ); }; ok( ( not $@ ), 'eval' ) or diag $@; ok( $valids->{date_and_time_field_good}, 'expecting date_and_time success' ); ok( ( grep /date_and_time_field_bad/, @$invalids ), 'expecting date_and_time failure' ); { my $r = Data::FormValidator->check( { # Testing leap years date_and_time_field_good => '02/29/2008', date_and_time_field_bad_pat => '02/29/2008', leap_seventy_six => '02/29/1976', }, { required => [qw/date_and_time_field_good date_and_time_field_bad_pat/], constraint_methods => { 'date_and_time_field_good' => date_and_time('MM/DD/YY(?:YY)?'), # This pattern actually tests with a 3 digit year, not a four digit year, and fails # on the date 02/29/2008, because 02/29/200 doesn't exist. 'date_and_time_field_bad_pat' => date_and_time('MM/DD/YYY?Y?'), 'leap_seventy_six' => date_and_time('MM/DD/YY(?:YY)?'), }, } ); my $valid = $r->valid; ok( $valid->{date_and_time_field_good}, '02/29/2008 should pass MM/DD/YY(?:YY)?' ); TODO: { local $TODO = "leap year bug?"; ok( $valid->{leap_seventy_six}, '02/29/1976 should pass MM/DD/YY(?:YY)?' ); } # This one fails not because the date is bad, but because the pattern is not sensible # It would be better to detect that the pattern was bad and fail that way, of course. ok( $r->invalid('date_and_time_field_bad_pat'), "02/29/2008 should fail MM/DD/YYY?Y?" ); } Data-FormValidator-4.88/t/27_qualify_ref_happy_death.t0000755000175000017500000000323713150655017023074 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More tests => 5; use Data::FormValidator; # Friendy error messages when quality_to_ref fails due to a typo. -mls 05/03/03 my %FORM = ( bad_email => 'oops', good_email => 'great@domain.com', 'short_name' => 'tim', ); my $results; eval { $results = Data::FormValidator->check( \%FORM, { required => 'good_email', filters => 'grim', # testing filter typo } ); }; like( $@, qr/found named/, 'happy filters typo failure' ); eval { $results = Data::FormValidator->check( \%FORM, { required => 'good_email', field_filters => { 'good_email' => 'grim', # testing filter typo }, } ); }; like( $@, qr/found named/, 'happy field_filters typo failure' ); eval { $results = Data::FormValidator->check( \%FORM, { required => 'good_email', field_filter_regexp_map => { qr/_email$/ => 'grim', # testing filter typo }, } ); }; like( $@, qr/found named/, 'happy field_filter_regexp_map typo failure' ); eval { $results = Data::FormValidator->check( \%FORM, { required => 'good_email', constraints => { good_email => 'e-mail', # typo in constraint name } } ); }; like( $@, qr/found named/, 'happy constraints typo failure' ); eval { $results = Data::FormValidator->check( \%FORM, { required => 'good_email', untaint_all_constraints => 1, constraints => { good_email => 'e-mail', # typo in constraint name } } ); }; like( $@, qr/found named/, 'happy untainted constraints typo failure' ); Data-FormValidator-4.88/t/untaint.pl0000755000175000017500000001670013150655017017541 0ustar dfarrelldfarrell#!/usr/bin/env perl -wT use strict; use Test::More (tests => 55); use Data::FormValidator; use Data::FormValidator::Constraints qw/ :closures FV_max_length /; use Scalar::Util 'tainted'; # A gift from Andy Lester, this trick shows me where eval's die. use Carp; $SIG{__WARN__} = \&carp; $SIG{__DIE__} = \&confess; $ENV{PATH} = "/bin/"; my $data1 = { firstname => $ARGV[0], #Jim }; my $data2 = { lastname => $ARGV[1], #Beam email1 => $ARGV[2], #jim@foo.bar email2 => $ARGV[3], #james@bar.foo }; my $data3 = { ip_address => $ARGV[4], #132.10.10.2 cats_name => $ARGV[5], #Monroe dogs_name => $ARGV[6], #Rufus }; my $data4 = { zip_field1 => [$ARGV[7],$ARGV[7]], #12345 , 12345 zip_field2 => [$ARGV[7],$ARGV[8]], #12345 , oops }; my $data5 = { zip_field1 => [$ARGV[7],$ARGV[7]], #12345 , 12345 zip_field2 => [$ARGV[7],$ARGV[7]], #12345 , oops }; my $data6 = { zip_field1 => [$ARGV[7],$ARGV[7]], #12345 , 12345 zip_field2 => [$ARGV[7],$ARGV[7]], #12345 , oops email1 => $ARGV[2], #jim@foo.bar email2 => $ARGV[3], #james@bar.foo }; my $data7 = { zip_field1 => [$ARGV[7],$ARGV[7]], #12345 , 12345 zip_field2 => [$ARGV[7],$ARGV[7]], #12345 , oops email1 => $ARGV[2], #jim@foo.bar email2 => $ARGV[3], #james@bar.foo }; my $profile = { rules1 => { untaint_constraint_fields => "firstname", required => "firstname", # constraints => { # firstname => '/^\w{1,15}$/' # }, constraint_methods => { firstname => FV_max_length(15), }, }, rules2 => { untaint_constraint_fields => [ qw( lastname email1 )], required => [ qw( lastname email1 email2) ], constraints => { lastname => '/^\w{1,10}$/', email1 => "email", email2 => "email", } }, rules2_closure => { untaint_constraint_fields => [ qw( email1 )], required => [ qw( email1 email2) ], constraint_methods => { email1 => email(), email2 => email(), } }, rules3 => { untaint_all_constraints => 1, required => [ qw(ip_address cats_name dogs_name) ], constraints => { ip_address => "ip_address", cats_name => '/^Felix$/', dogs_name => 'm/^rufus$/i', } }, rules4 => { untaint_constraint_fields=> ['zip_field1','zip_field2'], required=>[qw/zip_field1 zip_field2/], constraints=> { zip_field1=>'zip', }, }, rules5 => { untaint_regexp_map => qr/^zip_field\d/, required_regexp => qr/^zip_field\d/, constraint_method_regexp_map => { qr/^zip_field\d/ => zip(), }, }, rules6 => { untaint_regexp_map => [qr/^zip_field\d/, qr/^email\d/], required_regexp => qr/^(zip_field|email)\d/, constraint_method_regexp_map => { qr/^zip_field\d/ => zip(), qr/^email\d/ => email(), }, }, rules7 => { required_regexp => qr/^zip_field\d/, required => [qw(email1 email2)], untaint_regexp_map => [qr/^zip_field\d/, qr/^email\d/], untaint_constraint_fields => [qw(email1 email2)], constraint_method_regexp_map => { qr/^zip_field\d/ => zip(), }, constraints => { email1 => 'email', email2 => 'email', }, }, }; my $validator = new Data::FormValidator($profile); #Rules #1 my ( $valid, $missing, $invalid, $unknown ); eval { ( $valid, $missing, $invalid, $unknown ) = $validator->validate( $data1, "rules1"); }; is($@,'','avoided eval error'); ok($valid->{firstname}, 'found firstname'); ok(! tainted($valid->{firstname}), 'firstname is untainted'); is($valid->{firstname},$data1->{firstname}, 'firstname has expected value'); #Rules #2 eval { ( $valid, $missing, $invalid, $unknown ) = $validator->validate( $data2, "rules2"); }; is($@,'','avoided eval error'); ok($valid->{lastname}); ok(!tainted($valid->{lastname})); is($valid->{lastname},$data2->{lastname}); ok($valid->{email1}); ok(!tainted($valid->{email1})); is($valid->{email1},$data2->{email1}); ok($valid->{email2}); ok(tainted($valid->{email2}), 'email2 is tainted'); is($valid->{email2},$data2->{email2}); # Rules2 with closures { my ($result,$valid); eval { $result = $validator->check( $data2, "rules2_closure"); }; is($@,'', 'survived eval'); $valid = $result->valid(); ok($valid->{email1}, "found email1 in \%valid") || warn Dumper ($data2,$result); ok(!tainted($valid->{email1}), "email one is not tainted"); is($valid->{email1},$data2->{email1}, "email1 identity"); } #Rules #3 eval { ( $valid, $missing, $invalid, $unknown ) = $validator->validate( $data3, "rules3"); }; ok(!$@); ok($valid->{ip_address}); ok(!tainted($valid->{ip_address})); is($valid->{ip_address},$data3->{ip_address}); #in this case we're expecting no match ok(!(exists $valid->{cats_name}), 'cats_name is not valid'); is($invalid->[0], 'cats_name', 'cats_name fails constraint'); ok($valid->{dogs_name}); ok(!tainted($valid->{dogs_name})); is($valid->{dogs_name},$data3->{dogs_name}); # Rules # 4 eval { ( $valid, $missing, $invalid, $unknown ) = $validator->validate( $data4, "rules4"); }; ok(!$@, 'avoided eval error'); ok(!tainted($valid->{zip_field1}->[0]), 'zip_field1 should be untainted'); ok(tainted($valid->{zip_field2}->[0]), 'zip_field2 should be tainted'); my $results = Data::FormValidator->check( { qr_re_no_parens => $ARGV[9], # 0 qr_re_parens => $ARGV[9], # 0 }, { required => [qw/qr_re_no_parens qr_re_parens/], constraints=>{ qr_re_no_parens => qr/^.*$/, qr_re_parens => qr/^(.*)$/, }, untaint_all_constraints =>1 }); is($results->valid('qr_re_no_parens'),0,'qr RE without parens in untainted'); is($results->valid('qr_re_parens') ,0,'qr RE with parens in untainted'); # Rules #5 eval { ( $valid, $missing, $invalid, $unknown ) = $validator->validate( $data5, "rules5"); }; ok(!$@, 'avoided eval error'); ok($valid->{zip_field1}, "zip_field1 should be valid"); ok(!tainted($valid->{zip_field1}->[0]), 'zip_field1 should be untainted'); ok($valid->{zip_field2}, "zip_field2 should be valid"); ok(!tainted($valid->{zip_field2}->[0]), 'zip_field2 should be untainted'); # Rules #6 eval { ( $valid, $missing, $invalid, $unknown ) = $validator->validate( $data6, "rules6"); }; ok(!$@, 'avoided eval error'); ok($valid->{zip_field1}, "zip_field1 should be valid"); ok(!tainted($valid->{zip_field1}->[0]), 'zip_field1 should be untainted'); ok($valid->{zip_field2}, "zip_field2 should be valid"); ok(!tainted($valid->{zip_field2}->[0]), 'zip_field2 should be untainted'); ok($valid->{email1}, "email1 should be valid"); ok(!tainted($valid->{email1}), 'email1 should be untainted'); ok($valid->{email2}, "email2 should be valid"); ok(!tainted($valid->{email2}), 'email2 should be untainted'); # Rules #7 eval { ( $valid, $missing, $invalid, $unknown ) = $validator->validate( $data7, "rules7"); }; ok(!$@, 'avoided eval error'); ok($valid->{zip_field1}, "zip_field1 should be valid"); ok(!tainted($valid->{zip_field1}->[0]), 'zip_field1 should be untainted'); ok($valid->{zip_field2}, "zip_field2 should be valid"); ok(!tainted($valid->{zip_field2}->[0]), 'zip_field2 should be untainted'); ok($valid->{email1}, "email1 should be valid"); ok(!tainted($valid->{email1}), 'email1 should be untainted'); ok($valid->{email2}, "email2 should be valid"); ok(!tainted($valid->{email2}), 'email2 should be untainted'); Data-FormValidator-4.88/t/profile_checking.t0000755000175000017500000000234413150655017021201 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More tests => 1; use Data::FormValidator; my $input_profile = { required => [qw( email_1 email_ok)], optional => [ 'filled', 'not_filled' ], constraint_regexp_map => { '/^email/' => "email", }, constraints => { not_filled => 'phone', }, missing_optional_valid => 1, bad_key_which_should_trigger_error => 1, another_bad_key_which_should_trigger_error => 1, }; my $validator = new Data::FormValidator( { default => $input_profile } ); my $input_hashref = { email_1 => 'invalidemail', email_ok => 'mark@stosberg.com', filled => 'dog', not_filled => '', should_be_unknown => 1, }; my ( $valids, $missings, $invalids, $unknowns ); eval { ( $valids, $missings, $invalids, $unknowns ) = $validator->validate( $input_hashref, 'default' ); }; ok( not $@ or $@ =~ qr/\QInvalid input profile: keys not recognised [bad_key_which_should_trigger_error, another_bad_key_which_should_trigger_error]/ or $@ =~ qr/\QInvalid input profile: keys not recognised [another_bad_key_which_should_trigger_error, bad_key_which_should_trigger_error]/ ) || warn $@; Data-FormValidator-4.88/t/constraints_builtin.t0000755000175000017500000000103013150655017021772 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More qw/no_plan/; use Data::FormValidator; my $input_profile = { required => [qw( number_field )], constraints => { number_field => { name => 'number', constraint => qr/^\d+$/, } } }; my $input_hashref = { number_field => 0, }; my $results; eval { $results = Data::FormValidator->check( $input_hashref, $input_profile ); }; ok( !$@, 'survived validate' ); is( $results->valid->{number_field}, 0, 'using 0 in a constraint regexp works' ); Data-FormValidator-4.88/t/undefined_arrayref.t0000755000175000017500000000042213150655017021535 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More tests => 1; use Data::FormValidator; my ( $valid, $missing, $invalid, $unknown ) = Data::FormValidator->validate( {}, {} ); ok( ( ref $invalid eq 'ARRAY' ), "no invalid fields are returned as an arrayref" ); Data-FormValidator-4.88/t/constraints_factory.t0000755000175000017500000000124213150655017022000 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More 'no_plan'; use Data::FormValidator; use Data::FormValidator::ConstraintsFactory 'make_length_constraint'; { my $results = Data::FormValidator->check( { short_enough => 'doh', too_long => "So long she's happy", }, { required => [qw/too_long short_enough/], constraints => { too_long => make_length_constraint(5), short_enough => make_length_constraint(5), } } ); ok( $results->valid('short_enough'), 'positive test for make_length_constraint()' ); ok( !$results->valid('too_long'), 'negative test for make_length_constraint()' ); } Data-FormValidator-4.88/t/constraint_method_string.t0000755000175000017500000000304613150655017023020 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More tests => 4; use_ok('Data::FormValidator'); # in response to bug report 2006/10/25 by Brian E. Lozier # test script by Evan A. Zacks # # The problem was that when specifying constraint_methods in a profile and # using the name of a built-in (e.g., "zip") as the constraint, the built-in # (match_zip or valid_zip) ended up being called as a method rather than a # function. # # So now we throw an error if a non-code-ref is used with a constraint method. my $err_re = qr/not a code ref/; { my %profile = ( required => ['zip'], constraint_methods => { zip => 'zip', } ); my %data = ( zip => 56567 ); eval { my $r = Data::FormValidator->check( \%data, \%profile ) }; like( $@, $err_re, "error thrown when given a string to constraint_method" ); } { my %profile = ( required => ['zip'], constraint_methods => { zip => ['zip'], } ); my %data = ( zip => 56567 ); eval { my $r = Data::FormValidator->check( \%data, \%profile ) }; like( $@, $err_re, "error thrown when given a string to constraint_method...even as part of a list." ); } { my %profile = ( required => ['zip'], untaint_all_constraints => 1, constraint_methods => { zip => {} } ); my %data = ( zip => 56567 ); eval { my $r = Data::FormValidator->check( \%data, \%profile ) }; like( $@, $err_re, "error thrown when given a string to constraint_method...even as hash declaration." ); } Data-FormValidator-4.88/t/28_defaults_for_new.t0000755000175000017500000000150413150655017021542 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More tests => 3; use Data::FormValidator; # testing passing defaults to the new constructor. -mls 05/03/03 my %FORM = ( bad_email => 'oops', good_email => 'great@domain.com', 'short_name' => 'tim', ); my $dfv = Data::FormValidator->new( {}, { missing_optional_valie => 1 } ); eval { my $results = $dfv->check( \%FORM, {} ); }; like( $@, qr/Invalid input profile/, 'defaults are checked for syntax' ); $dfv = Data::FormValidator->new( {}, { missing_optional_valid => 1 } ); my $results = $dfv->check( \%FORM, {} ); ok( $results->{profile}->{missing_optional_valid}, 'testing defaults appearing in profile' ); $results = $dfv->check( \%FORM, { missing_optional_valid => 0 } ); ok( !$results->{profile}->{missing_optional_valid}, 'testing overriding defaults' ); Data-FormValidator-4.88/t/upload.t0000755000175000017500000002133513150655017017173 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { eval { require CGI;CGI->VERSION(4.35); }; plan skip_all => 'CGI 4.35 or higher not found' if $@; use_ok('CGI'); use_ok('Data::FormValidator::Constraints::Upload'); } my $cgi_simple_test = 0; eval { require CGI::Simple; }; if ($@) { diag "Skipping CGI::Simple Tests"; } else { diag "Adding CGI::Simple tests"; $cgi_simple_test = 1; } ######################### %ENV = ( %ENV, 'SCRIPT_NAME' => '/test.cgi', 'SERVER_NAME' => 'perl.org', 'HTTP_CONNECTION' => 'TE, close', 'REQUEST_METHOD' => 'POST', 'SCRIPT_URI' => 'http://www.perl.org/test.cgi', 'CONTENT_LENGTH' => 3129, 'SCRIPT_FILENAME' => '/home/usr/test.cgi', 'SERVER_SOFTWARE' => 'Apache/1.3.27 (Unix) ', 'HTTP_TE' => 'deflate,gzip;q=0.3', 'QUERY_STRING' => '', 'REMOTE_PORT' => '1855', 'HTTP_USER_AGENT' => 'Mozilla/5.0 (compatible; Konqueror/2.1.1; X11)', 'SERVER_PORT' => '80', 'REMOTE_ADDR' => '127.0.0.1', 'CONTENT_TYPE' => 'multipart/form-data; boundary=xYzZY', 'SERVER_PROTOCOL' => 'HTTP/1.1', 'PATH' => '/usr/local/bin:/usr/bin:/bin', 'REQUEST_URI' => '/test.cgi', 'GATEWAY_INTERFACE' => 'CGI/1.1', 'SCRIPT_URL' => '/test.cgi', 'SERVER_ADDR' => '127.0.0.1', 'DOCUMENT_ROOT' => '/home/develop', 'HTTP_HOST' => 'www.perl.org' ); diag "testing with CGI.pm version: $CGI::VERSION"; diag "testing with CGI::Simple version: $CGI::Simple::VERSION" if $cgi_simple_test; ## testing vars my $cgi_pm_q; my $cgi_simple_q; ## setup input (need cleaner way) open( IN, 'new; close(IN); ## setup CGI::Simple testing if ($cgi_simple_test) { open( IN, 'new(); close(IN); } use Data::FormValidator; my $default = { required => [qw/hello_world does_not_exist_gif 100x100_gif 300x300_gif/], validator_packages => 'Data::FormValidator::Constraints::Upload', constraints => { 'hello_world' => { constraint_method => 'file_format', params => [], }, 'does_not_exist_gif' => { constraint_method => 'file_format', params => [], }, '100x100_gif' => [ { constraint_method => 'file_format', params => [], }, { constraint_method => 'file_max_bytes', params => [], } ], '300x300_gif' => { constraint_method => 'file_max_bytes', params => [ \100 ], }, }, }; ## same set of tests with each one (does this work?) for my $q ( $cgi_pm_q, $cgi_simple_q ) { next unless $q; diag "Running tests with ", ref $q; my $dfv = Data::FormValidator->new( { default => $default } ); my $results; eval { $results = $dfv->check( $q, 'default' ); }; is( $@, '', 'survived eval' ); my $valid = $results->valid; my $invalid = $results->invalid; # as hash ref my @invalids = $results->invalid; my $missing = $results->missing; # Test to make sure hello world fails because it is the wrong type ok( ( grep { m/hello_world/ } @invalids ), 'expect format failure' ); # should fail on empty/missing source file data ok( ( grep { m/does_not_exist_gif/ } @invalids ), 'expect non-existent failure' ); ok( ( exists $valid->{'100x100_gif'}, "valid" ), 'Make sure 100x100 passes because it is the right type and size' ); my $meta = $results->meta('100x100_gif'); is( ref $meta, 'HASH', 'meta() returns hash ref' ); ok( $meta->{extension}, 'setting extension meta data' ); ok( $meta->{mime_type}, 'setting mime_type meta data' ); ok( ( grep { m/300x300/ } @invalids ), '300x300 should fail because it exceeds max_bytes' ); ok( ( $results->meta('100x100_gif')->{bytes} > 0 ), ( ref $q ) . ': setting bytes meta data' ); # Revalidate to usefully re-use the same fields my $profile_2 = { required => [qw/hello_world 100x100_gif 300x300_gif/], validator_packages => 'Data::FormValidator::Constraints::Upload', constraints => { '100x100_gif' => { constraint_method => 'image_max_dimensions', params => [ \200, \200 ], }, '300x300_gif' => { constraint_method => 'image_max_dimensions', params => [ \200, \200 ], }, }, }; $dfv = Data::FormValidator->new( { profile_2 => $profile_2 } ); eval { $results = $dfv->check( $q, 'profile_2' ); }; ok( not $@ ) or diag $@; $valid = $results->valid; $invalid = $results->invalid; # as hash ref @invalids = $results->invalid; $missing = $results->missing; ok( exists $valid->{'100x100_gif'}, 'expecting success with max_dimensions' ); ok( ( grep /300x300/, @invalids ), 'expecting failure with max_dimensions' ); ok( $results->meta('100x100_gif')->{width} > 0, 'setting width as meta data' ); ok( $results->meta('100x100_gif')->{width} > 0, 'setting height as meta data' ); # Now test trying constraint_regxep_map my $profile_3 = { required => [qw/hello_world 100x100_gif 300x300_gif/], validator_packages => 'Data::FormValidator::Constraints::Upload', constraint_regexp_map => { '/[13]00x[13]00_gif/' => { constraint_method => 'image_max_dimensions', params => [ \200, \200 ], } } }; $dfv = Data::FormValidator->new( { profile_3 => $profile_3 } ); ( $valid, $missing, $invalid ) = $dfv->validate( $q, 'profile_3' ); ok( exists $valid->{'100x100_gif'}, 'expecting success with max_dimensions using constraint_regexp_map' ); ok( ( grep { m/300x300/ } @$invalid ), 'expecting failure with max_dimensions using constraint_regexp_map' ); ## min test my $profile_4 = { required => [qw/hello_world 100x100_gif 300x300_gif/], validator_packages => 'Data::FormValidator::Constraints::Upload', constraints => { '100x100_gif' => { constraint_method => 'image_min_dimensions', params => [ \200, \200 ], }, '300x300_gif' => { constraint_method => 'image_min_dimensions', params => [ \200, \200 ], }, }, }; $dfv = Data::FormValidator->new( { profile_4 => $profile_4 } ); eval { $results = $dfv->check( $q, 'profile_4' ); }; ok( not $@ ) or diag $@; $valid = $results->valid; $invalid = $results->invalid; # as hash ref @invalids = $results->invalid; $missing = $results->missing; ok( exists $valid->{'300x300_gif'}, 'expecting success with min_dimensions' ); ok( ( grep /100x100/, @invalids ), 'expecting failure with min_dimensions' ); ## file type tests ## with new interface { use Data::FormValidator::Constraints::Upload qw(file_format); my $profile_5 = { required => [qw/hello_world 100x100_gif 300x300_gif/], constraint_methods => { '100x100_gif' => [ file_format( mime_types => [qw(image/gif)] ) ], '300x300_gif' => [ file_format( mime_types => [qw(image/png)] ) ] } }; $dfv = Data::FormValidator->new( { profile_5 => $profile_5 } ); eval { $results = $dfv->check( $q, 'profile_5' ); }; ok( not $@ ) or diag $@; $valid = $results->valid; $invalid = $results->invalid; # as hash ref @invalids = $results->invalid; $missing = $results->missing; ok( exists $valid->{'100x100_gif'}, 'expecting success with mime_type' ); ok( ( grep /300x300/, @invalids ), 'expecting failure with mime_type' ); } ## range checks with new format { use Data::FormValidator::Constraints::Upload qw(image_max_dimensions image_min_dimensions); my $profile_6 = { required => [qw/hello_world 100x100_gif 300x300_gif/], constraint_methods => { '100x100_gif' => [ image_max_dimensions( 200, 200 ), image_min_dimensions( 110, 100 ) ], '300x300_gif' => [ image_max_dimensions( 400, 400 ), image_min_dimensions( 245, 100 ) ] } }; $dfv = Data::FormValidator->new( { profile_6 => $profile_6 } ); eval { $results = $dfv->check( $q, 'profile_6' ); }; is( $@, '', 'survived eval' ); $valid = $results->valid; $invalid = $results->invalid; # as hash ref @invalids = $results->invalid; $missing = $results->missing; ok( ( grep /100x100/, @invalids ), 'expecting failure with size range' ); ok( exists $valid->{'300x300_gif'}, 'expecting success with size range' ); } } ## end of for loop done_testing; Data-FormValidator-4.88/t/closure_msgs.t0000755000175000017500000000165213150655017020414 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More; use Data::FormValidator; use Data::FormValidator::Constraints qw( email FV_eq_with ); # Test that closures and custom messages work in combination. # Addresses this reported bug: #73235: msgs lookup doesn't work for built in closures # https://rt.cpan.org/Ticket/Display.html?id=73235 my $result = Data::FormValidator->check( { email => 'a', email_confirm => 'b' }, { required => [qw( email email_confirm )], constraint_methods => { email => [ email(), FV_eq_with('email_confirm') ], }, msgs => { constraints => { email => 'Invalid Email Address', eq_with => 'Must match confirmation' }, } } ); like( $result->msgs->{email}, qr/Email Address/, "custom message for email() works" ); like( $result->msgs->{email}, qr/Must Match/i, "custom message for FV_eq_with() works" ); done_testing(); Data-FormValidator-4.88/t/constraints_reuse.t0000755000175000017500000000442113150655017021456 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More tests => 7; use Data::FormValidator; # This test is to confirm that values are preserved # for input data when used with multiple constraints # as 'params' # note: this relies on the constraint built_to_fail # being evaluated before expected_to_succeed. Which # relies on the order on which perl returns the keys # from each %{ $profile->{constraints} } my %data = ( 'depart_date' => '2004', 'return_date' => '2005', ); my %profile = ( required => [ qw/ depart_date return_date / ], field_filters => { depart_date => sub { my $v = shift; $v =~ s/XXX//; $v; } }, constraints => { depart_date => { name => 'expected_to_succeed', params => [qw/depart_date return_date/], constraint => sub { my ( $depart, $return ) = @_; Test::More::is( $depart, '2004' ); Test::More::is( $return, '2005' ); return ( $depart < $return ); }, }, return_date => { name => 'built_to_fail', params => [qw/depart_date return_date/], constraint => sub { my ( $depart, $return ) = @_; Test::More::is( $depart, '2004' ); Test::More::is( $return, '2005' ); return ( $depart > $return ); }, }, }, missing_optional_valid => 1, msgs => { format => 'error(%s)', constraints => { 'valid_date' => 'bad date', 'depart_le_return' => 'depart is greater than return', }, }, ); my $results = Data::FormValidator->check( \%data, \%profile ); ok( !$results->valid('return_date'), 'first constraint applied intentionally fails' ); ok( $results->valid('depart_date'), 'second constraint still has access to value of field used in first failed constraint.' ); # The next test are to confirm when a constraint method returns 'undef' # that it causes no warnings to be issued { my %profile = ( required => ['foo'], constraints => { foo => { constraint => sub { return; }, }, }, untaint_all_constraints => 1, ); my $err = ''; local *STDERR; open STDERR, '>', \$err; my $results = Data::FormValidator->check( { foo => 1 }, \%profile ); is( $err, '', 'no warnings emitted' ); } Data-FormValidator-4.88/t/FV_length.t0000755000175000017500000001100113150655017017550 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More 'no_plan'; BEGIN { use_ok('Data::FormValidator'); } use Data::FormValidator::Constraints qw( FV_max_length FV_min_length FV_length_between ); my $result = Data::FormValidator->check( { first_names => 'Too long', keywords => 'a', ok => 'Good', }, { required => [qw/first_names keywords ok/], constraint_methods => { first_names => FV_max_length(3), keywords => FV_length_between( 5, 8 ), too_long => FV_min_length(3), ok => { constraint_method => FV_length_between( 3, 6 ), name => 'ok_length', } }, msgs => { constraints => { ok_length => 'Not an OK length', length => 'Wrong Length', } }, } ); ok( defined $result ); # Test multi-line input: someone might be using this for a textarea or somesuch my $multiline_result = Data::FormValidator->check( my $expect = { alpha => "apple\naeroplane\n", # 16 char beta => "bus\nbuffalo\n", # 12 char charlie => "cat\ncoconut\ncoffee\n", # 19 char delta => "dog\ndinosaur\n", # 13 char echo => "egg\nelephant\nemu\n", # 17 char foxtrot => "flan\nfrog\n", # 10 char golf => "giraffe\ngrapefruit\n", # 19 char }, { required => [qw/alpha beta charlie delta echo foxtrot golf/], untaint_all_constraints => 1, constraint_methods => { alpha => FV_max_length(16), # max length beta => FV_max_length(11), # too long charlie => FV_min_length(19), # just long enough delta => FV_min_length(14), # too short echo => FV_length_between( 16, 18 ), # just right foxtrot => FV_length_between( 11, 13 ), # too short golf => FV_length_between( 16, 18 ), # too long }, }, ); ok( $multiline_result->valid('alpha'), 'multiline FV_max_length in bounds' ); ok( $multiline_result->invalid('beta'), 'multiline FV_max_length too long' ); ok( $multiline_result->valid('charlie'), 'multiline FV_min_length in bounds' ); ok( $multiline_result->invalid('delta'), 'multiline FV_min_length too short' ); ok( $multiline_result->valid('echo'), 'multiline FV_length_between in bounds' ); ok( $multiline_result->invalid('foxtrot'), 'multiline FV_length_between too short' ); ok( $multiline_result->invalid('golf'), 'multiline FV_length_between too long' ); # check expected values for valid untainted fields for my $field (qw( alpha charlie echo )) { is( $multiline_result->valid($field), $expect->{$field}, "identity $field" ); } # Test "long" results. Early implementations checked length with # regular expressions which limit length options to 32kb. # The 80000 char test string is an arbitrary length. # good a value as any other. And it's pretty long. # Just for good measure we'll use the unicode smiley character (as seen in # perluniintro) in our test string. my $smiley = "\x{263a}"; # Thats "smiling face, white" folks! my $long_string = "x$smiley" x 40000; # results in a 80000 length string my $long_result = Data::FormValidator->check( { alpha => $long_string, beta => $long_string, charlie => $long_string, delta => $long_string, echo => $long_string, foxtrot => $long_string, golf => $long_string, }, { required => [qw/alpha beta charlie delta echo foxtrot golf/], constraint_methods => { alpha => FV_max_length(80000), # max length beta => FV_max_length(79999), # too long charlie => FV_min_length(80000), # just long enough delta => FV_min_length(80001), # too short echo => FV_length_between( 79999, 80001 ), # just right foxtrot => FV_length_between( 80001, 80000 ), # too short golf => FV_length_between( 70000, 79999 ), # too long }, }, ); ok( $long_result->valid('alpha'), 'long FV_max_length in bounds' ); ok( $long_result->invalid('beta'), 'long FV_max_length too long' ); ok( $long_result->valid('charlie'), 'long FV_min_length in bounds' ); ok( $long_result->invalid('delta'), 'long FV_min_length too short' ); ok( $long_result->valid('echo'), 'long FV_length_between in bounds' ); ok( $long_result->invalid('foxtrot'), 'long FV_length_between too short' ); ok( $long_result->invalid('golf'), 'long FV_length_between too long' ); Data-FormValidator-4.88/t/30_filter_definedness.t0000755000175000017500000000143713150655017022046 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More qw/no_plan/; use Data::FormValidator; # to test definedness of built-in filters and general functions, as reported: http://rt.cpan.org/Ticket/Display.html?id=2751 # upgrade warn to die so we can catch it. $SIG{__WARN__} = sub { die $_[0] }; eval { my $results = Data::FormValidator->check( { empty_array => [ undef, undef ], very_empty => undef, }, { required => [qw/very_empty empty_array/], } ); }; ok( !$@, 'basic validation generates no warnings with -w' ) or diag $@; use Data::FormValidator::Filters (qw/:filters/); for my $filter ( grep { /^filter_/ } keys %:: ) { eval { $::{$filter}->(undef) }; ok( !$@, "uninitialized value in $filter filter generates no warning" ) or diag $@; } Data-FormValidator-4.88/t/05_valid_ip_address.t0000755000175000017500000000141213150655017021501 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More tests => 2; use Data::FormValidator; # performs a basic check to make sure valid_ip_address routine # succeeds and fails when it should. # by Mark Stosberg my $input_profile = { required => [qw( good_ip bad_ip )], constraints => { good_ip => 'ip_address', bad_ip => 'ip_address', } }; my $validator = new Data::FormValidator( { default => $input_profile } ); my $input_hashref = { 'good_ip' => '127.0.0.1', 'bad_ip' => '300.23.1.1', }; my ( $valids, $missings, $invalids, $unknowns ); eval { ( $valids, $missings, $invalids, $unknowns ) = $validator->validate( $input_hashref, 'default' ); }; ok( exists $valids->{'good_ip'} ); is( $invalids->[0], 'bad_ip' ); Data-FormValidator-4.88/t/dependency_groups.t0000755000175000017500000000307513150655017021425 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More; use Data::FormValidator; eval { require CGI;CGI->VERSION(4.35); }; plan skip_all => 'CGI 4.35 or higher not found' if $@; # test profile my $input_profile = { dependency_groups => { password => [qw/pass1 pass2/], }, }; my $input_hashref = { pass1 => 'foo' }; my ( $valids, $missings, $invalids, $unknowns ); my $result; my @fields = (qw/pass1 pass2/); my $validator = Data::FormValidator->new( { default => $input_profile } ); foreach my $fields ( [qw/pass1 pass2/], [qw/pass2 pass1/] ) { my ( $good, $bad ) = @$fields; $input_hashref = { $good => 'foo' }; ## ## validate() eval { ( $valids, $missings, $invalids, $unknowns ) = $validator->validate( $input_hashref, 'default' ); }; ok( !$@, "no eval problems" ); my %missings = map { $_ => 1 } @$missings; is( $valids->{$good}, $input_hashref->{$good}, "[$good] valid" ); ok( $missings{$bad}, "missing [$bad]" ); ## ## check() my $q = CGI->new("$good=foo"); foreach my $input ( $input_hashref, $q ) { eval { $result = $validator->check( $input, 'default' ); }; ok( !$@, "no eval problems" ); isa_ok( $result, "Data::FormValidator::Results", "returned object" ); ok( $result->has_missing, "has_missing returned true" ); ok( $result->missing($bad), "missing($bad) returned true" ); ok( !$result->missing($good), "missing($good) returned false" ); ok( $result->valid($good), "valid($good) returned true" ); ok( !$result->valid($bad), "valid($bad) returned true" ); } } done_testing; Data-FormValidator-4.88/t/21_multiple_fields.t0000755000175000017500000000236013150655017021367 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More tests => 3; use lib ( '.', '../t' ); use Data::FormValidator; # Verify that multiple params passed to a constraint are being handled correctly my $validator = new Data::FormValidator( { default => { required => [qw/my_zipcode_field my_other_field/], constraints => { my_zipcode_field => { constraint => \&zipcode_check, name => 'zipcode', params => [ 'my_zipcode_field', 'my_other_field' ], }, }, }, } ); my @args_for_check; # to control which args were given sub zipcode_check { @args_for_check = @_; if ( $_[0] == 402015 and $_[1] eq 'mapserver_rulez' ) { return 1; } return 0; } my $input_hashref = { my_zipcode_field => '402015', my_other_field => 'mapserver_rulez', }; my ( $valids, $missings, $invalids, $unknowns ); eval { ( $valids, $missings, $invalids, $unknowns ) = $validator->validate( $input_hashref, 'default' ); }; ok( not $@ ) or diag "eval error: $@"; ok( not grep { ( ref $_ ) eq 'ARRAY' } @$invalids ) or diag $#{$invalids}; is_deeply( \@args_for_check, [ 402015, 'mapserver_rulez' ] ); # Local variables: # compile-command: "cd .. && make test" # End: Data-FormValidator-4.88/t/20_careful_exception_handling.t0000755000175000017500000000155513150655017023555 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use lib ( '.', '../t' ); use Test::More tests => 1; use Data::FormValidator; # So as to not trigger a require later on in the code. require UNIVERSAL; # This tests to make sure that when we test $@, we are testing the right thing. # inspired by a patch from dom@semantico.com my $input_profile = { required => 'nothing', }; my $validator = new Data::FormValidator( { default => $input_profile } ); my $input_hashref = { '1_required' => 1, '1_optional' => 1, }; eval { # populate $@ to see if D::FV dies when it shouldn't $@ = 'exceptional value'; my ( $valids, $missings, $invalids, $unknowns ) = ( {}, [], [], [] ); ( $valids, $missings, $invalids, $unknowns ) = $validator->validate( $input_hashref, 'default' ); }; unlike( $@, qr/Error compiling regular expression/ ); # vim: set ai et sw=8 syntax=perl : Data-FormValidator-4.88/t/18_constraint_refs.t0000755000175000017500000000233013150655017021414 0ustar dfarrelldfarrell#!/usr/bin/env perl #!/usr/bin/perl -w use strict; use warnings; use lib ( '.', '../t' ); use Test::More tests => 4; use Data::FormValidator; # This tests for some constraint related bugs found by Chris Spiegel my $input_profile = { required => [qw( email subroutine )], constraints => { subroutine => sub { 0 }, } }; my $validator = new Data::FormValidator( { default => $input_profile } ); my $input_hashref = { subroutine => 'anything' }; my ( $valids, $missings, $invalids, $unknowns ) = ( {}, [], [], [] ); ( $valids, $missings, $invalids, $unknowns ) = $validator->validate( $input_hashref, 'default' ); # We need to make sure we do not get a reference back here ok( not ref $invalids->[0] ); $input_profile = { required => [qw( email)], constraints => { email => [ { constraint => 'email', name => 'Your email address is invalid.', } ], } }; $validator = new Data::FormValidator( { default => $input_profile } ); eval { ( $valids, $missings, $invalids, $unknowns ) = $validator->validate( { email => 'invalid' }, 'default' ); }; is( $@, '', 'survived eval' ); is( $invalids->[0]->[0], 'email' ); is( $invalids->[0]->[1], 'Your email address is invalid.' ); Data-FormValidator-4.88/t/check_profile_syntax.t0000755000175000017500000000151713150655017022112 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More qw/no_plan/; use Data::FormValidator; { local $@ = undef; eval { my $results = Data::FormValidator->check( {}, { msgs => { my_field => 'foo', }, } ); }; like( $@, qr/Invalid/, 'checking syntax of unknown msgs fields works' ); } my $results; eval { $results = Data::FormValidator->check( {}, { constraints => { key => { oops => 1, }, }, } ); }; like( $@, qr/Invalid/, 'checking syntax of constraint hashrefs works' ); eval { $results = Data::FormValidator->check( {}, { constraint_regexp_map => { qr/key/ => { oops => 1, }, }, } ); }; like( $@, qr/Invalid/, 'checking syntax of constraint_regexp_map hashrefs works' ); Data-FormValidator-4.88/t/upload_closure.t0000755000175000017500000001111413150655017020721 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More; BEGIN { eval { require CGI;CGI->VERSION(4.35); }; plan skip_all => 'CGI 4.35 or higher not found' if $@; use_ok('CGI'); use_ok('Data::FormValidator::Constraints::Upload'); } ######################### %ENV = ( %ENV, 'SCRIPT_NAME' => '/test.cgi', 'SERVER_NAME' => 'perl.org', 'HTTP_CONNECTION' => 'TE, close', 'REQUEST_METHOD' => 'POST', 'SCRIPT_URI' => 'http://www.perl.org/test.cgi', 'CONTENT_LENGTH' => 3129, 'SCRIPT_FILENAME' => '/home/usr/test.cgi', 'SERVER_SOFTWARE' => 'Apache/1.3.27 (Unix) ', 'HTTP_TE' => 'deflate,gzip;q=0.3', 'QUERY_STRING' => '', 'REMOTE_PORT' => '1855', 'HTTP_USER_AGENT' => 'Mozilla/5.0 (compatible; Konqueror/2.1.1; X11)', 'SERVER_PORT' => '80', 'REMOTE_ADDR' => '127.0.0.1', 'CONTENT_TYPE' => 'multipart/form-data; boundary=xYzZY', 'SERVER_PROTOCOL' => 'HTTP/1.1', 'PATH' => '/usr/local/bin:/usr/bin:/bin', 'REQUEST_URI' => '/test.cgi', 'GATEWAY_INTERFACE' => 'CGI/1.1', 'SCRIPT_URL' => '/test.cgi', 'SERVER_ADDR' => '127.0.0.1', 'DOCUMENT_ROOT' => '/home/develop', 'HTTP_HOST' => 'www.perl.org' ); diag "testing with CGI.pm version: $CGI::VERSION"; open( IN, 'new; use Data::FormValidator; use Data::FormValidator::Constraints::Upload qw( &file_format &file_max_bytes &image_max_dimensions ); my $default = { required => [qw/hello_world does_not_exist_gif 100x100_gif 300x300_gif/], validator_packages => 'Data::FormValidator::Constraints::Upload', constraint_methods => { 'hello_world' => file_format(), 'does_not_exist_gif' => file_format(), '100x100_gif' => [ file_format(), file_max_bytes(), ], '300x300_gif' => file_max_bytes(100), }, }; my $dfv = Data::FormValidator->new( { default => $default } ); my ($results); eval { $results = $dfv->check( $q, 'default' ); }; is( $@, '', 'survived eval' ); my $valid = $results->valid; my $invalid = $results->invalid; # as hash ref my @invalids = $results->invalid; my $missing = $results->missing; # Test to make sure hello world fails because it is the wrong type ok( ( grep { m/hello_world/ } @invalids ), 'expect format failure' ); # should fail on empty/missing source file data ok( ( grep { m/does_not_exist_gif/ } @invalids ), 'expect non-existent failure' ); # Make sure 100x100 passes because it is the right type and size ok( exists $valid->{'100x100_gif'} ); my $meta = $results->meta('100x100_gif'); is( ref $meta, 'HASH', 'meta() returns hash ref' ); ok( $meta->{extension}, 'setting extension meta data' ); ok( $meta->{mime_type}, 'setting mime_type meta data' ); # 300x300 should fail because it is too big ok( ( grep { m/300x300/ } @invalids ), 'max_bytes' ); ok( $results->meta('100x100_gif')->{bytes} > 0, 'setting bytes meta data' ); # Revalidate to usefully re-use the same fields my $profile_2 = { required => [qw/hello_world 100x100_gif 300x300_gif/], validator_packages => 'Data::FormValidator::Constraints::Upload', constraint_methods => { '100x100_gif' => image_max_dimensions( 200, 200 ), '300x300_gif' => image_max_dimensions( 200, 200 ), }, }; $dfv = Data::FormValidator->new( { profile_2 => $profile_2 } ); eval { $results = $dfv->check( $q, 'profile_2' ); }; is( $@, '', 'survived eval' ); $valid = $results->valid; $invalid = $results->invalid; # as hash ref @invalids = $results->invalid; $missing = $results->missing; ok( exists $valid->{'100x100_gif'}, 'expecting success with max_dimensions' ); ok( ( grep /300x300/, @invalids ), 'expecting failure with max_dimensions' ); ok( $results->meta('100x100_gif')->{width} > 0, 'setting width as meta data' ); ok( $results->meta('100x100_gif')->{width} > 0, 'setting height as meta data' ); # Now test trying constraint_regxep_map my $profile_3 = { required => [qw/hello_world 100x100_gif 300x300_gif/], validator_packages => 'Data::FormValidator::Constraints::Upload', constraint_method_regexp_map => { '/[13]00x[13]00_gif/' => image_max_dimensions( 200, 200 ), } }; $dfv = Data::FormValidator->new( { profile_3 => $profile_3 } ); ( $valid, $missing, $invalid ) = $dfv->validate( $q, 'profile_3' ); ok( exists $valid->{'100x100_gif'}, 'expecting success with max_dimensions using constraint_regexp_map' ); ok( ( grep { m/300x300/ } @$invalid ), 'expecting failure with max_dimensions using constraint_regexp_map' ); done_testing; Data-FormValidator-4.88/t/filter_constraints.t0000755000175000017500000000566213150655017021630 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use lib ( '.', '../t' ); use Test::More tests => 4; use Data::FormValidator; # This test is a for a bug where a value doesn't get filtered when it should # The bug was discovered by Jeff Till, and he contributed this test, too. # Verify that multiple params passed to a constraint are being filtered my $validator = new Data::FormValidator( { default => { filters => ['trim'], required => [qw/my_junk_field my_other_field/], constraints => { my_junk_field => { constraint => \&letters_2_var, name => 'zipcode', }, my_other_field => \&letters, }, }, } ); sub letters_2_var { if ( $_[0] =~ /^[a-z]+$/i ) { return 1; } return 0; } sub letters { if ( $_[0] =~ /^[a-z]+$/i ) { return 1; } return 0; } my $input_hashref = { my_junk_field => 'foo ', my_other_field => ' bar', }; my ( $valids, $missings, $invalids, $unknowns ) = $validator->validate( $input_hashref, 'default' ); is_deeply( $invalids, [], "all fields are valid" ); { # RT#13078 my $res; eval { $res = Data::FormValidator->check( { local_filter => ' needs@trimmed.com ', global_filter_field => ' needs@trimmed.com ', }, { required => [ 'local_filter', 'global_filter_field' ], filters => [ sub { my $v = shift; $v =~ s/needs/global/g; $v }, ], field_filters => { local_filter => 'trim', }, constraints => { local_filter => [ 'email', { constraint => sub { my $val = shift; return ( $val eq 'global@trimmed.com' ); }, params => ['local_filter'], } ], global_filter_field => [ sub { my $val = shift; if ( $val eq ' global@trimmed.com ' ) { return 1; } else { warn "without param got: '$val', expected 'global\@trimmed.com'"; return undef; } }, { constraint => sub { my $val = shift; if ( $val eq ' global@trimmed.com ' ) { return 1; } else { warn " using param got: '$val', expected 'global\@trimmed.com'"; return undef; } }, params => ['global_filter_field'], }, ] }, } ); }; is( $@, '', 'survived eval' ); eval { ok( $res->valid('local_filter'), " when passed through param, local filters are applied." ); }; eval { ok( $res->valid('global_filter_field'), " when passed through param, global filters are applied." ); }; } Data-FormValidator-4.88/t/constraints_invalid_once_only.t0000755000175000017500000000171513150655017024031 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More tests => 1; use Data::FormValidator; # this test checks that a failing constraint is only marked as invalid once sub check_passwords { my ( $dfv, $val ) = @_; my $passwords = $dfv->{__INPUT_DATA}->{password}; if ( ref($passwords) eq 'ARRAY' ) { if ( $$passwords[0] eq $$passwords[1] ) { return 1; } return 0; } return 1; } my %data = ( 'password' => [ '123456', '123457' ], ); my %profile = ( optional => [qw/password/], constraint_methods => { password => \&check_passwords, }, ); my $results = Data::FormValidator->check( \%data, \%profile ); my $invalid = $results->{invalid}; my $duplicated = {}; my $has_duplicates; foreach ( @{ $invalid->{password} } ) { next unless $_; if ( exists $duplicated->{$_} ) { $has_duplicates = 1; last; } $duplicated->{$_} = 1; } ok( !$has_duplicates, 'constraint marked as invalid only once' ); Data-FormValidator-4.88/t/16_cgi_object.t0000755000175000017500000000136213150655017020303 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use lib ( '.', '../t' ); use Test::More; use Data::FormValidator; # This script tests whether a CGI.pm object can be used to provide the input data # Mark Stosberg 02/16/03 eval { require CGI;CGI->VERSION(4.35); }; plan skip_all => 'CGI 4.35 or higher not found' if $@; my $q; eval { $q = CGI->new( { my_zipcode_field => 'big brown' } ); }; ok( not $@ ); my $input_profile = { required => ['my_zipcode_field'], }; my $validator = new Data::FormValidator( { default => $input_profile } ); my ( $valids, $missings, $invalids, $unknowns ); eval { ( $valids, $missings, $invalids, $unknowns ) = $validator->validate( $q, 'default' ); }; is( $valids->{my_zipcode_field}, 'big brown' ); done_testing; Data-FormValidator-4.88/t/simple.t0000755000175000017500000000141313150655017017173 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More tests => 3; use Data::FormValidator; my $input_profile = { required => [qw( email phone likes )], optional => [qq( toppings )], constraints => { email => "email", phone => "phone", } }; my $validator = new Data::FormValidator( { default => $input_profile } ); my $input_hashref = { email => 'invalidemail', phone => '201-999-9999', likes => [ 'a', 'b' ], toppings => 'foo' }; my ( $valids, $missings, $invalids, $unknowns ) = ( {}, [], [], [] ); eval { ( $valids, $missings, $invalids, $unknowns ) = $validator->validate( $input_hashref, 'default' ); }; is( $@, '', 'survived eval' ); ok( exists $valids->{'phone'}, "phone is valid" ); is( $invalids->[0], 'email' ) Data-FormValidator-4.88/t/constraints_regexp_map_interaction.t0000755000175000017500000000231513150655017025061 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use lib 'perllib'; use Test::More qw/no_plan/; use Data::FormValidator; my $input_profile = { required => ['email_field'], constraints => { email_field => ['email'], } }; my $input_hashref = { email_field => 'test@bad_email', }; my $results; eval { $results = Data::FormValidator->check( $input_hashref, $input_profile ); }; is( $@, '', "Survived validate" ); my @invalids = $results->invalid; is( scalar @invalids, 1, "Correctly catches the bad field" ); is( $invalids[0], 'email_field', "The invalid field is listed correctly as 'email_field'" ); # Now add constraint_regexp_map to the profile, and we'll get a weird interaction... my $regex = qr/^test/; $input_profile->{constraint_regexp_map} = { qr/email_/ => $regex }; eval { $results = Data::FormValidator->check( $input_hashref, $input_profile ); }; is( $@, '', "Survived validate" ); @invalids = $results->invalid; is( scalar @invalids, 1, "Still correctly catches the bad field" ); is( $invalids[0], 'email_field', "The invalid field is still listed correctly as 'email_field'" ); ok( $input_hashref->{email_field} =~ $regex, "But perl agrees that the email address does match the regex" ); Data-FormValidator-4.88/t/19_refs_as_values.t0000755000175000017500000000164213150655017021220 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use lib ( '.', '../t' ); use Test::More tests => 3; use Data::FormValidator; # This tests to make sure that we can use hashrefs and code refs as OK values in the input hash # inspired by a patch from Boris Zentner my $input_profile = { required => [qw( arrayref hashref coderef )], }; my $validator = new Data::FormValidator( { default => $input_profile } ); my $input_hashref = { arrayref => [ '', 1, 2 ], hashref => { tofu => 'good' }, coderef => sub { return 'the answer is 42' }, }; my ( $valids, $missings, $invalids, $unknowns ) = ( {}, [], [], [] ); ( $valids, $missings, $invalids, $unknowns ) = $validator->validate( $input_hashref, 'default' ); # empty strings in arrays should be set to "undef" ok( not defined $valids->{arrayref}->[0] ); # hash refs and code refs should be ok. is( ref $valids->{hashref}, 'HASH' ); is( ref $valids->{coderef}, 'CODE' ); Data-FormValidator-4.88/t/filters_shouldnt_modify.t0000755000175000017500000000115313150655017022642 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More qw/no_plan/; use Data::FormValidator; my %h = ( key => [ ' value1 ', ' value2 ' ] ); # Testing an internal function here, so it's OK if this test starts # to fail because the API changes my %out = Data::FormValidator::Results::_get_input_as_hash( {}, \%h ); isnt( $h{key}, $out{key}, "after copying structure, values should have different memory addresses" ); { Data::FormValidator->check( \%h, { required => ['key'], filters => ['trim'], } ); is( $h{key}[0], ' value1 ', "filters shouldn't modify data in arrayrefs" ); } Data-FormValidator-4.88/t/regexp_common_closure.t0000755000175000017500000000436213150655017022306 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More tests => 13; use Data::FormValidator; # Integration with Regexp::Common; my %FORM = ( bad_ip => '127 0 0 1', good_ip => '127.0.0.1', embedded_ip => 'The address is 127.0.0.1 or something close to that', valid_int => 0, ); my $results; BEGIN { use_ok( 'Data::FormValidator::Constraints', qw/:regexp_common/ ) } eval { $results = Data::FormValidator->check( \%FORM, { required => [qw/good_ip bad_ip valid_int/], constraint_method_regexp_map => { qr/_ip$/ => FV_net_IPv4(), }, constraint_methods => { valid_int => FV_num_int(), } } ); }; is( $@, '', 'survived eval' ); ok( $results->valid->{good_ip}, 'good ip' ); ok( $results->invalid->{bad_ip}, 'bad ip' ); is( $results->valid->{valid_int}, 0, 'zero is valid int' ); $results = Data::FormValidator->check( \%FORM, { untaint_all_constraints => 1, required => [qw/good_ip bad_ip valid_int/], constraint_method_regexp_map => { qr/_ip$/ => FV_net_IPv4(), }, constraint_methods => { valid_int => FV_num_int(), } } ); is( $@, '', 'survived eval' ); ok( $results->valid->{good_ip}, 'good ip with tainting' ); ok( $results->invalid->{bad_ip}, 'bad ip with tainting' ); is( $results->valid->{valid_int}, 0, 'zero is valid int with untainting' ); # Test passing flags $results = Data::FormValidator->check( \%FORM, { required => [qw/good_ip bad_ip/], constraint_method_regexp_map => { qr/_ip$/ => FV_net_IPv4_dec( -sep => ' ' ), } } ); ok( ( not $@ ), 'runtime errors' ) or diag $@; # Here we are trying passing a parameter which should reverse # the notion of which one expect to succeed. ok( $results->valid->{bad_ip}, 'expecting success with params' ); ok( $results->invalid->{good_ip}, 'expecting failure with params' ); # Testing end-to-end matching $results = Data::FormValidator->check( \%FORM, { required => [qw/embedded_ip/], constraint_method_regexp_map => { qr/_ip$/ => FV_net_IPv4(), } } ); my $invalid = scalar $results->invalid || {}; ok( $invalid->{embedded_ip}, 'testing that the RE must match from end-to-end' ); Data-FormValidator-4.88/t/pod.t0000755000175000017500000000126313150655017016467 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More; use File::Spec; use File::Find; # Check our Pod # The test was provided by Andy Lester, # who stole it from Brian D. Foy # Thanks to both ! eval { require Test::Pod; Test::Pod->import; }; my @files; if ($@) { plan skip_all => "Test::Pod required for testing POD"; } elsif ( $Test::Pod::VERSION < 0.95 ) { plan skip_all => "Test::Pod 0.95 required for testing POD"; } else { my $blib = File::Spec->catfile(qw(blib lib)); find( \&wanted, $blib, 'lib' ); plan tests => scalar @files; foreach my $file (@files) { pod_file_ok($file); } } sub wanted { push @files, $File::Find::name if /\.p(l|m|od)$/; } Data-FormValidator-4.88/t/17_multi_valued_keys.t0000755000175000017500000000442413150655017021743 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use lib ( '.', '../t' ); use Test::More tests => 8; use Data::FormValidator; # This script tests validating keys with multiple data my $input_hash = { single_value => ' Just One ', multi_values => [ ' One ', ' Big ', ' Happy ', ' Family ' ], re_multi_test => [qw/at the circus/], constraint_multi_test => [qw/12345 22234 oops/], }; my $input_profile = { required => [qw/single_value multi_values re_multi_test constraint_multi_test/], filters => [qw/trim/], field_filters => { single_value => 'lc', multi_values => 'uc', }, field_filter_regexp_map => { '/_multi_test$/' => 'ucfirst', }, constraints => { constraint_multi_test => 'zip', }, }; my $validator = new Data::FormValidator( { default => $input_profile } ); my ( $valids, $missings, $invalids, $unknowns ); eval { ( $valids, $missings, $invalids, $unknowns ) = $validator->validate( $input_hash, 'default' ); }; is( $valids->{single_value}, 'just one', 'inconditional filters still work with single values' ); is( lc $valids->{multi_values}->[0], lc 'one', 'inconditional filters work with multi values' ); is( $valids->{multi_values}->[0], 'ONE', 'field filters work with multiple values' ); is( $valids->{re_multi_test}->[0], 'At', 'Test the filters applied to multiple values by RE work' ); ok( !$valids->{constraint_multi_test}, 'If any of the values fail the constraint, the field becomes invalid' ); my $r; eval { $r = Data::FormValidator->check( { undef_multi => [undef] }, { required => 'undef_multi' } ); }; diag "error: $@" if $@; ok( $r->missing('undef_multi'), 'multi-valued field containing only undef should be missing' ); my $v; eval { $v = $r->valid('undef_multi'); }; diag "error: $@" if $@; ok( !$v, 'multiple valued fields containing only undefined values should not be valid' ); ### eval { $r = Data::FormValidator->check( { cc_type => ['Check'], }, { required => 'cc_type', dependencies => { cc_type => { Check => [qw( cc_num )], Visa => [qw( cc_num cc_exp cc_name )], }, }, } ); }; diag "error: $@" if $@; ok( $r->missing('cc_num'), 'a single valued array should still trigger the dependency check' ); Data-FormValidator-4.88/t/ValidatorPackagesTest1.pm0000755000175000017500000000046113150655017022362 0ustar dfarrelldfarrellpackage ValidatorPackagesTest1; sub match_single_validator_success_expected { my $val = shift; return 1; } sub match_single_validator_failure_expected { return undef; } sub filter_single_filter_remove_whitespace { my $val = shift; $val =~ s/^\s+//; $val =~ s/\s+$//; return $val; } 1; Data-FormValidator-4.88/t/untaint.t0000755000175000017500000000107213150655017017365 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Carp; use Config; $SIG{__WARN__} = \&carp; $SIG{__DIE__} = \&confess; # A gift from Andy Lester, this trick shows me where eval's die. my @args = ( '-I./lib', ( ( defined( $ENV{PERL5LIB} ) && length( $ENV{PERL5LIB} ) ) ? ( map { "-I$_" } split( /$Config{path_sep}/, $ENV{PERL5LIB} ) ) : () ), '-T', './t/untaint.pl', qw(Jim Beam jim@foo.bar james@bar.foo 132.10.10.2 Monroe Rufus 12345 oops 0) ); # We use $^X to make it easier to test with different versions of Perl. system( $^X, @args ); Data-FormValidator-4.88/t/procedural_valid.t0000755000175000017500000000542213150655017021225 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More qw/no_plan/; use Data::FormValidator qw(:validators :matchers); #Check that the valid_* routines are nominally working. my $invalid = "fake value"; #For CC Exp test my @time = localtime(time); my %tests = ( valid_american_phone => "555-555-5555", valid_cc_exp => "10/" . sprintf( "%.2d", ( $time[5] - 99 ) ), valid_cc_type => "MasterCard", valid_email => 'foo@domain.com', valid_ip_address => "64.58.79.230", valid_phone => "123-456-7890", valid_postcode => "T2N 0E6", valid_province => "NB", valid_state => "CA", valid_state_or_province => "QC", valid_zip => "94112", valid_zip_or_postcode => "50112", ); my $i = 1; foreach my $function ( keys(%tests) ) { my $rv; my $val = $tests{$function}; my $is_valid = "\$rv = $function('$val');"; my $not_valid = "\$rv = $function('$invalid');"; eval $is_valid; ok( not $@ and $rv == 1 ) or diag $@; #diag sprintf("%-25s using %-16s", $function, "(valid value)"); $i++; eval $not_valid; ok( not $@ and not $rv ) or diag sprintf( "%-25s using %-16s", $function, "(invalid value)" ); $i++; } #Test cc_number separately since it takes multiple parameters { my $rv; my $num = '4111111111111111'; eval "\$rv = match_cc_number('$num', 'v')"; ok( not $@ and ( $rv eq $num ) ) or diag sprintf( "%-25s using %-16s", "match_cc_number", "valid value. " ); eval "\$rv = valid_cc_number('$invalid', 'm')"; ok( not $@ and not $rv ) or diag sprintf ( "%-25s using %-16s", "valid_cc_number", "(invalid value)" ); } $i++; $i++; #Test fake validation routine { my $rv; eval "\$rv = valid_foobar('$invalid', 'm')"; ok($@) or diag sprintf( "%-25s", "Fake Valid Routine" ); } ok( !valid_email('pretty_b;ue_eyes16@cpan.org'), 'semi-colons in e-mail aren\'t valid' ); ok( !valid_email('Ollie 102@cpan.org'), 'spaces in e-mail aren\'t valid' ); ok( !valid_email('mark@summersualt.com\0mark@summersault.com'), "including a null in an e-mail is not valid." ); my $address_1 = 'mark'; isnt( $address_1, valid_email($address_1), "'$address_1' is not a valid e-mail" ); my $address_2 = 'Mark Stosberg '; ok( !valid_email($address_2), "'$address_2' is not a valid e-mail" ); my $address_3 = 'mark@summersault.com'; ok( valid_email($address_3), "'$address_3' is a valid e-mail" ); my $address_6 = 'Mark.Stosberg@summersault.com'; ok( valid_email($address_6), "'$address_6' is a valid e-mail" ); my $address_7 = 'Mark_Stosberg@summersault.com'; ok( valid_email($address_7), "'$address_7' is a valid e-mail" ); my $addr_8 = "Mark_O'Doul\@summersault.com"; ok( valid_email($addr_8), "'$addr_8' is a valid e-mail" ); Data-FormValidator-4.88/t/multiple_constraints.t0000755000175000017500000000426213150655017022171 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Data::FormValidator; use Test::More tests => 8; use lib ( '.', '../t' ); my $input_profile = { required => ['my_zipcode_field'], constraints => { my_zipcode_field => [ 'zip', { constraint => '/^406/', name => 'starts_with_406', } ], }, }; my $validator = new Data::FormValidator( { default => $input_profile } ); my $input_hashref = { my_zipcode_field => '402015', # born to lose }; my ( $valids, $missings, $invalids, $unknowns ); eval { ( $valids, $missings, $invalids, $unknowns ) = $validator->validate( $input_hashref, 'default' ); }; ok( !$@, 'survived eval' ); ok( ( grep { ( ref $_ ) eq 'ARRAY' } @$invalids ) ); # Test that the array ref in the invalids array contains three elements, my @zip_failures; for (@$invalids) { if ( ref $_ eq 'ARRAY' ) { if ( scalar @$_ == 3 ) { @zip_failures = @$_; # This is cheesy, and could be further refactored. ok(1); last; } } } # Test that the first element of the array is 'my_zipcode_field' my $t = shift @zip_failures; ok( $t eq 'my_zipcode_field' ); # Test that the two elements are 'zip' and 'starts_with_406' ok( eq_set( \@zip_failures, [qw/zip starts_with_406/] ) ); # The next three tests are to confirm that an input field is deleted # from the valids under the following conditions # 1. the input field has multiple constraints # 2. one or more constraint fails my %data = ( multiple => 'to fail', #multiple => [qw{this multi-value input will fail on the constraint below}], single => 'to pass', ); my %profile = ( required => [ qw/ multiple single / ], constraints => { multiple => [ { name => 'constraint_1', constraint => qr/\w/ }, # pass { name => 'constraint_2', constraint => qr/\d/ }, # force fail ], }, ); my $results = Data::FormValidator->check( \%data, \%profile ); ok( !$results->valid('multiple'), "expect 'multiple' not to appear in valid" ); is_deeply( $results->invalid('multiple'), ['constraint_2'], "list of failed constraints for 'multiple'" ); is( $results->valid('single'), 'to pass', "single is valid" ); Data-FormValidator-4.88/t/any_errors.t0000755000175000017500000000313013150655017020063 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More 'no_plan'; use Data::FormValidator; my $dfv_standard_any_errors = Data::FormValidator->new( {} ); my $dfv_custom_any_errors = Data::FormValidator->new( {}, { msgs => { any_errors => 'some_errors' } } ); my %profile = ( required => 'foo', ); my %good_input = ( 'foo' => 1, ); my %bad_input = ( 'bar' => 1, ); my ( $results, $msgs ); # standard 'any_errors', good input $results = $dfv_standard_any_errors->check( \%good_input, \%profile ); $msgs = $results->msgs; ok( $results, "[standard any_errors] good input passed" ); ok( !keys %$msgs, "[standard any_errors] no error messages" ); # standard 'any_errors', bad input $results = $dfv_standard_any_errors->check( \%bad_input, \%profile ); $msgs = $results->msgs; ok( !$results, "[standard any_errors] bad input caught" ); ok( keys %$msgs, "[standard any_errors] error messages reported" ); # custom 'any_errors', good input $results = $dfv_custom_any_errors->check( \%good_input, \%profile ); $msgs = $results->msgs; ok( $results, "[custom any_errors] good input passed" ); ok( !keys %$msgs, "[custom any_errors] no error messages" ); ok( !$msgs->{'some_errors'}, "[custom any_errors] 'some_errors' not reported" ); # custom 'any_errors', bad input $results = $dfv_custom_any_errors->check( \%bad_input, \%profile ); $msgs = $results->msgs; ok( !$results, "[custom any_errors] bad input caught" ); ok( keys %$msgs, "[custom any_errors] error messages reported" ); ok( $msgs->{'some_errors'}, "[custom any_errors] 'some_errors' reported" ); Data-FormValidator-4.88/t/00_base.t0000755000175000017500000000150713150655017017117 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More tests => 5; BEGIN { use_ok('Data::FormValidator'); } my $dfv; eval { $dfv = Data::FormValidator->new( {}, 'wrong' ); }; like( $@, qr/must be a hash ref/, 'second argument must be a hash ref or die' ); eval { $dfv = Data::FormValidator->new('test/00_base.WRONG'); my $results = $dfv->check( {}, 'profile1' ); }; like( $@, qr/no such file/i, 'bad profile file names should cause death' ); eval { $dfv = Data::FormValidator->new('test/00_base.badformat'); my $results = $dfv->check( {}, 'profile1' ); }; like( $@, qr/return a hash ref/, 'profile files should return a hash ref' ); eval { $dfv = Data::FormValidator->new('test/00_base.profile'); }; my $results = $dfv->check( {}, 'profile1' ); ok( scalar $results->missing, 'loading a profile from a file works' ); Data-FormValidator-4.88/t/msgs.t0000755000175000017500000001161513150655017016660 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More qw/no_plan/; use Data::FormValidator; my $simple_profile = { required => [qw/req_1 req_2/], optional => [qw/opt_1/], constraints => { req_1 => 'email' }, msgs => {}, }; my $simple_data = { req_1 => 'not_an_email', }; my $prefix_profile = { required => [qw/req_1 req_2/], optional => [qw/opt_1/], constraints => { req_1 => 'email' }, msgs => { prefix => '', any_errors => 'err__', }, }; my $input_profile = { required => [qw(admin prefork sleep rounds)], constraints => { admin => "email", prefork => sub { my $val = shift; if ( $val =~ /^\d$/ ) { if ( $val > 1 and $val < 9 ) { return $val; } } return 0; }, sleep => [ 'email', { name => 'min', constraint => sub { my $val = shift; if ( $val > 0 ) { return $val; } else { return 0; } } }, { name => 'max', constraint => sub { my $val = shift; if ( $val < 11 ) { return $val; } else { return 0; } } } ], rounds => [ { name => 'min', constraint => sub { my $val = shift; if ( $val > 19 ) { return $val; } else { return 0; } } }, { name => 'max', constraint => sub { my $val = shift; if ( $val < 101 ) { return $val; } else { return 0; } } } ] }, msgs => { missing => 'Test-Missing', invalid => 'Test-Invalid', invalid_seperator => ' ## ', constraints => { max => 'needs to be lesser than 11', min => 'needs to be greater than 0' }, format => 'ERROR: %s', prefix => 'error_', } }; my $validator = new Data::FormValidator( { simple => $simple_profile, default => $input_profile, prefix => $prefix_profile, } ); my $input_hashref = { admin => 'invalidemail', prefork => 9, sleep => 11, rounds => 8 }; my $results; eval { $results = $validator->check( $simple_data, 'simple' ); }; ok( not $@ ); TODO: { local $TODO = 'need to test for msgs() called before validate'; # msgs() should return emit a warning and return undef if the hash # structure it points to is undefined. However, if it points to an # empty hash, then maybe there are just no messages. } # testing simple msg definition, $self->msgs should be returned as a hash ref my $msgs; eval { $msgs = $results->msgs; }; ok( ( not $@ ), 'existence of msgs method' ) or diag $@; ok( ref $msgs eq 'HASH', 'invalid fields returned as hash in simple case' ); like( $msgs->{req_1}, qr/Invalid/, 'default invalid message' ); like( $msgs->{req_2}, qr/Missing/, 'default missing message' ); like( $msgs->{req_1}, qr/span/, 'default formatting' ); # testing single constraints and single error case eval { $results = $validator->check( $input_hashref, 'default' ); }; is( $@, '', 'survived eval' ); $msgs = $results->msgs; like( $msgs->{error_sleep}, qr/lesser.*Test|Test.*lesser/, 'multiple constraints constraint definition' ); eval { $results = $validator->check( $simple_data, 'prefix' ); }; is( $@, '', 'survived eval' ); $msgs = $results->msgs( { format => 'Control-Test: %s' } ); ok( defined $msgs->{req_1}, 'using default prefix' ); is( keys %$msgs, 3, 'size of msgs hash' ); # 2 errors plus 1 prefix ok( defined $msgs->{err__}, 'any_errors' ); like( $msgs->{req_1}, qr/Control/, 'passing controls to method' ); # See what happens when msgs is called with it does not appeare in the profile my @basic_input = ( { field_1 => 'email', }, { required => 'field_1', } ); $results = Data::FormValidator->check(@basic_input); eval { $results->msgs }; ok( ( not $@ ), 'calling msgs method without hash definition' ); ### { my $test_name = 'Spelling "separator" correctly should work OK.'; my $results = Data::FormValidator->check( { field => 'value', }, { required => [qw/field/], constraints => { field => [ 'email', 'province' ], }, msgs => { invalid_separator => ' ## ', }, } ); my $msgs = $results->msgs; like( $msgs->{field}, qr/##/, $test_name ); } ### { my $test_name = 'A callback can be used for msgs'; my $results = Data::FormValidator->check( { field => 'value', }, { required => [qw/field/], constraints => { field => [ 'email', 'province' ], }, msgs => sub { { field => 'callback!' } }, } ); my $msgs = $results->msgs; like( $msgs->{field}, qr/callback/, $test_name ); } Data-FormValidator-4.88/t/11_procedural_match.t0000755000175000017500000000320413150655017021517 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More tests => 26; use Data::FormValidator qw(:validators :matchers); #Check that the match_* routines are nominally working. my $invalid = "fake value"; #For CC Exp test my @time = localtime(time); my %tests = ( match_american_phone => "555-555-5555", match_cc_exp => "10/" . sprintf( "%.2d", ( $time[5] - 99 ) ), match_cc_type => "MasterCard", match_email => 'foo@domain.com', match_ip_address => "64.58.79.230", match_phone => "123-456-7890", match_postcode => "T2N 0E6", match_province => "NB", match_state => "CA", match_state_or_province => "QC", match_zip => "94112", match_zip_or_postcode => "50112", ); my $i = 1; foreach my $function ( keys(%tests) ) { my $rv; my $val = $tests{$function}; my $is_valid = "\$rv = $function('$val');"; my $not_valid = "\$rv = $function('$invalid');"; eval $is_valid; ok( not $@ and ( $rv eq $val ) ) or diag sprintf( "%-25s using %-16s", $function, "valid value. " ); $i++; eval $not_valid; ok( not $@ and not $rv ) or diag sprintf( "%-25s using %-16s", $function, "invalid value. " ); $i++; } #Test cc_number separately since it takes multiple parameters my $rv; my $num = '4111111111111111'; eval "\$rv = match_cc_number('$num', 'v')"; ok( not $@ and ( $rv eq $num ) ) or diag sprintf( "%-25s using %-16s", "match_cc_number", "valid value. " ); eval "\$rv = match_cc_number('$invalid', 'm')"; ok( not $@ and not $rv ) or diag sprintf( "%-25s using %-16s", "match_cc_number", "invalid value. " ); Data-FormValidator-4.88/t/13_validator_packages.t0000755000175000017500000000407013150655017022032 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use lib ( '.', '../t', 't/' ); use Test::More tests => 8; use Data::FormValidator; my $input_profile = { validator_packages => 'ValidatorPackagesTest1', required => [ 'required_1', 'required_2', 'required_3' ], constraints => { required_1 => 'single_validator_success_expected', required_2 => 'single_validator_failure_expected', }, field_filters => { required_3 => 'single_filter_remove_whitespace', }, }; my $validator = new Data::FormValidator( { default => $input_profile } ); my $input_hashref = { required_1 => 123, required_2 => 'testing', required_3 => ' has whitespace ', }; my ( $valids, $missings, $invalids, $unknowns ); eval { ( $valids, $missings, $invalids, $unknowns ) = $validator->validate( $input_hashref, 'default' ); }; ok( not $@ ) or diag "eval error: $@"; ok( defined $valids->{required_1} ); # Test to make sure that the field failed imported validator ok( grep /required_2/, @$invalids ); ok( defined $valids->{required_3} ); is( $valids->{required_3}, 'has whitespace' ); #### Now test importing from multiple packages $input_profile = { validator_packages => [ 'ValidatorPackagesTest1', 'ValidatorPackagesTest2' ], required => [ 'required_1', 'required_2' ], constraints => { required_1 => 'single_validator_success_expected', required_2 => 'multi_validator_success_expected', }, }; $validator = new Data::FormValidator( { default => $input_profile } ); $input_hashref = { required_1 => 123, required_2 => 'testing', }; eval { ( $valids, $missings, $invalids, $unknowns ) = $validator->validate( $input_hashref, 'default' ); }; ok( defined $valids->{required_1} ); ok( defined $valids->{required_2} ); # Now test calling 'validate' as a class method use Data::FormValidator; eval { my ( $valid, $missing, $invalid ) = Data::FormValidator->validate( $input_hashref, { required => [qw/required_1/], validator_packages => 'Data::FormValidator', } ); }; ok( not $@ ); Data-FormValidator-4.88/t/02_code_ref.t0000755000175000017500000000237013150655017017754 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More tests => 8; use Data::FormValidator; my $input_profile = { required => [qw( email phone likes )], optional => [qq( toppings )], constraints => { email => "email", phone => "phone", likes => { constraint => sub { return 1; }, params => [qw( likes email )], }, }, dependencies => { animal => [qw( species no_legs )], plant => { tree => [qw( trunk root )], flower => [qw( petals stem )], }, }, field_filters => { email => sub { return $_[0]; }, }, }; my $validator = new Data::FormValidator( { default => $input_profile } ); my $input_hashref = { email => 'invalidemail', phone => '201-999-9999', likes => [ 'a', 'b' ], toppings => 'foo', animal => 'goat', plant => 'flower' }; my ( $valids, $missings, $invalids, $unknowns ); eval { ( $valids, $missings, $invalids, $unknowns ) = $validator->validate( $input_hashref, 'default' ); }; is $@, '', 'survives'; ok( exists $valids->{'phone'}, "phone is valid" ); is( $invalids->[0], 'email', 'email is invalid' ); my %missings; @missings{@$missings} = (); ok( exists $missings{$_} ) for (qw(species no_legs petals stem)); is( @$missings, 4 ); Data-FormValidator-4.88/t/15_literal_param_constraints.t0000755000175000017500000000157513150655017023463 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use lib ( '.', '../t' ); use Test::More tests => 1; use Data::FormValidator; my $input_profile = { required => ['my_zipcode_field'], constraints => { my_zipcode_field => { constraint => \&starts_with_402, params => [ 'my_zipcode_field', \'cow' ], }, }, untaint_all_constraints => 1, }; my $validator = new Data::FormValidator( { default => $input_profile } ); my $input_hashref = { my_zipcode_field => 'big brown', }; sub starts_with_402 { my ( $zip, $cow ) = @_; return "$zip $$cow"; } my ( $valids, $missings, $invalids, $unknowns ); eval { ( $valids, $missings, $invalids, $unknowns ) = $validator->validate( $input_hashref, 'default' ); }; # Test to make sure that the constraint receives a literal value of an element passed by reference is( $valids->{my_zipcode_field}, 'big brown cow' ); Data-FormValidator-4.88/t/constraint_method.t0000755000175000017500000000262213150655017021431 0ustar dfarrelldfarrell use strict; use warnings; use Test::More qw/no_plan/; use Data::FormValidator; my $result = Data::FormValidator->check( { field => 'value' }, { required => 'field', constraints => { field => { constraint_method => sub { my $dfv = shift; my $name = $dfv->get_current_constraint_name; is( $name, 'test_name', "get_current_constraint_name works" ); }, name => 'test_name', } }, } ); { my $result = Data::FormValidator->check( { to_pass => 'value', to_fail => 'value', map_to_pass => 'value', map_to_fail => 'value', }, { required => [ qw/ to_pass to_fail map_to_pass map_to_fail / ], constraint_methods => { to_pass => qr/value/, to_fail => qr/wrong/, }, constraint_method_regexp_map => { qr/map_to_p.*/ => qr/value/, qr/map_to_f.*/ => qr/fail/, }, } ); ok( $result->invalid('to_fail'), "using qr with constraint_method fails as expected" ); ok( $result->valid('to_pass'), "using qr with constraint_method succeeds as expected" ); ok( $result->invalid('map_to_fail'), "using qr with constraint_method_regexp_map fails as expected" ); ok( $result->valid('map_to_pass'), "using qr with constraint_method_regexp_map succeeds as expected" ); } Data-FormValidator-4.88/t/constraint_method_zero.t0000755000175000017500000000511513150655017022470 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More 'no_plan'; use Data::FormValidator; # For RT#45177 { my $results = Data::FormValidator->check( { nine_is_ok => 9 }, { required => ['nine_is_ok'], constraint_methods => { 'nine_is_ok' => qr/^(9)$/ }, untaint_all_constraints => 1, } ); is( $results->valid('nine_is_ok'), 9, "nine should be valid for 9 with capturing parens (untainted)" ); } { my $results = Data::FormValidator->check( { nine_is_ok => 9 }, { required => ['nine_is_ok'], constraint_methods => { 'nine_is_ok' => qr/^9$/ }, untaint_all_constraints => 1, } ); is( $results->valid('nine_is_ok'), 9, "nine should be valid for 9 without capturing parens (untainted)" ); } { my $results = Data::FormValidator->check( { zero_is_ok => 0 }, { required => ['zero_is_ok'], constraint_methods => { 'zero_is_ok' => qr/^0$/ }, untaint_all_constraints => 1, } ); is( $results->valid('zero_is_ok'), 0, "zero should be valid without capturing parens (untainted)" ); } { my $results = Data::FormValidator->check( { zero_is_ok => 0 }, { required => ['zero_is_ok'], constraint_methods => { 'zero_is_ok' => qr/^(0)$/ }, untaint_all_constraints => 1, } ); is( $results->valid('zero_is_ok'), 0, "zero should be valid with capturing parens (untainted)" ); } { my $results = Data::FormValidator->check( { nine_is_ok => 9 }, { required => ['nine_is_ok'], constraint_methods => { 'nine_is_ok' => qr/^(9)$/ }, } ); is( $results->valid('nine_is_ok'), 9, "nine should be valid for 9 with capturing parens" ); } { my $results = Data::FormValidator->check( { nine_is_ok => 9 }, { required => ['nine_is_ok'], constraint_methods => { 'nine_is_ok' => qr/^9$/ }, } ); is( $results->valid('nine_is_ok'), 9, "nine should be valid for 9 without capturing parens" ); } { my $results = Data::FormValidator->check( { zero_is_ok => 0 }, { required => ['zero_is_ok'], constraint_methods => { 'zero_is_ok' => qr/^0$/ }, } ); is( $results->valid('zero_is_ok'), 0, "zero should be valid without capturing parens" ); } { my $results = Data::FormValidator->check( { zero_is_ok => 0 }, { required => ['zero_is_ok'], constraint_methods => { 'zero_is_ok' => qr/^(0)$/ }, } ); is( $results->valid('zero_is_ok'), 0, "zero should be valid with capturing parens" ); } Data-FormValidator-4.88/t/dates.t0000755000175000017500000000553513150655017017013 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More; eval { require Date::Calc; }; if ($@) { plan skip_all => 'Date::Calc required for date testing'; } else { plan 'no_plan'; } require Data::FormValidator::Constraints::Dates; use strict; my $format = Data::FormValidator::Constraints::Dates::_prepare_date_format( 'MM/DD/YYYY hh?:mm:ss pp'); my ( $date, $year, $month, $day, $hour, $min, $sec ) = Data::FormValidator::Constraints::Dates::_parse_date_format( $format, '12/02/2003 1:01:03 PM' ); ok( $date eq '12/02/2003 1:01:03 PM', 'returning untainted date' ); ok( $year == 2003, 'basic date prepare and parse test' ); ok( $month == 12 ); ok( $day == 2 ); ok( $hour == 13 ); ok( $min == 1 ); ok( $sec == 3 ); # Now try again, leaving out PM, which may trigger a warning when it shouldn't $format = Data::FormValidator::Constraints::Dates::_prepare_date_format( 'MM/DD/YYYY hh?:mm:ss'); ( $date, $year, $month, $day, $hour, $min, $sec ) = Data::FormValidator::Constraints::Dates::_parse_date_format( $format, '12/02/2003 1:01:03' ); is( $date, '12/02/2003 1:01:03', 'returning untainted date' ); ok( $year == 2003, 'basic date prepare and parse test' ); ok( $month == 12, 'month' ); ok( $day == 2, 'day' ); ok( $hour == 1, 'hour' ); ok( $min == 1, 'min' ); ok( $sec == 3, 'sec' ); use Data::FormValidator; my $simple_profile = { required => [qw/date_and_time_field_bad date_and_time_field_good/], validator_packages => [qw/Data::FormValidator::Constraints::Dates/], constraints => { 'date_and_time_field_good' => { constraint_method => 'date_and_time', params => [ \'MM/DD/YYYY hh:mm pp' ], }, 'date_and_time_field_bad' => { constraint_method => 'date_and_time', params => [ \'MM/DD/YYYY hh:mm pp' ], }, }, untaint_constraint_fields => [qw/date_and_time_field/], }; my $simple_data = { date_and_time_field_good => '12/04/2003 02:00 PM', date_and_time_field_bad => 'slug', }; my $validator = new Data::FormValidator( { simple => $simple_profile, } ); my ( $valids, $missings, $invalids, $unknowns ) = ( {}, [], {}, [] ); eval { ( $valids, $missings, $invalids, $unknowns ) = $validator->validate( $simple_data, 'simple' ); }; ok( ( not $@ ), 'eval' ) or diag $@; ok( $valids->{date_and_time_field_good}, 'expecting date_and_time success' ); ok( ( grep /date_and_time_field_bad/, @$invalids ), 'expecting date_and_time failure' ); { my $format = Data::FormValidator::Constraints::Dates::_prepare_date_format('MMDDYYYY'); my ( $date, $year, $month, $day, $hour, $min, $sec ) = Data::FormValidator::Constraints::Dates::_parse_date_format( $format, '12022003' ); ok( $date eq '12022003', 'returning date' ); ok( $year == 2003, 'basic date prepare and parse test' ); ok( $month == 12 ); ok( $day == 2 ); } Data-FormValidator-4.88/t/get_filtered_data.t0000755000175000017500000000273113150655017021334 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More tests => 4; use Data::FormValidator; use Data::FormValidator::Constraints qw(FV_eq_with); # Empty data/empty results; make sure fcn call works fine access_filtered_data_no_data: { my $results = Data::FormValidator->check( {}, {} ); my $filtered = $results->get_filtered_data(); is_deeply( $filtered, {}, 'get_filtered_data works for empty hashref' ); } # Test to make sure that we can access filtered data and that it looks right. access_filtered_data: { my $data = { 'password' => ' foo ', 'confirm' => ' foo ', }; my $expect_filtered_data = { 'password' => 'foo', 'confirm' => 'foo', }; my $profile = { 'required' => [qw( password confirm )], 'filters' => 'trim', }; my $results = Data::FormValidator->check( $data, $profile ); my $filtered = $results->get_filtered_data(); is_deeply( $filtered, $expect_filtered_data, 'get_filtered_data returns correct filtered data' ); } # RT#22589; FV_eq_with uses 'get_filtered_data()' rt22589: { my $data = { 'password' => ' foo ', 'confirm' => ' foo ', }; my $profile = { 'required' => [qw( password confirm )], 'filters' => 'trim', 'constraint_methods' => { 'confirm' => FV_eq_with('password'), }, }; my $results = Data::FormValidator->check( $data, $profile ); ok( $results->valid('password'), 'password valid' ); ok( $results->valid('confirm'), 'confirm valid' ); } Data-FormValidator-4.88/t/credit_card.t0000755000175000017500000000515613150655017020155 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More tests => 25; use Data::FormValidator; use Data::FormValidator::Constraints qw(:closures); # check credit card number validation (the cc_number constraint). # note: this constraint is checked directly in 11_procedural_match.t and # procedural_valid.t, but here we will test it indirectly through a profile my $dfv_profile_old = { required => [qw(credit_card_type credit_card_number)], constraints => { credit_card_number => { constraint => 'cc_number', params => [qw(credit_card_number credit_card_type)], }, }, }; # numbers from # http://www.verisign.com/support/payflow/manager/selfHelp/testCardNum.html # maps type => [ [ invalids ... ], [ valids ... ] ] my %cc_numbers = ( Visa => [ [ '4000111122223333', ], [ '4111111111111111', '4012888888881881', ] ], Mastercard => [ [ '5424111122223333', ], [ '5105105105105100', '5555555555554444', ] ], Discover => [ [ '6000111122223333', ], [ '6011111111111117', '6011000990139424', ] ], Amex => [ [ '371500001111222', ], [ '378282246310005', '371449635398431', ] ], ); while ( my ( $card_type, $numbers ) = each %cc_numbers ) { foreach my $is_valid ( 0 .. 1 ) { foreach my $n ( @{ $numbers->[$is_valid] } ) { my $msg = ( $is_valid ? "Valid" : "Invalid" ) . ": $card_type/$n"; my $input = { credit_card_type => $card_type, credit_card_number => $n, }; is( validate_q( $input, $dfv_profile_old ), $is_valid, "$msg (old)" ); } } } my $dfv_profile_new = eval { { required => [qw(credit_card_type credit_card_number)], constraint_methods => { credit_card_number => cc_number( { fields => ['credit_card_type'] } ), }, }; }; ok( !$@, "cc_number subroutine runs without error" ); # broken cc_number subroutine in older dfv SKIP: { skip "(Older DFV has broken cc_number subroutine)", 12 if $@; while ( my ( $card_type, $numbers ) = each %cc_numbers ) { foreach my $is_valid ( 0 .. 1 ) { foreach my $n ( @{ $numbers->[$is_valid] } ) { my $msg = ( $is_valid ? "Valid" : "Invalid" ) . ": $card_type/$n"; my $input = { credit_card_type => $card_type, credit_card_number => $n, }; is( validate_q( $input, $dfv_profile_new ), $is_valid, "$msg (new)" ); } } } } ## sub validate_q { my ( $data, $profile ) = @_; my $dfv_result = eval { Data::FormValidator->check( $data, $profile ); }; if ($@) { diag "Failed check [$@]"; return; } return ( $dfv_result->has_invalid || $dfv_result->has_missing ) ? 0 : 1; } Data-FormValidator-4.88/t/regexp_common.t0000755000175000017500000000361213150655017020547 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More tests => 10; use Data::FormValidator; # Integration with Regexp::Common; my %FORM = ( bad_ip => '127 0 0 1', good_ip => '127.0.0.1', embedded_ip => 'The address is 127.0.0.1 or something close to that', ); my $results; eval { $results = Data::FormValidator->check( \%FORM, { required => [qw/good_ip bad_ip/], constraint_regexp_map => { qr/_ip$/ => 'RE_net_IPv4', } } ); }; ok( ( not $@ ), 'runtime errors' ) or diag $@; ok( $results->valid->{good_ip}, 'good ip' ); ok( $results->invalid->{bad_ip}, 'bad ip' ); $results = Data::FormValidator->check( \%FORM, { untaint_all_constraints => 1, required => [qw/good_ip bad_ip/], constraint_regexp_map => { qr/_ip$/ => 'RE_net_IPv4', } } ); ok( ( not $@ ), 'runtime errors' ) or diag $@; ok( $results->valid->{good_ip}, 'good ip with tainting' ); ok( $results->invalid->{bad_ip}, 'bad ip with tainting' ); # Test passing flags $results = Data::FormValidator->check( \%FORM, { required => [qw/good_ip bad_ip/], constraint_regexp_map => { qr/_ip$/ => { constraint => 'RE_net_IPv4_dec', params => [ \'-sep' => \' ' ], } } } ); ok( ( not $@ ), 'runtime errors' ) or diag $@; # Here we are trying passing a parameter which should reverse # the notion of which one expect to succeed. ok( $results->valid->{bad_ip}, 'expecting success with params' ); ok( $results->invalid->{good_ip}, 'expecting failure with params' ); # Testing end-to-end matching $results = Data::FormValidator->check( \%FORM, { required => [qw/embedded_ip/], constraint_regexp_map => { qr/_ip$/ => 'RE_net_IPv4', } } ); my $invalid = scalar $results->invalid || {}; ok( $invalid->{embedded_ip}, 'testing that the RE must match from end-to-end' ); Data-FormValidator-4.88/t/constraints_builtin_closure.t0000755000175000017500000000300713150655017023534 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More; use Data::FormValidator; use Data::FormValidator::Constraints qw(:closures); my $input_profile = { required => [qw( number_field nan nan_typo )], optional => [qw( nan_name_this )], constraint_methods => { number_field => sub { my ( $self, $v ) = @_; #$self->set_current_constraint_name('number'); return ( $v =~ m/^\d+$/ ); }, nan => sub { my ( $self, $v ) = @_; $self->name_this('number'); return ( $v =~ m/^\d+$/ ); }, nan_typo => sub { my ( $self, $v ) = @_; $self->name_this('numer'); return ( $v =~ m/^\d+$/ ); }, nan_name_this => sub { my ( $d, $v ) = @_; $d->name_this('number'); return ( $v =~ m/^\d+$/ ); }, }, msgs => { constraints => { number => 'Must be a digit', } } }; my $input_hashref = { number_field => 0, nan => 'infinity', nan_name_this => 'infinity', }; my $results; eval { $results = Data::FormValidator->check( $input_hashref, $input_profile ); }; is( $@, '', 'survived eval' ); is( $results->valid()->{number_field}, 0, 'using 0 in a constraint regexp works' ); my $msgs = $results->msgs(); like( $msgs->{nan}, qr/Must be a digit/, 'set_current_contraint_name succeeds' ); like( $msgs->{nan_name_this}, qr/Must be a digit/, 'name_this succeeds' ); unlike( $msgs->{nan_typo}, qr/Must be a digit/, 'set_current_contraint_name doesn\'t work if you typo it' ); done_testing(); Data-FormValidator-4.88/t/params_not_mentioned.t0000755000175000017500000000216413150655017022113 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More; use Data::FormValidator; eval { require CGI;CGI->VERSION(4.35); }; plan skip_all => 'CGI 4.35 or higher not found' if $@; # Test that constrants can refer to fields that are not mentioned # in 'required' or 'optional' my $profile = { required => [qw(foo)], optional => [qw(bar)], constraints => { foo => { constraint => sub { if ( defined $_[0] && defined $_[1] ) { return $_[0] eq $_[1]; } else { return; } }, params => [qw(foo baz)], }, }, }; my $input = { foo => 'stuff', bar => 'other stuff', baz => 'stuff', }; my $results = Data::FormValidator->check( $input, $profile ); ok( !$results->has_invalid(), 'no_invalids' ); ok( $results->valid('foo'), 'foo valid' ); { # with CGI object as input. my $q = CGI->new($input); my $results; eval { $results = Data::FormValidator->check( $q, $profile ); }; is( $@, '', 'survived eval' ); ok( !$results->has_invalid(), 'no_invalids' ); ok( $results->valid('foo'), 'foo valid' ); } done_testing; Data-FormValidator-4.88/t/constraints_num_values.t0000755000175000017500000000210213150655017022503 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More; use Data::FormValidator; use Data::FormValidator::Constraints qw(:closures); # Test FV_num_values and FV_num_values_between my $results = Data::FormValidator->check( { num_values_pass => [qw(a b)], num_values_fail => [qw(a b)], num_values_between_pass => [qw(a)], num_values_between_fail => [qw(a b)], }, { optional_regexp => qr/.*/, constraint_methods => { num_values_pass => FV_num_values(2), num_values_fail => FV_num_values(1), num_values_between_pass => FV_num_values_between( 1, 2 ), num_values_between_fail => FV_num_values_between( 3, 4 ), } } ); my $valid = $results->valid; ok( $valid->{num_values_pass}, 'FV_num_values pass' ); ok( $valid->{num_values_between_pass}, 'FV_num_values_between pass' ); my $invalid = $results->invalid; ok( $invalid->{num_values_fail}, 'FV_num_values fail - one value requested, two found' ); ok( $invalid->{num_values_between_fail}, 'FV_num_values_between fail' ); done_testing(); Data-FormValidator-4.88/t/upload_post_text.txt0000755000175000017500000000607213150655017021661 0ustar dfarrelldfarrell--xYzZY Content-Disposition: form-data; name="hello_world"; filename="hello_world.txt" Content-Length: 13 Content-Type: text/plain Hello World! --xYzZY Content-Disposition: form-data; name="does_not_exist_gif"; filename="does_not_exist.gif" Content-Type: application/octet-stream --xYzZY Content-Disposition: form-data; name="100x100_gif"; filename="100x100.gif" Content-Length: 896 Content-Type: image/gif GIF89add@@@000pppPPP ```!,dd#dihlBp,tmxP_1l2ΨZ*v+rI/xL|G1z}SY3|ns;:'`\XV]rx{~F4<p514;<10417a;  3 5 M41 5 ǀMsmG -&0_gj°݆T) 0#V/PeA0p{0 *&F>CuS@C U]= ~vDa\"zV#BT!"j1$c1u} @\i,X$h5pK IN5'"X-  f PBfV֋ʀ#_,+ze5 XN 4@55%Whܠøș0.M,d#(@YYeԘ r*$ՊQzW*JEкZ; ۇzF+!; --xYzZY Content-Disposition: form-data; name="300x300_gif"; filename="300x300.gif" Content-Length: 1656 Content-Type: image/gif GIF89a,,@@@000pppPPP ߏ```!,,,#dihlp,tm|pH,Ȥrl:Ч(JZجv5NxL.zn|N~~iTA|nbVJ@¦Ɲʔ΍҆xqjg:X} oALP ÆB'qan#Gu? )RɒNԦr.l&Me6o˩SϞ~%t(F!Mk)S`H.*!ժbuŮ^5 q,YfώL$۶)e)w˺ve[s/_~ ,'A#&xQh!s*ZP12gl? -ZyNzҮ3v_f&{w$ݾa㿆#|9 5:A֯ʮ]. LΣ}=ۨ>}M/|?q2_? H`Cz(1%18< A7 DPȃ;0@ bsA=@> $`@|uQ *0#ZB@@ c;Z9O=B<@ ! #4X(YOc* %jS@'d=\ <YAPv 3ZʟzahB"k#K,:`j.ҚdaH0fКlZ#l(  fV I`<,fh&m `'=4@j;nLjDۙ—8@CrR^˃ 90,x"B(I";c[@Lu6Ptx{wwkuSWHnur3x<P8|rws5l^: ,:=Pɣ h <,&{oJo |:*& s 0@3{ y ޢj-c ,ݯ 7Mq@46M]3T5,MEt3L13ʔP2'L Ŵ1/,L 3ÿԐ/7Kù.?lK2ij,G KDVRx"DT*WJEIqKbRh2Ōx"ƞQ'oI5a1K>ď!")B~ĐAdFٿ: H$G a $+iI\p2$("QAT9=SƕXI>YzUlyK^?_r$>):cҁC#Y)gǚ栤)Hjv)pQ@gYYvA܉zӞfg~Ӝ`ԧ ĠE(srІ:D'J; --xYzZY-- Data-FormValidator-4.88/t/25_results.t0000755000175000017500000000221413150655017017711 0ustar dfarrelldfarrell#!/usr/bin/env perl use strict; use warnings; use Test::More tests => 7; use Data::FormValidator; my %FORM = ( stick => 'big', speak => 'softly', mv => [ 'first', 'second' ], ); my $results = Data::FormValidator->check( \%FORM, { required => [ 'stick', 'fromsub', 'whoami' ], optional => [ 'mv', 'opt_1', 'opt_2', ], defaults => { fromsub => sub { return "got value from a subroutine"; }, }, defaults_regexp_map => { qr/^opt_/ => 2, }, } ); ok( $results->valid('stick') eq 'big', 'using check() as class method' ); is( $results->valid('stick'), $FORM{stick}, 'valid() returns single value in scalar context' ); my @mv = $results->valid('mv'); is_deeply( \@mv, $FORM{mv}, 'valid() returns multi-valued results' ); my @stick = $results->valid('stick'); is_deeply( \@stick, [ $FORM{stick} ], 'valid() returns single value in list context' ); ok( $results->valid('fromsub') eq "got value from a subroutine", 'usg CODE references as default values' ); { is( $results->valid('opt_1'), 2, "defaults_regexp works (case 1)" ); is( $results->valid('opt_2'), 2, "defaults_regexp works (case 1)" ); }