Assert-Conditional

 view release on metacpan or  search on metacpan

lib/Assert/Conditional.pm  view on Meta::CPAN

        push @{ $his_export_tags->{$tag} }, $subname;
        carp "Adding $subname to EXPORT_TAG :$tag in $package at ",__FILE__," line ",__LINE__ if $debugging;
    }
}

################################################################

# Subs below are grouped by related type. Their documentation is
# in the sub <DATA> pod.

sub assert_list_context()
    :Assert( qw[context] )
{
    my $wantarray = his_context;
    $wantarray                  || botch "wanted to be called in list context";
}

sub assert_nonlist_context()
    :Assert( qw[context] )
{
    my $wantarray = his_context;
    !$wantarray                 || botch "wanted to be called in nonlist context";
}

sub assert_scalar_context()
    :Assert( qw[context] )
{
    my $wantarray = his_context;
    defined($wantarray) && !$wantarray
        || botch "wanted to be called in scalar context";
}

sub assert_void_context()
    :Assert( qw[context] )
{
    my $wantarray = his_context;
    !defined($wantarray)        || botch "wanted to be called in void context";
}

sub assert_nonvoid_context()
    :Assert( qw[context] )
{
    my $wantarray = his_context;
    defined($wantarray)        || botch "wanted to be called in nonvoid context";
}

sub assert_true($)
    :Assert( qw[scalar boolean] )
{
    my($arg) = @_;
    $arg                        || botch "expected true argument";
}

sub assert_false($)
    :Assert( qw[scalar boolean] )
{
    my($arg) = @_;
    $arg                        && botch "expected true argument";

}

sub assert_defined($)
    :Assert( qw[scalar] )
{
    my($value) = @_;
    defined($value)            || botch "expected defined value as argument";
}

sub assert_undefined($)
    :Assert( qw[scalar] )
{
    my($scalar) = @_;
    defined($scalar) && botch "expected undefined argument";
}

sub assert_defined_variable(\$)
    :Assert( qw[scalar] )
{
    &assert_scalarref;
    my($sref) = @_;
    defined($$sref)            || botch "expected defined scalar variable as argument";
}

sub assert_defined_value($)
    :Assert( qw[scalar] )
{
    my($value) = @_;
    defined($value)            || botch "expected defined value as argument";
}

sub assert_is($$)
    :Assert( qw[string] )
{
    my($this, $that) = @_;
    assert_defined($_) for $this, $that;
    assert_nonref($_)  for $this, $that;
    $this eq $that              || botch "string '$this' should be '$that'";
}

sub assert_isnt($$)
    :Assert( qw[string] )
{
    my($this, $that) = @_;
    assert_defined($_) for $this, $that;
    assert_nonref($_) for $this, $that;
    $this ne $that              || botch "string '$this' should not be '$that'";
}

sub assert_numeric($)
    :Assert( qw[number] )
{
    &assert_defined;
    &assert_nonref;
    my($n) = @_;
    looks_like_number($n)       || botch "'$n' doesn't look like a number";
}

sub assert_nonnumeric($)
    :Assert( qw[number] )
{
    &assert_nonref;
    my($n) = @_;
   !looks_like_number($n)       || botch "'$n' looks like a number";
}

sub assert_positive($)
    :Assert( qw[number] )
{
    &assert_numeric;
    my($n) = @_;
    $n > 0                     || botch "$n should be positive";
}

sub assert_nonpositive($)
    :Assert( qw[number] )
{
    &assert_numeric;
    my($n) = @_;
    $n <= 0                    || botch "$n should not be positive";
}

sub assert_negative($)
    :Assert( qw[number] )
{
    &assert_numeric;
    my($n) = @_;
    $n < 0                     || botch "$n should be negative";
}

sub assert_nonnegative($)
    :Assert( qw[number] )
{
    &assert_numeric;
    my($n) = @_;
    $n >= 0                     || botch "$n should not be negative";
}

sub assert_zero($)
    :Assert( qw[number] )
{
    &assert_numeric;
    my($n) = @_;
    $n == 0                     || botch "$n should be zero";
}

sub assert_nonzero($)
    :Assert( qw[number] )
{
    &assert_numeric;
    my($n) = @_;
    $n != 0                     || botch "$n should not be zero";
}

sub assert_integer($)
    :Assert( qw[number] )
{
    &assert_numeric;
    my($int) = @_;
    $int == int($int)              || botch "expected integer, not $int";
}

sub assert_fractional($)
    :Assert( qw[number] )
{
    &assert_numeric;
    my($float) = @_;
    $float != int($float)          || botch "expected fractional part, not $float";
}

sub assert_signed_number($)
    :Assert( qw[number] )
{
    &assert_numeric;
    my($n) = @_;
    $n =~ /^ [-+] /x             || botch "expected signed number, not $n";
}

sub assert_natural_number($)
    :Assert( qw[number] )
{
    &assert_positive_integer;
    my($int) = @_;
}

sub assert_whole_number($)
    :Assert( qw[number] )
{
    &assert_nonnegative_integer;
    my($int) = @_;
}

sub assert_positive_integer($)
    :Assert( qw[number] )
{
    &assert_integer;
    &assert_positive;
}

sub assert_nonpositive_integer($)
    :Assert( qw[number] )
{
    &assert_integer;
    &assert_nonpositive;
}

sub assert_negative_integer($)
    :Assert( qw[number] )
{
    &assert_integer;
    &assert_negative;
}

sub assert_nonnegative_integer($)
    :Assert( qw[number] )
{
    &assert_integer;
    &assert_nonnegative;
}

sub assert_hex_number($)
    :Assert( qw[regex number] )
{
    local($_) = @_;
    /^ (?:0x)? \p{ahex}+ \z/ix    || botch "expected only ASCII hex digits in string '$_'";
}

sub assert_box_number($)
    :Assert( qw[number] )
{
    local($_) = @_;
    &assert_defined;
    /^ (?: 0b )     [0-1]+       \z /x  ||
    /^ (?: 0o | 0)? [0-7]+       \z /x  ||
    /^ (?: 0x )     [0-9a-fA-F]+ \z /x
        || botch "I wouldn't feed '$_' to oct() if I were you";
}

