Beta Shell v2.0

File Manager

~ /usr/share/perl5/vendor_perl/Carp/Assert
Name	Size	Perms	Modified	Actions
[ .. / .. ]
More.pm	19.24 KB	-rw-r--r--	2020-10-07 03:38:49	Edit Del
Editing: More.pm (19.24 KB)

package Carp::Assert::More;

use warnings;
use strict;
use Exporter;
use Carp::Assert;

use vars qw( $VERSION @ISA @EXPORT );

sub _any(&;@);

=head1 NAME

Carp::Assert::More - convenience wrappers around Carp::Assert

=head1 VERSION

Version 1.24

=cut

BEGIN {
    $VERSION = '1.24';
    @ISA = qw(Exporter);
    @EXPORT = qw(
        assert_all_keys_in
        assert_aoh
        assert_arrayref
        assert_coderef
        assert_datetime
        assert_defined
        assert_empty
        assert_exists
        assert_fail
        assert_hashref
        assert_in
        assert_integer
        assert_is
        assert_isa
        assert_isa_in
        assert_isnt
        assert_keys_are
        assert_lacks
        assert_like
        assert_listref
        assert_negative
        assert_negative_integer
        assert_nonblank
        assert_nonempty
        assert_nonnegative
        assert_nonnegative_integer
        assert_nonref
        assert_nonzero
        assert_nonzero_integer
        assert_numeric
        assert_positive
        assert_positive_integer
        assert_undefined
        assert_unlike
    );
}

=head1 SYNOPSIS

A set of convenience functions for common assertions.

    use Carp::Assert::More;

    my $obj = My::Object;
    assert_isa( $obj, 'My::Object', 'Got back a correct object' );

=head1 DESCRIPTION

Carp::Assert::More is a set of wrappers around the L<Carp::Assert> functions
to make the habit of writing assertions even easier.

Everything in here is effectively syntactic sugar.  There's no technical
reason to use

    assert_isa( $foo, 'HTML::Lint' );

instead of

    assert( defined $foo );
    assert( ref($foo) eq 'HTML::Lint' );

other than readability and simplicity of the code.

My intent here is to make common assertions easy so that we as programmers
have no excuse to not use them.

=head1 CAVEATS

I haven't specifically done anything to make Carp::Assert::More be
backwards compatible with anything besides Perl 5.6.1, much less back
to 5.004.  Perhaps someone with better testing resources in that area
can help me out here.

=head1 SIMPLE ASSERTIONS

=head2 assert_is( $string, $match [,$name] )

Asserts that I<$string> matches I<$match>.

=cut

sub assert_is($$;$) {
    my $string = shift;
    my $match = shift;
    my $name = shift;

    # undef only matches undef
    return if !defined($string) && !defined($match);
    assert_defined( $string, $name );
    assert_defined( $match, $name );

    return if $string eq $match;

    require Carp;
    &Carp::confess( Carp::Assert::_fail_msg($name) );
}

=head2 assert_isnt( $string, $unmatch [,$name] )

Asserts that I<$string> does NOT match I<$unmatch>.

=cut

sub assert_isnt($$;$) {
    my $string = shift;
    my $unmatch = shift;
    my $name = shift;

    # undef only matches undef
    return if defined($string) xor defined($unmatch);

    return if defined($string) && defined($unmatch) && ($string ne $unmatch);

    require Carp;
    &Carp::confess( Carp::Assert::_fail_msg($name) );
}

=head2 assert_like( $string, qr/regex/ [,$name] )

Asserts that I<$string> matches I<qr/regex/>.

The assertion fails either the string or the regex are undef.

=cut

sub assert_like($$;$) {
    my $string = shift;
    my $regex = shift;
    my $name = shift;

    assert_nonref( $string, $name );
    assert_isa( $regex, 'Regexp', $name );
    return if $string =~ $regex;

    require Carp;
    &Carp::confess( Carp::Assert::_fail_msg($name) );
}

=head2 assert_unlike( $string, qr/regex/ [,$name] )

Asserts that I<$string> matches I<qr/regex/>.

The assertion fails if the regex is undef.

=cut

sub assert_unlike($$;$) {
    my $string = shift;
    my $regex  = shift;
    my $name   = shift;

    return if !defined($string);

    assert_nonref( $string, $name );
    assert_isa( $regex, 'Regexp', $name );
    return if $string !~ $regex;

    require Carp;
    &Carp::confess( Carp::Assert::_fail_msg($name) );
}

