File Coverage

blib/lib/B/XSUB/Dumber.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

#!/usr/bin/perl

package B::XSUB::Dumber;

use strict;
use warnings;

use Carp qw(croak);
use B qw(svref_2object class);
use B::Generate;
use Scalar::Util qw(reftype);
use XSLoader;

our $VERSION = '0.01';

XSLoader::load __PACKAGE__, $VERSION;

use base qw(B::OPCheck);

sub null {
    my $op = shift;
    return class($op) eq "NULL";
}

sub import {
	my ( $class, @subs ) = @_;

	my $xsubs = $^H{$class} || do {
		my %xsubs;
		use B::Utils;
		$class->SUPER::import(entersub => check => sub {
			my $op = shift;

			# FIXME only if !hasargs

			return unless null $op->first->sibling; # method

			my $kid = $op->first;
			$kid = $kid->first->sibling; # skip ex-list, pushmark
			while ( not null $kid->sibling ) {
				$kid = $kid->sibling;
			}

			my $cvop = $kid->first;

			if ($cvop->name eq "gv") {
				my $gv = $cvop->gv;
				my $cv = $gv->CV;
				if ( my $xsub = $cv->XSUB ) {
					if ( $xsubs{$xsub} ) {
						$op->ppaddr(simple_xsub_ppaddr());
						#$op->ppaddr($xsub); # not possible, it's not a PP (returns an OP*)
					}
				}
			}
		});

		\%xsubs;
	};

	foreach my $sub ( @subs ) {
		my $ref;

		unless ( ref($sub) ) {
			$ref = eval 'package ' . caller(). '; no strict "refs"; \&{$sub}';
			warn $@ if $@;
		} elsif ( reftype($sub) eq 'CODE' ) {
			$ref = $sub;
		}

		unless ( ref($ref) && reftype($ref) eq 'CODE' ) {
			croak "Must supply a sub name or a code reference to an XSUB";
		}

		my $xsub = svref_2object($ref)->XSUB;

		unless ( $xsub ) {
			croak "$sub is not an XSUB";
		}

		$xsubs->{$xsub}++;
	}
}

sub unimport {
	my $class = shift;
	$class->SUPER::unimport(); # FIXME only call if really everything is removed, and with the right opname and callback sub
}

__PACKAGE__

__END__