validatepp.pm

1. 记录每个帖子的访问人情况

        my $called = _get_called();

	my $missing = join ', ', map {"'$_'"} @missing;
	$options->{on_fail}->
            ( "Mandatory parameter" .
              (@missing > 1 ? 's': '') .
              " $missing missing in call to $called\n" );
    }

    # do untainting after we know everything passed
    foreach my $key ( grep { defined $p->{$_} && ! ref $p->{$_}
                             && ref $specs->{$_} && $specs->{$_}{untaint} }
                      keys %$p )
    {
        ($p->{$key}) = $p->{$key} =~ /(.+)/;
    }

    return wantarray ? %$p : $p;
}

sub validate_with
{
    return if $NO_VALIDATION && ! defined wantarray;

    my %p = @_;

    local $options = _get_options( (caller(0))[0], %p );

    unless ( $NO_VALIDATION )
    {
        unless ( exists $options->{called} )
        {
            $options->{called} = (caller( $options->{stack_skip} ))[3];
        }

    }

    if ( UNIVERSAL::isa( $p{spec}, 'ARRAY' ) )
    {
	return validate_pos( @{ $p{params} }, @{ $p{spec} } );
    }
    else
    {
        # intentionally ignore the prototype because this contains
        # either an array or hash reference, and validate() will
        # handle either one properly
	return &validate( $p{params}, $p{spec} );
    }
}

sub _normalize_callback
{
    my ( $p, $func ) = @_;

    my %new;

    foreach my $key ( keys %$p )
    {
        my $new_key = $func->( $key );

        unless ( defined $new_key )
        {
            die "The normalize_keys callback did not return a defined value when normalizing the key '$key'";
        }

        if ( exists $new{$new_key} )
        {
            die "The normalize_keys callback returned a key that already exists, '$new_key', when normalizing the key '$key'";
        }

        $new{$new_key} = $p->{ $key };
    }

    return \%new;
}

sub _normalize_named
{
    # intentional copy so we don't destroy original
    my %h = %{ $_[0] };

    if ( $options->{ignore_case} )
    {
        $h{ lc $_ } = delete $h{$_} for keys %h;
    }

    if ( $options->{strip_leading} )
    {
	foreach my $key (keys %h)
	{
	    my $new;
	    ($new = $key) =~ s/^\Q$options->{strip_leading}\E//;
	    $h{$new} = delete $h{$key};
	}
    }

    return \%h;
}

sub _validate_one_param
{
    my ($value, $params, $spec, $id) = @_;

    if ( exists $spec->{type} )
    {
	unless ( _get_type($value) & $spec->{type} )
	{
            my $type = _get_type($value);

	    my @is = _typemask_to_strings($type);
	    my @allowed = _typemask_to_strings($spec->{type});
	    my $article = $is[0] =~ /^[aeiou]/i ? 'an' : 'a';

            my $called = _get_called(1);

	    $options->{on_fail}->
                ( "$id to $called was $article '@is', which " .
                  "is not one of the allowed types: @allowed\n" );
	}
    }

    # short-circuit for common case
    return unless ( $spec->{isa} || $spec->{can} ||
                    $spec->{callbacks} || $spec->{regex} );

    if ( exists $spec->{isa} )
    {
	foreach ( ref $spec->{isa} ? @{ $spec->{isa} } : $spec->{isa} )
	{
	    unless ( UNIVERSAL::isa( $value, $_ ) )
	    {
		my $is = ref $value ? ref $value : 'plain scalar';
		my $article1 = $_ =~ /^[aeiou]/i ? 'an' : 'a';
		my $article2 = $is =~ /^[aeiou]/i ? 'an' : 'a';

                my $called = _get_called(1);

		$options->{on_fail}->
                    ( "$id to $called was not $article1 '$_' " .
                      "(it is $article2 $is)\n" );
	    }
	}
    }

    if ( exists $spec->{can} )
    {
	foreach ( ref $spec->{can} ? @{ $spec->{can} } : $spec->{can} )
	{
            unless ( UNIVERSAL::can( $value, $_ ) )
            {
                my $called = _get_called(1);

                $options->{on_fail}->( "$id to $called does not have the method: '$_'\n" );
            }
	}
    }

    if ( $spec->{callbacks} )
    {
        unless ( UNIVERSAL::isa( $spec->{callbacks}, 'HASH' ) )
        {
            my $called = _get_called(1);

            $options->{on_fail}->
                ( "'callbacks' validation parameter for $called must be a hash reference\n" );
        }


	foreach ( keys %{ $spec->{callbacks} } )
	{
            unless ( UNIVERSAL::isa( $spec->{callbacks}{$_}, 'CODE' ) )
            {
                my $called = _get_called(1);

                $options->{on_fail}->( "callback '$_' for $called is not a subroutine reference\n" );
            }

            unless ( $spec->{callbacks}{$_}->($value, $params) )
            {
                my $called = _get_called(1);

                $options->{on_fail}->( "$id to $called did not pass the '$_' callback\n" );
            }
	}
    }

    if ( exists $spec->{regex} )
    {
        unless ( $value =~ /$spec->{regex}/ )
        {
            my $called = _get_called(1);

            $options->{on_fail}->( "$id to $called did not pass regex check\n" );
        }
    }
}

