check.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

package Params::Check;

use strict;

use Carp                        qw[carp croak];
use Locale::Maketext::Simple    Style => 'gettext';

use Data::Dumper;

BEGIN {
    use Exporter    ();
    use vars        qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $ALLOW_UNKNOWN
                        $STRICT_TYPE $STRIP_LEADING_DASHES $NO_DUPLICATES
                        $PRESERVE_CASE $ONLY_ALLOW_DEFINED $WARNINGS_FATAL
                        $SANITY_CHECK_TEMPLATE $CALLER_DEPTH $_ERROR_STRING
                    ];

    @ISA        =   qw[ Exporter ];
    @EXPORT_OK  =   qw[check allow last_error];

    $VERSION                = '0.26';
    $VERBOSE                = $^W ? 1 : 0;
    $NO_DUPLICATES          = 0;
    $STRIP_LEADING_DASHES   = 0;
    $STRICT_TYPE            = 0;
    $ALLOW_UNKNOWN          = 0;
    $PRESERVE_CASE          = 0;
    $ONLY_ALLOW_DEFINED     = 0;
    $SANITY_CHECK_TEMPLATE  = 1;
    $WARNINGS_FATAL         = 0;
    $CALLER_DEPTH           = 0;
}

my %known_keys = map { $_ => 1 }
                    qw| required allow default strict_type no_override
                        store defined |;

=pod

=head1 NAME

Params::Check - A generic input parsing/checking mechanism.

=head1 SYNOPSIS

    use Params::Check qw[check allow last_error];

    sub fill_personal_info {
        my %hash = @_;
        my $x;

        my $tmpl = {
            firstname   => { required   => 1, defined => 1 },
            lastname    => { required   => 1, store => \$x },
            gender      => { required   => 1,
                             allow      => [qr/M/i, qr/F/i],
                           },
            married     => { allow      => [0,1] },
            age         => { default    => 21,
                             allow      => qr/^\d+$/,
                           },

            phone       => { allow => [ sub { return 1 if /$valid_re/ },
                                        '1-800-PERL' ]
                           },
            id_list     => { default        => [],
                             strict_type    => 1
                           },
            employer    => { default => 'NSA', no_override => 1 },
        };

        ### check() returns a hashref of parsed args on success ###
        my $parsed_args = check( $tmpl, \%hash, $VERBOSE )
                            or die qw[Could not parse arguments!];

        ... other code here ...
    }

    my $ok = allow( $colour, [qw|blue green yellow|] );

    my $error = Params::Check::last_error();


=head1 DESCRIPTION

Params::Check is a generic input parsing/checking mechanism.

It allows you to validate input via a template. The only requirement
is that the arguments must be named.

Params::Check can do the following things for you:

=over 4

=item *

Convert all keys to lowercase

=item *

Check if all required arguments have been provided

=item *

Set arguments that have not been provided to the default

=item *

Weed out arguments that are not supported and warn about them to the
user

=item *

Validate the arguments given by the user based on strings, regexes,
lists or even subroutines

=item *

Enforce type integrity if required

=back

Most of Params::Check's power comes from its template, which we'll
discuss below:

=head1 Template

As you can see in the synopsis, based on your template, the arguments
provided will be validated.

The template can take a different set of rules per key that is used.

The following rules are available:

=over 4

=item default

This is the default value if none was provided by the user.
This is also the type C<strict_type> will look at when checking type
integrity (see below).

=item required

A boolean flag that indicates if this argument was a required
argument. If marked as required and not provided, check() will fail.

=item strict_type

This does a C<ref()> check on the argument provided. The C<ref> of the
argument must be the same as the C<ref> of the default value for this
check to pass.

This is very useful if you insist on taking an array reference as
argument for example.

=item defined

If this template key is true, enforces that if this key is provided by
user input, its value is C<defined>. This just means that the user is
not allowed to pass C<undef> as a value for this key and is equivalent
to:
    allow => sub { defined $_[0] && OTHER TESTS }

=item no_override

This allows you to specify C<constants> in your template. ie, they
keys that are not allowed to be altered by the user. It pretty much
allows you to keep all your C<configurable> data in one place; the
C<Params::Check> template.

=item store

This allows you to pass a reference to a scalar, in which the data
will be stored:

    my $x;
    my $args = check(foo => { default => 1, store => \$x }, $input);

