/usr/share/perl5/HTML/Widget/Constraint/CallbackOnce.pm is in libhtml-widget-perl 1.11-3.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 | package HTML::Widget::Constraint::CallbackOnce;
use warnings;
use strict;
use base 'HTML::Widget::Constraint';
__PACKAGE__->mk_accessors(qw/callback/);
*cb = \&callback;
=head1 NAME
HTML::Widget::Constraint::CallbackOnce - CallbackOnce Constraint
=head1 SYNOPSIS
my $c = $widget->constraint( 'CallbackOnce', 'foo', 'bar' )->callback(
sub {
my ($foo, $bar) = @_;
return 1 if $foo == $bar * 2;
});
=head1 DESCRIPTION
A callback constraint which will only be run once for each call of
L<HTML::Widget/"process">.
=head1 METHODS
=head2 callback
=head2 cb
Arguments: \&callback
Requires a subroutine reference used for validation, which will be passed
a list of values corresponding to the constraint names.
L</cb> is provided as an alias to L</callback>.
=head2 process
Overrides L<HTML::Widget::Constraint/"process"> to ensure L</validate> is
only called once for each call of L</validate>.
=cut
sub process {
my ( $self, $w, $params ) = @_;
my @names = @{ $self->names };
my @values = map { $params->{$_} } @names;
my $result = $self->validate(@values);
my $results = [];
if ( $self->not ? $result : !$result ) {
for my $name (@names) {
push @$results, HTML::Widget::Error->new(
{ name => $name, message => $self->mk_message } );
}
}
return $results;
}
=head2 render_errors
Arguments: @names
A list of element names for which an error should be displayed.
If this is not set, the default behaviour is for the error to be displayed
for all of the Constraint's named elements.
=head2 validate
perform the actual validation.
=cut
sub validate {
my ( $self, @values ) = @_;
my $callback = $self->callback || sub {1};
return $callback->(@values);
}
=head1 AUTHOR
Carl Franks C<cfranks@cpan.org>
=head1 LICENSE
This library is free software, you can redistribute it and/or modify it under
the same terms as Perl itself.
=cut
1;
|