{
    # if it UNIVERSAL::isa the string on the left then its the type on
    # the right
    my %isas = ( 'ARRAY'  => ARRAYREF,
		 'HASH'   => HASHREF,
		 'CODE'   => CODEREF,
		 'GLOB'   => GLOBREF,
		 'SCALAR' => SCALARREF,
	       );
    my %simple_refs = map { $_ => 1 } keys %isas;

    sub _get_type
    {
	return UNDEF unless defined $_[0];

	my $ref = ref $_[0];
	unless ($ref)
	{
	    # catches things like:  my $fh = do { local *FH; };
	    return GLOB if UNIVERSAL::isa( \$_[0], 'GLOB' );
	    return SCALAR;
	}

	return $isas{$ref} if $simple_refs{$ref};

	foreach ( keys %isas )
	{
	    return $isas{$_} | OBJECT if UNIVERSAL::isa( $_[0], $_ );
	}

	# I really hope this never happens.
	return UNKNOWN;
    }
}

{
    my %type_to_string = ( SCALAR()    => 'scalar',
			   ARRAYREF()  => 'arrayref',
			   HASHREF()   => 'hashref',
			   CODEREF()   => 'coderef',
			   GLOB()      => 'glob',
			   GLOBREF()   => 'globref',
			   SCALARREF() => 'scalarref',
			   UNDEF()     => 'undef',
			   OBJECT()    => 'object',
			   UNKNOWN()   => 'unknown',
			 );

    sub _typemask_to_strings
    {
	my $mask = shift;

	my @types;
	foreach ( SCALAR, ARRAYREF, HASHREF, CODEREF, GLOB, GLOBREF,
                  SCALARREF, UNDEF, OBJECT, UNKNOWN )
	{
	    push @types, $type_to_string{$_} if $mask & $_;
	}
	return @types ? @types : ('unknown');
    }
}

{
    my %defaults = ( ignore_case   => 0,
		     strip_leading => 0,
		     allow_extra   => 0,
		     on_fail       => sub { require Carp;
                                            Carp::confess($_[0]) },
		     stack_skip    => 1,
                     normalize_keys => undef,
		   );

    *set_options = \&validation_options;
    sub validation_options
    {
	my %opts = @_;

	my $caller = caller;

	foreach ( keys %defaults )
	{
	    $opts{$_} = $defaults{$_} unless exists $opts{$_};
	}

	$OPTIONS{$caller} = \%opts;
    }

    sub _get_options
    {
	my ( $caller, %override ) = @_;

        if ( %override )
        {
            return
                ( $OPTIONS{$caller} ?
                  { %{ $OPTIONS{$caller} },
                    %override } :
                  { %defaults, %override }
                );
        }
        else
        {
            return
                ( exists $OPTIONS{$caller} ?
                  $OPTIONS{$caller} :
                  \%defaults );
        }
    }
}

sub _get_called
{
    my $extra_skip = $_[0] || 0;

    # always add one more for this sub
    $extra_skip++;

    my $called =
        ( exists $options->{called} ?
          $options->{called} :
          ( caller( $options->{stack_skip} + $extra_skip ) )[3]
        );

    $called = 'N/A' unless defined $called;

    return $called;
}

1;

__END__

=head1 NAME

Params::ValidatePP - pure Perl implementation of Params::Validate

=head1 SYNOPSIS

  See Params::Validate

=head1 DESCRIPTION

This is a pure Perl implementation of Params::Validate.  See the
Params::Validate documentation for details.

=head1 COPYRIGHT

Copyright (c) 2004 David Rolsky.  All rights reserved.  This program
is free software; you can redistribute it and/or modify it under the
same terms as Perl itself.

=cut