File Coverage

blib/lib/Macro/Simple.pm

Criterion	Covered	Total	%
statement	93	114	81.5
branch	21	36	58.3
condition	10	24	41.6
subroutine	17	20	85.0
pod	2	2	100.0
total	143	196	72.9

use 5.008003;
use strict;
use warnings;

package Macro::Simple;

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.002';

use Carp;

use constant DO_MACRO =>
	( $] ge 5.014000 and require Parse::Keyword and require PPI );
use constant DO_CLEAN =>
	( require namespace::clean );

require XSLoader;
XSLoader::load(__PACKAGE__, $VERSION);

sub import {
	my ( $class, $macros ) = ( shift, @_ );
	my $caller = caller;
	$class->setup_for( $caller, $macros );
}

sub setup_for {
	my ( $class, $caller, $macros ) = ( shift, @_ );

	my $installer = DO_MACRO ? '_setup_using_parse_keyword' : '_setup_fallback';

	for my $key ( sort keys %$macros ) {
		my ( $subname, $prototype ) = ( $key =~ m{\A(\w+)(.+)\z} );
		my $generator = $class->handle_generator( $macros->{$key} );

		$class->$installer( {
			caller    => $caller,
			subname   => $subname,
			prototype => $prototype,
			generator => $generator,
		} );
	}
}

sub handle_generator {
	my ( $class, $generator ) = ( shift, @_ );

	if ( 'HASH' eq ref $generator and $generator->{is} ) {
		my $code = $generator->{is}->inline_check( '$x' );
		$generator = sub { sprintf 'my $x = %s; %s', $_[0], $code };
	}
	elsif ( 'HASH' eq ref $generator and $generator->{assert} ) {
		my $code = $generator->{assert}->inline_assert( '$x' );
		$generator = sub { sprintf 'my $x = %s; %s', $_[0], $code };
	}
	elsif ( not ref $generator ) {
		my $format = $generator;
		$generator = sub { sprintf $format, @_ };
	}

	return $generator;
}

sub _setup_using_parse_keyword {
	my ( $class, $opt ) = ( shift, @_ );
	my ( $caller, $subname ) = @{$opt}{qw/ caller subname /};
	make_truthy("$caller\::$subname");
	no strict qw( refs );
	Parse::Keyword::install_keyword_handler(
		\&{ "$caller\::$subname" },
		sub { $class->_parse( $opt ) },
	);
	$class->_clean( $caller, $subname );
}

sub _setup_fallback {
	my ( $class, $opt ) = ( shift, @_ );
	my ( $caller, $subname, $prototype, $generator ) =
		@{$opt}{qw/ caller subname prototype generator /};
	my $code = $generator->( map "\$_[$_]", 0 .. 100 );
	no strict 'refs';
	*{"$caller\::$subname"} = eval "sub $prototype { $code }";
	$class->_clean( $caller, $subname );
}

sub _clean {
	my ( $class, $caller, $subname ) = ( shift, @_ );
	'namespace::clean'->import( -cleanee => $caller, $subname ) if DO_CLEAN;
}

sub _parse {
	my ( $class, $opt ) = ( shift, @_ );
	my ( $caller, $subname, $prototype, $generator ) =
		@{$opt}{qw/ caller subname prototype generator /};

	require Parse::Keyword;
	require PPI;
	my $str    = Parse::Keyword::lex_peek( 1000 );
	my $ppi    = 'PPI::Document'->new( \$str );
	my $list   = $ppi->find_first( 'Structure::List' );
	my @tokens = $list->find_first( 'Statement::Expression' )->children;
	my $length = 2;

	my @args = undef;
	while ( my $t = shift @tokens ) {
		$length += length( "$t" );

		if ( $t->isa( 'PPI::Token::Operator' ) and $t =~ m{\A(,|\=\>)\z} ) {
			push @args, undef;
		}
		elsif ( defined $args[-1] or not $t->isa( 'PPI::Token::Whitespace' ) ) {
			no warnings qw(uninitialized);
			$args[-1] .= "$t";
		}
	}
	pop @args unless defined $args[-1];

	if ( $prototype =~ /\A\((.+)\)\z/ ) {
		my $i = 0;
		local $_ = $1;
		my $saw_semicolon = 0;
		my $saw_slurpy = 0;
		while ( length ) {
			my $backslashed = 0;
			my $chars = '';

			if ( /\A;/ ) {
				$saw_semicolon++;
				s/\A.//;
				redo;
			}

			if ( /\A\\/ ) {
				$backslashed++;
				s/\A.//;
			}

			if ( /\A\[(.+?)\]/ ) {
				$chars = $1;
				s/\A\[(.+?)\]//;
			}
			else {
				$chars = substr $_, 0, 1;
				s/\A.//;
			}

			if (!$saw_semicolon) {
				$#args >= $i
					or croak "Not enough arguments for macro $subname$prototype";
			}

			my $arg = $args[$i];
			if ( $backslashed and $chars eq '@' ) {
				$arg =~ /\A\s*\@/
					or croak "Expected array for argument $i to macro $subname$prototype; got: $arg";
			}
			elsif ( $backslashed and $chars eq '%' ) {
				$arg =~ /\A\s*\%/
					or croak "Expected hash for argument $i to macro $subname$prototype; got: $arg";
			}
			elsif ( $chars =~ /[@%]/ ) {
				$saw_slurpy++;
			}

			$i++;
		}

		if ( $#args >= $i and !$saw_slurpy ) {
			croak "Too many arguments for macro $subname$prototype";
		}
	}

	Parse::Keyword::lex_read( $length );
	Parse::Keyword::lex_stuff( sprintf ' && do { %s }', $generator->(@args) );
	return \&truthy; # will never be called. sigh.
}

1;

__END__