view release on metacpan or  search on metacpan

lib/macro.pm  view on Meta::CPAN

package macro;

use 5.008_001;

use strict;
use warnings;
use warnings::register;

our $VERSION = '0.06';

use constant DEBUG => $ENV{PERL_MACRO_DEBUG} ? 1 : 0;

use Scalar::Util (); # tainted()
use Carp ();

use PPI::Document ();
use PPI::Lexer ();
my $lexer = PPI::Lexer->new();

use B ();
use B::Deparse ();
my $deparser = B::Deparse->new('-si0', '-x9');

my $backend;

if(DEBUG >= 1 && !$^C){
	require macro::filter;
	$backend = 'macro::filter';
}
else{
	require macro::compiler;
	$backend = 'macro::compiler';
}
sub import{
	my $class = shift;

	return unless @_;

	$backend->import(@_);

	return;
}

sub backend{
	return $backend;
}

sub new :method{
	my($class) = @_;

	return bless {} => $class;
}

sub defmacro :method{
	my $self = shift;

	while(my($name, $macro) = splice @_, 0, 2){
		if( !defined($name) || !defined($macro) ){
			warnings::warnif('Illigal declaration of macro');
			next;
		}
		if(Scalar::Util::tainted($name) || Scalar::Util::tainted($macro)){
			Carp::croak('Insecure dependency in macro::defmacro()');
			return;
		}

		if(exists $self->{$name}){
			warnings::warnif(qq{Macro "$name" redefined});
		}

		my $optimize;
		if(ref($macro) eq 'CODE'){
			$macro = _deparse($macro);
			$optimize = 1;
		}

		my $mdoc = $lexer->lex_source( $self->process($macro) );

		$mdoc->prune(\&_want_useless_element);
		die $@ if $@;

		$self->{$name} = $optimize ? $self->_optimize($mdoc) : $mdoc;
	}

	return;
}

sub _deparse{
	my($coderef) = @_;
	my $cv = B::svref_2object($coderef);

	if(ref($cv->START) eq 'B::NULL'){
		my $subr = sprintf '%s &%s::%s',
			($cv->XSUB ? 'XSUB' : 'undefined subroutine'),
			 $cv->GV->STASH->NAME, $cv->GV->SAFENAME;
		Carp::croak("Cannot use $subr as macro entity");
	}
	else{
		my $src = $deparser->coderef2text($coderef);
		if($src =~ s/\A ( [^\{]+ ) //xms){ # remove prototype and attributes
			my $s = $1;
			if($s =~ /( \( .+ \) )/xms){
				warnings::warnif("Subroutine prototype $1 ignored");
			}
			if($s =~ /(: \s+ \w+)/xms){
				warnings::warnif("Subroutine attribute $1 ignored");
			}
		}
		return 'do' . $src;
	}
}