view release on metacpan or  search on metacpan

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

sub  assert_object_stringifies                (  $                ) ;
sub  assert_odd_number                        (  $                ) ;
sub  assert_open_handle                       (  $                ) ;
sub  assert_positive                          (  $                ) ;
sub  assert_positive_integer                  (  $                ) ;
sub  assert_private_method                    (                   ) ;
sub  assert_protected_method                  (                   ) ;
sub  assert_public_method                     (                   ) ;
sub  assert_qualified_ident                   (  $                ) ;
sub  assert_refref                            (  $                ) ;
sub  assert_reftype                           (  $$               ) ;
sub  assert_regex                             (  $                ) ;
sub  assert_regular_file                      (  $                ) ;
sub  assert_sad_exit                          ( ;$                ) ;
sub  assert_scalar_context                    (                   ) ;
sub  assert_scalarref                         (  $                ) ;
sub  assert_signalled                         ( ;$                ) ;
sub  assert_signed_number                     (  $                ) ;
sub  assert_simple_perl_ident                 (  $                ) ;
sub  assert_single_line                       (  $                ) ;
sub  assert_single_paragraph                  (  $                ) ;
sub  assert_text_file                         (  $                ) ;
sub  assert_tied                              ( \[$@%*]           ) ;
sub  assert_tied_array                        ( \@                ) ;
sub  assert_tied_arrayref                     (  $                ) ;
sub  assert_tied_glob                         ( \*                ) ;
sub  assert_tied_globref                      (  $                ) ;
sub  assert_tied_hash                         ( \%                ) ;
sub  assert_tied_hashref                      (  $                ) ;
sub  assert_tied_referent                     (  $                ) ;
sub  assert_tied_scalar                       ( \$                ) ;
sub  assert_tied_scalarref                    (  $                ) ;
sub  assert_true                              (  $                ) ;
sub  assert_unblessed_ref                     (  $                ) ;
sub  assert_undefined                         (  $                ) ;
sub  assert_unhappy_code                      (  &                ) ;
sub  assert_unicode_ident                     (  $                ) ;
sub  assert_unlike                            (  $$               ) ;
sub  assert_unlocked                          ( \[%$] @           ) ;
sub  assert_unsignalled                       ( ;$                ) ;
sub  assert_untied                            ( \[$@%*]           ) ;
sub  assert_untied_array                      ( \@                ) ;
sub  assert_untied_arrayref                   (  $                ) ;
sub  assert_untied_glob                       ( \*                ) ;
sub  assert_untied_globref                    (  $                ) ;
sub  assert_untied_hash                       ( \%                ) ;
sub  assert_untied_hashref                    (  $                ) ;
sub  assert_untied_referent                   (  $                ) ;
sub  assert_untied_scalar                     ( \$                ) ;
sub  assert_untied_scalarref                  (  $                ) ;
sub  assert_uppercased                        (  $                ) ;
sub  assert_void_context                      (                   ) ;
sub  assert_whole_number                      (  $                ) ;
sub  assert_wide_characters                   (  $                ) ;
sub  assert_zero                              (  $                ) ;
############################################################

sub import {
    my ($package, @conditional_imports) = @_;
    my @normal_imports = $package->_strip_import_conditions(@conditional_imports);
    if    ($Assert_Never)  { $package->SUPER::import(@normal_imports, -if => 0) }
    elsif ($Assert_Always) { $package->SUPER::import(@normal_imports, -if => 1) }
    else                   { $package->SUPER::import(@conditional_imports     ) }
    $package->_reimport_nulled_code_protos();
}

# This is just pretty extreme, but it's also about the only way to
# make the Exporter shut up about things we sometimes need to do in
# this module.
#
# Well, not quite the only way: there's always local *SIG. :)
#
# Otherwise it dribbles all over your screen when you try more than one
# import, like importing a set and then reneging on a few of them.
# 
# Newer versions of Carp appear not to need these heroics.

sub export_to_level {
    my($package, $level, @export_args) = @_;

    state $old_carp = \&Carp::carp;
    state $filters = [
        qr/^Constant subroutine \S+ redefined/,
        qr/^Subroutine \S+ redefined/,
        qr/^Prototype mismatch:/,
    ];

    no warnings "redefine";
    local *Carp::carp = sub {
        my($text) = @_;
        $text =~ $_ && return for @$filters;
        local $Carp::CarpInternal{"Exporter::Heavy"} = 1;
        $old_carp->($text);
    };
    $package->SUPER::export_to_level($level+2, @export_args);
}

# You have to do this if you have asserts that take a code
# ref as their first argument and people want to use those
# without parentheses. That's because the constant subroutine
# that gets installed necessarily no longer has the prototype
# needed to support a code ref in the dative slot syntactically.
sub _reimport_nulled_code_protos {
    my($my_pack) = @_;
    my $his_pack = caller(1);

    no strict "refs";

    for my $export (@{$my_pack . "::EXPORT_OK"}) {
        my $real_proto = prototype($my_pack . "::$export");
        $real_proto && $real_proto =~ /^\s*&/           || next;
        my $his_func = $his_pack . "::$export";
        defined &$his_func                              || next;
        prototype($his_func)                            && next;
        eval qq{
            no warnings qw(prototype redefine);
            package $his_pack;
            sub $export ($real_proto) { 0 }
            1;
        } || panic "eval failed";
    }
}

# Remove the trailing -if/-unless from the conditional
# import list.
sub _strip_import_conditions {
    my($package, @args) = @_;
    my @export_args;
    while (@args && ($args[0] || '') !~ /^-(?:if|unless)$/) {
        push @export_args, shift @args;
    }
    return @export_args;
}

################################################################
# The following attribute handler handler for subs saves
# us a lot of bookkeeping trouble by letting us declare
# which export tag groups a particular assert belongs to
# at the point of declaration where it belongs, and so
# that it is all handled automatically.
################################################################
sub Assert : ATTR(CODE,BEGIN)
{
    my($package, $symbol, $referent, $attr, $data, $phase, $filename, $linenum) = @_;
    no strict "refs";
    my($subname, $tagref) = (*{$symbol}{NAME}, $data);
    $subname =~ /^assert_/
        || panic "$subname is not an assertion";

    my $his_export_ok = $package . "::EXPORT_OK";
    push @$his_export_ok, $subname;

    my $debugging = $Exporter::Verbose || $Assert_Debug;

    carp "Adding $subname to EXPORT_OK in $package at ",__FILE__," line ",__LINE__ if $debugging;