=head2 assert_defined( $this [, $name] )

Asserts that I<$this> is defined.

=cut

sub assert_defined($;$) {
    return if defined( $_[0] );

    require Carp;
    &Carp::confess( Carp::Assert::_fail_msg($_[1]) );
}

=head2 assert_undefined( $this [, $name] )

Asserts that I<$this> is not defined.

=cut

sub assert_undefined($;$) {
    return unless defined( $_[0] );

    require Carp;
    &Carp::confess( Carp::Assert::_fail_msg($_[1]) );
}

=head2 assert_nonblank( $this [, $name] )

Asserts that I<$this> is not blank and not a reference.

=cut

sub assert_nonblank($;$) {
    my $this = shift;
    my $name = shift;

    assert_nonref( $this, $name );
    return if $this ne "";

    require Carp;
    &Carp::confess( Carp::Assert::_fail_msg($name) );
}


=head1 NUMERIC ASSERTIONS

=head2 assert_numeric( $n [, $name] )

Asserts that C<$n> looks like a number, according to C<Scalar::Util::looks_like_number>.

=cut

sub assert_numeric {
    my $n    = shift;
    my $name = shift;

    require Scalar::Util;

    assert( Scalar::Util::looks_like_number( $n ), $name );

    return;
}


=head2 assert_integer( $this [, $name ] )

Asserts that I<$this> is an integer, which may be zero or negative.

    assert_integer( 0 );      # pass
    assert_integer( 14 );     # pass
    assert_integer( -14 );    # pass
    assert_integer( '14.' );  # FAIL

=cut

sub assert_integer($;$) {
    my $this = shift;
    my $name = shift;

    assert_nonref( $this, $name );
    return if $this =~ /^-?\d+$/;

    require Carp;
    &Carp::confess( Carp::Assert::_fail_msg($name) );
}

=head2 assert_nonzero( $this [, $name ] )

Asserts that the numeric value of I<$this> is not zero.

    assert_nonzero( 0 );    # FAIL
    assert_nonzero( -14 );  # pass
    assert_nonzero( '14.' );  # pass

Asserts that the numeric value of I<$this> is not zero.

=cut

sub assert_nonzero($;$) {
    my $this = shift;
    my $name = shift;

    no warnings;
    return if $this+0 != 0;

    require Carp;
    &Carp::confess( Carp::Assert::_fail_msg($name) );
}

=head2 assert_positive( $this [, $name ] )

Asserts that the numeric value of I<$this> is greater than zero.

    assert_positive( 0 );    # FAIL
    assert_positive( -14 );  # FAIL
    assert_positive( '14.' );  # pass

=cut

sub assert_positive($;$) {
    my $this = shift;
    my $name = shift;

    no warnings;
    return if $this+0 > 0;

    require Carp;
    &Carp::confess( Carp::Assert::_fail_msg($name) );
}

=head2 assert_nonnegative( $this [, $name ] )

Asserts that the numeric value of I<$this> is greater than or equal
to zero.  Since non-numeric strings evaluate to zero, this means that
any non-numeric string will pass.

    assert_nonnegative( 0 );      # pass
    assert_nonnegative( -14 );    # FAIL
    assert_nonnegative( '14.' );  # pass
    assert_nonnegative( 'dog' );  # pass

=cut

sub assert_nonnegative($;$) {
    my $this = shift;
    my $name = shift;

    no warnings;
    return if $this+0 >= 0;

    require Carp;
    &Carp::confess( Carp::Assert::_fail_msg($name) );
}

=head2 assert_negative( $this [, $name ] )

Asserts that the numeric value of I<$this> is less than zero.

    assert_negative( 0 );       # FAIL
    assert_negative( -14 );     # pass
    assert_negative( '14.' );   # FAIL

=cut

sub assert_negative($;$) {
    my $this = shift;
    my $name = shift;

    no warnings;
    return if $this+0 < 0;

    require Carp;
    &Carp::confess( Carp::Assert::_fail_msg($name) );
}

=head2 assert_nonzero_integer( $this [, $name ] )

Asserts that the numeric value of I<$this> is not zero, and that I<$this>
is an integer.

    assert_nonzero_integer( 0 );      # FAIL
    assert_nonzero_integer( -14 );    # pass
    assert_nonzero_integer( '14.' );  # FAIL

=cut

sub assert_nonzero_integer($;$) {
    my $this = shift;
    my $name = shift;

    assert_nonzero( $this, $name );
    assert_integer( $this, $name );
}

