More.pm - metacpan.org

package Carp::Assert::More;

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

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

*_fail_msg = *Carp::Assert::_fail_msg;


=head1 NAME

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

=head1 VERSION

Version 1.14

=cut

BEGIN {
    $VERSION = '1.14';
    @ISA = qw(Exporter);
    @EXPORT = qw(
        assert_defined
        assert_exists
        assert_fail
        assert_hashref
        assert_in
        assert_integer
        assert_is
        assert_isa
        assert_isnt
        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_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( _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( _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( _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( _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( _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( _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( _fail_msg($name) );
}

=head1 NUMERIC ASSERTIONS

=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 );    # FAIL
    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( _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( _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( _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( _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( _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( _fail_msg($name) );
}


=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( _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_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.

=cut

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

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

=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( _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( _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( _fail_msg($name) );
        }
    }
}

=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( _fail_msg($_[0]) );
}


=head1 COPYRIGHT & LICENSE

Copyright 2005-2012 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
Bob Diss,
Pete Krawczyk,
David Storrs,
Dan Friedman,
Allard Hoeve,
Thomas L. Shinnick,
and Leland Johnson
for code and fixes.

=cut

"I stood on the porch in a tie."
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)