—
—
—
—
—
—
—
—
—
—

              
#
#    Results.pm - Object which contains validation result.
#
#    This file is part of FormValidator.
#
#    Author: Francis J. Lacoste <francis.lacoste@iNsu.COM>
#    Maintainer: Mark Stosberg <mark@summersault.com>
#
#    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.
#
#  $Header$
use strict;
package Data::FormValidator::Results;
use Data::FormValidator::Filters qw/:filters/;
use Data::FormValidator::Constraints (qw/:validators :matchers/);
use vars qw/$AUTOLOAD $VERSION/;
use Symbol;
$VERSION = 3.13;
HideShow 43 lines of Pod
=pod
=head1 NAME
Data::FormValidator::Results - Object which contains the results of an input validation.
=head1 SYNOPSIS
        my $results = Data::FormValidator->check(\%input_hash, \%dfv_profile);
    # Print the name of missing fields
    if ( $results->has_missing ) {
        foreach my $f ( $results->missing ) {
            print $f, " is missing\n";
        }
    }
    # Print the name of invalid fields
    if ( $results->has_invalid ) {
        foreach my $f ( $results->invalid ) {
            print $f, " is invalid: ", $results->invalid( $f ) \n";
        }
    }
    # Print unknown fields
    if ( $results->has_unknown ) {
        foreach my $f ( $results->unknown ) {
            print $f, " is unknown\n";
        }
    }
    # Print valid fields
    foreach my $f ( $results->valid() ) {
        print $f, " =  ", $result->valid( $f ), "\n";
    }
