package Devel::UncheckedOps;
use strict;
use warnings FATAL => 'all';
use B qw( OPf_WANT_VOID class );
use B::Utils qw( walkallops_filtered opgrep );
use vars qw( $REPORT_CALLBACK %CHECK_DICT @CHECK_OPS @TERMINAL_OPS $VERSION
             $OPCODE_NAME $FIX_OPCODES $O_PM @QUEUED_FIXES_TO_APPLY $DEBUG );
# %ALLOPS %OPMAP
use Carp qw( carp );

$VERSION = '0.01';

# This is a largish list of stuff I think can be validated by this module.
# The default list of opcodes that will be checked is defined in @CHECK_OPS
# immediately following and normal users specify the list of ops to validate
# by passing in a reference to an array to the 'check' parameter of the use()
# call.
%CHECK_DICT = (
               # 'write' would be a nice op to add but I do not yet know how
               # it works in code.
               io =>
               [ qw[open close binmode dbmclose dbmopen fcntl flock getc ioctl
                    pipe_op tie read print prtf seek send sysopen sysread
                    sysseek syswrite recv tell truncate ] ],
               
               sockets =>
               [ qw[accept bind connect listen shutdown sockpair ] ],
               
               file =>
               [ qw[ chdir chmod chown chroot link mkdir readlink rename rmdir
                     symlink unlink utime rmdir ] ],
               
               directory =>
               [ qw[ closedir open_dir readdir rewinddir seekdir telldir ] ],
               
               # process =>
               # TODO:
               #   Check backtick
               #   die $?, not $!
               # [ qw[ exec fork kill system ] ],
               
               # I do not know how to validate the semaphore, shared memory,
               # or message passing code. Thi
               shared_memory =>
               [ qw[ shmctl shmget shmread shmwrite ] ],

               message_passing =>
               [ qw[ msgctl msgget msgrcv msgsnd ] ],

               semaphores =>
               [ qw[ semctl semget semop ] ],
               
               eval => [ qw[ dofile ] ],
               
               miscellaneous =>
               [ qw[ syscall ] ]
               
               );

@CHECK_OPS = ( map @$_,
               @CHECK_DICT{ qw( io
                                sockets
                                file
                                directory
                                eval
                                miscellaneous ) } );

# I started with just nextstate and leavesub but while reading opcode.pl
# went "eh, what the heck. Why not?" and just included the raft of related
# opcodes.
@TERMINAL_OPS = ( qw[ method
                      entersub
                      leavesub
                      leavesublv
                      caller
                      reset
                      
                      lineseq
                      nextstate
                      dbstate
                      unstack
                      enter
                      leave
                      scope
                      enteriter
                      iter
                      enterloop
                      leaveloop
                      return
                      last
                      next
                      redo
                      dump
                      goto
                      exit ] );

$REPORT_CALLBACK = \ &default_report;

CHECK
{
    check();
}

# Create an alias so that when fixing, a person can say fix() instead. This
# might only be interesting when the normal CHECK call wasn't called.
*fix = \✓
sub check
{
    if ( $FIX_OPCODES )
    {
        walkallops_filtered( \ &find_unchecked_system_call,
                             \ &queue_fix_opcode );
        fix_opcode( $_ ) for @QUEUED_FIXES_TO_APPLY;
    }
    else
    {
        walkallops_filtered( \ &find_unchecked_system_call,
                             $REPORT_CALLBACK );
    }
    
    if ( $O_PM )
    {
        eval "use O '$O_PM'";
    }

    return 1;
}

sub import
{
    my $class = shift;
    my %p = @_;
    
    # Ethier take a callback from the user via 
    #   use Devel::UncheckedOps ( callback => sub { ... } );
    # or supply a default.
    $REPORT_CALLBACK = $p{'report_callback'}
        if $p{'report'};

    # Allow both `use Devel::UncheckedOps( check => 'print' )` or
    # `use Devel::UncheckedOps( check => [ 'print' ] )`. This is the
    # parameter I most expect people to specify.
    if ( $p{'function'} )
    {
        @CHECK_OPS = $p{'function'};
    }
    elsif ( $p{'functions'} )
    {
        @CHECK_OPS = @{$p{'functions'}};
    }
    
    # This is a boolean value.
    $FIX_OPCODES = !! $p{'fix'};
    if ( $FIX_OPCODES )
    {
        eval q[
               use B::Generate ();
               use Internals ();
               1;
               ]
                   or carp( $@ );
    }
    
    # This is a boolean value. Various guts will be displayed if you pass
    # in a true value. The guts that are displayed are entirely up to my
    # most recent needs.
    $DEBUG = !! $p{'debug'};
    
    # This is passed to `use O '$O_PM'` so the user of this module can say
    # `use Devel::UncheckedOps( O => 'Deparse' )` to see what the
    # code looks like after deparsing. The parameter is any module in the B::
    # namespace that has already been designed to be called by O.pm in this
    # way. This includes Bblock, Bytecode, C, CC, Concise, Debug, Deparse,
    # Showlex, Stackobj, Stash, Terse, Xref or any other module you might
    # get from CPAN like B::Deobfuscate.
    $O_PM = $p{'O'};

    # I seriously doubt that anyone is going to need to specify these. I
    # include this solely for debugging purposes and perhaps the eventual
    # need for it.
    @TERMINAL_OPS = @{$p{'terminal_ops'}}
        if $p{'terminals'};

    return 1;
}