This is basically shorthand for saying:

    my $args = check( { foo => { default => 1 }, $input );
    my $x    = $args->{foo};

You can alter the global variable $Params::Check::NO_DUPLICATES to
control whether the C<store>'d key will still be present in your
result set. See the L<Global Variables> section below.

=item allow

A set of criteria used to validate a particular piece of data if it
has to adhere to particular rules.

See the C<allow()> function for details.

=back

=head1 Functions

=head2 check( \%tmpl, \%args, [$verbose] );

This function is not exported by default, so you'll have to ask for it
via:

    use Params::Check qw[check];

or use its fully qualified name instead.

C<check> takes a list of arguments, as follows:

=over 4

=item Template

This is a hashreference which contains a template as explained in the
C<SYNOPSIS> and C<Template> section.

=item Arguments

This is a reference to a hash of named arguments which need checking.

=item Verbose

A boolean to indicate whether C<check> should be verbose and warn
about what went wrong in a check or not.

You can enable this program wide by setting the package variable
C<$Params::Check::VERBOSE> to a true value. For details, see the
section on C<Global Variables> below.

=back

C<check> will return when it fails, or a hashref with lowercase
keys of parsed arguments when it succeeds.

So a typical call to check would look like this:

    my $parsed = check( \%template, \%arguments, $VERBOSE )
                    or warn q[Arguments could not be parsed!];

A lot of the behaviour of C<check()> can be altered by setting
package variables. See the section on C<Global Variables> for details
on this.

=cut

sub check {
    my ($utmpl, $href, $verbose) = @_;

    ### did we get the arguments we need? ###
    return if !$utmpl or !$href;

    ### sensible defaults ###
    $verbose ||= $VERBOSE || 0;

    ### clear the current error string ###
    _clear_error();

    ### XXX what type of template is it? ###
    ### { key => { } } ?
    #if (ref $args eq 'HASH') {
    #    1;
    #}

    ### clean up the template ###
    my $args = _clean_up_args( $href ) or return;

    ### sanity check + defaults + required keys set? ###
    my $defs = _sanity_check_and_defaults( $utmpl, $args, $verbose )
                    or return;

    ### deref only once ###
    my %utmpl   = %$utmpl;
    my %args    = %$args;
    my %defs    = %$defs;

    ### flag to see if anything went wrong ###
    my $wrong; 
    
    ### flag to see if we warned for anything, needed for warnings_fatal
    my $warned;

    for my $key (keys %args) {

        ### you gave us this key, but it's not in the template ###
        unless( $utmpl{$key} ) {

            ### but we'll allow it anyway ###
            if( $ALLOW_UNKNOWN ) {
                $defs{$key} = $args{$key};

            ### warn about the error ###
            } else {
                _store_error(
                    loc("Key '%1' is not a valid key for %2 provided by %3",
                        $key, _who_was_it(), _who_was_it(1)), $verbose);
                $warned ||= 1;
            }
            next;
        }

        ### check if you're even allowed to override this key ###
        if( $utmpl{$key}->{'no_override'} ) {
            _store_error(
                loc(q[You are not allowed to override key '%1'].
                    q[for %2 from %3], $key, _who_was_it(), _who_was_it(1)),
                $verbose
            );
            $warned ||= 1;
            next;
        }

        ### copy of this keys template instructions, to save derefs ###
        my %tmpl = %{$utmpl{$key}};

        ### check if you were supposed to provide defined() values ###
        if( ($tmpl{'defined'} || $ONLY_ALLOW_DEFINED) and
            not defined $args{$key}
        ) {
            _store_error(loc(q|Key '%1' must be defined when passed|, $key),
                $verbose );
            $wrong ||= 1;
            next;
        }

        ### check if they should be of a strict type, and if it is ###
        if( ($tmpl{'strict_type'} || $STRICT_TYPE) and
            (ref $args{$key} ne ref $tmpl{'default'})
        ) {
            _store_error(loc(q|Key '%1' needs to be of type '%2'|,
                        $key, ref $tmpl{'default'} || 'SCALAR'), $verbose );
            $wrong ||= 1;
            next;
        }

        ### check if we have an allow handler, to validate against ###
        ### allow() will report its own errors ###
        if( exists $tmpl{'allow'} and not do {
                local $_ERROR_STRING;
                allow( $args{$key}, $tmpl{'allow'} )
            }         
        ) {
            ### stringify the value in the error report -- we don't want dumps
            ### of objects, but we do want to see *roughly* what we passed
            _store_error(loc(q|Key '%1' (%2) is of invalid type for '%3' |.
                             q|provided by %4|,
                            $key, "$args{$key}", _who_was_it(),
                            _who_was_it(1)), $verbose);
            $wrong ||= 1;
            next;
        }

        ### we got here, then all must be OK ###
        $defs{$key} = $args{$key};

    }