CGI::Ex 2.08

[chaz/p5-CGI-Ex] / lib / CGI / Ex / Template.pm

diff --git a/lib/CGI/Ex/Template.pm b/lib/CGI/Ex/Template.pm
index 773000cb1a8cf7442d276d2f383bf6fd9a907245..5f8c1778f89873ce2c2ffd9afeeddee9c6f1d6d2 100644 (file)
--- a/lib/CGI/Ex/Template.pm
+++ b/lib/CGI/Ex/Template.pm
@@ -2,7 +2,7 @@ package CGI::Ex::Template;
 
 ###----------------------------------------------------------------###
 #  See the perldoc in CGI/Ex/Template.pod
-#  Copyright 2006 - Paul Seamons                                     #
+#  Copyright 2007 - Paul Seamons                                     #
 #  Distributed under the Perl Artistic License without warranty      #
 ###----------------------------------------------------------------###
 
@@ -39,7 +39,7 @@ use vars qw($VERSION
             );
 
 BEGIN {
-    $VERSION = '2.06';
+    $VERSION = '2.08';
 
     $PACKAGE_EXCEPTION   = 'CGI::Ex::Template::Exception';
     $PACKAGE_ITERATOR    = 'CGI::Ex::Template::Iterator';
@@ -276,7 +276,7 @@ BEGIN {
     $QR_NUM       = '(?:\d*\.\d+ | \d+) (?: [eE][+-]\d+ )?';
     $QR_AQ_NOTDOT = "(?! \\s* $QR_COMMENTS \\.)";
     $QR_AQ_SPACE  = '(?: \\s+ | \$ | (?=[;+]) )'; # the + comes into play on filenames
-    $QR_PRIVATE   = qr/^_/;
+    $QR_PRIVATE   = qr/^[_.]/;
 
     $WHILE_MAX    = 1000;
     $EXTRA_COMPILE_EXT = '.sto';
@@ -1678,6 +1678,7 @@ sub parse_DUMP {
 sub play_DUMP {
     my ($self, $ident, $node) = @_;
     require Data::Dumper;
+    local $Data::Dumper::Sortkeys  = 1;
     my $info = $self->node_info($node);
     my $out;
     my $var;
@@ -2379,38 +2380,41 @@ sub play_USE {
     pop @var; # remove the trailing '.'
 
     ### look for a plugin_base
-    my $base = $self->{'PLUGIN_BASE'} || 'Template::Plugin'; # I'm not maintaining plugins - leave that to TT
-    my $package = $self->{'PLUGINS'}->{$module} ? $self->{'PLUGINS'}->{$module}
-       : $self->{'PLUGIN_FACTORY'}->{$module} ? $self->{'PLUGIN_FACTORY'}->{$module}
-       : "${base}::${module}";
-    my $require = "$package.pm";
-    $require =~ s|::|/|g;
-
-    ### try and load the module - fall back to bare module if allowed
+    my $BASE = $self->{'PLUGIN_BASE'} || 'Template::Plugin'; # I'm not maintaining plugins - leave that to TT
     my $obj;
-    if ($self->{'PLUGIN_FACTORY'}->{$module} || eval {require $require}) {
-        my $shape   = $package->load;
-        my $context = $self->context;
-        my @args    = $args ? map { $self->play_expr($_) } @$args : ();
-        $obj = $shape->new($context, @args);
-    } elsif (lc($module) eq 'iterator') { # use our iterator if none found (TT's works just fine)
-        $obj = $PACKAGE_ITERATOR->new($args ? $self->play_expr($args->[0]) : []);
-    } elsif (my @packages = grep {lc($package) eq lc($_)} @{ $self->list_plugins({base => $base}) }) {
-        foreach my $package (@packages) {
-            my $require = "$package.pm";
-            $require =~ s|::|/|g;
-            eval {require $require} || next;
+
+    foreach my $base (ref($BASE) eq 'ARRAY' ? @$BASE : $BASE) {
+        my $package = $self->{'PLUGINS'}->{$module} ? $self->{'PLUGINS'}->{$module}
+        : $self->{'PLUGIN_FACTORY'}->{$module} ? $self->{'PLUGIN_FACTORY'}->{$module}
+        : "${base}::${module}";
+        my $require = "$package.pm";
+        $require =~ s|::|/|g;
+
+        ### try and load the module - fall back to bare module if allowed
+        if ($self->{'PLUGIN_FACTORY'}->{$module} || eval {require $require}) {
             my $shape   = $package->load;
             my $context = $self->context;
             my @args    = $args ? map { $self->play_expr($_) } @$args : ();
             $obj = $shape->new($context, @args);
-        }
-    } elsif ($self->{'LOAD_PERL'}) {
-        my $require = "$module.pm";
-        $require =~ s|::|/|g;
-        if (eval {require $require}) {
-            my @args = $args ? map { $self->play_expr($_) } @$args : ();
-            $obj = $module->new(@args);
+        } elsif (lc($module) eq 'iterator') { # use our iterator if none found (TT's works just fine)
+            $obj = $PACKAGE_ITERATOR->new($args ? $self->play_expr($args->[0]) : []);
+        } elsif (my @packages = grep {lc($package) eq lc($_)} @{ $self->list_plugins({base => $base}) }) {
+            foreach my $package (@packages) {
+                my $require = "$package.pm";
+                $require =~ s|::|/|g;
+                eval {require $require} || next;
+                my $shape   = $package->load;
+                my $context = $self->context;
+                my @args    = $args ? map { $self->play_expr($_) } @$args : ();
+                $obj = $shape->new($context, @args);
+            }
+        } elsif ($self->{'LOAD_PERL'}) {
+            my $require = "$module.pm";
+            $require =~ s|::|/|g;
+            if (eval {require $require}) {
+                my @args = $args ? map { $self->play_expr($_) } @$args : ();
+                $obj = $module->new(@args);
+            }
         }
     }
     if (! defined $obj) {
@@ -2848,26 +2852,30 @@ sub define_vmethod {
 }
 
 sub vmethod_as_scalar {
-    my ($str, $pat) = @_;
-    $pat = '%s' if ! defined $pat;
+    my $str = shift; $str = ''   if ! defined $str;
+    my $pat = shift; $pat = '%s' if ! defined $pat;
     local $^W;
-    return sprintf $pat, $str;
+    return @_ ? sprintf($pat, $_[0], $str)
+              : sprintf($pat, $str);
 }
 
 sub vmethod_as_list {
-    my ($ref, $pat, $sep) = @_;
-    $pat = '%s' if ! defined $pat;
-    $sep = ' '  if ! defined $sep;
+    my $ref = shift || return '';
+    my $pat = shift; $pat = '%s' if ! defined $pat;
+    my $sep = shift; $sep = ' '  if ! defined $sep;
     local $^W;
-    return join($sep, map {sprintf $pat, $_} @$ref);
+    return @_ ? join($sep, map {sprintf $pat, $_[0], $_} @$ref)
+              : join($sep, map {sprintf $pat, $_} @$ref);
 }
 
 sub vmethod_as_hash {
-    my ($ref, $pat, $sep) = @_;
-    $pat = "%s\t%s" if ! defined $pat;
-    $sep = "\n"  if ! defined $sep;
+    my $ref = shift || return '';
+    my $pat = shift; $pat = "%s\t%s" if ! defined $pat;
+    my $sep = shift; $sep = "\n"     if ! defined $sep;
     local $^W;
-    return join($sep, map {sprintf $pat, $_, $ref->{$_}} sort keys %$ref);
+    return ! @_    ? join($sep, map {sprintf $pat, $_, $ref->{$_}} sort keys %$ref)
+         : @_ == 1 ? join($sep, map {sprintf $pat, $_[0], $_, $ref->{$_}} sort keys %$ref) # don't get to pick - it applies to the key
+         :           join($sep, map {sprintf $pat, $_[0], $_, $_[1], $ref->{$_}} sort keys %$ref);
 }
 
 sub vmethod_chunk {
@@ -2895,7 +2903,11 @@ sub vmethod_indent {
 sub vmethod_format {
     my $str = shift; $str = ''   if ! defined $str;
     my $pat = shift; $pat = '%s' if ! defined $pat;
-    return join "\n", map{ sprintf $pat, $_ } split(/\n/, $str);
+    if (@_) {
+        return join "\n", map{ sprintf $pat, $_[0], $_ } split(/\n/, $str);
+    } else {
+        return join "\n", map{ sprintf $pat, $_ } split(/\n/, $str);
+    }
 }
 
 sub vmethod_match {
@@ -3014,6 +3026,13 @@ sub filter_redirect {
 ###----------------------------------------------------------------###
 
 sub dump_parse {
+    my $obj = UNIVERSAL::isa($_[0], __PACKAGE__) ? shift : __PACKAGE__->new;
+    my $str = shift;
+    require Data::Dumper;
+    return Data::Dumper::Dumper($obj->parse_tree(\$str));
+}
+
+sub dump_parse_expr {
     my $obj = UNIVERSAL::isa($_[0], __PACKAGE__) ? shift : __PACKAGE__->new;
     my $str = shift;
     require Data::Dumper;