]>
Dogcows Code - chaz/p5-CGI-Ex/blob - Template/Extra.pm
1 package CGI
::Ex
::Template
::Extra
;
5 CGI::Ex::Template::Extra - load extra and advanced features that aren't as commonly used
9 Provides for extra or extended features that may not be as commonly used.
10 This module should not normally be used by itself.
14 Paul Seamons <paul at seamons dot com>
18 This module may be distributed under the same terms as Perl itself.
25 our $VERSION = '2.13';
28 my ($self, $str_ref) = @_;
30 my %ctime = map {$_ => 1} @CGI::Ex
::Template
::CONFIG_COMPILETIME
;
31 my %rtime = map {$_ => 1} @CGI::Ex
::Template
::CONFIG_RUNTIME
;
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];
39 $self->{$key} = $self->play_expr($val);
40 } elsif (! $rtime{$key}) {
41 $self->throw('parse', "Unknown CONFIG option \"$key\"", undef, pos($$str_ref));
44 for (my $i = 1; $i < @$config; $i++) {
45 my $key = $config->[$i] = uc $config->[$i]->[0];
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));
56 my ($self, $config, $node, $out_ref) = @_;
58 my %rtime = map {$_ => 1} @CGI::Ex
::Template
::CONFIG_RUNTIME
;
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};
65 ### show what current values are
66 $$out_ref .= join("\n", map { $rtime{$_} ? ("CONFIG $_ = ".(defined($self->{$_}) ? $self->{$_} : 'undef')) : $_ } @the_rest);
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));
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));
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];
96 my ($self, $dump, $node, $out_ref) = @_;
98 my $conf = $self->{'DUMP'};
99 return if ! $conf && defined $conf; # DUMP => 0
100 $conf = {} if ref $conf ne 'HASH';
102 ### allow for handler override
103 my $handler = $conf->{'handler'};
105 require Data
::Dumper
;
106 my $obj = Data
::Dumper-
>new([]);
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 }
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;
118 ### look for the text describing what to dump
119 my $info = $self->node_info($node);
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'}) {
130 $out = $handler->($self->{'_vars'});
131 $out =~ s/\$VAR1/EntireStash/g;
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'};
139 $out = "DUMP: File \"$info->{file}\" line $info->{line}\n $out" if $conf->{'header'} || ! defined $conf->{'header'};
147 my ($self, $str_ref) = @_;
149 if ($$str_ref =~ m{ \G ([^\W\d]\w*) \s* = \s* }gcx) {
153 my $filter = $self->parse_expr($str_ref);
154 $filter = '' if ! defined $filter;
156 return [$name, $filter];
160 my ($self, $ref, $node, $out_ref) = @_;
161 my ($name, $filter) = @$ref;
163 return '' if ! @$filter;
165 $self->{'FILTERS'}->{$name} = $filter if length $name;
167 my $sub_tree = $node->[4];
171 eval { $self->execute_tree($sub_tree, \
$out) };
172 die $@ if $@ && ref($@) !~ /Template::Exception$/;
174 my $var = [[undef, '~', $out], 0, '|', @$filter]; # make a temporary var out of it
176 return $CGI::Ex
::Template
::DIRECTIVES-
>{'GET'}->[1]->($self, $var, $node, $out_ref);
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));
186 my ($self, $ref, $node, $out_ref) = @_;
188 my $var = $self->play_expr($ref);
189 my $sub_tree = $node->[4];
191 my $global = ! $self->{'SYNTAX'} || $self->{'SYNTAX'} ne 'ht' || $self->{'GLOBAL_VARS'};
193 my $items = ref($var) eq 'ARRAY' ? $var : ! defined($var) ? [] : [$var];
196 for my $ref (@$items) {
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;
208 ### execute the sub tree
209 eval { $self->execute_tree($sub_tree, $out_ref) };
211 if (UNIVERSAL
::isa
($err, $CGI::Ex
::Template
::PACKAGE_EXCEPTION
)) {
212 next if $err->type eq 'next';
213 last if $err->type =~ /last|break/;
223 my ($self, $str_ref, $node) = @_;
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;
228 $name = [ $name, 0 ];
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));
237 $node->[6] = 1; # set a flag to keep parsing
238 return [$name, $args];
242 my ($self, $ref, $node, $out_ref) = @_;
243 my ($name, $args) = @$ref;
246 my $sub_tree = $node->[4];
247 if (! $sub_tree || ! $sub_tree->[0]) {
248 $self->set_variable($name, undef);
250 } elsif ($sub_tree->[0]->[0] eq 'BLOCK') {
251 $sub_tree = $sub_tree->[0]->[4];
254 my $self_copy = $self;
255 eval {require Scalar
::Util
; Scalar
::Util
::weaken
($self_copy)};
257 ### install a closure in the stash that will handle the macro
258 $self->set_variable($name, sub {
260 my $copy = $self_copy->{'_vars'};
261 local $self_copy->{'_vars'}= {%$copy};
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;
270 my $named = pop(@_) if $_[-1] && UNIVERSAL
::isa
($_[-1],'HASH') && $#_ > $#$args;
272 foreach my $var (@$args) {
273 $self_copy->set_variable($var, shift(@positional));
275 foreach my $name (sort keys %$named) {
276 $self_copy->set_variable([$name, 0], $named->{$name});
279 ### finally - run the sub tree
281 $self_copy->execute_tree($sub_tree, \
$out);
289 my ($self, $info, $node, $out_ref) = @_;
290 $self->throw('perl', 'EVAL_PERL not set') if ! $self->{'EVAL_PERL'};
292 ### fill in any variables
293 my $perl = $node->[4] || return;
295 $self->execute_tree($perl, \
$out);
296 $out = $1 if $out =~ /^(.+)$/s; # blatant untaint - shouldn't use perl anyway
301 package CGI
::Ex
::Template
::Perl
;
303 my $context = $self->context;
304 my $stash = $context->stash;
306 ### setup a fake handle
308 tie
*PERLOUT
, 'CGI::Ex::Template::EvalPerlHandle', $out_ref;
309 my $old_fh = select PERLOUT
;
314 ### put the handle back
322 $self->throw('undef', $err) if ref($err) !~ /Template::Exception$/;
330 my ($self, $info, $node, $out_ref) = @_;
331 $self->throw('perl', 'EVAL_PERL not set') if ! $self->{'EVAL_PERL'};
333 ### fill in any variables
334 my $tree = $node->[4] || return;
336 $self->execute_tree($tree, \
$perl);
337 $perl = $1 if $perl =~ /^(.+)$/s; # blatant untaint - shouldn't use perl anyway
343 package CGI
::Ex
::Template
::Perl
;
345 my $context = $self->context;
346 my $stash = $context->stash;
353 $$out_ref .= $output;
356 $self->throw('undef', $err) if ref($err) !~ /Template::Exception$/;
364 my ($self, $str_ref) = @_;
366 my $QR_COMMENTS = $CGI::Ex
::Template
::QR_COMMENTS
;
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
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;
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});
386 $$str_ref =~ m{ \G \) \s* $QR_COMMENTS }gcxo || $self->throw('parse.missing', "Missing close ')'", undef, pos($$str_ref));
389 return [$var, $module, $args];
393 my ($self, $ref, $node, $out_ref) = @_;
394 my ($var, $module, $args) = @$ref;
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 '.'
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
404 ### look for a plugin_base
405 my $BASE = $self->{'PLUGIN_BASE'} || 'Template::Plugin'; # I'm not maintaining plugins - leave that to TT
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
;
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);
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);
439 if (! defined $obj) {
440 my $err = "$module: plugin not found";
441 $self->throw('plugin', $err);
445 $self->set_variable(\
@var, $obj);
451 my ($self, $str_ref) = @_;
453 my $ref = $self->parse_args($str_ref, {
462 my ($self, $ref, $node, $out_ref) = @_;
464 my ($blocks, $args, $name) = @$ref;
467 # [[undef, '{}', 'key1', 'val1', 'key2', 'val2'], 0]
470 foreach (my $i = 2; $i < @$args; $i+=2) {
471 my $key = $args->[$i];
472 my $val = $self->play_expr($args->[$i+1]);
474 if (@$key == 2 && ! ref($key->[0]) && ! $key->[1]) {
477 $self->set_variable($key, $val);
481 $hash->{$key} = $val;
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}};
489 $hash->{'blocks'} = $blocks;
492 if (! eval { require Template
::View
}) {
493 $self->throw('view', 'Could not load Template::View library');
495 my $view = Template
::View-
>new($self->context, $hash)
496 || $self->throw('view', $Template::View
::ERROR
);
499 my $old_view = $self->play_expr(['view', 0]);
500 $self->set_variable($name, $view);
501 $self->set_variable(['view', 0], $view);
505 $self->execute_tree($node->[4], \
$out);
509 $self->set_variable(['view', 0], $old_view);
515 ###----------------------------------------------------------------###
519 my $args = shift || {};
520 my $base = $args->{'base'} || '';
522 return $self->{'_plugins'}->{$base} ||= do {
526 my @dirs = grep {-d
$_} map {"$_/$base"} @INC;
528 foreach my $dir (@dirs) {
530 File
::Find
::find
(sub {
531 my $mod = $base .'/'. ($File::Find
::name
=~ m
|^ $dir / (.*\w
) \
.pm
$|x
? $1 : return);
537 \
@plugins; # return of the do
541 ###----------------------------------------------------------------###
543 package CGI
::Ex
::Template
::Context
;
545 use vars
qw($AUTOLOAD);
549 my $self = shift || {};
550 die "Missing _template" if ! $self->{'_template'};
551 return bless $self, $class;
554 sub _template
{ shift-
>{'_template'} || die "Missing _template" }
557 my ($self, $name) = @_;
558 return $self->_template->{'BLOCKS'}->{$name} || $self->_template->load_parsed_tree($name);
561 sub config
{ shift-
>_template }
565 return $self->{'stash'} ||= bless {_template
=> $self->_template}, 'CGI::Ex::Template::_Stash';
568 sub insert
{ shift-
>_template->_insert(@_) }
570 sub eval_perl
{ shift-
>_template->{'EVAL_PERL'} }
575 my $args = shift || {};
577 $self->_template->set_variable($_, $args->{$_}) for keys %$args;
580 $self->_template->_process($ref, $self->_template->_vars, \
$out);
587 my $args = shift || {};
589 my $t = $self->_template;
591 my $swap = $t->{'_vars'};
592 local $t->{'_vars'} = {%$swap};
594 $t->set_variable($_, $args->{$_}) for keys %$args;
596 my $out = ''; # have temp item to allow clear to correctly clear
597 eval { $t->_process($ref, $t->_vars, \
$out) };
599 die $err if ref($err) !~ /Template::Exception$/ || $err->type !~ /return/;
606 my ($self, $name, $filter, $is_dynamic) = @_;
607 $filter = [ $filter, 1 ] if $is_dynamic;
608 $self->define_vmethod('filter', $name, $filter);
612 my ($self, $name, $args, $alias) = @_;
613 my $t = $self->_template;
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')) {
621 } elsif (UNIVERSAL
::can
($name, 'factory')) {
622 $filter = $name->factory || $t->throw($name->error);
624 $t->throw('undef', "$name: filter not found");
627 if (UNIVERSAL
::isa
($filter, 'ARRAY')) {
628 $filter = ($filter->[1]) ? $filter->[0]->($t->context, @$args) : $filter->[0];
629 } elsif ($args && @$args) {
631 $filter = sub { $sub->(shift, @$args) };
634 $t->{'FILTERS'}->{$alias} = $filter if $alias;
639 sub define_vmethod
{ shift-
>_template->define_vmethod(@_) }
642 my ($self, $type, $info) = @_;
644 if (UNIVERSAL
::isa
($type, $CGI::Ex
::Template
::PACKAGE_EXCEPTION
)) {
646 } elsif (defined $info) {
647 $self->_template->throw($type, $info);
649 $self->_template->throw('undef', $type);
653 sub AUTOLOAD
{ shift-
>_template->throw('not_implemented', "The method $AUTOLOAD has not been implemented") }
657 ###----------------------------------------------------------------###
659 package CGI
::Ex
::Template
::_Stash
;
661 use vars
qw($AUTOLOAD);
663 sub _template
{ shift-
>{'_template'} || die "Missing _template" }
666 my ($self, $var) = @_;
668 if ($var =~ /^\w+$/) { $var = [$var, 0] }
669 else { $var = $self->_template->parse_expr(\
$var, {no_dots
=> 1}) }
671 return $self->_template->play_expr($var, {no_dots
=> 1});
675 my ($self, $var, $val) = @_;
677 if ($var =~ /^\w+$/) { $var = [$var, 0] }
678 else { $var = $self->_template->parse_expr(\
$var, {no_dots
=> 1}) }
680 $self->_template->set_variable($var, $val, {no_dots
=> 1});
684 sub AUTOLOAD
{ shift-
>_template->throw('not_implemented', "The method $AUTOLOAD has not been implemented") }
688 ###----------------------------------------------------------------###
690 package CGI
::Ex
::Template
::EvalPerlHandle
;
693 my ($class, $out_ref) = @_;
694 return bless [$out_ref], $class;
699 ${ $self->[0] } .= $_ for grep {defined && length} @_;
703 ###----------------------------------------------------------------###
This page took 0.089651 seconds and 4 git commands to generate.