sub find_unchecked_system_call
{
    # This is used by B::Utils::*_filtered to grep for opcodes that need to
    # be reported or fixed.

    my $op = shift;

    # I am going to fix/report this in another function immediately following.
    $OPCODE_NAME = $op->oldname;
    
#     if ( $FIX_OPCODES )
#     {
#         my $addr = $$op;
#         for my $m ( qw( sibling
#                         first
#                         last ) )
#         {
#             my $to = eval { ${ $op->$m } };
#             next unless $to;
            
#             push @{$OPMAP{ $to }}, [ $op, $m ];
#         }
#     }
    
    # B::Utils::opgrep test to decide if this opcode is one that is desirable.
    return ( opgrep( { name => \ @CHECK_OPS,
                       flags => OPf_WANT_VOID },
                     $op )
             or
             opgrep( { name => \ @CHECK_OPS,
                       next => { name => \ @TERMINAL_OPS } },
                     $op ) );
}

sub default_report
{
    # This is the default callback for reporting that something has gone awry.
    # It may be overriden by saying 
    # use Devel::UncheckedOps( report => \ &other_sub );
    carp( "Unchecked $OPCODE_NAME"
          . " call at $B::Utils::file line $B::Utils::line" );
}

sub queue_fix_opcode
{
    # This function puts fixes into a to-do list so that they are only
    # altered when the tree is not being currently walked.
    my $op = shift;
    push @QUEUED_FIXES_TO_APPLY, { op => $op,
                                   file => $B::Utils::file,
                                   line => $B::Utils::line };
    
    return 1;
}

