support for blocks, and some methods that can use them
authorTony Cook <tony@develop-help.com>
Wed, 17 Sep 2014 09:49:11 +0000 (19:49 +1000)
committerTony Cook <tony@develop-help.com>
Wed, 17 Sep 2014 09:49:11 +0000 (19:49 +1000)
site/cgi-bin/modules/Squirrel/Template/Expr.pm
site/cgi-bin/modules/Squirrel/Template/Expr/WrapArray.pm
site/cgi-bin/modules/Squirrel/Template/Expr/WrapBase.pm
t/020-templater/040-original.t

index fdc3875..e66d92e 100644 (file)
@@ -1,7 +1,7 @@
 package Squirrel::Template::Expr;
 use strict;
 
-our $VERSION = "1.014";
+our $VERSION = "1.015";
 
 package Squirrel::Template::Expr::Eval;
 use Scalar::Util ();
@@ -30,18 +30,18 @@ sub _wrapped {
     else {
       my $type = Scalar::Util::reftype($val);
       if ($type eq "ARRAY") {
-       return Squirrel::Template::Expr::WrapArray->new($val, $self->[TMPL]);
+       return Squirrel::Template::Expr::WrapArray->new($val, $self->[TMPL], undef, $self);
       }
       elsif ($type eq "HASH") {
-       return Squirrel::Template::Expr::WrapHash->new($val, $self->[TMPL]);
+       return Squirrel::Template::Expr::WrapHash->new($val, $self->[TMPL], undef, $self);
       }
       elsif ($type eq "CODE") {
-       return Squirrel::Template::Expr::WrapCode->new($val, $self->[TMPL]);
+       return Squirrel::Template::Expr::WrapCode->new($val, $self->[TMPL], undef, $self);
       }
     }
   }
   else {
-    return Squirrel::Template::Expr::WrapScalar->new($val, $self->[TMPL], $self->[ACTS]);
+    return Squirrel::Template::Expr::WrapScalar->new($val, $self->[TMPL], $self->[ACTS], $self);
   }
 }
 
@@ -102,6 +102,10 @@ sub _process_le {
   return $_[0]->process($_[1][1]) le $_[0]->process($_[1][2]);
 }
 