=head1 DESCRIPTION
This is the object returned by the Data::FormValidator check 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_data($data);
    my %valid       = %data;
    my @missings    = ();
    my @invalid     = ();
    my @unknown     = ();
        # msgs() method will need access to the profile
        $self->{profile} = $profile;
        my %imported_validators;
    # import valid_* subs from requested packages
        foreach my $package (_arrayify($profile->{validator_packages})) {
                if ( !exists $imported_validators{$package} ) {
                        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_)/, keys(%{*{$package_ref}}));
                        foreach 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 inconditional filters
    foreach my $filter (_arrayify($profile->{filters})) {
                if (defined $filter) {
                        # Qualify symbolic references
                        $filter = (ref $filter ? $filter : *{qualify_to_ref("filter_$filter")}{CODE}) ||
                                die "No filter found named: '$filter'";
                        foreach 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} }) {
                foreach my $filter ( _arrayify($filters)) {
                        if (defined $filter) {
                                # Qualify symbolic references
                                $filter = (ref $filter ? $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);
                foreach my $filter ( _arrayify($filters)) {
                        if (defined $filter) {
                                # Qualify symbolic references
                                $filter = (ref $filter ? $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);
                                }
                        }       
                }
        }
  
    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});
    foreach 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"
        my %require_some;
        while ( my ( $field, $deps) = each %{$profile->{require_some}} ) {
        foreach my $dep (_arrayify($deps)){
             $require_some{$dep} = 1;
        }
    }
         
        # Remove all empty fields
        foreach 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]);
                                }
                        }
                }
                else {
                        delete $valid{$field} unless (defined $valid{$field} and length $valid{$field});
                }
        }
    # Check if the presence of some fields makes other optional fields required.
    while ( my ( $field, $deps) = each %{$profile->{dependencies}} ) {
        if ($valid{$field}) {
                        if (ref($deps) eq 'HASH') {
                                foreach my $key (keys %$deps) {
                                        if($valid{$field} eq $key){
                                                foreach my $dep (_arrayify($deps->{$key})){
                                                        $required{$dep} = 1;
                                                }
                                        }
                                }
                        }
            else {
                foreach my $dep (_arrayify($deps)){
                    $required{$dep} = 1;
                }
            }
        }
    }
    # check dependency groups
    # the presence of any member makes them all required
    foreach my $group (values %{ $profile->{dependency_groups} }) {
       my $require_all = 0;
       foreach my $field (_arrayify($group)) {
                        $require_all = 1 if $valid{$field};
       }
       if ($require_all) {
                        map { $required{$_} = 1 } _arrayify($group); 
       }
    }
    # Find unknown
    @unknown =
      grep { not (exists $optional{$_} or exists $required{$_} or exists $require_some{$_} ) } keys %valid;
    # and remove them from the list
        foreach my $field ( @unknown ) {
                delete $valid{$field};
        }
    # Fill defaults
        while ( my ($field,$value) = each %{$profile->{defaults}} ) {
                $valid{$field} = $value unless exists $valid{$field};
        }
    # Check for required fields
    foreach 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;
                foreach 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 map 
        foreach my $re (keys %{ $profile->{constraint_regexp_map} }) {
                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->{constraints}{$key};
                                        my $new = $profile->{constraint_regexp_map}{$re};
                                        # If they already have an arrayref of constraints, add to the list
                                        if (ref $cur eq 'ARRAY') {
                                                push @{ $profile->{constraints}{$key} }, $new;
                                        } 
                                        # If they have a single constraint defined, create an array ref with with this plus the new one
                                        elsif ($cur) {
                                                $profile->{constraints}{$key} = [$cur,$new];
                                        }
                                        # otherwise, a new constraint is created with this as the single constraint
                                        else {
                                                $profile->{constraints}{$key} = $new;
                                        }
                                        warn "constraint_regexp_map: $key matches\n" if $profile->{debug};
                                                 
                                }
                        }
        }
  
    # Check constraints
    #Decide which fields to untaint
    my ($untaint_all, %untaint_hash);
        if (defined($profile->{untaint_constraint_fields})) {
                if (ref $profile->{untaint_constraint_fields} eq "ARRAY") {
                        foreach my $field (@{$profile->{untaint_constraint_fields}}) {
                                $untaint_hash{$field} = 1;
                        }
                }
                elsif ($valid{$profile->{untaint_constraint_fields}}) {
                        $untaint_hash{$profile->{untaint_constraint_fields}} = 1;
                }
        }
    elsif ((defined($profile->{untaint_all_constraints}))
           && ($profile->{untaint_all_constraints} == 1)) {
           $untaint_all = 1;
    }
     
    while ( my ($field,$constraint_list) = each %{$profile->{constraints}} ) {
       next unless exists $valid{$field};
           my $is_constraint_list = 1 if (ref $constraint_list eq 'ARRAY');
           my $untaint_this =  ($untaint_all || $untaint_hash{$field} || 0);
           my @invalid_list;
           foreach my $constraint_spec (_arrayify($constraint_list)) {
                         # set current constraint field for use by get_current_constraint_field
                         $self->{__CURRENT_CONSTRAINT_FIELD} = $field;
                         
                         my $c = $self->_constraint_hash_build($field,$constraint_spec,$untaint_this);
                         my $is_value_list = 1 if (ref $valid{$field} eq 'ARRAY');
                         if ($is_value_list) {
                                 foreach (my $i = 0; $i < scalar @{ $valid{$field}} ; $i++) {
                                         my @params = $self->_constraint_input_build($c,$valid{$field}->[$i],\%valid);
                                         # set current constraint field for use by get_current_constraint_value
                                         $self->{__CURRENT_CONSTRAINT_VALUE} = $valid{$field}->[$i];
                                         my ($match,$failed) = _constraint_check_match($c,\@params);
                                         if ($failed) {
                                                push @invalid_list, $failed;
                                         }
                                         else {
                                                 $valid{$field}->[$i] = $match if $untaint_this;
                                         }
                                 }
                         }
                         else {
                                my @params = $self->_constraint_input_build($c,$valid{$field},\%valid);
                                # set current constraint field for use by get_current_constraint_value
                                $self->{__CURRENT_CONSTRAINT_VALUE} = $valid{$field};
                                my ($match,$failed) = _constraint_check_match($c,\@params);
                                if ($failed) {
                                        push @invalid_list, $failed
                                }
                                else {
                                        $valid{$field} = $match if $untaint_this;
                                }
                         }
           }
           if (@invalid_list) {
                   if ($is_constraint_list) {
                           my @failed = map { $_->{name} } @invalid_list;
                                push @invalid, [$field, @failed];
                                push @{ $self->{invalid}->{$field} }, @failed;
                   }
                   else {
                           push @invalid, $field;
                                push @{ $self->{invalid}->{$field} }, $invalid_list[0]->{name} ;
                   }
                   delete $valid{$field};
           }
   }
    # add back in missing optional fields from the data hash if we need to
        foreach my $field ( keys %data ) {
                if ($profile->{missing_optional_valid} and $optional{$field} and (not exists $valid{$field})) {
                        $valid{$field} = undef;
                }
        }
        my ($missing,$invalid);
        $self->{valid} ||= {};
    $self->{valid}   =  { %valid , %{$self->{valid}} };
        # the older interface to validate returned things differently
    $self->{validate_invalid}        = \@invalid || [];
    $self->{missing} = { map { $_ => 1 } @missings };
    $self->{unknown} = { map { $_ => 1 } @unknown };
}
HideShow 21 lines of Pod
=pod
=head1  valid( [field], [value] );
This method returns in an array context the list of fields which
contains valid value. In a scalar context, it returns an hash reference
which contains the valid fields and their value.
If called with one argument, it returns the value of that field if it
contains valid data, undef otherwise.
If called with two arguments, the first is taken as a field in the valid
hash, and this field is set to the value of the second argument. The
value is returned.
This can be useful in some cases to call from within a constraint
to alter the results of the valid hash.
=cut
sub valid {
        my $self = shift;
        my $key = shift;
        my $val = shift;
        $self->{valid}{$key} = $val if defined $val;
        return $self->{valid}{$key} if defined $key;
        wantarray ? keys %{ $self->{valid} } : $self->{valid};
}
HideShow 8 lines of Pod
=pod
=head1 has_missing()
This method returns true if the results contains missing fields.
=cut
sub has_missing {
    return scalar keys %{$_[0]{missing}};
}
HideShow 13 lines of Pod
=pod
=head1 missing( [field] )
This method returns in an array context 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 field is missing,
undef otherwise.
=cut
sub missing {
    return $_[0]{missing}{$_[1]} if (defined $_[1]);
    wantarray ? keys %{$_[0]{missing}} : [ keys %{$_[0]{missing}} ];
}
HideShow 9 lines of Pod
=pod
=head1 has_invalid()
This method returns true if the results contains fields with invalid
data.
=cut
sub has_invalid {
    return scalar keys %{$_[0]{invalid}};
}
HideShow 15 lines of Pod
=pod
=head1 invalid( [field] )
This method returns in an array context 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 this field.
=cut
sub invalid {
        my $self = shift;
        my $field = shift;
    return $self->{invalid}{$field} if defined $field;
    wantarray ? keys %{$self->{invalid}} : $self->{invalid};
}
HideShow 8 lines of Pod
=pod
=head1 has_unknown()
This method returns true if the results contains unknown fields.
=cut
sub has_unknown {
    return scalar keys %{$_[0]{unknown}};
}
HideShow 13 lines of Pod
=pod
=head1 unknown( [field] )
This method returns in an array context the list of fields which
are unknown. In a scalar context, it returns an hash reference
which contains the unknown fields and their value.
If called with an argument, it returns the value of that field if it
is unknown, undef otherwise.
=cut
sub unknown {
    return $_[0]{unknown}{$_[1]} if (defined $_[1]);
    wantarray ? keys %{$_[0]{unknown}} : $_[0]{unknown};
}
HideShow 20 lines of Pod
=pod
=head1 msgs([config parameters])
This method returns a hash reference to error messages. The exact format
is determined by parameters in th C<msgs> area of the validation profile,
described in the L<Data::FormValidator> documentation.
This method takes one possible parameter, a hash reference containing the same 
options that you can define in the validation profile. This allows you to seperate
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 <msgs> method will be applied first, followed by ones
applied in the profile. This allows you to keep the controls you pass to
C<msgs> as "global" and override them in a specific profile if needed. 
=cut
sub 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 };
        my %profile = (
                prefix  => '',
                missing => 'Missing',
                invalid => 'Invalid',
                invalid_seperator => ' ',
                format  => '<span style="color:red;font-weight:bold"><span id="dfv_errors">* %s</span></span>',
                %{ $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_seperator}, 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);
        $msgs_ref->{ $profile{any_errors} } = 1 if defined $profile{any_errors};
        return $msgs_ref;
}
# 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;
        return $self->{__INPUT_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};
}
# INPUT: prefix_string, hash reference
# Copies the hash and prefixes all keys with prefix_string
# OUTPUT: hash refence
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 learning 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;
        # This looks like VooDoo to me, but it works. Simplications welcome. -mls 05/26/03 
        my $return_code = ($untaint_this) ? '; return ($& =~ m/(.*)/s)[0] if defined($`);' : '';
        my $sub;
        # If it's "qr" style
        if (substr($re,0,1) eq '(') {
                $sub = sub { 
                        my $match = $_[0] =~ $re; 
                        if ($untaint_this && defined $-[0]) {
                                return (substr($_[0], $-[0], $+[0] - $-[0]) =~ m/(.*)/s)[0];
                        }
                        else {
                                return $match;
                        }
                };
        }
        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 ||= 
                        '<span style="color:red;font-weight:bold"><span id="vrm_errors">* %s</span></span>';
        ($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 ( ref $val eq 'ARRAY' ) {
                # if it's a reference, return an array unless it points an empty array. -mls
                return (length $val->[0]) ? @$val : ();
   } 
   else {
                # if it's a string, return an array unless the string is missing or empty. -mls
                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};
        }
}
sub _constraint_hash_build {
        my ($self,$field,$constraint_spec,$untaint_this) = @_;
        die "_constraint_apply received wrong number of arguments" unless (scalar @_ == 4);
        my      $c = {
                        name            => $constraint_spec,
                        constraint  => $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);
        }
        # 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
                $c->{name} ||= $c->{constraint};
                # Save the current constraint name for later
                $self->{__CURRENT_CONSTRAINT_NAME} = $c->{name};
                 
                #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_/) {
                                $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}) {
                                $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_/) {
                                $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}'";
                        }
                }
        }
        return $c;
}
sub _constraint_input_build {
        my ($self,$c,$value,$valid) = @_;
        die "_constraint_input_build received wrong number of arguments" unless (scalar @_ == 4);
        my @params;
        if (defined $c->{params}) {
                foreach my $fname (_arrayify($c->{params})) {
                        # If the value is passed by reference, we treat it literally
                        push @params, (ref $fname) ? $fname : $valid->{$fname}
                }
        }
        else {
                push @params, $value;
        }
        unshift @params, $self if $c->{is_method};
        return @params;
}
sub _constraint_check_match {
        my      ($c,$params) = @_;
        die "_constraint_check_match received wrong number of arguments" unless (scalar @_ == 2);
        if (my $match = $c->{constraint}->( @$params )) { 
                return $match;
        }
        else {
                return 
                undef,  
                {
                        failed  => 1,
                        name    => $c->{name},
                };
        }
}
# Figure out whether the data is a hash reference of a CGI or Apache::Request object and return it has a hash
sub _get_data {
        my ($self,$data) = @_;
        $self->{__INPUT_DATA} = $data;
        require UNIVERSAL;
        if (UNIVERSAL::isa($data,'CGI') || UNIVERSAL::isa($data,'Apache::Request') ) {
                my %return;
                # make sure object supports param()
                defined($data->UNIVERSAL::can('param')) or
                croak("Data::FormValidator->validate called with CGI or Apache::Request object which lacks a param() method!");
                foreach my $k ($data->param()){
                        # we expect param to return an array if there are multiple values
                        my @v = $data->param($k);
                        $return{$k} = scalar(@v)>1 ? \@v : $v[0];
                }
                return %return;
        }
        # otherwise, it's already a hash reference
        else {
                return %$data;  
        }
}
sub _create_regexp_common_constraint  {
        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; 
}
1;
__END__
HideShow 22 lines of Pod
=pod
=head1 SEE ALSO
Data::FormValidator, Data::FormValidator::Filters,
Data::FormValidator::Constraints, Data::FormValidator::ConstraintsFactory
=head1 AUTHOR
Author: Francis J. Lacoste <francis.lacoste@iNsu.COM>
Maintainer: Mark Stosberg <mark@summersault.com> 
=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