File Coverage

blib/lib/Macro/Simple.pm

Criterion	Covered	Total	%
statement	89	109	81.6
branch	20	36	55.5
condition	10	24	41.6
subroutine	16	19	84.2
pod	1	1	100.0
total	136	189	71.9

use 5.008003;
use strict;
use warnings;

package Macro::Simple;

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

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

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 = $macros->{$key};
		if ( 'HASH' eq ref $generator and $generator->{is} ) {
			my $code = $generator->{is}->inline_check( '$x' );
			$generator = sub { sprintf 'my $x = %s; %s', $_[0], $code };
		}
		if ( '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, @_ };
		}

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

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

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 qw( refs );
	*{ "$caller\::$subname" } = eval "sub $prototype { $code }";
}

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 sub { }; # will never be called. sigh.
}

1;

__END__