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