template re-work: split wrappers out of Expr.pm
authorTony Cook <tony@develop-help.com>
Sat, 31 Mar 2012 04:30:28 +0000 (15:30 +1100)
committerTony Cook <tony@develop-help.com>
Fri, 20 Apr 2012 01:05:13 +0000 (11:05 +1000)
MANIFEST
site/cgi-bin/modules/Squirrel/Template/Expr.pm
site/cgi-bin/modules/Squirrel/Template/Expr/WrapArray.pm [new file with mode: 0644]
site/cgi-bin/modules/Squirrel/Template/Expr/WrapBase.pm [new file with mode: 0644]
site/cgi-bin/modules/Squirrel/Template/Expr/WrapClass.pm [new file with mode: 0644]
site/cgi-bin/modules/Squirrel/Template/Expr/WrapCode.pm [new file with mode: 0644]
site/cgi-bin/modules/Squirrel/Template/Expr/WrapHash.pm [new file with mode: 0644]
site/cgi-bin/modules/Squirrel/Template/Expr/WrapScalar.pm [new file with mode: 0644]

index 35463e5..0f9854a 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -330,6 +330,13 @@ site/cgi-bin/modules/Squirrel/Table.pm
 site/cgi-bin/modules/Squirrel/Template.pm
 site/cgi-bin/modules/Squirrel/Template/Constants.pm
 site/cgi-bin/modules/Squirrel/Template/Deparser.pm
+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
+site/cgi-bin/modules/Squirrel/Template/Expr/WrapClass.pm
+site/cgi-bin/modules/Squirrel/Template/Expr/WrapCode.pm
+site/cgi-bin/modules/Squirrel/Template/Expr/WrapHash.pm
+site/cgi-bin/modules/Squirrel/Template/Expr/WrapScalar.pm
 site/cgi-bin/modules/Squirrel/Template/Parser.pm
 site/cgi-bin/modules/Squirrel/Template/Processor.pm
 site/cgi-bin/modules/Squirrel/Template/Tokenizer.pm
index 5e1b7d6..fd972dd 100644 (file)
@@ -635,220 +635,4 @@ sub _vianame {
   return chr($code);
 }
 