=head2 assert_positive_integer( $this [, $name ] )

Asserts that the numeric value of I<$this> is greater than zero, and
that I<$this> is an integer.

    assert_positive_integer( 0 );     # FAIL
    assert_positive_integer( -14 );   # FAIL
    assert_positive_integer( '14.' ); # FAIL
    assert_positive_integer( '14' );  # pass

=cut

sub assert_positive_integer($;$) {
    my $this = shift;
    my $name = shift;

    assert_positive( $this, $name );
    assert_integer( $this, $name );
}

=head2 assert_nonnegative_integer( $this [, $name ] )

Asserts that the numeric value of I<$this> is not less than zero, and
that I<$this> is an integer.

    assert_nonnegative_integer( 0 );      # pass
    assert_nonnegative_integer( -14 );    # pass
    assert_nonnegative_integer( '14.' );  # FAIL

=cut

sub assert_nonnegative_integer($;$) {
    my $this = shift;
    my $name = shift;

    assert_nonnegative( $this, $name );
    assert_integer( $this, $name );
}

=head2 assert_negative_integer( $this [, $name ] )

Asserts that the numeric value of I<$this> is less than zero, and that
I<$this> is an integer.

    assert_negative_integer( 0 );      # FAIL
    assert_negative_integer( -14 );    # pass
    assert_negative_integer( '14.' );  # FAIL

=cut

sub assert_negative_integer($;$) {
    my $this = shift;
    my $name = shift;

    assert_negative( $this, $name );
    assert_integer( $this, $name );
}

=head1 REFERENCE ASSERTIONS

=head2 assert_isa( $this, $type [, $name ] )

Asserts that I<$this> is an object of type I<$type>.

=cut

sub assert_isa($$;$) {
    my $this = shift;
    my $type = shift;
    my $name = shift;

    assert_defined( $this, $name );

    # The assertion is true if
    # 1) For objects, $this is of class $type or of a subclass of $type
    # 2) For non-objects, $this is a reference to a HASH, SCALAR, ARRAY, etc.

    require Scalar::Util;

    return if Scalar::Util::blessed( $this ) && $this->isa( $type );
    return if ref($this) eq $type;

    require Carp;
    &Carp::confess( Carp::Assert::_fail_msg($name) );
}


=head2 assert_isa_in( $obj, \@types [, $description] )

Assert that the blessed C<$obj> isa one of the types in C<\@types>.

    assert_isa_in( $obj, [ 'My::Foo', 'My::Bar' ], 'Must pass either a Foo or Bar object' );

=cut

sub assert_isa_in($$;$) {
    my $obj   = shift;
    my $types = shift;
    my $name  = shift;

    require Scalar::Util;

    my $ok = _any { Scalar::Util::blessed($obj) && $obj->isa($_) } @{$types};
    assert( $ok, $name );

    return;
}


=head2 assert_empty( $this [, $name ] )

I<$this> must be a ref to either a hash or an array.  Asserts that that
collection contains no elements.  Will assert (with its own message,
not I<$name>) unless given a hash or array ref.   It is OK if I<$this> has
been blessed into objecthood, but the semantics of checking an object to see
if it does not have keys (for a hashref) or returns 0 in scalar context (for
an array ref) may not be what you want.

    assert_empty( 0 );       # FAIL
    assert_empty( 'foo' );   # FAIL
    assert_empty( undef );   # FAIL
    assert_empty( {} );      # pass
    assert_empty( [] );      # pass
    assert_empty( {foo=>1} );# FAIL
    assert_empty( [1,2,3] ); # FAIL

=cut

sub assert_empty($;$) {
    my $ref = shift;
    my $name = shift;

    require Scalar::Util;

    my $underlying_type;
    if ( Scalar::Util::blessed( $ref ) ) {
        $underlying_type = Scalar::Util::reftype( $ref );
    }
    else {
        $underlying_type = ref( $ref );
    }

    if ( $underlying_type eq 'HASH' ) {
        assert_is( scalar keys %{$ref}, 0, $name );
    }
    elsif ( $underlying_type eq 'ARRAY' ) {
        assert_is( scalar @{$ref}, 0, $name );
    }
    else {
        assert_fail( 'Not an array or hash reference' );
    }
}

=head2 assert_nonempty( $this [, $name ] )

