File Coverage

blib/lib/CGI/Validate.pm

Criterion	Covered	Total	%
statement	45	95	47.3
branch	10	48	20.8
condition	3	17	17.6
subroutine	7	13	53.8
pod	0	8	0.0
total	65	181	35.9

package CGI::Validate;

=head1 NAME

CGI::Validate - Advanced CGI form parser and type validation

=head1 SYNOPSIS

  use CGI::Validate;                # GetFormData() only
  use CGI::Validate qw(:standard);  # Normal use
  use CGI::Validate qw(:subs);      # Just functions
  use CGI::Validate qw(:vars);      # Just exception vars

  ## If you don't want it to check that every requested
  ## element arrived you can use this.  But I don't recommend it
  ## for most users.
  $CGI::Validate::Complete = 0;

  ## If you don't care that some fields in the form don't
  ## actually match what you asked for. -I don't recommend
  ## this unless you REALLY know what you're doing because this
  ## normally meens you've got typo's in your HTML and we can't
  ## catch them if you set this.
  ## $CGI::Validate::IgnoreNonMatchingFields = 1;

  my $FieldOne    = 'Default String';
  my $FieldTwo    = 8;
  my $FieldThree  = 'some default string';
  my @FieldFour   = ();  ## For multi-select field
  my @FieldFive   = ();  ## Ditto
  my $EmailAddress= '';

  ## Try...
  my $Query = GetFormData (
      'FieldOne=s'  => \$FieldOne,     ## Required string
      'FieldTwo=i'  => \$FieldTwo,     ## Required int
      'FieldThree'  => \$FieldThree,   ## Auto converted to the ":s" type
      'FieldFour=s' => \@FieldFour,    ## Multi-select field of strings
      'FieldFive=f' => \@FieldFive,    ## Multi-select field of floats
      'Email=e'     => \$EmailAddress, ## Must 'look' like an email address
  ) or do {
      ## Catch... (wouldn't you just love a case statement here?)
      if (%Missing) {
          die "Missing form elements: " . join (' ', keys %Missing);
      } elsif (%Invalid) {
          die "Invalid form elements: " . join (' ', keys %Invalid);
      } elsif (%Blank) {
          die "Blank form elements: " . join (' ', keys %Blank);
      } elsif (%InvalidType) {
          die "Invalid data types for fields: " . join (' ', keys %InvalidType);
      } else {
          die "GetFormData() exception: $CGI::Validate::Error";
      }
  };

  ## If you only want to check the form data, but don't want to
  ## have CGI::Validate set anything use this. -You still have full
  ## access to the data via the normal B object that is returned.

  use CGI::Validate qw(CheckFormData); # not exported by default
  my $Query = CheckFormData (
    'FieldOne=s',   'FieldTwo=i',   'FieldThree',   'FieldFour',
    'FieldFive',    'Email',
  ) or do {
      ... Same exceptions available as GetFormData above ...
  };

  ## Need some of your own validation code to be used?  Here is how you do it.
  addExtensions (
      myType   => sub { $_[0] =~ /test/ },
      fooBar   => \&fooBar,
      i_modify_the_actual_data => sub {
          if ($_[0] =~ /test/) {   ## data validation
              $_[0] = 'whatever';  ## modify the data by alias
              return 1;
          } else {
              return 0;
          }
     },
  );
  my $Query = GetFormData (
      'foo=xmyType'    => \$foo,
      'bar=xfooBar'    => \$bar,
      'cat=xi_modify_the_actual_data' => \$cat,
  );


  ## Builtin data type checks available are:
  s    string     # Any non-zero length value
  w    word       # Must have at least one \w char
  i    integer    # Integer value
  f    float      # Float value
  e    email      # Must match m/^\s*]+@[^@.<>]+(?:\.[^@.<>]+)+>?\s*$/
  x    extension  # User extension type.  See EXTENSIONS below.


=cut