-package Squirrel::Template::Expr::WrapBase;
-
-sub new {
-  my ($class, $item) = @_;
-
-  return bless [ $item ], $class;
-}
-
-{
-  package Squirrel::Template::Expr::WrapScalar;
-  our @ISA = qw(Squirrel::Template::Expr::WrapBase);
-
-  my %methods =
-    (
-     length => sub {
-       my ($item, $args) = @_;
-
-       @$args == 0
-        or die [ error => "scalar.length takes no parameters" ];
-
-       return length $item;
-     },
-     upper => sub {
-       my ($item, $args) = @_;
-
-       @$args == 0
-        or die [ error => "scalar.upper takes no parameters" ];
-
-       return uc $item;
-     },
-     lower => sub {
-       my ($item, $args) = @_;
-
-       @$args == 0
-        or die [ error => "scalar.lower takes no parameters" ];
-
-       return lc $item;
-     },
-     defined => sub {
-       my ($item, $args) = @_;
-
-       @$args == 0
-        or die [ error => "scalar.defined takes no parameters" ];
-
-       return defined $item;
-     },
-     trim => sub {
-       my ($item, $args) = @_;
-
-       @$args == 0
-        or die [ error => "scalar.defined takes no parameters" ];
-
-       $item =~ s/\A\s+//;
-       $item =~ s/\s+\z//;
-
-       return $item;
-     },
-     split => sub {
-       my ($item, $args) = @_;
-
-       my $split = @$args ? $args->[0] : " ";
-       my $limit = @$args >= 2 ? $args->[1] : 0;
-
-       return [ split $split, $item, $limit ];
-     },
-    );
-
-  sub call {
-    my ($self, $method, $args) = @_;
-
-    if ($methods{$method}) {
-      return $methods{$method}->($self->[0], $args);
-    }
-    die [ error => "No method $method for scalars" ];
-  }
-}
-
-{
-  package Squirrel::Template::Expr::WrapCode;
-  our @ISA = qw(Squirrel::Template::Expr::WrapBase);
-
-  sub call {
-    my ($self, $method, $args) = @_;
-
-    return $self->[0]->($method, @$args);
-  }
-}
-
-{
-  package Squirrel::Template::Expr::WrapArray;
-  our @ISA = qw(Squirrel::Template::Expr::WrapBase);
-
-  my $list_make_key = sub {
-    my ($item, $field) = @_;
-
-    if (Scalar::Util::blessed($item)) {
-      return $item->can($field) ? $item->$field() : "";
-    }
-    else {
-      return exists $item->{$field} ? $item->{$field} : "";
-    }
-  };
-
-  my %methods =
-    (
-     size => sub {
-       my ($item, $args) = @_;
-
-       @$args == 0
-        or die [ error => "list.size takes no parameters" ];
-
-       return scalar @$item;
-     },
-     sort => sub {
-       my ($item, $args) = @_;
-
-       @$item <= 1
-        and return [ @$item ]; # nothing to sort
-
-       if (@$args == 0) {
-        return [ sort @$item ];
-       }
-       elsif (@$args == 1) {
-        my $key = $args->[0];
-        return sort {
-          $list_make_key->($a, $key) cmp $list_make_key->($b, $key)
-        } @$item;
-       }
-       else {
-        die [ error => "list.sort takes 0 or 1 parameters" ];
-       }
-     },
-     reverse => sub {
-       my ($item, $args) = @_;
-
-       @$args == 0
-        or die [ error => "list.reverse takes no parameters" ];
-
-       return [ reverse @$item ];
-     },
-     join => sub {
-       my ($item, $args) = @_;
-
-       my $join = @$args ? $args->[0] : "";
-
-       return join($join, @$item);
-     },
-     last => sub {
-       my ($item, $args) = @_;
-
-       @$args == 0
-        or die [ error => "list.last takes no parameters" ];
-
-       return @$item ? $item->[-1] : ();
-     },
-     first => sub {
-       my ($item, $args) = @_;
-
-       @$args == 0
-        or die [ error => "list.first takes no parameters" ];
-
-       return @$item ? $item->[0] : ();
-     },
-    );
-
-  sub call {
-    my ($self, $method, $args) = @_;
-
-    if ($methods{$method}) {
-      return $methods{$method}->($self->[0], $args);
-    }
-    die [ error => "Unknown method $method for lists" ];
-  }
-}
-
-{
-  package Squirrel::Template::Expr::WrapHash;
-  our @ISA = qw(Squirrel::Template::Expr::WrapBase);
-
-  my %methods =
-    (
-     size => sub {
-       my ($item) = @_;
-       return scalar keys %$item;
-     },
-     keys => sub {
-       my ($item) = @_;
-
-       return [ keys %$item ];
-     },
-     values => sub {
-       my ($item) = @_;
-
-       return [ values %$item ];
-     },
-     list => sub {
-       my ($item) = @_;
-
-       return [ map {; key => $_, value => $item->{$_} } sort keys %$item ];
-     },
-    );
-
-  sub call {
-    my ($self, $method, $args) = @_;
-
-    if ($methods{$method}) {
-      return $methods{$method}->($self->[0], $args);
-    }
-    elsif (exists $self->[0]{$method}) {
-      return $self->[0]{$method};
-    }
-
-    die [ error => "Unknown method $method for hashes" ];
-  }
-}
-
 1;