I<$this> must be a ref to either a hash or an array.  Asserts that that
collection contains at least 1 element.  Will assert (with its own message,
not I<$name>) unless given a hash or array ref.   It is OK if I<$this> has
been blessed into objecthood, but the semantics of checking an object to see
if it has keys (for a hashref) or returns >0 in scalar context (for an array
ref) may not be what you want.

    assert_nonempty( 0 );       # FAIL
    assert_nonempty( 'foo' );   # FAIL
    assert_nonempty( undef );   # FAIL
    assert_nonempty( {} );      # FAIL
    assert_nonempty( [] );      # FAIL
    assert_nonempty( {foo=>1} );# pass
    assert_nonempty( [1,2,3] ); # pass

=cut

sub assert_nonempty($;$) {
    my $ref = shift;
    my $name = shift;

    require Scalar::Util;

    my $underlying_type;
    if ( Scalar::Util::blessed( $ref ) ) {
        $underlying_type = Scalar::Util::reftype( $ref );
    }
    else {
        $underlying_type = ref( $ref );
    }

    if ( $underlying_type eq 'HASH' ) {
        assert_positive( scalar keys %{$ref}, $name );
    }
    elsif ( $underlying_type eq 'ARRAY' ) {
        assert_positive( scalar @{$ref}, $name );
    }
    else {
        assert_fail( 'Not an array or hash reference' );
    }
}

=head2 assert_nonref( $this [, $name ] )

Asserts that I<$this> is not undef and not a reference.

=cut

sub assert_nonref($;$) {
    my $this = shift;
    my $name = shift;

    assert_defined( $this, $name );
    return unless ref( $this );

    require Carp;
    &Carp::confess( Carp::Assert::_fail_msg($name) );
}

=head2 assert_hashref( $ref [,$name] )

Asserts that I<$ref> is defined, and is a reference to a (possibly empty) hash.

B<NB:> This method returns I<false> for objects, even those whose underlying
data is a hashref. This is as it should be, under the assumptions that:

=over 4

=item (a)

you shouldn't rely on the underlying data structure of a particular class, and

=item (b)

you should use C<assert_isa> instead.

=back

=cut

sub assert_hashref($;$) {
    my $ref = shift;
    my $name = shift;

    return assert_isa( $ref, 'HASH', $name );
}

=head2 assert_arrayref( $ref [, $name] )

=head2 assert_listref( $ref [,$name] )

Asserts that I<$ref> is defined, and is a reference to a (possibly empty) list.

B<NB:> The same caveat about objects whose underlying structure is a
hash (see C<assert_hashref>) applies here; this method returns false
even for objects whose underlying structure is an array.

C<assert_listref> is an alias for C<assert_arrayref> and may go away in
the future.  Use C<assert_arrayref> instead.

=cut

sub assert_arrayref($;$) {
    my $ref  = shift;
    my $name = shift;

    return assert_isa( $ref, 'ARRAY', $name );
}
*assert_listref = *assert_arrayref;


=head2 assert_aoh( $ref [, $name ] )

Verifies that C<$array> is an arrayref, and that every element is a hashref.

The array C<$array> can be an empty arraref and the assertion will pass.

=cut

sub assert_aoh {
    my $array = shift;
    my $msg   = shift;

    $msg = 'Is an array of hashes' unless defined($msg);

    assert_arrayref( $array, "$msg: Is an array" );
    my $i = 0;
    for my $val ( @{$array} ) {
        assert_hashref( $val, "$msg: Element $i is a hash" );
        ++$i;
    }

    return;
}


=head2 assert_coderef( $ref [,$name] )

Asserts that I<$ref> is defined, and is a reference to a closure.

=cut

sub assert_coderef($;$) {
    my $ref = shift;
    my $name = shift;

    return assert_isa( $ref, 'CODE', $name );
}


=head1 TYPE-SPECIFIC ASSERTIONS

=head2 assert_datetime( $date )

Asserts that C<$date> is a DateTime object.

=cut

sub assert_datetime($;$) {
    my $datetime = shift;
    my $desc     = shift;

    $desc = 'Must be a DateTime object' unless defined($desc);

    assert_isa( $datetime, 'DateTime', $desc );

    return;
}


=head1 SET AND HASH MEMBERSHIP

=head2 assert_in( $string, \@inlist [,$name] );

Asserts that I<$string> is defined and matches one of the elements
of I<\@inlist>.

I<\@inlist> must be an array reference of defined strings.

=cut

