File Coverage

blib/lib/Hook/Scope.pm

Criterion	Covered	Total	%
statement	34	54	62.9
branch	9	16	56.2
condition	13	21	61.9
subroutine	6	9	66.6
pod	0	2	0.0
total	62	102	60.7

package Hook::Scope;

use 5.008;
use strict;

require Exporter;
require DynaLoader;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
@ISA = qw(Exporter
	DynaLoader);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Hook::Scope ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.

@EXPORT_OK = qw( POST PRE );

@EXPORT = qw();

$VERSION = '0.04';

bootstrap Hook::Scope $VERSION;

sub PRE (&) {
  $_[0]->();
}

sub B::NULL::next { return undef }
sub B::NULL::name { return undef }
use B::Generate;
sub optimizer {
  my $op = shift;
  my $cop;

#  print $op->name . "-" . $cop->name . ":" . $cop->file . ":" . $cop->line . "\n";

  my @scope;
  my @scope_code;
  my $start = $op->first();
  my $previous;
  while($start && ref($start) ne 'B::NULL') {
    if($start->name =~/^enter/ && $start->name ne 'entersub') {
      push @scope, $start;
      push @scope_code, [];
    } elsif($start->name =~/^leave/) {
      pop @scope;
      my $entersubs = pop @scope_code;
      if($entersubs) {
	foreach my $entersub (@$entersubs) {
	  if(ref($start) eq 'B::BINOP') {
	    my $lineseq = $start->last();
	    $entersub->sibling->sibling($lineseq->first());
	    $lineseq->first($entersub);
	    $entersub->sibling->next($start->first->next);
	    $start->first->next($entersub);
	  } else {
	    print $start->first . "- $start\n";
	  }
	}
      }
    }

    $previous = $start if($start->next && ref($start->next) eq 'B::COP');

    if($start->name eq 'refgen' &&
       $start->next && $start->next->name eq 'gv' &&
       $start->next->next && $start->next->next->name eq 'entersub') {
      my $entersub = $start->next->next();
      my $gvop = $start->next();
      my $gv;
      if(ref($gvop) eq 'B::PADOP') {
	#this lives in the threaded
	my $cv = $op->find_cv();
	$gv = (($cv->PADLIST->ARRAY)[1]->ARRAY)[$gvop->padix];
      } else {
	die "No support for non threaded gvs yet\n";
      }
      if($gv->NAME eq 'PRE') {
	my $root_state = $previous->next();
	$previous->sibling($entersub->sibling());
	$previous->next($entersub->next());

	push @{$scope_code[-1]}, $root_state;


      }
    }


#    print scalar @scope . ": " . ($previous ? $previous->name . " -> " : "") . $start->name . "\n";




    $start = $start->next();

  }

=cut
  walkoptree_filtered(
		      $op,
		      sub {
			return 1 if(opgrep(
					   {
					    name => 'refgen',
					    next => {
						     'name' => 'gv',
						     'next' => {
								'name' => 'entersub' }
						    },
					   }, @_)
				   );


			print $_[0]->name() . "\n";

			return 0;
		      },
		      sub {
			my $gvop = $_[0]->next();
			my $gv;
			if(ref($gvop) eq 'B::PADOP') {
			  #this lives in the threaded
			  my $cv = $op->find_cv();
			  $gv = (($cv->PADLIST->ARRAY)[1]->ARRAY)[$gvop->padix];
			} else {
			  die "No support for non threaded gvs yet\n";
			}
			return unless ($gv->NAME eq 'PRE');
			my $entersub = $gvop->next();
			print "FOUND A PRE\n";

		      },
		     );
=cut

}

use optimizer 'sub-detect' => \&optimizer;



1;
__END__