Carp-Ensure
view release on metacpan or search on metacpan
@ISA = qw( Exporter );
###############################################################################
# The idea of the following is shamelessly stolen from `Carp::Assert'
@EXPORT = qw( ensure DEBUG );
@EXPORT_OK = qw( is_a );
$EXPORT_TAGS{NDEBUG} = $EXPORT_TAGS{DEBUG} = [ @EXPORT ];
sub REAL_DEBUG() { 1 }
sub NDEBUG() { 0 }
sub noop { undef }
# Export the proper DEBUG flag according to if :NDEBUG is set.
# Also export noop versions of our routines if NDEBUG
sub import($@) {
my( $cls, @syms ) = @_;
if(scalar(grep{ $_ eq ':NDEBUG' }(@syms)) ||
(exists($ENV{PERL_NDEBUG}) ? $ENV{PERL_NDEBUG} : $ENV{'NDEBUG'})) {
my $dst = caller();
foreach ( @{$EXPORT_TAGS{NDEBUG}} ) {
no strict 'refs';
*{$dst . '::' . $_} = $_ eq 'DEBUG' ? \&NDEBUG : \&noop;
}
Carp::Ensure->export_to_level(1, $cls, grep{ $_ ne ':NDEBUG' }(@syms));
}
else {
*DEBUG = *REAL_DEBUG;
Carp::Ensure->export_to_level(1, $cls, @syms);
}
}
sub unimport($@) {
my( $cls, @syms ) = @_;
*DEBUG = *NDEBUG;
import($cls, ':NDEBUG', @syms);
}
# End of stolen idea
###############################################################################
=head1 NAME
The C<if DEBUG> concept is taken from L<Carp::Assert> where it is explained in
detail (particularly in L<Carp::Assert/"Debugging vs Production">. Actually the
B<DEBUG> value is probably shared between L<Carp::Assert> and this module. So
take care when enabling it in one and disabling it in the other package C<use>.
In short: If you say C<use Carp::Ensure> you switch B<DEBUG> on and B<ensure>
works as expected. If you say C<no Carp::Ensure> then the whole call is
compiled away from the program and has no impact on efficiency.
=cut
sub ensure($@) {
# Call it with our arguments to save a copy
my $err = &_is_not;
confess("ensure: $err")
if $err;
return !undef;
}
###############################################################################
=item B<is_a>
immediately stopping the program on failure or to build your own testing subs
like this:
sub Carp::Ensure::is_a_word1empty { Carp::Ensure::is_a('word|empty', ${shift()}) }
If a false value is returned I<$@> is set to an error message. Otherwise I<$@>
is undefined.
=cut
sub is_a($@) {
# Call it with our arguments to save a copy
$@ = &_is_not;
return !$@;
}
###############################################################################
my $ErrTpCall = 1;
my $ErrTpDscr = 2;
my $ErrTpType = 3;
# This does the real work. Returns an error message or undef.
sub _is_not($@) {
my $tp = shift();
my $err;
unless(defined($tp))
{ $err = "$ErrTpCall Undefined first argument"; }
elsif(!ref($tp)) {
my $cTp = $tp;
$cTp =~ s/\s+//g;
$err = _type($cTp, 0, \@_);
}
# everything worked.
=over 4
=item I<type> :=
I<hash> | I<array> | I<alternative>
=cut
sub _type($$$ ) {
my( $tp, $idx, $arr ) = @_;
if($tp =~ /^\@/)
{ return _array($tp, $idx, $arr); }
elsif($tp =~ /^\%/)
{ return _hash($tp, $idx, $arr); }
else
{ return _alternative($tp, \$arr->[$idx]); }
}
###############################################################################
=item I<hash> :=
'C<%>' I<alternative> 'C<=>>' I<alternative>
=cut
sub _hash($$$ ) {
my( $tp, $idx, $arr ) = @_;
$tp =~ s/^\%//;
return "$ErrTpDscr Missing `=>' in hash type `\%$tp'"
unless $tp =~ /=>/;
my( $keyTp, $valTp ) = ( $`, $' );
my $err;
$err = _alternative($keyTp, \$arr->[$idx++]) ||
_alternative($valTp, \$arr->[$idx++])
}
###############################################################################
=item I<array> :=
'C<@>' I<alternative>
=cut
sub _array($$$ ) {
my( $tp, $idx, $arr ) = @_;
$tp =~ s/^\@//;
my $err;
$err = _alternative($tp, \$arr->[$idx++])
while !$err && $idx < @$arr;
return $err;
}
###############################################################################
=item I<alternative> :=
I<simple> 'C<|>' I<alternative> | I<simple>
=cut
sub _alternative($$) {
my( $tp, $val ) = @_;
return _simple($tp, $val)
unless $tp =~ /\|/;
foreach my $alt ( split(/\|/, $tp) ) {
my $err = _simple($alt, $val);
return undef
unless $err;
'C<\>' I<type> | I<class> | I<object> | 'C<HASH>' | 'C<ARRAY>' | 'C<CODE>' | 'C<GLOB>'
Note: Take care with the C<\>. Even in a string using single quotes a directly
following backslash quotes a backslash! Whitespace between subsequent
backslashes simplifies things greatly.
=cut
my @referenceSs = qw( HASH ARRAY CODE GLOB );
sub _reference($$) {
my( $tp, $val ) = @_;
if(grep{ $tp eq $_ }(@referenceSs))
{ return _is_a($tp, $val); }
elsif($tp =~ /^\^/)
{ return _class($tp, $val); }
elsif($tp =~ s/^\\//) {
return "$ErrTpType `" . $$val . "' is not a reference"
unless ref($val) eq "REF";
}
###############################################################################
=item I<dynamic> :=
I<user>
=cut
sub _dynamic($$) {
my( $tp, $val ) = @_;
return _user($tp, $val);
}
###############################################################################
=item I<special> :=
'C<undefined>' | 'C<defined>' | 'C<anything>'
=cut
my @specialSs = qw( undefined defined anything );
sub _special($$) {
my( $tp, $val ) = @_;
return _is_a($tp, $val);
}
###############################################################################
=item I<scalar> :=
'C<string>' | 'C<word>' | 'C<empty>' | 'C<integer>' | 'C<float>' | 'C<boolean>' | 'C<regex>'
These common simple types are predefined.
=cut
my @scalarSs = qw( string word empty integer float boolean regex );
sub _scalar($$) {
my( $tp, $val ) = @_;
return "$ErrTpDscr Unknown scalar type `$tp'"
unless grep{ $tp eq $_ }(@scalarSs);
return _is_a($tp, $val);
}
###############################################################################
by the name matching the regular expression I<object>. This may mean, that the
class is a superclass of the class given by the value.
Thus the first parameter of a method which might be used static as well as with
an object has a type of
Some::Class|^Some::Class
=cut
sub _class($$) {
my( $tp, $val ) = @_;
$tp =~ /^\^/;
my $cls = $';
return ref($val) eq "SCALAR" && eval { $$val->isa($cls) } ? undef :
"$ErrTpType `" . $$val . "' is not of type `$tp'";
}
###############################################################################
I</^[A-Z]\w*(::\w+)*$/>
The value is a object (i.e. a blessed reference) of the class represented by
the name matching the regular expression. This may mean, that the class is a
superclass of the object's class.
=cut
my $objectRe = '[A-Z]\w*(::\w+)*';
sub _object($$) {
my( $tp, $val ) = @_;
return ref($val) eq "REF" && UNIVERSAL::isa($$val, $tp) ? undef :
"$ErrTpType `" . $$val . "' is not of type `$tp'";
}
###############################################################################
=item I<user> :=
must be defined. When checking a value for being a I<userType>, the sub is
called with a single argument being a B<reference>(!) to the value it should
check. This minimizes copying. The sub must return false if the referenced
value is not of the desired type and a true value otherwise. See C<is_a> for an
example.
=cut
my $userRe = '[a-z]\w*';
sub _user($$) {
my( $tp, $val ) = @_;
return _is_a($tp, $val);
}
###############################################################################
sub _simple($$) {
my( $tp, $val ) = @_;
if(grep{ $tp eq $_ }(@scalarSs))
{ return _scalar($tp, $val); }
elsif(grep{ $tp eq $_ }(@specialSs))
{ return _special($tp, $val); }
elsif($tp =~ /^$userRe$/)
{ return _dynamic($tp, $val); }
elsif(scalar(grep{ $tp eq $_ }(@referenceSs)) ||
$tp =~ /^\\/ || $tp =~ /^$objectRe$/ || $tp =~ /^\^$objectRe$/)
=head2 Terminal symbols
The terminal symbols have the following meaning:
=cut
###############################################################################
# Calls the `is_a_$tp'(`$val') sub.
sub _is_a($$) {
my( $tp, $val ) = @_;
my $sub = "is_a_$tp";
no strict 'refs';
return "$ErrTpDscr No user defined test `Carp::Ensure::$sub'"
unless defined(&$sub);
return &$sub($val) ? undef :
"$ErrTpType `" . $$val . "' is not of type `$tp'";
}
=over 4
=item C<HASH>
The value is a reference(!) to a hash with arbitrary keys and values. Use this
if you don't want to check the hash content.
=cut
sub is_a_HASH($ ) {
my( $r ) = @_;
return ref($r) eq "REF" && ref($$r) eq "HASH";
}
###############################################################################
=item C<ARRAY>
The value is a reference(!) to an array with arbitrary content. Use this if you
don't want to check the array content.
=cut
sub is_a_ARRAY($ ) {
my( $r ) = @_;
return ref($r) eq "REF" && ref($$r) eq "ARRAY";
}
###############################################################################
=item C<CODE>
The value is a reference to some code. This may be an anonymous or a named sub.
=cut
sub is_a_CODE($ ) {
my( $r ) = @_;
return ref($r) eq "REF" && ref($$r) eq "CODE";
}
###############################################################################
=item C<GLOB>
The value is a GLOB.
=cut
sub is_a_GLOB($ ) {
my( $r ) = @_;
return ref($r) eq "GLOB";
}
###############################################################################
=item C<undefined>
Only the undefined value is permitted. Often used as one part of an
alternative. Missing optional arguments of a sub are undefined, also.
=cut
sub is_a_undefined($ ) {
my( $r ) = @_;
return ref($r) eq "SCALAR" && !defined($$r);
}
###############################################################################
=item C<defined>
The value only needs to be defined.
=cut
sub is_a_defined($ ) {
my( $r ) = @_;
return defined($$r);
}
###############################################################################
=item C<anything>
Actually not a test since anything is permitted.
=cut
sub is_a_anything($ ) {
return !undef;
}
###############################################################################
=item C<string>
An arbitrary string.
=cut
sub is_a_string($ ) {
my( $r ) = @_;
return ref($r) eq "SCALAR";
}
###############################################################################
=item C<word>
A string matching C</w+/>.
=cut
sub is_a_word($ ) {
my( $r ) = @_;
return ref($r) eq "SCALAR" && $$r =~ /^\w+$/;
}
###############################################################################
=item C<empty>
An empty string.
=cut
sub is_a_empty($ ) {
my( $r ) = @_;
return ref($r) eq "SCALAR" && defined($$r) && $$r eq "";
}
###############################################################################
=item C<integer>
An integer.
=cut
sub is_a_integer($ ) {
my( $r ) = @_;
return ref($r) eq "SCALAR" && $$r =~/^[-+]?\d+$/;
}
###############################################################################
=item C<float>
An floating point number.
=cut
sub is_a_float($ ) {
my( $r ) = @_;
return ref($r) eq "SCALAR" && $$r =~ /^[-+]?(\d+(\.\d*)?|\.\d+)([Ee][-+]?\d+)?$/;
}
###############################################################################
=item C<boolean>
A boolean. Actually every scalar is a boolean in Perl, so this is more a
description of how a certain value is used.
=cut
sub is_a_boolean($ ) {
my( $r ) = @_;
return ref($r) eq "SCALAR";
}
###############################################################################
=item C<regex>
A string which compiles cleanly as a regular expression. The C<regex> is
applied to an empty string so any parentheses in the C<regex> will probably
don't result in anything useful.
Note, that nothing prevents the C<regex> from executing arbitrary code if you
manage to include this somehow. The results are completly undefined.
=cut
sub is_a_regex($ ) {
my( $r ) = @_;
return ref($r) eq "SCALAR" && defined($$r) && defined(eval { "" =~ /$$r/ });
}
###############################################################################
=back
=head2 Precedence
use Carp::Ensure(qw( :DEBUG is_a ));
$loaded = 1;
ok(1);
my $errPfx = "ensure";
###############################################################################
sub ensure2Error($@) {
eval { &ensure if DEBUG };
# warn($@) if $@;
return $@;
}
###############################################################################
sub okType($@) {
ok(!&ensure2Error);
}
###############################################################################
sub noType($@) {
my $tp = $_[0];
$tp =~ s/^[\\@]*//;
ok(&ensure2Error, qr/^$errPfx: Invalid type: `.*' is not of type `\\*\Q$tp\E'/);
}
###############################################################################
# Test checking of parameter types
ok(ensure2Error(undef),
qr/^$errPfx: Invalid call: Undefined first argument/);
noType('GLOB', { });
noType('GLOB', undef);
noType('GLOB', $string);
noType('GLOB', \$string);
###############################################################################
# Test user type
package Carp::Ensure;
sub is_a_natural($ ) {
my( $r ) = @_;
return ref($r) eq "SCALAR" && $$r =~/^[1-9]\d*$/;
}
package main;
okType('natural', 7);
okType('natural', -$integer);
noType('natural', $integer);
noType('natural', [ ]);
ok(ensure2Error('positive', 1),
qr/^$errPfx: Invalid description: No user defined test/);
###############################################################################
# Test object type
package Grand;
sub new($ ) {
my( $proto ) = @_;
::okType('^Grand|Grand', $proto);
my $class = ref($proto) || $proto;
my $self = { };
bless($self, $class);
return $self;
}
package Parent;
okType('\@word1empty', [ $word, $empty ]);
noType('\@word1empty', [ $word, $empty, undef ]);
okType('\%word1empty=>natural', { eins => 1, "" => 2 });
ok(ensure2Error('\%word1empty=>natural', { eins => 1, "" => 2, drei => -3 }),
qr/^$errPfx: Invalid type: `.*' is not of type/);
###############################################################################
# Test argument lists
sub prePost($@) {
my $tps = shift();
my @vals = @_;
my $r = is_a($tps, \@_) ? undef : $@;
for(my $i = 0; $i < @vals; $i++) {
return $i
unless $vals[$i] eq $_[$i];
}
return $r;
}
( run in 0.247 second using v1.01-cache-2.11-cpan-1f129e94a17 )