????
Current Path : /proc/thread-self/root/usr/local/lib64/perl5/Template/ |
Current File : //proc/thread-self/root/usr/local/lib64/perl5/Template/Directive.pm |
#================================================================= -*-Perl-*- # # Template::Directive # # DESCRIPTION # Factory module for constructing templates from Perl code. # # AUTHOR # Andy Wardley <abw@wardley.org> # # WARNING # Much of this module is hairy, even furry in places. It needs # a lot of tidying up and may even be moved into a different place # altogether. The generator code is often inefficient, particularly in # being very anal about pretty-printing the Perl code all neatly, but # at the moment, that's still high priority for the sake of easier # debugging. # # COPYRIGHT # Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # #============================================================================ package Template::Directive; use strict; use warnings; use base 'Template::Base'; use Template::Constants; use Template::Exception; our $VERSION = '3.100'; our $DEBUG = 0 unless defined $DEBUG; our $WHILE_MAX = 1000 unless defined $WHILE_MAX; our $PRETTY = 0 unless defined $PRETTY; our $OUTPUT = '$output .= '; sub _init { my ($self, $config) = @_; $self->{ NAMESPACE } = $config->{ NAMESPACE }; return $self; } sub trace_vars { my $self = shift; return @_ ? ($self->{ TRACE_VARS } = shift) : $self->{ TRACE_VARS }; } sub pad { my ($text, $pad) = @_; $pad = ' ' x ($pad * 4); $text =~ s/^(?!#line)/$pad/gm; $text; } #======================================================================== # FACTORY METHODS # # These methods are called by the parser to construct directive instances. #======================================================================== #------------------------------------------------------------------------ # template($block) #------------------------------------------------------------------------ sub template { my ($self, $block) = @_; $block = pad($block, 2) if $PRETTY; return "sub { return '' }" unless $block =~ /\S/; return <<EOF; sub { my \$context = shift || die "template sub called without context\\n"; my \$stash = \$context->stash; my \$output = ''; my \$_tt_error; eval { BLOCK: { $block } }; if (\$@) { \$_tt_error = \$context->catch(\$@, \\\$output); die \$_tt_error unless \$_tt_error->type eq 'return'; } return \$output; } EOF } #------------------------------------------------------------------------ # anon_block($block) [% BLOCK %] ... [% END %] #------------------------------------------------------------------------ sub anon_block { my ($self, $block) = @_; $block = pad($block, 2) if $PRETTY; return <<EOF; # BLOCK $OUTPUT do { my \$output = ''; my \$_tt_error; eval { BLOCK: { $block } }; if (\$@) { \$_tt_error = \$context->catch(\$@, \\\$output); die \$_tt_error unless \$_tt_error->type eq 'return'; } \$output; }; EOF } #------------------------------------------------------------------------ # block($blocktext) #------------------------------------------------------------------------ sub block { my ($self, $block) = @_; return join("\n", @{ $block || [] }); } #------------------------------------------------------------------------ # textblock($text) #------------------------------------------------------------------------ sub textblock { my ($self, $text) = @_; return "$OUTPUT " . &text($self, $text) . ';'; } #------------------------------------------------------------------------ # text($text) #------------------------------------------------------------------------ sub text { my ( $self, $text ) = @_; return '' if !length $text; if ( $text =~ tr{$@\\}{} ) { $text =~ s/(["\$\@\\])/\\$1/g; $text =~ s/\n/\\n/g; return '"' . $text . '"'; } $text =~ s{'}{\\'}g if index( $text, q{'} ) != -1; return q{'} . $text . q{'}; } #------------------------------------------------------------------------ # quoted(\@items) "foo$bar" #------------------------------------------------------------------------ sub quoted { my ($self, $items) = @_; return '' unless @$items; return ("('' . " . $items->[0] . ')') if scalar @$items == 1; return '(' . join(' . ', @$items) . ')'; # my $r = '(' . join(' . ', @$items) . ' . "")'; # print STDERR "[$r]\n"; # return $r; } #------------------------------------------------------------------------ # ident(\@ident) foo.bar(baz) #------------------------------------------------------------------------ sub ident { my ($self, $ident) = @_; return "''" unless @$ident; my $ns; # Careful! Template::Parser always creates a Template::Directive object # (as of v2.22_1) so $self is usually an object. However, we used to # allow Template::Directive methods to be called as class methods and # Template::Namespace::Constants module takes advantage of this fact # by calling Template::Directive->ident() when it needs to generate an # identifier. This hack guards against Mr Fuckup from coming to town # when that happens. if (ref $self) { # trace variable usage if ($self->{ TRACE_VARS }) { my $root = $self->{ TRACE_VARS }; my $n = 0; my $v; while ($n < @$ident) { $v = $ident->[$n]; for ($v) { s/^'//; s/'$// }; $root = $root->{ $v } ||= { }; $n += 2; } } # does the first element of the identifier have a NAMESPACE # handler defined? if (@$ident > 2 && ($ns = $self->{ NAMESPACE })) { my $key = $ident->[0]; # a faster alternate to $key =~ s/^'(.+)'$/$1/s if ( index( $key, q[']) == 0 ) { substr( $key, 0, 1, '' ); substr( $key, -1, 1, '' ); # remove the last char blindly } if ($ns = $ns->{ $key }) { return $ns->ident($ident); } } } if (scalar @$ident <= 2 && ! $ident->[1]) { $ident = $ident->[0]; } else { $ident = '[' . join(', ', @$ident) . ']'; } return "\$stash->get($ident)"; } #------------------------------------------------------------------------ # identref(\@ident) \foo.bar(baz) #------------------------------------------------------------------------ sub identref { my ($self, $ident) = @_; return "''" unless @$ident; if (scalar @$ident <= 2 && ! $ident->[1]) { $ident = $ident->[0]; } else { $ident = '[' . join(', ', @$ident) . ']'; } return "\$stash->getref($ident)"; } #------------------------------------------------------------------------ # assign(\@ident, $value, $default) foo = bar #------------------------------------------------------------------------ sub assign { my ($self, $var, $val, $default) = @_; if (ref $var) { if (scalar @$var == 2 && ! $var->[1]) { $var = $var->[0]; } else { $var = '[' . join(', ', @$var) . ']'; } } $val .= ', 1' if $default; return "\$stash->set($var, $val)"; } #------------------------------------------------------------------------ # args(\@args) foo, bar, baz = qux #------------------------------------------------------------------------ sub args { my ($self, $args) = @_; my $hash = shift @$args; push(@$args, '{ ' . join(', ', @$hash) . ' }') if @$hash; return '0' unless @$args; return '[ ' . join(', ', @$args) . ' ]'; } #------------------------------------------------------------------------ # filenames(\@names) #------------------------------------------------------------------------ sub filenames { my ($self, $names) = @_; if (@$names > 1) { $names = '[ ' . join(', ', @$names) . ' ]'; } else { $names = shift @$names; } return $names; } #------------------------------------------------------------------------ # get($expr) [% foo %] #------------------------------------------------------------------------ sub get { my ($self, $expr) = @_; return "$OUTPUT $expr;"; } #------------------------------------------------------------------------ # call($expr) [% CALL bar %] #------------------------------------------------------------------------ sub call { my ($self, $expr) = @_; $expr .= ';'; return $expr; } #------------------------------------------------------------------------ # set(\@setlist) [% foo = bar, baz = qux %] #------------------------------------------------------------------------ sub set { my ($self, $setlist) = @_; my $output; while (my ($var, $val) = splice(@$setlist, 0, 2)) { $output .= &assign($self, $var, $val) . ";\n"; } chomp $output; return $output; } #------------------------------------------------------------------------ # default(\@setlist) [% DEFAULT foo = bar, baz = qux %] #------------------------------------------------------------------------ sub default { my ($self, $setlist) = @_; my $output; while (my ($var, $val) = splice(@$setlist, 0, 2)) { $output .= &assign($self, $var, $val, 1) . ";\n"; } chomp $output; return $output; } #------------------------------------------------------------------------ # insert(\@nameargs) [% INSERT file %] # # => [ [ $file, ... ], \@args ] #------------------------------------------------------------------------ sub insert { my ($self, $nameargs) = @_; my ($file, $args) = @$nameargs; $file = $self->filenames($file); return "$OUTPUT \$context->insert($file);"; } #------------------------------------------------------------------------ # include(\@nameargs) [% INCLUDE template foo = bar %] # # => [ [ $file, ... ], \@args ] #------------------------------------------------------------------------ sub include { my ($self, $nameargs) = @_; my ($file, $args) = @$nameargs; my $hash = shift @$args; $file = $self->filenames($file); $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; return "$OUTPUT \$context->include($file);"; } #------------------------------------------------------------------------ # process(\@nameargs) [% PROCESS template foo = bar %] # # => [ [ $file, ... ], \@args ] #------------------------------------------------------------------------ sub process { my ($self, $nameargs) = @_; my ($file, $args) = @$nameargs; my $hash = shift @$args; $file = $self->filenames($file); $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; return "$OUTPUT \$context->process($file);"; } #------------------------------------------------------------------------ # if($expr, $block, $else) [% IF foo < bar %] # ... # [% ELSE %] # ... # [% END %] #------------------------------------------------------------------------ sub if { my ($self, $expr, $block, $else) = @_; my @else = $else ? @$else : (); $else = pop @else; $block = pad($block, 1) if $PRETTY; my $output = "if ($expr) {\n$block\n}\n"; foreach my $elsif (@else) { ($expr, $block) = @$elsif; $block = pad($block, 1) if $PRETTY; $output .= "elsif ($expr) {\n$block\n}\n"; } if (defined $else) { $else = pad($else, 1) if $PRETTY; $output .= "else {\n$else\n}\n"; } return $output; } #------------------------------------------------------------------------ # foreach($target, $list, $args, $block) [% FOREACH x = [ foo bar ] %] # ... # [% END %] #------------------------------------------------------------------------ sub foreach { my ($self, $target, $list, $args, $block, $label) = @_; $args = shift @$args; $args = @$args ? ', { ' . join(', ', @$args) . ' }' : ''; $label ||= 'LOOP'; my ($loop_save, $loop_set, $loop_restore, $setiter); if ($target) { $loop_save = 'eval { $_tt_oldloop = ' . &ident($self, ["'loop'"]) . ' }'; $loop_set = "\$stash->{'$target'} = \$_tt_value"; $loop_restore = "\$stash->set('loop', \$_tt_oldloop)"; } else { $loop_save = '$stash = $context->localise()'; # $loop_set = "\$stash->set('import', \$_tt_value) " # . "if ref \$value eq 'HASH'"; $loop_set = "\$stash->get(['import', [\$_tt_value]]) " . "if ref \$_tt_value eq 'HASH'"; $loop_restore = '$stash = $context->delocalise()'; } $block = pad($block, 3) if $PRETTY; return <<EOF; # FOREACH do { my (\$_tt_value, \$_tt_error, \$_tt_oldloop); my \$_tt_list = $list; unless (UNIVERSAL::isa(\$_tt_list, 'Template::Iterator')) { \$_tt_list = Template::Config->iterator(\$_tt_list) || die \$Template::Config::ERROR, "\\n"; } (\$_tt_value, \$_tt_error) = \$_tt_list->get_first(); $loop_save; \$stash->set('loop', \$_tt_list); eval { $label: while (! \$_tt_error) { $loop_set; $block; (\$_tt_value, \$_tt_error) = \$_tt_list->get_next(); } }; $loop_restore; die \$@ if \$@; \$_tt_error = 0 if \$_tt_error && \$_tt_error eq Template::Constants::STATUS_DONE; die \$_tt_error if \$_tt_error; }; EOF } #------------------------------------------------------------------------ # next() [% NEXT %] # # Next iteration of a FOREACH loop (experimental) #------------------------------------------------------------------------ sub next { my ($self, $label) = @_; $label ||= 'LOOP'; return <<EOF; (\$_tt_value, \$_tt_error) = \$_tt_list->get_next(); next $label; EOF } #------------------------------------------------------------------------ # wrapper(\@nameargs, $block) [% WRAPPER template foo = bar %] # # => [ [$file,...], \@args ] #------------------------------------------------------------------------ sub wrapper { my ($self, $nameargs, $block) = @_; my ($file, $args) = @$nameargs; my $hash = shift @$args; local $" = ', '; # print STDERR "wrapper([@$file], { @$hash })\n"; return $self->multi_wrapper($file, $hash, $block) if @$file > 1; $file = shift @$file; $block = pad($block, 1) if $PRETTY; push(@$hash, "'content'", '$output'); $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; return <<EOF; # WRAPPER $OUTPUT do { my \$output = ''; $block \$context->include($file); }; EOF } sub multi_wrapper { my ($self, $file, $hash, $block) = @_; $block = pad($block, 1) if $PRETTY; push(@$hash, "'content'", '$output'); $hash = @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; $file = join(', ', reverse @$file); # print STDERR "multi wrapper: $file\n"; return <<EOF; # WRAPPER $OUTPUT do { my \$output = ''; $block foreach ($file) { \$output = \$context->include(\$_$hash); } \$output; }; EOF } #------------------------------------------------------------------------ # while($expr, $block) [% WHILE x < 10 %] # ... # [% END %] #------------------------------------------------------------------------ sub while { my ($self, $expr, $block, $label) = @_; $block = pad($block, 2) if $PRETTY; $label ||= 'LOOP'; return <<EOF; # WHILE do { my \$_tt_failsafe = $WHILE_MAX; $label: while (($expr) && --\$_tt_failsafe >= 0) { $block } die "WHILE loop terminated (> $WHILE_MAX iterations)\\n" if \$_tt_failsafe < 0; }; EOF } #------------------------------------------------------------------------ # switch($expr, \@case) [% SWITCH %] # [% CASE foo %] # ... # [% END %] #------------------------------------------------------------------------ sub switch { my ($self, $expr, $case) = @_; my @case = @$case; my ($match, $block, $default); my $caseblock = ''; $default = pop @case; foreach $case (@case) { $match = $case->[0]; $block = $case->[1]; $block = pad($block, 1) if $PRETTY; $caseblock .= <<EOF; \$_tt_match = $match; \$_tt_match = [ \$_tt_match ] unless ref \$_tt_match eq 'ARRAY'; if (grep(/^\\Q\$_tt_result\\E\$/, \@\$_tt_match)) { $block last SWITCH; } EOF } $caseblock .= $default if defined $default; $caseblock = pad($caseblock, 2) if $PRETTY; return <<EOF; # SWITCH do { my \$_tt_result = $expr; my \$_tt_match; SWITCH: { $caseblock } }; EOF } #------------------------------------------------------------------------ # try($block, \@catch) [% TRY %] # ... # [% CATCH %] # ... # [% END %] #------------------------------------------------------------------------ sub try { my ($self, $block, $catch) = @_; my @catch = @$catch; my ($match, $mblock, $default, $final, $n); my $catchblock = ''; my $handlers = []; $block = pad($block, 2) if $PRETTY; $final = pop @catch; $final = "# FINAL\n" . ($final ? "$final\n" : '') . 'die $_tt_error if $_tt_error;' . "\n" . '$output;'; $final = pad($final, 1) if $PRETTY; $n = 0; foreach $catch (@catch) { $match = $catch->[0] || do { $default ||= $catch->[1]; next; }; $mblock = $catch->[1]; $mblock = pad($mblock, 1) if $PRETTY; push(@$handlers, "'$match'"); $catchblock .= $n++ ? "elsif (\$_tt_handler eq '$match') {\n$mblock\n}\n" : "if (\$_tt_handler eq '$match') {\n$mblock\n}\n"; } $catchblock .= "\$_tt_error = 0;"; $catchblock = pad($catchblock, 3) if $PRETTY; if ($default) { $default = pad($default, 1) if $PRETTY; $default = "else {\n # DEFAULT\n$default\n \$_tt_error = '';\n}"; } else { $default = '# NO DEFAULT'; } $default = pad($default, 2) if $PRETTY; $handlers = join(', ', @$handlers); return <<EOF; # TRY $OUTPUT do { my \$output = ''; my (\$_tt_error, \$_tt_handler); eval { $block }; if (\$@) { \$_tt_error = \$context->catch(\$@, \\\$output); die \$_tt_error if \$_tt_error->type =~ /^(return|stop)\$/; \$stash->set('error', \$_tt_error); \$stash->set('e', \$_tt_error); if (defined (\$_tt_handler = \$_tt_error->select_handler($handlers))) { $catchblock } $default } $final }; EOF } #------------------------------------------------------------------------ # throw(\@nameargs) [% THROW foo "bar error" %] # # => [ [$type], \@args ] #------------------------------------------------------------------------ sub throw { my ($self, $nameargs) = @_; my ($type, $args) = @$nameargs; my $hash = shift(@$args); my $info = shift(@$args); $type = shift @$type; # uses same parser production as INCLUDE # etc., which allow multiple names # e.g. INCLUDE foo+bar+baz if (! $info) { $args = "$type, undef"; } elsif (@$hash || @$args) { local $" = ', '; my $i = 0; $args = "$type, { args => [ " . join(', ', $info, @$args) . ' ], ' . join(', ', (map { "'" . $i++ . "' => $_" } ($info, @$args)), @$hash) . ' }'; } else { $args = "$type, $info"; } return "\$context->throw($args, \\\$output);"; } #------------------------------------------------------------------------ # clear() [% CLEAR %] # # NOTE: this is redundant, being hard-coded (for now) into Parser.yp #------------------------------------------------------------------------ sub clear { return "\$output = '';"; } #------------------------------------------------------------------------ # break() [% BREAK %] # # NOTE: this is redundant, being hard-coded (for now) into Parser.yp #------------------------------------------------------------------------ sub OLD_break { return 'last LOOP;'; } #------------------------------------------------------------------------ # return() [% RETURN %] #------------------------------------------------------------------------ sub return { return "\$context->throw('return', '', \\\$output);"; } #------------------------------------------------------------------------ # stop() [% STOP %] #------------------------------------------------------------------------ sub stop { return "\$context->throw('stop', '', \\\$output);"; } #------------------------------------------------------------------------ # use(\@lnameargs) [% USE alias = plugin(args) %] # # => [ [$file, ...], \@args, $alias ] #------------------------------------------------------------------------ sub use { my ($self, $lnameargs) = @_; my ($file, $args, $alias) = @$lnameargs; $file = shift @$file; # same production rule as INCLUDE $alias ||= $file; $args = &args($self, $args); $file .= ", $args" if $args; # my $set = &assign($self, $alias, '$plugin'); return "# USE\n" . "\$stash->set($alias,\n" . " \$context->plugin($file));"; } #------------------------------------------------------------------------ # view(\@nameargs, $block) [% VIEW name args %] # # => [ [$file, ... ], \@args ] #------------------------------------------------------------------------ sub view { my ($self, $nameargs, $block, $defblocks) = @_; my ($name, $args) = @$nameargs; my $hash = shift @$args; $name = shift @$name; # same production rule as INCLUDE $block = pad($block, 1) if $PRETTY; if (%$defblocks) { $defblocks = join(",\n", map { "'$_' => $defblocks->{ $_ }" } keys %$defblocks); $defblocks = pad($defblocks, 1) if $PRETTY; $defblocks = "{\n$defblocks\n}"; push(@$hash, "'blocks'", $defblocks); } $hash = @$hash ? '{ ' . join(', ', @$hash) . ' }' : ''; return <<EOF; # VIEW do { my \$output = ''; my \$_tt_oldv = \$stash->get('view'); my \$_tt_view = \$context->view($hash); \$stash->set($name, \$_tt_view); \$stash->set('view', \$_tt_view); $block \$stash->set('view', \$_tt_oldv); \$_tt_view->seal(); # \$output; # not used - commented out to avoid warning }; EOF } #------------------------------------------------------------------------ # perl($block) #------------------------------------------------------------------------ sub perl { my ($self, $block) = @_; $block = pad($block, 1) if $PRETTY; return <<EOF; # PERL \$context->throw('perl', 'EVAL_PERL not set') unless \$context->eval_perl(); $OUTPUT do { my \$output = "package Template::Perl;\\n"; $block local(\$Template::Perl::context) = \$context; local(\$Template::Perl::stash) = \$stash; my \$_tt_result = ''; tie *Template::Perl::PERLOUT, 'Template::TieString', \\\$_tt_result; my \$_tt_save_stdout = select *Template::Perl::PERLOUT; eval \$output; select \$_tt_save_stdout; \$context->throw(\$@) if \$@; \$_tt_result; }; EOF } #------------------------------------------------------------------------ # no_perl() #------------------------------------------------------------------------ sub no_perl { my $self = shift; return "\$context->throw('perl', 'EVAL_PERL not set');"; } #------------------------------------------------------------------------ # rawperl($block) # # NOTE: perhaps test context EVAL_PERL switch at compile time rather than # runtime? #------------------------------------------------------------------------ sub rawperl { my ($self, $block, $line) = @_; for ($block) { s/^\n+//; s/\n+$//; } $block = pad($block, 1) if $PRETTY; $line = $line ? " (starting line $line)" : ''; return <<EOF; # RAWPERL #line 1 "RAWPERL block$line" $block EOF } #------------------------------------------------------------------------ # filter() #------------------------------------------------------------------------ sub filter { my ($self, $lnameargs, $block) = @_; my ($name, $args, $alias) = @$lnameargs; $name = shift @$name; $args = &args($self, $args); $args = $args ? "$args, $alias" : ", undef, $alias" if $alias; $name .= ", $args" if $args; $block = pad($block, 1) if $PRETTY; return <<EOF; # FILTER $OUTPUT do { my \$output = ''; my \$_tt_filter = \$context->filter($name) || \$context->throw(\$context->error); $block &\$_tt_filter(\$output); }; EOF } #------------------------------------------------------------------------ # capture($name, $block) #------------------------------------------------------------------------ sub capture { my ($self, $name, $block) = @_; if (ref $name) { if (scalar @$name == 2 && ! $name->[1]) { $name = $name->[0]; } else { $name = '[' . join(', ', @$name) . ']'; } } $block = pad($block, 1) if $PRETTY; return <<EOF; # CAPTURE \$stash->set($name, do { my \$output = ''; $block \$output; }); EOF } #------------------------------------------------------------------------ # macro($name, $block, \@args) #------------------------------------------------------------------------ sub macro { my ($self, $ident, $block, $args) = @_; $block = pad($block, 2) if $PRETTY; if ($args) { my $nargs = scalar @$args; $args = join(', ', map { "'$_'" } @$args); $args = $nargs > 1 ? "\@_tt_args{ $args } = splice(\@_, 0, $nargs)" : "\$_tt_args{ $args } = shift"; return <<EOF; # MACRO \$stash->set('$ident', sub { my \$output = ''; my (%_tt_args, \$_tt_params); $args; \$_tt_params = shift; \$_tt_params = { } unless ref(\$_tt_params) eq 'HASH'; \$_tt_params = { \%_tt_args, %\$_tt_params }; my \$stash = \$context->localise(\$_tt_params); eval { $block }; \$stash = \$context->delocalise(); die \$@ if \$@; return \$output; }); EOF } else { return <<EOF; # MACRO \$stash->set('$ident', sub { my \$_tt_params = \$_[0] if ref(\$_[0]) eq 'HASH'; my \$output = ''; my \$stash = \$context->localise(\$_tt_params); eval { $block }; \$stash = \$context->delocalise(); die \$@ if \$@; return \$output; }); EOF } } sub debug { my ($self, $nameargs) = @_; my ($file, $args) = @$nameargs; my $hash = shift @$args; $args = join(', ', @$file, @$args); $args .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; return "$OUTPUT \$context->debugging($args); ## DEBUG ##"; } 1; __END__ =head1 NAME Template::Directive - Perl code generator for template directives =head1 SYNOPSIS # no user serviceable parts inside =head1 DESCRIPTION The C<Template::Directive> module defines a number of methods that generate Perl code for the runtime representation of the various Template Toolkit directives. It is used internally by the L<Template::Parser> module. =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2022 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<Template::Parser> =cut # Local Variables: # mode: perl # perl-indent-level: 4 # indent-tabs-mode: nil # End: # # vim: expandtab shiftwidth=4: