view release on metacpan or  search on metacpan

t/03_normalized_validating.t  view on Meta::CPAN

        my $desc = $test_subs->{$test}->{-desc};
        my $failure = '';
        eval { $failure = &$sub; };
        if ($@) {
            $failure = $@;
        }
        if ($failure ne '') {
            chomp $failure;
            print "not ok $test\n";
            print STDERR "    $desc - $failure\n";
            $n_failures++;
        } else {
            print "ok $test\n";
            print STDERR "    $desc - ok\n";

        }
    }
    
    print "END\n";
}

###########################################################################################

sub _current_time {
    my ($field_name, $field_value, $args_hash) = @_;
    $args_hash->{$field_name} = time;
    return 1;
}

sub _is_integer {
    my ($field_name, $field_value, $args_hash) = @_;
    unless (defined ($field_value))            { return (0, 'Not defined');    }
    unless (int($field_value) eq $field_value) { return (0, 'Not an integer'); }
    return 1;
}

sub bind_parms_test {
    my $result = eval {
        @_ = ( 
                'Handle' => Acme::Sub::Parms::TestObject->new,
                 'Thing' => Acme::Sub::Parms::TestObject->new,
                'Another' => \"example",
                'Yathing' => 1,
               );
        BindParms : (
            my $handle         : handle   [required, is_defined, can=param];
            my $thing          : thing    [optional, isa=Acme::Sub::Parms::TestObject];
            my $another_thing  : another  [optional, type=SCALAR];
            my $yathing        : yathing  [optional, is_defined, callback=_is_integer];
            my $calltime       : calltime [callback=_current_time];
            my $defaulted      : dthing   [optional, default="help me"];

        )

        unless (defined($handle) and defined($thing)) {
            return 'failed to parse named parameters';
        }
        return '';
    };
    if (not defined $result) {
        $result = "fatal error $@";
    }

    return $result;
}

###

package Acme::Sub::Parms::TestObject;

sub param {
    1;
}

sub new {
    my $self = bless {}, 'Acme::Sub::Parms::TestObject';
    return $self;
}