File Coverage

blib/lib/B/Generate.pm

Criterion	Covered	Total	%
statement	24	68	35.2
branch	3	28	10.7
condition	1	24	4.1
subroutine	7	11	63.6
pod			n/a
total	35	131	26.7

package B::Generate;

require 5.005_62;
use strict;
use warnings;
use B ();

require DynaLoader;
use vars qw( @ISA $VERSION );
@ISA = qw(DynaLoader);
$VERSION = '1.55';

{
    # 'no warnings' does not work.
    local $SIG{__WARN__} = sub {
        return if $_[0] =~ /Subroutine B(?:::\w+)+ redefined/;
        warn $_[0];
    };
    bootstrap B::Generate $VERSION;
}

package
  B::OP; # do not index
use constant OP_LIST    => B::opnumber("list");
use B qw(OPf_PARENS OPf_KIDS);

# for convenience
sub B::NULL::type { 0 };

# This is where we implement op.c in Perl. Sssh.
# XXX coverage: 0
sub linklist {
    my $o = shift;
    if ( $o->can("first") and $o->first and ${ $o->first } ) {
        $o->next( $o->first->linklist );
        for ( my $kid = $o->first; $$kid; $kid = $kid->sibling ) {
            if ( ${ $kid->sibling } ) {
                $kid->next( $kid->sibling->linklist );
            }
            else {
                $kid->next($o);
            }
        }
    }
    else {
        $o->next($o);
    }
    $o->clean;
    return $o->next;
}

# coverage: scope.t
sub append_elem {
    my ( $class, $type, $first, $last ) = @_;
    return $last  unless $first and $$first;
    return $first unless $last  and $$last;

    if ( $first->type() != $type
        or ( $type == OP_LIST and ( $first->flags & OPf_PARENS ) ) )
    {
        return B::LISTOP->new( $type, 0, $first, $last );
    }

    if ( $first->flags() & OPf_KIDS ) {

        $first->last->sibling($last);
    }
    else {
        $first->flags( $first->flags | OPf_KIDS );
        $first->first($last);
    }
    $first->last($last);
    return $first;
}

# coverage: scope.t
sub prepend_elem {
    my ( $class, $type, $first, $last ) = @_;
    if ( $last->type() != $type ) {
        return B::LISTOP->new( $type, 0, $first, $last );
    }

    if ( $type == OP_LIST ) {
        $first->sibling( $last->first->sibling );
        $last->first->sibling($first);
        $last->flags( $last->flags & ~OPf_PARENS )
            unless ( $first->flags & OPf_PARENS );
    }
    else {
        unless ( $last->flags & OPf_KIDS ) {
            $last->last($first);
            $last->flags( $last->flags | OPf_KIDS );
        }
        $first->sibling( $last->first );
        $last->first($first);
    }
    $last->flags( $last->flags | OPf_KIDS );
    return $last;    # I cannot believe this works.
}

# coverage: scope.t
sub scope {
    my $o = shift;
    return unless $o and $$o;
    if ( $o->flags & OPf_PARENS ) {
        $o = B::OP->prepend_elem( B::opnumber("lineseq"),
             B::OP->new( "enter", 0 ), $o );
        $o->type( B::opnumber("leave") );
    }
    else {
        if ( $o->type == B::opnumber("lineseq") ) {
            my $kid;
            $o->type( B::opnumber("scope") );
            $kid = $o->first;
            die "This probably shouldn't happen (\$kid->null)\n"
                if ( $kid->type == B::opnumber("nextstate")
                or $kid->type == B::opnumber("dbstate") );
        }
        else {
            $o = B::LISTOP->new( "scope", 0, $o, undef );
        }
    }
    return ($o);
}

1;
__END__