File Coverage

blib/lib/Devel/OptreeDiff.pm

Criterion	Covered	Total	%
statement	115	234	49.1
branch	31	72	43.0
condition	9	14	64.2
subroutine	26	47	55.3
pod	5	12	41.6
total	186	379	49.0

package Devel::OptreeDiff;
BEGIN {
  $Devel::OptreeDiff::VERSION = '2.3';
}
use strict;
use warnings;
use base 'Exporter';
use Algorithm::Diff qw();
use B qw( svref_2object class cstring sv_undef walkoptree );
use B::Utils qw();
use vars qw( @EXPORT_OK
    %SIDES
    %ADDR %DONE_GV %LINKS @NODES @specialsv_name );

@EXPORT_OK = 'fmt_optree_diff';

@specialsv_name
    = qw( Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no (SV*)pWARN_ALL (SV*)pWARN_NONE (SV*)pWARN_STD );

# Create several functions as a wrapper over the functions from
# Algorithm::Diff.
BEGIN {
    for my $method (
        qw( LCS
        diff
        sdiff
        traverse_sequences
        traverse_balanced )
        )
    {
        push @EXPORT_OK, "optree_$method";

        ## no critic eval
        eval "sub " . __PACKAGE__ . "::optree_$method {
            local %SIDES;
            my \@a = as_string( a =>
                                svref_2object( \$_[0] )->ROOT );
            my \@b = as_string( b =>
                                svref_2object( \$_[1] )->ROOT );
            my \@a_names = map { s/^(\\S+) // ? \$1 : \$_ } \@a;
            my \@b_names = map { s/^(\\S+) // ?\$1 : \$_ } \@b;

            my \@diff =
            Algorithm::Diff::$method
            ( # The first two parameters are transformed into the
              # data that this module will be capable of handling
              # a diff on.
              \\\@a, \\\@b,

              # All the additional parameters, if any are passed
              # directly through to Algorithm::Diff::$method
              \@_[ 2 .. \$#_ ]);

           for my \$chunk ( \@diff )
           {
               for my \$line ( \@\$chunk )
               {
                   \$line->[2] = ( \$line->[0] eq '+'
                                   ? \$b_names[\$line->[1]]
                                   : \$a_names[\$line->[1]] )
                                 . \".\$line->[2]\";
                   \$line->[2] =~ s/^([^.]+)\\.\\1\\s*/\$1/;
               }
           }
           \@diff;
        }

        1 "
            or die $@;
    }
}

sub fmt_optree_diff {
    my @chunks = map join( "", map "$_->[0] $_->[2]\n", @$_ ), &optree_diff;
    for my $chunk (@chunks) {
        my %seen;

        # Elide redundant node paths
        $chunk =~ s((?<=^..)([^.\s]+)){
            ( $seen{$1}++
              ? ( ' ' x length $1 )
              : $1 )
            }meg;
    }
    @chunks;
}

sub as_string {
    my ( $side, $op ) = @_;

    local %ADDR;
    local %DONE_GV;
    local @NODES;
    local %LINKS;

    # Serialize the optree
    walkoptree( $op, 'OptreeDiff_as_string' );

    # Delete empty elements
    #    for my $n ( @NODES )
    #    {
    #        delete @{$n}{ grep !defined( $n->{$_ } ), keys %$n };
    #    }

    augment_nodes_with_node_path();

    map( {  my $node = $_;

                my @keys = (
                sort {
                    (     ( $a eq 'name' and $b ne 'name' ) ? -1
                        : ( $a ne 'name' and $b eq 'name' ) ? 1
                        : ( $a cmp $b )
                        )
                    }
                    keys %$node
                );

                map( +(
                    $_ eq 'name' ? $node->{'node path'}
                    : defined $node->{$_}
                    ? "$node->{'node path'} $_ = $node->{$_}"
                    : ()
                ),
                grep( +( $_ ne 'node path' && $_ ne 'class' && $_ ne 'addr' ),
                    @keys ) );
    } @NODES );
}

sub augment_nodes_with_node_path {
    for my $n (@NODES) {
        my $addr     = $n->{'addr'};
        my $rel_from = $LINKS{$addr};

        if ( not $rel_from ) {
            $n->{'node path'} = "/$n->{'name'}";
        }
        else {
            $n->{'node path'} = $n->{'name'};
            while ($rel_from) {
                my $prev;
                if ( grep $_ eq 'first', keys %$rel_from ) {
                    $prev = $rel_from->{'first'}{'prev'};
                    $n->{'node path'}
                        = "$rel_from->{'first'}{'name'}/$n->{'node path'}";
                }
                elsif ( grep $_ eq 'sibling', keys %$rel_from ) {
                    $prev = $rel_from->{'sibling'}{'prev'};
                    $n->{'node path'}
                        = "$rel_from->{'sibling'}{'name'}*$n->{'node path'}";
                }

                $rel_from = $LINKS{$prev};
            }
            $n->{'node path'} = "/$n->{'node path'}";
        }
    }
}

sub ADDR {
    return 0;
    return 0 if not $_[0];

    0xADD + ( $ADDR{ $_[0]->oldname }{ $_[0] } ||= scalar keys %ADDR );
}

sub add_link {
    my %p    = @_;
    my $from = ${ $p{'op'} };
    my $rel  = lc $p{'rel'};

    my $to = $p{'op'}->$rel;
    return if not ref $to;
    $to = $$to;

    return if not( $from and $to );

    #    $LINKS{ $rel }{ $to } = $from;
    $LINKS{$to}{$rel} = {
        'prev' => $from,
        'name' => $p{'op'}->oldname
    };
}

BEGIN {
    for (qw( SIBLING FIRST )) {
        ## no critic eval
        eval "sub ${_}_CHECK {
            return if not \$LINKS{ '\L$_\E' }{ \$_[0] };
            push \@NODES, \"->$_\";
        }
        1 "
            or die $@;
    }
}

# Now inject lots of methods into the B::*OP namespace so it can
# be called by B::walkoptree( $ROOT, 'OptreeDiff_as_string' )

sub B::OP::OptreeDiff_as_string {
    my ($op) = @_;

    return if not $$op;

    my $class = class $op;
    bless $op, 'B::OP' if $class eq 'NULL';

    push(
        @NODES,
        {   addr  => $$op,
            name  => $op->oldname,
            class => $class,
            map( +( "op_$_", $op->$_ ), ( 'targ', 'flags', 'private' ) )
        }
    );
    add_link(
        op  => $op,
        rel => 'SIBLING'
    );
    SIBLING_CHECK($op);
    FIRST_CHECK($op);
}

sub B::UNOP::OptreeDiff_as_string {
    my ($op) = @_;
    add_link(
        op  => $op,
        rel => 'first'
    );

    $op->B::OP::OptreeDiff_as_string(),;
}

sub B::BINOP::OptreeDiff_as_string {
    my ($op) = @_;

    $op->B::UNOP::OptreeDiff_as_string(),;
}

sub B::LOOP::OptreeDiff_as_string {
    my ($op) = @_;
    $op->B::BINOP::OptreeDiff_as_string(),
        $NODES[-1]{"op_$_"} = ADDR( ${ $op->$_ } )
        for (qw( redoop nextop lastop ));
}

sub B::LOGOP::OptreeDiff_as_string {
    my ($op) = @_;
    $op->B::UNOP::OptreeDiff_as_string(),
        $NODES[-1]{"op_other"} = ADDR( ${ $op->other } );
}

sub B::LISTOP::OptreeDiff_as_string {
    my ($op) = @_;
    $op->B::BINOP::OptreeDiff_as_string(),;
}

sub B::PMOP::OptreeDiff_as_string {
    my ($op) = @_;

    $op->B::LISTOP::OptreeDiff_as_string(),
        $NODES[-1]{"op_$_"} = ADDR( ${ $op->$_ } )
        for (qw( pmreplroot pmreplstart pmnext ));
    $NODES[-1]{"op_pmflags"}           = ${ $op->pmflags };
    $NODES[-1]{'op_pmregexp->precomp'} = cstring( $op->precomp );

    # Now recurse down for whatever the pmreplroot is.
    $op->pmreplroot->OptreeDiff_as_string;
}

sub B::COP::OptreeDiff_as_string {
    my ($op) = @_;

    $op->B::OP::OptreeDiff_as_string();
    $NODES[-1]{"cop_$_"} = eval { ${ $op->$_ } }
        for (qw( label stashpv arybase ));
    $NODES[-1]{'cop_warnings'} = ${ $op->warnings };
    $NODES[-1]{'cop_io'}       = cstring(
        class( $op->io ) eq 'SPECIAL'
        ? ''
        : $op->io->as_string
    );
}

sub B::SVOP::OptreeDiff_as_string {
    my ($op) = @_;

    $op->B::OP::OptreeDiff_as_string(),

        $op->sv->OptreeDiff_as_string;
}

sub B::PVOP::OptreeDiff_as_string {
    my ($op) = @_;

    $op->B::OP::OptreeDiff_as_string(),
        $NODES[-1]{"op_pv"} = cstring( $op->pv );
}

sub B::PADOP::OptreeDiff_as_string {
    my ($op) = @_;

    $op->B::OP::OptreeDiff_as_string(), $NODES[-1]{'op_padix'} = $op->padix;
}

sub B::NULL::OptreeDiff_as_string {
    my ($sv) = @_;

    push(
        @NODES,
        {   null => (
                $$sv == ${ sv_undef() }
                ? "&sv_undef\n"
                : ADDR($$sv)
            )
        }
    );
}

sub B::SV::OptreeDiff_as_string {
    my ($sv) = @_;

    push( @NODES, { class => class($sv) } );
    if ($$sv) {
        $NODES[-1]{'addr'} = ADDR($$sv);
        $NODES[-1]{"sv $_"} = $sv->$_ for ( 'REFCNT', 'FLAGS' );
    }
}

sub B::RV::OptreeDiff_as_string {
    my ($rv) = @_;

    B::SV::OptreeDiff_as_string($rv), $NODES[-1]{'RV'} = ADDR( ${ $rv->RV } );

    # Recurse and push another node onto the list
    $rv->RV->OptreeDiff_as_string;
}

sub B::PV::OptreeDiff_as_string {
    my ($sv) = @_;

    my $pv = $sv->PV();
    $pv = '' if not defined $pv;

    $sv->B::SV::OptreeDiff_as_string(), $NODES[-1]{'xpv_pv'} = cstring($pv);
    $NODES[-1]{'xpv_cur'} = length $pv;
}

sub B::IV::OptreeDiff_as_string {
    my ($sv) = @_;

    $sv->B::SV::OptreeDiff_as_string(), $NODES[-1]{'xiv_iv'} = $sv->IV;
}

sub B::NV::OptreeDiff_as_string {
    my ($sv) = @_;

    $sv->B::IV::OptreeDiff_as_string(), $NODES[-1]{'xnv_nv'} = $sv->NV;
}

sub B::PVIV::OptreeDiff_as_string {
    my ($sv) = @_;

    $sv->B::PV::OptreeDiff_as_string(), $NODES[-1]{'xiv_iv'} = $sv->IV;
}

sub B::PVNV::OptreeDiff_as_string {
    my ($sv) = @_;

    $sv->B::PVIV::OptreeDiff_as_string(), $NODES[-1]{'xnv_nv'} = $sv->NV;
}

sub B::PVLV::OptreeDiff_as_string {
    my ($sv) = @_;

    $sv->B::PVNV::OptreeDiff_as_string(), $NODES[-1]{"xlv_\L$_"} = $sv->$_
        for ( 'TARGOFF', 'TARGLEN' );
    $NODES[-1]{'xlv_type'} = cstring( chr $sv->TYPE );
}

sub B::BM::OptreeDiff_as_string {
    my ($sv) = @_;

    $sv->B::PVNV::OptreeDiff_as_string(), $NODES[-1]{"xbm_\L$_"} = $sv->$_
        for ( 'USEFUL', 'PREVIOUS' );
    $NODES[-1]{'xbm_rare'} = cstring( chr $sv->RARE );
}

sub B::CV::OptreeDiff_as_string {
    my ($sv)      = @_;
    my ($stash)   = $sv->STASH;
    my ($start)   = $sv->START;
    my ($root)    = $sv->ROOT;
    my ($padlist) = $sv->PADLIST;
    my ($gv)      = $sv->GV;

    $sv->B::PVNV::OptreeDiff_as_string();

    $NODES[-1]{$_} = ADDR( ${ $sv->$_ } )
        for ( 'STASH', 'START', 'ROOT', 'GV', 'PADLIST', 'OUTSIDE' );
    $NODES[-1]{'DEPTH'} = $sv->DEPTH;

    $_->OptreeDiff_as_string
        for grep $_,
        map $sv->$_,
        ( 'GV', 'PADLIST', 'ROOT', 'START' );
}

sub B::AV::OptreeDiff_as_string {
    my ($av)    = @_;
    my (@array) = $av->ARRAY;

    $av->B::SV::OptreeDiff_as_string,
        $NODES[-1]{'ARRAY'} = join( ", ", map ADDR($$_), @array );
    $NODES[-1]{'FILL'} = scalar @array;
    $NODES[-1]{$_} = $av->$_ for qw( MAX OFF AvFLAGS );
}

sub B::GV::OptreeDiff_as_string {
    my ($gv) = @_;

    $NODES[-1]{'GV'} = join( "::", $gv->STASH->NAME, $gv->SAFENAME );
}

sub B::SPECIAL::OptreeDiff_as_string {
    my ($sv) = @_;

    $NODES[-1] .= join "", $specialsv_name[$$sv], "\n";
}

1;
__END__