X-Git-Url: https://git.dogcows.com/gitweb?p=chaz%2Fp5-CGI-Ex;a=blobdiff_plain;f=lib%2FCGI%2FEx%2FTemplate%2FExtra.pm;fp=lib%2FCGI%2FEx%2FTemplate%2FExtra.pm;h=9fb9f31913a3fa8e596b05f07fd6b8dca3d024be;hp=0000000000000000000000000000000000000000;hb=80a766126b7d0281ee013d369d9e6af45cc2cf42;hpb=8cd30501f5be7e40e26b3dc885dfe25520d39df9 diff --git a/lib/CGI/Ex/Template/Extra.pm b/lib/CGI/Ex/Template/Extra.pm new file mode 100644 index 0000000..9fb9f31 --- /dev/null +++ b/lib/CGI/Ex/Template/Extra.pm @@ -0,0 +1,705 @@ +package CGI::Ex::Template::Extra; + +=head1 NAME + +CGI::Ex::Template::Extra - load extra and advanced features that aren't as commonly used + +=head1 DESCRIPTION + +Provides for extra or extended features that may not be as commonly used. +This module should not normally be used by itself. + +=head1 AUTHOR + +Paul Seamons + +=head1 LICENSE + +This module may be distributed under the same terms as Perl itself. + +=cut + +use strict; +use warnings; + +our $VERSION = '2.13'; + +sub parse_CONFIG { + my ($self, $str_ref) = @_; + + my %ctime = map {$_ => 1} @CGI::Ex::Template::CONFIG_COMPILETIME; + my %rtime = map {$_ => 1} @CGI::Ex::Template::CONFIG_RUNTIME; + + my $config = $self->parse_args($str_ref, {named_at_front => 1, is_parened => 1}); + my $ref = $config->[0]->[0]; + for (my $i = 2; $i < @$ref; $i += 2) { + my $key = $ref->[$i] = uc $ref->[$i]; + my $val = $ref->[$i + 1]; + if ($ctime{$key}) { + $self->{$key} = $self->play_expr($val); + } elsif (! $rtime{$key}) { + $self->throw('parse', "Unknown CONFIG option \"$key\"", undef, pos($$str_ref)); + } + } + for (my $i = 1; $i < @$config; $i++) { + my $key = $config->[$i] = uc $config->[$i]->[0]; + if ($ctime{$key}) { + $config->[$i] = "CONFIG $key = ".(defined($self->{$key}) ? $self->{$key} : 'undef'); + } elsif (! $rtime{$key}) { + $self->throw('parse', "Unknown CONFIG option \"$key\"", undef, pos($$str_ref)); + } + } + return $config; +} + +sub play_CONFIG { + my ($self, $config, $node, $out_ref) = @_; + + my %rtime = map {$_ => 1} @CGI::Ex::Template::CONFIG_RUNTIME; + + ### do runtime config - not many options get these + my ($named, @the_rest) = @$config; + $named = $self->play_expr($named); + @{ $self }{keys %$named} = @{ $named }{keys %$named}; + + ### show what current values are + $$out_ref .= join("\n", map { $rtime{$_} ? ("CONFIG $_ = ".(defined($self->{$_}) ? $self->{$_} : 'undef')) : $_ } @the_rest); + return; +} + +sub parse_DEBUG { + my ($self, $str_ref) = @_; + $$str_ref =~ m{ \G ([Oo][Nn] | [Oo][Ff][Ff] | [Ff][Oo][Rr][Mm][Aa][Tt]) \s* }gcx + || $self->throw('parse', "Unknown DEBUG option", undef, pos($$str_ref)); + my $ret = [lc($1)]; + if ($ret->[0] eq 'format') { + $$str_ref =~ m{ \G ([\"\']) (|.*?[^\\]) \1 \s* }gcxs + || $self->throw('parse', "Missing format string", undef, pos($$str_ref)); + $ret->[1] = $2; + } + return $ret; +} + +sub play_DEBUG { + my ($self, $ref) = @_; + if ($ref->[0] eq 'on') { + delete $self->{'_debug_off'}; + } elsif ($ref->[0] eq 'off') { + $self->{'_debug_off'} = 1; + } elsif ($ref->[0] eq 'format') { + $self->{'_debug_format'} = $ref->[1]; + } + return; +} + +sub play_DUMP { + my ($self, $dump, $node, $out_ref) = @_; + + my $conf = $self->{'DUMP'}; + return if ! $conf && defined $conf; # DUMP => 0 + $conf = {} if ref $conf ne 'HASH'; + + ### allow for handler override + my $handler = $conf->{'handler'}; + if (! $handler) { + require Data::Dumper; + my $obj = Data::Dumper->new([]); + my $meth; + foreach my $prop (keys %$conf) { $obj->$prop($conf->{$prop}) if $prop =~ /^\w+$/ && ($meth = $obj->can($prop)) } + my $sort = defined($conf->{'Sortkeys'}) ? $obj->Sortkeys : 1; + $obj->Sortkeys(sub { my $h = shift; [grep {$_ !~ $CGI::Ex::Template::QR_PRIVATE} ($sort ? sort keys %$h : keys %$h)] }); + $handler = sub { $obj->Values([@_]); $obj->Dump } + } + + my ($named, @dump) = @$dump; + push @dump, $named if ! $self->is_empty_named_args($named); # add named args back on at end - if there are some + $_ = $self->play_expr($_) foreach @dump; + + ### look for the text describing what to dump + my $info = $self->node_info($node); + my $out; + if (@dump) { + $out = $handler->(@dump && @dump == 1 ? $dump[0] : \@dump); + my $name = $info->{'text'}; + $name =~ s/^[+=~-]?\s*DUMP\s+//; + $name =~ s/\s*[+=~-]?$//; + $out =~ s/\$VAR1/$name/; + } elsif (defined($conf->{'EntireStash'}) && ! $conf->{'EntireStash'}) { + $out = ''; + } else { + $out = $handler->($self->{'_vars'}); + $out =~ s/\$VAR1/EntireStash/g; + } + + if ($conf->{'html'} || (! defined($conf->{'html'}) && $ENV{'REQUEST_METHOD'})) { + $out = $CGI::Ex::Template::SCALAR_OPS->{'html'}->($out); + $out = "
$out
"; + $out = "DUMP: File \"$info->{file}\" line $info->{line}$out" if $conf->{'header'} || ! defined $conf->{'header'}; + } else { + $out = "DUMP: File \"$info->{file}\" line $info->{line}\n $out" if $conf->{'header'} || ! defined $conf->{'header'}; + } + + $$out_ref .= $out; + return; +} + +sub parse_FILTER { + my ($self, $str_ref) = @_; + my $name = ''; + if ($$str_ref =~ m{ \G ([^\W\d]\w*) \s* = \s* }gcx) { + $name = $1; + } + + my $filter = $self->parse_expr($str_ref); + $filter = '' if ! defined $filter; + + return [$name, $filter]; +} + +sub play_FILTER { + my ($self, $ref, $node, $out_ref) = @_; + my ($name, $filter) = @$ref; + + return '' if ! @$filter; + + $self->{'FILTERS'}->{$name} = $filter if length $name; + + my $sub_tree = $node->[4]; + + ### play the block + my $out = ''; + eval { $self->execute_tree($sub_tree, \$out) }; + die $@ if $@ && ref($@) !~ /Template::Exception$/; + + my $var = [[undef, '~', $out], 0, '|', @$filter]; # make a temporary var out of it + + return $CGI::Ex::Template::DIRECTIVES->{'GET'}->[1]->($self, $var, $node, $out_ref); +} + +sub parse_LOOP { + my ($self, $str_ref, $node) = @_; + return $self->parse_expr($str_ref) + || $self->throw('parse', 'Missing variable on LOOP directive', undef, pos($$str_ref)); +} + +sub play_LOOP { + my ($self, $ref, $node, $out_ref) = @_; + + my $var = $self->play_expr($ref); + my $sub_tree = $node->[4]; + + my $global = ! $self->{'SYNTAX'} || $self->{'SYNTAX'} ne 'ht' || $self->{'GLOBAL_VARS'}; + + my $items = ref($var) eq 'ARRAY' ? $var : ! defined($var) ? [] : [$var]; + + my $i = 0; + for my $ref (@$items) { + ### setup the loop + $self->throw('loop', 'Scalar value used in LOOP') if $ref && ref($ref) ne 'HASH'; + local $self->{'_vars'} = (! $global) ? ($ref || {}) : (ref($ref) eq 'HASH') ? {%{ $self->{'_vars'} }, %$ref} : $self->{'_vars'}; + if ($self->{'LOOP_CONTEXT_VARS'} && ! $CGI::Ex::Template::QR_PRIVATE) { + $self->{'_vars'}->{'__counter__'} = ++$i; + $self->{'_vars'}->{'__first__'} = $i == 1 ? 1 : 0; + $self->{'_vars'}->{'__last__'} = $i == @$items ? 1 : 0; + $self->{'_vars'}->{'__inner__'} = $i == 1 || $i == @$items ? 0 : 1; + $self->{'_vars'}->{'__odd__'} = ($i % 2) ? 1 : 0; + } + + ### execute the sub tree + eval { $self->execute_tree($sub_tree, $out_ref) }; + if (my $err = $@) { + if (UNIVERSAL::isa($err, $CGI::Ex::Template::PACKAGE_EXCEPTION)) { + next if $err->type eq 'next'; + last if $err->type =~ /last|break/; + } + die $err; + } + } + + return; +} + +sub parse_MACRO { + my ($self, $str_ref, $node) = @_; + + my $name = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b) (?! \\.) \\s* $CGI::Ex::Template::QR_COMMENTS"}); + $self->throw('parse', "Missing macro name", undef, pos($$str_ref)) if ! defined $name; + if (! ref $name) { + $name = [ $name, 0 ]; + } + + my $args; + if ($$str_ref =~ m{ \G \( \s* }gcx) { + $args = $self->parse_args($str_ref, {positional_only => 1}); + $$str_ref =~ m{ \G \) \s* }gcx || $self->throw('parse.missing', "Missing close ')'", undef, pos($$str_ref)); + } + + $node->[6] = 1; # set a flag to keep parsing + return [$name, $args]; +} + +sub play_MACRO { + my ($self, $ref, $node, $out_ref) = @_; + my ($name, $args) = @$ref; + + ### get the sub tree + my $sub_tree = $node->[4]; + if (! $sub_tree || ! $sub_tree->[0]) { + $self->set_variable($name, undef); + return; + } elsif ($sub_tree->[0]->[0] eq 'BLOCK') { + $sub_tree = $sub_tree->[0]->[4]; + } + + 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 { + ### macros localize + my $copy = $self_copy->{'_vars'}; + local $self_copy->{'_vars'}= {%$copy}; + + ### prevent recursion + local $self_copy->{'_macro_recurse'} = $self_copy->{'_macro_recurse'} || 0; + my $max = $self_copy->{'MAX_MACRO_RECURSE'} || $CGI::Ex::Template::MAX_MACRO_RECURSE; + $self_copy->throw('macro_recurse', "MAX_MACRO_RECURSE $max reached") + if ++$self_copy->{'_macro_recurse'} > $max; + + ### set arguments + my $named = pop(@_) if $_[-1] && UNIVERSAL::isa($_[-1],'HASH') && $#_ > $#$args; + my @positional = @_; + foreach my $var (@$args) { + $self_copy->set_variable($var, shift(@positional)); + } + foreach my $name (sort keys %$named) { + $self_copy->set_variable([$name, 0], $named->{$name}); + } + + ### finally - run the sub tree + my $out = ''; + $self_copy->execute_tree($sub_tree, \$out); + return $out; + }); + + return; +} + +sub play_PERL { + my ($self, $info, $node, $out_ref) = @_; + $self->throw('perl', 'EVAL_PERL not set') if ! $self->{'EVAL_PERL'}; + + ### fill in any variables + my $perl = $node->[4] || return; + my $out = ''; + $self->execute_tree($perl, \$out); + $out = $1 if $out =~ /^(.+)$/s; # blatant untaint - shouldn't use perl anyway + + ### try the code + my $err; + eval { + package CGI::Ex::Template::Perl; + + my $context = $self->context; + my $stash = $context->stash; + + ### setup a fake handle + local *PERLOUT; + tie *PERLOUT, 'CGI::Ex::Template::EvalPerlHandle', $out_ref; + my $old_fh = select PERLOUT; + + eval $out; + $err = $@; + + ### put the handle back + select $old_fh; + + }; + $err ||= $@; + + + if ($err) { + $self->throw('undef', $err) if ref($err) !~ /Template::Exception$/; + die $err; + } + + return; +} + +sub play_RAWPERL { + my ($self, $info, $node, $out_ref) = @_; + $self->throw('perl', 'EVAL_PERL not set') if ! $self->{'EVAL_PERL'}; + + ### fill in any variables + my $tree = $node->[4] || return; + my $perl = ''; + $self->execute_tree($tree, \$perl); + $perl = $1 if $perl =~ /^(.+)$/s; # blatant untaint - shouldn't use perl anyway + + ### try the code + my $err; + my $output = ''; + eval { + package CGI::Ex::Template::Perl; + + my $context = $self->context; + my $stash = $context->stash; + + eval $perl; + $err = $@; + }; + $err ||= $@; + + $$out_ref .= $output; + + if ($err) { + $self->throw('undef', $err) if ref($err) !~ /Template::Exception$/; + die $err; + } + + return; +} + +sub parse_USE { + my ($self, $str_ref) = @_; + + my $QR_COMMENTS = $CGI::Ex::Template::QR_COMMENTS; + + my $var; + my $mark = pos $$str_ref; + if (defined(my $_var = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b) (?! \\.) \\s* $QR_COMMENTS"})) + && ($$str_ref =~ m{ \G = >? \s* $QR_COMMENTS }gcxo # make sure there is assignment + || ((pos($$str_ref) = $mark) && 0)) # otherwise we need to rollback + ) { + $var = $_var; + } + + my $module = $self->parse_expr($str_ref, {auto_quote => "(\\w+\\b (?: (?:\\.|::) \\w+\\b)*) (?! \\.) \\s* $QR_COMMENTS"}); + $self->throw('parse', "Missing plugin name while parsing $$str_ref", undef, pos($$str_ref)) if ! defined $module; + $module =~ s/\./::/g; + + my $args; + my $open = $$str_ref =~ m{ \G \( \s* $QR_COMMENTS }gcxo; + $args = $self->parse_args($str_ref, {is_parened => $open, named_at_front => 1}); + + if ($open) { + $$str_ref =~ m{ \G \) \s* $QR_COMMENTS }gcxo || $self->throw('parse.missing', "Missing close ')'", undef, pos($$str_ref)); + } + + return [$var, $module, $args]; +} + +sub play_USE { + my ($self, $ref, $node, $out_ref) = @_; + my ($var, $module, $args) = @$ref; + + ### get the stash storage location - default to the module + $var = $module if ! defined $var; + my @var = map {($_, 0, '.')} split /(?:\.|::)/, $var; + pop @var; # remove the trailing '.' + + my ($named, @args) = @$args; + push @args, $named if ! $self->is_empty_named_args($named); # add named args back on at end - if there are some + + ### look for a plugin_base + my $BASE = $self->{'PLUGIN_BASE'} || 'Template::Plugin'; # I'm not maintaining plugins - leave that to TT + my $obj; + + 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; + $obj = $shape->new($context, map { $self->play_expr($_) } @args); + } elsif (lc($module) eq 'iterator') { # use our iterator if none found (TT's works just fine) + $obj = $self->iterator($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; + $obj = $shape->new($context, map { $self->play_expr($_) } @args); + } + } elsif ($self->{'LOAD_PERL'}) { + my $require = "$module.pm"; + $require =~ s|::|/|g; + if (eval {require $require}) { + $obj = $module->new(map { $self->play_expr($_) } @args); + } + } + } + if (! defined $obj) { + my $err = "$module: plugin not found"; + $self->throw('plugin', $err); + } + + ### all good + $self->set_variable(\@var, $obj); + + return; +} + +sub parse_VIEW { + my ($self, $str_ref) = @_; + + my $ref = $self->parse_args($str_ref, { + named_at_front => 1, + require_arg => 1, + }); + + return $ref; +} + +sub play_VIEW { + my ($self, $ref, $node, $out_ref) = @_; + + my ($blocks, $args, $name) = @$ref; + + ### get args ready + # [[undef, '{}', 'key1', 'val1', 'key2', 'val2'], 0] + $args = $args->[0]; + my $hash = {}; + foreach (my $i = 2; $i < @$args; $i+=2) { + my $key = $args->[$i]; + my $val = $self->play_expr($args->[$i+1]); + if (ref $key) { + if (@$key == 2 && ! ref($key->[0]) && ! $key->[1]) { + $key = $key->[0]; + } else { + $self->set_variable($key, $val); + next; # what TT does + } + } + $hash->{$key} = $val; + } + + ### prepare the blocks + my $prefix = $hash->{'prefix'} || (ref($name) && @$name == 2 && ! $name->[1] && ! ref($name->[0])) ? "$name->[0]/" : ''; + foreach my $key (keys %$blocks) { + $blocks->{$key} = {name => "${prefix}${key}", _tree => $blocks->{$key}}; + } + $hash->{'blocks'} = $blocks; + + ### get the view + if (! eval { require Template::View }) { + $self->throw('view', 'Could not load Template::View library'); + } + my $view = Template::View->new($self->context, $hash) + || $self->throw('view', $Template::View::ERROR); + + ### 'play it' + my $old_view = $self->play_expr(['view', 0]); + $self->set_variable($name, $view); + $self->set_variable(['view', 0], $view); + + if ($node->[4]) { + my $out = ''; + $self->execute_tree($node->[4], \$out); + # throw away $out + } + + $self->set_variable(['view', 0], $old_view); + $view->seal; + + return; +} + +###----------------------------------------------------------------### + +sub list_plugins { + my $self = shift; + my $args = shift || {}; + my $base = $args->{'base'} || ''; + + return $self->{'_plugins'}->{$base} ||= do { + my @plugins; + + $base =~ s|::|/|g; + my @dirs = grep {-d $_} map {"$_/$base"} @INC; + + foreach my $dir (@dirs) { + require File::Find; + File::Find::find(sub { + my $mod = $base .'/'. ($File::Find::name =~ m|^ $dir / (.*\w) \.pm $|x ? $1 : return); + $mod =~ s|/|::|g; + push @plugins, $mod; + }, $dir); + } + + \@plugins; # return of the do + }; +} + +###----------------------------------------------------------------### + +package CGI::Ex::Template::Context; + +use vars qw($AUTOLOAD); + +sub new { + my $class = shift; + my $self = shift || {}; + die "Missing _template" if ! $self->{'_template'}; + return bless $self, $class; +} + +sub _template { shift->{'_template'} || die "Missing _template" } + +sub template { + my ($self, $name) = @_; + return $self->_template->{'BLOCKS'}->{$name} || $self->_template->load_parsed_tree($name); +} + +sub config { shift->_template } + +sub stash { + my $self = shift; + return $self->{'stash'} ||= bless {_template => $self->_template}, 'CGI::Ex::Template::_Stash'; +} + +sub insert { shift->_template->_insert(@_) } + +sub eval_perl { shift->_template->{'EVAL_PERL'} } + +sub process { + my $self = shift; + my $ref = shift; + my $args = shift || {}; + + $self->_template->set_variable($_, $args->{$_}) for keys %$args; + + my $out = ''; + $self->_template->_process($ref, $self->_template->_vars, \$out); + return $out; +} + +sub include { + my $self = shift; + my $ref = shift; + my $args = shift || {}; + + my $t = $self->_template; + + my $swap = $t->{'_vars'}; + local $t->{'_vars'} = {%$swap}; + + $t->set_variable($_, $args->{$_}) for keys %$args; + + my $out = ''; # have temp item to allow clear to correctly clear + eval { $t->_process($ref, $t->_vars, \$out) }; + if (my $err = $@) { + die $err if ref($err) !~ /Template::Exception$/ || $err->type !~ /return/; + } + + return $out; +} + +sub define_filter { + my ($self, $name, $filter, $is_dynamic) = @_; + $filter = [ $filter, 1 ] if $is_dynamic; + $self->define_vmethod('filter', $name, $filter); +} + +sub filter { + my ($self, $name, $args, $alias) = @_; + my $t = $self->_template; + + my $filter; + if (! ref $name) { + $filter = $t->{'FILTERS'}->{$name} || $CGI::Ex::Template::FILTER_OPS->{$name} || $CGI::Ex::Template::SCALAR_OPS->{$name}; + $t->throw('filter', $name) if ! $filter; + } elsif (UNIVERSAL::isa($name, 'CODE') || UNIVERSAL::isa($name, 'ARRAY')) { + $filter = $name; + } elsif (UNIVERSAL::can($name, 'factory')) { + $filter = $name->factory || $t->throw($name->error); + } else { + $t->throw('undef', "$name: filter not found"); + } + + if (UNIVERSAL::isa($filter, 'ARRAY')) { + $filter = ($filter->[1]) ? $filter->[0]->($t->context, @$args) : $filter->[0]; + } elsif ($args && @$args) { + my $sub = $filter; + $filter = sub { $sub->(shift, @$args) }; + } + + $t->{'FILTERS'}->{$alias} = $filter if $alias; + + return $filter; +} + +sub define_vmethod { shift->_template->define_vmethod(@_) } + +sub throw { + my ($self, $type, $info) = @_; + + if (UNIVERSAL::isa($type, $CGI::Ex::Template::PACKAGE_EXCEPTION)) { + die $type; + } elsif (defined $info) { + $self->_template->throw($type, $info); + } else { + $self->_template->throw('undef', $type); + } +} + +sub AUTOLOAD { shift->_template->throw('not_implemented', "The method $AUTOLOAD has not been implemented") } + +sub DESTROY {} + +###----------------------------------------------------------------### + +package CGI::Ex::Template::_Stash; + +use vars qw($AUTOLOAD); + +sub _template { shift->{'_template'} || die "Missing _template" } + +sub get { + my ($self, $var) = @_; + if (! ref $var) { + if ($var =~ /^\w+$/) { $var = [$var, 0] } + else { $var = $self->_template->parse_expr(\$var, {no_dots => 1}) } + } + return $self->_template->play_expr($var, {no_dots => 1}); +} + +sub set { + my ($self, $var, $val) = @_; + if (! ref $var) { + if ($var =~ /^\w+$/) { $var = [$var, 0] } + else { $var = $self->_template->parse_expr(\$var, {no_dots => 1}) } + } + $self->_template->set_variable($var, $val, {no_dots => 1}); + return $val; +} + +sub AUTOLOAD { shift->_template->throw('not_implemented', "The method $AUTOLOAD has not been implemented") } + +sub DESTROY {} + +###----------------------------------------------------------------### + +package CGI::Ex::Template::EvalPerlHandle; + +sub TIEHANDLE { + my ($class, $out_ref) = @_; + return bless [$out_ref], $class; +} + +sub PRINT { + my $self = shift; + ${ $self->[0] } .= $_ for grep {defined && length} @_; + return 1; +} + +###----------------------------------------------------------------### + +1;