CGI-ValidOp-0.56/0000755000175000017550000000000011310301055013314 5ustar exodistexodistCGI-ValidOp-0.56/t/0000755000175000017550000000000011310301055013557 5ustar exodistexodistCGI-ValidOp-0.56/t/06object-new.t0000644000175000017550000007044111310300511016151 0ustar exodistexodist# Modified from 05object.t - Erik Hollensbe # Modification done by Chad Granum use strict; use warnings; use Test::More tests => 108; use Test::Exception; use Data::Dumper; our $CLASS = "CGI::ValidOp::Object"; our ($one, $two); # $one is the same object throughout this suite use_ok($CLASS); # constructor tests #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ throws_ok { $one = $CLASS->new } qr/^No name/i; throws_ok { $one = $CLASS->new('foo') } qr/^No arguments/; throws_ok { $one = $CLASS->new('foo', 1) } qr/^args must be a hash/i; ok ($one = $CLASS->new('foo', { address1 => [ 'Address Line 1', 'required' ] }) ); is_deeply($one, { min_objects => 0, max_objects => 0, fields_required => [], construct_object => undef, name => 'foo', _param_template => { 'address1' => bless( { 'checks' => [ 'required' ], 'name' => 'address1', 'tainted' => undef, 'required' => 1, 'label' => 'Address Line 1', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ) }, _objects => [], _validated => 0, _errors => [], } ); # set_var #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ throws_ok { $one->set_var } qr/^args must be hash/i; throws_ok { $one->set_var({}) } qr/^missing parameters/i; throws_ok { $one->set_var( { name => "object--one" } ) } qr/^missing parameters/i; throws_ok { $one->set_var( { value => "one" } ) } qr/^missing parameters/i; throws_ok { $one->set_var( { name => "object--one", value => "two" } ) } qr/^Invalid parameter/i; throws_ok { $one->set_var( { name => "object--one--", value => "two" } ) } qr/^Invalid parameter/i; throws_ok { $one->set_var( { name => "object--one--foo", value => "two" } ) } qr/^Invalid parameter/i; throws_ok { $one->set_var( { name => "object--one--0", value => "two" } ) } qr/^Invalid parameter/i; throws_ok { $one->set_var( { name => "object--one--0--", value => "two" } ) } qr/^Invalid parameter/i; throws_ok { $one->set_var( { name => "object--one--0----", value => "two" } ) } qr/^Invalid parameter/i; throws_ok { $one->set_var( { name => "object--one----", value => "two" } ) } qr/^Invalid parameter/i; throws_ok { $one->set_var( { name => "object--one------", value => "two" } ) } qr/^Invalid parameter/i; throws_ok { $one->set_var( { name => "object--one----0----", value => "two" } ) } qr/^Invalid parameter/i; throws_ok { $one->set_var( { name => "object--bar--0--address1", value => "bar" }) } qr/^Name does not match/i; ok ( $one->set_var( { name => "object--foo--0--address1", value => "bar" } )); is_deeply($one, { _errors => [], name => 'foo', min_objects => 0, max_objects => 0, fields_required => [], construct_object => undef, _param_template => { 'address1' => bless( { 'checks' => [ 'required' ], 'name' => 'address1', 'tainted' => undef, 'required' => 1, 'label' => 'Address Line 1', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ) }, _objects => [ { 'address1' => { 'checks' => ['required'], 'name' => 'object--foo--0--address1', 'tainted' => 'bar', 'required' => 1, 'label' => 'Address Line 1', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef', }, } ], _validated => 0, } ); # set_vars #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ throws_ok { $one->set_vars } qr/args must be hash/i; ok ($one = $CLASS->new( 'foo', { address1 => [ 'Address Line 1', 'required' ], address2 => [ 'Address Line 2' ], key => [ 'Key' ], } ) ); ok ($one->set_vars( { "object--foo--0--address1" => "123 Anywhere", "object--foo--0--address2" => "234 Anywhere", "object--foo--0--key" => "value1", "object--foo--1--address1" => "456 Anywhere", "object--foo--1--address2" => "678 Anywhere", "object--foo--1--key" => "value2", } ) ); is_deeply( $one->{_objects}, [ { 'address1' => bless( { 'checks' => [ 'required' ], 'name' => 'object--foo--0--address1', 'tainted' => '123 Anywhere', 'required' => 1, 'label' => 'Address Line 1', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ), 'key' => bless( { 'checks' => [], 'name' => 'object--foo--0--key', 'tainted' => 'value1', 'required' => 0, 'label' => 'Key', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ), 'address2' => bless( { 'checks' => [], 'name' => 'object--foo--0--address2', 'tainted' => '234 Anywhere', 'required' => 0, 'label' => 'Address Line 2', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ) }, { 'address1' => bless( { 'checks' => [ 'required' ], 'name' => 'object--foo--1--address1', 'tainted' => '456 Anywhere', 'required' => 1, 'label' => 'Address Line 1', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ), 'address2' => bless( { 'checks' => [], 'name' => 'object--foo--1--address2', 'tainted' => '678 Anywhere', 'required' => 0, 'label' => 'Address Line 2', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ), 'key' => bless( { 'checks' => [], 'name' => 'object--foo--1--key', 'tainted' => 'value2', 'required' => 0, 'label' => 'Key', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ) } ] ); # (min|max)_objects #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ is ($one->PROPERTIES->{-max_objects}, 0); is ($one->PROPERTIES->{-min_objects}, 0); ok ($one->can('max_objects')); ok ($one->can('min_objects')); ok (!$one->max_objects); ok (!$one->min_objects); ok ($one->max_objects(2)); ok ($one->min_objects(1)); is ($one->max_objects, 2); is ($one->min_objects, 1); # HACK so tests do what we expect without setting up a new object $one->{_validated} = 0; lives_ok { $one->validate }; ok ($one->max_objects(1)); # HACK so tests do what we expect without setting up a new object $one->{_validated} = 0; lives_ok { $one->validate }; is_deeply($one->global_errors, ['object violation: max_objects (1) has been violated' ] ); # HACK so tests do what we expect without setting up a new object $one->{_validated} = 0; ok ($one->max_objects(2)); ok ($one->min_objects(3)); $one->{_errors} = []; throws_ok { $one->validate } qr/min_objects is greater than max_objects/; # HACK so tests do what we expect without setting up a new object $one->{_validated} = 0; ok ($one->min_objects(1)); # it's ok if max_objects is set to 0 and min is set to something else. ok (!$one->max_objects(0)); lives_ok { $one->validate }; # HACK so tests do what we expect without setting up a new object $one->{_validated} = 0; $one->{_errors} = []; ok ($one->min_objects(4)); lives_ok { $one->validate }; is_deeply($one->global_errors, [ 'object violation: min_objects (4) has been violated', ] ); $one->{_errors} = []; # normalize_objects #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ok ($two = $CLASS->new('foo', { foo => [ 'foo', 'required' ], address1 => [ 'Address Line 1', 'required' ] })); ok ($two->set_vars({ "object--foo--0--foo" => 'bar' })); ok ($two->normalize_objects); is_deeply( $two->{_objects}, [ { 'address1' => bless( { 'checks' => [ 'required' ], 'required' => '1', 'name' => 'address1', 'label' => 'Address Line 1', 'tainted' => undef, 'on_error_return' => 'undef', 'error_decoration' => [ undef, undef ] }, 'CGI::ValidOp::Param' ), 'foo' => bless( { 'checks' => [ 'required' ], 'required' => '1', 'name' => 'object--foo--0--foo', 'label' => 'foo', 'tainted' => 'bar', 'on_error_return' => 'undef', 'error_decoration' => [ undef, undef ] }, 'CGI::ValidOp::Param' ) } ] ); # validate #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ok ($one->max_objects(2)); ok ($one->min_objects(1)); lives_ok { $one->validate }; is_deeply( $one->{_objects}, [ { 'address1' => bless( { 'checks' => [ 'required' ], 'name' => 'object--foo--0--address1', 'value' => '123 Anywhere', 'tainted' => '123 Anywhere', 'required' => 1, 'label' => 'Address Line 1', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ), 'key' => bless( { 'checks' => [], 'name' => 'object--foo--0--key', 'value' => 'value1', 'tainted' => 'value1', 'required' => 0, 'label' => 'Key', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ), 'address2' => bless( { 'checks' => [], 'name' => 'object--foo--0--address2', 'value' => '234 Anywhere', 'tainted' => '234 Anywhere', 'required' => 0, 'label' => 'Address Line 2', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ) }, { 'address1' => bless( { 'checks' => [ 'required' ], 'name' => 'object--foo--1--address1', 'value' => '456 Anywhere', 'tainted' => '456 Anywhere', 'required' => 1, 'label' => 'Address Line 1', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ), 'address2' => bless( { 'checks' => [], 'name' => 'object--foo--1--address2', 'value' => '678 Anywhere', 'tainted' => '678 Anywhere', 'required' => 0, 'label' => 'Address Line 2', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ), 'key' => bless( { 'checks' => [], 'name' => 'object--foo--1--key', 'value' => 'value2', 'tainted' => 'value2', 'required' => 0, 'label' => 'Key', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ) } ] ); # test that required fields get errors properly ok ( $two = $CLASS->new('foo', { foo => [ "Foo" ], address1 => [ "Address Line 1", 'required' ], } ) ); ok ($two->set_vars( { "object--foo--0--foo" => 'bar' } )); lives_ok { $two->validate }; is_deeply( $two->{_objects}, [ { 'address1' => bless( { 'checks' => [ 'required' ], 'errors' => { 'required' => 'Address Line 1 is required.' }, 'value' => undef, 'name' => 'address1', 'tainted' => undef, 'required' => '1', 'label' => 'Address Line 1', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ), 'foo' => bless( { 'checks' => [], 'required' => '0', 'value' => 'bar', 'name' => 'object--foo--0--foo', 'label' => 'Foo', 'tainted' => 'bar', 'on_error_return' => 'undef', 'error_decoration' => [ undef, undef ] }, 'CGI::ValidOp::Param' ) } ] ); # test that validate does not run twice. $two->{_validated} = 0; lives_ok { $two->validate }; ok($two->{_validated}); my $tmp = $two->{_objects}; # this should NOT change after validation ok ($two->set_vars( { "object--foo--0--foo" => 'quux' } )); is_deeply($tmp, $two->{_objects}); # objects() (part one, hashes) #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ is_deeply( $one->objects, [ { 'address1' => '123 Anywhere', 'address2' => '234 Anywhere', 'key' => 'value1' }, { 'address1' => '456 Anywhere', 'key' => 'value2', 'address2' => '678 Anywhere' } ] ); # fields_required() #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ok ($one->can('fields_required')); ok ($one->fields_required); is_deeply ($one->fields_required, []); ok ($one->fields_required([qw(key)])); ok ($one->set_vars( { "object--foo--0--key" => undef } )); # HACK so tests do what we expect without setting up a new object $one->{_validated} = 0; # undef here is ok. what won't be ok is in the errors hash. is_deeply( $one->objects, [ { 'address1' => '123 Anywhere', 'address2' => '234 Anywhere', 'key' => undef, }, { 'address1' => '456 Anywhere', 'key' => 'value2', 'address2' => '678 Anywhere' } ] ); # notice [0][foo]'s error message existing. good! is_deeply( $one->{_objects}, [ { 'address1' => bless( { 'checks' => [ 'required' ], 'required' => '1', 'value' => '123 Anywhere', 'name' => 'object--foo--0--address1', 'label' => 'Address Line 1', 'tainted' => '123 Anywhere', 'on_error_return' => 'undef', 'error_decoration' => [ undef, undef ] }, 'CGI::ValidOp::Param' ), 'key' => bless( { 'checks' => [ 'required' ], 'errors' => { 'required' => 'Key is required.' }, 'value' => undef, 'name' => 'object--foo--0--key', 'tainted' => undef, 'required' => 1, 'label' => 'Key', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ), 'address2' => bless( { 'checks' => [ 'required' ], 'required' => 1, 'value' => '234 Anywhere', 'name' => 'object--foo--0--address2', 'label' => 'Address Line 2', 'tainted' => '234 Anywhere', 'on_error_return' => 'undef', 'error_decoration' => [ undef, undef ] }, 'CGI::ValidOp::Param' ) }, { 'address1' => bless( { 'checks' => [ 'required' ], 'required' => '1', 'value' => '456 Anywhere', 'name' => 'object--foo--1--address1', 'label' => 'Address Line 1', 'tainted' => '456 Anywhere', 'on_error_return' => 'undef', 'error_decoration' => [ undef, undef ] }, 'CGI::ValidOp::Param' ), 'address2' => bless( { 'checks' => [ 'required' ], 'required' => 1, 'value' => '678 Anywhere', 'name' => 'object--foo--1--address2', 'label' => 'Address Line 2', 'tainted' => '678 Anywhere', 'on_error_return' => 'undef', 'error_decoration' => [ undef, undef ] }, 'CGI::ValidOp::Param' ), 'key' => bless( { 'checks' => [ 'required' ], 'required' => 1, 'value' => 'value2', 'name' => 'object--foo--1--key', 'label' => 'Key', 'tainted' => 'value2', 'on_error_return' => 'undef', 'error_decoration' => [ undef, undef ] }, 'CGI::ValidOp::Param' ) } ] ); # object_errors() #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ is_deeply( $one->object_errors, { global_errors => [], object_errors => [ { 'address1' => [], 'address2' => [], 'key' => ['Key is required.'] }, { 'address1' => [], 'key' => [], 'address2' => [], } ] } ); # objects() (part two, real objects) #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ SKIP: { skip "need Loompa", 34 unless eval { require Loompa; 1 }; package Foo; use strict; use warnings; our @ISA = 'Loompa'; sub methods { [qw/address1 address2 key/] } package main; ok ($one = $CLASS->new( 'foo', { -construct_object => 'Foo', address1 => [ 'Address Line 1', 'required' ], address2 => [ 'Address Line 2' ], key => [ 'Key' ], } ) ); ok ($one->set_vars( { "object--foo--0--address1" => "123 Anywhere", "object--foo--0--address2" => "234 Anywhere", "object--foo--0--key" => "value1", "object--foo--1--address1" => "456 Anywhere", "object--foo--1--address2" => "678 Anywhere", "object--foo--1--key" => "value2", } ) ); foreach my $object (@{$one->objects}) { isa_ok($object, 'Foo'); } is ($one->objects->[0]->key, 'value1'); is ($one->objects->[0]->address1, '123 Anywhere'); is ($one->objects->[0]->address2, '234 Anywhere'); is ($one->objects->[1]->key, 'value2'); is ($one->objects->[1]->address1, '456 Anywhere'); is ($one->objects->[1]->address2, '678 Anywhere'); # objects() (part three, object pruning) #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ok ($one = $CLASS->new( 'foo', { -construct_object => 'Foo', address1 => [ 'Address Line 1', 'required' ], address2 => [ 'Address Line 2' ], key => [ 'Key' ], } ) ); # XXX the big difference here is that we're filling 0 and 2, not 0 and 1. ok ($one->set_vars( { "object--foo--0--address1" => "123 Anywhere", "object--foo--0--address2" => "234 Anywhere", "object--foo--0--key" => "value1", "object--foo--2--address1" => "456 Anywhere", "object--foo--2--address2" => "678 Anywhere", "object--foo--2--key" => "value2", } ) ); foreach my $object (@{$one->objects}) { isa_ok($object, 'Foo'); } is ($one->objects->[0]->key, 'value1'); is ($one->objects->[0]->address1, '123 Anywhere'); is ($one->objects->[0]->address2, '234 Anywhere'); is ($one->objects->[1]->key, 'value2'); is ($one->objects->[1]->address1, '456 Anywhere'); is ($one->objects->[1]->address2, '678 Anywhere'); ok ($one = $CLASS->new( 'foo', { -construct_object => 'Foo', address1 => [ 'Address Line 1', 'required' ], address2 => [ 'Address Line 2' ], key => [ 'Key' ], } ) ); # XXX the big difference here is that we're filling 1 and 2, not 0 and 1. ok ($one->set_vars( { "object--foo--1--address1" => "123 Anywhere", "object--foo--1--address2" => "234 Anywhere", "object--foo--1--key" => "value1", "object--foo--2--address1" => "456 Anywhere", "object--foo--2--address2" => "678 Anywhere", "object--foo--2--key" => "value2", } ) ); foreach my $object (@{$one->objects}) { isa_ok($object, 'Foo'); } is ($one->objects->[0]->key, 'value1'); is ($one->objects->[0]->address1, '123 Anywhere'); is ($one->objects->[0]->address2, '234 Anywhere'); is ($one->objects->[1]->key, 'value2'); is ($one->objects->[1]->address1, '456 Anywhere'); is ($one->objects->[1]->address2, '678 Anywhere'); ok ($one = $CLASS->new( 'foo', { bar => [ 'Checkbox', 'checkbox::boolean' ], } ) ); # XXX the big difference here is that we're filling 1 and 2, not 0 and 1. ok ($one->set_vars( { "object--foo--0--bar" => "on", "object--foo--1--bar" => undef, } ) ); is ($one->objects->[0]->{bar}, 1); is ($one->objects->[1]->{bar}, 0); } CGI-ValidOp-0.56/t/03param.t0000755000175000017550000002655111304772200015232 0ustar exodistexodist#!/usr/bin/perl use warnings; use strict; use lib qw/ t lib /; use Test::More tests => 113; use Test::Exception; use vars qw/ $one $tmp $required_error $text_error $error $param $check /; use Data::Dumper; BEGIN { use_ok( 'CGI::ValidOp::Param' )} # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # setup error messages $required_error = '$label is required.'; $text_error = 'Only letters, numbers, and the following punctuation are allowed for $label: ! " \' ( ) * , - . / : ; ? \ @ & %'; # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # constructor throws_ok{ $one = CGI::ValidOp::Param->new } qr/Parameter names are required for all values/; ok( $one = CGI::ValidOp::Param->new( 'foo' )); ok( $one->isa( 'CGI::ValidOp::Param' )); ok( $one->label( 'I am Foo' )); is( $one->required, 0 ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # label is( $one->label( undef ), undef ); is( $one->label, undef ); is( $one->label( 'Bar None' ), 'Bar None' ); is( $one->label, 'Bar None' ); ok( $one = CGI::ValidOp::Param->new({ name => 'foo', label => 'Foo type', })); is( $one->label, 'Foo type' ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # tainted is( $one->tainted( undef ), undef ); is( $one->tainted, undef ); is( $one->tainted( '' ), undef ); is( $one->tainted, undef ); is( $one->tainted( 'Bar None' ), 'Bar None' ); is( $one->tainted, 'Bar None' ); ok( $one = CGI::ValidOp::Param->new({ name => 'foo', label => 'Foo type', tainted => 'fooby', })); is( $one->tainted, 'fooby' ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # required is( $one->required( 0 ), 0 ); is( $one->required, 0 ); is( $one->required( 1 ), 1 ); is( $one->required, 1 ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # load check failing eval{ $one->load_check }; like( $@, qr/Must pass a scalar check name to/ ); eval{ $one->load_check( 'killme' )}; like( $@, qr/Failed to require CGI::ValidOp::Check::killme/ ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # load check: simple package, default ok( $check = $one->load_check( 'text' )); ok( $check->isa( 'CGI::ValidOp::Check::text' )); is( $check->validator, qr#^[\w\s\(\*\.\\\?,!"'/:;@&%)-]+$# ); # is( $check->errmsg, q#Only letters, numbers, and the following punctuation are allowed for $label: ! " ' ( ) * , - . / : ; ? \ @ & %# ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # load check: method in package ok( $check = $one->load_check( 'text::word' )); ok( $check->isa( 'CGI::ValidOp::Check::text' )); is( $check->validator, qr#^\w+$# ); is( $check->errmsg, q#Only one word is allowed for $label# ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # load check: passing params ok( $check = $one->load_check( 'text(6,12)' )); is( $check->name, 'default' ); is_deeply( [ $check->params ], [ 6, 12 ]); ok( $check = $one->load_check( 'text::word(6,12)' )); is( $check->name, 'word' ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # multi check # must check fail, then pass, to see if we get a value (we shouldn't) # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # required failing should stop other tests # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # check_required # | RETURNS | add_ | | $param-> | defined | # | undef | tainted | error | if | required | tainted | # |-------|---------|-------| |----------|---------| # | X | | X | | X | | # | X | | | | | | # | | X | | | X | X | # | | X | | | | X | # delete $one->{ errors }; # ok( $one->checks([ 'required' ])); # is( $one->tainted( undef ), undef ); # is( $one->check_required, undef ); # is( @{ $one->errors }, 1 ); # is( $one->value, undef ); # # delete $one->{ errors }; # ok( $one->checks([ 'required' ])); # is( $one->tainted( 'bar' ), 'bar' ); # is( $one->check_required, 'bar' ); # is( $one->errors, undef ); # is( $one->value, 'bar' ); # # delete $one->{ errors }; # is( $one->checks( undef ), undef ); # is( $one->tainted( 'bar' ), 'bar' ); # is( $one->check_required, 'bar' ); # is( $one->errors, undef ); # is( $one->value, 'bar' ); # # delete $one->{ errors }; # is( $one->checks( undef ), undef ); # is( $one->tainted( undef ), undef ); # is( $one->check_required, undef ); # is( $one->errors, undef ); # is( $one->value, undef ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # checks dying eval{ $one->check }; like( $@, qr/Must pass a scalar check name to CGI::ValidOp::Param::load_check/ ); eval{ $one->check([ qw/ required /])}; like( $@, qr/Must pass a scalar check name to CGI::ValidOp::Param::load_check/ ); eval{ $one->check( 'fooby' )}; like( $@, qr/Must pass a scalar check name to CGI::ValidOp::Param::load_check/ ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # check delete $one->{ errors }; is( $one->check( 'foo', 'text' ), 'foo' ); is( $one->errors, undef ); is( $one->check( 'foo', 'text' ), 'foo' ); is( $one->errors, undef ); is( $one->check( "\0", 'text' ), undef ); is( @{ $one->errors }, 1 ); like( $one->errors->[ 0 ], qr/Only letters, numbers, and the following punctuation are allowed for Foo type/ ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # multiple values ok( $one = CGI::ValidOp::Param->new({ name => 'fruits', label => 'Fruits I like', })); $one->tainted( "orange\0plum\0nectarine" ); is( $one->validate, undef ); is( $one->errors, undef ); is_deeply( $one->value, [ qw/ orange plum nectarine /]); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # validate: required fails ok( $one = CGI::ValidOp::Param->new({ name => 'foo', label => 'Foo type', checks => [ 'required' ], })); ok( $one->isa( 'CGI::ValidOp::Param' )); is( $one->required, 1 ); ( $error = $required_error ) =~ s/\$label/Foo type/; $one->validate; is( @{ $one->errors }[ 0 ], $error ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # validate: text fails ok( $one = CGI::ValidOp::Param->new({ name => 'foo', label => 'Foo type', checks => [ 'required', 'text' ], })); $one->tainted( '$ENV{crackme}' ); ( $error = $text_error ) =~ s/\$label/Foo type/; $one->validate; is( @{ $one->errors }[ 0 ], $error ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # validate: both succeed ok( $one = CGI::ValidOp::Param->new({ name => 'foo', label => 'Foo type', checks => [ 'required', 'text' ], })); $one->tainted( 'i am some regular text. foo!' ); is( $one->validate, undef ); is( $one->errors, undef ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # value $one->tainted( undef ); is( $one->validate, undef ); is( $one->value, undef ); eval{ $one->value( 'die' )}; like( $@, qr/Cannot directly set parameter value/ ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # value, taking into account on_error_return can_ok( $one, 'on_error_return' ); is( $one->on_error_return, 'undef' ); ok( $one = CGI::ValidOp::Param->new({ name => 'foo', })); $one->tainted( '' ); is( $one->value, undef ); # encoded ok( $one = CGI::ValidOp::Param->new({ name => 'foo', })); $one->on_error_return( 'encoded' ); $one->tainted( '' ); is( $one->value, '<script>crackme()</script>' ); # tainted ok( $one = CGI::ValidOp::Param->new({ name => 'foo', })); $one->on_error_return( 'tainted' ); $one->tainted( '' ); is( $one->value, '' ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # values, make sure on_error_return doesn't affect valid params ok( $one = CGI::ValidOp::Param->new({ name => 'foo', checks => [ 'required' ], })); is( $one->value, undef ); ok( $one = CGI::ValidOp::Param->new({ name => 'foo', checks => [ 'text::liberal' ], })); $one->tainted( 'He said "foo"' ); is( $one->value, 'He said "foo"' ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # errors ok( $one = CGI::ValidOp::Param->new({ name => 'foo', label => 'Foo type', })); is( $one->label, 'Foo type' ); is( $one->errors, undef ); is( $one->add_error, undef ); is( $one->add_error( 'foo' ), undef ); is( $one->errors, undef ); ok( $one->add_error( 'text', 'jack sprat would eat no fat; $label' )); is( @{ $one->errors }, 1 ); is( $one->{ errors }{ text }, 'jack sprat would eat no fat; Foo type' ); is( @{ $one->errors }[ 0 ], 'jack sprat would eat no fat; Foo type' ); ok( $one->error_decoration( '"' )); ok( $one->add_error( 'wb', 'fiery the angels fell; $label' )); is( @{ $one->errors }, 2 ); is( $one->{ errors }{ wb }, 'fiery the angels fell; "Foo type"' ); is( @{ $one->errors }[ 0 ], 'fiery the angels fell; "Foo type"' ); is( @{ $one->errors }[ 1 ], 'jack sprat would eat no fat; Foo type' ); ok( $one->error_decoration( '[', ']' )); ok( $one->add_error( 'wb', 'fiery the angels rose; $label' )); is( @{ $one->errors }, 2 ); is( $one->{ errors }{ wb }, 'fiery the angels rose; [Foo type]' ); is( @{ $one->errors }[ 0 ], 'fiery the angels rose; [Foo type]' ); ok( $one->label( 'plain' )); ok( $one->error_decoration( '<<', '>>' )); ok( $one->add_error( 'wb', 'The rain in Spain falls mainly in the $label.' )); is( @{ $one->errors }, 2 ); is( $one->{ errors }{ wb }, 'The rain in Spain falls mainly in the <>.' ); is( @{ $one->errors }[ 0 ], 'The rain in Spain falls mainly in the <>.' ); ok( $one->error_decoration( '', '' )); ok( $one->add_error( 'wb(3)', 'The rain in Spain falls mainly in the plain.' )); is( @{ $one->errors }, 2 ); is( $one->{ errors }{ wb }, 'The rain in Spain falls mainly in the plain.' ); is( @{ $one->errors }[ 0 ], 'The rain in Spain falls mainly in the plain.' ); ok( $one->add_error( 'wb::los', 'Zoa.' )); is( @{ $one->errors }, 3 ); is( $one->{ errors }{ 'wb::los' }, 'Zoa.' ); is( @{ $one->errors }[ 1 ], 'Zoa.' ); delete $one->{ errors }; __END__ # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # dies too gorily for a TODO test ... local $TODO = ''; ok( $one = CGI::ValidOp::Param->new({ name => 'foo-bar', label => 'Foo type', })); is( $one->label, 'Foo type' ); # vim:ft=perl CGI-ValidOp-0.56/t/12check_text.t0000755000175000017550000000552511304772200016251 0ustar exodistexodist#!/usr/bin/perl -T use warnings; use strict; use lib qw/ t lib /; use CGI::ValidOp::Test; use Test::More tests => 166; use vars qw/ $errmsg /; use Data::Dumper; use Test::Taint; BEGIN { use_ok( 'CGI::ValidOp::Param' )} # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # text $errmsg = qr/Only letters, numbers, and the following punctuation are allowed for William Blake/; check_check( 'text', 0, 0 ); check_check( 'text', "\0", undef, 0, $errmsg ); check_check( 'text', "\n", undef, 0, $errmsg ); check_check( 'text', ' foo bar ', 'foo bar' ); check_check( 'text', 'foo bar', 'foo bar' ); check_check( 'text', 'foo', 'foo' ); check_check( 'text', '%&()', '%&()' ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # text::word $errmsg = qr/Only one word is allowed for William Blake/; check_check( 'text::word', 0, 0 ); check_check( 'text::word', "\0", undef, 0, $errmsg ); check_check( 'text::word', "\n", undef, 0, $errmsg ); check_check( 'text::word', 'foo bar', undef, 0, $errmsg ); check_check( 'text::word', 'foo', 'foo' ); check_check( 'text::word', 'foo_bar', 'foo_bar' ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # text::words $errmsg = qr/Only words are allowed for William Blake/; check_check( 'text::words', 0, 0 ); check_check( 'text::words', "\0", undef, 0, $errmsg ); check_check( 'text::words', "\n", undef, 0, $errmsg ); check_check( 'text::words', 'foo', 'foo' ); check_check( 'text::words', 'foo bar', 'foo bar' ); check_check( 'text::words', 'foo-bar', 'foo-bar' ); check_check( 'text::word', 'foo_bar', 'foo_bar' ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # text::liberal $errmsg = qr/Only letters, numbers, and the following punctuation are allowed for William Blake/; check_check( 'text::liberal', 0, 0 ); check_check( 'text::liberal', "\0", undef, 0, $errmsg ); check_check( 'text::liberal', "\n", undef, 0, $errmsg ); check_check( 'text::liberal', 'foo bar', 'foo bar' ); check_check( 'text::liberal', '$echo', '$echo' ); check_check( 'text::liberal', '# comment me', '# comment me' ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # text::hippie $errmsg = qr/Only letters, numbers, and the following punctuation are allowed for William Blake/; check_check( 'text::hippie', 0, 0 ); check_check( 'text::hippie', "\0", undef, 0, $errmsg ); check_check( 'text::hippie', "\n", undef, 0, $errmsg ); check_check( 'text::hippie', 'foo bar', 'foo bar' ); check_check( 'text::hippie', '$echo', '$echo' ); check_check( 'text::hippie', '#23_^[32]{23}', '#23_^[32]{23}' ); check_check( 'text::hippie', '', undef, 0, $errmsg ); # hippies aren't psycho # vim:ft=perl CGI-ValidOp-0.56/t/14check_checkbox.t0000755000175000017550000000243111304772200017046 0ustar exodistexodist#!/usr/bin/perl -T use warnings; use strict; use lib qw/ t lib /; use CGI::ValidOp::Test; use Test::More tests => 70; use vars qw/ $one $errmsg /; use Data::Dumper; use Test::Taint; BEGIN { use_ok( 'CGI::ValidOp::Param' )} # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # checkbox $errmsg = qr/Checkbox William Blake must be checked./; check_check( 'checkbox', undef, undef ); check_check( 'checkbox', 0, undef, undef, $errmsg ); check_check( 'checkbox', 'one', undef, undef, $errmsg ); check_check( 'checkbox', 'on', 'on', 0 ); check_check( 'checkbox', 'ON', 'ON', 0 ); check_check( 'checkbox', 'On', 'On', 0 ); check_check( 'checkbox', 'oN', 'oN', 0 ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # checkbox::boolean : returns 1 or 0 $errmsg = qr/Only a checkbox is allowed for parameter William Blake./; check_check( 'checkbox::boolean', undef, 0 ); check_check( 'checkbox::boolean', 0, undef, undef, $errmsg ); check_check( 'checkbox::boolean', 'one', undef, undef, $errmsg ); check_check( 'checkbox::boolean', 'on', 1 ); check_check( 'checkbox::boolean', 'ON', 1 ); check_check( 'checkbox::boolean', 'On', 1 ); check_check( 'checkbox::boolean', 'oN', 1 ); # vim:ft=perl CGI-ValidOp-0.56/t/05object-legacy.t0000644000175000017550000007033311310300474016633 0ustar exodistexodistuse constant TESTS => 107; #=============================================================================== # # FILE: 05-object.t # # DESCRIPTION: Object-style parameters: tests. # # FILES: --- # BUGS: --- # NOTES: --- # AUTHOR: Erik Hollensbe (), # COMPANY: OpenSourcery, LLC # VERSION: 1.0 # CREATED: 01/13/2008 03:45:27 PST # REVISION: $id$ #=============================================================================== use strict; use warnings; use Test::More tests => TESTS; # see line 1 use Test::Exception; use Data::Dumper; our $CLASS = "CGI::ValidOp::Object"; our ($one, $two); # $one is the same object throughout this suite use_ok($CLASS); # constructor tests #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ throws_ok { $one = $CLASS->new } qr/^No name/i; throws_ok { $one = $CLASS->new('foo') } qr/^No arguments/; throws_ok { $one = $CLASS->new('foo', 1) } qr/^args must be a hash/i; ok ($one = $CLASS->new('foo', { address1 => [ 'Address Line 1', 'required' ] }) ); is_deeply($one, { min_objects => 0, max_objects => 0, fields_required => [], construct_object => undef, name => 'foo', _param_template => { 'address1' => bless( { 'checks' => [ 'required' ], 'name' => 'address1', 'tainted' => undef, 'required' => 1, 'label' => 'Address Line 1', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ) }, _objects => [], _validated => 0, _errors => [], } ); # set_var #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ throws_ok { $one->set_var } qr/^args must be hash/i; throws_ok { $one->set_var({}) } qr/^missing parameters/i; throws_ok { $one->set_var( { name => "one" } ) } qr/^missing parameters/i; throws_ok { $one->set_var( { value => "one" } ) } qr/^missing parameters/i; throws_ok { $one->set_var( { name => "one", value => "two" } ) } qr/^Invalid parameter/i; throws_ok { $one->set_var( { name => "one[", value => "two" } ) } qr/^Invalid parameter/i; throws_ok { $one->set_var( { name => "one[]", value => "two" } ) } qr/^Invalid parameter/i; throws_ok { $one->set_var( { name => "one[foo]", value => "two" } ) } qr/^Invalid parameter/i; throws_ok { $one->set_var( { name => "one[0]", value => "two" } ) } qr/^Invalid parameter/i; throws_ok { $one->set_var( { name => "one[0][]", value => "two" } ) } qr/^Invalid parameter/i; throws_ok { $one->set_var( { name => "one[][]", value => "two" } ) } qr/^Invalid parameter/i; throws_ok { $one->set_var( { name => "one[[0]][]]", value => "two" } ) } qr/^Invalid parameter/i; throws_ok { $one->set_var( { name => "bar[0][address1]", value => "bar" }) } qr/^Name does not match/i; #throws_ok { $one->set_var( { name => "foo[0][bar]", value => "foo" }) } qr/^Parameter \(bar\) for object \(foo\) does not match/i; ok ( $one->set_var( { name => "foo[0][address1]", value => "bar" } )); is_deeply($one, { _errors => [], name => 'foo', min_objects => 0, max_objects => 0, fields_required => [], construct_object => undef, _param_template => { 'address1' => bless( { 'checks' => [ 'required' ], 'name' => 'address1', 'tainted' => undef, 'required' => 1, 'label' => 'Address Line 1', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ) }, _objects => [ { 'address1' => { 'checks' => ['required'], 'name' => 'foo[0][address1]', 'tainted' => 'bar', 'required' => 1, 'label' => 'Address Line 1', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef', }, } ], _validated => 0, } ); # set_vars #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ throws_ok { $one->set_vars } qr/args must be hash/i; ok ($one = $CLASS->new( 'foo', { address1 => [ 'Address Line 1', 'required' ], address2 => [ 'Address Line 2' ], key => [ 'Key' ], } ) ); ok ($one->set_vars( { "foo[0][address1]" => "123 Anywhere", "foo[0][address2]" => "234 Anywhere", "foo[0][key]" => "value1", "foo[1][address1]" => "456 Anywhere", "foo[1][address2]" => "678 Anywhere", "foo[1][key]" => "value2", } ) ); is_deeply( $one->{_objects}, [ { 'address1' => bless( { 'checks' => [ 'required' ], 'name' => 'foo[0][address1]', 'tainted' => '123 Anywhere', 'required' => 1, 'label' => 'Address Line 1', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ), 'key' => bless( { 'checks' => [], 'name' => 'foo[0][key]', 'tainted' => 'value1', 'required' => 0, 'label' => 'Key', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ), 'address2' => bless( { 'checks' => [], 'name' => 'foo[0][address2]', 'tainted' => '234 Anywhere', 'required' => 0, 'label' => 'Address Line 2', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ) }, { 'address1' => bless( { 'checks' => [ 'required' ], 'name' => 'foo[1][address1]', 'tainted' => '456 Anywhere', 'required' => 1, 'label' => 'Address Line 1', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ), 'address2' => bless( { 'checks' => [], 'name' => 'foo[1][address2]', 'tainted' => '678 Anywhere', 'required' => 0, 'label' => 'Address Line 2', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ), 'key' => bless( { 'checks' => [], 'name' => 'foo[1][key]', 'tainted' => 'value2', 'required' => 0, 'label' => 'Key', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ) } ] ); # (min|max)_objects #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ is ($one->PROPERTIES->{-max_objects}, 0); is ($one->PROPERTIES->{-min_objects}, 0); ok ($one->can('max_objects')); ok ($one->can('min_objects')); ok (!$one->max_objects); ok (!$one->min_objects); ok ($one->max_objects(2)); ok ($one->min_objects(1)); is ($one->max_objects, 2); is ($one->min_objects, 1); # HACK so tests do what we expect without setting up a new object $one->{_validated} = 0; lives_ok { $one->validate }; ok ($one->max_objects(1)); # HACK so tests do what we expect without setting up a new object $one->{_validated} = 0; lives_ok { $one->validate }; is_deeply($one->global_errors, ['object violation: max_objects (1) has been violated' ] ); # HACK so tests do what we expect without setting up a new object $one->{_validated} = 0; ok ($one->max_objects(2)); ok ($one->min_objects(3)); $one->{_errors} = []; throws_ok { $one->validate } qr/min_objects is greater than max_objects/; # HACK so tests do what we expect without setting up a new object $one->{_validated} = 0; ok ($one->min_objects(1)); # it's ok if max_objects is set to 0 and min is set to something else. ok (!$one->max_objects(0)); lives_ok { $one->validate }; # HACK so tests do what we expect without setting up a new object $one->{_validated} = 0; $one->{_errors} = []; ok ($one->min_objects(4)); lives_ok { $one->validate }; is_deeply($one->global_errors, [ 'object violation: min_objects (4) has been violated', ] ); $one->{_errors} = []; # normalize_objects #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ok ($two = $CLASS->new('foo', { foo => [ 'foo', 'required' ], address1 => [ 'Address Line 1', 'required' ] })); ok ($two->set_vars({ "foo[0][foo]" => 'bar' })); ok ($two->normalize_objects); is_deeply( $two->{_objects}, [ { 'address1' => bless( { 'checks' => [ 'required' ], 'required' => '1', 'name' => 'address1', 'label' => 'Address Line 1', 'tainted' => undef, 'on_error_return' => 'undef', 'error_decoration' => [ undef, undef ] }, 'CGI::ValidOp::Param' ), 'foo' => bless( { 'checks' => [ 'required' ], 'required' => '1', 'name' => 'foo[0][foo]', 'label' => 'foo', 'tainted' => 'bar', 'on_error_return' => 'undef', 'error_decoration' => [ undef, undef ] }, 'CGI::ValidOp::Param' ) } ] ); # validate #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ok ($one->max_objects(2)); ok ($one->min_objects(1)); lives_ok { $one->validate }; is_deeply( $one->{_objects}, [ { 'address1' => bless( { 'checks' => [ 'required' ], 'name' => 'foo[0][address1]', 'value' => '123 Anywhere', 'tainted' => '123 Anywhere', 'required' => 1, 'label' => 'Address Line 1', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ), 'key' => bless( { 'checks' => [], 'name' => 'foo[0][key]', 'value' => 'value1', 'tainted' => 'value1', 'required' => 0, 'label' => 'Key', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ), 'address2' => bless( { 'checks' => [], 'name' => 'foo[0][address2]', 'value' => '234 Anywhere', 'tainted' => '234 Anywhere', 'required' => 0, 'label' => 'Address Line 2', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ) }, { 'address1' => bless( { 'checks' => [ 'required' ], 'name' => 'foo[1][address1]', 'value' => '456 Anywhere', 'tainted' => '456 Anywhere', 'required' => 1, 'label' => 'Address Line 1', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ), 'address2' => bless( { 'checks' => [], 'name' => 'foo[1][address2]', 'value' => '678 Anywhere', 'tainted' => '678 Anywhere', 'required' => 0, 'label' => 'Address Line 2', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ), 'key' => bless( { 'checks' => [], 'name' => 'foo[1][key]', 'value' => 'value2', 'tainted' => 'value2', 'required' => 0, 'label' => 'Key', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ) } ] ); # test that required fields get errors properly ok ( $two = $CLASS->new('foo', { foo => [ "Foo" ], address1 => [ "Address Line 1", 'required' ], } ) ); ok ($two->set_vars( { "foo[0][foo]" => 'bar' } )); lives_ok { $two->validate }; is_deeply( $two->{_objects}, [ { 'address1' => bless( { 'checks' => [ 'required' ], 'errors' => { 'required' => 'Address Line 1 is required.' }, 'value' => undef, 'name' => 'address1', 'tainted' => undef, 'required' => '1', 'label' => 'Address Line 1', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ), 'foo' => bless( { 'checks' => [], 'required' => '0', 'value' => 'bar', 'name' => 'foo[0][foo]', 'label' => 'Foo', 'tainted' => 'bar', 'on_error_return' => 'undef', 'error_decoration' => [ undef, undef ] }, 'CGI::ValidOp::Param' ) } ] ); # test that validate does not run twice. $two->{_validated} = 0; lives_ok { $two->validate }; ok($two->{_validated}); my $tmp = $two->{_objects}; # this should NOT change after validation ok ($two->set_vars( { "foo[0][foo]" => 'quux' } )); is_deeply($tmp, $two->{_objects}); # objects() (part one, hashes) #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ is_deeply( $one->objects, [ { 'address1' => '123 Anywhere', 'address2' => '234 Anywhere', 'key' => 'value1' }, { 'address1' => '456 Anywhere', 'key' => 'value2', 'address2' => '678 Anywhere' } ] ); # fields_required() #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ok ($one->can('fields_required')); ok ($one->fields_required); is_deeply ($one->fields_required, []); ok ($one->fields_required([qw(key)])); ok ($one->set_vars( { "foo[0][key]" => undef } )); # HACK so tests do what we expect without setting up a new object $one->{_validated} = 0; # undef here is ok. what won't be ok is in the errors hash. is_deeply( $one->objects, [ { 'address1' => '123 Anywhere', 'address2' => '234 Anywhere', 'key' => undef, }, { 'address1' => '456 Anywhere', 'key' => 'value2', 'address2' => '678 Anywhere' } ] ); # notice [0][foo]'s error message existing. good! is_deeply( $one->{_objects}, [ { 'address1' => bless( { 'checks' => [ 'required' ], 'required' => '1', 'value' => '123 Anywhere', 'name' => 'foo[0][address1]', 'label' => 'Address Line 1', 'tainted' => '123 Anywhere', 'on_error_return' => 'undef', 'error_decoration' => [ undef, undef ] }, 'CGI::ValidOp::Param' ), 'key' => bless( { 'checks' => [ 'required' ], 'errors' => { 'required' => 'Key is required.' }, 'value' => undef, 'name' => 'foo[0][key]', 'tainted' => undef, 'required' => 1, 'label' => 'Key', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ), 'address2' => bless( { 'checks' => [ 'required' ], 'required' => 1, 'value' => '234 Anywhere', 'name' => 'foo[0][address2]', 'label' => 'Address Line 2', 'tainted' => '234 Anywhere', 'on_error_return' => 'undef', 'error_decoration' => [ undef, undef ] }, 'CGI::ValidOp::Param' ) }, { 'address1' => bless( { 'checks' => [ 'required' ], 'required' => '1', 'value' => '456 Anywhere', 'name' => 'foo[1][address1]', 'label' => 'Address Line 1', 'tainted' => '456 Anywhere', 'on_error_return' => 'undef', 'error_decoration' => [ undef, undef ] }, 'CGI::ValidOp::Param' ), 'address2' => bless( { 'checks' => [ 'required' ], 'required' => 1, 'value' => '678 Anywhere', 'name' => 'foo[1][address2]', 'label' => 'Address Line 2', 'tainted' => '678 Anywhere', 'on_error_return' => 'undef', 'error_decoration' => [ undef, undef ] }, 'CGI::ValidOp::Param' ), 'key' => bless( { 'checks' => [ 'required' ], 'required' => 1, 'value' => 'value2', 'name' => 'foo[1][key]', 'label' => 'Key', 'tainted' => 'value2', 'on_error_return' => 'undef', 'error_decoration' => [ undef, undef ] }, 'CGI::ValidOp::Param' ) } ] ); # object_errors() #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ is_deeply( $one->object_errors, { global_errors => [], object_errors => [ { 'address1' => [], 'address2' => [], 'key' => ['Key is required.'] }, { 'address1' => [], 'key' => [], 'address2' => [], } ] } ); # objects() (part two, real objects) #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ SKIP: { skip "need Loompa", 34 unless eval { require Loompa; 1 }; package Foo; use strict; use warnings; our @ISA = 'Loompa'; sub methods { [qw/address1 address2 key/] } package main; ok ($one = $CLASS->new( 'foo', { -construct_object => 'Foo', address1 => [ 'Address Line 1', 'required' ], address2 => [ 'Address Line 2' ], key => [ 'Key' ], } ) ); ok ($one->set_vars( { "foo[0][address1]" => "123 Anywhere", "foo[0][address2]" => "234 Anywhere", "foo[0][key]" => "value1", "foo[1][address1]" => "456 Anywhere", "foo[1][address2]" => "678 Anywhere", "foo[1][key]" => "value2", } ) ); foreach my $object (@{$one->objects}) { isa_ok($object, 'Foo'); } is ($one->objects->[0]->key, 'value1'); is ($one->objects->[0]->address1, '123 Anywhere'); is ($one->objects->[0]->address2, '234 Anywhere'); is ($one->objects->[1]->key, 'value2'); is ($one->objects->[1]->address1, '456 Anywhere'); is ($one->objects->[1]->address2, '678 Anywhere'); # objects() (part three, object pruning) #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ok ($one = $CLASS->new( 'foo', { -construct_object => 'Foo', address1 => [ 'Address Line 1', 'required' ], address2 => [ 'Address Line 2' ], key => [ 'Key' ], } ) ); # XXX the big difference here is that we're filling 0 and 2, not 0 and 1. ok ($one->set_vars( { "foo[0][address1]" => "123 Anywhere", "foo[0][address2]" => "234 Anywhere", "foo[0][key]" => "value1", "foo[2][address1]" => "456 Anywhere", "foo[2][address2]" => "678 Anywhere", "foo[2][key]" => "value2", } ) ); foreach my $object (@{$one->objects}) { isa_ok($object, 'Foo'); } is ($one->objects->[0]->key, 'value1'); is ($one->objects->[0]->address1, '123 Anywhere'); is ($one->objects->[0]->address2, '234 Anywhere'); is ($one->objects->[1]->key, 'value2'); is ($one->objects->[1]->address1, '456 Anywhere'); is ($one->objects->[1]->address2, '678 Anywhere'); ok ($one = $CLASS->new( 'foo', { -construct_object => 'Foo', address1 => [ 'Address Line 1', 'required' ], address2 => [ 'Address Line 2' ], key => [ 'Key' ], } ) ); # XXX the big difference here is that we're filling 1 and 2, not 0 and 1. ok ($one->set_vars( { "foo[1][address1]" => "123 Anywhere", "foo[1][address2]" => "234 Anywhere", "foo[1][key]" => "value1", "foo[2][address1]" => "456 Anywhere", "foo[2][address2]" => "678 Anywhere", "foo[2][key]" => "value2", } ) ); foreach my $object (@{$one->objects}) { isa_ok($object, 'Foo'); } is ($one->objects->[0]->key, 'value1'); is ($one->objects->[0]->address1, '123 Anywhere'); is ($one->objects->[0]->address2, '234 Anywhere'); is ($one->objects->[1]->key, 'value2'); is ($one->objects->[1]->address1, '456 Anywhere'); is ($one->objects->[1]->address2, '678 Anywhere'); ok ($one = $CLASS->new( 'foo', { bar => [ 'Checkbox', 'checkbox::boolean' ], } ) ); # XXX the big difference here is that we're filling 1 and 2, not 0 and 1. ok ($one->set_vars( { "foo[0][bar]" => "on", "foo[1][bar]" => undef, } ) ); is ($one->objects->[0]->{bar}, 1); is ($one->objects->[1]->{bar}, 0); } CGI-ValidOp-0.56/t/18check_email.t0000644000175000017550000000261611304772200016355 0ustar exodistexodist#!/usr/bin/perl -T use warnings; use strict; use lib qw/ t lib /; use CGI::ValidOp::Test; use Test::More tests => 70; use vars qw/ $one $errmsg /; use Data::Dumper; use Test::Taint; BEGIN { use_ok( 'CGI::ValidOp::Param' )} # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Bad addresses check_check( 'email', undef, undef ); #Empty address is ok. check_check( 'email', 'bob', undef, 0, "William Blake: 'bob' is not a valid email address." ); check_check( 'email', 'bob.com', undef, 0, "William Blake: 'bob.com' is not a valid email address." ); check_check( 'email', 'bob@bob', undef, 0, "William Blake: 'bob\@bob' is not a valid email address." ); check_check( 'email', 'bob@bob@bob.com', undef, 0, "William Blake: 'bob\@bob\@bob.com' is not a valid email address." ); # Good Addresses check_check( 'email', 'bob@bob.com', 'bob@bob.com' ); check_check( 'email', 'bob.bob@bob.com', 'bob.bob@bob.com' ); check_check( 'email', 'bob-bob@bob.com', 'bob-bob@bob.com' ); check_check( 'email', 'bob_bob@bob.com', 'bob_bob@bob.com' ); check_check( 'email', 'bob@bob.bob.com', 'bob@bob.bob.com' ); check_check( 'email', 'bob@bob-bob.com', 'bob@bob-bob.com' ); check_check( 'email', 'bob@bob_bob.com', 'bob@bob_bob.com' ); check_check( 'email', 'bob@bob+bob.com', 'bob@bob+bob.com' ); check_check( 'email', 'bob+bob@bob.com', 'bob+bob@bob.com' ); CGI-ValidOp-0.56/t/15check_demographics.t0000755000175000017550000000455111304772200017733 0ustar exodistexodist#!/usr/bin/perl -T use warnings; use strict; use lib qw/ t lib /; use CGI::ValidOp::Test; use Test::More tests => 690; use vars qw/ $one $errmsg /; use Data::Dumper; use Test::Taint; BEGIN { use_ok( 'CGI::ValidOp::Param' )} # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # default check_check( 'demographics', undef, 'DIE' ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # us_state2 $errmsg = qr/William Blake must be the 2-letter abbreviation for a US state name./; check_check( 'demographics::us_state2', undef, undef ); check_check( 'demographics::us_state2', $_, undef, undef, $errmsg ) for qw/ohio oregon us sa za rc/; check_check( 'demographics::us_state2', $_, $_ ) for qw/AL AK AS AZ AR CA CO CT DE DC FM FL GA GU HI ID IL IN IA KS KY LA ME MH MD MA MI MN MS MO MT NE NV NH NJ NM NY NC ND MP OH OK OR PW PA PR RI SC SD TN TX UT VT VI VA WA WV WI WY al ak as az ar ca co ct de dc fm fl ga gu hi id il in ia ks ky la me mh md ma mi mn ms mo mt ne nv nh nj nm ny nc nd mp oh ok or pw pa pr ri sc sd tn tx ut vt vi va wa wv wi wy/; # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # ssn $errmsg = qr/William Blake must be a number like "123-45-6789"./; check_check( 'demographics::us_ssn', 12345678, undef, undef, $errmsg ); check_check( 'demographics::us_ssn', 1234567890, undef, undef, $errmsg ); check_check( 'demographics::us_ssn', '123456789', '123456789' ); check_check( 'demographics::us_ssn', '123-45-6789', '123-45-6789' ); check_check( 'demographics::us_ssn', '123-456789', '123-456789' ); check_check( 'demographics::us_ssn', '12345-6789', '12345-6789' ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # ssn integer $errmsg = qr/William Blake must be a number like "123-45-6789"./; check_check( 'demographics::us_ssn(integer)', 12345678, undef, undef, $errmsg ); check_check( 'demographics::us_ssn(integer)', 1234567890, undef, undef, $errmsg ); check_check( 'demographics::us_ssn(integer)', '123456789', '123456789' ); check_check( 'demographics::us_ssn(integer)', '123-45-6789', '123456789' ); check_check( 'demographics::us_ssn(integer)', '123-456789', '123456789' ); check_check( 'demographics::us_ssn(integer)', '12345-6789', '123456789' ); # vim:ft=perl CGI-ValidOp-0.56/t/91cgi_basic.cgi0000755000175000017550000000177011304772200016337 0ustar exodistexodist#!/usr/bin/perl use warnings; use strict; use Test::More tests => 16; use vars qw/ $one $error $text_error $required_error /; use Data::Dumper; use lib '../lib'; BEGIN { use_ok( 'CGI::ValidOp' )} BEGIN { use_ok( 'CGI::ValidOp::Check::text' )} $ENV{REQUEST_METHOD} = 'GET'; $ENV{QUERY_STRING} = 'number=3172&name=Lava lamp&price=27.99&crackme=;rm / -rf'; # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ok( $one = CGI::ValidOp->new ); ok( $one->isa( 'CGI::ValidOp' )); is( $one->param( 'number' ), 3172 ); is( $one->param( 'name' ), 'Lava lamp' ); is( $one->param( 'price' ), 27.99 ); is( $one->param( 'crackme' ), undef ); # ( $error = $text_error ) =~ s/\$label/crackme/; ok( $one->errors ); is( @{ $one->errors }[ 0 ], $error ); is_deeply( $one->Vars, { number => 3172, name => 'Lava lamp', price => 27.99, crackme => undef, }); ok( $one->errors ); is( @{ $one->errors }[ 0 ], $error ); CGI-ValidOp-0.56/t/10validop.t0000755000175000017550000007334511310300630015560 0ustar exodistexodist#!/usr/bin/perl use warnings; use strict; use lib qw/ t lib /; use CGI::ValidOp::Test; use Test::More tests => 253; use vars qw/ $one $vars $ops $op $param @params %vars /; use Data::Dumper; BEGIN { use_ok( 'CGI::ValidOp' )} # setup {{{ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $vars = { item => 'Cat food', price => '10.99', shipping => 'FedEx', }; $ops = { add => { item => [ 'item name', 'required' ], number => [ 'item number', 'required' ], shipping => [ 'shipping method', 'required' ], }, remove => { number => [ 'item number', 'required' ], item => [ 'item name', 'required' ], } }; # }}} # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # blank constructor $one = CGI::ValidOp->new; ok( defined( $one )); ok( $one->isa( 'CGI::ValidOp' )); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # defaults is( $one->allow_unexpected, 1 ); is( $one->default_op, 'default' ); is( $one->runmode_name, 'op' ); is( $one->print_warnings, 1 ); is( $one->disable_uploads, 1 ); is( $one->post_max, 25_000 ); is( $one->error_decoration, undef ); is( $one->on_error_return_undef, 1 ); is( $one->on_error_return_encoded, 0 ); is( $one->on_error_return_tainted, 0 ); is( $one->return_only_received, 0 ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # setting options $one = CGI::ValidOp->new({ -allow_unexpected => 0, -default_op => 'home', -runmode_name => 'action', -print_warnings => 0, -disable_uploads => 0, -post_max => 2_500_000, -error_decoration => [ '', '' ], foo => 'bar', }); is( ref($one->cgi_object), 'CGI' ); is( $one->allow_unexpected, 0 ); is( $one->default_op, 'home' ); is( $one->runmode_name, 'action' ); is( $one->print_warnings, 0 ); is( $one->disable_uploads, 0 ); is( $one->post_max, 2_500_000 ); is_deeply( { $one->ops }, { foo => 'bar' }); is_deeply([ $one->error_decoration ], [ '', '' ]); is_deeply([ $one->error_decoration( 'foo', 'bar' )], [ 'foo', 'bar' ]); is( $one->on_error_return_undef, 1 ); is( $one->on_error_return_encoded, 0 ); is( $one->on_error_return_tainted, 0 ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # setting options, checking precedence of on_error properties $one = CGI::ValidOp->new; is( $one->on_error_return_undef, 1 ); is( $one->on_error_return_encoded, 0 ); is( $one->on_error_return_tainted, 0 ); $one = CGI::ValidOp->new({ -on_error_return_undef => 1, -on_error_return_encoded => 1, -on_error_return_tainted => 1, }); is( $one->on_error_return_undef, 1 ); is( $one->on_error_return_encoded, 0 ); is( $one->on_error_return_tainted, 0 ); $one = CGI::ValidOp->new({ -on_error_return_undef => 0, -on_error_return_encoded => 1, -on_error_return_tainted => 1, }); is( $one->on_error_return_undef, 0 ); is( $one->on_error_return_encoded, 1 ); is( $one->on_error_return_tainted, 0 ); $one = CGI::ValidOp->new({ -on_error_return_undef => 0, -on_error_return_encoded => 0, -on_error_return_tainted => 1, }); is( $one->on_error_return_undef, 0 ); is( $one->on_error_return_encoded, 0 ); is( $one->on_error_return_tainted, 1 ); # setting one only $one = CGI::ValidOp->new({ -on_error_return_undef => 1, }); is( $one->on_error_return_undef, 1 ); is( $one->on_error_return_encoded, 0 ); is( $one->on_error_return_tainted, 0 ); $one = CGI::ValidOp->new({ -on_error_return_encoded => 1, }); is( $one->on_error_return_undef, 0 ); is( $one->on_error_return_encoded, 1 ); is( $one->on_error_return_tainted, 0 ); $one = CGI::ValidOp->new({ -on_error_return_tainted => 1, }); is( $one->on_error_return_undef, 0 ); is( $one->on_error_return_encoded, 0 ); is( $one->on_error_return_tainted, 1 ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # setting options on the fly $one = CGI::ValidOp->new; is( $one->on_error_return_undef, 1 ); is( $one->on_error_return_encoded, 0 ); is( $one->on_error_return_tainted, 0 ); # setting active option as 1 has no effect $one->on_error_return_undef( 1 ); is( $one->on_error_return_undef, 1 ); is( $one->on_error_return_encoded, 0 ); is( $one->on_error_return_tainted, 0 ); # setting undef option as 0 $one->on_error_return_undef( 0 ); is( $one->on_error_return_undef, 0 ); is( $one->on_error_return_encoded, 0 ); is( $one->on_error_return_tainted, 0 ); # setting encoded option as 1 unsets undef $one->on_error_return_encoded( 1 ); is( $one->on_error_return_undef, 0 ); is( $one->on_error_return_encoded, 1 ); is( $one->on_error_return_tainted, 0 ); # setting encoded option as 0 works $one->on_error_return_encoded( 0 ); is( $one->on_error_return_undef, 0 ); is( $one->on_error_return_encoded, 0 ); is( $one->on_error_return_tainted, 0 ); # setting tainted as 1 unsets undef $one->on_error_return_tainted( 1 ); is( $one->on_error_return_undef, 0 ); is( $one->on_error_return_encoded, 0 ); is( $one->on_error_return_tainted, 1 ); # setting tainted as 0 works $one->on_error_return_tainted( 0 ); is( $one->on_error_return_undef, 0 ); is( $one->on_error_return_encoded, 0 ); is( $one->on_error_return_tainted, 0 ); # setting encoded as 1 unsets tainted $one->on_error_return_tainted( 1 ); $one->on_error_return_encoded( 1 ); is( $one->on_error_return_undef, 0 ); is( $one->on_error_return_encoded, 1 ); is( $one->on_error_return_tainted, 0 ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # set_vars should accept any input # an empty hashref should set the 'vars' property to undef # a hashref should set 'vars' to that hashref # anything else should have no effect delete $one->{ _vars }; is( $one->{ _vars }, undef ); is( $one->set_vars, undef ); is( $one->set_vars( $vars ), undef ); is_deeply( $one->{ _vars }, $vars ); is( $one->set_vars( undef ), undef ); is_deeply( $one->{ _vars }, $vars ); is( $one->set_vars( 0 ), undef ); is_deeply( $one->{ _vars }, $vars ); is( $one->set_vars( 'foo' ), undef ); is_deeply( $one->{ _vars }, $vars ); is( $one->set_vars( [ 'foo' ] ), undef ); is_deeply( $one->{ _vars }, $vars ); is( $one->set_vars( {} ), undef ); is( $one->{ _vars }, undef ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # setup for op_alias, get_op_name $one = CGI::ValidOp->new({ one => {}, two => { -alias => 'Second Op', }, three => { -alias => [ 'Op The Third', 'third' ], }, }); is( $one->op_alias, undef ); is( $one->op_alias( 'Second op' ), undef ); is( $one->op_alias( 'Second Op' ), 'two' ); is( $one->op_alias( 'Op The Third' ), 'three' ); is( $one->op_alias( 'third' ), 'three' ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # get_op_name is( $one->get_op_name, 'default' ); is( $one->set_vars({ op => 'foo' }), undef ); is( $one->get_op_name, 'default' ); is( $one->set_vars({ op => 'default' }), undef ); is( $one->get_op_name, 'default' ); is( $one->set_vars({ op => 'Default' }), undef ); is( $one->get_op_name, 'default' ); is( $one->set_vars({ op => 'One' }), undef ); is( $one->get_op_name, 'one' ); is( $one->set_vars({ op => 'THREE' }), undef ); is( $one->get_op_name, 'three' ); is( $one->set_vars({ op => 'Op The Third' }), undef ); is( $one->get_op_name, 'three' ); is( $one->set_vars({ op => "one\0One\0three" }), undef ); is( $one->get_op_name, 'one' ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # make_op $one = CGI::ValidOp->new; is( $one->param, undef ); $one->ops({ default => { item => [ 'item name', 'required' ], }, }); $one->make_op; is( $one->op, 'default' ); is( $one->Op->name, 'default' ); is( @{ $one->Op->Param }, 1 ); is( $one->Op->Param( 'item' )->name, 'item' ); is( $one->Op->Param( 'item' )->label, 'item name' ); is_deeply( [ $one->Op->Param( 'item' )->checks ], [ 'required' ]); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # setup ok( $one = CGI::ValidOp->new ); $vars = { item => 'Cat food', price => '10.99', shipping => 'FedEx', }; is( $one->set_vars( $vars ), undef ); is_deeply( $one->{ _vars }, $vars ); is( $one->op, 'default' ); ok( $one->Op->isa( 'CGI::ValidOp::Op' )); is( $one->Op->name, 'default' ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # on_error_return $one = CGI::ValidOp->new; is( $one->Op->on_error_return, 'undef' ); $one = CGI::ValidOp->new({ -on_error_return_undef => 1, }); is( $one->Op->on_error_return, 'undef' ); $one = CGI::ValidOp->new({ -on_error_return_encoded => 1, }); is( $one->Op->on_error_return, 'encoded' ); $one = CGI::ValidOp->new({ -on_error_return_tainted => 1, }); is( $one->Op->on_error_return, 'tainted' ); $one = CGI::ValidOp->new({ -on_error_return_undef => 1, -on_error_return_encoded => 1, -on_error_return_tainted => 1, }); is( $one->Op->on_error_return, 'undef' ); $one = CGI::ValidOp->new({ -on_error_return_undef => 0, -on_error_return_encoded => 1, -on_error_return_tainted => 1, }); is( $one->Op->on_error_return, 'encoded' ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # op is( $one->op, 'default' ); is( $one->op( 'foo' ), 'foo' ); is( $one->op, 'foo' ); eval{ $one->op( 'echo rm / -rf' )}; like( $@, qr/Invalid op name/ ); eval{ $one->op( "trojan\nhorse" )}; like( $@, qr/Invalid op name/ ); eval{ $one->op( "trojan horse" )}; like( $@, qr/Invalid op name/ ); is( $one->op( 'i_am_an_op' ), 'i_am_an_op' ); is( $one->op, 'i_am_an_op' ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # setup $vars = { item => 'Cat food', price => '10.99', shipping => 'FedEx', op => 'add', }; is( $one->set_vars( $vars ), undef ); is_deeply( $one->{ _vars }, $vars ); is( $one->op, 'default' ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Op object ok( $one->Op->isa( 'CGI::ValidOp::Op' )); is( $one->Op->name, 'default' ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # add_param eval{ $one->add_param( 'baz', \'baz' )}; like( $@, qr/Incorrect param definition/ ); ok( $param = $one->add_param( 'baz' )); ok( $param->isa( 'CGI::ValidOp::Param' )); is( $param->name, 'baz' ); is( $param->label, undef ); is_deeply( [ $param->checks ], [ qw/ text /]); ok( $param = $one->{ Op }{ _params }{ 'baz' }); is( $param->name, 'baz' ); ok( $param = $one->add_param( foo => [ 'I Am Foo', 'required', 'text' ] )); ok( $param->isa( 'CGI::ValidOp::Param' )); is( $param->name, 'foo' ); is( $param->label, 'I Am Foo' ); is_deeply( [ $param->checks ], [ qw/ required text /]); ok( $param = $one->{ Op }{ _params }{ 'foo' }); is( $param->name, 'foo' ); ok( $param = $one->add_param( 'foo', [ 'I Am Foo', 'required', 'text' ])); ok( $param->isa( 'CGI::ValidOp::Param' )); is( $param->name, 'foo' ); is( $param->label, 'I Am Foo' ); is_deeply( [ $param->checks ], [ qw/ required text /]); ok( $param = $one->{ Op }{ _params }{ 'foo' }); is( $param->name, 'foo' ); ok( $param = $one->add_param( 'bar', [ 'We Are Bar', 'required', 'checkbox' ])); ok( $param->isa( 'CGI::ValidOp::Param' )); is( $param->name, 'bar' ); is( $param->label, 'We Are Bar' ); is_deeply( [ $param->checks ], [ qw/ required checkbox /]); ok( $param = $one->{ Op }{ _params }{ 'bar' }); is( $param->name, 'bar' ); ok( $param = $one->add_param( 'bar', [ 'We Are Bar' ])); ok( $param->isa( 'CGI::ValidOp::Param' )); is( $param->name, 'bar' ); is( $param->label, 'We Are Bar' ); is_deeply( [ $param->checks ], []); ok( $param = $one->{ Op }{ _params }{ 'bar' }); is( $param->name, 'bar' ); ok( $param = $one->add_param( 'object[property]', [ 'We Are Bar' ])); ok( $param->isa( 'CGI::ValidOp::Param' )); is( $param->name, 'object[property]' ); is( $param->label, 'We Are Bar' ); is_deeply( [ $param->checks ], []); ok( $param = $one->{ Op }{ _params }{ 'object[property]' }); is( $param->name, 'object[property]' ); ok ($param = $one->add_param( 'object', { address1 => ['Address Line 1', 'required'], address2 => ['Address Line 2'], key => ['Key', 'required', 'text' ], } ) ); isa_ok($param, 'CGI::ValidOp::Object'); is_deeply( $param, bless( { _validated => 0, '_param_template' => { 'address1' => bless( { 'checks' => ['required'], 'name' => 'address1', 'tainted' => undef, 'required' => 1, 'label' => 'Address Line 1', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ), 'address2' => bless( { 'checks' => [], 'name' => 'address2', 'tainted' => undef, 'required' => 0, 'label' => 'Address Line 2', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ), 'key' => bless( { 'checks' => [ 'required', 'text' ], 'name' => 'key', 'tainted' => undef, 'required' => 1, 'label' => 'Key', 'error_decoration' => [ undef, undef ], 'on_error_return' => 'undef' }, 'CGI::ValidOp::Param' ) }, 'name' => 'object', 'construct_object' => undef, '_objects' => [], 'min_objects' => 0, 'fields_required' => [], 'max_objects' => 0, _errors => [], }, 'CGI::ValidOp::Object' ) ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # param ok( @params = $one->param ); is_deeply([ sort @params ], [ qw/ bar baz foo item object[property] price shipping / ]); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # pass params into constructor $one = CGI::ValidOp->new({ add => { -alias => [ 'Add Item', 'Add an item' ], item => [ 'item name', 'required' ], number => [ 'item number', 'required' ], shipping => [ 'shipping method', 'required' ], }, remove => { -alias => 'Remove Item', number => [ 'item number', 'required' ], item => [ 'item name', 'required' ], }, edit => {}, view => {}, }); $vars = { item => 'Cat food', price => '10.99', shipping => 'FedEx', op => 'Add an item', }; ok( defined( $one )); ok( $one->isa( 'CGI::ValidOp' )); is( $one->set_vars( $vars ), undef ); is_deeply( $one->{ _vars }, $vars ); is( $one->op, 'add' ); ok( $one->Op->isa( 'CGI::ValidOp::Op' )); is( $one->Op->Param( 'item' )->label, 'item name' ); is_deeply( [ $one->Op->Param( 'item' )->checks ], [ 'required' ]); is( $one->Op->Param( 'item' )->value, 'Cat food' ); is( $one->param( 'item' ), 'Cat food' ); is( $one->param( 'number' ), undef ); is( $one->param( 'shipping' ), 'FedEx' ); is( $one->param( 'price' ), 10.99 ); $one->allow_unexpected( 0 ); is( $one->op, 'add' ); is( $one->param( 'item' ), 'Cat food' ); is( $one->param( 'number' ), undef ); is( $one->param( 'shipping' ), 'FedEx' ); is( $one->param( 'price' ), undef ); is_deeply( { $one->Vars }, { item => 'Cat food', number => undef, shipping => 'FedEx', }); %vars = $one->Vars; is_deeply( \%vars, { item => 'Cat food', number => undef, shipping => 'FedEx', }); $vars = $one->Vars; is_deeply( $vars, { item => 'Cat food', number => undef, shipping => 'FedEx', }); $one->allow_unexpected( 1 ); is_deeply( { $one->Vars }, { item => 'Cat food', number => undef, shipping => 'FedEx', price => 10.99, }); $one->return_only_received( 1 ); is_deeply( { $one->Vars }, { item => 'Cat food', shipping => 'FedEx', price => 10.99, }); $one->return_only_received( 0 ); is_deeply( { $one->Vars }, { item => 'Cat food', number => undef, shipping => 'FedEx', price => 10.99, }); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # pass params into constructor, shorthand notation $vars = { item => 'Cat food', price => '10.99', shipping => 'FedEx', op => 'add', }; $one = undef; $one = CGI::ValidOp->new({ -allow_unexpected => 0, add => { item => [ 'item name', 'required' ], }, }); ok( defined( $one )); ok( $one->isa( 'CGI::ValidOp' )); is( $one->set_vars( $vars ), undef ); is_deeply( $one->{ _vars }, $vars ); is( $one->op, 'add' ); is( $one->param( 'item' ), 'Cat food' ); is( $one->param( 'number' ), undef ); is( $one->param( 'shipping' ), undef ); is( $one->param( 'price' ), undef ); is_deeply( { $one->Vars }, { item => 'Cat food', }); $one->allow_unexpected( 0 ); is_deeply( { $one->Vars }, { item => 'Cat food', }); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # undefined ops will not be set $vars = { item => 'Cat food', price => '10.99', shipping => 'FedEx', }; $one = undef; $one = CGI::ValidOp->new; is( $one->set_vars({ op => 'foo' }), undef ); is( $one->op, 'default' ); SKIP: { skip "no Loompa", 30 unless eval { require Loompa; 1 }; package Foo; our @ISA = qw(Loompa); sub methods { [qw(one two three)] } sub required_methods { [qw(one two)] } package main; #{{{ Old system with [] $one = CGI::ValidOp->new( { step2_save => { -on_error => 'step2', foo => { -construct_object => 'Foo', one => [ 'One', 'required' ], two => [ 'Two', 'required' ], three => [ 'Three', 'required' ], } } } ); isa_ok($one, 'CGI::ValidOp'); $one->set_vars( { op => 'step2_save', 'foo[0][one]' => '1', 'foo[0][two]' => '2', 'foo[0][three]' => '3', } ); ok (my $objects = $one->objects('foo')); isa_ok($objects->[0], 'Foo'); can_ok($objects->[0], 'one'); can_ok($objects->[0], 'two'); can_ok($objects->[0], 'three'); is ($objects->[0]->one, 1); is ($objects->[0]->two, 2); is ($objects->[0]->three, 3); is_deeply($one->objects, { 'foo' => [ bless( { 'one' => 1, 'two' => 2, 'three' => 3, }, 'Foo' ) ] } ); $one = CGI::ValidOp->new( { step2_save => { -on_error => 'step2', # addresses client_address => { -min_objects => 1, -max_objects => 3, address1 => [ 'Address 0 Line 1', 'required' ], city => [ 'Address 0 City', 'required' ], state => [ 'Address 0 State', 'required' ], postcode => [ 'Address 0 Post Code', 'required' ], not_required => [ 'Address 0 Not Required' ], } } } ); ok ($one->isa('CGI::ValidOp')); $one->set_vars( { op => 'step2_save', 'client_address[0][address1]' => 'foo1', 'client_address[0][city]' => 'bar1', 'client_address[0][state]' => 'baz1', 'client_address[0][postcode]' => 'quux1', 'client_address[0][not_required]' => 'not_required!!!', 'client_address[1][address1]' => 'foo2', 'client_address[1][city]' => 'bar2', 'client_address[1][state]' => 'baz2', 'client_address[1][postcode]' => 'quux2', 'client_address[2][address1]' => 'foo3', 'client_address[2][city]' => 'bar3', 'client_address[2][state]' => 'baz3', 'client_address[2][postcode]' => 'quux3', } ); is_deeply( $one->objects('client_address'), [ { address1 => 'foo1', city => 'bar1', state => 'baz1', postcode => 'quux1', not_required => 'not_required!!!', }, { address1 => 'foo2', city => 'bar2', state => 'baz2', postcode => 'quux2', not_required => undef, }, { address1 => 'foo3', city => 'bar3', state => 'baz3', postcode => 'quux3', not_required => undef, } ] ); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # object_errors $one = CGI::ValidOp->new( { step2_save => { -on_error => 'step2', # addresses client_address => { -min_objects => 1, -max_objects => 3, address1 => [ 'Address 0 Line 1', 'required' ], city => [ 'Address 0 City', 'required' ], state => [ 'Address 0 State', 'required' ], postcode => [ 'Address 0 Post Code', 'required' ], not_required => [ 'Address 0 Not Required' ], } } } ); ok ($one->isa('CGI::ValidOp')); $one->set_vars( { op => 'step2_save', } ); is_deeply($one->object_errors, { client_address => { global_errors => [ 'object violation: min_objects (1) has been violated' ], object_errors => [ ], } } ); is_deeply($one->object_errors('client_address'), { global_errors => [ 'object violation: min_objects (1) has been violated' ], object_errors => [ ], } ); #}}} #{{{ New system with object--x--#--x $one = CGI::ValidOp->new( { step2_save => { -on_error => 'step2', foo => { -construct_object => 'Foo', one => [ 'One', 'required' ], two => [ 'Two', 'required' ], three => [ 'Three', 'required' ], } } } ); isa_ok($one, 'CGI::ValidOp'); $one->set_vars( { op => 'step2_save', 'object--foo--0--one' => '1', 'object--foo--0--two' => '2', 'object--foo--0--three' => '3', } ); ok ($objects = $one->objects('foo')); isa_ok($objects->[0], 'Foo'); can_ok($objects->[0], 'one'); can_ok($objects->[0], 'two'); can_ok($objects->[0], 'three'); is ($objects->[0]->one, 1); is ($objects->[0]->two, 2); is ($objects->[0]->three, 3); is_deeply($one->objects, { 'foo' => [ bless( { 'one' => 1, 'two' => 2, 'three' => 3, }, 'Foo' ) ] } ); $one = CGI::ValidOp->new( { step2_save => { -on_error => 'step2', # addresses client_address => { -min_objects => 1, -max_objects => 3, address1 => [ 'Address 0 Line 1', 'required' ], city => [ 'Address 0 City', 'required' ], state => [ 'Address 0 State', 'required' ], postcode => [ 'Address 0 Post Code', 'required' ], not_required => [ 'Address 0 Not Required' ], } } } ); ok ($one->isa('CGI::ValidOp')); $one->set_vars( { op => 'step2_save', 'object--client_address--0--address1' => 'foo1', 'object--client_address--0--city' => 'bar1', 'object--client_address--0--state' => 'baz1', 'object--client_address--0--postcode' => 'quux1', 'object--client_address--0--not_required' => 'not_required!!!', 'object--client_address--1--address1' => 'foo2', 'object--client_address--1--city' => 'bar2', 'object--client_address--1--state' => 'baz2', 'object--client_address--1--postcode' => 'quux2', 'object--client_address--2--address1' => 'foo3', 'object--client_address--2--city' => 'bar3', 'object--client_address--2--state' => 'baz3', 'object--client_address--2--postcode' => 'quux3', } ); is_deeply( $one->objects('client_address'), [ { address1 => 'foo1', city => 'bar1', state => 'baz1', postcode => 'quux1', not_required => 'not_required!!!', }, { address1 => 'foo2', city => 'bar2', state => 'baz2', postcode => 'quux2', not_required => undef, }, { address1 => 'foo3', city => 'bar3', state => 'baz3', postcode => 'quux3', not_required => undef, } ] ); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # object_errors $one = CGI::ValidOp->new( { step2_save => { -on_error => 'step2', # addresses client_address => { -min_objects => 1, -max_objects => 3, address1 => [ 'Address 0 Line 1', 'required' ], city => [ 'Address 0 City', 'required' ], state => [ 'Address 0 State', 'required' ], postcode => [ 'Address 0 Post Code', 'required' ], not_required => [ 'Address 0 Not Required' ], } } } ); ok ($one->isa('CGI::ValidOp')); $one->set_vars( { op => 'step2_save', } ); is_deeply($one->object_errors, { client_address => { global_errors => [ 'object violation: min_objects (1) has been violated' ], object_errors => [ ], } } ); is_deeply($one->object_errors('client_address'), { global_errors => [ 'object violation: min_objects (1) has been violated' ], object_errors => [ ], } ); #}}} } CGI-ValidOp-0.56/t/01base.t0000755000175000017550000001313311304772200015032 0ustar exodistexodist#!/usr/bin/perl -T use warnings; use strict; use lib qw/ t lib /; package Main; use Test::More tests => 76; use Test::Taint; use Test::Exception; use vars qw/ $one $two $tmp @tmp %tmp /; use Data::Dumper; BEGIN { use_ok( 'CGI::ValidOp::Base' )} # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # test package with no PROPERTIES package CGI::ValidOp::NoPROPERTIES; use base qw/ CGI::ValidOp::Base /; # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # object creation package Main; $one = CGI::ValidOp::NoPROPERTIES->new; ok( defined( $one )); ok( $one->isa( 'CGI::ValidOp::NoPROPERTIES' )); ok( $one->isa( 'CGI::ValidOp::Base' )); $two = $one->new; ok( defined( $two )); ok( $two->isa( 'CGI::ValidOp::NoPROPERTIES' )); ok( $two->isa( 'CGI::ValidOp::Base' )); $one = new CGI::ValidOp::NoPROPERTIES; ok( defined( $one )); ok( $one->isa( 'CGI::ValidOp::NoPROPERTIES' )); ok( $one->isa( 'CGI::ValidOp::Base' )); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # set_name() failures $one->{ name } = undef; is( $one->{ name }, undef ); throws_ok{ $one->set_name({})} qr/ERROR: set_name\(\) API./; throws_ok{ $one->set_name([ 'foo' ])} qr/ERROR: set_name\(\) API./; throws_ok{ $one->set_name({ foo => 'foo' })} qr/ERROR: set_name\(\) API./; throws_ok{ $one->set_name( \'foo' )} qr/ERROR: set_name\(\) API./; throws_ok{ $one->set_name({ bar => 'name' })} qr/ERROR: set_name\(\) API./; throws_ok{ $one->set_name } qr/Parameter names are required for all values./; throws_ok{ $one->set_name({ name => undef })} qr/Parameter names are required for all values./; throws_ok{ $one->set_name( 'rank and serial number' )} qr/Parameter names must contain only letters, numbers, underscores, and square brackets./; throws_ok{ $one->set_name({ name => 'foo bar' })} qr/Parameter names must contain only letters, numbers, underscores, and square brackets./; is( $one->{ name }, undef ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # set_name() successes is( $one->set_name({ name => 'bar' }), 'bar' ); is( $one->{ name }, 'bar' ); delete $one->{ name }; is( $one->set_name( 'foo' ), 'foo' ); is( $one->{ name }, 'foo' ); is( $one->set_name( 'baz' ), 'baz' ); is( $one->{ name }, 'baz' ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # set_name() successes, with brackets in name # ... although technically any characters are valid markup is( $one->set_name({ name => 'foo[bar]' }), 'foo[bar]' ); is( $one->{ name }, 'foo[bar]' ); delete $one->{ name }; is( $one->set_name( '[]' ), '[]' ); is( $one->{ name }, '[]' ); is( $one->set_name( '[baz' ), '[baz' ); is( $one->{ name }, '[baz' ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # taint checking $tmp = 'foo'; taint( $tmp ); tainted_ok( $tmp ); ok( $one->is_tainted( $tmp )); $tmp =~ /^(foo)$/; untainted_ok( $1 ); ok( ! $one->is_tainted( $1 )); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # error_decoration is( $one->error_decoration, undef ); is( $one->error_decoration( undef ), undef ); is( $one->error_decoration( $one->error_decoration ), undef ); is_deeply([ $one->error_decoration( undef, 'END' )], [ undef, 'END' ]); is_deeply([ $one->error_decoration ], [ undef, 'END' ]); is_deeply([ $one->error_decoration( 'BEGIN', undef )], [ 'BEGIN', undef ]); is_deeply([ $one->error_decoration ], [ 'BEGIN', undef ]); is_deeply([ $one->error_decoration( '[', ']' )], [ '[', ']' ]); is_deeply([ $one->error_decoration ], [ '[', ']' ]); is_deeply([ $one->error_decoration( '"' )], [ '"', '"' ]); is_deeply([ $one->error_decoration ], [ '"', '"' ]); is_deeply([ $one->error_decoration([ '[', ']' ])], [ '[', ']' ]); is_deeply([ $one->error_decoration ], [ '[', ']' ]); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # test package with PROPERTIES package CGI::ValidOp::HasProperties; use base qw/ CGI::ValidOp::Base /; sub PROPERTIES { { boy => 'calvin', not_defined => undef, zero => 0, arrayref => [ 17, 19, 23 ], hashref => { foo => 'bar', bar => 'foo' }, array => ( 'one', 'two', 'three' ), } } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ package Main; $one = CGI::ValidOp::HasProperties->new; ok( defined( $one )); ok( $one->isa( 'CGI::ValidOp::HasProperties' )); ok( $one->isa( 'CGI::ValidOp::Base' )); is( $one->boy, 'calvin' ); is( $one->not_defined, undef); is( $one->zero, 0); @tmp = $one->arrayref; is( @tmp, 3 ); is_deeply( \@tmp, [ 17, 19, 23 ]); %tmp = $one->hashref; is( keys %tmp, 2 ); is_deeply( { $one->hashref }, { foo => 'bar', bar => 'foo' }); is( $one->array, 'one' ); # arrays are bad, m'kay? is( $one->two, 'three' ); # arrays are bad, m'kay? is( $one->boy( 1 ), 1 ); is( $one->boy, 1 ); is( $one->boy( 0 ), 0 ); is( $one->boy, 0 ); is( $one->boy( undef ), undef ); is( $one->boy, undef ); is( $one->boy( '' ), undef ); is( $one->boy, undef ); is( $one->boy( 3, 7, 11 ), 3 ); is( $one->boy, 3 ); is_deeply( [ $one->boy([ 3, 7, 11 ]) ], [ 3, 7, 11 ]); is_deeply( [ $one->boy ], [ 3, 7, 11 ]); is_deeply( { $one->boy({ a => 2, b => 4 }) }, { a => 2, b => 4 }); is_deeply( { $one->boy }, { a => 2, b => 4 }); # vim:ft=perl CGI-ValidOp-0.56/t/00test.t0000755000175000017550000000032411304772200015074 0ustar exodistexodist#!/usr/bin/perl -T use warnings; use strict; use lib qw/ t lib /; use Test::More tests => 1; BEGIN { use_ok( 'CGI::ValidOp::Test' )} # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # vim:ft=perl CGI-ValidOp-0.56/t/02check.t0000755000175000017550000002151311304772200015177 0ustar exodistexodist#!/usr/bin/perl -T use warnings; use strict; use lib qw/ t lib /; package Main; use Test::More tests => 95; use Test::Taint; use vars qw/ $one $validator $errmsg $tmp $sub @params /; use Data::Dumper; use Carp; BEGIN { use_ok( 'CGI::ValidOp::Check' )} # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # setup sub taintme { my $value = shift; taint( $value ); tainted_ok( $value ); $value; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # defaults eval{ CGI::ValidOp::Check->new( 'zippy' )}; like( $@, qr/No such check \("zippy"\) in package "CGI::ValidOp::Check"/ ); $one = CGI::ValidOp::Check->new; ok( defined( $one )); ok( $one->isa( 'CGI::ValidOp::Check' )); ok(( $validator, $errmsg ) = $one->default ); is( ref $validator, 'CODE' ); is( $errmsg, 'Parameter $label contained invalid data.' ); is( $one->name, 'default' ); is( ref $one->validator, 'CODE' ); is( $one->errmsg, 'Parameter $label contained invalid data.' ); eval{ $one->check }; like( $@, qr/You must override CGI::ValidOp::Check::check/ ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # pass/fail is_deeply([ $one->pass ], [ undef, undef ]); is_deeply([ $one->pass( 'foo' ) ], [ 'foo', undef ]); is_deeply([ $one->fail ], [ undef, undef ]); is_deeply([ $one->fail( 'foo' )], [ undef, 'foo' ]); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # regex checks taint_checking_ok(); $tmp = taintme( 'a' ); is_deeply([ $one->check_regexp( $tmp, qr/^\w$/ )], [ 'a', undef ]); untainted_ok( $one->check_regexp( $tmp, qr/\w/ )); $tmp = taintme( 1 ); is_deeply([ $one->check_regexp( $tmp, qr/^\w$/ )], [ 1, undef ]); untainted_ok( $one->check_regexp( $tmp, qr/\w/ )); $tmp = taintme( '_' ); is_deeply([ $one->check_regexp( $tmp, qr/^\w$/ )], [ '_', undef ]); untainted_ok( $one->check_regexp( $tmp, qr/\w/ )); is_deeply([ $one->check_regexp( 'fo', qr/^\w$/ )], [ undef, 'Parameter $label contained invalid data.' ]); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # coderef checks $sub = sub{ return unless my $v = shift; $v =~ /^(foo)$/; return $1; }; is( $one->check_code( undef, $sub ), undef ); is( $one->check_code( 0, $sub ), undef ); is( $one->check_code( 'foo bar', $sub ), undef ); $tmp = taintme( 'foo' ); is( $one->check_code( $tmp, $sub ), 'foo' ); untainted_ok( $one->check_code( $tmp, $sub )); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # test package package CGI::ValidOp::Check::Test; use strict; use warnings; use base qw/ CGI::ValidOp::Check /; sub default {( qr/\w/, 'Must be one character', )} sub coderef { my $self = shift; sub { my $value = shift; $value =~ /^(foo)$/; return $self->pass( $1 ) if $1; $self->fail( 'Must be foo' ); } } sub coderef_tainted { my $self = shift; sub { return $self->fail( 'this should go down in flames' ) unless $_[ 0 ] eq 'foo'; $self->pass( $_[ 0 ] ); } } sub echo_incoming { my $self = shift; sub { $self->pass( join '-', @_ ); } } sub arrayref { [ qw/ one two three /] } sub notaref { 'foo' } sub should_pass { my $self = shift; sub { $self->pass( 1 ); } } sub should_fail { my $self = shift; sub { $self->fail( 'this should fail' ); } } sub should_allow_tainted { my $self = shift; sub { $self->allow_tainted( 1 ); $self->pass( $_[ 0 ]); }; } sub should_check_undef { my $self = shift; sub { my $value = shift; return $self->pass( 'undefined' ) unless defined $value; $self->pass( 'defined' ); } } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ package Main; # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # disallowed types eval{ $one = CGI::ValidOp::Check::Test->new( 'arrayref' )}; like( $@, qr/Disallowed reference type for validator. You used ARRAY; valid types are: regexp code/ ); eval{ $one = CGI::ValidOp::Check::Test->new( 'notaref' )}; like( $@, qr/Disallowed reference type for validator. You used ; valid types are: regexp code/ ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # default $one = CGI::ValidOp::Check::Test->new; ok( defined( $one )); ok( $one->isa( 'CGI::ValidOp::Check::Test' )); is( $one->name, 'default' ); is( $one->errmsg, 'Must be one character' ); is( $one->validator, qr/\w/ ); ok( ! $one->allow_tainted ); $tmp = taintme( 'a' ); is( $one->check( $tmp ), 'a' ); untainted_ok( $one->check( $tmp )); $tmp = taintme( 1 ); is( $one->check( $tmp ), 1 ); untainted_ok( $one->check( $tmp )); $tmp = taintme( '/' ); is( $one->check( $tmp ), undef ); untainted_ok( $one->check( $tmp )); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # pass/fail $one = CGI::ValidOp::Check::Test->new( 'should_pass' ); $tmp = taintme( 'i will pass' ); is( $one->check( $tmp ), 1 ); untainted_ok( $one->check( $tmp )); $one = CGI::ValidOp::Check::Test->new( 'should_fail' ); $tmp = taintme( 'i will fail' ); is_deeply([ $one->check( $tmp )], [ undef, 'this should fail' ]); untainted_ok( $one->check( $tmp )); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # coderef $one = CGI::ValidOp::Check::Test->new( 'coderef' ); ok( defined( $one )); ok( $one->isa( 'CGI::ValidOp::Check::Test' )); is( $one->name, 'coderef' ); is( $one->errmsg, undef ); is( ref $one->validator, 'CODE' ); $tmp = taintme( 'a' ); is( $one->check( $tmp ), undef ); untainted_ok( $one->check( $tmp )); $tmp = taintme( 1 ); is( $one->check( $tmp ), undef ); untainted_ok( $one->check( $tmp )); $tmp = taintme( 0 ); is( $one->check( $tmp ), undef ); untainted_ok( $one->check( $tmp )); $tmp = taintme( 'foo' ); is( $one->check( $tmp ), 'foo' ); untainted_ok( $one->check( $tmp )); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # tainted coderef $one = CGI::ValidOp::Check::Test->new( 'coderef_tainted' ); ok( defined( $one )); ok( $one->isa( 'CGI::ValidOp::Check::Test' )); is( $one->name, 'coderef_tainted' ); is( $one->errmsg, undef ); is( ref $one->validator, 'CODE' ); $tmp = taintme( 'foo' ); eval{ $one->check( $tmp )}; like( $@, qr/Validator returned a tainted value/ ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # allow tainted $one = CGI::ValidOp::Check::Test->new( 'should_allow_tainted' ); ok( ! $one->allow_tainted ); $tmp = taintme( 'foo' ); is( $one->check( $tmp ), 'foo' ); ok( $one->allow_tainted ); tainted_ok( $one->check( $tmp )); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # echo incoming parameters @params = qw/ fee fi foe /; $one = CGI::ValidOp::Check::Test->new( 'echo_incoming', @params ); is_deeply([ $one->params ], \@params ); is_deeply([ $one->check( 'foo' )], [ 'foo-fee-fi-foe', undef ]); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # check undef $one = CGI::ValidOp::Check::Test->new( 'should_check_undef' ); ok( $one->should_check_undef ); is( $one->check( 'foo' ), 'defined' ); is( $one->check( undef ), 'undefined' ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # for documentation # these tests are redundant, but i want to make sure what i'm # putting in the docs is correct package CGI::ValidOp::Check::demo; use base qw/ CGI::ValidOp::Check /; sub default { ( qr/^demo$/, # validator '$label must equal "demo."', # error message ) } sub color { my $self = shift; ( sub { my( $value, $color ) = @_; return $1 if $value =~ /^($color)$/i; $self->errmsg( "\$label must be the color: $color." ); return; }, ) } package Main; my $demo = CGI::ValidOp::Check::demo->new; is( $demo->check( 'failure' ), undef ); is( $demo->check( 'demo' ), 'demo' ); my $value = $demo->check( 'demo' ); ok( ! $demo->is_tainted( $value )); my $demo_color = CGI::ValidOp::Check::demo->new( 'color', 'red' ); is( $demo_color->check( 'green' ), undef ); is( $demo_color->errmsg, '$label must be the color: red.' ); is( $demo_color->check( 'red' ), 'red' ); # vim:ft=perl CGI-ValidOp-0.56/t/17check_sql.t0000755000175000017550000000377611304772200016077 0ustar exodistexodist#!/usr/bin/perl -T use warnings; use strict; use lib qw/ t lib /; use CGI::ValidOp::Test; use Test::More tests => 96; use vars qw/ $errmsg /; use Data::Dumper; use Test::Taint; BEGIN { use_ok( 'CGI::ValidOp::Param' )} # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # default $errmsg = qr/Only letters, numbers, and the following punctuation are allowed for William Blake/; check_check( 'sql', 0, 0 ); check_check( 'sql', "\0", undef, 0, $errmsg ); check_check( 'sql', "\n", undef, 0, $errmsg ); check_check( 'sql', ' foo bar ', 'foo bar' ); check_check( 'sql', 'foo bar', 'foo bar' ); check_check( 'sql', 'foo', 'foo' ); check_check( 'sql', '%&()', '%&()' ); check_check( 'sql', 'foo bar', "foo\nbar" ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # safer check_check( 'sql::safer', 0, 0 ); check_check( 'sql::safer', ';', undef, 0, qr/Semicolons not allowed for William Blake/ ); check_check( 'sql::safer', '-', undef, 0, qr/Dashes not allowed for William Blake/ ); check_check( 'sql::safer', 'DROP', undef, 0, qr/DROP statement not allowed for William Blake/ ); check_check( 'sql::safer', 'DELETE', undef, 0, qr/DELETE statement not allowed for William Blake/ ); check_check( 'sql::safer', 'UPDATE', undef, 0, qr/UPDATE statement not allowed for William Blake/ ); check_check( 'sql::safer', 'INTO', undef, 0, qr/INTO statement not allowed for William Blake/ ); check_check( 'sql::safer', 'SELECT', undef, 0, qr/SELECT statement not allowed for William Blake/ ); check_check( 'sql::safer', 'SELECT * FROM foo WHERE 1 = 1', undef, 0, qr/SELECT statement not allowed for William Blake/ ); check_check( 'sql::safer', 'SELECT * FROM foo WHERE 1 = 1', undef, 0, qr/SELECT statement not allowed for William Blake/ ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # safer_select check_check( 'sql::safer_select', 'SELECT * FROM foo WHERE 1 = 1', 'SELECT * FROM foo WHERE 1 = 1' ); CGI-ValidOp-0.56/t/19check_alternative.t0000644000175000017550000000163511304772200017605 0ustar exodistexodist#!/usr/bin/perl -T use warnings; use strict; use lib qw/ t lib /; use CGI::ValidOp::Test; use CGI::ValidOp; use Test::More tests => 19; use vars qw/ $one $errmsg /; use Data::Dumper; use Test::Taint; BEGIN { use_ok( 'CGI::ValidOp::Param' )} # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Set the no_param parameter so that CGI can pick it up. $ENV{ REQUEST_METHOD } = 'GET'; $ENV{ QUERY_STRING } = "no_param=1"; # No effect, the one we want is set, the alternative is not. check_check( 'alternative(fake_param)', 'hello', 'hello' ); #Error, nothing was set, and the alternative was not either. check_check( 'alternative(fake_param)', undef, undef, 0, 'William Blake is required.' ); #No error, the alternative was set check_check( 'alternative(no_param)', undef, undef ); #No value, the alternative was set check_check( 'alternative(no_param)', '"should go away"', undef ); CGI-ValidOp-0.56/t/04op.t0000755000175000017550000001276211304772200014550 0ustar exodistexodist#!/usr/bin/perl use warnings; use strict; use lib qw/ t lib /; use Test::More tests => 84; use Test::Exception; use vars qw/ $one $param @params /; use Data::Dumper; BEGIN { use_ok( 'CGI::ValidOp::Op' )} # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # constructor errors throws_ok{ $one = CGI::ValidOp::Op->new } qr/Parameter names are required for all values/; # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # valid constructor ok( $one = CGI::ValidOp::Op->new( 'home' )); ok( $one->isa( 'CGI::ValidOp::Op' )); is( $one->name, 'home' ); is( $one->{ name }, 'home' ); is( $one->error_decoration, undef ); is( $one->on_error_return, 'undef' ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # name, alias ok( $one = CGI::ValidOp::Op->new({ name => 'home', alias => [ 'Mad William', 'Mr Blake' ], })); is( $one->name, 'home' ); is_deeply( [ $one->alias ], [ 'Mad William', 'Mr Blake' ]); ok( $one = CGI::ValidOp::Op->new({ name => 'home', alias => 'poet', })); is( $one->name, 'home' ); is_deeply( $one->alias, 'poet'); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # add_param failures is( $one->{ _params }, undef ); throws_ok{ $one->add_param } qr/set_name\(\) API/; throws_ok{ $one->add_param( {} ) } qr/set_name\(\) API/; throws_ok{ $one->add_param({ foo => 'bar' }) } qr/set_name\(\) API/; throws_ok{ $one->add_param({ name => undef }) } qr/Parameter names are required for all values./; throws_ok{ $one->add_param({ name => 'foo bar' }) } qr/Parameter names must contain only letters, numbers, underscores, and square brackets./; # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # add_param successes ok( $param = $one->add_param({ name => 'foo' })); ok( $param->isa( 'CGI::ValidOp::Param' )); is( $param->name, 'foo' ); is( $param->on_error_return, 'undef' ); ok( $param = $one->add_param({ name => 'foo[bar]' })); ok( $param->isa( 'CGI::ValidOp::Param' )); is( $param->name, 'foo[bar]' ); is( $param->on_error_return, 'undef' ); ok( $param = $one->{ _params }{ 'foo' }); ok( $param->isa( 'CGI::ValidOp::Param' )); is( $param->name, 'foo' ); is_deeply( [ $param->checks ], [ qw/ text /]); is( $param->tainted, undef ); is( $param->value, undef ); $one->on_error_return( 'encoded' ); ok( $param = $one->add_param( 'bar' )); ok( $param->isa( 'CGI::ValidOp::Param' )); is( $param->name, 'bar' ); is( $param->on_error_return, 'encoded' ); ok( $param = $one->{ _params }{ 'bar' }); ok( $param->isa( 'CGI::ValidOp::Param' )); is( $param->name, 'bar' ); is_deeply( [ $param->checks ], [ qw/ text /]); is( $param->tainted, undef ); is( $param->value, undef ); $one->on_error_return( 'tainted' ); ok( $param = $one->add_param({ name => 'wb', label => 'William Blake', tainted => 'fiery the angels cracked my box', checks => [ 'required', 'text' ], })); ok( $param->isa( 'CGI::ValidOp::Param' )); is( $param->name, 'wb' ); is( $param->label, 'William Blake' ); is( $param->tainted, 'fiery the angels cracked my box' ); is_deeply( [ $param->checks ], [ qw/ required text /]); is( $param->value, 'fiery the angels cracked my box' ); is( $param->on_error_return, 'tainted' ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # add_param duplicates is( $param->label( 'I am Bar' ), 'I am Bar' ); $one->add_param( 'bar' ); ok( $param = $one->{ _params }{ 'bar' }); is( $param->label, undef ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Param is( $one->Param( 'bang' ), undef ); ok( $param = $one->Param( 'foo' )); ok( $param->isa( 'CGI::ValidOp::Param' )); is( $param->name, 'foo' ); is( @{ $one->Param }, 4 ); ok( @params = $one->Param ); ok( $params[ $_ ]->isa( 'CGI::ValidOp::Param' )) for 0..2; delete $one->{ _params }; is( $one->Param, undef ); is( $one->Param( 'foo' ), undef ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # add_param called on incoming arguments with no dash ok( $one = CGI::ValidOp::Op->new({ name => 'home', error_decoration => [ '', '' ], comment => { label => 'Comment text', checks => [ 'required', 'text' ], }, item => { label => 'item name', checks => [ 'required', 'text' ], }, multi => { label => 'Multiple parameters', checks => [ 'required', 'text' ], }, price => { label => 'item number', checks => [ 'required', 'text' ], }, shipping => { label => 'shipping method', checks => [ 'required', 'text' ], }, })); is_deeply([ $one->error_decoration ], [ '', '' ]); is( @{ $one->Param }, 5 ); ok( @params = $one->Param ); for( 0..4 ) { ok( $params[ $_ ]->isa( 'CGI::ValidOp::Param' )); is_deeply([ $params[ $_ ]->error_decoration ], [ '', '' ]); } is( $one->Param( 'item' )->name, 'item' ); is( $one->Param( 'item' )->label, 'item name' ); is_deeply( [ $one->Param( 'item' )->checks ], [ 'required', 'text' ]); ok( $one->Param( 'item' )->required ); CGI-ValidOp-0.56/t/13check_number.t0000755000175000017550000001005711304772200016552 0ustar exodistexodist#!/usr/bin/perl -T use warnings; use strict; use lib qw/ t lib /; use CGI::ValidOp::Test; use Test::More tests => 248; use vars qw/ $one $errmsg /; use Data::Dumper; use Test::Taint; BEGIN { use_ok( 'CGI::ValidOp::Param' )} # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # number $errmsg = qr/William Blake must be a number./; check_check( 'number', 0, 0 ); check_check( 'number', 0, 0 ); check_check( 'number', -0, -0 ); check_check( 'number', 123, 123 ); check_check( 'number', -123, -123 ); check_check( 'number', +123, +123 ); check_check( 'number', 123.45, 123.45 ); check_check( 'number', '8.7E3', '8.7E3' ); check_check( 'number', '-8.7e3', '-8.7e3' ); check_check( 'number', '123.4.5', undef, 0, $errmsg ); check_check( 'number', 'foo', undef, 0, $errmsg ); check_check( 'number', '123-456', undef, 0, $errmsg ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # number::integer $errmsg = qr/William Blake must be an integer./; check_check( 'number::integer', 0, 0 ); check_check( 'number::integer', 0, 0 ); check_check( 'number::integer', -0, -0 ); check_check( 'number::integer', 123, 123 ); check_check( 'number::integer', -123, -123 ); check_check( 'number::integer', +123, +123 ); check_check( 'number::integer', 123.45, undef, 0, $errmsg ); check_check( 'number::integer', '8.7E3', undef, 0, $errmsg ); check_check( 'number::integer', '-8.7e3', undef, 0, $errmsg ); check_check( 'number::integer', '123.4.5', undef, 0, $errmsg ); check_check( 'number::integer', 'foo', undef, 0, $errmsg ); check_check( 'number::integer', '123-456', undef, 0, $errmsg ); check_check( 'number::integer', '.5', undef, 0, $errmsg ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # number::decimal $errmsg = qr/William Blake must be a decimal number./; check_check( 'number::decimal', 0, 0 ); check_check( 'number::decimal', 0, 0 ); check_check( 'number::decimal', -0, -0 ); check_check( 'number::decimal', 123, 123 ); check_check( 'number::decimal', -123, -123 ); check_check( 'number::decimal', +123, +123 ); check_check( 'number::decimal', 123.45, 123.45 ); check_check( 'number::decimal', '8.7E3', undef, 0, $errmsg ); check_check( 'number::decimal', '-8.7e3', undef, 0, $errmsg ); check_check( 'number::decimal', '123.4.5', undef, 0, $errmsg ); check_check( 'number::decimal', 'foo', undef, 0, $errmsg ); check_check( 'number::decimal', '123-456', undef, 0, $errmsg ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # number::decimal sub errormsg { my @values = @_; my $out = 'William Blake: "' . join( ', ', @values ); $out .=(@values > 1) ? '" are not positive integers.' : '" is not a positive integer.'; return $out; } is( errormsg( -5, -10, 'uhg' ), 'William Blake: "-5, -10, uhg" are not positive integers.' ); is( errormsg( -5 ), 'William Blake: "-5" is not a positive integer.' ); check_check( 'number::positive_list', 0, 0 ); check_check( 'number::positive_list', '1,-1,5', undef, 0, errormsg( '-1' )); check_check( 'number::positive_list', '1,-0,5', undef, 0, errormsg( '-0' )); check_check( 'number::positive_list', '5,10,100', '5, 10, 100' ); check_check( 'number::positive_list', '1,-5,-10,-100,5', undef, 0, errormsg( -5, -10, -100 )); check_check( 'number::positive_list', '-5', undef, 0, errormsg( -5 )); check_check( 'number::positive_list', '5, 10, 100', '5, 10, 100' ); check_check( 'number::positive_list', '1, -5, -10, -100, 5', undef, 0, errormsg( -5, -10, -100 )); check_check( 'number::positive_list', '5 , 10 , 100', '5, 10, 100' ); check_check( 'number::positive_list', '1 , -5 , -10 , -100 , 5', undef, 0, errormsg( -5, -10, -100 )); check_check( 'number::positive_list', 'bob', undef, 0, errormsg( 'bob' )); check_check( 'number::positive_list', 'bob, fred', undef, 0, errormsg( 'bob', 'fred' )); # vim:ft=perl CGI-ValidOp-0.56/t/20check_required_if.t0000644000175000017550000000127611304772200017556 0ustar exodistexodist#!/usr/bin/perl -T use warnings; use strict; use lib qw/ t lib /; use CGI::ValidOp::Test; use CGI::ValidOp; use Test::More tests => 19; use vars qw/ $one $errmsg /; use Data::Dumper; use Test::Taint; BEGIN { use_ok( 'CGI::ValidOp::Param' )} $ENV{REQUEST_METHOD} = 'GET'; $ENV{QUERY_STRING} = 'fake_param=1'; # both unset check_check( 'required_if(no_param)', undef, undef, 0, undef ); # dependant set, predicate unset check_check( 'required_if(no_param)', 'hello', undef, 0, undef ); # predicate set, dependant unset check_check( 'required_if(fake_param)', undef, undef, 0, 'William Blake is required.' ); # both set check_check( 'required_if(fake_param)', 'hello', 'hello', 0, undef ); CGI-ValidOp-0.56/t/16check_date.t0000755000175000017550000002727111304772200016210 0ustar exodistexodist#!/usr/bin/perl -T use warnings; use strict; use lib qw/ t lib /; use CGI::ValidOp::Test; use Test::More tests => 607; use vars qw/ $one $errmsg /; use Data::Dumper; use Test::Taint; use CGI::ValidOp::Check::date; BEGIN { use_ok( 'CGI::ValidOp::Param' )} # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # check__format methods is(CGI::ValidOp::Check::date::check_iso_format(undef), undef); is(CGI::ValidOp::Check::date::check_iso_format(''), undef); is_deeply( [ CGI::ValidOp::Check::date::check_iso_format('2006-06-01') ], [ '2006', '06', '01'] ); is(CGI::ValidOp::Check::date::check_iso_format('5/5/2005'), undef); is(CGI::ValidOp::Check::date::check_american_format(undef), undef); is(CGI::ValidOp::Check::date::check_american_format(''), undef); is_deeply( [ CGI::ValidOp::Check::date::check_american_format('5/6/2005') ], ['2005', '5', '6'] ); is(CGI::ValidOp::Check::date::check_american_format('2005-05-06'), undef); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # tests for day/month/year element check methods is(CGI::ValidOp::Check::date::check_year(undef), undef); is(CGI::ValidOp::Check::date::check_year(''), 0); is(CGI::ValidOp::Check::date::check_year('2000'), 1); #Requiring 4 digit years, otherwise we have to figure out #if 02 is 1902 or 2002 or the 2nd year of our lord... is(CGI::ValidOp::Check::date::check_year('02'), 0); is(CGI::ValidOp::Check::date::check_month(undef), undef); is(CGI::ValidOp::Check::date::check_month('-1'), 0); is(CGI::ValidOp::Check::date::check_month('+1'), 0); is(CGI::ValidOp::Check::date::check_month('0'), 0); is(CGI::ValidOp::Check::date::check_month('1'), 1); is(CGI::ValidOp::Check::date::check_month('01'), 1); is(CGI::ValidOp::Check::date::check_month('12'), 1); is(CGI::ValidOp::Check::date::check_month('13'), 0); is(CGI::ValidOp::Check::date::check_day(undef), undef); is(CGI::ValidOp::Check::date::check_day('1', undef), undef); is(CGI::ValidOp::Check::date::check_day('1','2',undef), undef); is(CGI::ValidOp::Check::date::check_day('0','1',undef), 0); is(CGI::ValidOp::Check::date::check_day('-1','1',undef), 0); is(CGI::ValidOp::Check::date::check_day('+1','1',undef), 0); is(CGI::ValidOp::Check::date::check_day('31','1',undef), 1); is(CGI::ValidOp::Check::date::check_day('32','1',undef), 0); is(CGI::ValidOp::Check::date::check_day('28','2','1999'), 1); is(CGI::ValidOp::Check::date::check_day('29','2','1991'), 0); is(CGI::ValidOp::Check::date::check_day('29','2','2000'), 1); is(CGI::ValidOp::Check::date::check_day('30','2','2000'), 0); is(CGI::ValidOp::Check::date::check_day('31','3',undef), 1); is(CGI::ValidOp::Check::date::check_day('32','3',undef), 0); is(CGI::ValidOp::Check::date::check_day('30','4',undef), 1); is(CGI::ValidOp::Check::date::check_day('31','4',undef), 0); is(CGI::ValidOp::Check::date::check_day('31','5',undef), 1); is(CGI::ValidOp::Check::date::check_day('32','5',undef), 0); is(CGI::ValidOp::Check::date::check_day('30','6',undef), 1); is(CGI::ValidOp::Check::date::check_day('31','6',undef), 0); is(CGI::ValidOp::Check::date::check_day('31','7',undef), 1); is(CGI::ValidOp::Check::date::check_day('32','7',undef), 0); is(CGI::ValidOp::Check::date::check_day('31','8',undef), 1); is(CGI::ValidOp::Check::date::check_day('32','8',undef), 0); is(CGI::ValidOp::Check::date::check_day('30','9',undef), 1); is(CGI::ValidOp::Check::date::check_day('31','9',undef), 0); is(CGI::ValidOp::Check::date::check_day('31','10',undef), 1); is(CGI::ValidOp::Check::date::check_day('32','10',undef), 0); is(CGI::ValidOp::Check::date::check_day('30','11',undef), 1); is(CGI::ValidOp::Check::date::check_day('31','11',undef), 0); is(CGI::ValidOp::Check::date::check_day('31','12',undef), 1); is(CGI::ValidOp::Check::date::check_day('32','12',undef), 0); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # tests for date::general check_check( 'date::general', undef, undef, 0); check_check( 'date::general', '2005', undef, 0); check_check( 'date::general', '31-3-1999', undef, 0); check_check( 'date::general', '3-31', undef, 0); check_check( 'date::general', '10-5-2006', '2006-10-05'); check_check( 'date::general', '2004-1-31', '2004-01-31' ); check_check( 'date::general', '2004-02-29', '2004-02-29' ); check_check( 'date::general', '2004-3-31', '2004-03-31' ); check_check( 'date::general', '2004-4-30', '2004-04-30' ); check_check( 'date::general', '2004-5-31', '2004-05-31' ); check_check( 'date::general', '1-1-1999', '1999-01-01'); check_check( 'date::general', '1-1-1900', '1900-01-01'); check_check( 'date::general', '1-15-1945', '1945-01-15'); check_check( 'date::general', '02-03-1345', '1345-02-03'); check_check( 'date::general', '2/29/2000', '2000-02-29'); check_check( 'date::general', '2/30/2000', undef, 0); check_check( 'date::general', '9/31/1922', undef, 0); check_check( 'date::general', 'a date 9/31/1922', undef, 0); check_check( 'date::general', '9 - 31 - 1922', undef, 0); check_check( 'date::general', '9/31/1922withstuff', undef, 0); check_check( 'date::general', '9/31/1922 other stuff', undef, 0); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # tests for date::american check_check( 'date::american', undef, undef, 0); check_check( 'date::american', '2005', undef, 0); check_check( 'date::american', '31-3-1999', undef, 0); check_check( 'date::american', '3-31', undef, 0); check_check( 'date::american', '10-5-2006', '2006-10-05'); check_check( 'date::american', '1-1-1999', '1999-01-01'); check_check( 'date::american', '1-1-1900', '1900-01-01'); check_check( 'date::american', '1-15-1945', '1945-01-15'); check_check( 'date::american', '02-03-1345', '1345-02-03'); check_check( 'date::american', '2/29/2000', '2000-02-29'); check_check( 'date::american', '2/30/2000', undef, 0); check_check( 'date::american', '9/31/1922', undef, 0); check_check( 'date::american', 'a date 9/31/1922', undef, 0); check_check( 'date::american', '9 - 31 - 1922', undef, 0); check_check( 'date::american', '9/31/1922withstuff', undef, 0); check_check( 'date::american', '9/31/1922 other stuff', undef, 0); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # iso my $errmsg = 'William Blake must include year, month, and date as YYYY-MM-DD'; check_check( 'date::iso', undef, undef, 0 ); check_check( 'date::iso', 10, undef, 0, $errmsg ); check_check( 'date::iso', '2004', undef, 0, $errmsg ); check_check( 'date::iso', '2004-10', undef, 0, $errmsg ); check_check( 'date::iso', 'y-1-1', undef, 0, $errmsg ); check_check( 'date::iso', '1-m-1', undef, 0, $errmsg ); check_check( 'date::iso', '1-1-d', undef, 0, $errmsg ); check_check( 'date::iso', '2004-13-1', undef, 0, $errmsg ); check_check( 'date::iso', '2004-0-1', undef, 0, $errmsg ); check_check( 'date::iso', '2004-1-0', undef, 0, $errmsg ); check_check( 'date::iso', '2004-1-32', undef, 0, $errmsg ); check_check( 'date::iso', '2004-2-30', undef, 0, $errmsg ); check_check( 'date::iso', '2004-3-32', undef, 0, $errmsg ); check_check( 'date::iso', '2004-4-31', undef, 0, $errmsg ); check_check( 'date::iso', '2004-5-32', undef, 0, $errmsg ); check_check( 'date::iso', '2004-6-31', undef, 0, $errmsg ); check_check( 'date::iso', '2004-7-32', undef, 0, $errmsg ); check_check( 'date::iso', '2004-8-32', undef, 0, $errmsg ); check_check( 'date::iso', '2004-9-31', undef, 0, $errmsg ); check_check( 'date::iso', '2004-10-32', undef, 0, $errmsg ); check_check( 'date::iso', '2004-11-31', undef, 0, $errmsg ); check_check( 'date::iso', '2004-12-32', undef, 0, $errmsg ); check_check( 'date::iso', '2004-1-31', '2004-01-31' ); check_check( 'date::iso', '2004-2-29', '2004-02-29' ); check_check( 'date::iso', '2004-3-31', '2004-03-31' ); check_check( 'date::iso', '2004-4-30', '2004-04-30' ); check_check( 'date::iso', '2004-5-31', '2004-05-31' ); check_check( 'date::iso', '2004-6-30', '2004-06-30' ); check_check( 'date::iso', '2004-7-31', '2004-07-31' ); check_check( 'date::iso', '2004-8-31', '2004-08-31' ); check_check( 'date::iso', '2004-9-30', '2004-09-30' ); check_check( 'date::iso', '2004-10-31', '2004-10-31' ); check_check( 'date::iso', '2004-11-30', '2004-11-30' ); check_check( 'date::iso', '2004-12-31', '2004-12-31' ); check_check( 'date::iso', '1900-2-28', '1900-02-28' ); check_check( 'date::iso', '1900-2-29', undef, 0, $errmsg ); check_check( 'date::iso', '1904-2-28', '1904-02-28' ); check_check( 'date::iso', '1904-2-29', '1904-02-29' ); check_check( 'date::iso', '1996-2-28', '1996-02-28' ); check_check( 'date::iso', '1996-2-29', '1996-02-29' ); check_check( 'date::iso', '1997-2-28', '1997-02-28' ); check_check( 'date::iso', '1997-2-29', undef, 0, $errmsg ); check_check( 'date::iso', '2000-2-28', '2000-02-28' ); check_check( 'date::iso', '2000-2-29', '2000-02-29' ); check_check( 'date::iso', '2002-2-28', '2002-02-28' ); check_check( 'date::iso', '2002-2-29', undef, 0, $errmsg ); check_check( 'date::iso', '2003-2-28', '2003-02-28' ); check_check( 'date::iso', '2003-2-29', undef, 0, $errmsg ); check_check( 'date::iso', '2005-2-28', '2005-02-28' ); check_check( 'date::iso', '2005-2-29', undef, 0, $errmsg ); #Not a valid time, should ignore check_check( 'date::iso(bob)', '2005-2-28', '2005-02-28' ); sub format_date { my ( $vectors ) = @_; my @date = ( $vectors->{ year }, $vectors->{ month }, $vectors->{ day }); # Make sure each section is at least 2 characters long @date = map { (length( "$_" ) - 1) ? $_ : "0$_" } @date; return join( "-", @date ); } my ( $y, $m, $d ) = CGI::ValidOp::Check::date::today(); my %time_diff = ( past => -1, present => 0, future => 1, ); for my $time ( qw/ past present future /) { my $diff = $time_diff{$time}; for my $vector ( qw/ year month day /) { my $vectors = { year => $y, month => $m, day => $d, }; $vectors->{ $vector } += $diff; # Normlize # Unless we are checking the present or yesterday, assume the biggest day of the month is 28 my $maxday = ( $time eq 'present' or ( $time eq 'past' and $vector eq 'day' ) ) ? 31 : 28; if ( $vectors->{ day } > $maxday ) { $vectors->{ day } = 1; $vectors->{ month }++; } if ( $vectors->{ day } < 1 ) { $vectors->{ day } = $maxday; $vectors->{ month }--; } if ( $vectors->{ month } > 12 ) { $vectors->{ month } = 1; $vectors->{ year }++; } if ( $vectors->{ month } < 1 ) { $vectors->{ month } = 12; $vectors->{ year }--; } check_check( 'date::iso(' . $time . ')', format_date( $vectors ), format_date( $vectors ) ); for my $check ( qw/ past present future /) { next if $check eq $time; check_check( 'date::iso(' . $check . ')', format_date( $vectors ), undef, 0, "William Blake cannot be in the " . $time ); } } } # vim:ft=perl CGI-ValidOp-0.56/t/11check_length.t0000755000175000017550000000332411304772200016540 0ustar exodistexodist#!/usr/bin/perl -T use warnings; use strict; use lib qw/ t lib /; use CGI::ValidOp::Test; use Test::More tests => 112; use vars qw/ $errmsg /; use Data::Dumper; use Test::Taint; BEGIN { use_ok( 'CGI::ValidOp::Param' )} # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # length check_check( 'length', 123, 123, 'taint' ); check_check( 'length(0)', 123, 123, 'taint' ); check_check( 'length(0,0)', 123, 123, 'taint' ); check_check( 'length(3)', 12, undef, 0, 'length must be exactly 3' ); check_check( 'length(3)', 123, 123, 'taint' ); check_check( 'length(3)', 1234, undef, 0, 'length must be exactly 3' ); check_check( 'length(3,3)', 12, undef, 0, 'length must be exactly 3' ); check_check( 'length(3,3)', 123, 123, 'taint' ); check_check( 'length(3,3)', 1234, undef, 0, 'length must be exactly 3' ); check_check( 'length(0,3)', 12, 12, 'taint' ); check_check( 'length(0,3)', 123, 123, 'taint' ); check_check( 'length(0,3)', 1234, undef, 0, 'length must be at most 3' ); check_check( 'length(3,0)', 12, undef, 0, 'length must be at least 3' ); check_check( 'length(3,0)', 123, 123, 'taint' ); check_check( 'length(3,0)', 1234, 1234, 'taint' ); check_check( 'length(3,6)', 12, undef, 0, 'length must be between 3 and 6' ); check_check( 'length(3,6)', 123, 123, 'taint' ); check_check( 'length(3,6)', 1234, 1234, 'taint' ); check_check( 'length(3,6)', 12345, 12345, 'taint' ); check_check( 'length(3,6)', 123456, 123456, 'taint' ); check_check( 'length(3,6)', 1234567, undef, 0, 'length must be between 3 and 6' ); check_check( 'length(6,3)', 123, 'DIE', 0, "Length 'min' must be less than 'max.'" ); # vim:ft=perl CGI-ValidOp-0.56/t/99workflow1.t0000755000175000017550000001435211304772200016100 0ustar exodistexodist#!/usr/bin/perl -T use strict; use warnings; use lib qw/ t lib /; use CGI::ValidOp::Test; use Test::More tests => 69; use vars qw/ $one /; use Data::Dumper; BEGIN { use_ok( 'CGI::ValidOp' )} # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # workflow 1, no params defined $one = init_obj; is( $one->cgi_object->param('item'), 'Cat food' ); is( $one->op, 'default' ); is( $one->param( 'item' ), 'Cat food' ); is( $one->param( 'price' ), '10.99' ); is( $one->param( 'shipping' ), 'FedEx' ); is( $one->param( 'unexpect' ), 'I am the slime' ); is( $one->param( 'comment' ), "Now is the time for\nall good men\nto come to the aid" ); is( $one->param( 'checkme' ), 'ON' ); is( $one->param( 'donotcheckme' ), undef ); is( $one->param( 'client_email' ), 'whitemice@hyperintelligent_pandimensional_beings.com' ); is( $one->param( 'no_client' ), 1 ); is( $one->param( 'client' ), 'disappear' ); #no alternative check specified is( $one->param( 'client', [ 'alternative(no_client)' ]), undef ); is_deeply( $one->param( 'multi' ), [ qw/ banana orange plum /]); is( $one->param( 'crackme' ), undef ); is_deeply({ $one->Vars }, { name => 'Mouse-a-meal', checkme => 'ON', comment => "Now is the time for\nall good men\nto come to the aid", crackme => undef, date => '2004-09-29', donotcheckme => undef, item => 'Cat food', multi => [ qw/ banana orange plum /], notdefined => undef, price => '10.99', shipping => 'FedEx', unexpect => 'I am the slime', xssme => undef, no_client => 1, client_email => 'whitemice@hyperintelligent_pandimensional_beings.com', client => undef, }); is( @{ $one->errors }, 2 ); like( @{ $one->errors }[ 0 ], qr/Only letters, numbers, and/ ); like( @{ $one->errors }[ 1 ], qr/Only letters, numbers, and/ ); $one->allow_unexpected( 0 ); is( $one->op, 'default' ); is( $one->param( 'crackme' ), undef ); is( $one->param( 'item' ), undef ); is( $one->param( 'price' ), undef ); is( $one->param( 'shipping' ), undef ); is( $one->param( 'unexpect' ), undef ); is( $one->Vars, undef ); is( $one->errors, undef ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # allow unexpected $one->allow_unexpected( 1 ); is( $one->param( 'comment' ), "Now is the time for\nall good men\nto come to the aid" ); is( $one->param( 'crackme' ), undef ); is( $one->param( 'item' ), 'Cat food' ); is( $one->param( 'price' ), '10.99' ); is( $one->param( 'shipping' ), 'FedEx' ); is( $one->param( 'unexpect' ), 'I am the slime' ); is( $one->param( 'client_email' ), 'whitemice@hyperintelligent_pandimensional_beings.com' ); is( $one->param( 'no_client' ), 1 ); is( $one->param( 'client' ), 'disappear' ); #no alternative check specified is( $one->param( 'client', [ 'alternative(no_client)' ]), undef ); is_deeply( $one->param( 'multi' ), [ qw/ banana orange plum /]); is_deeply( { $one->Vars }, { name => 'Mouse-a-meal', checkme => 'ON', comment => "Now is the time for\nall good men\nto come to the aid", crackme => undef, date => '2004-09-29', donotcheckme => undef, item => 'Cat food', multi => [ qw/ banana orange plum /], notdefined => undef, price => '10.99', shipping => 'FedEx', unexpect => 'I am the slime', xssme => undef, no_client => 1, client_email => 'whitemice@hyperintelligent_pandimensional_beings.com', client => undef, }); is( @{ $one->errors }, 2 ); like( @{ $one->errors }[ 0 ], qr/Only letters, numbers, and/ ); like( @{ $one->errors }[ 1 ], qr/Only letters, numbers, and/ ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # do not allow unexpected $one->allow_unexpected( 0 ); is( $one->param( 'crackme' ), undef ); is( $one->param( 'item' ), undef ); is( $one->param( 'price' ), undef ); is( $one->param( 'shipping' ), undef ); is( $one->param( 'unexpect' ), undef ); is( $one->Vars, undef ); is( $one->errors, undef ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # on error return encoded $one = init_obj({ -on_error_return_encoded => 1 }); $one->allow_unexpected( 1 ); is( $one->on_error_return_encoded, 1 ); is( $one->param( 'comment' ), "Now is the time for\nall good men\nto come to the aid" ); is( $one->param( 'crackme' ), '$ENV{ meat_of_evil }' ); is( $one->param( 'item' ), 'Cat food' ); is( $one->param( 'price' ), '10.99' ); is( $one->param( 'shipping' ), 'FedEx' ); is( $one->param( 'unexpect' ), 'I am the slime' ); is( $one->param( 'xssme' ), '<script>alert("haxored")</script>' ); is( $one->param( 'client_email' ), 'whitemice@hyperintelligent_pandimensional_beings.com' ); is( $one->param( 'no_client' ), 1 ); is( $one->param( 'client' ), 'disappear' ); #No alternative check specified is( $one->param( 'client', [ 'alternative(no_client)' ]), undef ); is_deeply( $one->param( 'multi' ), [ qw/ banana orange plum /]); is_deeply( { $one->Vars }, { name => 'Mouse-a-meal', checkme => 'ON', comment => "Now is the time for\nall good men\nto come to the aid", crackme => '$ENV{ meat_of_evil }', date => '2004-09-29', donotcheckme => undef, item => 'Cat food', multi => [ qw/ banana orange plum /], notdefined => undef, price => '10.99', shipping => 'FedEx', unexpect => 'I am the slime', xssme => '<script>alert("haxored")</script>', no_client => 1, client_email => 'whitemice@hyperintelligent_pandimensional_beings.com', client => undef, }); is( @{ $one->errors }, 2 ); like( @{ $one->errors }[ 0 ], qr/Only letters, numbers, and/ ); like( @{ $one->errors }[ 1 ], qr/Only letters, numbers, and/ ); # vim:ft=perl CGI-ValidOp-0.56/t/99workflow2.t0000755000175000017550000000654311304772200016104 0ustar exodistexodist#!/usr/bin/perl -T use strict; use warnings; use lib qw/ t lib /; use CGI::ValidOp::Test; use Test::More tests => 33; use vars qw/ $one /; use Data::Dumper; BEGIN { use_ok( 'CGI::ValidOp' )} # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # workflow 2, params called with checks 'on-the-fly' $one = init_obj({ -error_decoration => '"', }); is( $one->param( 'comment' ), "Now is the time for\nall good men\nto come to the aid" ); is( $one->param( 'crackme', [ 'required', 'text' ]), undef ); is( $one->param( 'foobar', [ 'required' ]), undef ); is( $one->param( 'item', [ 'required', 'text' ]), 'Cat food' ); is( $one->param( 'price', [ 'required' ]), '10.99' ); is( $one->param( 'shipping', [ 'required' ]), 'FedEx' ); is( $one->param( 'notdefined', [ 'required' ]), undef ); is( $one->param( 'unexpect' ), 'I am the slime' ); is( $one->param( 'client_email' ), 'whitemice@hyperintelligent_pandimensional_beings.com' ); is( $one->param( 'no_client' ), 1 ); is( $one->param( 'client' ), 'disappear' ); #No check is( $one->param( 'client', [ 'alternative(no_client)' ] ), undef ); is( $one->param( 'donotcheckme', [ 'checkbox::boolean' ]), 0 ); is_deeply( $one->param( 'multi' ), [ qw/ banana orange plum /]); is_deeply( { $one->Vars }, { name => 'Mouse-a-meal', checkme => 'ON', comment => "Now is the time for\nall good men\nto come to the aid", crackme => undef, date => '2004-09-29', donotcheckme => 0, foobar => undef, item => 'Cat food', multi => [ qw/ banana orange plum /], notdefined => undef, price => '10.99', shipping => 'FedEx', unexpect => 'I am the slime', xssme => undef, no_client => 1, client_email => 'whitemice@hyperintelligent_pandimensional_beings.com', client => undef, }); is( @{ $one->errors }, 3 ); like( @{ $one->errors }[ 0 ], qr/"foobar" is required/ ); like( @{ $one->errors }[ 1 ], qr/Only letters, numbers, and/ ); like( @{ $one->errors }[ 2 ], qr/Only letters, numbers, and/ ); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # do not allow unexpected $one->allow_unexpected( 0 ); is( $one->param( 'comment', [ 'text' ] ), "Now is the time for\nall good men\nto come to the aid" ); is( $one->param( 'crackme', [ 'required', 'text' ]), undef ); is( $one->param( 'foobar', [ 'required' ]), undef ); is( $one->param( 'item', [ 'required', 'text' ]), 'Cat food' ); is( $one->param( 'price', [ 'required' ]), '10.99' ); is( $one->param( 'shipping', [ 'required' ]), 'FedEx' ); is( $one->param( 'unexpect' ), undef ); is_deeply( $one->param( 'multi', [ 'text' ] ), [ qw/ banana orange plum /]); is_deeply( { $one->Vars }, { comment => "Now is the time for\nall good men\nto come to the aid", crackme => undef, foobar => undef, item => 'Cat food', multi => [ qw/ banana orange plum /], price => '10.99', shipping => 'FedEx', }); is( @{ $one->errors }, 2 ); like( @{ $one->errors }[ 0 ], qr/"foobar" is required/ ); like( @{ $one->errors }[ 1 ], qr/Only letters, numbers, and/ ); # vim:ft=perl CGI-ValidOp-0.56/t/99workflow3.t0000755000175000017550000000324511304772200016101 0ustar exodistexodist#!/usr/bin/perl -T use strict; use warnings; use lib qw/ t lib /; use CGI::ValidOp::Test; use Test::More tests => 23; use vars qw/ $one /; use Data::Dumper; BEGIN { use_ok( 'CGI::ValidOp' )} # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # workflow 3, params added individually $one = init_obj; $one->allow_unexpected( 0 ); ok( $one->add_param( 'name' )); ok( $one->add_param( 'item' )); ok( $one->add_param( 'multi' )); ok( $one->add_param( 'price' )); ok( $one->add_param( 'shipping' )); ok( $one->add_param( 'client_email' )); ok( $one->add_param( 'no_client' )); ok( $one->add_param( 'client' )); is( $one->param( 'name' ), 'Mouse-a-meal' ); is( $one->param( 'crackme' ), undef ); is( $one->param( 'item' ), 'Cat food' ); is( $one->param( 'price' ), '10.99' ); is( $one->param( 'shipping' ), 'FedEx' ); is( $one->param( 'unexpect' ), undef ); is( $one->param( 'client' ), 'disappear' ); #no check is( $one->param( 'client', [ 'alternative(no_client)' ] ), undef ); is( $one->param( 'no_client' ), 1 ); is( $one->param( 'client_email' ), 'whitemice@hyperintelligent_pandimensional_beings.com' ); is_deeply( $one->param( 'multi', [ 'text' ] ), [ qw/ banana orange plum /]); is_deeply( { $one->Vars }, { name => 'Mouse-a-meal', item => 'Cat food', multi => [ qw/ banana orange plum /], price => '10.99', shipping => 'FedEx', client => undef, no_client => 1, client_email => 'whitemice@hyperintelligent_pandimensional_beings.com', }); is( $one->errors, undef ); # vim:ft=perl CGI-ValidOp-0.56/t/99workflow4.t0000755000175000017550000000715411304772200016105 0ustar exodistexodist#!/usr/bin/perl -T use strict; use warnings; use lib qw/ t lib /; use CGI::ValidOp::Test; use Test::More tests => 30; use vars qw/ $one /; use Data::Dumper; BEGIN { use_ok( 'CGI::ValidOp' )} # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # workflow 4, params created at start $one = init_obj({ add => { comment => [ 'Comment text', 'required', 'text'], item => [ 'item name', 'required', 'text' ], multi => [ 'Multiple parameters', 'required', 'text' ], price => [ 'item number', 'required', 'text' ], shipping => [ 'shipping method', 'required', 'text'], donotcheckme => [ 'Do not check me', 'checkbox::boolean' ], client => [ 'client name', 'alternative(no_client)' ], client_email => [ 'client_email', 'email' ], no_client => [ 'no client' ], }, }); is( $one->param( 'comment', [ 'text' ] ), "Now is the time for\nall good men\nto come to the aid" ); is( $one->param( 'crackme' ), undef ); is( $one->param( 'item' ), 'Cat food' ); is( $one->param( 'price' ), '10.99' ); is( $one->param( 'shipping' ), 'FedEx' ); is( $one->param( 'unexpect' ), 'I am the slime' ); is( $one->param( 'checkme' ), 'ON' ); is( $one->param( 'client' ), undef ); is( $one->param( 'client_email' ), 'whitemice@hyperintelligent_pandimensional_beings.com' ); is_deeply( $one->param( 'multi', [ 'text' ] ), [ qw/ banana orange plum /]); is_deeply( { $one->Vars }, { name => 'Mouse-a-meal', checkme => 'ON', comment => "Now is the time for\nall good men\nto come to the aid", crackme => undef, date => '2004-09-29', donotcheckme => 0, item => 'Cat food', multi => [ qw/ banana orange plum /], notdefined => undef, price => '10.99', shipping => 'FedEx', unexpect => 'I am the slime', xssme => undef, client => undef, no_client => 1, client_email => 'whitemice@hyperintelligent_pandimensional_beings.com', }); is( @{ $one->errors }, 2 ); like( @{ $one->errors }[ 0 ], qr/Only letters, numbers, and/ ); like( @{ $one->errors }[ 1 ], qr/Only letters, numbers, and/ ); # add arbitrary errors $one->Op->Param( 'crackme' )->add_error( 'fooby', '$label must be fooby!' ); is( @{ $one->errors }, 3 ); like( @{ $one->errors }[ 0 ], qr/Only letters, numbers, and/ ); like( @{ $one->errors }[ 1 ], qr/Only letters, numbers, and/ ); like( @{ $one->errors }[ 2 ], qr/must be fooby/ ); $one->allow_unexpected( 0 ); is( $one->param( 'comment', [ 'text' ] ), "Now is the time for\nall good men\nto come to the aid" ); is( $one->param( 'crackme' ), undef ); is( $one->param( 'item' ), 'Cat food' ); is( $one->param( 'price' ), '10.99' ); is( $one->param( 'shipping' ), 'FedEx' ); is( $one->param( 'unexpect' ), undef ); ok( ! $one->param( 'checkme' )); is_deeply( $one->param( 'multi', [ 'text' ] ), [ qw/ banana orange plum /]); is_deeply( { $one->Vars }, { comment => "Now is the time for\nall good men\nto come to the aid", donotcheckme => 0, item => 'Cat food', multi => [ qw/ banana orange plum /], price => '10.99', shipping => 'FedEx', client => undef, no_client => 1, client_email => 'whitemice@hyperintelligent_pandimensional_beings.com', }); is( $one->errors, undef ); # vim:ft=perl CGI-ValidOp-0.56/t/99workflow5.t0000644000175000017550000000601511310300651016070 0ustar exodistexodistuse constant TESTS => 22; #=============================================================================== # # FILE: 99workflow5.t # # DESCRIPTION: Tests the objects functionality in a workflow-style fashion. # Greatly mimics elements from eMC. # # FILES: --- # BUGS: --- # NOTES: --- # AUTHOR: Erik Hollensbe (), # COMPANY: # VERSION: 1.0 # CREATED: 01/15/2008 06:17:20 AM PST # REVISION: $Id$ #=============================================================================== use strict; use warnings; use Test::More tests => TESTS; # see line 1 use CGI::ValidOp::Test; use_ok('CGI::ValidOp'); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $obj = init_obj_via_cgi_pm( { op => 'add', 'object--stuff--0--name' => '123 Foobar', 'object--stuff--0--item' => '8675309', 'object--stuff--0--number' => 'Funkytown', 'object--stuff--0--shipping' => 'PA', 'object--stuff--0--client_email' => 'shorts@shorts.com', 'object--stuff--0--client' => 'bob', 'object--stuff--0--no_client' => 0, }, $ops2 ); isa_ok($obj, 'CGI::ValidOp'); ok ($obj->objects('stuff')); isa_ok($obj->objects('stuff')->[0], 'HASH'); is_deeply($obj->objects('stuff')->[0], { name => '123 Foobar', item => '8675309', number => 'Funkytown', shipping => 'PA', client => 'bob', no_client => 0, client_email => 'shorts@shorts.com', } ); SKIP: { skip "no Loompa", 17 unless eval { require Loompa; 1 }; package Stuff; our @ISA = qw(Loompa); sub methods { [qw(name item number shipping client client_email no_client)] } package main; # test constructing an object $obj = init_obj_via_cgi_pm( { op => 'add', 'object--stuff--0--name' => '123 Foobar', 'object--stuff--0--item' => '8675309', 'object--stuff--0--number' => 'Funkytown', 'object--stuff--0--shipping' => 'PA', 'object--stuff--0--client_email' => 'shorts@shorts.com', 'object--stuff--0--client' => 'bob', 'object--stuff--0--no_client' => 0, }, $ops3 ); isa_ok($obj, 'CGI::ValidOp'); ok($obj->objects('stuff')); isa_ok($obj->objects('stuff')->[0], 'Stuff'); my $stuff = $obj->objects('stuff')->[0]; can_ok($stuff, 'name'); can_ok($stuff, 'number'); can_ok($stuff, 'item'); can_ok($stuff, 'shipping'); can_ok($stuff, 'client'); can_ok($stuff, 'client_email'); can_ok($stuff, 'no_client'); is($stuff->name, '123 Foobar'); is($stuff->item, '8675309'); is($stuff->number, 'Funkytown'); is($stuff->shipping, 'PA'); is($stuff->client, 'bob'); is($stuff->no_client, 0); is($stuff->client_email, 'shorts@shorts.com'); } CGI-ValidOp-0.56/t/99workflow6.t0000644000175000017550000000563511310300672016103 0ustar exodistexodistuse constant TESTS => 22; #=============================================================================== # # FILE: 99workflow5.t # # DESCRIPTION: Tests the objects functionality in a workflow-style fashion. # Greatly mimics elements from eMC. # # FILES: --- # BUGS: --- # NOTES: --- # AUTHOR: Erik Hollensbe (), # COMPANY: # VERSION: 1.0 # CREATED: 01/15/2008 06:17:20 AM PST # REVISION: $Id$ #=============================================================================== use strict; use warnings; use Test::More tests => TESTS; # see line 1 use CGI::ValidOp::Test; use_ok('CGI::ValidOp'); #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ my $obj = init_obj_via_cgi_pm( { op => 'add', 'stuff[0][name]' => '123 Foobar', 'stuff[0][item]' => '8675309', 'stuff[0][number]' => 'Funkytown', 'stuff[0][shipping]' => 'PA', 'stuff[0][client_email]' => 'shorts@shorts.com', 'stuff[0][client]' => 'bob', 'stuff[0][no_client]' => 0, }, $ops2 ); isa_ok($obj, 'CGI::ValidOp'); ok ($obj->objects('stuff')); isa_ok($obj->objects('stuff')->[0], 'HASH'); is_deeply($obj->objects('stuff')->[0], { name => '123 Foobar', item => '8675309', number => 'Funkytown', shipping => 'PA', client => 'bob', no_client => 0, client_email => 'shorts@shorts.com', } ); SKIP: { skip "no Loompa", 17 unless eval { require Loompa; 1 }; package Stuff; our @ISA = qw(Loompa); sub methods { [qw(name item number shipping client client_email no_client)] } package main; # test constructing an object $obj = init_obj_via_cgi_pm( { op => 'add', 'stuff[0][name]' => '123 Foobar', 'stuff[0][item]' => '8675309', 'stuff[0][number]' => 'Funkytown', 'stuff[0][shipping]' => 'PA', 'stuff[0][client_email]' => 'shorts@shorts.com', 'stuff[0][client]' => 'bob', 'stuff[0][no_client]' => 0, }, $ops3 ); isa_ok($obj, 'CGI::ValidOp'); ok($obj->objects('stuff')); isa_ok($obj->objects('stuff')->[0], 'Stuff'); my $stuff = $obj->objects('stuff')->[0]; can_ok($stuff, 'name'); can_ok($stuff, 'number'); can_ok($stuff, 'item'); can_ok($stuff, 'shipping'); can_ok($stuff, 'client'); can_ok($stuff, 'client_email'); can_ok($stuff, 'no_client'); is($stuff->name, '123 Foobar'); is($stuff->item, '8675309'); is($stuff->number, 'Funkytown'); is($stuff->shipping, 'PA'); is($stuff->client, 'bob'); is($stuff->no_client, 0); is($stuff->client_email, 'shorts@shorts.com'); } CGI-ValidOp-0.56/bin/0000755000175000017550000000000011310301055014064 5ustar exodistexodistCGI-ValidOp-0.56/bin/encode.pl0000755000175000017550000000016111304772200015666 0ustar exodistexodist#!/usr/bin/perl use strict; use warnings; use HTML::Entities; print encode_entities( $_ ), "\n" for @ARGV; CGI-ValidOp-0.56/inc/0000755000175000017550000000000011310301055014065 5ustar exodistexodistCGI-ValidOp-0.56/inc/Module/0000755000175000017550000000000011310301055015312 5ustar exodistexodistCGI-ValidOp-0.56/inc/Module/Install/0000755000175000017550000000000011310301055016720 5ustar exodistexodistCGI-ValidOp-0.56/inc/Module/Install/Can.pm0000644000175000017550000000333311310301037017761 0ustar exodistexodist#line 1 package Module::Install::Can; use strict; use Config (); use File::Spec (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 156 CGI-ValidOp-0.56/inc/Module/Install/Base.pm0000644000175000017550000000176611310301037020142 0ustar exodistexodist#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '0.91'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { $_[0]->admin->VERSION; } sub DESTROY {} package Module::Install::Base::FakeAdmin; my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 154 CGI-ValidOp-0.56/inc/Module/Install/Win32.pm0000644000175000017550000000340311310301037020160 0ustar exodistexodist#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; CGI-ValidOp-0.56/inc/Module/Install/WriteAll.pm0000644000175000017550000000222211310301037020777 0ustar exodistexodist#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91';; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { $self->makemaker_args( PL_FILES => {} ); } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; CGI-ValidOp-0.56/inc/Module/Install/Makefile.pm0000644000175000017550000001600311310301037020773 0ustar exodistexodist#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing, always use defaults if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } sub makemaker_args { my $self = shift; my $args = ( $self->{makemaker_args} ||= {} ); %$args = ( %$args, @_ ); return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = sShift; my $name = shift; my $args = $self->makemaker_args; $args->{name} = defined $args->{$name} ? join( ' ', $args->{name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } my %test_dir = (); sub _wanted_t { /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1; } sub tests_recursive { my $self = shift; if ( $self->tests ) { die "tests_recursive will not work if tests are already defined"; } my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } %test_dir = (); require File::Find; File::Find::find( \&_wanted_t, $dir ); $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # MakeMaker can complain about module versions that include # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. $self->build_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{VERSION} = $self->version; $args->{NAME} =~ s/-/::/g; if ( $self->tests ) { $args->{test} = { TESTS => $self->tests }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = $self->author; } if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) { $args->{NO_META} = 1; } if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } # Merge both kinds of requires into prereq_pm my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_, ($self->configure_requires, $self->build_requires, $self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # merge both kinds of requires into prereq_pm my $subdirs = ($args->{DIR} ||= []); if ($self->bundles) { foreach my $bundle (@{ $self->bundles }) { my ($file, $dir) = @$bundle; push @$subdirs, $dir if -d $dir; delete $prereq->{$file}; } } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } $args->{INSTALLDIRS} = $self->installdirs; my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if (my $preop = $self->admin->preop($user_preop)) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; my $makefile = do { local $/; }; close MAKEFILE or die $!; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 394 CGI-ValidOp-0.56/inc/Module/Install/Fetch.pm0000644000175000017550000000462711310301037020320 0ustar exodistexodist#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; CGI-ValidOp-0.56/inc/Module/Install/Metadata.pm0000644000175000017550000003530411310301037021003 0ustar exodistexodist#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract author version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords }; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config\n"; return $self; } $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; return 1; } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the reall old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless $self->author; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub perl_version_from { my $self = shift; if ( Module::Install::_read($_[0]) =~ m/ ^ (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; $author =~ s{E}{<}g; $author =~ s{E}{>}g; $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } sub license_from { my $self = shift; if ( Module::Install::_read($_[0]) =~ m/ ( =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b .*? ) (=head\\d.*|=cut.*|) \z /ixms ) { my $license_text = $1; my @phrases = ( 'under the same (?:terms|license) as (?:perl|the perl programming language) itself' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'BSD license' => 'bsd', 1, 'Artistic license' => 'artistic', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s{\s+}{\\s+}g; if ( $license_text =~ /\b$pattern\b/i ) { $self->license($license); return 1; } } } warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } sub _extract_bugtracker { my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than on rt.cpan.org link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; CGI-ValidOp-0.56/inc/Module/Install.pm0000644000175000017550000002411411310301037017260 0ustar exodistexodist#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '0.91'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); use Cwd (); use File::Find (); use File::Path (); use FindBin; sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; unless ( -f $self->{file} ) { require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{"$self->{file}"}; delete $INC{"$self->{path}.pm"}; # Save to the singleton $MAIN = $self; return 1; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = delete $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } sub _read { local *FH; if ( $] >= 5.006 ) { open( FH, '<', $_[0] ) or die "open($_[0]): $!"; } else { open( FH, "< $_[0]" ) or die "open($_[0]): $!"; } my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } sub _write { local *FH; if ( $] >= 5.006 ) { open( FH, '>', $_[0] ) or die "open($_[0]): $!"; } else { open( FH, "> $_[0]" ) or die "open($_[0]): $!"; } foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[0]) <=> _version($_[1]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2009 Adam Kennedy. CGI-ValidOp-0.56/lib/0000755000175000017550000000000011310301055014062 5ustar exodistexodistCGI-ValidOp-0.56/lib/CGI/0000755000175000017550000000000011310301055014464 5ustar exodistexodistCGI-ValidOp-0.56/lib/CGI/ValidOp.pm0000644000175000017550000006026611310300706016374 0ustar exodistexodistpackage CGI::ValidOp; use strict; use warnings; our $VERSION = '0.56'; use base qw/ CGI::ValidOp::Base /; use CGI::ValidOp::Op; use CGI::ValidOp::Param; use CGI::ValidOp::Object; use CGI; use Carp qw/ croak confess /; use Data::Dumper; # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub PROPERTIES { { ops => undef, print_warnings => 1, default_op => 'default', runmode_name => 'op', disable_uploads => 1, post_max => 25_000, -cgi_object => new CGI, -error_decoration => undef, -allow_unexpected => 1, -on_error_return_undef => 0, -on_error_return_encoded => 0, -on_error_return_tainted => 0, -return_only_received => 0, } } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # the argument parsing means: # 1) if an argument is prefixed with a '-', take it as a config option # 2) else take it as an op sub init { my $self = shift; my( $args ) = @_; my( %ops, %config ); if( ref $args eq 'HASH' ) { for( keys %$args ) { $_ =~ /^-(.*)$/ ? $config{ $1 } = $args->{ $_ } : $ops{ $_ } = $args->{ $_ }; } $config{ ops } = \%ops if keys %ops; $self->SUPER::init( \%config ); } else { $self->SUPER::init; } # order of precedence for on_error arguments -- only one of the three # shold be active at once $self->on_error_return_undef( 1 ) unless $self->on_error_return_encoded or $self->on_error_return_tainted; $self->on_error_return_tainted( 0 ) if $self->on_error_return_undef or $self->on_error_return_encoded; $self->on_error_return_encoded( 0 ) if $self->on_error_return_undef; $self->get_cgi_vars; $self; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub cgi_object { my $self = shift; my( $value ) = @_; return $self->{ cgi_object } unless defined $value; $self->{cgi_object} = $value; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub reset_on_error { my $self = shift; # we want object construction not to account for precedence return if $self->{ in_init }; $self->{ $_ } = 0 for qw/ on_error_return_undef on_error_return_encoded on_error_return_tainted /; return; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub on_error_return_undef { my $self = shift; my( $value ) = @_; return $self->{ on_error_return_undef } unless defined $value; $self->reset_on_error if $value; $self->{ on_error_return_undef } = $value ? 1 : 0; return $self->{ on_error_return_undef }; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub on_error_return_encoded { my $self = shift; my( $value ) = @_; return $self->{ on_error_return_encoded } unless defined $value; $self->reset_on_error if $value; $self->{ on_error_return_encoded } = $value ? 1 : 0; return $self->{ on_error_return_encoded }; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub on_error_return_tainted { my $self = shift; my( $value ) = @_; return $self->{ on_error_return_tainted } unless defined $value; $self->reset_on_error if $value; $self->{ on_error_return_tainted } = $value ? 1 : 0; return $self->{ on_error_return_tainted }; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # FIXME if you add a param and then change allow_unexpected, that param will go away sub allow_unexpected { my $self = shift; return $self->{ allow_unexpected } unless @_; $self->{ allow_unexpected } = shift; $self->set_vars; # FIXME this is a hack; related to the above FIXME } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub return_only_received { my $self = shift; return $self->{ return_only_received } unless @_; $self->{ return_only_received } = shift; $self->{ return_only_received }; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub get_cgi_vars { my $self = shift; $CGI::POST_MAX = $self->post_max; $CGI::DISABLE_UPLOADS = $self->disable_uploads; $self->set_vars({ $self->cgi_object->Vars }); # next two lines may be necessary for file uploads, but break existing # multi-value param functionality # my $cgi = CGI->new; # $self->set_vars({ map { $_ => $cgi->param( $_ )} $cgi->param }); return; # so we can't get untainted user input } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # an empty hashref {} resets vars # TODO should accept arrayrefs as values sub set_vars { my $self = shift; my( $vars ) = @_; return if $self->{ in_init }; # if we're still being initialized if( ref $vars eq 'HASH' ) { if( keys %$vars == 0 ) { delete $self->{ _vars }; } else { $self->{ _vars } = $vars; } } $self->make_op; $self->make_params; return; # so we can't get untainted user input } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # make the current Op object and add the defined params sub make_op { my $self = shift; delete $self->{ Op }; my $options = $self->ops; return unless my $params = $options->{ $self->op }; for( keys %$params ) { next if /^-.*/; $self->add_param( $_, $params->{ $_ }); } return; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # makes parameters using incoming vars sub make_params { my $self = shift; my $vars = $self->{ _vars }; # create params if we need to and are allowed if( $self->allow_unexpected ) { for( keys %$vars ) { next if $_ eq $self->runmode_name; # don't make one for runmode if (/\[/ || /^object--/) { $self->append_to_object($_); } # Make it available even if it is added to an object $self->add_param( $_ ) unless $self->Op->Param( $_ ); } } # set all tainted values $_->tainted( $vars->{ $_->name }) for $self->Op->Param; return; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # appends a parameter to an object - takes a parameter name as an argument. sub append_to_object { my $self = shift; my ($param_name) = @_; $self->{_objects} ||= { }; $param_name =~ /^object--(\w+)--/ || $param_name =~ /^([^\[]+)/; my $name = $1; return unless ($self->{_objects}{$name}); $self->{_objects}{$name}->set_var({ name => $param_name, value => $self->{_vars}{$param_name} }); return $name; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # accepts: # ( $name ) # ( \%options ) # ( $name, \%options ) # ( $name, [ $label, @checks ]) sub add_param { my $self = shift; my $param; if( @_ == 1 ) { # either a hashref or a single name $param = $self->Op->add_param( @_ ); } else { # either a name and hashref or a name and arrayref my( $name, $vars ) = @_; my( $label, $checks ); if ( ref $vars eq 'ARRAY' ) { $label = $vars->[0]; # slice and take a reference to that, copying 1..-1 $checks = [@{$vars}[1..$#$vars]]; $param = $self->Op->add_param({ name => $name, label => $label, checks => $checks, }); } elsif( ref $vars eq 'HASH' ) { $self->{_objects} ||= { }; $param = $self->{_objects}{$name} = CGI::ValidOp::Object->new($name, $vars); } else { croak qr/Incorrect param definition./; } } if ($param->isa('CGI::ValidOp::Param')) { $param->tainted( $self->{ _vars }{ $param->name }) if defined $self->{ _vars }; } $param; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # capitalized for CGI compatibility sub Vars { my $self = shift; my %params; my @vars = keys %{ $self->{ _vars }} if $self->{ _vars }; for( $self->Op->Param ) { my $name = $_->name; next if $self->return_only_received and not grep /^$name$/ => @vars; $params{ $name } = $_->value; } return unless keys %params; wantarray ? %params : \%params; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # fetches an object collection sub objects { my $self = shift; my ($object_name) = @_; $self->{_objects} ||= { }; if (defined($object_name)) { return $self->{_objects}{$object_name} ? $self->{_objects}{$object_name}->objects : []; } my $hash = { }; foreach my $key (keys %{$self->{_objects}}) { $hash->{$key} = $self->{_objects}{$key}->objects || []; } return $hash; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # fetches all the errors for object collections sub object_errors { my $self = shift; my ($object_name) = @_; if (defined($object_name)) { # return the errors just for the requested object return $self->{_objects}{$object_name} ? $self->{_objects}{$object_name}->object_errors : {}; } my $hash = { }; # return all the object errors in a hash keyed by the object name foreach my $key (keys %{$self->{_objects}}) { $hash->{$key} = $self->{_objects}{$key}->object_errors; } return $hash; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub op { my $self = shift; $self->Op( @_ )->name; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # given a scalar, returns the op for which that scalar is an alias # accounts both for alias being a string and an arrayref # alias is case-sensitive sub op_alias { my $self = shift; my( $alias ) = @_; return unless $alias and $self->ops; for( keys %{ $self->ops }) { next unless $self->ops->{ $_ }{ -alias }; return $_ if $self->ops->{ $_ }{ -alias } eq $alias; return $_ if ref $self->ops->{ $_ }{ -alias } eq 'ARRAY' and grep /^$alias$/, @{ $self->ops->{ $_ }{ -alias }}; } return; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub get_op_name { my $self = shift; my $op_name; if( $self->{ _vars } and $self->{ _vars }{ $self->runmode_name }) { $op_name = $self->{ _vars }{ $self->runmode_name }; ( $op_name ) = split /\0/, $op_name; # if we get more than one, use the first $op_name = $self->op_alias( $op_name ) if $self->op_alias( $op_name ); $op_name = $self->default_op unless $self->ops and grep /^$op_name$/i => keys %{ $self->ops }; } else { $op_name = $self->default_op; } lc $op_name; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # FIXME if you add a param and then change op, that param will go away sub Op { my $self = shift; my( $op_name ) = @_; croak 'Invalid op name; only a word is allowed.' if $op_name and $op_name !~ /^\w+$/; unless( $op_name ) { return $self->{ Op } if $self->{ Op }; $op_name = $self->get_op_name; } # print STDERR Dumper[ # $self->{ on_error_return_undef }, # $self->{ on_error_return_encoded }, # $self->{ on_error_return_tainted }, # ]; my $on_error_return = $self->on_error_return_encoded ? 'encoded' : $self->on_error_return_tainted ? 'tainted' : 'undef'; $self->{ Op } = CGI::ValidOp::Op->new({ name => $op_name, error_decoration => [ $self->error_decoration ], on_error_return => $on_error_return, }); $self->{ Op }; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub param { my $self = shift; my( $param_name, $checks ) = @_; # return all param names if we're not asked for one unless( $param_name ) { my @params = map $_->name, $self->Op->Param; return @params if @params; return; } my $param = $self->Op->Param( $param_name, $checks ); if( !$param and $checks ) { # if we have checks create the param $param = $self->add_param($param_name, [ $param_name, @$checks ]); } return $param->value if $param; return; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub errors { my $self = shift; return unless $self->Op->Param; my @errors; for( $self->Op->Param ) { $_->validate; # slightly nasty to have to do this next unless my $errors = $_->errors; push @errors => @$errors; } @errors = sort @errors; return \@errors if @errors; return; } 1; __END__ =head1 NAME CGI::ValidOp - Simple validation of CGI parameters and runmodes. =head1 SYNOPSIS # given the following CGI parameters: # op=add_item; name=William Blake; ssn=345-21-6789; crackme=$ENV{EVIL_MEAT}; use CGI::ValidOp; my $cgi = CGI::ValidOp->new({ add_item => { # using full syntax name => { label => 'Name', checks => [ 'required', 'text::words' ], }, ssn => { label => 'Social Security number', checks => [ 'demographics::us_ssn' ], }, }, remove_item => { # using shortcut syntax ssn => [ 'Social Security number', 'required', 'demographics::us_ssn' ], confirm => [ 'Confirmation checkbox', 'required', 'checkbox::boolean' ], }, cgi_object => new CGI($fh), }); my $name = $cgi->param( 'name' ); # eq "William Blake" my $ssn = $cgi->param( 'ssn' ); # eq "345-21-6789" my $crackme = $cgi->param( 'crackme' ); # is undef; it was removed by the check my $confirm = $cgi->param( 'confirm' ); # is undef; it doesn't exist my $op = $cgi->op; # eq "add_item" my @errors = $cgi->errors; # eq ( 'Parameter "crackme" contained invalid data.' ) my %vars = $cgi->Vars; # eq ( # name => "William Blake", # ssn => "345-21-6789", # crackme => undef, # ) =head1 DESCRIPTION CGI::ValidOp is a CGI parameter validator that also helps you manage runmodes. Its aims are similar to Perl's: make the easy jobs easy and the complex jobs possible. CGI parameter validation is boring, and precisely for that reason it's easy to get wrong or ignore. CGI::ValidOp takes as much of the repetition as possible out of this job, replacing it with a simple interface. =head2 Unique features There are many CGI parameter validation modules on CPAN; why on earth would I write another one, and why should you use it? Before writing ValidOp I made a list of requirements and checked all available modules against it, hoping that even if nothing matched there'd be a project which I could subclass or contribute to. I didn't find anything. Here's what I think ValidOp does right: =over 4 =item Simple API. =item Minimal usage is useful. =item Easy to add new checks. =item Relation of parameters to run-modes/operations. In addition to validating parameters, CGI::ValidOp has a number of methods for dealing with runmodes (henceforth referred to as 'ops'). In fact, the 'op' concept is key to ValidOp's advanced usage: parameters are defined as children of ops. A "display_item" op may need only a numeric id, while an "add_item" op will take several parameters. All these can be defined once in a single location. =item Validation defaults settable on many levels to minimize repetition. You can change the validation defaults for the entire app, all parameters for one runmode, or per-parameter. =item CGI integration and compatibility. Parameters can be accessed just like with CGI.pm: L for individual parameters and L for all of them. =item Per-parameter error messages. While error message must be available globally, having per-parameter error messages is an important usability improvement. When returning a long form page to a user, it's good to show them error messages where they're most useful. =item OO and test-driven ValidOp is test-driven, object-oriented Perl. =item Extensive and public test suite. If you're going to trust someone else's code for security purposes it's nice to have proof that it works. CGI::ValidOp has an extensive test suite that checks every part of its operation, particularly the validation routines. I keep the current version running at L validop with a full test page. If you can produce unexpected output, file a bug report. =back =head1 METHODS =head2 new( \%options ) Creates and returns a new CGI::ValidOp object. The initializing hashref is optional. If supplied, it may contain two types of values: configuration options and runmode definitions. Configuration options must be prepended with a dash (C<->); runmodes must not be. Setting 'cgi_object' will allow you to override the CGI object that would be provided by default, if say, you needed to use this module under mod_perl. my $cgi = CGI::ValidOp->new({ -allow_unexpected => 0, # configuration option add => {}, # op, or runmode definition ); See L and L for more details. =head2 param( $name, \@checks ) C behaves similarly to the CGI.pm method of the same name, returning the value for the named parameter. The differences from CGI.pm's C are: =over 4 =item * The return value will be validated against all defined checks. =item * The return value will be untainted if the checks require it. =item * Any necessary error messages will be created. =back The C<\@checks> arrayref is optional. If supplied, it replaces all previously defined checks for the parameter and overrides all defaults. An empty arrayref (C<[]>) will give you the parameter as input by the user, unchecked; it will still be tainted. =head2 Vars C behaves similarly to the CGI.pm method of the same name, returning the entire parameter list. In scalar context it returns a hash reference; in list context it returns a hash. The differences from CGI.pm's C method are: =over 4 =item * Multivalue parameters are returned as an arrayref, rather than a null-byte packed string. =item * The L parameter ("op" by default) is not returned; see L for more details. =item * Unexpected parameters are not returned (see L). =item * Parameters that failed one or more checks are returned as C. =item * In scalar context the hashref is not tied, and changes to it do not affect the parameter list. =back =head2 op Returns the current runmode name. In the normal case, this is the CGI parameter given for "op" (but see L). Several factors affect the return value: =over 4 =item * If a runmode parameter is given but it doesn't match the name of any defined runmode, L are searched. =item * If no L matches, the value of L is returned. =back Note that while ValidOp doesn't require you to use its runmode management features, it still uses them internally. Even in the of no defined parameters or runmodes, ValidOp uses "default" as its runmode and all parameters are subsidiary to it. This is invisible to the user. =head2 errors Returns an arrayref of all error messages for the current parameter list and parameter definitions. Returns C if there are no errors. =head2 Op( $op_name ) Returns the CGI::ValidOp::Op object for the current runmode, or the runmode given. See L for more details, or the documentation for L for all the details. =head2 set_vars( \%params ) Resets the parameter list to the given hash reference. =head1 CONFIGURATION ValidOp has a number of configurable options which alter its behavior. These options can be given in the constructor, via accessor methods, or both: my $cgi = CGI::ValidOp->new({ -allow_unexpected => 0, -default_op => 'home', }); $cgi->default_op( 'view' ); # overrides 'home' above =head2 allow_unexpected Default: B<1>. Accepts: B<1 or 0>. Controls whether ValidOp accepts incoming CGI parameters which you have not defined. If true, all incoming parameters are accepted and validated. If false, parameters you have not defined are ignored. =head2 return_only_received Default: B<0>. Accepts: B<1 or 0>. If true, will not return any data for a parameter not received in the query string. ValidOp's default behavior is to return an C value in this situation. =head2 default_op Default: B<'default'>. Accepts: B. The default runmode name. If no runmode parameter is given, or if the runmode given does not exist, the runmode specified here will be used. See L. =head2 disable_uploads Default: B<1>. Accepts: B. Passed through to CGI.pm when getting parameters. See L. =head2 error_decoration Default: B. Accepts: B. Text with which to surround parameter labels in error messages. If given a single scalar, it is inserted both before and after the label. If given an arrayref, the first value is inserted before and the second is inserted after. Given an error message of C<$label is required.> and a label of "Confirmation checkbox," ValidOp would normally output C. Here's how various values affect the error message: $cgi->error_decoration( '"' ); # "Confirmation checkbox" is required. $cgi->error_decoration( '* ', undef ); # * Confirmation checkbox is required. $cgi->error_decoration( undef, ':' ); # Confirmation checkbox: is required. $cgi->error_decoration( '', '' ); # Confirmation checkbox is required. =head2 post_max Default: B<25,000>. Accepts: B. Passed through to CGI.pm when getting parameters. See L. =head2 runmode_name Default: B<'op'>. Accepts: B. The name of the runmode. ValidOp treates the runmode parameter differently from other parameters; see L for more details. =head2 on_error_return... These routines control what values are returned by C and C. They are mutually exclusive, and have the following order of precedence: =over 4 =item * on_error_return_undef =item * on_error_return_encoded =item * on_error_return_tainted =back In other words, if both C and C are given as true, C will apply. =head3 on_error_return_undef The default behavior. Values which fail validation are ignored, and returned as C. =head3 on_error_return_encoded Values which fail validation are returned as input, but first encoded with L's C method. =head3 on_error_return_tainted Values which fail validation are returned unchanged. Don't do this. =head1 Defining Checks =over 4 =item ValidOp checks When constructing a CGI::ValidOp object, you may pass a C<-checks> option. The default checks are: C<['text']>. =item Op checks When defining an op within the CGI::ValidOp constructor, you may pass a C<-checks> option. =item Parameter checks When defining a param within the op definition, you may pass a C<-checks> option. =item On-the-fly checks When calling the C method, you may pass an array reference as the second parameter. This arrayref is passed straight through to the parameter's C accessor. =back =head1 COPYRIGHT Copyright (c) 2003-2005 Randall Hansen. All rights reserved. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =head1 AUTHORS Randall Hansen Chad Granum =cut # $Id: ValidOp.pm 387 2005-04-21 23:45:27Z soh $ CGI-ValidOp-0.56/lib/CGI/ValidOp/0000755000175000017550000000000011310301055016022 5ustar exodistexodistCGI-ValidOp-0.56/lib/CGI/ValidOp/Check.pm0000644000175000017550000002726411304772200017417 0ustar exodistexodistpackage CGI::ValidOp::Check; use strict; use warnings; use base qw/ CGI::ValidOp::Base /; use Carp; my @ALLOWED_TYPES = ( qw/ regexp code /); # types of reference we allow for checks # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub PROPERTIES { { validator => undef, errmsg => undef, name => undef, params => undef, allow_tainted => 0, } } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # params are optional parameters passed in, e.g. "check_name(3,4)" sub init { my $self = shift; my( $check_name, @params ) = @_; $check_name ||= 'default'; my $pkg = ref $self; croak qq/No such check ("$check_name") in package "$pkg"./ unless $self->can( $check_name ); my( $validator, $errmsg ) = $self->$check_name; my $validator_type = ref $validator; croak join ' ', "Disallowed reference type for validator. You used $validator_type; valid types are:", @ALLOWED_TYPES unless $validator_type and grep /^$validator_type$/i, @ALLOWED_TYPES; $self->SUPER::init({ validator => $validator, errmsg => $errmsg, name => $check_name, params => \@params, }); } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # called by a check to indicate success: "pass( $value )" sub pass { my $self = shift; my( $value ) = @_; ( $value, undef ); } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # called by a check to indicate failure "fail( $errmsg )" sub fail { my $self = shift; my( $errmsg ) = @_; ( undef, $errmsg ); } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # check to see what type of validator we have and call the appropriate sub sub check { my $self = shift; my( $tainted ) = @_; # trim whitespace if (defined $tainted) { $tainted =~ s/^\s+//; $tainted =~ s/\s+$//; } my $check_sub = 'check_'. lc ref $self->validator; $self->$check_sub( $tainted, $self->validator ); } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # this method makes the decision about whether the test passed or failed # if it gets undef it returns it with no error message # if the regex then returns undef it returns an error sub check_regexp { my $self = shift; my( $tainted, $validator ) = @_; return( undef, undef ) unless defined $tainted; $tainted =~ /($validator)/; return $1 unless wantarray; defined $1 ? ( $1, undef ) : ( undef, $self->errmsg ); } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # this method expects the coderef to call either pass or fail sub check_code { my $self = shift; my( $tainted, $validator ) = @_; my( $value, $errmsg ) = &$validator( $tainted, $self->params ); croak 'Validator returned a tainted value' if $self->is_tainted( $value ) and ! $self->allow_tainted; wantarray ? ( $value, $errmsg ) : $value; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub default { ( sub { croak 'You must override CGI::ValidOp::Check::check() with your own code.'; }, 'Parameter $label contained invalid data.', ) } 1; __END__ =head1 NAME CGI::ValidOp::Check - base class for CGI::ValidOp checks =head1 SYNOPSIS package CGI::ValidOp::Check::demo; use base qw/ CGI::ValidOp::Check /; sub default { ( qr/^demo$/, # validator '$label must equal "demo."', # error message ) } sub color { my $self = shift; ( sub { my( $value, $color ) = @_; $self->pass( $1 ) if $value =~ /^($color)$/i; $self->fail( "\$label must be the color: $color." ); }, ) } =head1 DESCRIPTION CGI::ValidOp::Check contains all the code to validate data from CGI::ValidOp::Param objects, and enables simple creation your own checks. Unless you're creating or testing your own checks, you should use and read the documentation for L instead. =head2 How checks are used Each check module must contain at least one check, and can contain as many as you care to create. This document walks through the creation of one module containing mutliple checks. Some of ValidOp's default checks are organized by types of data (e.g. 'text', 'number'), but there's nothing to say you must also do this. You may find it convenient to package all the checks for one project in a single module. Your check can be used in three ways. The first is with a simple scalar corresponding to the module name: $validop->param( 'price', [ 'mychecks' ]); The second is by calling a particular check within the package: $validop->param( 'price', [ 'mychecks::robot' ]); The third is by passing parameters to either the module or a check: $validop->param( 'price', [ 'mychecks(3,6)' ]); $validop->param( 'price', [ 'mychecks::robot("Robbie")' ]); =head1 METHODS Unless you're creating or testing your own checks, this reference is not likely to help you. You can use ValidOp's public API without knowing a thing about ValidOp::Check's internals. =head2 params() The 'params' method returns a list passed to the check by the user: $validop->param( 'price', [ 'mychecks(3,6)' ]); These parameters are captured by splitting the contents of the parenthesis on commas. The resulting list is made available with the 'params' method. =head2 validator( $regexp_or_coderef ) Sets or returns the validator. =head2 errmsg( $error_message ) Sets or returns the error message. When CGI::ValidOp::Param parses these error messages, it replaces every isntance of C<$label> with the parameter's 'label' property or, if that does not exist, with the parameter's 'name'. =head2 check( $tainted_value ) check() runs its calling object's validator against the incoming tainted value. It returns the resulting value on success, or C on failure. check() itself does very little work; it finds what type of validator it has (regex and coderef are the only types currently allowed) and farms out the work to the appropriate method. =head2 check_regexp( $tainted, $validator ) check_regexp() captures the result of matching $tainted against $validator, using code similar to this: $tainted =~ /($validator)/; return $1; Note that the return value is untainted. Also note that the code does B anchor the regular expression with ^ (at the beginning) or $ (at the end). In other words, if you used this quoted regex as a check: qr/demo/ any string containing "demo" (e.g. "demographics," "modemophobia") would pass. This may or may not be what you intend. =head2 check_code( $tainted, $validator ) check_code() passes $tainted to the anonymous subroutine referenced by $validator and returns the result. The two most notable differences from regex checks are that the value of L is passed into the validator subroutine and that the entire thing croaks if the return value is tainted. ValidOp's default behavior is to die like a dog if your coderef returns a tainted value. This safe default can be changed by returning a third list item from your check subroutine, a hashref of additional properties: sub should_allow_tainted {( sub { $_[ 0 ] }, 'This should be an error message', { allow_tainted => 1, } )} =head2 is_tainted =head1 CREATING A CHECK MODULE =head2 Starting a check module For the moment, your check module must be in the CGI::ValidOp::Check namespace; future versions will allow more flexibility. The module must be in Perl's search path. package CGI::ValidOp::Check::demo; You must subclass CGI::ValidOp::Check for your module. It contains methods that the rest of the code uses to perform the validation. use base qw/ CGI::ValidOp::Check /; =head2 Creating checks Each check is completely defined by a single subroutine. If you define only one check in your module, it should be called 'default'. Using only the module name as a check, the 'default' subroutine is called. There's nothing to stop you calling your single check something else, but it does mean less intuitive use. Checks return one to three scalar values. The first value is the check itself, and is required. The second value is an optional error message. The third is an optional list of additional properties, defined for the check and made available as methods. sub check_name { ( $check, $errmsg, \%options ) } =head2 Types of checks =head3 Quoted regular expression The simplest checks are quoted regular expressions. These are perfect for relatively static data. This one checks that the incoming value is "demo" and sets a custom error message. Any instance of '$label' in an error message is substituted with the parameter's 'label' property, if you define one, or the parameter's 'name' property (which is required and thus guaranteed to exist). sub default { ( qr/^demo$/, # validator '$label must equal "demo."', # error message ) } Parameters are validated against Regex checks with the L method. You cannot pass parameters to a regex check (more to the point you can, but they'll be ignored). =head3 Subroutine reference These checks can be much more powerful and flexible, but require a little extra work. sub color { my $self = shift; ( sub { my( $value, $color ) = @_; return $1 if $value =~ /^($color)$/i; $self->errmsg( "\$label must be the color: $color." ); return; }, ) } You'll note that the check only returns one item, an anonymous subroutine. This coderef sets the check's error message with the 'errmsg' method, allowing it to pass incoming parameters into the error message. (You could supply an error message here as the second array element, but it would be overridden.) Parameters are validated against coderef checks with the L method: Right now the only additional property available ValidOp checks is 'allow_tainted.' ValidOp's stock 'length' check uses this, reasoning that just knowing the length of an incoming value isn't reason enough to trust it. package Main; my $demo = CGI::ValidOp::Check::demo->new; is( $demo->check( 'failure' ), undef ); is( $demo->check( 'demo' ), 'demo' ); my $value = $demo->check( 'demo' ); ok( ! $demo->is_tainted( $value )); my $demo_color = CGI::ValidOp::Check::demo->new( 'color', 'red' ); is( $demo_color->check( 'green' ), undef ); is( $demo_color->errmsg, '$label must be the color: red.' ); is( $demo_color->check( 'red' ), 'red' ); =head1 AUTHOR Randall Hansen =head1 COPYRIGHT Copyright (c) 2003-2005 Randall Hansen. All rights reserved. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut # $Id: Check.pm 388 2005-04-22 16:11:04Z soh $ /^checkbox$/ and return qr/^on$/i; /^email$/ and return qr/[\w\.@]+/; /^encode_html$/ and return sub { require HTML::Entities; my( $value ) = @_; return( HTML::Entities::encode( $value ), 1 ); }; /^checkbox_10$/ and return sub { $_ = shift; /^on$/i and return 1; return 0; }; # file name, from http://www.perlmonks.org/index.pl?node_id=36309 # /^( # (?:\w+\/)* # Directory components? # \w+ # Start of filename # (?:\.\w+)? # Extension? # )$/x CGI-ValidOp-0.56/lib/CGI/ValidOp/Param.pm0000644000175000017550000001470311304772200017434 0ustar exodistexodistpackage CGI::ValidOp::Param; use strict; use warnings; use base qw/ CGI::ValidOp::Base /; use Carp; use Data::Dumper; use HTML::Entities; use Storable qw(dclone); # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub PROPERTIES { { label => undef, checks => [ qw/ text/ ], required => 0, -error_decoration => undef, tainted => undef, on_error_return => 'undef', } } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub init { my $self = shift; my( $args ) = @_; # XXX set_name should raise the error, maybe $self->set_name( $args ) or croak 'Name required in CGI::ValidOp::Param::init().'; $self->SUPER::init( $args ); $self->required( 1 ) # FIXME hack, not a ::Check; can it be? if grep /^required$/ => $self->checks; $self; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # treats the empty string '' as undef sub tainted { my $self = shift; my( $tainted ) = @_; return $self->{ tainted } unless @_; delete $self->{ value }; undef $tainted if defined $tainted and $tainted eq ''; $self->{ tainted } = $tainted; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # returns validated param # take on_error_return into account sub value { my $self = shift; croak 'Cannot directly set parameter value with CGI::ValidOp::Param::value().' if @_; $self->validate; return encode_entities( $self->tainted ) if $self->errors and $self->on_error_return eq 'encoded'; return $self->tainted if $self->errors and $self->on_error_return eq 'tainted'; return if $self->errors; # 'undef' is the default return $self->{ value } } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # validates $self->{ tainted } against all checks defined for it sub validate { my $self = shift; # empty arrayref means "no checks" return unless $self->checks and $self->checks > 0; $self->check_required; # this is a little magic; read its comments for my $check_name( $self->checks ) { next if $check_name eq 'required'; #FIXME nasty special case delete $self->{ value }; # we'll set the value later if it's ok if( $self->tainted and $self->tainted =~ /\0/ ) { # if multi-value for( split /\0/, $self->tainted ) { my $value = $self->check( $_, $check_name ); push @{ $self->{ value }} => $value if defined $value; } } else { my $value = $self->check( $self->tainted, $check_name ); $self->{ value } = $value if defined $value; } } return; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # checks a single value against one check # returns a good value, or adds an error and returns undef sub check { my $self = shift; my( $tainted, $check_name ) = @_; my $check = $self->load_check( $check_name ); my( $value, $errmsg ) = $check->check( $tainted ); return $value unless $errmsg; $self->add_error( $check_name, $errmsg ); return; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # check_string can be any of (e.g.): # foo, foo::bar, foo(2,4), foo::bar(2,4) sub load_check { my $self = shift; my( $check_string ) = @_; croak "Must pass a scalar check name to CGI::ValidOp::Param::load_check()" if !$check_string or ref $check_string; # strip out trailing parens and capture anything inside them as a list ( my $check_name = $check_string ) =~ s/(.*)\((.*)\)/$1/; my @params = $2 ? split /,/ => $2 : undef; my( $package, $method ) = split /::/, $check_name; $package = "CGI::ValidOp::Check::$package"; eval "require $package"; $@ and croak "Failed to require $package in CGI::ValidOp::Param::check(): ". $@; $package->new( $method, @params ); } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # FIXME this should go into ::Check # | $param-> | defined | | RETURNS | | add | # if | required | tainted | then | undef | tainted | and | error? | # |----------|---------| |-------|---------| |--------| # | X | | | X | | | X | # | | | | X | | | | # | X | X | | | X | | | # | | X | | | X | | | sub check_required { my $self = shift; if( defined $self->tainted ) { $self->{ value } = $self->tainted; return $self->{ value }; } $self->add_error( 'required', '$label is required.' ) if $self->required; return; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # returns error if it was added, undef otherwise sub add_error { my $self = shift; my( $check_name, $error ) = @_; return unless $check_name and $error; $check_name =~ s/(.*)\((.*)\)/$1/; # removes trailing parens $self->{ errors }{ $check_name } = $error; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # copy constructor. sub clone { return dclone(shift); } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # errors are structured like: # $param = { # ... # errors => { # $check_name => $error_message, # } sub errors { my $self = shift; return unless $self->{ errors }; my @errors; my( $b, $e ) = $self->error_decoration; for( sort values %{ $self->{ errors }}) { my $label = $self->label || $self->name; { # don't care if these exist no warnings qw/ uninitialized /; $label = $b . $label . $e; } $_ =~ s/\$label/$label/g; push @errors => $_ } return \@errors if @errors; return; } 1; __END__ =head1 NAME CGI::ValidOp::Param - Parameter object for CGI::ValidOp =head1 DESCRIPTION Implements a CGI parameter object. Used internally by CGI::ValidOp; please see the L documentation. =head1 AUTHOR Randall Hansen =head1 COPYRIGHT Copyright (c) 2003-2006 Randall Hansen. All rights reserved. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut CGI-ValidOp-0.56/lib/CGI/ValidOp/Base.pm0000644000175000017550000001056611305006616017253 0ustar exodistexodistpackage CGI::ValidOp::Base; use strict; use warnings; use Data::Dumper; use Carp qw/ croak confess /; # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub new { my $proto = shift; my $class = ref $proto || $proto; my $self = bless {}, $class; $self->init( @_ ); } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # if the calling object has a PROPERTIES method, this # 1) creates accessor methods for each key returned, # 2) and calls the method with the value # if the key is prefixed with a '-', only (2) is performed sub init { my $self = shift; my( $args ) = @_; return $self unless $self->can( 'PROPERTIES' ); $self->{ in_init } = 1; # tells other methods that we're not baked yet my $config = $self->PROPERTIES; for( keys %$config ) { $self->method( $_ ) unless $_ =~ /^-/; ( my $prop = $_ ) =~ s/^-//; $self->$prop( $config->{ $_ }); # set default $self->$prop( $args->{ $prop }) # set incoming if ref $args eq 'HASH' and defined $args->{ $prop }; } delete $self->{ in_init }; $self; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # creates a method to store the property sub method { my $self = shift; my( $property ) = @_; my $pkg = caller; return if $pkg->can( $property ); no strict 'refs'; *{ "${ pkg }::$property" } = sub { my $self = shift; my( $value ) = @_; if( @_ ) { undef $value if defined $value and $value eq ''; $self->{ $property } = $value; } return unless defined wantarray; return @{ $self->{ $property }} if wantarray and ref $self->{ $property } eq 'ARRAY'; return %{ $self->{ $property }} if wantarray and ref $self->{ $property } eq 'HASH'; $self->{ $property }; }; return; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # accessor for object name; will accept a scalar word # or a hashref containing a 'name' key sub set_name { my $self = shift; my( $args ) = @_; my %e = ( api => q/ERROR: set_name() API./, preq => q/Parameter names are required for all values./, regex => q/Parameter names must contain only letters, numbers, underscores, and square brackets./, ); my $name; if( ref $args ) { croak $e{ api } unless ref $args eq 'HASH' and keys %$args; croak $e{ api } unless grep /^name$/ => keys %$args; croak $e{ preq } unless $args->{ name }; $name = $args->{ name }; } $name ||= $args; croak $e{ preq } unless $name; croak $e{ regex } unless $name =~ /^[\w\[\]-]+$/; $self->{ name } = $name; $self->{ name }; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # adapted from 'CGI Programming with Perl' sub is_tainted { my $self = shift; my( $value ) = @_; return unless defined $value; my $blank = substr( $value, 0, 0 ); return not eval { eval "1 || $blank" || 1 }; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub error_decoration { my $self = shift; my( $begin, $end ) = @_; # must accept arrayref ( $begin, $end ) = @$begin if ref $begin eq 'ARRAY'; # we have to be able to pass undef as the second param $end = $begin if ! defined $end and @_ == 1; if( @_ ) { $self->{ error_decoration } = [ $begin, $end ]; return( $begin, $end ); } ( $begin, $end ) = @{ $self->{ error_decoration }} if $self->{ error_decoration }; return @{ $self->{ error_decoration }} if defined $begin or defined $end; return; }; 1; __END__ =head1 NAME CGI::ValidOp::Base - base class for CGI::ValidOp and its associates. =head1 DESCRIPTION Provides object and method construction, and other common methods, for other CGI::ValidOp classes. Should not be used directly; see L. =head1 AUTHOR Randall Hansen =head1 COPYRIGHT Copyright (c) 2003-2005 Randall Hansen. All rights reserved. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut # $Id: Base.pm 387 2005-04-21 23:45:27Z soh $ CGI-ValidOp-0.56/lib/CGI/ValidOp/Check/0000755000175000017550000000000011310301055017037 5ustar exodistexodistCGI-ValidOp-0.56/lib/CGI/ValidOp/Check/date.pm0000644000175000017550000001356111304772200020327 0ustar exodistexodistpackage CGI::ValidOp::Check::date; use strict; use warnings; use base qw/ CGI::ValidOp::Check /; my %TIMES = ( past => 1, present => 1, future => 1, ); sub iso { my $self = shift; sub { my $value = shift; my $times = [ grep { $TIMES{ $_ } if defined $_ } @_ ]; return $self->pass unless defined $value; my $errmsg = '$label must include year, month, and date as YYYY-MM-DD'; my ($y, $m, $d) = check_iso_format($value) or return $self->fail( $errmsg ); if ( $times and $times->[0] ) { my ( $valid, $time ) = valid_date( $y, $m, $d, $times ); return $self->fail( '$label cannot be in the ' . $time ) unless ( $valid ); } if ( check_year($y) && check_month($m) && check_day($d, $m, $y) ) { return $self->pass( sprintf( "%02d-%02d-%02d", $y, $m, $d )); } return $self->fail( $errmsg ); } } sub american { my $self = shift; sub { my $value = shift; return $self->pass unless defined $value; my $errmsg = '$label must be a valid date in a standard American format: mm/dd/yyyy or mm-dd-yyyy. (Leading zeros are not required)'; my( $y, $m, $d ) = check_american_format($value) or return $self->fail( $errmsg ); if ( check_year($y) && check_month($m) && check_day($d, $m, $y) ) { return $self->pass( sprintf( '%d-%02d-%02d', $y, $m, $d )); } return $self->fail( $errmsg ); } } sub general { my $self = shift; sub { my $value = shift; return $self->pass unless defined $value; my $errmsg = '$label must be a valid date in one of the following formats: mm/dd/yyyy, mm-dd-yyyy, yyyy-mm-dd. (Leading zeros are not required)'; my( $y, $m, $d ) = check_american_format($value); unless (defined $y) { ($y, $m, $d) = check_iso_format($value); } if ( check_year($y) && check_month($m) && check_day($d, $m, $y) ) { return $self->pass( sprintf( '%d-%02d-%02d', $y, $m, $d )); } return $self->fail( $errmsg ); } } sub valid_date { my ( $y, $m, $d, $times ) = @_; my @today = today(); my @value = ( $y, $m, $d ); my $time = 'present'; for ( my $i = 0; $i < 3; $i++ ) { if ( $today[$i] > $value[$i] ) { $time = 'past'; last; } if ( $today[$i] < $value[$i] ) { $time = 'future'; last; } } return (grep { m/$time/ } @$times) ? 1 : 0, $time; } sub today { my ($sec,$min,$hour,$mday,$mon,$year) = localtime time; return ( $year + 1900, $mon + 1, $mday); } # Checks that given date is in iso format and returns array # of year, month, day strings if so, else undef. sub check_iso_format { my $date = shift; return unless defined $date; my( $y, $m, $d ) = $date =~ qr#^(\d{1,4})-(\d{1,2})-(\d{1,2})$# or return undef; return ($y, $m, $d); } # Checks that given date is in american format and returns # array of year, month, day strings if so, else undef. sub check_american_format { my $date = shift; return unless defined $date; my( $m, $d, $y ) = $date =~ qr#^(\d{1,2})(?:-|/)(\d{1,2})(?:-|/)(\d{4})$# or return undef; return ($y, $m, $d); } # Returns 1 if year is a 4 digit number. sub check_year { my $y = shift; return unless defined $y; return 1 if $y =~ qr/^\d{4}$/; return 0; } # Returns 1 if month is between 1 and 12. Accepts 01, 02... sub check_month { my $m = shift; return unless defined $m; return 1 if $m =~ qr/^\d{1,2}$/ and $m > 0 and $m < 13; return 0; } # Requires day and month; requires year if month is February. # Returns 1 if day is valid for month/year. 0 if not. # Returns undefined if insufficient parameters given. sub check_day { my( $d, $m, $y ) = @_; return unless defined $d and defined $m; # checking February's day requires the year for leap years return unless $m != 2 or defined $y; return 0 if $d !~ qr/^\d{1,2}$/ or $d < 1 or $d >31; # 30 days hath september, april, june and november if ($m == 4 || $m == 6 || $m == 9 || $m == 11 ) { return 1 if $d <= 30; } # all the rest have 31 elsif ($m != 2) { return 1; } # except February, which has 28 elsif ( not leap_year($y)) { return 1 if $d <= 28; } # or on a leap year, 29 else { return 1 if $d <= 29; } return 0; } sub leap_year { my $y = shift; return 0 if $y % 4; # not multiple of 4 return 1 unless $y % 400; # is multiple of 400 return 0 unless $y % 100; # is multiple of 100 return 1; # everything else } 1; __END__ =head1 NAME CGI::ValidOp::Check::date - CGI::ValidOp::Check module to check if input looks like a date. =head1 DESCRIPTION =over 4 =item iso Checks for ISO 8601 compliance: YYYY-MM-DD. Returns date in compliant format, zero-padded if necessary. =item american Checks that the date is a standard American mm/dd/yyyy or mm-dd-yyyy date. Insists on 4 digit years. Leading zeros for month and day are optional. Returns date in ISO format with leading zeros. This allows the application to handle dates in a single, consistent format. The presentation layer can then concern itself with what format dates need to be displayed in. =item general Checks that the date is either iso or american format. Returns iso format. =back =head1 AUTHOR Randall Hansen Joshua Partlow =head1 COPYRIGHT Copyright (c) 2003-2006 Randall Hansen. All rights reserved. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut CGI-ValidOp-0.56/lib/CGI/ValidOp/Check/email.pm0000644000175000017550000000164211304772200020476 0ustar exodistexodistpackage CGI::ValidOp::Check::email; use strict; use warnings; use base qw/ CGI::ValidOp::Check /; sub default { my $self = shift; sub { my ( $tainted ) = @_; return $self->pass() unless $tainted; $tainted =~ /^(.*)$/s; my $value = $1; # For now only very basic validation. # Make sure we have data before and after an @ symbol, and make sure the # data after the @ symbol contains at least one period. # For full validation we may want to use an existing cpan module. # Found a perl regex that is 100% compliant e-mail validation, # however it made me laugh really hard: # http://ex-parrot.com/~pdw/Mail-RFC822-Address.html return $self->fail( "\$label: '$value' is not a valid email address." ) if $value =~ m/\@.*\@/ig or not $value =~ m/.+\@.+\..+/ig; return $self->pass( $value ); } } 1; CGI-ValidOp-0.56/lib/CGI/ValidOp/Check/checkbox.pm0000644000175000017550000000240511304772200021173 0ustar exodistexodistpackage CGI::ValidOp::Check::checkbox; use strict; use warnings; use base qw/ CGI::ValidOp::Check /; sub default { ( qr/^on$/i, q#Checkbox $label must be checked.#, ) } sub boolean { my $self = shift; sub { my $value = shift; return $self->pass( 0 ) unless defined $value; return $self->pass( 1 ) if $value =~ /^on$/i; $self->fail( q/Only a checkbox is allowed for parameter $label./ ); } } 1; __END__ =head1 NAME CGI::ValidOp::Check::checkbox - CGI::ValidOp::Check module to validate a checkbox control. =head1 DESCRIPTION =over 4 =item default Fails unless value equals "on" (or "on," since it's case-insensitive). Using this check requires the checkbox to be checked; if the checkbox is unchecked an error will be created. =item boolean Returns 1 if the checkbox was checked (i.e. is "on"); 0 if it was not; an error if it reeives any other data. =back =head1 AUTHOR Randall Hansen =head1 COPYRIGHT Copyright (c) 2003-2005 Randall Hansen. All rights reserved. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut # $Id: checkbox.pm 75 2005-01-14 05:49:20Z soh $ CGI-ValidOp-0.56/lib/CGI/ValidOp/Check/length.pm0000644000175000017550000000502511304772200020667 0ustar exodistexodistpackage CGI::ValidOp::Check::length; use strict; use warnings; use base qw/ CGI::ValidOp::Check /; use Carp; sub default { my $self = shift; sub { # this code is brutally verbose, but all the tests pass my( $value, $min, $max ) = @_; $self->allow_tainted( 1 ); return $self->pass unless defined $value; # length # length(0) # length(0,0) return $self->pass( $value ) unless $min or $max; # length(3) # length(3,3) if(( $min and ! defined $max ) or $min and $min == $max ) { return $self->pass( $value ) if $value =~ /^.{$min}$/; return $self->fail( "\$label length must be exactly $min characters long." ); } # length(3,0) elsif( $min and defined $max and $max == 0 ) { return $self->pass( $value ) if $value =~ /^.{$min,}$/; return $self->fail( "\$label length must be at least $min characters long." ); } # length(6,3) elsif( $min and defined $max and $min > $max ) { croak "Length 'min' must be less than 'max.'" } # length(0,3) elsif( $min == 0 and $max ) { return $self->pass( $value ) if $value =~ /^.{$min,$max}$/; return $self->fail( "\$label length must be at most $max characters long." ); } # length(3,6) elsif( $min and $max ) { return $self->pass( $value ) if $value =~ /^.{$min,$max}$/; return $self->fail( "\$label length must be between $min and $max characters long." ); } croak 'Something has gone horribly wrong with length check.'; } } 1; __END__ =head1 NAME CGI::ValidOp::Check::length - CGI::ValidOp::Check module to check length of value =head1 DESCRIPTION Fails if length of value in characters is not within specified parameters. Usage: =over 4 =item length =item length(0) =item length(0,0) Any value will pass. =item length(3) =item length(3,3) Length must exactly equal 3. =item length(3,0) Length must be at least 3. =item length(0,3) Length must be at most 3. =item length(3,6) Length must be between 3 and 6. =item length(6,3) Error; death. =back =head1 AUTHOR Randall Hansen =head1 COPYRIGHT Copyright (c) 2003-2005 Randall Hansen. All rights reserved. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut # $Id: length.pm 75 2005-01-14 05:49:20Z soh $ CGI-ValidOp-0.56/lib/CGI/ValidOp/Check/text.pm0000644000175000017550000000355511304772200020400 0ustar exodistexodistpackage CGI::ValidOp::Check::text; use strict; use warnings; use base qw/ CGI::ValidOp::Check /; sub default { ( qr#^[\w\s\(\*\.\\\?,!"'/:;@&%)-]+$#, q#Only letters, numbers, and the following punctuation are allowed for $label: ! " ' ( ) * , - . / : ; ? \ @ & %#, ) } sub word { ( qr/^\w+$/, q#Only one word is allowed for $label#, ) } sub words { ( qr/^[\w -]+$/, q#Only words are allowed for $label#, ) } sub liberal { ( qr#^[\w\s\(\*\.\\\?,!"'/:;&=%~\+\@\$)\#-]+$#, q|Only letters, numbers, and the following punctuation are allowed for $label: ! " ' ( ) * , - . / : ; & = % ~ + ? \ @ $ #|, ) } sub hippie { ( qr{^[\w\s\(\*\.\\\?#,{}^_[\]!"'/:;&=%~\+\@\$)-]+$}, q{Only letters, numbers, and the following punctuation are allowed for $label: ! " ' ( ) * , - . / : ; & = % ~ + ? \ @ # { } [ ] ^ _ $}, ) } 1; __END__ =head1 NAME CGI::ValidOp::Check::text - CGI::ValidOp::Check module to validate text =head1 DESCRIPTION =over 4 =item default Fails if incoming value contains characters other than Perl's character classes \w, \s, and: ! " ' ( ) * , - . / : ; ? @ \ =item word Fails if value contains anything other an Perl's "word" character class ([a-zA-Z0-9_]). =item words Like B above, but can contain spaces as well. =item liberal Expands on default allowing $ = ~ + =item hippie Even more permissive than liberal, including # { } [ ] ^ _ $ Still does not allow to be embedded though... =back =head1 AUTHOR Randall Hansen =head1 COPYRIGHT Copyright (c) 2003-2005 Randall Hansen. All rights reserved. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut # $Id: text.pm 75 2005-01-14 05:49:20Z soh $ CGI-ValidOp-0.56/lib/CGI/ValidOp/Check/sql.pm0000644000175000017550000000445011304772200020206 0ustar exodistexodistpackage CGI::ValidOp::Check::sql; use strict; use warnings; use base qw/ CGI::ValidOp::Check /; sub default { ( qr|^[\w\s\.:\[\]_\^\*/%+<>=~!@#&\|`\?\$\(\),;'"-]+$|, q{Only letters, numbers, and the following punctuation are allowed for $label: . : [ ] _ ^ * / % + - <> = ~ ! @ # & | ` ? $ ( ) , ; ' "}, ) } sub safer { my $self = shift; sub { my( $value ) = @_; my $error = _safer( $value ); return $self->fail( $error ) if $error; return $self->fail( "SELECT statement not allowed for \$label" ) if $value =~ /select/i; $value =~ /^(.*)$/s; return $self->pass( $1 ); } } sub safer_select { my $self = shift; sub { my( $value ) = @_; my $error = _safer( $value ); return $self->fail( $error ) if $error; $value =~ /^(.*)$/s; return $self->pass( $1 ); } } sub _safer { my( $value ) = @_; return "Semicolons not allowed for \$label" if $value =~ /[;]/; return "Dashes not allowed for \$label" if $value =~ /[-]/; return "DELETE statement not allowed for \$label" if $value =~ /delete/i; return "DROP statement not allowed for \$label" if $value =~ /drop/i; return "UPDATE statement not allowed for \$label" if $value =~ /update/i; return "INTO statement not allowed for \$label" if $value =~ /into/i; return; } 1; __END__ =head1 NAME CGI::ValidOp::Check::sql - CGI::ValidOp::Check module to validate SQL. =head1 DESCRIPTION =over 4 =item default Fails if incoming value contains characters other than: \w \s . : [ ] _ ^ * / % + - <> = ~ ! @ # & | ` ? $ ( ) , ; ' " =item safer Named "safer" since allowing users to write SQL can never be truly "safe." This check attempts to allow only things which will not harm data. It doesn't prevent a clever query from wreaking other havoc, though, like a DOS. =item safer_select Just like "safer" but allows 'SELECT'. =back =head1 AUTHOR Randall Hansen =head1 COPYRIGHT Copyright (c) 2003-2007 Randall Hansen. All rights reserved. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut CGI-ValidOp-0.56/lib/CGI/ValidOp/Check/required_if.pm0000644000175000017550000000100711304772200021700 0ustar exodistexodistpackage CGI::ValidOp::Check::required_if; use strict; use warnings; use base qw/ CGI::ValidOp::Check /; sub default { my $self = shift; sub { my ( $value, $cond ) = @_; # pass if both are set OR if both are unset # see caveats in Check::alternative too my $cgi = CGI->new; return $self->pass unless $cgi->param( $cond ); return $self->fail( "\$label is required." ) unless $value; $value =~ m/^(.*)$/; return $self->pass( "$1" ); }; } 1; CGI-ValidOp-0.56/lib/CGI/ValidOp/Check/alternative.pm0000644000175000017550000000205711304772200021726 0ustar exodistexodistpackage CGI::ValidOp::Check::alternative; use strict; use warnings; use base qw/ CGI::ValidOp::Check /; use CGI; sub default { my $self = shift; sub { my ( $value, $cond ) = @_; # Pass if there is a value, and the conditional is empty # Pass if the value is empty but the conditional is not # Pass if both are set # FIXME: Only need to check if the parameter is true or false # this means this is safe in that we won;t be bringing in anything # bad, however since this is being queried from CGI instead of validop # it will return true even if '$cond' is not validated. This is not # critical, but should be resolved. my $CGI = CGI->new; #Randall, please don't kill me. return $self->pass if $CGI->param( $cond ); if ( $value ) { $value =~ m/^(.*)$/; return $self->pass( $1 ); } #Fail saying the label is required because the condition has not been met. return $self->fail( "\$label is required." ); } } 1; CGI-ValidOp-0.56/lib/CGI/ValidOp/Check/number.pm0000644000175000017550000000361111304772200020675 0ustar exodistexodistpackage CGI::ValidOp::Check::number; use strict; use warnings; use base qw/ CGI::ValidOp::Check /; sub default { ( qr/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/, '$label must be a number.', ) } sub integer { ( qr/^[+-]?\d+$/, '$label must be an integer.', ) } sub decimal { ( qr/^-?(?:\d+(?:\.\d*)?|\.\d+)$/, '$label must be a decimal number.', ) } sub positive_int { ( qr/^[+]?\d+$/, '$label must be a positive integer.', ) } sub positive_list { my $self = shift; sub { my ( $input ) = @_; return $self->pass() unless defined $input; $input =~ m/(.*)/g; $input = $1; my @values = split(/\s*,\s*/, $input ); my @bad; for my $value ( @values ) { next if $value =~ m/^[+]?\d+$/; push( @bad, $value ); } if ( @bad ) { my $error = '$label: "' . join( ', ', @bad ); $error .= (@bad > 1) ? '" are not positive integers.' : '" is not a positive integer.'; return $self->fail( $error ); } return $self->pass( join(', ', @values )); } } 1; __END__ =head1 NAME CGI::ValidOp::Check::number - CGI::ValidOp::Check module to check for numericity. =head1 DESCRIPTION =over 4 =item default Checks for something that looks like a number. =item integer Checks for an integer, positive or negative; includes 0. =item decimal Checks for a decimal, positive or negative; includes 0. =back =head1 AUTHOR Randall Hansen =head1 COPYRIGHT Copyright (c) 2003-2005 Randall Hansen. All rights reserved. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut # $Id: number.pm 75 2005-01-14 05:49:20Z soh $ CGI-ValidOp-0.56/lib/CGI/ValidOp/Check/demographics.pm0000644000175000017550000000604611304772200022057 0ustar exodistexodistpackage CGI::ValidOp::Check::demographics; use strict; use warnings; use base qw/ CGI::ValidOp::Check /; # sub default { # ( # qr/^on$/i, # q#Parameter $label must be a US state name.#, # ) # } sub us_state2 { my $self = shift; sub { my $value = shift; return $self->pass unless defined $value; my $errmsg = q/$label must be the 2-letter abbreviation for a US state name./; return $self->fail( $errmsg ) unless $value =~ /^\w{2}$/; return $self->pass( $1 ) if $value =~ qr/^(al|ak|as|az|ar|ca|co|ct|de|dc|fm|fl|ga|gu|hi|id|il|in|ia|ks|ky|la|me|mh|md|ma|mi|mn|ms|mo|mt|ne|nv|nh|nj|nm|ny|nc|nd|mp|oh|ok|or|pw|pa|pr|ri|sc|sd|tn|tx|ut|vt|vi|va|wa|wv|wi|wy)$/i; $self->fail( $errmsg ); } } sub us_ssn { my $self = shift; sub { my( $value, $constraint ) = @_; return $self->pass unless defined $value; if( $value =~ /(^\d{3}-?\d{2}-?\d{4}$)/ ) { my $ssn = $1; $ssn =~ s/-//g if $constraint and $constraint eq 'integer'; return $self->pass( $ssn ); } return $self->fail( q/$label must be a number like "123-45-6789"./); } } 1; __END__ =head1 NAME CGI::ValidOp::Check::demographics - CGI::ValidOp::Check module to validate various demographics. =head1 DESCRIPTION =over 4 =item default Should die. =item us_state2 Passes if value is a valid United States 2-letter abbreviation, as determined by the USPS: http://www.usps.com/ncsc/lookups/usps_abbreviations.html. =item us_ssn($constraint) Passes if value is a 9-digit integer with optional dashes (e.g. 123-45-6789). If C<$constraint> is C the dashes are stripped: # given CGI variable 'ssn' equal to '123-45-6789' $ssn = $cgi->param( 'ssn', [ 'demographics::ssn' ]); # eq '123-45-6789' $ssn = $cgi->param( 'ssn', [ 'demographics::ssn(integer)' ]); # eq '123456789' =back =head1 AUTHOR Randall Hansen =head1 COPYRIGHT Copyright (c) 2003-2005 Randall Hansen. All rights reserved. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut # $Id: demographics.pm 75 2005-01-14 05:49:20Z soh $ __DATA__ AL AK AS AZ AR CA CO CT DE DC FM FL GA GU HI ID IL IN IA KS KY LA ME MH MD MA MI MN MS MO MT NE NV NH NJ NM NY NC ND MP OH OK OR PW PA PR RI SC SD TN TX UT VT VI VA WA WV WI WY ALABAMA ALASKA AMERICAN SAMOA ARIZONA ARKANSAS CALIFORNIA COLORADO CONNECTICUT DELAWARE DISTRICT OF COLUMBIA FEDERATED STATES OF MICRONESIA FLORIDA GEORGIA GUAM HAWAII IDAHO ILLINOIS INDIANA IOWA KANSAS KENTUCKY LOUISIANA MAINE MARSHALL ISLANDS MARYLAND MASSACHUSETTS MICHIGAN MINNESOTA MISSISSIPPI MISSOURI MONTANA NEBRASKA NEVADA NEW HAMPSHIRE NEW JERSEY NEW MEXICO NEW YORK NORTH CAROLINA NORTH DAKOTA NORTHERN MARIANA ISLANDS OHIO OKLAHOMA OREGON PALAU PENNSYLVANIA PUERTO RICO RHODE ISLAND SOUTH CAROLINA SOUTH DAKOTA TENNESSEE TEXAS UTAH VERMONT VIRGIN ISLANDS VIRGINIA WASHINGTON WEST VIRGINIA WISCONSIN WYOMING CGI-ValidOp-0.56/lib/CGI/ValidOp/Op.pm0000644000175000017550000000571011304772200016750 0ustar exodistexodistpackage CGI::ValidOp::Op; use strict; use warnings; use base qw/ CGI::ValidOp::Base /; use CGI::ValidOp::Param; use Data::Dumper; use Carp; # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub PROPERTIES { { name => undef, alias => undef, error_op => undef, -error_decoration => undef, on_error_return => 'undef', } } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # the argument parsing means: # 1) if an argument is an existing method, take it as a config option # 2) else take it as a param # FIXME should have a params key instead; this is too magical sub init { my $self = shift; my( $args ) = @_; $self->SUPER::init; # FIXME nasty hack to get around methods not being # defined 'cause we return if no input $self->set_name( $args ) or croak 'Name required in CGI::ValidOp::Op::init.'; return $self unless ref $args eq 'HASH'; my( %config, %params ); for( keys %$args ) { $self->can( $_ ) ? $config{ $_ } = $args->{ $_ } : $params{ $_ } = $args->{ $_ }; } $self->SUPER::init( \%config ); for( keys %params ) { $params{ $_ }->{ name } = $_; $self->add_param( $params{ $_ }); } $self; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # takes a hashref specifying a parameter sub add_param { my $self = shift; my( $vars ) = @_; if( defined $vars and ref $vars eq '' ) { $vars = { name => $vars }; } $vars->{ on_error_return } = $self->on_error_return; croak 'no param created' unless my $param = CGI::ValidOp::Param->new( $vars ); $param->error_decoration( $self->error_decoration ); $self->{ _params }{ $param->name } = $param; $param; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # returns all Param objects unless asked for one # also sets new checks for a param if they're given sub Param { my $self = shift; my( $param_name, $checks ) = @_; if( $param_name ) { my $param = $self->{ _params }{ $param_name }; $param->checks( $checks ) if $param and $checks; return $param; } my @params; push @params => $self->{ _params }{ $_ } for sort keys %{ $self->{ _params }}; return unless @params; wantarray ? @params : \@params; } 1; __END__ =head1 NAME CGI::ValidOp::Op - Op object for CGI::ValidOp =head1 DESCRIPTION Implements an Op object, which contains parameters. Used internally by CGI::ValidOp; please see the L documentation. =head1 AUTHOR Randall Hansen =head1 COPYRIGHT Copyright (c) 2003-2005 Randall Hansen. All rights reserved. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut # $Id: Op.pm 388 2005-04-22 16:11:04Z soh $ CGI-ValidOp-0.56/lib/CGI/ValidOp/Object.pm0000644000175000017550000002442711305007556017614 0ustar exodistexodist#=============================================================================== # # FILE: CGI/ValidOp/Object.pm # # DESCRIPTION: Object-level parameters for CGI::ValidOp # # FILES: --- # BUGS: --- # NOTES: --- # AUTHOR: Erik Hollensbe (), # COMPANY: OpenSourcery, LLC # VERSION: 1.0 # CREATED: 01/13/2008 03:48:07 PST # REVISION: $Id$ #=============================================================================== package CGI::ValidOp::Object; use strict; use warnings; use Carp qw(croak confess); use base qw(CGI::ValidOp::Base); use CGI::ValidOp::Param; use Data::Dumper; sub PROPERTIES { { name => undef, -min_objects => 0, -max_objects => 0, -fields_required => [], -construct_object => undef, } } # constructor. requires a name (text) and an args definition (hash of array) #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub init { my $self = shift; my ($name, $args) = (@_); croak ("No name") unless defined $name; croak ("No arguments") unless $args; croak ("Args must be a hash") unless ref $args eq 'HASH'; $self->SUPER::init($args); $self->set_name( { name => $name } ); $self->{_param_template} = { }; foreach my $arg (keys %$args) { if ($arg =~ /^-/) { $arg =~ s/^-//; $self->$arg($args->{"-$arg"}); } else { my ($label, @checks) = @{$args->{$arg}}; $self->{_param_template}{$arg} = CGI::ValidOp::Param->new( { name => $arg, label => $label, checks => \@checks, } ); } } $self->{_validated} = 0; $self->{_errors} = []; $self->{_objects} = []; return $self; } # sets a var on an object. requires a hash with a name and value which would # supposedly come from the CGI object. # # A lot of validation happens here. It probably shouldn't, but it's much # cleaner this way. # # Builds C::V::Param objects out from this data and fills an array of hash with # it in _objects. # # While this could be used to set one thing at a time, set_vars() is probably # better for that, and conforms to the rest of the external API. #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub set_var { my $self = shift; my ($args) = @_; croak ("args must be hash") unless (defined $args and ref $args eq 'HASH'); croak ("missing parameters in args hash") unless (defined $args->{name} and exists $args->{value}); # XXX: this regex parses foo[0][key] into "foo", 0, "key". Don't touch it. $args->{name} =~ /^([^\[]+?)\[(\d+?)\]\[([^\]]+?)\]$/ || $args->{name} =~ /^object--(\w+)--(\d+)--(\w+)/; my ($param_name, $index, $key) = ($1, $2, $3); unless (defined($param_name) && defined($index) && defined($key)) { ($param_name, $index, $key) = map { defined($_) ? $_ : "Unknown" } ($param_name, $index, $key); croak ("Invalid parameter ($args->{name}, $param_name, $index, $key) in ".__PACKAGE__."::set_var(): not enough data") } croak ("Name does not match this object") unless ($param_name eq $self->name); unless (defined($self->{_param_template}{$key})) { $self->{_param_template}{$key} = new CGI::ValidOp::Param( { name => $key, label => $key, checks => [] } ); } # croak ("Parameter ($key) for object (".$self->name.") does not match object template") # unless (defined($self->{_param_template}{$key})); $self->{_objects}[$index] ||= { }; my $param = $self->{_param_template}{$key}; $param = $param->clone; $param->name($args->{name}); $param->tainted($args->{value}); $self->{_objects}[$index]{$key} = $param; return $param; } # sets multiple vars on an object. key => value association. See set_var() for # more information. #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub set_vars { my $self = shift; my ($args) = @_; croak ("args must be hash") unless (defined $args and ref $args eq 'HASH'); while (my ($name, $value) = each %$args) { $self->set_var({ name => $name, value => $value }); } return 1; } # Normalizes objects so that they have all parameters and constraints. #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub normalize_objects { my $self = shift; @{$self->{_objects}} = grep defined($_), @{$self->{_objects}}; foreach my $object (@{$self->{_objects}}) { foreach my $template_name (keys %{$self->{_param_template}}) { if (!exists($object->{$template_name})) { $object->{$template_name} = $self->{_param_template}{$template_name}->clone; } } foreach my $param_name (keys %$object) { # XXX: this is a bit dirty, but I didn't want to modify Param's API. # yet another reason not to call validate() twice. if ( scalar grep $param_name, @{$self->fields_required} and !scalar grep 'required', @{$object->{$param_name}{checks}} ) { $object->{$param_name}->required(1); push @{$object->{$param_name}{checks}}, 'required'; } } } return 1; } # Validates all the params on the object. #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub validate { my $self = shift; return if $self->{_validated}; # this should croak because someone flubbed an ops definition. croak ("min_objects is greater than max_objects") if ($self->min_objects gt $self->max_objects and $self->max_objects gt 0); $self->normalize_objects; foreach my $object (@{$self->{_objects}}) { foreach my $param_name (keys %$object) { # XXX: this is a bit of a hack. Since we want encoded entities and # this is tightly coupled in Param, we override param's {value} # value with the value returned. I'm not sure if this is such a hot # idea, but ATM can't think of a better one. # # e.g., this could lead to double-encoding if validate is called # twice. $object->{$param_name}{value} = $object->{$param_name}->value; } } $self->global_errors("object violation: min_objects (".$self->min_objects.") has been violated") if ($self->min_objects and $self->min_objects gt @{$self->{_objects}}); $self->global_errors("object violation: max_objects (".$self->max_objects.") has been violated") if ($self->max_objects and $self->max_objects lt @{$self->{_objects}}); $self->{_validated} = 1; return; } # # global_errors is a private interface that is an acccessor (with append only) # to set errors that are global to this class of objects. #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub global_errors { my $self = shift; push @{$self->{_errors}}, $_ for (@_); return $self->{_errors}; } # object_errors is another external interface. it provides the errors for our # parameters. #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub object_errors { my $self = shift; $self->validate; my $objects = [ ]; foreach my $object (@{$self->{_objects}}) { push @$objects, { map { $_ => ($object->{$_}->errors || [ ]) } keys %$object }; } return { global_errors => $self->global_errors, object_errors => $objects }; } # objects is the external interface to the end-user. it's passed through validop #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub objects { my $self = shift; $self->validate; my $objects = [ ]; foreach my $object (@{$self->{_objects}}) { if ($self->construct_object) { my $new_obj = $self->construct_object->new( { map { ( $_ => ( defined( $object->{$_}->value ) ? $object->{$_}->value : undef ) ) } keys %$object } ); push @$objects, $new_obj; } else { push @$objects, { map { $_ => ( defined( $object->{$_}->value ) ? $object->{$_}->value : undef ) } keys %$object }; } } return $objects; } # # Accessors #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub max_objects { my $self = shift; $self->{max_objects} = shift if (defined $_[0]); return $self->{max_objects}; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub min_objects { my $self = shift; $self->{min_objects} = shift if (defined $_[0]); return $self->{min_objects}; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub fields_required { my $self = shift; $self->{fields_required} = shift if (defined $_[0]); return $self->{fields_required}; } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub construct_object { my $self = shift; $self->{construct_object} = shift if (@_); return $self->{construct_object}; } 'validop'; __END__ =head1 NAME CGI::ValidOp::Object - CGI<->object bridge for CGI::ValidOp =head1 DESCRIPTION Implements a CGI<->object bridge. Used internally by CGI::ValidOp; please see the L documentation. =head1 AUTHORS Erik Hollensbe Chad Granum =head1 COPYRIGHT Copyright (c) 2003-2006 Randall Hansen. All rights reserved. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut CGI-ValidOp-0.56/lib/CGI/ValidOp/Test.pm0000644000175000017550000001301111304772200017302 0ustar exodistexodistpackage CGI::ValidOp::Test; use strict; use warnings; require Exporter; use vars qw/ @ISA @EXPORT $one $tmp @tmp %tmp $vars1 $ops1 $ops2 $ops3 /; @ISA = qw/ Exporter /; @EXPORT = qw/ $vars1 $ops1 $ops2 $ops3 &check_taint &check_check &init_param &init_obj init_obj_via_cgi_pm /; use Carp; use Data::Dumper; use Test::More; use Test::Taint; # {{{ data 1 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $vars1 = { name => 'Mouse-a-meal', item => 'Cat food', price => '10.99', shipping => 'FedEx', client_email => 'whitemice@hyperintelligent_pandimensional_beings.com', no_client => 1, client => undef, }; $ops1 = { add => { name => [ 'item brand name', 'required' ], item => [ 'item name', 'required' ], number => [ 'item number', 'required' ], shipping => [ 'shipping method', 'required' ], client => [ 'client name', 'alternative(no_client)' ], no_client => [ 'no client option' ], client_email => [ 'client email address', 'email' ], }, remove => { number => [ 'item number', 'required' ], item => [ 'item name', 'required' ], }, }; $ops2 = { add => { stuff => { name => [ 'item brand name', 'required' ], item => [ 'item name', 'required' ], number => [ 'item number', 'required' ], shipping => [ 'shipping method', 'required' ], client => [ 'client name', 'alternative(no_client)' ], no_client => [ 'no client option' ], client_email => [ 'client email address', 'email' ], } } }; $ops3 = { add => { stuff => { -construct_object => 'Stuff', name => [ 'item brand name', 'required' ], item => [ 'item name', 'required' ], number => [ 'item number', 'required' ], shipping => [ 'shipping method', 'required' ], client => [ 'client name', 'alternative(no_client)' ], no_client => [ 'no client option' ], client_email => [ 'client email address', 'email' ], } } }; # }}} # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub check_check { my( $check_name, $value, $expect_value, $expect_tainted, $errmsg ) = @_; no warnings qw/ uninitialized /; # many of these values are optional taint_checking_ok( undef ); taint( $value ); tainted_ok( $value ); my $test_id = $errmsg ? "testing: $value fails with $check_name" : "testing: $value = $expect_value with $check_name"; my $caller = join ' : ' => ( caller() )[ 1, 2 ]; my $param = CGI::ValidOp::Param->new({ name => 'tester', label => 'William Blake' }); ok( $param->isa( 'CGI::ValidOp::Param' ), $test_id ); my $new_value; eval{ $new_value = $param->check( $value, $check_name )}; croak "Unexpected check failure: $@" if $@ and $expect_value ne 'DIE'; # if we tell it to expect 'DIE', then it should die and we match # $@ against the expected error message defined $expect_value and $expect_value eq 'DIE' ? like( $@, qr/$errmsg/, $caller ) : is( $new_value, $expect_value, $caller ); $expect_tainted ? tainted_ok( $new_value, $caller ) : untainted_ok( $new_value, $caller ); $errmsg and !( $expect_value and $expect_value eq 'DIE' ) ? like( @{ $param->errors }[0], qr/$errmsg/, $caller ) : is( $param->errors, undef, $caller ); } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub init_param { my $spec = shift; ok( my $param = CGI::ValidOp::Param->new( $spec )); $param; } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub init_obj { $ENV{ REQUEST_METHOD } = 'GET'; $ENV{ QUERY_STRING } = join '&', "comment=Now is the time for\nall good men\nto come to the aid", 'crackme=$ENV{ meat_of_evil }', 'date=2004-09-29', 'name=Mouse-a-meal', 'item=Cat food', 'multi=banana', 'multi=orange', 'multi=plum', 'notdefined=', 'op=add', 'price=10.99', 'shipping=FedEx', 'unexpect=I am the slime', 'checkme=ON', 'donotcheckme=', 'xssme=', 'client_email=whitemice@hyperintelligent_pandimensional_beings.com', 'no_client=1', 'client=disappear', ; my $obj = CGI::ValidOp->new ( @_ ); ok( $obj->isa( 'CGI::ValidOp' )); return $obj; } sub init_obj_via_cgi_pm { my ($params, $ops) = @_; my $q = new CGI; $q->param( -name => $_, -value => $params->{$_} ) foreach (keys %$params); return CGI::ValidOp->new({ -cgi_object => $q, %$ops}); } 1; __END__ =head1 NAME CGI::ValidOp::Test - test class for CGI::ValidOp and its associates. =head1 DESCRIPTION none yet =head1 AUTHOR Randall Hansen =head1 COPYRIGHT Copyright (c) 2003-2005 Randall Hansen. All rights reserved. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut # $Id: Base.pm 40 2004-10-03 06:26:24Z soh $ CGI-ValidOp-0.56/TODO0000644000175000017550000000336011304772200014015 0ustar exodistexodistnow --- lowercase all ops automatically checks shouldn't have to be under CGI::ValidOp::Check checks should be found locally on the filesystem decide: new({ -config param/op }) OR new({ config params/ops => { param/op } }) file upload ----------- use CGI qw/ -private_tempfiles /; - or - CGI::private_tempfiles(1);
- test with: application/x-www-form-urlencoded check cgi_error size and type per file? cgi->upload (new in 2.47) $fh = upload('uploaded_file'); while (<$fh>) { print; } $filename = param('uploaded_file'); $type = uploadInfo($filename)->{'Content-Type'}; unless ($type eq 'text/html') { die "HTML FILES ONLY!"; } my $handler = CGI::Untaint->new( map { $_ => $cgi->param($_) } $cgi->param); # NOT my $handler = CGI::Untaint->new( $cgi->Vars ); ! # It's important that you use CGI->param rather than CGI->Vars as the latter # only returns the uploaded file's name and not its contents. maybe ----- make ::Param->{ errors } a hashref -- ::Param warnings, add_error, errors -- in ::Base? find a better way to pass around error_decoration later ----- auto-vivify ops? -- ValidOp::add_param done ---- better parsing of incoming params -- ValidOp::add_param better error message if require fails -- ::Param::load_pkg setting 'op' should also create Op object -- ValidOp::op needs 'name' method -- ::Base needs 'param' method -- ::Op needs 'Param' method -- ::Op needs 'params' method -- ::Op (note is in ValidOp) needs 'Params' method -- ::Op (note is in ValidOp) allow_unexpected -- ValidOp::make_params ValidOp::Vars ValidOp::errors make 'default' a variable instead of hardcoded -- ::Param::check_one CGI-ValidOp-0.56/pod2html.pl0000755000175000017550000000062211304772200015414 0ustar exodistexodist#!/usr/bin/perl use strict; use warnings; use Pod::Simple::HTMLBatch; my $pod = Pod::Simple::HTMLBatch->new; $pod->css_flurry( 0 ); $pod->javascript_flurry( 0 ); $pod->add_css( '/res/css/cpan.css' ); $pod->batch_convert( [ 'lib/CGI', 'lib/CGI/ValidOp' ], '/Users/soh/public_html/dev/validop/pod' ); # $pod->batch_convert( [ '/System/Library/Perl/5.8.1/CGI.pm' ], '/Users/soh/public_html/doc/cgi' ); CGI-ValidOp-0.56/LICENSE0000644000175000017550000005010111304772200014325 0ustar exodistexodistTerms of Perl itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --------------------------------------------------------------------------- The General Public License (GPL) Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 675 Mass Ave, Cambridge, MA 02139, USA. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS --------------------------------------------------------------------------- The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. 9. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End CGI-ValidOp-0.56/README0000644000175000017550000000274211304772200014210 0ustar exodistexodistCGI::ValidOp Simple validation of CGI parameters and runmodes. DESCRIPTION CGI::ValidOp is a CGI parameter validator that also helps you manage runmodes. Its aims are similar to Perl's: make the easy jobs easy and the complex jobs possible. CGI parameter validation is boring, and precisely for that reason it's easy to get wrong or ignore. CGI::ValidOp takes as much of the repetition as possible out of this job, replacing it with a simple interface. Any data provided by CGI::ValidOp's parameter methods will have been untainted and validated. In addition to validating parameters, CGI::ValidOp has a number of methods for dealing with runmodes (henceforth referred to as 'ops'). In fact, the 'op' concept is key to ValidOp's advanced usage: parameters are subsidiary to ops. Each op has zero or more parameters, each defined with as much or as little specificity as you please. If you're going to trust someone else's code for security purposes it's nice to have proof that it works. CGI::ValidOp has an extensive test suite that checks every part of its operation, particularly the validation routines. I keep the current version running at http://sonofhans.net/validop with a full test page. If you can produce unexpected output, file a bug report. AUTHOR Randall Hansen ACKNOWLEDGEMENTS Thanks to: Josh Heumann for good simplification advice; Joshua Keroes for trading code review for beer; Alison Randall for thinking it was a good idea in the first place. CGI-ValidOp-0.56/Changes0000644000175000017550000000061011305017130014606 0ustar exodistexodist0.55 Mon, 30 Dec 2009 11:34:47 -0800 - Make object params available through standard interface 0.54 Mon, 30 Dec 2009 10:50:00 -0800 - Add new way to format object cgi parameters 0.53 Mon, 08 Jun 2009 13:20:01 -0700 - add required_if() check 0.52 Tue, 07 Apr 2009 08:40:23 -0700 - add missing prereq for Test::Taint 0.51 Mon, 06 Apr 2009 - First CPAN release CGI-ValidOp-0.56/Makefile.PL0000644000175000017550000000051611304772200015277 0ustar exodistexodistuse inc::Module::Install; name 'CGI-ValidOp'; all_from 'lib/CGI/ValidOp.pm'; requires 'HTML::Entities' => 0; requires 'CGI' => 0; test_requires 'Test::Taint' => 0; test_requires 'Test::More' => 0; test_requires 'Test::Exception' => 0; repository 'https://svn.opensourcery.com/public/projects/validop/trunk'; WriteAll; CGI-ValidOp-0.56/META.yml0000644000175000017550000000125011310301037014563 0ustar exodistexodist--- abstract: 'Simple validation of CGI parameters and runmodes.' author: - '-2005 Randall Hansen. All rights reserved.' build_requires: ExtUtils::MakeMaker: 6.42 Test::Exception: 0 Test::More: 0 Test::Taint: 0 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 0.91' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: CGI-ValidOp no_index: directory: - inc - t requires: CGI: 0 HTML::Entities: 0 resources: license: http://dev.perl.org/licenses/ repository: https://svn.opensourcery.com/public/projects/validop/trunk version: 0.56 CGI-ValidOp-0.56/INSTALL0000644000175000017550000000033111304772200014351 0ustar exodistexodistINSTALLATION perl Makefile.PL make make test make install If you are on a windows box you should use 'nmake' rather than 'make'. PREREQUISITES None, other than Perl 5.005 itself and the modules that come with it. CGI-ValidOp-0.56/MANIFEST0000644000175000017550000000234411310301044014446 0ustar exodistexodistbin/encode.pl Changes inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm INSTALL lib/CGI/ValidOp.pm lib/CGI/ValidOp/Base.pm lib/CGI/ValidOp/Check.pm lib/CGI/ValidOp/Check/alternative.pm lib/CGI/ValidOp/Check/checkbox.pm lib/CGI/ValidOp/Check/date.pm lib/CGI/ValidOp/Check/demographics.pm lib/CGI/ValidOp/Check/email.pm lib/CGI/ValidOp/Check/length.pm lib/CGI/ValidOp/Check/number.pm lib/CGI/ValidOp/Check/required_if.pm lib/CGI/ValidOp/Check/sql.pm lib/CGI/ValidOp/Check/text.pm lib/CGI/ValidOp/Object.pm lib/CGI/ValidOp/Op.pm lib/CGI/ValidOp/Param.pm lib/CGI/ValidOp/Test.pm LICENSE Makefile.PL MANIFEST This list of files META.yml pod2html.pl README t/00test.t t/01base.t t/02check.t t/03param.t t/04op.t t/05object-legacy.t t/06object-new.t t/10validop.t t/11check_length.t t/12check_text.t t/13check_number.t t/14check_checkbox.t t/15check_demographics.t t/16check_date.t t/17check_sql.t t/18check_email.t t/19check_alternative.t t/20check_required_if.t t/91cgi_basic.cgi t/99workflow1.t t/99workflow2.t t/99workflow3.t t/99workflow4.t t/99workflow5.t t/99workflow6.t TODO