sub assert_in($$;$) {
    my $string = shift;
    my $arrayref = shift;
    my $name = shift;

    assert_nonref( $string, $name );
    assert_isa( $arrayref, 'ARRAY', $name );
    foreach my $element (@{$arrayref}) {
        assert_nonref( $element, $name );
        return if $string eq $element;
    }
    require Carp;
    &Carp::confess( Carp::Assert::_fail_msg($name) );
}

=head2 assert_exists( \%hash, $key [,$name] )

=head2 assert_exists( \%hash, \@keylist [,$name] )

Asserts that I<%hash> is indeed a hash, and that I<$key> exists in
I<%hash>, or that all of the keys in I<@keylist> exist in I<%hash>.

    assert_exists( \%custinfo, 'name', 'Customer has a name field' );

    assert_exists( \%custinfo, [qw( name addr phone )],
                            'Customer has name, address and phone' );

=cut

sub assert_exists($$;$) {
    my $hash = shift;
    my $key = shift;
    my $name = shift;

    assert_isa( $hash, 'HASH', $name );
    my @list = ref($key) ? @$key : ($key);

    for ( @list ) {
        if ( !exists( $hash->{$_} ) ) {
            require Carp;
            &Carp::confess( Carp::Assert::_fail_msg($name) );
        }
    }
}

=head2 assert_lacks( \%hash, $key [,$name] )

=head2 assert_lacks( \%hash, \@keylist [,$name] )

Asserts that I<%hash> is indeed a hash, and that I<$key> does NOT exist
in I<%hash>, or that none of the keys in I<@keylist> exist in I<%hash>.

    assert_lacks( \%users, 'root', 'Root is not in the user table' );

    assert_lacks( \%users, [qw( root admin nobody )], 'No bad usernames found' );

=cut

sub assert_lacks($$;$) {
    my $hash = shift;
    my $key = shift;
    my $name = shift;

    assert_isa( $hash, 'HASH', $name );
    my @list = ref($key) ? @$key : ($key);

    for ( @list ) {
        if ( exists( $hash->{$_} ) ) {
            require Carp;
            &Carp::confess( Carp::Assert::_fail_msg($name) );
        }
    }
}


=head2 assert_all_keys_in( \%hash, \@names [, $name ] )

Asserts that each key in C<%hash> is in the list of C<@names>.

This is used to ensure that there are no extra keys in a given hash.

    assert_all_keys_in( $obj, [qw( height width depth )], '$obj can only contain height, width and depth keys' );

=cut

sub assert_all_keys_in($$;$) {
    my $hash       = shift;
    my $valid_keys = shift;
    my $name       = shift;

    assert_hashref( $hash );
    assert_arrayref( $valid_keys );

    foreach my $key ( keys %{$hash} ) {
        assert_in( $key, $valid_keys, $name );
    }

    return;
}


=head2 assert_keys_are( \%hash, \@keys [, $name ] )

Asserts that the keys for C<%hash> are exactly C<@keys>, no more and no less.

=cut

sub assert_keys_are($$;$) {
    my $hash       = shift;
    my $valid_keys = shift;
    my $name       = shift;

    assert_hashref( $hash );
    assert_arrayref( $valid_keys );

    foreach my $key ( keys %{$hash} ) {
        assert_in( $key, $valid_keys, $name );
    }

    assert_is(scalar keys %{$hash}, scalar @{$valid_keys}, 'There are the correct number of keys');

    return;
}


=head1 UTILITY ASSERTIONS

=head2 assert_fail( [$name] )

Assertion that always fails.  C<assert_fail($msg)> is exactly the same
as calling C<assert(0,$msg)>, but it eliminates that case where you
accidentally use C<assert($msg)>, which of course never fires.

=cut

sub assert_fail(;$) {
    require Carp;
    &Carp::confess( Carp::Assert::_fail_msg($_[0]) );
}


# Since List::Util doesn't have any() all the way back.
sub _any(&;@) {
    my $sub = shift;
    $sub->($_) && return 1 for @_;
    return 0;
}


=head1 COPYRIGHT & LICENSE

Copyright 2005-2020 Andy Lester.

This program is free software; you can redistribute it and/or modify
it under the terms of the Artistic License version 2.0.

=head1 ACKNOWLEDGEMENTS

Thanks to
Eric A. Zarko,
Bob Diss,
Pete Krawczyk,
David Storrs,
Dan Friedman,
Allard Hoeve,
Thomas L. Shinnick,
and Leland Johnson
for code and fixes.

=cut

1;