BEGIN { require 5.004 }
use strict;
use vars qw(
	@EXPORT		@EXPORT_OK	%EXPORT_TAGS	$VERSION	@ISA
	$Complete	$IgnoreNonMatchingFields	$Error
	%Missing	%Invalid	%Blank			%InvalidType
);
require Exporter;
@ISA		= qw(Exporter);
@EXPORT		= qw(GetFormData);
@EXPORT_OK	= qw(%Missing %Invalid %Blank %InvalidType addExtensions GetFormData CheckFormData);
%EXPORT_TAGS = (
	standard	=> [ @EXPORT_OK ],
	all			=> [ @EXPORT_OK ], # depreciated
	vars		=> [ qw(%Missing %Invalid %Blank %InvalidType) ],
	subs		=> [ qw(addExtensions GetFormData CheckFormData) ],
);
$VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf '%d.%03d'.'%02d' x ($#r-1), @r};

use CGI 2.30;
use Carp;

## User settable globals
$Complete = 1;
$IgnoreNonMatchingFields = 0;

## Code settable globals
my %TYPES = (
	's'	=> [ 'string',	\&CheckString	],
	'w'	=> [ 'word',	\&CheckWord		],
	'i'	=> [ 'integer',	\&CheckInt		],
	'f' => [ 'float',	\&CheckFloat	],
	'e' => [ 'email',	\&CheckEmail	],
	'x'	=> [ 'extension',	sub { confess q(PANIC: Can't Happen[tm]: Sorry, but type 'x' is not supported in raw form.  See EXTENSIONS in perldoc ) . __FILE__ . '. ' } ],
);

sub addExtensions {
	my %exts	= @_
		or confess qq(usage: addExtentions ('name' => sub { validation code }));
	while (my ($ext, $sub) = each %exts) {
		ref $sub eq 'CODE'
			or confess qq($sub is not a CODE ref for extension type '$ext');
		$TYPES{"x$ext"} = [ "x$ext", $sub ];
	}
}

sub GetFormData {
	my %fields		= ();	## We load this latter from @_
	my %form		= ();	## Values from the form actually gave us

	## Damn CGI changed it's frigging interface... :-(
	my $query		= new CGI;
	%form			= %{ $query };

## Use this code below if the CGI object form gets changed.  Yes, we're breaking OO rules, so kill me I need the speed!
#	foreach my $name ($query->param) {
#		$form{$name} = [ $query->param ($name) ];
#	}

	%Missing		= ();	## We use these to do our $Complete testing
 	%Invalid		= ();	## Fields they didn't ask for
	%Blank			= ();	## Fields left blank, that have a required modifier
	%InvalidType	= ();	## Fields with data not matching there type defs

	## Program's validation spec part
	## Load %fields, and add :s type to fields that don't contain one
	for (my $arg=0; $arg <= $#_; $arg += 2) {
		## Split field in to name, if it's optional, and it's required type
		my ($field, $optional, $type) = ($_[$arg] =~ /^([^:=]+)([:=]?)(\w*)/);

		## Moron check...
		unless ($field) { $Error = qq(Invalid arg "$_[$arg]" given to GetFormData(): No field name???); return }

		## Optional argument, or required?  Default optional
		$optional = $optional eq '=' ? 0 : 1;

		$type ||= 's';  ## Default optional string

		$TYPES{$type}
			or ($Error = qq(Invalid type "$type" given for field "$field"), return);
		$type = $TYPES{$type};

		$fields{$field}{reference} = $_[ $arg + 1 ]
			or ($Error = qq(No place given to stick the value for "$field"), return);
		## Check for correct reference type
		(ref $fields{$field}{reference} eq 'SCALAR') || (ref $fields{$field}{reference} eq 'ARRAY')
			or ($Error = qq(Invalid reference type "@{[ ref ($fields{$field}{reference}) ]}" given for "$field".  Must be SCALAR or ARRAY), return);

		$fields{$field}{optional}	= $optional;
		$fields{$field}{type}		= $type;
	}

	## $Complete checking:
	if ($Complete) {
		foreach my $field (keys %fields) {
			## Make sure we have it
	 		unless (exists $form{$field}) {
				$Missing{$field} = qq(Missing required form element "$field");
	 		}
	 	}
	}

	## Form's data
	## Check all form fields for type et al...
	foreach my $field ($query->param) {
		## Did we get a bad field from the form?
		unless (exists $fields{$field}) {
			## Do we care?
			unless ($IgnoreNonMatchingFields) {
				# push @Invalid, "Non-matching field: $field";
				$Invalid{$field} = "Non-matching field: $field";
			}
			next;
		}

		# my @values = $query->param ($field);

		unless (scalar @{ $form{$field} } or $fields{$field}{optional}) {
			$Blank{$field} = qq(Required field "$field" contains no data);
			next;
		}

		## Type checking
		my $argNum = 0;
		foreach my $arg (@{ $form{$field} }) {
			$argNum++;

			## Hmm, is the field empty?
			if (length $arg > 0) {
				## Check the data to make sure it's the right type.
				## Since $arg is aliased from @values, the sub can modify the
				## actual data if it wants to (filter type check).
				unless ( $fields{$field}{type}[1]->($arg) ) {
					if (scalar @{ $form{$field} } > 1) {
						$InvalidType{$field} = qq(Invalid data type found for array field $field, indices $argNum ($fields{$field}{type}[0] expected, found "$arg"));
					} else {
						$InvalidType{$field} = qq(Invalid data type found for field $field ($fields{$field}{type}[0] expected, found "$arg"));
					}
				}
			} else {
				unless ($fields{$field}{optional}) {
					## Hmm, blank field in multi-select?  Odd if that's the case
					if (scalar @{ $form{$field} } > 1) {
						$Blank{$field} = qq(Required field "$field" contains no data in $argNum segment);
					} else {
						$Blank{$field} = qq(Required field "$field" contains no data);
					}
				}
			}
		}
		if (ref $fields{$field}{reference} eq 'ARRAY') {
			@{ $fields{$field}{reference} } = @{ $form{$field} };
		} else {
			${ $fields{$field}{reference} } = $form{$field}->[0];
		}
	}

	## Ok, did all that go well?
	if (%Missing or %Invalid or %Blank or %InvalidType) {
		$Error = join ",\n",
			values %Missing,
			values %Invalid,
			values %Blank,
			values %InvalidType;
		return;
	} else {
		return $query;
	}
}

## Default type handlers

sub CheckString {
	my $value	= shift;
	## Any non-zero length string is valid
	return 1 if (length $value > 0);
	return;
}

sub CheckWord {
	my $value	= shift;
	## Must have at least \w char
	return 1 if ($value =~ /\w/);
	return;
}

sub CheckInt {
	my $value	= shift;
	return 1 if ($value =~ /^\d+$/);
	return;
}

sub CheckFloat {
	my $value	= shift;

	## Must be in a "3.0" or "30" format
#	return 1 if ($value =~ /^\d+\.\d+$/);
	return 1 if ($value =~ /^\d+.?\d*$/);
	return;
}

sub CheckEmail {
	my $value	= shift;
	## Must look like a "standard" email address.  White space
	## is permitted on the ends though.
	return 1 if ($value =~ m/^\s*]+@[^@.<>]+(?:\.[^@.<>]+)+>?\s*$/);
}

sub CheckFormData {
	my %types	= ();
	@types{@_}	= \(0 .. $#_);		# Black magic, beware...
	return GetFormData (%types);
};

1;

__END__