Acme-Acotie

 view release on metacpan or  search on metacpan

inc/Module/Install.pm  view on Meta::CPAN

# Whether or not inc::Module::Install is actually loaded, the
# $INC{inc/Module/Install.pm} is what will still get set as long as
# the caller loaded module this in the documented manner.
# If not set, the caller may NOT have loaded the bundled version, and thus
# they may not have a MI version that works with the Makefile.PL. This would
# result in false errors or unexpected behaviour. And we don't want that.
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
unless ( $INC{$file} ) { die <<"END_DIE" }

Please invoke ${\__PACKAGE__} with:

	use inc::${\__PACKAGE__};

not:

	use ${\__PACKAGE__};

inc/Test/Base.pm  view on Meta::CPAN

sub run(&;$) {
    (my ($self), @_) = find_my_self(@_);
    my $callback = shift;
    for my $block (@{$self->block_list}) {
        $block->run_filters unless $block->is_filtered;
        &{$callback}($block);
    }
}

my $name_error = "Can't determine section names";
sub _section_names {
    return @_ if @_ == 2;
    my $block = $self->first_block
      or croak $name_error;
    my @names = grep {
        $_ !~ /^(ONLY|LAST|SKIP)$/;
    } @{$block->{_section_order}[0] || []};
    croak "$name_error. Need two sections in first block"
      unless @names == 2;
    return @names;
}

sub _assert_plan {
    plan('no_plan') unless $Have_Plan;
}

sub END {
    run_compare() unless $Have_Plan or $DIED or not $import_called;

inc/Test/Base/Filter.pm  view on Meta::CPAN

sub eval {
    $self->assert_scalar(@_);
    my @return = CORE::eval(shift);
    return $@ if $@;
    return @return;
}

sub eval_all {
    $self->assert_scalar(@_);
    my $out = '';
    my $err = '';
    Test::Base::tie_output(*STDOUT, $out);
    Test::Base::tie_output(*STDERR, $err);
    my $return = CORE::eval(shift);
    no warnings;
    untie *STDOUT;
    untie *STDERR;
    return $return, $@, $out, $err;
}

sub eval_stderr {
    $self->assert_scalar(@_);
    my $output = '';
    Test::Base::tie_output(*STDERR, $output);
    CORE::eval(shift);
    no warnings;
    untie *STDERR;
    return $output;
}

sub eval_stdout {

inc/Test/Builder.pm  view on Meta::CPAN

sub _autoflush {
    my($fh) = shift;
    my $old_fh = select $fh;
    $| = 1;
    select $old_fh;
}


my($Testout, $Testerr);
sub _dup_stdhandles {
    my $self = shift;

    $self->_open_testhandles;

    # Set everything to unbuffered else plain prints to STDOUT will
    # come out in the wrong order from our own prints.
    _autoflush($Testout);
    _autoflush(\*STDOUT);
    _autoflush($Testerr);
    _autoflush(\*STDERR);

    $self->output        ($Testout);
    $self->failure_output($Testerr);
    $self->todo_output   ($Testout);
}


my $Opened_Testhandles = 0;
sub _open_testhandles {
    my $self = shift;
    
    return if $Opened_Testhandles;
    
    # We dup STDOUT and STDERR so people can change them in their
    # test suites while still getting normal test output.
    open( $Testout, ">&STDOUT") or die "Can't dup STDOUT:  $!";
    open( $Testerr, ">&STDERR") or die "Can't dup STDERR:  $!";

#    $self->_copy_io_layers( \*STDOUT, $Testout );
#    $self->_copy_io_layers( \*STDERR, $Testerr );
    
    $Opened_Testhandles = 1;
}


sub _copy_io_layers {
    my($self, $src, $dst) = @_;
    
    $self->_try(sub {
        require PerlIO;

inc/Test/More.pm  view on Meta::CPAN

    my $diag;
    $obj_name = 'The object' unless defined $obj_name;
    my $name = "$obj_name isa $class";
    if( !defined $object ) {
        $diag = "$obj_name isn't defined";
    }
    elsif( !ref $object ) {
        $diag = "$obj_name isn't a reference";
    }
    else {
        # We can't use UNIVERSAL::isa because we want to honor isa() overrides
        my($rslt, $error) = $tb->_try(sub { $object->isa($class) });
        if( $error ) {
            if( $error =~ /^Can't call method "isa" on unblessed reference/ ) {
                # Its an unblessed reference
                if( !UNIVERSAL::isa($object, $class) ) {
                    my $ref = ref $object;
                    $diag = "$obj_name isn't a '$class' it's a '$ref'";
                }
            } else {
                die <<WHOA;
WHOA! I tried to call ->isa on your object and got some weird error.
Here's the error.
$error
WHOA
            }
        }
        elsif( !$rslt ) {
            my $ref = ref $object;
            $diag = "$obj_name isn't a '$class' it's a '$ref'";
        }
    }
            
      

inc/Test/More.pm  view on Meta::CPAN

    }
    else {
        $code = <<USE;
package $pack;
use $module \@{\$args[0]};
1;
USE
    }


    my($eval_result, $eval_error) = _eval($code, \@imports);
    my $ok = $tb->ok( $eval_result, "use $module;" );
    
    unless( $ok ) {
        chomp $eval_error;
        $@ =~ s{^BEGIN failed--compilation aborted at .*$}
                {BEGIN failed--compilation aborted at $filename line $line.}m;
        $tb->diag(<<DIAGNOSTIC);
    Tried to use '$module'.
    Error:  $eval_error
DIAGNOSTIC

    }

    return $ok;
}


sub _eval {
    my($code) = shift;
    my @args = @_;

    # Work around oddities surrounding resetting of $@ by immediately
    # storing it.
    local($@,$!,$SIG{__DIE__});   # isolate eval
    my $eval_result = eval $code;
    my $eval_error  = $@;

    return($eval_result, $eval_error);
}

#line 718

sub require_ok ($) {
    my($module) = shift;
    my $tb = Test::More->builder;

    my $pack = caller;

    # Try to deterine if we've been given a module name or file.
    # Module names must be barewords, files not.
    $module = qq['$module'] unless _is_module_name($module);

    my $code = <<REQUIRE;
package $pack;
require $module;
1;
REQUIRE

    my($eval_result, $eval_error) = _eval($code);
    my $ok = $tb->ok( $eval_result, "require $module;" );

    unless( $ok ) {
        chomp $eval_error;
        $tb->diag(<<DIAGNOSTIC);
    Tried to require '$module'.
    Error:  $eval_error
DIAGNOSTIC

    }

    return $ok;
}


sub _is_module_name {
    my $module = shift;