r3245 - in
/packages/libparams-check-perl/branches/upstream/current: CHANGES
META.yml lib/Params/Check.pm t/01_Params-Check.t
gregoa-guest at users.alioth.debian.org
gregoa-guest at users.alioth.debian.org
Sat Jul 8 18:31:34 UTC 2006
Author: gregoa-guest
Date: Sat Jul 8 18:31:32 2006
New Revision: 3245
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=3245
Log:
Load /tmp/tmp.aRjAr15136/libparams-check-perl-0.25 into
packages/libparams-check-perl/branches/upstream/current.
Modified:
packages/libparams-check-perl/branches/upstream/current/CHANGES
packages/libparams-check-perl/branches/upstream/current/META.yml
packages/libparams-check-perl/branches/upstream/current/lib/Params/Check.pm
packages/libparams-check-perl/branches/upstream/current/t/01_Params-Check.t
Modified: packages/libparams-check-perl/branches/upstream/current/CHANGES
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libparams-check-perl/branches/upstream/current/CHANGES?rev=3245&op=diff
==============================================================================
--- packages/libparams-check-perl/branches/upstream/current/CHANGES (original)
+++ packages/libparams-check-perl/branches/upstream/current/CHANGES Sat Jul 8 18:31:32 2006
@@ -1,3 +1,11 @@
+Changes for 0.25 Wed Jul 5 17:13:07 2006
+============================================
+
+* Apply patch from #20299 that implements the
+ $Params::Check::CALLER_DEPTH variable.
+* Add a warning if the store => variable
+ s not a reference.
+
Changes for 0.24 Thu Mar 2 13:04:27 2006
============================================
Modified: packages/libparams-check-perl/branches/upstream/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libparams-check-perl/branches/upstream/current/META.yml?rev=3245&op=diff
==============================================================================
--- packages/libparams-check-perl/branches/upstream/current/META.yml (original)
+++ packages/libparams-check-perl/branches/upstream/current/META.yml Sat Jul 8 18:31:32 2006
@@ -1,7 +1,7 @@
# http://module-build.sourceforge.net/META-spec.html
#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
name: Params-Check
-version: 0.24
+version: 0.25
version_from: lib/Params/Check.pm
installdirs: site
requires:
Modified: packages/libparams-check-perl/branches/upstream/current/lib/Params/Check.pm
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libparams-check-perl/branches/upstream/current/lib/Params/Check.pm?rev=3245&op=diff
==============================================================================
--- packages/libparams-check-perl/branches/upstream/current/lib/Params/Check.pm (original)
+++ packages/libparams-check-perl/branches/upstream/current/lib/Params/Check.pm Sat Jul 8 18:31:32 2006
@@ -12,13 +12,13 @@
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
+ $SANITY_CHECK_TEMPLATE $CALLER_DEPTH
];
@ISA = qw[ Exporter ];
@EXPORT_OK = qw[check allow last_error];
- $VERSION = '0.24';
+ $VERSION = '0.25';
$VERBOSE = $^W ? 1 : 0;
$NO_DUPLICATES = 0;
$STRIP_LEADING_DASHES = 0;
@@ -28,6 +28,7 @@
$ONLY_ALLOW_DEFINED = 0;
$SANITY_CHECK_TEMPLATE = 1;
$WARNINGS_FATAL = 0;
+ $CALLER_DEPTH = 0;
}
my %known_keys = map { $_ => 1 }
@@ -506,6 +507,13 @@
} grep {
not $known_keys{$_}
} keys %{$utmpl{$key}};
+
+ ### make sure you passed a ref, otherwise, complain about it!
+ if ( exists $utmpl{$key}->{'store'} ) {
+ _store_error( loc(
+ q|Store variable for '%1' is not a reference!|, $key
+ ), 1, 1 ) unless ref $utmpl{$key}->{'store'};
+ }
}
}
@@ -527,7 +535,7 @@
sub _who_was_it {
my $level = $_[0] || 0;
- return (caller(2 + $level))[3] || 'ANON'
+ return (caller(2 + $CALLER_DEPTH + $level))[3] || 'ANON'
}
=head2 last_error()
@@ -646,6 +654,30 @@
If set to true, L<Params::Check> will C<croak> when an error during
template validation occurs, rather than return C<false>.
+
+Default is 0;
+
+=head2 $Params::Check::CALLER_DEPTH
+
+This global modifies the argument given to C<caller()> by
+C<Params::Check::check()> and is useful if you have a custom wrapper
+function around C<Params::Check::check()>. The value must be an
+integer, indicating the number of wrapper functions inserted between
+the real function call and C<Params::Check::check()>.
+
+Example wrapper function, using a custom stacktrace:
+
+ sub check {
+ my ($template, $args_in) = @_;
+
+ local $Params::Check::WARNINGS_FATAL = 1;
+ local $Params::Check::CALLER_DEPTH = $Params::Check::CALLER_DEPTH + 1;
+ my $args_out = Params::Check::check($template, $args_in);
+
+ my_stacktrace(Params::Check::last_error) unless $args_out;
+
+ return $args_out;
+ }
Default is 0;
Modified: packages/libparams-check-perl/branches/upstream/current/t/01_Params-Check.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libparams-check-perl/branches/upstream/current/t/01_Params-Check.t?rev=3245&op=diff
==============================================================================
--- packages/libparams-check-perl/branches/upstream/current/t/01_Params-Check.t (original)
+++ packages/libparams-check-perl/branches/upstream/current/t/01_Params-Check.t Sat Jul 8 18:31:32 2006
@@ -260,6 +260,17 @@
like( $@, qr/invalid type/,
" error stored ok" );
}
+
+### store => \$foo tests
+{ ### quell warnings
+ local $SIG{__WARN__} = sub {};
+
+ my $tmpl = { foo => { store => '' } };
+ check( $tmpl, {} );
+
+ my $re = quotemeta q|Store variable for 'foo' is not a reference!|;
+ like(last_error(), qr/$re/, "Caught non-reference 'store' variable" );
+}
### edge case tests ###
{ ### if key is not provided, and value is '', will P::C treat
@@ -319,3 +330,20 @@
is( $rv->{lastname}, $lastname,
" found provided values in rv" );
}
+
+### $Params::Check::CALLER_DEPTH test
+{
+ sub wrapper { check ( @_ ) };
+ sub inner { wrapper( @_ ) };
+ sub outer { inner ( @_ ) };
+ outer( { dummy => { required => 1 }}, {} );
+
+ like( last_error, qr/for .*::wrapper by .*::inner$/,
+ "wrong caller without CALLER_DEPTH" );
+
+ local $Params::Check::CALLER_DEPTH = 1;
+ outer( { dummy => { required => 1 }}, {} );
+
+ like( last_error, qr/for .*::inner by .*::outer$/,
+ "right caller with CALLER_DEPTH" );
+}
More information about the Pkg-perl-cvs-commits
mailing list