Skip to content

Instantly share code, notes, and snippets.

@tobyink tobyink/macros.pl
Created Apr 1, 2014

Embed
What would you like to do?
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";
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.