Dogcows Code - chaz/p5-CGI-Ex/blob - lib/CGI/Ex/Template/Extra.pm

   1 package CGI::Ex::Template::Extra;
   2
   3 =head1 NAME
   4
   5 CGI::Ex::Template::Extra - load extra and advanced features that aren't as commonly used
   6
   7 =head1 DESCRIPTION
   8
   9 Provides for extra or extended features that may not be as commonly used.
  10 This module should not normally be used by itself.
  11
  12 =head1 AUTHOR
  13
  14 Paul Seamons <paul at seamons dot com>
  15
  16 =head1 LICENSE
  17
  18 This module may be distributed under the same terms as Perl itself.
  19
  20 =cut
  21
  22 use strict;
  23 use warnings;
  24
  25 our $VERSION = '2.13';
  26
  27 sub parse_CONFIG {
  28     my ($self, $str_ref) = @_;
  29
  30     my %ctime = map {$_ => 1} @CGI::Ex::Template::CONFIG_COMPILETIME;
  31     my %rtime = map {$_ => 1} @CGI::Ex::Template::CONFIG_RUNTIME;
  32
  33     my $config = $self->parse_args($str_ref, {named_at_front => 1, is_parened => 1});
  34     my $ref = $config->[0]->[0];
  35     for (my $i = 2; $i < @$ref; $i += 2) {
  36         my $key = $ref->[$i] = uc $ref->[$i];
  37         my $val = $ref->[$i + 1];
  38         if ($ctime{$key}) {
  39             $self->{$key} = $self->play_expr($val);
  40         } elsif (! $rtime{$key}) {
  41             $self->throw('parse', "Unknown CONFIG option \"$key\"", undef, pos($$str_ref));
  42         }
  43     }
  44     for (my $i = 1; $i < @$config; $i++) {
  45         my $key = $config->[$i] = uc $config->[$i]->[0];
  46         if ($ctime{$key}) {
  47             $config->[$i] = "CONFIG $key = ".(defined($self->{$key}) ? $self->{$key} : 'undef');
  48         } elsif (! $rtime{$key}) {
  49             $self->throw('parse', "Unknown CONFIG option \"$key\"", undef, pos($$str_ref));
  50         }
  51     }
  52     return $config;
  53 }
  54
  55 sub play_CONFIG {
  56     my ($self, $config, $node, $out_ref) = @_;
  57
  58     my %rtime = map {$_ => 1} @CGI::Ex::Template::CONFIG_RUNTIME;
  59
  60     ### do runtime config - not many options get these
  61     my ($named, @the_rest) = @$config;
  62     $named = $self->play_expr($named);
  63     @{ $self }{keys %$named} = @{ $named }{keys %$named};
  64
  65     ### show what current values are
  66     $$out_ref .= join("\n", map { $rtime{$_} ? ("CONFIG $_ = ".(defined($self->{$_}) ? $self->{$_} : 'undef')) : $_ } @the_rest);
  67     return;
  68 }
  69
  70 sub parse_DEBUG {
  71     my ($self, $str_ref) = @_;
  72     $$str_ref =~ m{ \G ([Oo][Nn] | [Oo][Ff][Ff] | [Ff][Oo][Rr][Mm][Aa][Tt]) \s* }gcx
  73         || $self->throw('parse', "Unknown DEBUG option", undef, pos($$str_ref));
  74     my $ret = [lc($1)];
  75     if ($ret->[0] eq 'format') {
  76         $$str_ref =~ m{ \G ([\"\']) (|.*?[^\\]) \1 \s* }gcxs
  77             || $self->throw('parse', "Missing format string", undef, pos($$str_ref));
  78         $ret->[1] = $2;
  79     }
  80     return $ret;
  81 }
  82
  83 sub play_DEBUG {
  84     my ($self, $ref) = @_;
  85     if ($ref->[0] eq 'on') {
  86         delete $self->{'_debug_off'};
  87     } elsif ($ref->[0] eq 'off') {
  88         $self->{'_debug_off'} = 1;
  89     } elsif ($ref->[0] eq 'format') {
  90         $self->{'_debug_format'} = $ref->[1];
  91     }
  92     return;
  93 }
  94
  95 sub play_DUMP {
  96     my ($self, $dump, $node, $out_ref) = @_;
  97
  98     my $conf = $self->{'DUMP'};
  99     return if ! $conf && defined $conf; # DUMP => 0
 100     $conf = {} if ref $conf ne 'HASH';
 101
 102     ### allow for handler override
 103     my $handler = $conf->{'handler'};
 104     if (! $handler) {
 105         require Data::Dumper;
 106         my $obj = Data::Dumper->new([]);
 107         my $meth;
 108         foreach my $prop (keys %$conf) { $obj->$prop($conf->{$prop}) if $prop =~ /^\w+$/ && ($meth = $obj->can($prop)) }
 109         my $sort = defined($conf->{'Sortkeys'}) ? $obj->Sortkeys : 1;
 110         $obj->Sortkeys(sub { my $h = shift; [grep {$_ !~ $CGI::Ex::Template::QR_PRIVATE} ($sort ? sort keys %$h : keys %$h)] });
 111         $handler = sub { $obj->Values([@_]); $obj->Dump }
 112     }
 113
 114     my ($named, @dump) = @$dump;
 115     push @dump, $named if ! $self->is_empty_named_args($named); # add named args back on at end - if there are some
 116     $_ = $self->play_expr($_) foreach @dump;
 117
 118     ### look for the text describing what to dump
 119     my $info = $self->node_info($node);
 120     my $out;
 121     if (@dump) {
 122         $out = $handler->(@dump && @dump == 1 ? $dump[0] : \@dump);
 123         my $name = $info->{'text'};
 124         $name =~ s/^[+=~-]?\s*DUMP\s+//;
 125         $name =~ s/\s*[+=~-]?$//;
 126         $out =~ s/\$VAR1/$name/;
 127     } elsif (defined($conf->{'EntireStash'}) && ! $conf->{'EntireStash'}) {
 128         $out = '';
 129     } else {
 130         $out = $handler->($self->{'_vars'});
 131         $out =~ s/\$VAR1/EntireStash/g;
 132     }
 133
 134     if ($conf->{'html'} || (! defined($conf->{'html'}) && $ENV{'REQUEST_METHOD'})) {
 135         $out = $CGI::Ex::Template::SCALAR_OPS->{'html'}->($out);
 136         $out = "<pre>$out</pre>";
 137         $out = "<b>DUMP: File \"$info->{file}\" line $info->{line}</b>$out" if $conf->{'header'} || ! defined $conf->{'header'};
 138     } else {
 139         $out = "DUMP: File \"$info->{file}\" line $info->{line}\n    $out" if $conf->{'header'} || ! defined $conf->{'header'};
 140     }
 141
 142     $$out_ref .= $out;
 143     return;
 144 }
 145
 146 sub parse_FILTER {
 147     my ($self, $str_ref) = @_;
 148     my $name = '';
 149     if ($$str_ref =~ m{ \G ([^\W\d]\w*) \s* = \s* }gcx) {
 150         $name = $1;
 151     }
 152
 153     my $filter = $self->parse_expr($str_ref);
 154     $filter = '' if ! defined $filter;
 155
 156     return [$name, $filter];
 157 }
 158
 159 sub play_FILTER {
 160     my ($self, $ref, $node, $out_ref) = @_;
 161     my ($name, $filter) = @$ref;
 162
 163     return '' if ! @$filter;
 164
 165     $self->{'FILTERS'}->{$name} = $filter if length $name;
 166
 167     my $sub_tree = $node->[4];
 168
 169     ### play the block
 170     my $out = '';
 171     eval { $self->execute_tree($sub_tree, \$out) };
 172     die $@ if $@ && ref($@) !~ /Template::Exception$/;
 173
 174     my $var = [[undef, '~', $out], 0, '|', @$filter]; # make a temporary var out of it
 175
 176     return $CGI::Ex::Template::DIRECTIVES->{'GET'}->[1]->($self, $var, $node, $out_ref);
 177 }
 178
 179 sub parse_LOOP {
 180     my ($self, $str_ref, $node) = @_;
 181     return $self->parse_expr($str_ref)
 182         || $self->throw('parse', 'Missing variable on LOOP directive', undef, pos($$str_ref));
 183 }
 184
 185 sub play_LOOP {
 186     my ($self, $ref, $node, $out_ref) = @_;
 187
 188     my $var = $self->play_expr($ref);
 189     my $sub_tree = $node->[4];
 190
 191     my $global = ! $self->{'SYNTAX'} || $self->{'SYNTAX'} ne 'ht' || $self->{'GLOBAL_VARS'};
 192
 193     my $items = ref($var) eq 'ARRAY' ? $var : ! defined($var) ? [] : [$var];
 194
 195     my $i = 0;
 196     for my $ref (@$items) {
 197         ### setup the loop
 198         $self->throw('loop', 'Scalar value used in LOOP') if $ref && ref($ref) ne 'HASH';
 199         local $self->{'_vars'} = (! $global) ? ($ref || {}) : (ref($ref) eq 'HASH') ? {%{ $self->{'_vars'} }, %$ref} : $self->{'_vars'};
 200         if ($self->{'LOOP_CONTEXT_VARS'} && ! $CGI::Ex::Template::QR_PRIVATE) {
 201             $self->{'_vars'}->{'__counter__'} = ++$i;
 202             $self->{'_vars'}->{'__first__'} = $i == 1 ? 1 : 0;
 203             $self->{'_vars'}->{'__last__'}  = $i == @$items ? 1 : 0;
 204             $self->{'_vars'}->{'__inner__'} = $i == 1 || $i == @$items ? 0 : 1;
 205             $self->{'_vars'}->{'__odd__'}   = ($i % 2) ? 1 : 0;
 206         }
 207
 208         ### execute the sub tree
 209         eval { $self->execute_tree($sub_tree, $out_ref) };
 210         if (my $err = $@) {
 211             if (UNIVERSAL::isa($err, $CGI::Ex::Template::PACKAGE_EXCEPTION)) {
 212                 next if $err->type eq 'next';
 213                 last if $err->type =~ /last|break/;
 214             }
 215             die $err;
 216         }
 217     }
 218
 219     return;
 220 }
 221
 222 sub parse_MACRO {
 223     my ($self, $str_ref, $node) = @_;
 224
 225     my $name = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b) (?! \\.) \\s* $CGI::Ex::Template::QR_COMMENTS"});
 226     $self->throw('parse', "Missing macro name", undef, pos($$str_ref)) if ! defined $name;
 227     if (! ref $name) {
 228         $name = [ $name, 0 ];
 229     }
 230
 231     my $args;
 232     if ($$str_ref =~ m{ \G \( \s* }gcx) {
 233         $args = $self->parse_args($str_ref, {positional_only => 1});
 234         $$str_ref =~ m{ \G \) \s* }gcx || $self->throw('parse.missing', "Missing close ')'", undef, pos($$str_ref));
 235     }
 236
 237     $node->[6] = 1;           # set a flag to keep parsing
 238     return [$name, $args];
 239 }
 240
 241 sub play_MACRO {
 242     my ($self, $ref, $node, $out_ref) = @_;
 243     my ($name, $args) = @$ref;
 244
 245     ### get the sub tree
 246     my $sub_tree = $node->[4];
 247     if (! $sub_tree || ! $sub_tree->[0]) {
 248         $self->set_variable($name, undef);
 249         return;
 250     } elsif ($sub_tree->[0]->[0] eq 'BLOCK') {
 251         $sub_tree = $sub_tree->[0]->[4];
 252     }
 253
 254     my $self_copy = $self;
 255     eval {require Scalar::Util; Scalar::Util::weaken($self_copy)};
 256
 257     ### install a closure in the stash that will handle the macro
 258     $self->set_variable($name, sub {
 259         ### macros localize
 260         my $copy = $self_copy->{'_vars'};
 261         local $self_copy->{'_vars'}= {%$copy};
 262
 263         ### prevent recursion
 264         local $self_copy->{'_macro_recurse'} = $self_copy->{'_macro_recurse'} || 0;
 265         my $max = $self_copy->{'MAX_MACRO_RECURSE'} || $CGI::Ex::Template::MAX_MACRO_RECURSE;
 266         $self_copy->throw('macro_recurse', "MAX_MACRO_RECURSE $max reached")
 267             if ++$self_copy->{'_macro_recurse'} > $max;
 268
 269         ### set arguments
 270         my $named = pop(@_) if $_[-1] && UNIVERSAL::isa($_[-1],'HASH') && $#_ > $#$args;
 271         my @positional = @_;
 272         foreach my $var (@$args) {
 273             $self_copy->set_variable($var, shift(@positional));
 274         }
 275         foreach my $name (sort keys %$named) {
 276             $self_copy->set_variable([$name, 0], $named->{$name});
 277         }
 278
 279         ### finally - run the sub tree
 280         my $out = '';
 281         $self_copy->execute_tree($sub_tree, \$out);
 282         return $out;
 283     });
 284
 285     return;
 286 }
 287
 288 sub play_PERL {
 289     my ($self, $info, $node, $out_ref) = @_;
 290     $self->throw('perl', 'EVAL_PERL not set') if ! $self->{'EVAL_PERL'};
 291
 292     ### fill in any variables
 293     my $perl = $node->[4] || return;
 294     my $out  = '';
 295     $self->execute_tree($perl, \$out);
 296     $out = $1 if $out =~ /^(.+)$/s; # blatant untaint - shouldn't use perl anyway
 297
 298     ### try the code
 299     my $err;
 300     eval {
 301         package CGI::Ex::Template::Perl;
 302
 303         my $context = $self->context;
 304         my $stash   = $context->stash;
 305
 306         ### setup a fake handle
 307         local *PERLOUT;
 308         tie *PERLOUT, 'CGI::Ex::Template::EvalPerlHandle', $out_ref;
 309         my $old_fh = select PERLOUT;
 310
 311         eval $out;
 312         $err = $@;
 313
 314         ### put the handle back
 315         select $old_fh;
 316
 317     };
 318     $err ||= $@;
 319
 320
 321     if ($err) {
 322         $self->throw('undef', $err) if ref($err) !~ /Template::Exception$/;
 323         die $err;
 324     }
 325
 326     return;
 327 }
 328
 329 sub play_RAWPERL {
 330     my ($self, $info, $node, $out_ref) = @_;
 331     $self->throw('perl', 'EVAL_PERL not set') if ! $self->{'EVAL_PERL'};
 332
 333     ### fill in any variables
 334     my $tree = $node->[4] || return;
 335     my $perl  = '';
 336     $self->execute_tree($tree, \$perl);
 337     $perl = $1 if $perl =~ /^(.+)$/s; # blatant untaint - shouldn't use perl anyway
 338
 339     ### try the code
 340     my $err;
 341     my $output = '';
 342     eval {
 343         package CGI::Ex::Template::Perl;
 344
 345         my $context = $self->context;
 346         my $stash   = $context->stash;
 347
 348         eval $perl;
 349         $err = $@;
 350     };
 351     $err ||= $@;
 352
 353     $$out_ref .= $output;
 354
 355     if ($err) {
 356         $self->throw('undef', $err) if ref($err) !~ /Template::Exception$/;
 357         die $err;
 358     }
 359
 360     return;
 361 }
 362
 363 sub parse_USE {
 364     my ($self, $str_ref) = @_;
 365
 366     my $QR_COMMENTS = $CGI::Ex::Template::QR_COMMENTS;
 367
 368     my $var;
 369     my $mark = pos $$str_ref;
 370     if (defined(my $_var = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b) (?! \\.) \\s* $QR_COMMENTS"}))
 371         && ($$str_ref =~ m{ \G = >? \s* $QR_COMMENTS }gcxo # make sure there is assignment
 372             || ((pos($$str_ref) = $mark) && 0))               # otherwise we need to rollback
 373         ) {
 374         $var = $_var;
 375     }
 376
 377     my $module = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b (?: (?:\\.|::) \\w+\\b)*) (?! \\.) \\s* $QR_COMMENTS"});
 378     $self->throw('parse', "Missing plugin name while parsing $$str_ref", undef, pos($$str_ref)) if ! defined $module;
 379     $module =~ s/\./::/g;
 380
 381     my $args;
 382     my $open = $$str_ref =~ m{ \G \( \s* $QR_COMMENTS }gcxo;
 383     $args = $self->parse_args($str_ref, {is_parened => $open, named_at_front => 1});
 384
 385     if ($open) {
 386         $$str_ref =~ m{ \G \) \s* $QR_COMMENTS }gcxo || $self->throw('parse.missing', "Missing close ')'", undef, pos($$str_ref));
 387     }
 388
 389     return [$var, $module, $args];
 390 }
 391
 392 sub play_USE {
 393     my ($self, $ref, $node, $out_ref) = @_;
 394     my ($var, $module, $args) = @$ref;
 395
 396     ### get the stash storage location - default to the module
 397     $var = $module if ! defined $var;
 398     my @var = map {($_, 0, '.')} split /(?:\.|::)/, $var;
 399     pop @var; # remove the trailing '.'
 400
 401     my ($named, @args) = @$args;
 402     push @args, $named if ! $self->is_empty_named_args($named); # add named args back on at end - if there are some
 403
 404     ### look for a plugin_base
 405     my $BASE = $self->{'PLUGIN_BASE'} || 'Template::Plugin'; # I'm not maintaining plugins - leave that to TT
 406     my $obj;
 407
 408     foreach my $base (ref($BASE) eq 'ARRAY' ? @$BASE : $BASE) {
 409         my $package = $self->{'PLUGINS'}->{$module} ? $self->{'PLUGINS'}->{$module}
 410         : $self->{'PLUGIN_FACTORY'}->{$module} ? $self->{'PLUGIN_FACTORY'}->{$module}
 411         : "${base}::${module}";
 412         my $require = "$package.pm";
 413         $require =~ s|::|/|g;
 414
 415         ### try and load the module - fall back to bare module if allowed
 416         if ($self->{'PLUGIN_FACTORY'}->{$module} || eval {require $require}) {
 417             my $shape   = $package->load;
 418             my $context = $self->context;
 419             $obj = $shape->new($context, map { $self->play_expr($_) } @args);
 420         } elsif (lc($module) eq 'iterator') { # use our iterator if none found (TT's works just fine)
 421             $obj = $self->iterator($args[0]);
 422         } elsif (my @packages = grep {lc($package) eq lc($_)} @{ $self->list_plugins({base => $base}) }) {
 423             foreach my $package (@packages) {
 424                 my $require = "$package.pm";
 425                 $require =~ s|::|/|g;
 426                 eval {require $require} || next;
 427                 my $shape   = $package->load;
 428                 my $context = $self->context;
 429                 $obj = $shape->new($context, map { $self->play_expr($_) } @args);
 430             }
 431         } elsif ($self->{'LOAD_PERL'}) {
 432             my $require = "$module.pm";
 433             $require =~ s|::|/|g;
 434             if (eval {require $require}) {
 435                 $obj = $module->new(map { $self->play_expr($_) } @args);
 436             }
 437         }
 438     }
 439     if (! defined $obj) {
 440         my $err = "$module: plugin not found";
 441         $self->throw('plugin', $err);
 442     }
 443
 444     ### all good
 445     $self->set_variable(\@var, $obj);
 446
 447     return;
 448 }
 449
 450 sub parse_VIEW {
 451     my ($self, $str_ref) = @_;
 452
 453     my $ref = $self->parse_args($str_ref, {
 454         named_at_front       => 1,
 455         require_arg          => 1,
 456     });
 457
 458     return $ref;
 459 }
 460
 461 sub play_VIEW {
 462     my ($self, $ref, $node, $out_ref) = @_;
 463
 464     my ($blocks, $args, $name) = @$ref;
 465
 466     ### get args ready
 467     # [[undef, '{}', 'key1', 'val1', 'key2', 'val2'], 0]
 468     $args = $args->[0];
 469     my $hash = {};
 470     foreach (my $i = 2; $i < @$args; $i+=2) {
 471         my $key = $args->[$i];
 472         my $val = $self->play_expr($args->[$i+1]);
 473         if (ref $key) {
 474             if (@$key == 2 && ! ref($key->[0]) && ! $key->[1]) {
 475                 $key = $key->[0];
 476             } else {
 477                 $self->set_variable($key, $val);
 478                 next; # what TT does
 479             }
 480         }
 481         $hash->{$key} = $val;
 482     }
 483
 484     ### prepare the blocks
 485     my $prefix = $hash->{'prefix'} || (ref($name) && @$name == 2 && ! $name->[1] && ! ref($name->[0])) ? "$name->[0]/" : '';
 486     foreach my $key (keys %$blocks) {
 487         $blocks->{$key} = {name => "${prefix}${key}", _tree => $blocks->{$key}};
 488     }
 489     $hash->{'blocks'} = $blocks;
 490
 491     ### get the view
 492     if (! eval { require Template::View }) {
 493         $self->throw('view', 'Could not load Template::View library');
 494     }
 495     my $view = Template::View->new($self->context, $hash)
 496         || $self->throw('view', $Template::View::ERROR);
 497
 498     ### 'play it'
 499     my $old_view = $self->play_expr(['view', 0]);
 500     $self->set_variable($name, $view);
 501     $self->set_variable(['view', 0], $view);
 502
 503     if ($node->[4]) {
 504         my $out = '';
 505         $self->execute_tree($node->[4], \$out);
 506         # throw away $out
 507     }
 508
 509     $self->set_variable(['view', 0], $old_view);
 510     $view->seal;
 511
 512     return;
 513 }
 514
 515 ###----------------------------------------------------------------###
 516
 517 sub list_plugins {
 518     my $self = shift;
 519     my $args = shift || {};
 520     my $base = $args->{'base'} || '';
 521
 522     return $self->{'_plugins'}->{$base} ||= do {
 523         my @plugins;
 524
 525         $base =~ s|::|/|g;
 526         my @dirs = grep {-d $_} map {"$_/$base"} @INC;
 527
 528         foreach my $dir (@dirs) {
 529             require File::Find;
 530             File::Find::find(sub {
 531                 my $mod = $base .'/'. ($File::Find::name =~ m|^ $dir / (.*\w) \.pm $|x ? $1 : return);
 532                 $mod =~ s|/|::|g;
 533                 push @plugins, $mod;
 534             }, $dir);
 535         }
 536
 537         \@plugins; # return of the do
 538     };
 539 }
 540
 541 ###----------------------------------------------------------------###
 542
 543 package CGI::Ex::Template::Context;
 544
 545 use vars qw($AUTOLOAD);
 546
 547 sub new {
 548     my $class = shift;
 549     my $self  = shift || {};
 550     die "Missing _template" if ! $self->{'_template'};
 551     return bless $self, $class;
 552 }
 553
 554 sub _template { shift->{'_template'} || die "Missing _template" }
 555
 556 sub template {
 557     my ($self, $name) = @_;
 558     return $self->_template->{'BLOCKS'}->{$name} || $self->_template->load_parsed_tree($name);
 559 }
 560
 561 sub config { shift->_template }
 562
 563 sub stash {
 564     my $self = shift;
 565     return $self->{'stash'} ||= bless {_template => $self->_template}, 'CGI::Ex::Template::_Stash';
 566 }
 567
 568 sub insert { shift->_template->_insert(@_) }
 569
 570 sub eval_perl { shift->_template->{'EVAL_PERL'} }
 571
 572 sub process {
 573     my $self = shift;
 574     my $ref  = shift;
 575     my $args = shift || {};
 576
 577     $self->_template->set_variable($_, $args->{$_}) for keys %$args;
 578
 579     my $out  = '';
 580     $self->_template->_process($ref, $self->_template->_vars, \$out);
 581     return $out;
 582 }
 583
 584 sub include {
 585     my $self = shift;
 586     my $ref  = shift;
 587     my $args = shift || {};
 588
 589     my $t = $self->_template;
 590
 591     my $swap = $t->{'_vars'};
 592     local $t->{'_vars'} = {%$swap};
 593
 594     $t->set_variable($_, $args->{$_}) for keys %$args;
 595
 596     my $out = ''; # have temp item to allow clear to correctly clear
 597     eval { $t->_process($ref, $t->_vars, \$out) };
 598     if (my $err = $@) {
 599         die $err if ref($err) !~ /Template::Exception$/ || $err->type !~ /return/;
 600     }
 601
 602     return $out;
 603 }
 604
 605 sub define_filter {
 606     my ($self, $name, $filter, $is_dynamic) = @_;
 607     $filter = [ $filter, 1 ] if $is_dynamic;
 608     $self->define_vmethod('filter', $name, $filter);
 609 }
 610
 611 sub filter {
 612     my ($self, $name, $args, $alias) = @_;
 613     my $t = $self->_template;
 614
 615     my $filter;
 616     if (! ref $name) {
 617         $filter = $t->{'FILTERS'}->{$name} || $CGI::Ex::Template::FILTER_OPS->{$name} || $CGI::Ex::Template::SCALAR_OPS->{$name};
 618         $t->throw('filter', $name) if ! $filter;
 619     } elsif (UNIVERSAL::isa($name, 'CODE') || UNIVERSAL::isa($name, 'ARRAY')) {
 620         $filter = $name;
 621     } elsif (UNIVERSAL::can($name, 'factory')) {
 622         $filter = $name->factory || $t->throw($name->error);
 623     } else {
 624         $t->throw('undef', "$name: filter not found");
 625     }
 626
 627     if (UNIVERSAL::isa($filter, 'ARRAY')) {
 628         $filter = ($filter->[1]) ? $filter->[0]->($t->context, @$args) : $filter->[0];
 629     } elsif ($args && @$args) {
 630         my $sub = $filter;
 631         $filter = sub { $sub->(shift, @$args) };
 632     }
 633
 634     $t->{'FILTERS'}->{$alias} = $filter if $alias;
 635
 636     return $filter;
 637 }
 638
 639 sub define_vmethod { shift->_template->define_vmethod(@_) }
 640
 641 sub throw {
 642     my ($self, $type, $info) = @_;
 643
 644     if (UNIVERSAL::isa($type, $CGI::Ex::Template::PACKAGE_EXCEPTION)) {
 645         die $type;
 646     } elsif (defined $info) {
 647         $self->_template->throw($type, $info);
 648     } else {
 649         $self->_template->throw('undef', $type);
 650     }
 651 }
 652
 653 sub AUTOLOAD { shift->_template->throw('not_implemented', "The method $AUTOLOAD has not been implemented") }
 654
 655 sub DESTROY {}
 656
 657 ###----------------------------------------------------------------###
 658
 659 package CGI::Ex::Template::_Stash;
 660
 661 use vars qw($AUTOLOAD);
 662
 663 sub _template { shift->{'_template'} || die "Missing _template" }
 664
 665 sub get {
 666     my ($self, $var) = @_;
 667     if (! ref $var) {
 668         if ($var =~ /^\w+$/) {  $var = [$var, 0] }
 669         else {                  $var = $self->_template->parse_expr(\$var, {no_dots => 1}) }
 670     }
 671     return $self->_template->play_expr($var, {no_dots => 1});
 672 }
 673
 674 sub set {
 675     my ($self, $var, $val) = @_;
 676     if (! ref $var) {
 677         if ($var =~ /^\w+$/) {  $var = [$var, 0] }
 678         else {                  $var = $self->_template->parse_expr(\$var, {no_dots => 1}) }
 679     }
 680     $self->_template->set_variable($var, $val, {no_dots => 1});
 681     return $val;
 682 }
 683
 684 sub AUTOLOAD { shift->_template->throw('not_implemented', "The method $AUTOLOAD has not been implemented") }
 685
 686 sub DESTROY {}
 687
 688 ###----------------------------------------------------------------###
 689
 690 package CGI::Ex::Template::EvalPerlHandle;
 691
 692 sub TIEHANDLE {
 693     my ($class, $out_ref) = @_;
 694     return bless [$out_ref], $class;
 695 }
 696
 697 sub PRINT {
 698     my $self = shift;
 699     ${ $self->[0] } .= $_ for grep {defined && length} @_;
 700     return 1;
 701 }
 702
 703 ###----------------------------------------------------------------###
 704
 705 1;