diff --git a/site/cgi-bin/modules/Squirrel/Template/Expr/WrapArray.pm b/site/cgi-bin/modules/Squirrel/Template/Expr/WrapArray.pm
new file mode 100644 (file)
index 0000000..159bf4d
--- /dev/null
@@ -0,0 +1,112 @@
+package Squirrel::Template::Expr::WrapArray;
+use strict;
+use base qw(Squirrel::Template::Expr::WrapBase);
+use Scalar::Util ();
+
+my $list_make_key = sub {
+  my ($item, $field) = @_;
+
+  if (Scalar::Util::blessed($item)) {
+    return $item->can($field) ? $item->$field() : "";
+  }
+  else {
+    return exists $item->{$field} ? $item->{$field} : "";
+  }
+};
+
+sub _do_size {
+  my ($self, $args) = @_;
+
+  @$args == 0
+    or die [ error => "list.size takes no parameters" ];
+
+  return scalar @{$self->[0]};
+}
+
+sub _do_sort {
+  my ($self, $args) = @_;
+
+  @{$self->[0]} <= 1
+    and return [ @{$self->[0]} ]; # nothing to sort
+
+  if (@$args == 0) {
+    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]}
+      ];
+  }
+  else {
+    die [ error => "list.sort takes 0 or 1 parameters" ];
+  }
+}
+
+sub _do_reverse {
+  my ($self, $args) = @_;
+
+  @$args == 0
+    or die [ error => "list.reverse takes no parameters" ];
+
+  return [ reverse @{$self->[0]} ];
+}
+
+sub _do_join {
+  my ($self, $args) = @_;
+
+  my $join = @$args ? $args->[0] : "";
+
+  return join($join, @{$self->[0]});
+}
+
+sub _do_last {
+  my ($self, $args) = @_;
+
+  @$args == 0
+    or die [ error => "list.last takes no parameters" ];
+
+  return @{$self->[0]} ? $self->[0][-1] : ();
+}
+
+sub _do_first {
+  my ($self, $args) = @_;
+
+  @$args == 0
+    or die [ error => "list.first takes no parameters" ];
+
+  return @{$self->[0]} ? $self->[0][0] : ();
+}
+
+sub _do_shift {
+  my ($self, $args) = @_;
+
+  @$args == 0
+    or die [ error => "list.shift takes no parameters" ];
+
+  return shift @{$self->[0]};
+}
+
+sub _do_pop {
+  my ($self, $args) = @_;
+
+  @$args == 0
+    or die [ error => "list.pop takes no parameters" ];
+
+  return pop @{$self->[0]};
+}
+
+sub call {
+  my ($self, $method, $args) = @_;
+
+  my $real_method = "_do_$method";
+  if ($self->can($real_method)) {
+    return $self->$real_method($args);
+  }
+  die [ error => "Unknown method $method for lists" ];
+}
+
+1;
diff --git a/site/cgi-bin/modules/Squirrel/Template/Expr/WrapBase.pm b/site/cgi-bin/modules/Squirrel/Template/Expr/WrapBase.pm
new file mode 100644 (file)
index 0000000..187864c
--- /dev/null
@@ -0,0 +1,11 @@
+package Squirrel::Template::Expr::WrapBase;
+use strict;
+our $VERSION = "1.000";
+
+sub new {
+  my ($class, $item) = @_;
+
+  return bless [ $item ], $class;
+}
+
+1;
diff --git a/site/cgi-bin/modules/Squirrel/Template/Expr/WrapClass.pm b/site/cgi-bin/modules/Squirrel/Template/Expr/WrapClass.pm
new file mode 100644 (file)
index 0000000..7bdd976
--- /dev/null
@@ -0,0 +1,20 @@
+package Squirrel::Template::Expr::WrapClass;
+use strict;
+use base qw(Squirrel::Template::Expr::WrapBase);
+
+sub call {
+  my ($self, $method, $args, $ctx) = @_;
+  if ($self->[0]->can("restricted_method")) {
+    $self->[0]->restricted_method($method)
+      and die [ error => "method $method is restricted" ];
+  }
+
+  $self->[0]->can($method)
+    or die [ error => "No such method $method" ];
+
+  return $ctx eq 'LIST' ? $self->[0]->$method(@$args)
+    : scalar $self->[0]->$method(@$args);
+}
+
+1;
+
diff --git a/site/cgi-bin/modules/Squirrel/Template/Expr/WrapCode.pm b/site/cgi-bin/modules/Squirrel/Template/Expr/WrapCode.pm
new file mode 100644 (file)
index 0000000..7b6368e
--- /dev/null
@@ -0,0 +1,13 @@
+package Squirrel::Template::Expr::WrapCode;
+use strict;
+use base qw(Squirrel::Template::Expr::WrapBase);
+
+our $VERSION = "1.000";
+
+sub call {
+  my ($self, $method, $args) = @_;
+
+  return $self->[0]->($method, @$args);
+}
+
+1;
diff --git a/site/cgi-bin/modules/Squirrel/Template/Expr/WrapHash.pm b/site/cgi-bin/modules/Squirrel/Template/Expr/WrapHash.pm
new file mode 100644 (file)
index 0000000..c6035d8
--- /dev/null
@@ -0,0 +1,75 @@
+package Squirrel::Template::Expr::WrapHash;
+use strict;
+use base qw(Squirrel::Template::Expr::WrapBase);
+
+our $VERSION = "1.000";
+
+sub _do_size {
+  my ($self) = @_;
+
+  return scalar keys %{$self->[0]};
+}
+
+sub _do_keys {
+  my ($self) = @_;
+
+  return [ keys %{$self->[0]} ];
+}
+
+sub _do_values {
+  my ($self) = @_;
+
+  return [ values %{$self->[0]} ];
+}
+
+sub _do_list {
+  my ($self) = @_;
+
+  my $item = $self->[0];
+  return [ map {; key => $_, value => $item->{$_} } sort keys %$item ];
+}
+
+sub _do_delete {
+  my ($self, $args) = @_;
+
+  return delete @{$self->[0]}{@$args};
+}
+
+sub call {
+  my ($self, $method, $args) = @_;
+
+  my $real_method = "_do_$method";
+  if ($self->can($real_method)) {
+    return $self->$real_method($args);
+  }
+  else {
+    return $self->[0]{$method};
+  }
+
+  die [ error => "Unknown method $method for hashes" ];
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Squirrel::Template::Expr::WrapHash - virtual method wrapper for hashes
+
+=head1 SYNOPSIS
+
+  my $wrapper = Squirrel::Template::Expr::WrapHash->new(\%somehash);
+
+  <:= somehash.size :>
+  <:= somehash.keys :>
+  <:= somehash.values :>
+  <:= somehash.list :>
+  <:= somehash.delete(key) :>
+  <:= somehash.aKey :>
+
+=head1 DESCRIPTION
+
+Provides virtual methods for hashes.
+
+=cut
diff --git a/site/cgi-bin/modules/Squirrel/Template/Expr/WrapScalar.pm b/site/cgi-bin/modules/Squirrel/Template/Expr/WrapScalar.pm
new file mode 100644 (file)
index 0000000..94daac8
--- /dev/null
@@ -0,0 +1,84 @@
+package Squirrel::Template::Expr::WrapScalar;
+use strict;
+use base qw(Squirrel::Template::Expr::WrapBase);
+
+our $VERSION = "1.000";
+
+sub _do_length  {
+  my ($self, $args) = @_;
+
+  @$args == 0
+    or die [ error => "scalar.length takes no parameters" ];
+
+  return length $self->[0];
+}
+
+sub _do_upper {
+  my ($self, $args) = @_;
+
+  @$args == 0
+    or die [ error => "scalar.upper takes no parameters" ];
+
+  return uc $self->[0];
+}
+
+sub _do_lower {
+  my ($self, $args) = @_;
+
+  @$args == 0
+    or die [ error => "scalar.lower takes no parameters" ];
+
+  return lc $self->[0];
+}
+
+sub _do_defined {
+  my ($self, $args) = @_;
+
+  @$args == 0
+    or die [ error => "scalar.defined takes no parameters" ];
+
+  return defined $self->[0];
+}
+
+sub _do_trim {
+  my ($self, $args) = @_;
+
+  @$args == 0
+    or die [ error => "scalar.defined takes no parameters" ];
+
+  my $copy = $self->[0];
+  $copy =~ s/\A\s+//;
+  $copy =~ s/\s+\z//;
+
+  return $copy;
+}
+
+sub _do_split {
+  my ($self, $args) = @_;
+
+  my $split = @$args ? $args->[0] : " ";
+  my $limit = @$args >= 2 ? $args->[1] : 0;
+
+  return [ split $split, $self->[0], $limit ];
+}
+
+sub _do_format {
+  my ($self, $args) = @_;
+
+  @$args == 1
+    or die [ error => "scalar.format takes one parameter" ];
+
+  return sprintf($args->[0], $self->[0]);
+}
+
+sub call {
+  my ($self, $method, $args) = @_;
+
+  my $real_method = "_do_$method";
+  if ($self->can($real_method)) {
+    return $self->$real_method($args);
+  }
+  die [ error => "No method $method for scalars" ];
+}
+
+1;