macros.pl

use v5.10;
use strict;
use warnings;

BEGIN {
	package Macro::Simple;
	use Carp;
	use Parse::Keyword {};
	
	sub import
	{
		my $me     = shift;
		my %macros = %{$_[0]};
		my $caller = caller;
		
		for my $key (sort keys %macros)
		{
			my ($subname, $prototype) = ($key =~ m{\A(\w+)(.+)\z});
			my $generator = $macros{$key};
			no strict qw(refs);
			*{"$caller\::$subname"} = sub { 1 }; # XXX: implement this in XS
			Parse::Keyword::install_keyword_handler(
				\&{"$caller\::$subname"},
				sub { $me->_parse($caller, $subname, $prototype, $generator) },
			);
		}
	}
	
	sub _parse
	{
		my $me = shift;
		my ($caller, $subname, $prototype, $generator) = @_;
		
		require PPI;
		my $str    = 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";
			}
		}
		
		lex_read($length);
		lex_stuff(sprintf(' && (%s)', $generator->(@args)));
		sub { };
	}
	
	$INC{'Macro/Simple.pm'} = __FILE__;
};

use Macro::Simple {
	'ISA($;$)' => sub {
		my ($obj, $class) = @_;
		$class ||= '__PACKAGE__';
		require Scalar::Util;
		return sprintf(
			'Scalar::Util::blessed(%s) and %s->isa(%s)',
			$obj,
			$obj,
			$class,
		);
	},
};

my $foo                  = bless [];
my $is_blessed_into_main = ISA($foo, "main");

say $is_blessed_into_main ? "Yes" : "No";