sub fix_opcode
{
    # This function accepts a 'fix' as previously queued by queue_fix_opcode().
    my $fix = shift;
    my $op   = $fix->{'op'};
    my $file = $fix->{'file'};
    my $line = $fix->{'line'};

    printf( __PACKAGE__
            . " FIXING %s at %s line %s\n",
            op_to_text( $op ),
            $file,
            $line )
        if $DEBUG;
    
    # This is the in-memory address of the opcode. It is used
    my $orig_next = $op->next;
    my $orig_sibling = $op->sibling;
    printf( __PACKAGE__
            . " SIBLING %s\n",
            op_to_text( $orig_sibling ) )
        if $DEBUG;


    my $orig_parent = $op->parent;
    printf( __PACKAGE__
            . " PARENT %s\n",
            op_to_text( $orig_parent ) )
        if $DEBUG;
    
    my $orig_reverse_first;
    $orig_reverse_first = $orig_parent
        if ${$orig_parent->first} == $$op;
    printf( __PACKAGE__
            . " PARENT->FIRST %s\n",
            op_to_text( $orig_parent->first ) )
        if $DEBUG;
    
    my $orig_reverse_last;
    $orig_reverse_last = $orig_parent
        if ${$orig_parent->last} == $$op;
    printf( __PACKAGE__
            . " PARENT->LAST %s\n",
            op_to_text( $orig_parent->last ) )
        if $DEBUG;
    
    # Maybe find the opcode that thinks this opcode is its sibling by going
    # to this opcode's parent and walking over the list of siblings until this
    # one is reached. The previously visited opcode is the one we're after.
    my @siblings = $orig_parent->kids;
    my $orig_reverse_sibling = ( grep ${$siblings[$_]->sibling} == $$op,
                                 0 .. $#siblings - 1 )[0];
    $orig_reverse_sibling = $siblings[ $orig_reverse_sibling ]
        if defined $orig_reverse_sibling;
    
    printf( __PACKAGE__
            . " REVERSE SIBLING %s\n",
            op_to_text( $orig_reverse_sibling ) )
        if ( $DEBUG
             and $orig_reverse_sibling
             and ${$orig_reverse_sibling->sibling} == $$op );
    
    # Construct the new program fragment in reverse order so parent nodes
    # can point to child nodes. This alters the original node so it is
    # now inside the new fragment.
    
    # or
    #    ORIGINAL
    #    die
    #       pushmark
    #       gvsv
    
    use Devel::Peek;
    my $gvsv = B::SVOP->new( 'gvsv' => 2, '$!' );
    
    # Now inflate the reference count for *! because this is a sneaky way
    # to take a reference that doesn't inform the variable's refcnt.
    Internals::SetRefCount( \*!, 1 + Internals::GetRefCount( \*! ) );

    my $pushmark = B::OP->new( 'pushmark' => 2 );
    my $die = B::LISTOP->new( 'die' => 5, $pushmark, $gvsv );
    $die->targ( 1 );
    $die->private( 1 );
    my $or_root = B::LOGOP->new( 'or' => 2, $op, $die );
    my $or_op = $or_root->first;
    $or_op->private( 1 );
    
    
    
    # Insert this fragment into the appropriate place in the tree. Every place
    # that the ORIGINAL node was, this new node has to replace it.
    
    # PARENT
    #   ->first( ORIGINAL )
    #   ->last(  ORIGINAL )
    $orig_reverse_first->first( $or_root ) if $orig_reverse_first;
    $orig_reverse_last->last( $or_root ) if $orig_reverse_last;

    # PARENT
    #    KID
    #       ->sibling( ORIGINAL )
    $orig_reverse_sibling->sibling( $or_root ) if $orig_reverse_sibling;
    
    # PARENT
    #    ORIGINAL
    #       ->sibling( KID )
    $or_root->sibling( $orig_sibling ) if $orig_sibling;


    # Now thread the execution order.
    # EXT -> $op
    #     -> OR
    #        -> $orig_next
    #           ...
    #        -> $pushmark
    #           -> gvsv
    #           -> die
    # Insert the OR into the execution
    $op->next( $or_op );
    
    # Continue as normal if $or succeeds
    $or_op->next( $orig_next );
    
    # Otherwise detour and then reroute back to the normal place
    $or_op->other( $pushmark );
    $pushmark->next( $gvsv );
    $gvsv->next( $die );
    $die->next( $orig_next );

    1;
}

sub op_to_text
{
    my $op = shift;
    
    return 'undef' if not defined $op;
    my $class = class $op;
    my $name;
    eval {
        $name = $op->oldname;
        1;
    } or do {
        $name = '';
    };
    
    my $addr = sprintf '(0x%07x)', $$op ;
    
    join( '=',
          grep length(),
          $class, $name, $addr );
}

1;

__END__

=head1 NAME

Devel::UncheckedOps - Perl extension to warp your mind

=head1 SYNOPSIS

  use Devel::UncheckedOps ( functions => [ 'print', 'prtf' ],
                                  fix => 1 );

=head1 DESCRIPTION

This module examines the compiled perl program and either reports or fixes
unchecked system calls. 

=head1 USE PARAMETERS

=over4

=item function => NAME

This parameter specifies a single function name to search for. Do remember
to document %CHECK_DICT which has a big, categorized list of op codes.

 use Devel::UncheckedOps ( function => 'print' );

=item functions => \ @NAMES

This parameter specifies a list of function names to search for. Do remember
to document %CHECK_DICT which has a big, categorized list of op codes.

=item report => \ &CALLBACK

If the program is not fixing then it is reporting. This allows the user to
specify and alternate reporting function. It is passed the opcode that is
in error.

=item fix => BOOLEAN

A boolean value that triggers all the really cool guts so even non-overridable
stuff like print and printf are fixed up.

=item debug => BOOLEAN

A boolean to get some additional information. Generally this is useful when
debugging the operation of the fixing code.

=item O => B:: backend name

Put stuff like 'Deparse', 'Concise', 'Terse', 'Debug', etc. here. This just
arranges to have the program passed to the appropriate B:: backend after it
has been altered. It is like saying -MO=Deparse to a command-line script.

=item terminal_ops => \ @NAMES

Go read the source.

=back

=head1 MOD_PERL?

Mention that everything can be called directly from check() though everything
normally happens during the normal CHECK routine. This may not even be valid
to bring up.

=head1 SEE ALSO

See... what? That request that wished for this?

=head1 AUTHOR

Me.

=head1 COPYRIGHT AND LICENSE

Same as perl, etc,. 

=cut