sub assert_even_number($)
    :Assert( qw[number] )
{
    &assert_integer;
    my($n) = @_;
    $n % 2 == 0                 || botch "$n should be even";
}

sub assert_odd_number($)
    :Assert( qw[number] )
{
    &assert_integer;
    my($n) = @_;
    $n % 2 == 1                 || botch "$n should be odd";
}

sub assert_in_numeric_range($$$)
    :Assert( qw[number] )
{
    assert_numeric($_) for my($n, $low, $high) = @_;
    $n >= $low && $n <= $high   || botch "expected $low <= $n <= $high";
}

sub assert_empty($)
    :Assert( qw[string] )
{
    &assert_defined;
    &assert_nonref;
    my($string) = @_;
    length($string) == 0        || botch "expected zero-length string";
}

sub assert_nonempty($)
    :Assert( qw[string] )
{
    &assert_defined;
    &assert_nonref;
    my($string) = @_;
    length($string) != 0        || botch "expected non-zero-length string";
}

sub assert_blank($)
    :Assert( qw[string regex] )
{
    &assert_defined;
    &assert_nonref;
    my($string) = @_;
    $string =~ /^ \p{whitespace}* \z/x     || botch "found non-whitespace in string '$string'"
}

sub assert_nonblank($)
    :Assert( qw[string regex] )
{
    &assert_defined;
    &assert_nonref;
    my($string) = @_;
    $string =~ / \P{whitespace}/x       || botch "found no non-whitespace in string '$string'"
}

my $_single_line_rx = qr{
    \A
    ( (?! \R ) \X )+
    \R ?
    \z
}x;

sub assert_single_line($)
    :Assert( qw[string regex] )
{
    &assert_nonempty;
    my($string) = @_;
    $string =~ $_single_line_rx         || botch "expected at most a single linebreak at the end";
}

sub assert_multi_line($)
    :Assert( qw[string regex] )
{
    &assert_nonempty;
    my($string) = @_;
    $string !~ $_single_line_rx         || botch "expected more than one linebreak";
}

sub assert_single_paragraph($)
    :Assert( qw[string regex] )
{
    &assert_nonempty;
    my($string) = @_;
    $string =~ / \A ( (?! \R ) \X )+ \R* \z /x
                                        || botch "expected at most a single linebreak at the end";
}

sub assert_bytes($)
    :Assert( qw[string] )
{
    local($_) = @_;
    /^ [\x00-\xFF] + \z/x      || botch "unexpected wide characters in byte string";
}

sub assert_nonbytes($)
    :Assert( qw[string] )
{
    &assert_wide_characters;
}

sub assert_wide_characters($)
    :Assert( qw[string] )
{
    local($_) = @_;
    /[^\x00-\xFF]/x             || botch "expected some wide characters in string";
}

sub assert_nonascii($)
    :Assert( qw[string regex] )
{
    local($_) = @_;
    /\P{ascii}/x                || botch "expected non-ASCII in string";
}

sub assert_ascii($)
    :Assert( qw[string regex] )
{
    local($_) = @_;
    /^ \p{ASCII} + \z/x        || botch "expected only ASCII in string";
}

sub assert_alphabetic($)
    :Assert( qw[string regex] )
{
    local($_) = @_;
    /^ \p{alphabetic} + \z/x        || botch "expected only alphabetics in string";
}

sub assert_nonalphabetic($)
    :Assert( qw[string regex] )
{
    local($_) = @_;
    /^ \P{alphabetic} + \z/x        || botch "expected only non-alphabetics in string";
}

sub assert_alnum($)
    :Assert( qw[regex] )
{
    local($_) = @_;
    /^ \p{alnum} + \z/x        || botch "expected only alphanumerics in string";
}

sub assert_digits($)
    :Assert( qw[regex number] )
{
    local($_) = @_;
    /^ [0-9] + \z/x           || botch "expected only ASCII digits in string";
}

sub assert_uppercased($)
    :Assert( qw[case regex] )
{
    local($_) = @_;
    ($] >= 5.014
        ?  ! /\p{Changes_When_Uppercased}/
        :  $_ eq uc )                 || botch "changes case when uppercased";
}

sub assert_lowercased($)
    :Assert( qw[case regex] )
{
    local($_) = @_;
    ($] >= 5.014
        ?  ! /\p{Changes_When_Lowercased}/
        :  $_ eq lc )                 || botch "changes case when lowercased";
}

sub assert_unicode_ident($)
    :Assert( qw[regex] )
{
    local($_) = @_;
    /^ \p{XID_Start} \p{XID_Continue}* \z/x
                               || botch "invalid identifier $_";
}

# This is a lie.
my $perl_simple_ident_rx = qr{
    \b

lib/Assert/Conditional.pm  view on Meta::CPAN

    \p{XID_Continue} *+
    \b
}x;