+sub _process_cmp {
+  return $_[0]->process($_[1][1]) cmp $_[0]->process($_[1][2]);
+}
+
 # number relops
 sub _process_neq {
   return $_[0]->process($_[1][1]) == $_[0]->process($_[1][2]);
@@ -139,6 +143,10 @@ sub _process_cond {
   return $_[0]->process($_[1][1]) ? $_[0]->process($_[1][2]) : $_[0]->process($_[1][3]);
 }
 
+sub _process_ncmp {
+  return $_[0]->process($_[1][1]) <=> $_[0]->process($_[1][2]);
+}
+
 sub _process_uminus {
   return - ($_[0]->process($_[1][1]));
 }
@@ -151,6 +159,10 @@ sub _process_const {
   return $_[1][1];
 }
 
+sub _process_block {
+  return bless [ $_[1][1], $_[1][2] ], "Squirrel::Template::Expr::Block";
+}
+
 sub _do_call {
   my ($self, $val, $args, $method, $ctx) = @_;
 
@@ -195,21 +207,49 @@ sub _process_callvar {
   return $self->_do_call($val, $args, $method, $ctx);
 }
 
-sub _process_funccall {
-  my ($self, $node, $ctx) = @_;
+sub _do_callblock {
+  my ($self, $ids, $exprs, $args) = @_;
+
+  my $result;
+  my %args;
+  @args{@$ids} = @$args;
+  $args{_arguments} = $args;
+  if (eval { $self->[TMPL]->start_scope("calling block", \%args), 1}) {
+    for my $expr (@$exprs) {
+      $result = $self->process($expr);
+    }
+    $self->[TMPL]->end_scope();
+  }
+
+  return $result;
+}
+
+sub call_function {
+  my ($self, $code, $args, $ctx) = @_;
 
   $ctx ||= "";
-  my $code = $self->process($node->[1]);
-  my $args = $self->process_list($node->[2]);
 
   if (Scalar::Util::reftype($code) eq "CODE") {
     return $ctx eq "LIST" ? $code->(@$args) : scalar($code->(@$args));
   }
+  elsif (Scalar::Util::blessed($code)
+        && $code->isa("Squirrel::Template::Expr::Block")) {
+    return $self->_do_callblock($code->[0], $code->[1], $args);
+  }
   else {
     die [ error => "can't call non code as a function" ];
   }
 }
 
+sub _process_funccall {
+  my ($self, $node, $ctx) = @_;
+
+  my $code = $self->process($node->[1]);
+  my $args = $self->process_list($node->[2]);
+
+  return $self->call_function($code, $args, $ctx);
+}
+
 sub _process_list {
   my ($self, $node) = @_;
 
@@ -333,6 +373,7 @@ my %ops =
    "opgt" => "gt",
    "ople" => "le",
    "opge" => "ge",
+   "opcmp" => "cmp",
 
    "op==" => "neq",
    "op!=" => "nne",
@@ -342,6 +383,7 @@ my %ops =
    "op>=" => "nge",
    'op=~' => "match",
    'op!~' => "notmatch",
+   'op<=>' => 'ncmp',
   );
 
 sub _parse_cond {
@@ -388,7 +430,7 @@ sub _parse_and {
   return $result;
 }
 
-my %relops = map {; "op$_" => 1 } qw(eq ne gt lt ge le == != < > >= <= =~ !~);
+my %relops = map {; "op$_" => 1 } qw(eq ne gt lt ge le cmp == != < > >= <= <=> =~ !~);
 
 sub _parse_rel {
   my ($self, $tok) = @_;
@@ -607,6 +649,44 @@ sub _parse_primary {
   elsif ($t->[0] eq 'undef') {
     return [ "undef" ];
   }
+  elsif ($t->[0] eq 'blockstart') {
+    # @{ idlist: expr; ... }
+    # idlist can be empty:
+    # @{ : expr; ... }
+    # the expr list will become more complex at some point
+    my @ids;
+    my $nexttype = $tok->peektype;
+    if ($nexttype ne 'op:') {
+      $nexttype eq 'id'
+       or die [ error => "Expected id or : after \@{ but found $nexttype->[0]" ];
+      push @ids, $tok->get->[2];
+      while ($tok->peektype eq 'op,') {
+       $tok->get;
+       $tok->peektype eq 'id'
+         or die [ error => "Expected id after , in \@{ but found $nexttype->[0]" ];
+       push @ids, $tok->get->[2];
+      }
+      my $end = $tok->get;
+      $end->[0] eq 'op:'
+       or die [ error => "Expected :  or , in identifier list in \@{ but found $end->[0]" ];
+    }
+    else {
+      # consume the :
+      $tok->get;
+    }
+    my @exprs;
+    push @exprs, $self->_parse_expr($tok);
+    while ($tok->peektype eq 'op;') {
+      $tok->get;
+      push @exprs, $self->_parse_expr($tok);
+    }
+    $nexttype = $tok->peektype;
+    $nexttype eq 'op}'
+      or die [ error => "Expected } at end of \@{ but found $nexttype" ];
+    # consume the }
+    $tok->get;
+    return [ block => \@ids, \@exprs ];
+  }
   else {
     die [ error => "Expected term but got $t->[0]" ];
   }
@@ -696,7 +776,7 @@ sub get {
         $self->[TEXT] =~ s!\A(\s*/((?:[^/\\]|\\.)+)/([ismx]*\s)?\s*)!!) {
     push @$queue, [ re => $1, $2, $3 || "" ];
   }
-  elsif ($self->[TEXT] =~ s/\A(\s*(not\b|eq\b|ne\b|le\b|lt\b|ge\b|gt\b|<=|>=|[!=]\=|\=\~|!~|[_\?:,\[\]\(\)<>=!.*\/+\{\};\$-])\s*)//) {
+  elsif ($self->[TEXT] =~ s/\A(\s*(not\b|eq\b|ne\b|le\b|lt\b|ge\b|gt\b|cmp\b|<=>|<=|>=|[!=]\=|\=\~|!~|[_\?:,\[\]\(\)<>=!.*\/+\{\};\$-])\s*)//) {
     push @$queue, [ "op$2" => $1 ];
   }
   elsif ($self->[TEXT] =~ s/\A(\s*([A-Za-z_][a-zA-Z_0-9]*)\s*)//) {
@@ -713,6 +793,9 @@ sub get {
   elsif ($self->[TEXT] =~ s/\A(\s*\@undef\bs*)//) {
     push @$queue, [ undef => $1 ];
   }
+  elsif ($self->[TEXT] =~ s/\A(\s*@\{\s*)//) {
+    push @$queue, [ blockstart => $1 ];
+  }
   else {
     die [ error => "Unknown token '$self->[TEXT]'" ];
   }
@@ -944,6 +1027,14 @@ binary - C<0b1100100>
 
 an undefined value - C<@undef>
 
+=item *
+
+blocks - C<< @{ I<idlist> : I<exprlist> } >> where C<< I<idlist> >> is
+a comma separated list of local variables that arguments are assigned
+to, and I<exprlist> is a semi-colon separated list of expressions.
+The block literal can be called as if it's a function, or supplied to
+methods like the array grep() method.
+
 =back
 
 Strings can be either " or ' delimited.
index 3b3f9df..ca638d3 100644 (file)
@@ -4,7 +4,7 @@ use base qw(Squirrel::Template::Expr::WrapBase);
 use Scalar::Util ();
 use List::Util ();
 
-our $VERSION = "1.008";
+our $VERSION = "1.009";
 
 my $list_make_key = sub {
   my ($item, $field) = @_;
@@ -36,13 +36,24 @@ sub _do_sort {
     return [ sort @{$self->[0]} ];
   }
   elsif (@$args == 1) {
-    my $key = $args->[0];
-    return 
-      [
-       sort {
-        $list_make_key->($a, $key) cmp $list_make_key->($b, $key)
-       } @{$self->[0]}
-      ];
+    if (ref $args->[0]) {
+      my $eval = $self->expreval;
+      return
+       [
+        sort {
+          $eval->call_function($args->[0], [ $a, $b ])
+        } @{$self->[0]}
+       ];
+    }
+    else {
+      my $key = $args->[0];
+      return 
+       [
+        sort {
+          $list_make_key->($a, $key) cmp $list_make_key->($b, $key)
+        } @{$self->[0]}
+       ];
+    }
   }
   else {
     die [ error => "list.sort takes 0 or 1 parameters" ];
@@ -182,6 +193,28 @@ sub _do_as_hash {
   return +{ @{$self->[0]}, @extra };
 }
 
+sub _do_grep {
+  my ($self, $args) = @_;
+
+  my $eval = $self->expreval;
+  return
+    [
+     grep $eval->call_function($args->[0], [ $_ ]),
+     @{$self->[0]}
+    ];
+}
+
+sub _do_map {
+  my ($self, $args) = @_;
+
+  my $eval = $self->expreval;
+  return
+    [
+     map $eval->call_function($args->[0], [ $_ ]),
+     @{$self->[0]}
+    ];
+}
+
 sub call {
   my ($self, $method, $args) = @_;
 
@@ -211,11 +244,13 @@ Squirrel::Template::Expr::WrapArray - provide virtual methods for arrays
   last = somearray.last
   first = somearray.first
   first = somearray.shift # modifies somearray
-  somearray.push(avalue);
+  somearray.push(avalue)
   last = somearray.pop # modifies somearray
-  somearray.unshift(avalue);
+  somearray.unshift(avalue)
   somearray.is_list # always true
   somearray.is_hash # always false
+  odd = somearray.grep(@{a: a mod 2 == 0 })
+  doubled = somearray.map(@{a: a * 2 })
 
 =head1 DESCRIPTION
 
@@ -230,14 +265,18 @@ references) in L<Squirrel::Template>'s expression language.
 
 The number of elements in the list.
 
-=item sorted()
+=item sort()
 
 The elements sorted by name.
 
-=item sorted(fieldname)
+=item sort(fieldname)
 
 The elements sorted as objects calling C<fieldname>.
 
+=item sort(block)
+
+The elem
+
 =item reversed
 
 The elements in reverse order.
@@ -282,6 +321,16 @@ Return a new array with any contained arrays expanded one level.
 
   [ [ [ 1 ], 2 ], 3 ].expand => [ [ 1 ], 2, 3 ]
 
+=item grep(block)
+
+Return a new list containing only those elements that C<block> returns
+true for.
+
+=item map(block)
+
+Return the list of return values from C<block> as applied to each
+element.
+
 =item set(index, value)
 
 Set the specified I<index> in the array to I<value>.  Returns
index e5d9bd4..a4a884a 100644 (file)
@@ -1,11 +1,15 @@
 package Squirrel::Template::Expr::WrapBase;
 use strict;
-our $VERSION = "1.001";
+our $VERSION = "1.002";
 
 sub new {
-  my ($class, $item, $templater, $acts) = @_;
+  my ($class, $item, $templater, $acts, $eval) = @_;
 
-  return bless [ $item, $templater, $acts ], $class;
+  return bless [ $item, $templater, $acts, $eval ], $class;
+}
+
+sub expreval {
+  $_[0][3];
 }
 
 1;
index e1a73a8..07c58e2 100644 (file)
@@ -1,7 +1,7 @@
 #!perl -w
 # Basic tests for Squirrel::Template
 use strict;
-use Test::More tests => 189;
+use Test::More tests => 198;
 use HTML::Entities;
 
 sub template_test($$$$;$$);
@@ -517,10 +517,14 @@ OUT
      [ 'num1 <= 101', 1 ],
      [ 'num1 <= 100', '' ],
      [ 'num1 <= 102', '1' ],
+     [ 'num1 <=> 102', '-1' ],
+     [ 'num1 <=> 101', '0' ],
      [ 'str eq "ABC"', '1' ],
      [ 'str eq "AB"', '' ],
      [ 'str ne "AB"', '1' ],
      [ 'str ne "ABC"', '' ],
+     [ 'str cmp "ABC"', 0 ],
+     [ 'str cmp "AB"', 1 ],
      [ 'str.lower', 'abc' ],
      [ 'somelist.size', 6 ],
      [ '[ 4, 2, 3 ].first', 4 ],
@@ -542,6 +546,9 @@ OUT
      [ '[ 1, 2, 3 ][1]', 2 ],
      [ 'testclass.foo', "[TestClass.foo]" ],
      [ '@undef.defined', "" ],
+     [ '(@{: "abc" })()', "abc" ],
+     [ '(@{a,b: a+b})(12, 13)', '25' ],
+     [ '(@{a,b: a; b; a-b })(10, 5)', '5' ],
 
      # WrapScalar
      [ '"foo".length', 3 ],
@@ -605,6 +612,8 @@ OUT
      [ '[ 1, 2 ].is_hash', 0 ],
      [ '[ 1 .. 5 ].shuffle.size', 5 ],
      [ '([ "a", 1, "b", "2" ].as_hash)["a"]', 1 ],
+     [ '[ 1 .. 5].grep(@{a: a mod 2 == 0 }).join(",")', '2,4' ],
+     [ '[ { a: 3 }, { a: 1 }, { a: 2 } ].sort(@{a,b: b.a <=> a.a }).map(@{a: a.a}).join("")', '321' ],
 
      # WrapHash
      [ '{ "foo": 1 }.is_list', 0 ],