OP_PRINT
OP_PUSHMARK
OP_RV2AV
OP_GV
NULL
##</code><code>##

+OP_NULL
+OP_OR
 OP_PRINT
 OP_PUSHMARK
 OP_RV2AV
 OP_GV
 NULL
+OP_DIE
+OP_PUSHMARK
+OP_NULL
+OP_GVSV
##</code><code>##

use Data::Dumper 'Dumper';
use Devel::CodeDiff 'code_diff';

my @d = code_diff( sub { print @_ },
                   sub { print @_ or die $! } );

# Fixup the output so it is less verbose
for ( @d )
{
    for ( @$_ )
    {
        $_->[2] =~ /\[(.+)\]/ and $_->[2] = $1;
        $_ = join " ", @$_;
    }
}

print Dumper( @d );
##</code><code>##

$VAR1 = [
          '- 3 OP_PRINT',
          '+ 3 OP_NULL',
          '- 4 OP_PUSHMARK',
          '+ 4 OP_OR',
          '- 5 OP_RV2AV',
          '+ 5 OP_PRINT',
          '- 6 OP_GV',
          '+ 6 OP_PUSHMARK',
          '- 7 NULL (0xae6)
AV (0xae8)
REFCNT 2
FLAGS 0xa
ARRAY (FILL 1
MAX 3
OFF 0
AvFLAGS 2
Nullsv
',
          '+ 7 OP_RV2AV',
          '+ 8 OP_GV',
          '+ 9 NULL (0xaea)
AV (0xaec)
REFCNT 2
FLAGS 0xa
ARRAY (FILL 1
MAX 3
OFF 0
AvFLAGS 2
Nullsv
',
          '+ 10 OP_DIE',
          '+ 11 OP_PUSHMARK',
          '+ 12 OP_NULL',
          '+ 13 OP_GVSV'
        ];
##</code><code>##

package Devel::CodeDiff;
use strict;
use warnings;
use base 'Exporter';
use Algorithm::Diff qw( traverse_balanced );
use B qw( svref_2object class cstring sv_undef walkoptree );
use B::Utils qw();
use B::Asmdata qw( @specialsv_name );
use vars qw( $VERSION @EXPORT_OK %SIDES %ADDR %DONE_GV %LINKS @NODES );

$VERSION = '0.01';
@EXPORT_OK = 'code_diff';

sub code_diff
{
    local %SIDES = ( a => { ADDR => {},
                            DONE_GV => {},
                            NODES => [],
                            LINKS => {} },
                     b => { ADDR => {},
                            DONE_GV => {},
                            NODES => [],
                            LINKS => {} } );
    Algorithm::Diff::diff( [ as_string( a => svref_2object( $_[0] )->ROOT ) ],
                           [ as_string( b => svref_2object( $_[1] )->ROOT ) ] );
}

sub as_string
{
    my $side = shift;
    my $op = shift;
    
    
    local *ADDR = $SIDES{ $side }{ 'ADDR' };
    local *DONE_GV = $SIDES{ $side }{ 'DONE_GV' };
    local *NODES = $SIDES{ $side }{ 'NODES' };
    local *LINKS = $SIDES{ $side }{ 'LINKS' };
    
    walkoptree( $op, 'CodeDiff_as_string' );
    @NODES;
}

sub ADDR
{
    return 0 if not $_[0];
    
    0xADD + ( exists $ADDR{$_[0]}
              ? $ADDR{$_[0]}
              : ( $ADDR{$_[0]} = scalar keys %ADDR ) );
}

sub B::OP::CodeDiff_as_string {
    my ($op) = @_;
    
    return "<" if not $$op;
    
    my $class = class $op;
    bless $op, 'B::OP' if $class eq 'NULL';
    
    $LINKS{ $op }{ 'sibling' } = ADDR( ${$op->sibling} );
    push( @NODES,
          sprintf( "%s (0x%x)\n"
                   . "op_sibling 0x%x\n"
                   . "op_ppaddr %s\n"
                   . "op_targ %d\n"
                   . "op_type %d\n"
                   . "op_flags %d\n"
                   . "op_private %d\n",
                   $class,
                   ADDR( $$op ),
                   ADDR( ${$op->sibling} ),
                   $op->ppaddr,
                   $op->targ,
                   $op->type,
                   $op->flags,
                   $op->private ) );
}

sub B::UNOP::CodeDiff_as_string {
    my ($op) = @_;
    $LINKS{$op}{'first'} = ADDR( ${$op->first} );

    $op->B::OP::CodeDiff_as_string(),
    $NODES[-1] .= 
        join( "",
              sprintf( "op_first 0x%x\n",
                       ADDR( ${$op->first} ) ) );
}

sub B::BINOP::CodeDiff_as_string {
    my ($op) = @_;
    $op->B::UNOP::CodeDiff_as_string(),
    $NODES[-1] .=
        join( "",
              sprintf( "op_last 0x%x\n",
                       ADDR( ${$op->last} ) ) );
}

sub B::LOOP::CodeDiff_as_string {
    my ($op) = @_;
    $op->B::BINOP::CodeDiff_as_string(),
    $NODES[-1] .=
        join( "",
              sprintf( "op_redoop 0x%x\n"
                       . "op_nextop 0x%x\n"
                       . "op_lastop 0x%x\n",
                       ADDR( ${$op->redoop} ),
                       ADDR( ${$op->nextop} ),
                       ADDR( ${$op->lastop} ) ) );
}

sub B::LOGOP::CodeDiff_as_string {
    my ($op) = @_;
    $op->B::UNOP::CodeDiff_as_string(),
    $NODES[-1] .=
        join( "",
              sprintf( "op_other 0x%x\n",
                       ADDR( ${$op->other} ) ) );
}

sub B::LISTOP::CodeDiff_as_string {
    my ($op) = @_;
    $op->B::BINOP::CodeDiff_as_string(),
    $NODES[-1] .=
        join( "",
              sprintf( "op_children %d\n",
                       $op->children ) );
}

sub B::PMOP::CodeDiff_as_string {
    my ($op) = @_;
    
    # push( @NODES, ... )
    $op->B::LISTOP::CodeDiff_as_string(),
    $NODES[-1] .=
        join( "",
              sprintf( "op_pmreplroot 0x%x\n"
                       . "op_pmreplstart 0x%x\n"
                       . "op_pmnext 0x%x\n"
                       . "op_pmregexp->precomp %s\n"
                       . "op_pmflags 0x%x\n",
                       ADDR( ${$op->pmreplroot} ),
                       ADDR( ${$op->pmreplstart} ),
                       ADDR( ${$op->pmnext} ),
                       cstring($op->precomp),
                       $op->pmflags ) );
    
    $op->pmreplroot->CodeDiff_as_string;
}

sub B::COP::CodeDiff_as_string {
    my ($op) = @_;
    my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->CodeDiff_as_string;
    
    # push( @NODES, ... )
    $op->B::OP::CodeDiff_as_string();
    $NODES[-1] .= 
        join( "",
              sprintf( "cop_label %s\n"
                       . "cop_stash_pv %s\n"
                       . "cop_arybase %d\n"
                       . "cop_warnings 0x%x\n"
                       . "cop_io %s\n",
                       $op->label,
                       $op->stashpv,
                       $op->arybase,
                       ${$op->warnings},
                       cstring($cop_io) ) );
}

sub B::SVOP::CodeDiff_as_string {
    my ($op) = @_;
    $op->B::OP::CodeDiff_as_string(),
    $NODES[-1] .=
        join( "",
              sprintf( "op_sv 0x%x\n",
                       ADDR( ${$op->sv} ) ) );
    $op->sv->CodeDiff_as_string;
}

sub B::PVOP::CodeDiff_as_string {
    my ($op) = @_;
    $op->B::OP::CodeDiff_as_string(),
    $NODES[-1] .=
        join( "",
              sprintf( "op_pv %s\n",
                       cstring($op->pv) ) );
}

sub B::PADOP::CodeDiff_as_string {
    my ($op) = @_;
    $op->B::OP::CodeDiff_as_string(),
    $NODES[-1] .=
        join( "",
              sprintf( "op_padix %ld\n",
                       $op->padix ) );
}

sub B::NULL::CodeDiff_as_string {
    my ($sv) = @_;
    
    push( @NODES,
          ( $$sv == ${sv_undef()}
            ? "&sv_undef\n"
            : sprintf( "NULL (0x%x)\n",
                       ADDR( $$sv ) ) ) );
}

sub B::SV::CodeDiff_as_string {
    my ($sv) = @_;
    
    $NODES[-1] .= ( $$sv
                    ? sprintf( "%s (0x%x)\n"
                               . "REFCNT %d\n"
                               . "FLAGS 0x%x\n",
                               class( $sv ),
                               ADDR( $$sv ),
                               $sv->REFCNT,
                               $sv->FLAGS )
                    : class( $sv ) . " = NULL\n" );
}

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

    B::SV::CodeDiff_as_string($rv),
    $NODES[-1] .=
        join( "",
              sprintf( "RV 0x%x\n", ADDR( ${$rv->RV} ) ) );
    $rv->RV->CodeDiff_as_string;
}

sub B::PV::CodeDiff_as_string {
    my ($sv) = @_;
    my $pv = $sv->PV();
    $pv = '' if not defined $pv;
    
    $sv->B::SV::CodeDiff_as_string(),
    $NODES[-1] .=
        join( "",
              sprintf( "xpv_pv %s\n"
                       . "xpv_cur %s\n",
                       cstring($pv),
                       length($pv) ) );
}

sub B::IV::CodeDiff_as_string {
    my ($sv) = @_;
    $sv->B::SV::CodeDiff_as_string(),
    $NODES[-1] .=
        join( "",
              sprintf("xiv_iv %d\n", $sv->IV ) );
}

sub B::NV::CodeDiff_as_string {
    my ($sv) = @_;
    $sv->B::IV::CodeDiff_as_string(),
    $NODES[-1] .=
        join( "",
              sprintf( "xnv_nv %s\n",
                       $sv->NV ) );
}

sub B::PVIV::CodeDiff_as_string {
    my ($sv) = @_;
    $sv->B::PV::CodeDiff_as_string(),
    $NODES[-1] .=
        join( "",
              sprintf( "xiv_iv %d\n", $sv->IV ) );
}

sub B::PVNV::CodeDiff_as_string {
    my ($sv) = @_;
    $sv->B::PVIV::CodeDiff_as_string(),
    $NODES[-1] .=
        join( "",
              sprintf( "xnv_nv %s\n", $sv->NV ) );
}

sub B::PVLV::CodeDiff_as_string {
    my ($sv) = @_;
    $sv->B::PVNV::CodeDiff_as_string(),
    $NODES[-1] .=
        join( "",
              sprintf( "xlv_targoff %d\n"
                       . "xlv_targlen %u\n"
                       . "xlv_type %s\n",
                       $sv->TARGOFF,
                       $sv->TARGLEN,
                       cstring(chr($sv->TYPE)) ) );
}

sub B::BM::CodeDiff_as_string {
    my ($sv) = @_;
    
    $sv->B::PVNV::CodeDiff_as_string(),
    $NODES[-1] .=
        join( "",
              sprintf( "xbm_useful %d\n"
                       . "xbm_previous %u\n"
                       . "xbm_rare %s\n",
                       $sv->USEFUL,
                       $sv->PREVIOUS,
                       cstring(chr($sv->RARE)) ) );
}

sub B::CV::CodeDiff_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::CodeDiff_as_string();
    $NODES[-1] .=
        join( "",
              sprintf( "STASH 0x%x\n"
                       . "START 0x%x\n"
                       . "ROOT 0x%x\n"
                       . "GV 0x%x\n"
                       . "DEPTH %d\n"
                       . "PADLIST 0x%x\n"
                       . "OUTSIDE 0x%x\n",
                       ADDR( $$stash ),
                       ADDR( $$start ),
                       ADDR( $$root ),
                       ADDR( $$gv ), 
                       $sv->DEPTH,
                       ADDR( $padlist ),
                       ADDR( ${$sv->OUTSIDE} ) ) );
    
    $_->CodeDiff_as_string for grep $_, ( $gv, $padlist, $root, $start );
}

