summaryrefslogtreecommitdiffstats
path: root/t/fun/lib/Fun.pm
diff options
context:
space:
mode:
authorJesse Luehrs <doy@tozt.net>2013-07-21 16:50:34 -0400
committerJesse Luehrs <doy@tozt.net>2013-07-21 16:50:34 -0400
commit597610ad1c915a5b004148fdb3151b0cec976790 (patch)
tree9e3e002a3b536ea943d73b51c8318d08f3f6ecb9 /t/fun/lib/Fun.pm
parent336e491e532144d1c8a6e367409149e8d084fa1d (diff)
downloadparse-keyword-597610ad1c915a5b004148fdb3151b0cec976790.tar.gz
parse-keyword-597610ad1c915a5b004148fdb3151b0cec976790.zip
add tests for Fun
Diffstat (limited to 't/fun/lib/Fun.pm')
-rw-r--r--t/fun/lib/Fun.pm157
1 files changed, 157 insertions, 0 deletions
diff --git a/t/fun/lib/Fun.pm b/t/fun/lib/Fun.pm
new file mode 100644
index 0000000..57bea91
--- /dev/null
+++ b/t/fun/lib/Fun.pm
@@ -0,0 +1,157 @@
+package Fun;
+use strict;
+use warnings;
+
+use Parse::Keyword { fun => \&fun_parser };
+use Sub::Name 'subname';
+
+use Exporter 'import';
+
+our @EXPORT = 'fun';
+
+# XXX this isn't quite right, i think, but probably close enough for now?
+my $start_rx = qr/^[\p{ID_Start}_]$/;
+my $cont_rx = qr/^\p{ID_Continue}$/;
+
+sub fun { @_ ? $_[0] : () }
+
+sub fun_parser {
+ my ($name, $prototype, $body);
+
+ lex_read_space;
+
+ if (lex_peek =~ /$start_rx|^:$/) {
+ $name = parse_name(1);
+ }
+
+ lex_read_space;
+
+ if (lex_peek eq '(') {
+ $prototype = parse_prototype();
+ }
+
+ lex_read_space;
+
+ if (lex_peek eq '{') {
+ local $Fun::{'DEFAULTS::'};
+ if ($prototype) {
+ lex_read;
+
+ my $preamble = '{';
+
+ my @names = map { $_->{name} } @$prototype;
+ $preamble .= 'my (' . join(', ', @names) . ') = @_;';
+
+ my $index = 1;
+ for my $var (grep { defined $_->{default} } @$prototype) {
+ {
+ no strict 'refs';
+ *{ 'Fun::DEFAULTS::default_' . $index } = sub () {
+ $var->{default}
+ };
+ }
+ $preamble .= $var->{name} . ' = Fun::DEFAULTS::default_' . $index . '->()' . ' unless @_ > ' . $var->{index} . ';';
+ $index++;
+ }
+
+ lex_stuff($preamble);
+ }
+ $body = parse_block;
+ }
+ else {
+ die "syntax error";
+ }
+
+ if (defined $name) {
+ my $full_name = join('::', compiling_package, $name);
+ {
+ no strict 'refs';
+ *$full_name = subname $full_name, $body;
+ }
+ return (sub {}, 1);
+ }
+ else {
+ return (sub { $body }, 0);
+ }
+}
+
+sub parse_name {
+ my ($allow_package) = @_;
+ my $name = '';
+
+ my $char_rx = $start_rx;
+
+ while (1) {
+ my $char = lex_peek;
+ last unless length $char;
+ if ($char =~ $char_rx) {
+ $name .= $char;
+ lex_read(1);
+ $char_rx = $cont_rx;
+ }
+ elsif ($allow_package && $char eq ':') {
+ die "syntax error" unless lex_peek(3) =~ /^::(?:[^:]|$)/;
+ $name .= '::';
+ lex_read(2);
+ }
+ else {
+ last;
+ }
+ }
+
+ return length($name) ? $name : undef;
+}
+
+sub parse_prototype {
+ die "syntax error" unless lex_peek eq '(';
+ lex_read;
+ lex_read_space;
+
+ if (lex_peek eq ')') {
+ lex_read;
+ return;
+ }
+
+ my $seen_slurpy;
+ my @vars;
+ while ((my $sigil = lex_peek) ne ')') {
+ my $var = {};
+ die "syntax error"
+ unless $sigil eq '$' || $sigil eq '@' || $sigil eq '%';
+ die "Can't declare parameters after a slurpy parameter"
+ if $seen_slurpy;
+
+ $seen_slurpy = 1 if $sigil eq '@' || $sigil eq '%';
+
+ lex_read;
+ lex_read_space;
+ my $name = parse_name(0);
+ lex_read_space;
+
+ $var->{name} = "$sigil$name";
+
+ if (lex_peek eq '=') {
+ lex_read;
+ lex_read_space;
+ $var->{default} = parse_arithexpr;
+ }
+
+ $var->{index} = @vars;
+
+ push @vars, $var;
+
+ die "syntax error"
+ unless lex_peek eq ')' || lex_peek eq ',';
+
+ if (lex_peek eq ',') {
+ lex_read;
+ lex_read_space;
+ }
+ }
+
+ lex_read;
+
+ return \@vars;
+}
+
+1;