my $perl_qualified_ident_rx = qr{
    (?: $perl_simple_ident_rx
      | (?: :: | ' )
    ) +
}x;

sub assert_simple_perl_ident($)
    :Assert( qw[regex ident] )
{
    local($_) = @_;
    /^ $perl_simple_ident_rx \z/x
                                || botch "invalid simple perl identifier $_";
}

sub assert_full_perl_ident($)
    :Assert( qw[regex ident] )
{
    local($_) = @_;
    /^ $perl_qualified_ident_rx \z/x
                                || botch "invalid qualified perl identifier $_";
}

sub assert_qualified_ident($)
    :Assert( qw[regex ident] )
{
    &assert_full_perl_ident;
    local($_) = @_;
    /(?: ' | :: ) /x           || botch "no package separators in $_";
}

sub assert_ascii_ident($)
    :Assert( qw[regex ident] )
{
    local($_) = @_;
    /^ (?= \p{ASCII}+ \z) (?! \d) \w+ \z/x
                                || botch q(expected only ASCII \\w characters in string);
}

sub assert_regex($)
    :Assert( qw[regex] )
{
    my($pattern) = @_;
    assert_isa($pattern, "Regexp");
}

sub assert_like($$)
    :Assert( qw[regex] )
{
    my($string, $pattern) = @_;
    assert_defined($string);
    assert_nonref($string);
    assert_regex($pattern);
    $string =~ $pattern         || botch "'$string' did not match $pattern";
}

sub assert_unlike($$)
    :Assert( qw[regex] )
{
    my($string, $pattern) = @_;
    assert_defined($string);
    assert_nonref($string);
    assert_regex($pattern);
    $string !~ $pattern         || botch "'$string' should not match $pattern";
}

sub assert_latin1($)
    :Assert( qw[string unicode] )
{
    &assert_bytes;
}

sub assert_latinish($)
    :Assert( qw[unicode] )
{
    local($_) = @_;
    /^[\p{Latin}\p{Common}\p{Inherited}]+/
                                    || botch "expected only Latinish characters in string";
}

sub assert_astral($)
    :Assert( qw[unicode] )
{
    local($_) = @_;
    no warnings "utf8";  # early versions of perl complain of illegal for interchange on FFFF
    /[^\x00-\x{FFFF}]/x            || botch "expected non-BMP characters in string";
}

sub assert_nonastral($)
    :Assert( qw[unicode] )
{
    local($_) = @_;
    no warnings "utf8";  # early versions of perl complain of illegal for interchange on FFFF
    /^ [\x00-\x{FFFF}] * \z/x      || botch "unexpected non-BMP characters in string";
}

sub assert_bmp($)
    :Assert( qw[unicode] )
{
    &assert_nonastral;
}

sub assert_nfc($)
    :Assert( qw[unicode] )
{
    my($str) = @_;
    checkNFC($str) // $str eq NFC($str)
                                || botch "string not in NFC form";
}

sub assert_nfkc($)
    :Assert( qw[unicode] )
{
    my($str) = @_;
    checkNFKC($str) // $str eq NFKC($str)
                                || botch "string not in NFKC form";
}

sub assert_nfd($)
    :Assert( qw[unicode] )
{
    my($str) = @_;
    checkNFD($str)              || botch "string not in NFD form";
}

sub assert_nfkd($)
    :Assert( qw[unicode] )
{
    my($str) = @_;
    checkNFKD($str)              || botch "string not in NFKD form";
}

sub assert_eq($$)
    :Assert( qw[string unicode] )
{
    my($this, $that) = @_;
    NFC($this) eq NFC($that)    || botch "'$this' and '$that' are not equivalent Unicode strings";
}

sub assert_eq_letters($$)
    :Assert( qw[string unicode] )
{
    my($this, $that) = @_;
    UCA1($this) eq UCA1($that)  || botch "'$this' and '$that' do not equivalent letters"
}

sub assert_in_list($@)
    :Assert( qw[list] )
{
    my($needle, @haystack) = @_;
    #assert_nonref($needle);
    my $undef_needle = !defined($needle);
    for my $straw (@haystack) {
        #assert_nonref($straw);
        return if $undef_needle
            ? !defined($straw)
            : ("$needle" eq (defined($straw) && "$straw"))
    }
    $needle = "undef" unless defined $needle;
    botch "couldn't find $needle in " . join(", " => map { defined() ? $_ : "undef" } @haystack);
}

sub assert_not_in_list($@)
    :Assert( qw[list] )
{
    my($needle, @haystack) = @_;
    my $found = 0;
    for my $straw (@haystack) {
        if (defined $needle) {
            next if !defined $straw;
            if ("$needle" eq "$straw") {
                $found = 1;
                last;

lib/Assert/Conditional.pm  view on Meta::CPAN

            next if defined $straw;
            $found = 1;
            last;
        }
    }
    return unless $found;
    $needle = "undef" unless defined $needle;
    botch "found $needle in forbidden list";
}

sub assert_list_nonempty( @ )
    :Assert( qw[list array] )
{
    @_                          || botch "list is empty";
}

sub assert_array_nonempty( \@ )
    :Assert( qw[array] )
{
    &assert_arrayref_nonempty;
}

sub assert_arrayref_nonempty( $ )
    :Assert( qw[array] )
{
    &assert_array_length;
    my($aref) = @_;
    assert_arrayref($aref);
    my $count = @$aref;
    $count > 0  || botch("array is empty");
}

sub assert_array_length( \@ ;$ )
    :Assert( qw[array] )
{
    if (@_ == 1) {
        assert_array_length_min(@{$_[0]} => 1);
        return;
    }
    my($aref, $want) = @_;
    assert_arrayref($aref);
    assert_whole_number($want);
    my $have  = @$aref;
    $have == $want            || botch_array_length($have, $want);
}

sub assert_array_length_min( \@ $ )
    :Assert( qw[array] )
{
    my($aref, $want) = @_;
    assert_arrayref($aref);
    assert_whole_number($want);
    my $have = @$aref;
    $have >= $want            || botch_array_length($have, "$want or more");
}

sub assert_array_length_max( \@ $ )
    :Assert( qw[array] )
{
    my($aref, $want) = @_;
    assert_arrayref($aref);
    assert_whole_number($want);
    my $have = @$aref;
    $have <= $want            || botch_array_length($have, "$want or fewer");
}

sub assert_array_length_minmax( \@ $$)
    :Assert( qw[array] )
{
    my($aref, $low, $high) = @_;
    my $have = @$aref;
    assert_whole_number($_) for $low, $high;
    $have >= $low && $have <= $high
                                || botch_array_length($have, "between $low and $high");
}

sub assert_argc(;$)
    :Assert( qw[argc] )
{
    unless (@_) {
        his_args                || botch_argc(0, "at least 1");
        return;
    }
    &assert_whole_number;
    my($want) = @_;
    my $have = his_args;
    $have == $want              || botch_argc($have, $want);
}

sub assert_argc_min($)
    :Assert( qw[argc] )
{
    &assert_whole_number;
    my($want) = @_;
    my $have = his_args;
    $have >= $want              || botch_argc($have, "$want or more");
}

sub assert_argc_max($)
    :Assert( qw[argc] )
{
    &assert_whole_number;
    my($want) = @_;
    my $have = his_args;
    $have <= $want             || botch_argc($have, "$want or fewer");
}

sub assert_argc_minmax($$)
    :Assert( qw[argc] )
{
    assert_whole_number($_) for my($low, $high) = @_;
    my $have = his_args;
    $have >= $low && $have <= $high
        || botch_argc($have, "between $low and $high");
}

sub assert_hash_nonempty(\%)
    :Assert( qw[hash] )
{
    &assert_hashref_nonempty;
}

sub assert_hashref_nonempty($)
    :Assert( qw[hash] )
{
    &assert_hashref;
    my($href) = @_;
    %$href                      || botch "hash is empty";
}

sub assert_hash_keys(\% @)
    :Assert( qw[hash] )
{
    &assert_hashref_keys;
}

sub assert_hash_keys_required(\% @)
    :Assert( qw[hash] )
{
    &assert_hashref_keys_required;
}

sub assert_hash_keys_allowed(\% @)
    :Assert( qw[hash] )
{
    &assert_hashref_keys_allowed;
}

sub assert_hash_keys_required_and_allowed(\% $ $)
    :Assert( qw[hash] )
{
    &assert_hashref_keys_required_and_allowed;
}

sub assert_hash_keys_allowed_and_required(\% $ $)
    :Assert( qw[hash] )
{
    &assert_hashref_keys_allowed_and_required;
}

sub assert_hashref_keys($@)
    :Assert( qw[hash] )
{
    &assert_hashref_keys_required;
}

sub assert_hashref_keys_required($@)
    :Assert( qw[hash] )
{
    my($hashref, @keylist) = @_;
    assert_min_keys($hashref, @keylist);
}

sub assert_hashref_keys_allowed($@)
    :Assert( qw[hash] )
{
    my($hashref, @keylist) = @_;
    assert_max_keys($hashref, @keylist);
}

sub _promote_to_typeref($$) {
    my(undef, $type) = @_;
    &assert_anyref;
    $_[0] = ${ $_[0] } if (reftype($_[0]) // "") =~ /^ (?: SCALAR | REF ) \z/x;
    assert_reftype($type, $_[0]);
}

sub _promote_to_hashref ($) { _promote_to_typeref($_[0], "HASH")  }
sub _promote_to_arrayref($) { _promote_to_typeref($_[0], "ARRAY") }

sub assert_min_keys( \[%$] @ )
    :Assert( qw[hash] )
{
    my($hashref, @keylist) = @_;
    _promote_to_hashref($hashref);
    @keylist                            || botch "no min keys given";

    my @missing = grep { !exists $hashref->{$_} } @keylist;
    return unless @missing;

    my $message = "key" . (@missing > 1 && "s") . " "
                . quotify_and(uca_sort @missing)
                . " missing from hash";

    botch $message;
}

sub assert_max_keys( \[%$] @ )
    :Assert( qw[hash] )
{
    my($hashref, @keylist) = @_;
    _promote_to_hashref($hashref);
    my %allowed = map { $_ => 1 } @keylist;
    my @forbidden;
    for my $key (keys %$hashref) {
        delete $allowed{$key} || push @forbidden, $key;
    }
    return unless @forbidden;

    my $message = "key" . (@forbidden > 1 && "s") . " "
                        . quotify_and(uca_sort @forbidden)
                        . " forbidden in hash";

    botch $message;
}

sub assert_minmax_keys( \[%$] \[@$] \[@$] )
    :Assert( qw[hash] )
{
    my($hashref, $minkeys, $maxkeys) = @_;
    _promote_to_hashref($hashref);
    _promote_to_arrayref($minkeys);
    @$minkeys || botch "no min keys given";
    _promote_to_arrayref($maxkeys);
    @$maxkeys || botch "no max keys given";

    my @forbidden;

lib/Assert/Conditional.pm  view on Meta::CPAN

    my $forbidden_msg = !@forbidden ? "" :
        "key" . (@forbidden > 1 && "s") . " "
              . quotify_and(uca_sort @forbidden)
              . " forbidden in hash";

    my $message = commify_and grep { length } $missing_msg, $forbidden_msg;
    botch $message;
}

sub assert_keys( \[%$] @ )
    :Assert( qw[hash] )
{
    my($hashref, @keylist) = @_;
    _promote_to_hashref($hashref);
    assert_minmax_keys($hashref, @keylist, @keylist);
}

sub assert_hashref_keys_required_and_allowed($$$)
    :Assert( qw[hash] )
{
    my($hashref, $required, $allowed) = @_;
    assert_minmax_keys($hashref, $required, $allowed);
}

sub assert_hashref_keys_allowed_and_required($$$)
    :Assert( qw[hash] )
{
    my($hashref, $allowed, $required) = @_;
    assert_minmax_keys($hashref, $required, $allowed);
}


# From perl5180delta, you couldn't actually get any use of
# the predicates to check whether a hash or hashref was
# locked because even though they were exported those

lib/Assert/Conditional.pm  view on Meta::CPAN

                _promote_to_hashref($hashref);
               !hash_locked(%$hashref)    || botch "hash is not locked";
            }

            1;

END_OF_LOCK_STUFF
    }
}

sub assert_anyref($)
    :Assert( qw[ref] )
{
    my($arg) = @_;
    ref($arg)                   || botch "expected reference argument";
}

sub assert_nonref($)
    :Assert( qw[ref] )
{
    my($arg) = @_;
   !ref($arg)                   || botch "expected nonreference argument";
}

sub assert_reftype($$)
    :Assert( qw[object ref] )
{
    my($want_type, $arg) = @_;
    my $have_type = reftype($arg) // "non-reference";
    $have_type eq $want_type      || botch "expected reftype of $want_type not $have_type";
}

sub assert_globref($)
    :Assert( qw[glob ref] )
{
    my($arg) = @_;
    assert_reftype(GLOB => $arg);
}

sub assert_ioref($)
    :Assert( qw[io ref] )
{
    my($arg) = @_;
    assert_reftype(IO => $arg);
}

sub assert_coderef($)
    :Assert( qw[code ref] )
{
    my($arg) = @_;
    assert_reftype(CODE => $arg);
}

sub assert_hashref($)
    :Assert( qw[hash ref] )
{
    my($arg) = @_;
    assert_reftype(HASH => $arg);
}

sub assert_arrayref($)
    :Assert( qw[array ref] )
{
    my($arg) = @_;
    assert_reftype(ARRAY => $arg);
}

sub assert_refref($)
    :Assert( qw[ref] )
{
    my($arg) = @_;
    assert_reftype(REF => $arg);
}

sub assert_scalarref($)
    :Assert( qw[scalar ref] )
{
    my($arg) = @_;
    assert_reftype(SCALAR => $arg);
}

sub assert_unblessed_ref($)
    :Assert( qw[ref object] )
{
    &assert_anyref;
    &assert_nonobject;
}

sub assert_method()
    :Assert( qw[object] )
{
    my $argc = his_args;
    $argc >= 1                  || botch "invocant missing from method invoked as subroutine";
}

sub assert_object_method()
    :Assert( qw[object] )
{
    my $argc = his_args;
    $argc >= 1                  || botch "no invocant found";
    my($self) = his_args;
    blessed($self)              || botch "object method invoked as class method";
}

sub assert_class_method()
    :Assert( qw[object] )
{
    my $argc = his_args;
    $argc >= 1                  || botch "no invocant found";
    my($class) = his_args;
   !blessed($class)             || botch "class method invoked as object method";
}

# This one is a no-op!
sub assert_public_method()
    :Assert( qw[object] )
{
    my $argc = his_args;
    $argc >= 1                  || botch "invocant missing from public method invoked as subroutine";
}

my %skip_caller = map { $_ => 1 } qw(
    Class::MOP::Method::Wrapped
    Moose::Meta::Method::Augmented
);

# And this one isn't *all* that hard... relatively speaking.
sub assert_private_method()
    :Assert( qw[object] )
{
    my $argc = his_args;
    $argc >= 1                  || botch "invocant missing from private method invoked as subroutine";

    my $frame = 0;
    my @to    = caller $frame++;

    my @from = caller $frame++;
    while (@from && $skip_caller{ $from[CALLER_PACKAGE] }) {

lib/Assert/Conditional.pm  view on Meta::CPAN

        || push @botches, "alien file $from[CALLER_FILENAME] line $from[CALLER_LINE]";

    @botches == 0
        || botch "$msg " . join(" at " => @botches);

}

# But this one? This one is RIDICULOUS. O Moose how we hates you
# foreverz for ruining perl's simple inheritance model and its export
# model and its import model and its package model till the end of time!
sub assert_protected_method()
    :Assert( qw[object] )
{
    my $argc = his_args;
    $argc >= 1                  || botch "invocant missing from protected method invoked as subroutine";

    my $self;  # sic, no assignment
    my $frame = 0;

    my $next_frame = sub {
        package DB;

lib/Assert/Conditional.pm  view on Meta::CPAN

        || $self->DOES( $from[CALLER_PACKAGE] )
    )   || botch join " " => ($msg,
               "called from unfriendly package"
                     => $from[CALLER_PACKAGE],
                at   => $from[CALLER_FILENAME],
                line => $from[CALLER_LINE]
           );

}

sub assert_known_package($)
    :Assert( qw[object ident] )
{
    &assert_nonempty;
    my($arg) = @_;
    my $stash = do { no strict "refs"; \%{ $arg . "::" } };
    no overloading;
    %$stash                     || botch "unknown package $arg";
}

sub assert_object($)
    :Assert( qw[object] )
{
    no overloading;
    &assert_anyref;
    my($arg) = @_;
    blessed($arg)               || botch "expected blessed referent not $arg";
}

sub assert_nonobject($)
    :Assert( qw[object] )
{
    no overloading;
    my($arg) = @_;
   !blessed($arg)               || botch "expected unblessed referent not $arg";
}

sub _get_invocant_type($) {
    my($invocant) = @_;
    my $type;
    if (blessed $invocant) {
        $type = "object";
    } else {
        $type = "package";
    }
    return $type;
}

sub assert_can($@)
    :Assert( qw[object] )
{
    no overloading;
    my($invocant, @methods) = @_;
    @methods                            || botch "need one or more methods to check against";
    my $type = _get_invocant_type $invocant;
    my @cant = grep { !$invocant->can($_) } @methods;
    return unless @cant;

    my $message = "cannot invoke method"
                . (@cant > 1 && "s") . " "
                . quotify_or(uca_sort @cant)
                . " on $type $invocant";

    botch $message;
}

sub assert_cant($@)
    :Assert( qw[object] )
{
    no overloading;
    my($invocant, @methods) = @_;
    @methods                            || botch "need one or more methods to check against";
    my $type = _get_invocant_type $invocant;
    my @can = grep { $invocant->can($_) } @methods;
    return unless @can;

    my $message = "should not be able to invoke method"
                . (@can > 1 && "s") . " "
                . quotify_or(uca_sort @can)
                . " on $type $invocant";

    botch $message;
}

sub assert_object_can($@)
    :Assert( qw[object] )
{
    my($instance, @methods) = @_;
    assert_object($instance);
    assert_can($instance, @methods);
}

sub assert_object_cant($@)
    :Assert( qw[object] )
{
    my($instance, @methods) = @_;
    assert_object($instance);
    assert_cant($instance, @methods);
}

sub assert_class_can($@)
    :Assert( qw[object] )
{
    my($class, @methods) = @_;
    assert_known_package($class);
    assert_can($class, @methods);
}

sub assert_class_cant($@)
    :Assert( qw[object] )
{
    my($class, @methods) = @_;
    assert_known_package($class);
    assert_cant($class, @methods);
}

sub assert_isa($@)
    :Assert( qw[object] )
{
    my($subclass, @superclasses) = @_;
    @superclasses                       || botch "needs one or more superclasses to check against";
    my $type = _get_invocant_type $subclass;
    my @ainta = grep { !$subclass->isa($_) } @superclasses;
    !@ainta || botch "your $subclass $type should be a subclass of " . commify_and(uca_sort @ainta);
}

sub assert_ainta($@)
    :Assert( qw[object] )
{
    no overloading;

    my($subclass, @superclasses) = @_;
    @superclasses                       || botch "needs one or more superclasses to check against";
    my $type = _get_invocant_type $subclass;
    my @isa = grep { $subclass->isa($_) } @superclasses;
    !@isa || botch "your $subclass $type should not be a subclass of " . commify_or(uca_sort @isa);
}

sub assert_object_isa($@)
    :Assert( qw[object] )
{
    my($instance, @superclasses) = @_;
    assert_object($instance);
    assert_isa($instance, @superclasses);
}

sub assert_object_ainta($@)
    :Assert( qw[object] )
{
    my($instance, @superclasses) = @_;
    assert_object($instance);
    assert_ainta($instance, @superclasses);
}

sub assert_class_isa($@)
    :Assert( qw[object] )
{
    my($class, @superclasses) = @_;
    assert_known_package($class);
    assert_isa($class, @superclasses);
}

sub assert_class_ainta($@)
    :Assert( qw[object] )
{
    my($class, @superclasses) = @_;
    assert_known_package($class);
    assert_ainta($class, @superclasses);
}

sub assert_does($@)
    :Assert( qw[object] )
{
    no overloading;
    my($invocant, @roles) = @_;
    @roles                              || botch "needs one or more roles to check against";
    my $type = _get_invocant_type $invocant;
    my @doesnt = grep { !$invocant->DOES($_) } @roles;
    !@doesnt || botch "your $type $invocant does not have role"
                    .  (@doesnt > 1 && "s") . " "
                    .  commify_or(uca_sort @doesnt);
}

sub assert_doesnt($@)
    :Assert( qw[object] )
{
    no overloading;
    my($invocant, @roles) = @_;
    @roles                              || botch "needs one or more roles to check against";
    my $type = _get_invocant_type $invocant;
    my @does = grep { $invocant->DOES($_) } @roles;
    !@does || botch "your $type $invocant does not have role"
                    .  (@does > 1 && "s") . " "
                    .  commify_or(uca_sort @does);
}

sub assert_object_overloads($@)
    :Assert( qw[object overload] )
{
    no overloading;
    &assert_object;
    my($object, @operators) = @_;
    overload::Overloaded($object)       || botch "your $object isn't overloaded";
    my @missing = grep { !overload::Method($object, $_) } @operators;
    !@missing || botch "your $object does not overload the operator"
                    .  (@missing > 1 && "s") . " "
                    . quotify_or(@missing);
}

sub assert_object_stringifies($)
    :Assert( qw[object overload] )
{
    my($object) = @_;
    assert_object_overloads $object, q{""};
}

sub assert_object_nummifies($)
    :Assert( qw[object overload] )
{
    my($object) = @_;
    assert_object_overloads $object, q{0+};
}

sub assert_object_boolifies($)
    :Assert( qw[object overload] )
{
    my($object) = @_;
    assert_object_overloads $object, q{bool};
}

#########################################

# Some of these can trigger unwanted overloads.
{

lib/Assert/Conditional.pm  view on Meta::CPAN

        :Assert( qw[tie glob ref] )
    {
        &assert_globref;
        my($globref) = @_;
       !tied(*$globref)    || botch "glob is tied";
    }

} # scope for no overloading

# Common subroutine for the two happy/unhappy code tests.
sub _run_code_test($$) {
    my($code, $joy) = @_;
    assert_coderef($code);
    return if !!&$code() == !!$joy;
    botch sprintf "%s assertion %s is sadly %s",
        $joy ? "happy" : "unhappy",
        subname_or_code($code),
        $joy ? "false" : "true";
}

sub assert_happy_code(&)
    :Assert( qw[boolean code] )
{
    my($cref) = @_;
    _run_code_test($cref => 1);
}

sub assert_unhappy_code(&)
    :Assert( qw[boolean code] )
{
    my($cref) = @_;
    _run_code_test($cref => 0);
}

sub assert_open_handle($)
    :Assert( qw[io file] )
{
    my($arg) = @_;
    assert_defined($arg);
    defined(openhandle($arg))   || botch "handle $arg is not an open handle";
}

sub assert_regular_file($)
    :Assert( qw[file] )
{
    my($arg) = @_;
    assert_defined($arg);
    -f $arg                    || botch "appears that $arg is not a plainfile"
                                      . " nor a symlink to a plainfile";
}

sub assert_text_file($)
    :Assert( qw[file] )
{
    &assert_regular_file;
    my($arg) = @_;
    -T $arg                    || botch "appears that $arg does not contain text";
}

sub assert_directory($)
    :Assert( qw[file] )
{
    my($arg) = @_;
    -d $arg                    || botch "appears that $arg is not a directory"
                                      . " nor a symlink to a directory";
}

sub _WIFCORED(;$) {
    my($wstat) = @_ ? $_[0] : $?;
    # non-standard but nearly ubiquitous; too hard to fish from real sys/wait.h
    return WIFSIGNALED($wstat) && !!($wstat & 128);
}

sub _coredump_message(;$) {
    my($wstat) = @_ ? $_[0] : $?;
    return _WIFCORED($wstat) && " (core dumped)";
}

sub _signum_message($) {
    my($number) = @_;
    my $name = sig_num2longname($number);
    return "$name(#$number)";
}

sub assert_legal_exit_status(;$)
    :Assert( qw[process] )
{
    my($wstat) = @_ ? $_[0] : $?;
    assert_whole_number($wstat);
    $wstat < 2**16              || botch "exit value $wstat over 16 bits";
}

sub assert_signalled(;$)
    :Assert( qw[process] )
{
    &assert_legal_exit_status;
    my($wstat) = @_ ? $_[0] : $?;
    WIFSIGNALED($wstat)         || botch "exit value $wstat indicates no signal";
}

sub assert_unsignalled(;$)
    :Assert( qw[process] )
{
    &assert_legal_exit_status;
    my($wstat) = @_ ? $_[0] : $?;
    WIFEXITED($wstat)           && return;
    my $signo  = WTERMSIG($wstat);
    my $sigmsg = _signum_message($signo);
    my $cored  = _coredump_message($wstat);
    botch "exit value $wstat indicates process died from signal $sigmsg$cored";
}

sub assert_dumped_core(;$)
    :Assert( qw[process] )
{
    &assert_signalled;
    my($wstat) = @_ ? $_[0] : $?;
    my $signo = WTERMSIG($wstat);
    my $sigmsg = _signum_message($signo);
    _WIFCORED($wstat)           || botch "exit value $wstat indicates signal $sigmsg but no core dump";
}

sub assert_no_coredump(;$)
    :Assert( qw[process] )
{
    my($wstat) = @_ ? $_[0] : $?;
    my $cored = $wstat & 128;   # not standard; too hard to fish from real sys/wait.h
    return unless _WIFCORED($wstat);
    return unless $cored;
    my $signo  = WTERMSIG($wstat);
    my $sigmsg = _signum_message($signo);
    botch "exit value $wstat shows process died of a $sigmsg and dumped core";
}

sub assert_exited(;$)
    :Assert( qw[process] )
{
    &assert_legal_exit_status;
    my($wstat) = @_ ? $_[0] : $?;
    return if WIFEXITED($wstat);
    &assert_signalled;
    my $signo  = WTERMSIG($wstat);
    my $sigmsg = _signum_message($signo);
    my $cored  = _coredump_message($wstat);
    botch "exit value $wstat shows process did not exit but rather died of $sigmsg$cored";
}

sub assert_happy_exit(;$)
    :Assert( qw[process] )
{
    &assert_exited;
    my($wstat) = @_ ? $_[0] : $?;
    my $exit = WEXITSTATUS($wstat);
    $exit == 0                  || botch "exit status $exit is not a happy exit";
}

sub assert_sad_exit(;$)
    :Assert( qw[process] )
{
    &assert_exited;
    my($wstat) = @_ ? $_[0] : $?;
    my $exit = WEXITSTATUS($wstat);
    $exit != 0                  || botch "exit status 0 is an unexpectedly happy exit";
}

# If you actually *execute*(!) this module as though it were a perl
# script rather than merely require or compile it, it dumps out its

lib/Assert/Conditional/Utils.pm  view on Meta::CPAN

# Yes, you can actually export these that way too.
our($Assert_Debug, $Assert_Always, $Assert_Carp, $Assert_Never, $Allow_Handlers)
    :Export( qw[vars] );

our $Pod_Generation;

# Let's not talk about these ones.
our(%PLURAL, %N_PLURAL)
    :Export( qw[acme_plurals] );

sub _init_envariables() {

    use Env qw(
        ASSERT_CONDITIONAL
        ASSERT_CONDITIONAL_BUILD_POD
        ASSERT_CONDITIONAL_DEBUG
        ASSERT_CONDITIONAL_ALLOW_HANDLERS
    );

    $Pod_Generation //= $ASSERT_CONDITIONAL_BUILD_POD      || 0;
    $Allow_Handlers //= $ASSERT_CONDITIONAL_ALLOW_HANDLERS || 0;

lib/Assert/Conditional/Utils.pm  view on Meta::CPAN

    $Assert_Always ||= 1 unless $Assert_Carp || $Assert_Never;

    if ($Assert_Never) {
        warn q(Ignoring $Assert_Always because $Assert_Never is true) if $Assert_Always;
        warn q(Ignoring $Assert_Carp because $Assert_Never is true)   if $Assert_Carp;
        $Assert_Always = $Assert_Carp = 0;
    }

}

sub _init_public_vars() {
    Acme::Plural->import();
}

# Now run that function right now, before the rest of the function:
BEGIN { _init_envariables() }

sub botch($)
    :Export( qw[botch] )
{
    return if $Assert_Never;

    my($msg) = @_;
    my $sub = his_assert;

    local @SIG{<__{DIE,WARN}__>} unless $Allow_Handlers;

    my $botch = "$0\[$$]: botched assertion $sub: \u$msg";

lib/Assert/Conditional/Utils.pm  view on Meta::CPAN

    if ($Assert_Carp) {
        Carp::carp($botch)
    }

    if ($Assert_Always) {
        $botch = shortmess("$botch, bailing out");
        Carp::confess("$botch\n   Beginning stack dump from failed $sub");
    }
}

sub botch_false()
    :Export( qw[botch] )
{
    panic "value should not be false";
}

sub botch_undef()
    :Export( qw[botch] )
{
    panic "value should not be undef";
}

#################################################################
#
# A few stray utility functions that are a bit too intimate with
# the assertions in this file to deserve being made public

sub botch_argc($$)
    :Export( qw[botch] )
{
    my($have, $want) = @_;
    botch_have_thing_wanted(HAVE => $have, THING => "argument", WANTED => $want);
}

sub botch_array_length($$)
    :Export( qw[botch] )
{
    my($have, $want) = @_;
    botch_have_thing_wanted(HAVE => $have, THING => "array element", WANTED => $want);
}

sub botch_have_thing_wanted(@)
    :Export( qw[botch] )
{
    my(%param) = @_;
    my $have   = $param{HAVE}   // botch_undef;
    my $thing  = $param{THING}  // botch_undef;
    my $wanted = $param{WANTED} // botch_undef;
    botch "have $N_PLURAL{$thing => $have} but wanted $wanted";
}

#################################################################

sub panic($)
    :Export( qw[lint botch] )
{
    my($msg) = @_;
    local @SIG{<__{DIE,WARN}__>} unless $Allow_Handlers;
    Carp::confess("Panicking on internal error: $msg");
}

sub FIXME()
    :Export( qw[lint] )
{
    panic "Unimplemented code reached; you forgot to code up a TODO section";
}

sub NOT_REACHED()
    :Export( qw[lint] )
{
    panic "Logically unreachable code somehow reached";
}

#################################################################

# Find the highest assert_ on the stack so that we don't misreport
# failures. For example this next one illustrated below should be
# reporting that assert_hash_keys_required botched because that's the

lib/Assert/Conditional/Utils.pm  view on Meta::CPAN

##
##    Beginning stack dump from failed assert_hash_keys_required at lib/Assert/Conditional/Utils.pm line 391.
## 	Assert::Conditional::Utils::botch("key 'snap' missing from hash") called at lib/Assert/Conditional.pm line 1169
## 	Assert::Conditional::assert_min_keys(REF(0x7fe6196ec3f0), "snap") called at lib/Assert/Conditional.pm line 1135
## 	Assert::Conditional::assert_hashref_keys_required called at lib/Assert/Conditional.pm line 1104
## 	Assert::Conditional::assert_hash_keys_required(HASH(0x7fe619028f70), "snap") called at -e line 1

# But if we can't find as assert_\w+ on the stack, just use the name of the
# the thing that called the thing that called us, so presumably whatever
# called botch.
sub his_assert()
    :Export( qw[frame] )
{
    my $assert_rx = qr/::assert_\w+\z/x;
    my $i;
    my $sub = q();
    for ($i = 1; $sub !~ $assert_rx; $i++)  {
        $sub = his_sub($i) // last;
    }
    $sub //= his_sub(2); # in case we couldn't find an assert_\w+ sub
    while ((his_sub($i+1) // "") =~ $assert_rx) {
        $sub = his_sub(++$i);
    }
    $sub =~ s/.*:://;
    return $sub;
}

sub his_args(;$)
    :Export( qw[frame] )
{
    my $frames = @_ && $_[0];
    do { package DB; () = caller($frames+2); };
    return @DB::args;
}

sub his_frame(;$)
    :Export( qw[frame] )
{
    my $frames = @_ && $_[0];
    return caller($frames+2);
}

BEGIN {

    # Stealing lovely "iota" magic from the
    # Go language construct of the same name.

lib/Assert/Conditional/Utils.pm  view on Meta::CPAN

        CALLER_HINTHASH
    );

    push @{ $EXPORT_TAGS{CALLER} }, @caller_consts;

    push @{ $EXPORT_TAGS{frame}  },
         @{ $EXPORT_TAGS{CALLER} };

}

sub his_package(;$)
    :Export( qw[frame] )
{
    my $frames = @_ && $_[0];
    (his_frame($frames+1))[CALLER_PACKAGE]
}

sub his_filename(;$)
    :Export( qw[frame] )
{
    my $frames = @_ && $_[0];
    (his_frame($frames+1))[CALLER_FILENAME]
}

sub his_line(;$)
    :Export( qw[frame] )
{
    my $frames = @_ && $_[0];
    (his_frame($frames+1))[CALLER_LINE]
}

sub his_subroutine(;$)
    :Export( qw[frame] )
{
    my $frames = @_ && $_[0];
    (his_frame($frames+1))[CALLER_SUBROUTINE]
}

sub his_sub(;$)
    :Export( qw[frame] )
{
    my $frames = @_ && $_[0];
    his_subroutine($frames + 1);
}

sub his_context(;$)
    :Export( qw[frame] )
{
    my $frames = @_ && $_[0];
    (his_frame($frames+1))[CALLER_WANTARRAY]
}

sub his_is_require(;$)
    :Export( qw[frame] )
{
    my $frames = @_ && $_[0];
    (his_frame($frames+1))[CALLER_IS_REQUIRE]
}

#################################################################

my ($hint_bits, $warning_bits);
BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}

sub code_of_coderef($)
    :Export( qw[code] )
{
    my($coderef) = @_;

    my $deparse = B::Deparse->new(
        "-P",
        "-sC",
       #"-x9",
       #"-q",
       #"-q",

lib/Assert/Conditional/Utils.pm  view on Meta::CPAN

    for ($body) {
        s/^\h+(?:use|no) (?:strict|warnings|feature|integer|utf8|bytes|re)\b[^\n]*\n//gm;
        s/^\h+package [^\n]*;\n//gm;
        s/\A\{\n\h+([^\n;]*);\n\}\z/{ $1 }/;
    }

    return $body;

}

sub name_of_coderef($)
    :Export( qw[code] )
{
    require B;
    my($coderef) = @_;
    my $cv = B::svref_2object($coderef);
    return unless $cv->isa("B::CV");
    my $gv = $cv->GV;
    return if $gv->isa("B::SPECIAL");
    my $subname  = $gv->NAME;
    my $packname = $gv->STASH->NAME;
    return $packname . "::" . $subname;
}

sub subname_or_code($)
    :Export( qw[code] )
{
    my($coderef) = @_;
    my $name = name_of_coderef($coderef);
    if ($name =~ /__ANON__/) {
        return code_of_coderef($coderef);
    } else {
        return "$name()";
    }
}

#################################################################

sub serialize_conjunction($@) {
    my $conj = shift;
    (@_ == 0) ? ''                                      :
    (@_ == 1) ? $_[0]                                   :
    (@_ == 2) ? join(" $conj ", @_)                     :
                join(", ", @_[0 .. ($#_-1)], "$conj $_[-1]");
}

sub commify_series
    :Export( qw[list] )
{

lib/Assert/Conditional/Utils.pm  view on Meta::CPAN

{
    commify_nor map { "'$_'" } @_;
}

sub quotify_but
    :Export( qw[list] )
{
    commify_but map { "'$_'" } @_;
}

sub dump_exports(@)
    :Export( qw[exports] )
{
    my $caller_package = caller;
    dump_package_exports($caller_package, @_);
}

sub dump_package_exports($@)
    :Export( qw[exports] )
{
    my($pkg, @exports) = @_;
    my %tag2aref = do { no strict 'refs'; %{$pkg . "::EXPORT_TAGS"} };
    delete $tag2aref{asserts};
    my %seen; # for the all repetition
    my @taglist = @exports ? @exports : ('all', uca_sort(keys %tag2aref));
    my $errors = 0;
    print "=head2 Export Tags\n\n=over\n\n" if $Pod_Generation;
    for my $tag (@taglist)  {

lib/Assert/Conditional/Utils.pm  view on Meta::CPAN

            print "Conditional export tag :$tag exports ", commify_series(uca_sort @$aref), ".\n";
        }
    }
    print "=back\n\n" if $Pod_Generation;
    return $errors == 0;
}

#################################################################

sub UCA (_)             :Export( qw[unicode] );
sub UCA1(_)             :Export( qw[unicode] );
sub UCA2(_)             :Export( qw[unicode] );
sub UCA3(_)             :Export( qw[unicode] );
sub UCA4(_)             :Export( qw[unicode] );
sub uca_cmp ($$)        :Export( qw[unicode] );
sub uca1_cmp($$)        :Export( qw[unicode] );
sub uca2_cmp($$)        :Export( qw[unicode] );
sub uca3_cmp($$)        :Export( qw[unicode] );
sub uca4_cmp($$)        :Export( qw[unicode] );

{
    my @Comparitor;

    sub _get_comparitor($) {
        my($level) = @_;
        panic "invalid level $level" unless $level =~ /^[1-4]$/;
        return $Comparitor[$level] if $Comparitor[$level];

        require Unicode::Collate;

lib/Assert/Conditional/Utils.pm  view on Meta::CPAN

            "UCA$strength"->($that)

        };
    }

    no warnings "once";
    *UCA     = \&UCA1;
    *uca_cmp = \&uca1_cmp;
}

sub uca_sort(@)
    :Export( qw[unicode list] )
{
     state $collator = _get_comparitor(4);
     return $collator->sort(@_);
}

{
    sub _uniq {
        my %seen;
        my @out;