sub B::AV::CodeDiff_as_string {
    my ($av) = @_;
    my(@array) = $av->ARRAY;
    $av->B::SV::CodeDiff_as_string,
    $NODES[-1] .=
        join( "",
              sprintf( "ARRAY (",
                       join( ", ",
                             map( "0x" . ADDR( $$_ ),
                                  @array) ),
                       ")\n" ),
              sprintf( "FILL %d\n"
                       . "MAX %d\n"
                       . "OFF %d\n"
                       . "AvFLAGS %d\n",
                       scalar(@array),
                       $av->MAX,
                       $av->OFF,
                       $av->AvFLAGS ) );
}

sub B::GV::CodeDiff_as_string {
    my ($gv) = @_;
    if ($DONE_GV{$$gv}++) {
        $NODES[-1] .=
            sprintf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
        return;
    }
    my ($sv) = $gv->SV;
    my ($av) = $gv->AV;
    my ($cv) = $gv->CV;
    $gv->B::SV::CodeDiff_as_string,
    $NODES[-1] .=
        join( "",
              sprintf( "NAME %s\n"
                       . "STASH %s (0x%x)\n"
                       . "SV 0x%x\n"
                       . "GvREFCNT %d\n"
                       . "FORM 0x%x\n"
                       . "AV 0x%x\n"
                       . "HV 0x%x\n"
                       . "EGV 0x%x\n"
                       . "CV 0x%x\n"
                       . "CVGEN %d\n"
                       . "GvFLAGS 0x%x\n",
                       $gv->SAFENAME,
                       $gv->STASH->NAME,
                       ADDR( $gv->STASH ),
                       ADDR( $$sv ),
                       $gv->GvREFCNT,
                       ADDR( $gv->FORM ),
                       ADDR( $$av ),
                       ADDR( ${$gv->HV} ),
                       ADDR( ${$gv->EGV} ),
                       ADDR( $$cv ),
                       $gv->CVGEN,
                       $gv->GvFLAGS ) );
    $_->CodeDiff_as_string for grep $_, ( $sv,
                                          $av,
                                          $cv );
}

sub B::SPECIAL::CodeDiff_as_string {
    my $sv = shift;
    
    $NODES[-1] .=
        join "", $specialsv_name[$$sv], "\n";
}


1;
__END__

=head1 NAME

Devel::CodeDiff - Produces diffs of perl code

=head1 SYNOPSIS

  use Devel::CodeDiff 'code_diff';
  use Data::Dumper 'Dumper';
  print Dumper( code_diff( sub { print or die },
                           sub { print } ) );

=head1 DESCRIPTION

=head2 EXPORT

=head1 SEE ALSO

=head1 AUTHOR

=head1 COPYRIGHT AND LICENSE

=cut