X-Git-Url: https://git.dogcows.com/gitweb?p=chaz%2Fp5-CGI-Ex;a=blobdiff_plain;f=lib%2FCGI%2FEx%2FTemplate.pm;h=5f8c1778f89873ce2c2ffd9afeeddee9c6f1d6d2;hp=6c95025d56646ae428c69a454eb148dea94ef552;hb=8abbacc82b52f460bef67c1923ae98873a95e123;hpb=d710d6cd21be21c0ab2df3566c2bd61d9015cac6

diff --git a/lib/CGI/Ex/Template.pm b/lib/CGI/Ex/Template.pm
index 6c95025..5f8c177 100644
--- 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.04';
+    $VERSION = '2.08';
 
     $PACKAGE_EXCEPTION   = 'CGI::Ex::Template::Exception';
     $PACKAGE_ITERATOR    = 'CGI::Ex::Template::Iterator';
@@ -66,6 +66,7 @@ BEGIN {
         defined  => sub { 1 },
         indent   => \&vmethod_indent,
         int      => sub { local $^W; int $_[0] },
+        fmt      => \&vmethod_as_scalar,
         'format' => \&vmethod_format,
         hash     => sub { {value => $_[0]} },
         html     => sub { local $_ = $_[0]; s/&/&amp;/g; s/</&lt;/g; s/>/&gt;/g; s/\"/&quot;/g; $_ },
@@ -101,6 +102,7 @@ BEGIN {
     $LIST_OPS = {
         as      => \&vmethod_as_list,
         first   => sub { my ($ref, $i) = @_; return $ref->[0] if ! $i; return [@{$ref}[0 .. $i - 1]]},
+        fmt     => \&vmethod_as_list,
         grep    => sub { my ($ref, $pat) = @_; [grep {/$pat/} @$ref] },
         hash    => sub { local $^W; my ($list, $i) = @_; defined($i) ? {map {$i++ => $_} @$list} : {@$list} },
         join    => sub { my ($ref, $join) = @_; $join = ' ' if ! defined $join; local $^W; return join $join, @$ref },
@@ -129,6 +131,7 @@ BEGIN {
         delete  => sub { return '' if ! defined $_[1]; delete  $_[0]->{ $_[1] } },
         each    => sub { [%{ $_[0] }] },
         exists  => sub { return '' if ! defined $_[1]; exists $_[0]->{ $_[1] } },
+        fmt     => \&vmethod_as_hash,
         hash    => sub { $_[0] },
         import  => sub { my ($a, $b) = @_; return '' if ref($b) ne 'HASH'; @{$a}{keys %$b} = values %$b; '' },
         item    => sub { my ($h, $k) = @_; return '' if ! defined $k || $k =~ $QR_PRIVATE; $h->{$k} },
@@ -273,10 +276,12 @@ 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';
+
+    eval {require Scalar::Util};
 };
 
 ###----------------------------------------------------------------###
@@ -1673,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;
@@ -1933,7 +1939,8 @@ sub play_MACRO {
         $sub_tree = $sub_tree->[0]->[4];
     }
 
-    my $self_copy = $self->weak_copy;
+    my $self_copy = $self;
+    eval {require Scalar::Util; Scalar::Util::weaken($self_copy)};
 
     ### install a closure in the stash that will handle the macro
     $self->set_variable($name, sub {
@@ -2373,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) {
@@ -2775,20 +2785,6 @@ sub list_plugins {
     };
 }
 
-### get a copy of self without circular refs for use in closures
-sub weak_copy {
-    my $self = shift;
-    my $self_copy;
-    if (eval { require Scalar::Util }
-        && defined &Scalar::Util::weaken) {
-        $self_copy = $self;
-        Scalar::Util::weaken($self_copy);
-    } else {
-        $self_copy = bless {%$self}, ref($self); # hackish way to avoid circular refs on old perls (pre 5.8)
-    }
-    return $self_copy;
-}
-
 sub debug_node {
     my ($self, $node) = @_;
     my $info = $self->node_info($node);
@@ -2856,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 {
@@ -2903,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 {
@@ -3022,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;