From 3fe8e76eb82e9d74f656674c5ba913950e166ab1 Mon Sep 17 00:00:00 2001 From: Paul Seamons Date: Thu, 8 Jun 2006 00:00:00 +0000 Subject: [PATCH] CGI::Ex 2.02 --- CGI-Ex.spec | 2 +- Changes | 14 + MANIFEST | 1 - META.yml | 2 +- lib/CGI/Ex.pm | 2 +- lib/CGI/Ex/App.pm | 20 +- lib/CGI/Ex/Auth.pm | 13 +- lib/CGI/Ex/Conf.pm | 25 +- lib/CGI/Ex/Dump.pm | 2 +- lib/CGI/Ex/Fill.pm | 2 +- lib/CGI/Ex/Template.pm | 520 ++++++++++++++++---------- lib/CGI/Ex/Template.pod | 644 +++++++++++++++++++++++--------- lib/CGI/Ex/Validate.pm | 2 +- lib/CGI/Ex/validate.js | 5 +- samples/benchmark/bench_auth.pl | 1 + t/1_validate_07_yaml.t | 4 +- t/1_validate_08_yaml_file.t | 4 +- t/1_validate_14_untaint.t | 13 +- t/3_conf_01_write.t | 2 +- t/7_template_00_base.t | 86 ++++- t/8_auth_00_base.t | 1 + 21 files changed, 944 insertions(+), 421 deletions(-) diff --git a/CGI-Ex.spec b/CGI-Ex.spec index f0ab4d9..41ddd24 100644 --- a/CGI-Ex.spec +++ b/CGI-Ex.spec @@ -1,5 +1,5 @@ %define name CGI-Ex -%define version 2.00 +%define version 2.02 %define __find_provides %( echo -n /usr/lib/rpm/find-provides && [ -x /usr/lib/rpm/find-provides.perl ] && echo .perl ) %define __find_requires %( echo -n /usr/lib/rpm/find-requires && [ -x /usr/lib/rpm/find-requires.perl ] && echo .perl ) diff --git a/Changes b/Changes index f11632b..12a29df 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,17 @@ +2.02 2006-06-08 + * Fix the yaml tests + * Add failed_sleep to Auth + * Various pod fixes + * Allow for conf_read and write errors to die - we really do need to have those bubble up. + * Fix all tests + * Allow for validate.js to work with existing onsubmit handlers of forms + * Added "as" virtual methods to Template + * Added Virtual Objects to Template + * Added self modifiers (*= etc) to Template + * Added increment and decrement (++ --) to Template + * Allow for scientific notation and hexidecimal in Template + * Added int, rand and random virtual methods to Template + 2.01 2006-05-31 * Added App refine_path hook. * Added App destroy method. diff --git a/MANIFEST b/MANIFEST index bfbd9b8..d57f9bd 100644 --- a/MANIFEST +++ b/MANIFEST @@ -14,7 +14,6 @@ lib/CGI/Ex/Template.pm lib/CGI/Ex/Template.pod lib/CGI/Ex/validate.js lib/CGI/Ex/Validate.pm -lib/CGI/Ex/Var.pm lib/CGI/Ex/yaml_load.js Makefile.PL MANIFEST diff --git a/META.yml b/META.yml index 8eeae39..690896c 100644 --- a/META.yml +++ b/META.yml @@ -1,7 +1,7 @@ # http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: CGI-Ex -version: 2.01 +version: 2.02 version_from: lib/CGI/Ex.pm installdirs: site requires: diff --git a/lib/CGI/Ex.pm b/lib/CGI/Ex.pm index 952bf7a..42f7b64 100644 --- a/lib/CGI/Ex.pm +++ b/lib/CGI/Ex.pm @@ -24,7 +24,7 @@ use vars qw($VERSION use base qw(Exporter); BEGIN { - $VERSION = '2.01'; + $VERSION = '2.02'; $PREFERRED_CGI_MODULE ||= 'CGI'; @EXPORT = (); @EXPORT_OK = qw(get_form diff --git a/lib/CGI/Ex/App.pm b/lib/CGI/Ex/App.pm index 313baf4..11e3965 100644 --- a/lib/CGI/Ex/App.pm +++ b/lib/CGI/Ex/App.pm @@ -10,7 +10,7 @@ use strict; use vars qw($VERSION); BEGIN { - $VERSION = '2.01'; + $VERSION = '2.02'; Time::HiRes->import('time') if eval {require Time::HiRes}; } @@ -757,15 +757,17 @@ sub print { sub print_out { my ($self, $step, $out) = @_; - $self->cgix->print_content_type(); + $self->cgix->print_content_type; print $out; } sub swap_template { my ($self, $step, $file, $swap) = @_; - require CGI::Ex::Template; my $args = $self->run_hook('template_args', $step); + $args->{'INCLUDE_PATH'} ||= sub { $self->base_dir_abs || die "Could not find base_dir_abs while looking for template INCLUDE_PATH on step \"$step\"" }; + + require CGI::Ex::Template; my $t = CGI::Ex::Template->new($args); my $out = ''; @@ -774,13 +776,7 @@ sub swap_template { return $out; } -sub template_args { - my $self = shift; - my $step = shift; - return { - INCLUDE_PATH => sub { $self->base_dir_abs || die "Could not find base_dir_abs while looking for template INCLUDE_PATH on step \"$step\"" }, - }; -} +sub template_args { {} } sub fill_template { my ($self, $step, $outref, $fill) = @_; @@ -936,9 +932,9 @@ sub hash_validation { if (ref($file) && ! UNIVERSAL::isa($file, 'SCALAR')) { $hash = $file; - ### read the file - if it fails - errors should be in the webserver error logs + ### read the file - if it is not found, errors will be in the webserver logs (all else dies) } elsif ($file) { - $hash = eval { $self->vob->get_validation($file) } || {}; + $hash = $self->vob->get_validation($file) || {}; } else { $hash = {}; diff --git a/lib/CGI/Ex/Auth.pm b/lib/CGI/Ex/Auth.pm index 2169318..2208427 100644 --- a/lib/CGI/Ex/Auth.pm +++ b/lib/CGI/Ex/Auth.pm @@ -18,7 +18,7 @@ use MIME::Base64 qw(encode_base64 decode_base64); use Digest::MD5 qw(md5_hex); use CGI::Ex; -$VERSION = '2.01'; +$VERSION = '2.02'; ###----------------------------------------------------------------### @@ -144,6 +144,10 @@ sub get_valid_auth { $self->login_print; my $data = $self->last_auth_data; eval { die defined($data) ? $data : "Requesting credentials" }; + + ### allow for a sleep to help prevent brute force + sleep($self->failed_sleep) if defined($data) && $data->error ne 'Login expired' && $self->failed_sleep; + return; } @@ -226,6 +230,7 @@ sub use_blowfish { shift->{'use_blowfish'} ||= '' } sub use_plaintext { my $s = shift; $s->use_crypt || ($s->{'use_plaintext'} ||= 0) } sub use_base64 { my $s = shift; $s->{'use_base64'} = 1 if ! defined $s->{'use_base64'}; $s->{'use_base64'} } sub expires_min { my $s = shift; $s->{'expires_min'} = 6 * 60 if ! defined $s->{'expires_min'}; $s->{'expires_min'} } +sub failed_sleep { shift->{'failed_sleep'} ||= 0 } sub logout_redirect { my $self = shift; @@ -987,6 +992,12 @@ This value will have no effect when use_plaintext or use_crypt is set. A value of -1 means no expiration. +=item C + +Number of seconds to sleep if the passed tokens are invalid. Does not apply +if validation failed because of expired tokens. Default value is 0. +Setting to 0 disables any sleeping. + =item C The name of the html login form to attach the javascript to. Default is "cea_form". diff --git a/lib/CGI/Ex/Conf.pm b/lib/CGI/Ex/Conf.pm index 5bcedfd..82c76dc 100644 --- a/lib/CGI/Ex/Conf.pm +++ b/lib/CGI/Ex/Conf.pm @@ -28,7 +28,7 @@ use vars qw($VERSION ); @EXPORT_OK = qw(conf_read conf_write); -$VERSION = '2.01'; +$VERSION = '2.02'; $DEFAULT_EXT = 'conf'; @@ -131,10 +131,14 @@ sub conf_read { ### determine the handler my $handler = $EXT_READERS{$ext} || croak "Unknown file extension: $ext"; - return eval { scalar $handler->($file, $args) } || do { - warn "Couldn't read $file: $@ " if ! $args->{no_warn_on_fail}; - return undef; - }; + ### don't die if the file is not found - do die otherwise + if (! -e $file) { + eval { die "Conf file $file not found" }; + warn "Conf file $file not found" if ! $args->{'no_warn_on_fail'}; + return; + } + + return eval { scalar $handler->($file, $args) } || die "Error while reading conf file $file\n$@"; } sub read_ref { @@ -419,12 +423,7 @@ sub conf_write { $handler = $EXT_WRITERS{$ext} || croak "Unknown file extension: $ext"; } - return eval { scalar $handler->($file, $conf, $args) } || do { - warn "Couldn't write $file: $@ " if ! $args->{no_warn_on_fail}; - return 0; - }; - - return 1; + return eval { scalar $handler->($file, $conf, $args) } || die "Error while writing conf file $file\n$@"; } sub write_ref { @@ -753,6 +752,8 @@ overwritable) by adding a suffix of _immutable or _immu to the key (ie matches $IMMUTABLE_KEY, the entire file is considered immutable. The immutable defaults may be overriden using $IMMUTABLE_QR and $IMMUTABLE_KEY. +Errors during read die. If the file does not exist undef is returned. + =item C<-Ewrite_ref> Takes a file and the reference to be written. Figures out the type @@ -766,6 +767,8 @@ paths where used - the directive 'FIRST' will write the changes to the first file in the path - otherwise the last path will be used. If ->read had found immutable keys, then those keys are removed before writing. +Errors during write die. + =item C<-Epreload_files> Arguments are file(s) and/or directory(s) to preload. preload_files will diff --git a/lib/CGI/Ex/Dump.pm b/lib/CGI/Ex/Dump.pm index d93a8ca..7a2e7aa 100644 --- a/lib/CGI/Ex/Dump.pm +++ b/lib/CGI/Ex/Dump.pm @@ -17,7 +17,7 @@ use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION use strict; use Exporter; -$VERSION = '2.01'; +$VERSION = '2.02'; @ISA = qw(Exporter); @EXPORT = qw(dex dex_warn dex_text dex_html ctrace dex_trace); @EXPORT_OK = qw(dex dex_warn dex_text dex_html ctrace dex_trace debug); diff --git a/lib/CGI/Ex/Fill.pm b/lib/CGI/Ex/Fill.pm index b90acf9..ee6d2a1 100644 --- a/lib/CGI/Ex/Fill.pm +++ b/lib/CGI/Ex/Fill.pm @@ -24,7 +24,7 @@ use vars qw($VERSION use base qw(Exporter); BEGIN { - $VERSION = '2.01'; + $VERSION = '2.02'; @EXPORT = qw(form_fill); @EXPORT_OK = qw(fill form_fill html_escape get_tagval_by_key swap_tagval_by_key); }; diff --git a/lib/CGI/Ex/Template.pm b/lib/CGI/Ex/Template.pm index f326155..3703367 100644 --- a/lib/CGI/Ex/Template.pm +++ b/lib/CGI/Ex/Template.pm @@ -10,21 +10,24 @@ use strict; use constant trace => $ENV{'CET_TRACE'} || 0; # enable for low level tracing use vars qw($VERSION $TAGS - $SCALAR_OPS $HASH_OPS $LIST_OPS $FILTER_OPS + $SCALAR_OPS $HASH_OPS $LIST_OPS $FILTER_OPS $VOBJS $DIRECTIVES $QR_DIRECTIVE $OPERATORS - $OP_UNARY - $OP_BINARY - $OP_TRINARY $OP_DISPATCH + $OP_ASSIGN + $OP + $OP_PREFIX + $OP_POSTFIX + $OP_TERNARY $QR_OP - $QR_OP_UNARY - $QR_OP_PARENED + $QR_OP_PREFIX + $QR_OP_ASSIGN $QR_COMMENTS $QR_FILENAME + $QR_NUM $QR_AQ_NOTDOT $QR_AQ_SPACE $QR_PRIVATE @@ -36,7 +39,7 @@ use vars qw($VERSION ); BEGIN { - $VERSION = '2.01'; + $VERSION = '2.02'; $PACKAGE_EXCEPTION = 'CGI::Ex::Template::Exception'; $PACKAGE_ITERATOR = 'CGI::Ex::Template::Iterator'; @@ -44,7 +47,7 @@ BEGIN { $PACKAGE_STASH = 'CGI::Ex::Template::_Stash'; $PACKAGE_PERL_HANDLE = 'CGI::Ex::Template::EvalPerlHandle'; - $TAGS ||= { + $TAGS = { default => ['[%', '%]'], # default template => ['[%', '%]'], # default metatext => ['%%', '%%'], # Text::MetaText @@ -55,19 +58,25 @@ BEGIN { html => [''], # HTML comments }; - $SCALAR_OPS ||= { + $SCALAR_OPS = { + '0' => sub { shift }, + as => \&vmethod_as_scalar, chunk => \&vmethod_chunk, collapse => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; s/\s+/ /g; $_ }, defined => sub { 1 }, indent => \&vmethod_indent, + int => sub { local $^W; int $_[0] }, 'format' => \&vmethod_format, hash => sub { {value => $_[0]} }, html => sub { local $_ = $_[0]; s/&/&/g; s//>/g; s/\"/"/g; $_ }, lcfirst => sub { lcfirst $_[0] }, length => sub { defined($_[0]) ? length($_[0]) : 0 }, + list => sub { [$_[0]] }, lower => sub { lc $_[0] }, match => \&vmethod_match, + new => sub { defined $_[0] ? $_[0] : '' }, null => sub { '' }, + rand => sub { local $^W; rand shift }, remove => sub { vmethod_replace(shift, shift, '', 1) }, repeat => \&vmethod_repeat, replace => \&vmethod_replace, @@ -82,25 +91,28 @@ BEGIN { uri => \&vmethod_uri, }; - $FILTER_OPS ||= { # generally - non-dynamic filters belong in scalar ops + $FILTER_OPS = { # generally - non-dynamic filters belong in scalar ops eval => [\&filter_eval, 1], evaltt => [\&filter_eval, 1], file => [\&filter_redirect, 1], redirect => [\&filter_redirect, 1], }; - $LIST_OPS ||= { + $LIST_OPS = { + as => \&vmethod_as_list, first => sub { my ($ref, $i) = @_; return $ref->[0] if ! $i; return [@{$ref}[0 .. $i - 1]]}, grep => sub { my ($ref, $pat) = @_; [grep {/$pat/} @$ref] }, - hash => sub { my ($list, $i) = @_; defined($i) ? {map {$i++ => $_} @$list} : {@$list} }, + 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 }, last => sub { my ($ref, $i) = @_; return $ref->[-1] if ! $i; return [@{$ref}[-$i .. -1]]}, list => sub { $_[0] }, max => sub { $#{ $_[0] } }, merge => sub { my $ref = shift; return [ @$ref, grep {defined} map {ref eq 'ARRAY' ? @$_ : undef} @_ ] }, + new => sub { local $^W; return [@_] }, nsort => \&vmethod_nsort, pop => sub { pop @{ $_[0] } }, push => sub { my $ref = shift; push @$ref, @_; return '' }, + random => sub { my $ref = shift; $ref->[ rand @$ref ] }, reverse => sub { [ reverse @{ $_[0] } ] }, shift => sub { shift @{ $_[0] } }, size => sub { scalar @{ $_[0] } }, @@ -111,24 +123,39 @@ BEGIN { unshift => sub { my $ref = shift; unshift @$ref, @_; return '' }, }; - $HASH_OPS ||= { + $HASH_OPS = { + as => \&vmethod_as_hash, defined => sub { return '' if ! defined $_[1]; defined $_[0]->{ $_[1] } }, delete => sub { return '' if ! defined $_[1]; delete $_[0]->{ $_[1] } }, each => sub { [%{ $_[0] }] }, exists => sub { return '' if ! defined $_[1]; exists $_[0]->{ $_[1] } }, 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} }, + items => sub { [ %{ $_[0] } ] }, keys => sub { [keys %{ $_[0] }] }, list => sub { [$_[0]] }, - pairs => sub { [map { {key => $_, value => $_[0]->{$_}} } keys %{ $_[0] } ] }, + new => sub { local $^W; return (@_ == 1 && ref $_[-1] eq 'HASH') ? $_[-1] : {@_} }, nsort => sub { my $ref = shift; [sort {$ref->{$a} <=> $ref->{$b} } keys %$ref] }, + pairs => sub { [map { {key => $_, value => $_[0]->{$_}} } keys %{ $_[0] } ] }, size => sub { scalar keys %{ $_[0] } }, sort => sub { my $ref = shift; [sort {lc $ref->{$a} cmp lc $ref->{$b}} keys %$ref] }, values => sub { [values %{ $_[0] }] }, }; + $VOBJS = { + Text => $SCALAR_OPS, + List => $LIST_OPS, + Hash => $HASH_OPS, + }; + foreach (values %$VOBJS) { + $_->{'Text'} = $_->{'as'}; + $_->{'Hash'} = $_->{'hash'}; + $_->{'List'} = $_->{'list'}; + } + $DIRECTIVES = { - #name #parse_sub #play_sub #block #postdir #continue #move_to_front + #name parse_sub play_sub block postdir continue move_to_front BLOCK => [\&parse_BLOCK, \&play_BLOCK, 1, 0, 0, 1], BREAK => [sub {}, \&play_control], CALL => [\&parse_CALL, \&play_CALL], @@ -175,67 +202,80 @@ BEGIN { $QR_DIRECTIVE = qr{ ^ (\w+|\|) (?= $|[\s;\#]) }x; ### setup the operator parsing - $OPERATORS ||= [ - # name => # order, precedence, symbols, only_in_parens, sub to create - [2, 96, ['**', '^', 'pow'], 0, sub { $_[0] ** $_[1] } ], - [1, 93, ['!'], 0, sub { ! $_[0] } ], - [1, 93, ['-'], 0, sub { @_ == 1 ? 0 - $_[0] : $_[0] - $_[1] } ], - [2, 90, ['*'], 0, sub { $_[0] * $_[1] } ], - [2, 90, ['/'], 0, sub { $_[0] / $_[1] } ], - [2, 90, ['div', 'DIV'], 0, sub { int($_[0] / $_[1]) } ], - [2, 90, ['%', 'mod', 'MOD'], 0, sub { $_[0] % $_[1] } ], - [2, 85, ['+'], 0, sub { $_[0] + $_[1] } ], - [2, 85, ['-'], 0, sub { @_ == 1 ? 0 - $_[0] : $_[0] - $_[1] } ], - [2, 85, ['_', '~'], 0, sub { join "", @_ } ], - [2, 80, ['<'], 0, sub { $_[0] < $_[1] } ], - [2, 80, ['>'], 0, sub { $_[0] > $_[1] } ], - [2, 80, ['<='], 0, sub { $_[0] <= $_[1] } ], - [2, 80, ['>='], 0, sub { $_[0] >= $_[1] } ], - [2, 80, ['lt'], 0, sub { $_[0] lt $_[1] } ], - [2, 80, ['gt'], 0, sub { $_[0] gt $_[1] } ], - [2, 80, ['le'], 0, sub { $_[0] le $_[1] } ], - [2, 80, ['ge'], 0, sub { $_[0] ge $_[1] } ], - [2, 75, ['==', 'eq'], 0, sub { $_[0] eq $_[1] } ], - [2, 75, ['!=', 'ne'], 0, sub { $_[0] ne $_[1] } ], - [2, 70, ['&&'], 0, undef ], - [2, 65, ['||'], 0, undef ], - [2, 60, ['..'], 0, sub { $_[0] .. $_[1] } ], - [3, 55, ['?', ':'], 0, undef ], - [2, 52, ['='], 1, undef ], - [1, 50, ['not', 'NOT'], 0, sub { ! $_[0] } ], - [2, 45, ['and', 'AND'], 0, undef ], - [2, 40, ['or', 'OR'], 0, undef ], - [0, 0, ['hash'], 0, sub { return {@_}; } ], - [0, 0, ['array'], 0, sub { return [@_] } ], + $OPERATORS = [ + # type precedence symbols action (undef means play_operator will handle) + ['prefix', 98, ['++'], undef ], + ['prefix', 98, ['--'], undef ], + ['postfix', 98, ['++'], undef ], + ['postfix', 98, ['--'], undef ], + ['infix', 96, ['**', 'pow'], sub { $_[0] ** $_[1] } ], + ['prefix', 93, ['!'], sub { ! $_[0] } ], + ['prefix', 93, ['-'], sub { @_ == 1 ? 0 - $_[0] : $_[0] - $_[1] } ], + ['infix', 90, ['*'], sub { $_[0] * $_[1] } ], + ['infix', 90, ['/'], sub { $_[0] / $_[1] } ], + ['infix', 90, ['div', 'DIV'], sub { int($_[0] / $_[1]) } ], + ['infix', 90, ['%', 'mod', 'MOD'], sub { $_[0] % $_[1] } ], + ['infix', 85, ['+'], sub { $_[0] + $_[1] } ], + ['infix', 85, ['-'], sub { @_ == 1 ? 0 - $_[0] : $_[0] - $_[1] } ], + ['infix', 85, ['~', '_'], sub { join "", @_ } ], + ['infix', 80, ['<'], sub { $_[0] < $_[1] } ], + ['infix', 80, ['>'], sub { $_[0] > $_[1] } ], + ['infix', 80, ['<='], sub { $_[0] <= $_[1] } ], + ['infix', 80, ['>='], sub { $_[0] >= $_[1] } ], + ['infix', 80, ['lt'], sub { $_[0] lt $_[1] } ], + ['infix', 80, ['gt'], sub { $_[0] gt $_[1] } ], + ['infix', 80, ['le'], sub { $_[0] le $_[1] } ], + ['infix', 80, ['ge'], sub { $_[0] ge $_[1] } ], + ['infix', 75, ['==', 'eq'], sub { $_[0] eq $_[1] } ], + ['infix', 75, ['!=', 'ne'], sub { $_[0] ne $_[1] } ], + ['infix', 70, ['&&'], undef ], + ['infix', 65, ['||'], undef ], + ['infix', 60, ['..'], sub { $_[0] .. $_[1] } ], + ['ternary', 55, ['?', ':'], undef ], + ['assign', 53, ['+='], sub { $_[0] + $_[1] } ], + ['assign', 53, ['-='], sub { $_[0] - $_[1] } ], + ['assign', 53, ['*='], sub { $_[0] * $_[1] } ], + ['assign', 53, ['/='], sub { $_[0] / $_[1] } ], + ['assign', 53, ['%='], sub { $_[0] % $_[1] } ], + ['assign', 53, ['**='], sub { $_[0]** $_[1] } ], + ['assign', 53, ['~=', '_='], sub { $_[0] . $_[1] } ], + ['assign', 52, ['='], undef ], + ['prefix', 50, ['not', 'NOT'], sub { ! $_[0] } ], + ['infix', 45, ['and', 'AND'], undef ], + ['infix', 40, ['or', 'OR'], undef ], + ['', 0, ['hash'], sub { return {@_}; } ], + ['', 0, ['array'], sub { return [@_] } ], ]; - $OP_DISPATCH ||= {map {my $ref = $_; map {$_ => $ref->[4]} @{$ref->[2]}} @$OPERATORS}; - $OP_UNARY ||= {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] == 1} @$OPERATORS}; - $OP_BINARY ||= {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] == 2} @$OPERATORS}; - $OP_TRINARY ||= {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] == 3} @$OPERATORS}; + $OP = {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] ne 'prefix' } @$OPERATORS}; # all non-prefix + $OP_PREFIX = {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] eq 'prefix' } @$OPERATORS}; + $OP_DISPATCH = {map {my $ref = $_; map {$_ => $ref->[3]} @{$ref->[2]}} grep {$_->[3] } @$OPERATORS}; + $OP_ASSIGN = {map {my $ref = $_; map {$_ => 1} @{$ref->[2]}} grep {$_->[0] eq 'assign' } @$OPERATORS}; + $OP_POSTFIX = {map {my $ref = $_; map {$_ => 1} @{$ref->[2]}} grep {$_->[0] eq 'postfix'} @$OPERATORS}; # bool is postfix + $OP_TERNARY = {map {my $ref = $_; map {$_ => 1} @{$ref->[2]}} grep {$_->[0] eq 'ternary'} @$OPERATORS}; # bool is ternary sub _op_qr { # no mixed \w\W operators my %used; - my $chrs = join '|', map {quotemeta $_} grep {++$used{$_} < 2} grep {/^\W{2,}$/} @_; - my $chr = join '', map {quotemeta $_} grep {++$used{$_} < 2} grep {/^\W$/} @_; - my $word = join '|', grep {++$used{$_} < 2} grep {/^\w+$/} @_; + my $chrs = join '|', reverse sort map {quotemeta $_} grep {++$used{$_} < 2} grep {/^\W{2,}$/} @_; + my $chr = join '', sort map {quotemeta $_} grep {++$used{$_} < 2} grep {/^\W$/} @_; + my $word = join '|', reverse sort grep {++$used{$_} < 2} grep {/^\w+$/} @_; $chr = "[$chr]" if $chr; $word = "\\b(?:$word)\\b" if $word; return join('|', grep {length} $chrs, $chr, $word) || die "Missing operator regex"; } - sub _build_op_qr { _op_qr(sort map {@{ $_->[2] }} grep {$_->[0] > 1 && ! $_->[3]} @$OPERATORS) } # all binary, trinary, non-parened ops - sub _build_op_qr_unary { _op_qr(sort map {@{ $_->[2] }} grep {$_->[0] == 1 } @$OPERATORS) } # unary operators - sub _build_op_qr_paren { _op_qr(sort map {@{ $_->[2] }} grep { $_->[3]} @$OPERATORS) } # paren - $QR_OP ||= _build_op_qr(); - $QR_OP_UNARY ||= _build_op_qr_unary(); - $QR_OP_PARENED ||= _build_op_qr_paren(); - + sub _build_op_qr { _op_qr(map {@{ $_->[2] }} grep {$_->[0] ne 'prefix'} @$OPERATORS) } + sub _build_op_qr_prefix { _op_qr(map {@{ $_->[2] }} grep {$_->[0] eq 'prefix'} @$OPERATORS) } + sub _build_op_qr_assign { _op_qr(map {@{ $_->[2] }} grep {$_->[0] eq 'assign'} @$OPERATORS) } + $QR_OP = _build_op_qr(); + $QR_OP_PREFIX = _build_op_qr_prefix(); + $QR_OP_ASSIGN = _build_op_qr_assign(); $QR_COMMENTS = '(?-s: \# .* \s*)*'; $QR_FILENAME = '([a-zA-Z]]:/|/)? [\w\-\.]+ (?:/[\w\-\.]+)*'; + $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; + $WHILE_MAX = 1000; $EXTRA_COMPILE_EXT = '.sto'; }; @@ -609,7 +649,7 @@ sub parse_tree { } elsif ($func eq 'META') { my $args = $self->parse_args(\$tag); my $hash; - if (($hash = $self->vivify_args($args)->[-1]) + if (($hash = $self->get_variable($args->[-1])) && UNIVERSAL::isa($hash, 'HASH')) { unshift @meta, %$hash; # first defined win } @@ -630,9 +670,9 @@ sub parse_tree { ### allow for bare variable getting and setting } elsif (defined(my $var = $self->parse_variable(\$tag))) { push @$pointer, $node; - if ($tag =~ s{ ^ = >? \s* $QR_COMMENTS }{}ox) { + if ($tag =~ s{ ^ ($QR_OP_ASSIGN) >? \s* $QR_COMMENTS }{}ox) { $node->[0] = 'SET'; - $node->[3] = eval { $DIRECTIVES->{'SET'}->[0]->($self, \$tag, $node, $var) }; + $node->[3] = eval { $DIRECTIVES->{'SET'}->[0]->($self, \$tag, $node, $1, $var) }; if (my $err = $@) { $err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node; die $err; @@ -677,8 +717,14 @@ sub parse_tree { $node->[2] = $continue; $post_op = $node; - } else { # error - $self->throw('parse', "Found trailing info \"$tag\"", $node) if length $tag; + ### unlink TT2 - look for another directive + } elsif (length $tag) { + #$self->throw('parse', "Found trailing info \"$tag\"", $node); + $continue = $j - length $tag; + $node->[2] = $continue; + $post_op = undef; + + } else { $continue = undef; $post_op = undef; } @@ -763,23 +809,40 @@ sub parse_variable { my $copy = $$str_ref; # copy while parsing to allow for errors - ### test for leading unary operators - my $has_unary; - if ($copy =~ s{ ^ ($QR_OP_UNARY) \s* $QR_COMMENTS }{}ox) { + ### test for leading prefix operators + my $has_prefix; + if ($copy =~ s{ ^ ($QR_OP_PREFIX) \s* $QR_COMMENTS }{}ox) { return if $ARGS->{'auto_quote'}; # auto_quoted thing was too complicated - $has_unary = $1; + $has_prefix = $1; } my @var; my $is_literal; my $is_namespace; + ### allow hex + if ($copy =~ s{ ^ 0x ( [a-fA-F0-9]+ ) \s* $QR_COMMENTS }{}ox) { + my $number = eval { hex $1 } || 0; + push @var, \ $number; + $is_literal = 1; + ### allow for numbers - if ($copy =~ s{ ^ ( (?:\d*\.\d+ | \d+) ) \s* $QR_COMMENTS }{}ox) { + } elsif ($copy =~ s{ ^ ( $QR_NUM ) \s* $QR_COMMENTS }{}ox) { my $number = $1; push @var, \ $number; $is_literal = 1; + ### allow for quoted array constructor + } elsif ($copy =~ s{ ^ qw (\W) \s* }{}x) { + my $quote = $1; + $quote =~ y|([{<|)]}>|; + $copy =~ s{ ^ (.*) \Q$quote\E \s* $QR_COMMENTS }{}sx + || $self->throw('parse.missing.array_close', "Missing close \"$quote\"", undef, length($$str_ref) - length($copy)); + my $str = $1; + $str =~ s{ ^ \s+ | \s+ $ }{}x; + my $arrayref = ['array', split /\s+/, $str]; + push @var, \ $arrayref; + ### looks like a normal variable start } elsif ($copy =~ s{ ^ (\w+) \s* $QR_COMMENTS }{}ox) { push @var, $1; @@ -896,8 +959,11 @@ sub parse_variable { my $name = $1; my $var = $self->parse_variable(\$name); push @var, $var; - } elsif ($copy =~ s{ ^ (\w+) \s* $QR_COMMENTS }{}ox) { + + ### allow for names + } elsif ($copy =~ s{ ^ (-? \w+) \s* $QR_COMMENTS }{}ox) { push @var, $1; + } else { $self->throw('parse', "Not sure how to continue parsing on \"$copy\" ($$str_ref)"); } @@ -924,15 +990,18 @@ sub parse_variable { if (! $self->{'_operator_precedence'}) { my $tree; my $found; - while ($copy =~ s{ ^ ($QR_OP) \s* $QR_COMMENTS }{}ox ## look for operators - then move along - || ($ARGS->{'allow_parened_ops'} - && $copy =~ s{ ^ ($QR_OP_PARENED) \s* $QR_COMMENTS }{}ox) ) { + while ($copy =~ s{ ^ ($QR_OP) (\s* $QR_COMMENTS) }{}ox) { ## look for operators - then move along + if (! $ARGS->{'allow_parened_ops'} && $OP_ASSIGN->{$1}) { + $copy = $1 . $2 . $copy; + last; + } + local $self->{'_operator_precedence'} = 1; my $op = $1; - my $var2 = $self->parse_variable(\$copy); + my $var2 = $OP_POSTFIX->{$op} ? 1 : $self->parse_variable(\$copy); # cheat - give a "second value" to postfix ops - ### allow for unary operator precedence - if ($has_unary && (($OP_BINARY->{$op} || $OP_TRINARY->{$op})->[1] < $OP_UNARY->{$has_unary}->[1])) { + ### allow for prefix operator precedence + if ($has_prefix && $OP->{$op}->[1] < $OP_PREFIX->{$has_prefix}->[1]) { if ($tree) { if ($#$tree == 1) { # only one operator - keep simple things fast $var = [\ [$tree->[0], $var, $tree->[1]], 0]; @@ -943,14 +1012,13 @@ sub parse_variable { undef $tree; undef $found; } - $var = [ \ [ $has_unary, $var ], 0 ]; - undef $has_unary; + $var = [ \ [ $has_prefix, $var ], 0 ]; + undef $has_prefix; } ### add the operator to the tree push (@{ $tree ||= [] }, $op, $var2); - my $ref = $OP_BINARY->{$op} || $OP_TRINARY->{$op}; - $found->{$op} = $ref->[1]; + $found->{$op} = $OP->{$op}->[1]; } ### if we found operators - tree the nodes by operator precedence @@ -964,9 +1032,9 @@ sub parse_variable { } } - ### allow for unary on non-chained variables - if ($has_unary) { - $var = [ \ [ $has_unary, $var ], 0 ]; + ### allow for prefix on non-chained variables + if ($has_prefix) { + $var = [ \ [ $has_prefix, $var ], 0 ]; } $$str_ref = $copy; # commit the changes @@ -984,14 +1052,14 @@ sub apply_precedence { local $found->{$op}; delete $found->{$op}; my @trees; - my @trinary; + my @ternary; ### split the array on the current operator for (my $i = 0; $i <= $#$tree; $i ++) { - my $is_trinary = $OP_TRINARY->{$op} && grep {$_ eq $tree->[$i]} @{ $OP_TRINARY->{$op}->[2] }; - next if $tree->[$i] ne $op && ! $is_trinary; + my $is_ternary = $OP_TERNARY->{$op} && grep {$_ eq $tree->[$i]} @{ $OP->{$op}->[2] }; + next if $tree->[$i] ne $op && ! $is_ternary; push @trees, [splice @$tree, 0, $i, ()]; # everything up to the operator - push @trinary, $tree->[0] if $is_trinary; + push @ternary, $tree->[0] if $is_ternary; shift @$tree; # pull off the operator $i = -1; } @@ -1009,29 +1077,29 @@ sub apply_precedence { } } - ### return binary - if ($OP_BINARY->{$op}) { + ### return infix and assign + if (! $OP_TERNARY->{$op}) { my $val = $trees[-1]; $val = [ \ [ $op, $trees[$_], $val ], 0 ] for reverse (0 .. $#trees - 1); # reverse order - helps out || return $val; } - ### return simple trinary - if (@trinary == 2) { + ### return simple ternary + if (@ternary == 2) { return [ \ [ $op, @trees ], 0 ]; } - ### reorder complex trinary - rare case - while ($#trinary >= 1) { - ### if we look starting from the back - the first lead trinary op will always be next to its matching op - for (my $i = $#trinary; $i >= 0; $i --) { - next if $OP_TRINARY->{$trinary[$i]}->[2]->[1] eq $trinary[$i]; - my ($op, $op2) = splice @trinary, $i, 2, (); # remove the pair of operators + ### reorder complex ternary - rare case + while ($#ternary >= 1) { + ### if we look starting from the back - the first lead ternary op will always be next to its matching op + for (my $i = $#ternary; $i >= 0; $i --) { + next if $OP->{$ternary[$i]}->[2]->[1] eq $ternary[$i]; + my ($op, $op2) = splice @ternary, $i, 2, (); # remove the pair of operators my $node = [ \ [$op, @trees[$i .. $i + 2] ], 0 ]; splice @trees, $i, 3, $node; } } - return $trees[0]; # at this point the trinary has been reduced to a single operator + return $trees[0]; # at this point the ternary has been reduced to a single operator } @@ -1115,28 +1183,30 @@ sub get_variable { my $i = 0; ### determine the top level of this particular variable access - my $ref = $var->[$i++]; + my $ref; + my $name = $var->[$i++]; my $args = $var->[$i++]; - warn "get_variable: begin \"$ref\"\n" if trace; - if (ref $ref) { - if (ref($ref) eq 'SCALAR') { # a scalar literal - $ref = $$ref; - } elsif (ref($ref) eq 'REF') { # operator - return $self->play_operator($$ref) if ${ $ref }->[0] eq '..'; - $ref = $self->play_operator($$ref); + warn "get_variable: begin \"$name\"\n" if trace; + if (ref $name) { + if (ref $name eq 'SCALAR') { # a scalar literal + $ref = $$name; + } elsif (ref $name eq 'REF') { # operator + return $self->play_operator($$name) if ${ $name }->[0] eq '..'; + $ref = $self->play_operator($$name); } else { # a named variable access (ie via $name.foo) - $ref = $self->get_variable($ref); - if (defined $ref) { - return if $ref =~ $QR_PRIVATE; # don't allow vars that begin with _ - $ref = $self->{'_vars'}->{$ref}; + $name = $self->get_variable($name); + if (defined $name) { + return if $name =~ $QR_PRIVATE; # don't allow vars that begin with _ + $ref = $self->{'_vars'}->{$name}; } } - } elsif (defined $ref) { + } elsif (defined $name) { if ($ARGS->{'is_namespace_during_compile'}) { - $ref = $self->{'NAMESPACE'}->{$ref}; + $ref = $self->{'NAMESPACE'}->{$name}; } else { - return if $ref =~ $QR_PRIVATE; # don't allow vars that begin with _ - $ref = $self->{'_vars'}->{$ref}; + return if $name =~ $QR_PRIVATE; # don't allow vars that begin with _ + $ref = $self->{'_vars'}->{$name}; + $ref = $VOBJS->{$name} if ! defined $ref; } } @@ -1146,7 +1216,7 @@ sub get_variable { ### check at each point if the rurned thing was a code if (UNIVERSAL::isa($ref, 'CODE')) { - my @results = $ref->($args ? @{ $self->vivify_args($args) } : ()); + my @results = $ref->($args ? map { $self->get_variable($_) } @$args : ()); if (defined $results[0]) { $ref = ($#results > 0) ? \@results : $results[0]; } elsif (defined $results[1]) { @@ -1160,8 +1230,8 @@ sub get_variable { ### descend one chained level last if $i >= $#$var; my $was_dot_call = $ARGS->{'no_dots'} ? 1 : $var->[$i++] eq '.'; - my $name = $var->[$i++]; - my $args = $var->[$i++]; + $name = $var->[$i++]; + $args = $var->[$i++]; warn "get_variable: nested \"$name\"\n" if trace; ### allow for named portions of a variable name (foo.$name.bar) @@ -1184,10 +1254,10 @@ sub get_variable { ### allow for scalar and filter access (this happens for every non virtual method call) if (! ref $ref) { if ($SCALAR_OPS->{$name}) { # normal scalar op - $ref = $SCALAR_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ()); + $ref = $SCALAR_OPS->{$name}->($ref, $args ? map { $self->get_variable($_) } @$args : ()); } elsif ($LIST_OPS->{$name}) { # auto-promote to list and use list op - $ref = $LIST_OPS->{$name}->([$ref], $args ? @{ $self->vivify_args($args) } : ()); + $ref = $LIST_OPS->{$name}->([$ref], $args ? map { $self->get_variable($_) } @$args : ()); } elsif (my $filter = $self->{'FILTERS'}->{$name} # filter configured in Template args || $FILTER_OPS->{$name} # predefined filters in CET @@ -1207,7 +1277,7 @@ sub get_variable { eval { my $sub = $filter->[0]; if ($filter->[1]) { # it is a "dynamic filter" that will return a sub - ($sub, my $err) = $sub->($self->context, $args ? @{ $self->vivify_args($args) } : ()); + ($sub, my $err) = $sub->($self->context, $args ? map { $self->get_variable($_) } @$args : ()); if (! $sub && $err) { $self->throw('filter', $err) if ref($err) !~ /Template::Exception$/; die $err; @@ -1240,7 +1310,7 @@ sub get_variable { ### method calls on objects if ($was_dot_call && UNIVERSAL::can($ref, 'can')) { - my @args = $args ? @{ $self->vivify_args($args) } : (); + my @args = $args ? map { $self->get_variable($_) } @$args : (); my @results = eval { $ref->$name(@args) }; if ($@) { my $class = ref $ref; @@ -1262,7 +1332,7 @@ sub get_variable { if ($was_dot_call && exists($ref->{$name}) ) { $ref = $ref->{$name}; } elsif ($HASH_OPS->{$name}) { - $ref = $HASH_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ()); + $ref = $HASH_OPS->{$name}->($ref, $args ? map { $self->get_variable($_) } @$args : ()); } elsif ($ARGS->{'is_namespace_during_compile'}) { return $var; # abort - can't fold namespace variable } else { @@ -1271,10 +1341,12 @@ sub get_variable { ### array access } elsif (UNIVERSAL::isa($ref, 'ARRAY')) { - if ($name =~ /^\d+$/) { - $ref = ($name > $#$ref) ? undef : $ref->[$name]; + if ($name =~ m{ ^ -? $QR_NUM $ }ox) { + $ref = $ref->[$name]; + } elsif ($LIST_OPS->{$name}) { + $ref = $LIST_OPS->{$name}->($ref, $args ? map { $self->get_variable($_) } @$args : ()); } else { - $ref = (! $LIST_OPS->{$name}) ? undef : $LIST_OPS->{$name}->($ref, $args ? @{ $self->vivify_args($args) } : ()); + $ref = undef; } } } @@ -1311,8 +1383,7 @@ sub set_variable { $ref = $self->get_variable($ref); if (defined $ref && $ref !~ $QR_PRIVATE) { # don't allow vars that begin with _ if ($#$var <= $i) { - $self->{'_vars'}->{$ref} = $val; - return; + return $self->{'_vars'}->{$ref} = $val; } else { $ref = $self->{'_vars'}->{$ref} ||= {}; } @@ -1325,20 +1396,28 @@ sub set_variable { } elsif (defined $ref) { return if $ref =~ $QR_PRIVATE; # don't allow vars that begin with _ if ($#$var <= $i) { - $self->{'_vars'}->{$ref} = $val; - return; + return $self->{'_vars'}->{$ref} = $val; } else { $ref = $self->{'_vars'}->{$ref} ||= {}; } } - ### let the top level thing be a code block - if (UNIVERSAL::isa($ref, 'CODE')) { - return; - } + while (defined $ref) { - ### vivify the chained levels - while (defined $ref && $#$var > $i) { + ### check at each point if the returned thing was a code + if (UNIVERSAL::isa($ref, 'CODE')) { + my @results = $ref->($args ? map { $self->get_variable($_) } @$args : ()); + if (defined $results[0]) { + $ref = ($#results > 0) ? \@results : $results[0]; + } elsif (defined $results[1]) { + die $results[1]; # TT behavior - why not just throw ? + } else { + return; + } + } + + ### descend one chained level + last if $i >= $#$var; my $was_dot_call = $ARGS->{'no_dots'} ? 1 : $var->[$i++] eq '.'; my $name = $var->[$i++]; my $args = $var->[$i++]; @@ -1348,8 +1427,7 @@ sub set_variable { if (ref($name) eq 'ARRAY') { $name = $self->get_variable($name); if (! defined($name) || $name =~ /^[_.]/) { - $ref = undef; - next; + return; } } else { die "Shouldn't get a ".ref($name)." during a vivify on chain"; @@ -1359,10 +1437,14 @@ sub set_variable { return; } + ### scalar access + if (! ref $ref) { + return; + ### method calls on objects - if (UNIVERSAL::can($ref, 'can')) { + } elsif (UNIVERSAL::can($ref, 'can')) { my $lvalueish; - my @args = $args ? @{ $self->vivify_args($args) } : (); + my @args = $args ? map { $self->get_variable($_) } @$args : (); if ($i >= $#$var) { $lvalueish = 1; push @args, $val; @@ -1374,20 +1456,20 @@ sub set_variable { } elsif (defined $results[1]) { die $results[1]; # TT behavior - why not just throw ? } else { - $ref = undef; + return; } return if $lvalueish; next; } - die $@ if ref $@ || $@ !~ /Can\'t locate object method/; + my $class = ref $ref; + die $@ if ref $@ || $@ !~ /Can\'t locate object method "\Q$name\E" via package "\Q$class\E"/; # fall on down to "normal" accessors } ### hash member access if (UNIVERSAL::isa($ref, 'HASH')) { if ($#$var <= $i) { - $ref->{$name} = $val; - return; + return $ref->{$name} = $val; } else { $ref = $ref->{$name} ||= {}; next; @@ -1395,10 +1477,9 @@ sub set_variable { ### array access } elsif (UNIVERSAL::isa($ref, 'ARRAY')) { - if ($name =~ /^\d+$/) { + if ($name =~ m{ ^ -? $QR_NUM $ }ox) { if ($#$var <= $i) { - $ref->[$name] = $val; - return; + return $ref->[$name] = $val; } else { $ref = $ref->[$name] ||= {}; next; @@ -1407,32 +1488,11 @@ sub set_variable { return; } - ### scalar access - } elsif (! ref($ref) && defined($ref)) { - return; - } - - ### check at each point if the returned thing was a code - if (defined($ref) && UNIVERSAL::isa($ref, 'CODE')) { - my @results = $ref->($args ? @{ $self->vivify_args($args) } : ()); - if (defined $results[0]) { - $ref = ($#results > 0) ? \@results : $results[0]; - } elsif (defined $results[1]) { - die $results[1]; # TT behavior - why not just throw ? - } else { - return; - } } } - return $ref; -} - -sub vivify_args { - my $self = shift; - my $vars = shift; - return [map {$self->get_variable($_)} @$vars]; + return; } ###----------------------------------------------------------------### @@ -1442,9 +1502,14 @@ sub play_operator { my $tree = shift; if ($OP_DISPATCH->{$tree->[0]}) { - my @args = map { $self->get_variable($tree->[$_]) } 1 .. $#$tree; local $^W; - return $OP_DISPATCH->{$tree->[0]}->(@args); + if ($OP_ASSIGN->{$tree->[0]}) { + my $val = $OP_DISPATCH->{$tree->[0]}->( $self->get_variable($tree->[1]), $self->get_variable($tree->[2]) ); + $self->set_variable($tree->[1], $val); + return $val; + } else { + return $OP_DISPATCH->{$tree->[0]}->( map { $self->get_variable($tree->[$_]) } 1 .. $#$tree ); + } } my $op = $tree->[0]; @@ -1465,6 +1530,18 @@ sub play_operator { } elsif ($op eq '?') { local $^W; return $self->get_variable($tree->[1]) ? $self->get_variable($tree->[2]) : $self->get_variable($tree->[3]); + + } elsif ($op eq '++') { + local $^W; + my $val = 0 + $self->get_variable($tree->[1]); + $self->set_variable($tree->[1], $val + 1); + return $tree->[2] ? $val : $val + 1; # ->[2] is set to 1 during parsing of postfix ops + + } elsif ($op eq '--') { + local $^W; + my $val = 0 + $self->get_variable($tree->[1]); + $self->set_variable($tree->[1], $val - 1); + return $tree->[2] ? $val : $val - 1; # ->[2] is set to 1 during parsing of postfix ops } $self->throw('operator', "Un-implemented operation $op"); @@ -1553,7 +1630,7 @@ sub parse_DEFAULT { $DIRECTIVES->{'SET'}->[0]->(@_) } sub play_DEFAULT { my ($self, $set) = @_; foreach (@$set) { - my ($set, $default) = @$_; + my ($op, $set, $default) = @$_; next if ! defined $set; my $val = $self->get_variable($set); if (! $val) { @@ -2042,35 +2119,40 @@ sub play_RAWPERL { } sub parse_SET { - my ($self, $tag_ref, $node, $initial_var) = @_; + my ($self, $tag_ref, $node, $initial_op, $initial_var) = @_; my @SET; my $copy = $$tag_ref; my $func; + + if ($initial_op) { + if ($$tag_ref =~ $QR_DIRECTIVE # find a word + && $DIRECTIVES->{$1}) { # is it a directive - if so set up capturing + $node->[6] = 1; # set a flag to keep parsing + my $val = $node->[4] ||= []; # setup storage + return [[$initial_op, $initial_var, $val]]; + } else { # get a normal variable + return [[$initial_op, $initial_var, $self->parse_variable($tag_ref)]]; + } + } + while (length $$tag_ref) { - my $set; - my $get_val; - my $val; - if ($initial_var) { - $set = $initial_var; - undef $initial_var; - $get_val = 1; + my $set = $self->parse_variable($tag_ref); + last if ! defined $set; + + if ($$tag_ref =~ s{ ^ ($QR_OP_ASSIGN) >? \s* }{}x) { + my $op = $1; + if ($$tag_ref =~ $QR_DIRECTIVE # find a word + && $DIRECTIVES->{$1}) { # is it a directive - if so set up capturing + $node->[6] = 1; # set a flag to keep parsing + my $val = $node->[4] ||= []; # setup storage + push @SET, [$op, $set, $val]; + last; + } else { # get a normal variable + push @SET, [$op, $set, $self->parse_variable($tag_ref)]; + } } else { - $set = $self->parse_variable($tag_ref); - last if ! defined $set; - $get_val = $$tag_ref =~ s{ ^ = >? \s* }{}x; - } - if (! $get_val) { # no next val - $val = undef; - } elsif ($$tag_ref =~ $QR_DIRECTIVE # find a word - && $DIRECTIVES->{$1}) { # is it a directive - if so set up capturing - $node->[6] = 1; # set a flag to keep parsing - $val = $node->[4] ||= []; # setup storage - push @SET, [$set, $val]; - last; - } else { # get a normal variable - $val = $self->parse_variable($tag_ref); + push @SET, ['=', $set, undef]; } - push @SET, [$set, $val]; } return \@SET; } @@ -2078,7 +2160,7 @@ sub parse_SET { sub play_SET { my ($self, $set, $node) = @_; foreach (@$set) { - my ($set, $val) = @$_; + my ($op, $set, $val) = @$_; if (! defined $val) { # not defined $val = ''; } elsif ($node->[4] && $val == $node->[4]) { # a captured directive @@ -2090,6 +2172,11 @@ sub play_SET { $val = $self->get_variable($val); } + if ($OP_DISPATCH->{$op}) { + local $^W; + $val = $OP_DISPATCH->{$op}->($self->get_variable($set), $val); + } + $self->set_variable($set, $val); } return; @@ -2118,8 +2205,8 @@ sub play_SWITCH { next if ! defined $val && defined $test; next if defined $val && ! defined $test; if ($val ne $test) { # check string-wise first - then numerical - next if $val !~ /^ -? (?: \d*\.\d+ | \d+) $/x; - next if $test !~ /^ -? (?: \d*\.\d+ | \d+) $/x; + next if $val !~ m{ ^ -? $QR_NUM $ }ox; + next if $test !~ m{ ^ -? $QR_NUM $ }ox; next if $val != $test; } @@ -2148,7 +2235,7 @@ sub play_THROW { my ($self, $ref, $node) = @_; my ($name, $args) = @$ref; $name = $self->get_variable($name); - my @args = $args ? @{ $self->vivify_args($args) } : (); + my @args = $args ? map { $self->get_variable($_) } @$args : (); $self->throw($name, \@args, $node); } @@ -2275,7 +2362,7 @@ sub play_USE { if ($self->{'PLUGIN_FACTORY'}->{$module} || eval {require $require}) { my $shape = $package->load; my $context = $self->context; - my @args = $args ? @{ $self->vivify_args($args) } : (); + my @args = $args ? map { $self->get_variable($_) } @$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->get_variable($args->[0]) : []); @@ -2286,14 +2373,14 @@ sub play_USE { eval {require $require} || next; my $shape = $package->load; my $context = $self->context; - my @args = $args ? @{ $self->vivify_args($args) } : (); + my @args = $args ? map { $self->get_variable($_) } @$args : (); $obj = $shape->new($context, @args); } } elsif ($self->{'LOAD_PERL'}) { my $require = "$module.pm"; $require =~ s|::|/|g; if (eval {require $require}) { - my @args = $args ? @{ $self->vivify_args($args) } : (); + my @args = $args ? map { $self->get_variable($_) } @$args : (); $obj = $module->new(@args); } } @@ -2745,6 +2832,29 @@ sub define_vmethod { return 1; } +sub vmethod_as_scalar { + my ($str, $pat) = @_; + $pat = '%s' if ! defined $pat; + local $^W; + return sprintf $pat, $str; +} + +sub vmethod_as_list { + my ($ref, $pat, $sep) = @_; + $pat = '%s' if ! defined $pat; + $sep = ' ' if ! defined $sep; + local $^W; + return 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; + local $^W; + return join($sep, map {sprintf $pat, $_, $ref->{$_}} sort keys %$ref); +} + sub vmethod_chunk { my $str = shift; my $size = shift || 1; diff --git a/lib/CGI/Ex/Template.pod b/lib/CGI/Ex/Template.pod index e0ea842..d954eab 100644 --- a/lib/CGI/Ex/Template.pod +++ b/lib/CGI/Ex/Template.pod @@ -70,7 +70,7 @@ In general the following statements are true: If you use Template::Stash::XS with a cached in memory template, then CET is about as fast. - Using TT with a compiled-in-memory template is only 33 + Using TT with a compiled-in-memory template is only 33% faster than CET with a new object compiling each time. It is pretty hard to beat the speed of XS stash with compiled in @@ -102,8 +102,8 @@ commonly used public methods are listed later in this document. =item C -This is the main method call for staring processing. Any errors that results in the -template being stopped processing will be stored and available via the ->error method. +This is the main method call for starting processing. Any errors that result in the +template processing being stopped will be stored and available via the ->error method. Process takes three arguments. @@ -175,128 +175,252 @@ to Template::Stash::define_vmethod. =head1 TODO - Add WRAPPER config item + Add WRAPPER configuration item (the WRAPPER directive is supported). Add ERROR config item =head1 HOW IS CGI::Ex::Template DIFFERENT -CET uses the same template syntax and configuration items -as TT2, but the internals of CET were written from scratch. In -addition to this, the following is a list of some of the ways that -configuration and syntax of CET different from that of TT. +CET uses the same base template syntax and configuration items as TT2, +but the internals of CET were written from scratch. Additionally much +of the planned TT3 syntax is supported. The following is a list of +some of the ways that the configuration and syntax of CET are +different from that of TT2. Note: items that are planned to work in +TT3 are marked with (TT3). =over 4 -Numerical hash keys work [% a = {1 => 2} %] +=item Numerical hash keys work -Quoted hash key interpolation is fine [% a = {"$foo" => 1} %] + [% a = {1 => 2} %] -Multiple ranges in same constructor [% a = [1..10, 21..30] %] +=item Quoted hash key interpolation is fine -Constructor types can call virtual methods + [% a = {"$foo" => 1} %] - [% a = [1..10].reverse %] +=item Multiple ranges in same constructor - [% "$foo".length %] + [% a = [1..10, 21..30] %] - [% 123.length %] # = 3 +=item Constructor types can call virtual methods. (TT3) - [% 123.4.length %] # = 5 + [% a = [1..10].reverse %] - [% -123.4.length %] # = -5 ("." binds more tightly than "-") + [% "$foo".length %] - [% (a ~ b).length %] + [% 123.length %] # = 3 - [% "hi".repeat(3) %] + [% 123.4.length %] # = 5 - [% {a => b}.size %] + [% -123.4.length %] # = -5 ("." binds more tightly than "-") -Reserved names are less reserved + [% (a ~ b).length %] - [% GET GET %] # gets the variable named "GET" + [% "hi".repeat(3) %] - [% GET $GET %] # gets the variable who's name is stored in "GET" + [% {a => b}.size %] -Filters and SCALAR_OPS are interchangeable. +=item The "${" and "}" variable interpolators can contain expressions, +not just variables. - [% a | length %] + [% [0..10].${ 1 + 2 } %] # = 4 - [% b . lower %] + [% {ab => 'AB'}.${ 'a' ~ 'b' } %] # = AB -Pipe "|" can be used anywhere dot "." can be and means to call -the virtual method. + [% color = qw/Red Blue/; FOR [1..4] ; color.${ loop.index % color.size } ; END %] + # = RedBlueRedBlue - [% a = {size => "foo"} %][% a.size %] # = foo +=item Arrays can be accessed with non-integer numbers. - [% a = {size => "foo"} %][% a|size %] # = 1 (size of hash) + [% [0..10].${ 2.3 } %] # = 3 -Pipe "|" and "." can be mixed. +=item Reserved names are less reserved. (TT3) - [% "aa" | repeat(2) . length %] # = 4 + [% GET GET %] # gets the variable named "GET" -Whitespace is less meaningful. + [% GET $GET %] # gets the variable who's name is stored in "GET" - [% 2-1 %] # = 1 (fails in TT) +=item Filters and SCALAR_OPS are interchangeable. (TT3) -Added pow operator. + [% a | length %] - [% 2 ** 3 %] [% 2 pow 3 %] # = 8 8 + [% b . lower %] -FOREACH variables can be nested +=item Pipe "|" can be used anywhere dot "." can be and means to call +the virtual method. (TT3) - [% FOREACH f.b = [1..10] ; f.b ; END %] + [% a = {size => "foo"} %][% a.size %] # = foo - Note that nested variables are subject to scoping issues. - f.b will not be reset to its value before the FOREACH. + [% a = {size => "foo"} %][% a|size %] # = 1 (size of hash) -Post operative directives can be nested. +=item Pipe "|" and "." can be mixed. (TT3) - [% one IF two IF three %] + [% "aa" | repeat(2) . length %] # = 4 - same as +=item Added Virtual Object Namespaces. (TT3) - [% IF three %][% IF two %][% one %][% END %][% END %] +The Text, List, and Hash types give direct access +to virtual methods. + [% a = "foobar" %][% Text.length(a) %] # = 6 - [% a = [[1..3], [5..7]] %][% i FOREACH i = j FOREACH j = a %] # = 123567 + [% a = [1 .. 10] %][% List.size(a) %] # = 10 -CATCH blocks can be empty. + [% a = {a=>"A", b=>"B"} ; Hash.size(a) %] = 2 -CET does not generate Perl code. It generates an "opcode" tree. + [% foo = {a => 1, b => 2} + | Hash.keys + | List.join(", ") %] # = a, b -CET uses storable for its compiled templates. If EVAL_PERL is off, -CET will not eval_string on ANY piece of information. +=item Added "as" scalar, list, and hash virtual methods. -There is no context. CET provides a context object that mimics the -Template::Context interface for use by some TT filters, eval perl -blocks, and plugins. + [% list.as("%s", ", ") %] -There is no stash. CET only supports the variables passed in -VARIABLES, PRE_DEFINE, and those passed to the process method. CET -provides a stash object that mimics the Template::Stash interface for -use by some TT filters, eval perl blocks, and plugins. + [% hash.as("%s => %s", "\n") %] -There is no provider. CET uses the load_parsed_tree method to get and -cache templates. +=item Whitespace is less meaningful. (TT3) -There is no grammar. CET has its own built in grammar system. + [% 2-1 %] # = 1 (fails in TT2) -There is no VIEW directive. +=item Added pow operator. -There are no references. (There was in initial beta tests, but it was decided -to remove the little used feature). + [% 2 ** 3 %] [% 2 pow 3 %] # = 8 8 -The DEBUG directive only understands DEBUG_DIRS (8) and DEBUG_UNDEF (2). +=item Added self modifiers (+=, -=, *=, /=, %=, **=, ~=). (TT3) -When debug dirs is on, directives on different lines separated by colons show the line they + [% a = 2; a *= 3 ; a %] # = 6 + [% a = 2; (a *= 3) ; a %] # = 66 + +=item Added pre and post increment and decrement (++ --). (TT3) + + [% ++a ; ++a %] # = 12 + [% a-- ; a-- %] # = 0-1 + +=item Added qw// contructor. (TT3) + + [% a = qw(a b c); a.1 %] # = b + + [% qw/a b c/.2 %] # = c + +=item Allow for scientific notation. (TT3) + + [% a = 1.2e-20 %] + + [% 123.as('%.3e') %] # = 1.230e+02 + +=item Allow for hexidecimal input. (TT3) + + [% a = 0xff0000 %][% a %] # = 16711680 + + [% a = 0xff2 / 0xd; a.as('%x') %] # = 13a + +=item FOREACH variables can be nested. + + [% FOREACH f.b = [1..10] ; f.b ; END %] + +Note that nested variables are subject to scoping issues. +f.b will not be reset to its value before the FOREACH. + +=item Post operative directives can be nested. (TT3) + +Andy Wardley calls this side-by-side effect notation. + + [% one IF two IF three %] + + same as + + [% IF three %][% IF two %][% one %][% END %][% END %] + + + [% a = [[1..3], [5..7]] %][% i FOREACH i = j FOREACH j = a %] # = 123567 + +=item Semi-colons on directives in the same tag are optional. (TT3) + + [% SET a = 1 + GET a + %] + + [% FOREACH i = [1 .. 10] + i + END %] + +Note: a semi-colon is still required in front of any block directive +that can be used as a post-operative directive. + + [% 1 IF 0 + 2 %] # prints 2 + + [% 1; IF 0 + 2 + END %] # prints 1 + +=item CATCH blocks can be empty. + +TT2 requires them to contain something. + +=item Added a DUMP directive. + +Used for Data::Dumpering the passed variable or expression. + + [% DUMP a.a %] + +=item CET does not generate Perl code. + +It generates an "opcode" tree. + +=item CET uses storable for its compiled templates. + +If EVAL_PERL is off, CET will not eval_string on ANY piece of information. + +=item There is no context. + +CET provides a context object that mimics the Template::Context +interface for use by some TT filters, eval perl blocks, and plugins. + +=item There is no stash. + +Well there is but it isn't an object. + +CET only supports the variables passed in VARIABLES, PRE_DEFINE, and +those passed to the process method. CET provides a stash object that +mimics the Template::Stash interface for use by some TT filters, eval +perl blocks, and plugins. + +=item There is no provider. + +CET uses the load_parsed_tree method to get and cache templates. + +=item There is no grammar. + +CET has its own built in recursive grammar system. + +=item There is no VIEW directive. + + +=item There are no references. + +There was in initial beta tests, but it was decided to remove the little used feature. + +It makes it the same as + + [% obj.method("foo") %] + +This is removed in CET. + +=item The DEBUG directive is more limited. + +It only understands DEBUG_DIRS (8) and DEBUG_UNDEF (2). + +=item When debug dirs is on, directives on different lines separated by colons show the line they are on rather than a general line range. -There is no ANYCASE configuration item. There was in initial beta tests, but it -was dropped in favor of consistent parsing syntax. +=item There is no ANYCASE configuration item. + +There was in initial beta tests, but it was dropped in favor of consistent parsing syntax. -There is no V1DOLLAR configuration item. This is a TT version 1 compatibility item and -is not available in CET. +=item There is no V1DOLLAR configuration item. + +This is a TT version 1 compatibility item and is not available in CET. =back @@ -333,7 +457,7 @@ a hashref as the second argument to the process method, or by setting the "VARIA ### pass the variables during object creation (will be available to every process call) my $cet = CGI::Ex::Template->new(VARIABLES => \%vars); -=head1 GETTING VARIABLES +=head2 GETTING VARIABLES Once you have variables defined, they can be used directly in the template by using their name in the stash. Or by using the GET directive. @@ -351,13 +475,13 @@ Would print when processed: To access members of a hashref or an arrayref, you can chain together the names using a ".". [% some_data.a %] - [% my_list.0] [% my_list.1 %] + [% my_list.0] [% my_list.1 %] [% my_list.-1 %] [% some_data.c.2 %] Would print: A - 20 21 + 20 21 50 4 If the value of a variable is a code reference, it will be called. You can add a set of parenthesis @@ -373,7 +497,7 @@ Would print: You passed me (). You passed me (). You passed me (bar). - You passed me (1, 2, 3). + You passed me (1.0, 2, 3). If the value of a variable is an object, methods can be called using the "." operator. @@ -387,9 +511,11 @@ Would print something like: $VAR1 = [ \[ '+', '1', '2' ], 0 ]; -Each type of data has virtual methods associated with them. Virtual methods -allow for access to common functions. For the full list of built in virtual -methods, please see the section titled VIRTUAL METHODS +Each type of data (string, array and hash) have virtual methods +associated with them. Virtual methods allow for access to functions +that are commonly used on those types of data. For the full list of +built in virtual methods, please see the section titled VIRTUAL +METHODS [% foo.length %] [% my_list.size %] @@ -403,7 +529,7 @@ Would print: It is also possible to "interpolate" variable names using a "$". This allows for storing the name of a variable inside another variable. If a variable name is a little -more complex, it can be embedded inside of "${" and "}". +more complex it can be embedded inside of "${" and "}". [% $vname %] [% ${vname} %] @@ -419,6 +545,19 @@ Would print: 3234 3234 +In CET it is also possible to embed any expression (non-directive) in "${" and "}" +and it is possible to use non-integers for array access. (This is not available in TT2) + + [% ['a'..'z'].${ 2.3 } %] + [% {ab => 'AB'}.${ 'a' ~ 'b' } %] + [% color = qw/Red Blue/; FOR [1..4] ; color.${ loop.index % color.size } ; END %] + +Would print: + + c + AB + RedBlueRedBlue + =head2 SETTING VARIABLES. To define variables during processing, you can use the = operator. In most cases @@ -445,7 +584,7 @@ Would print: 2 val1 val2 -It is possible to set multiple values at the same time. +It is possible to set multiple values in the same SET directive. [% SET a = 'A' b = 'B' @@ -474,10 +613,11 @@ Would print =head1 LITERALS AND CONSTRUCTORS -The following are the types of literals allowed in CET. They can be used as arguments -to functions, in place of variables in directives, and in place of variables in expressions. - -In CET it is also possible to call virtual methods on literal values. +The following are the types of literals (numbers and strings) and +constructors (hash and array constructs) allowed in CET. They can be +used as arguments to functions, in place of variables in directives, +and in place of variables in expressions. In CET it is also possible +to call virtual methods on literal values. =over 4 @@ -488,57 +628,80 @@ In CET it is also possible to call virtual methods on literal values. [% pi = 3.14159 %] Sets the value of the variable. [% 3.13159.length %] Prints 7 (the string length of the number) +Scientific notation is supported. -=item Single quoted string. + [% 314159e-5 + 0 %] Prints 3.14159. + + [% .0000001.as('%.1e') %] Prints 1.0e-07 + +Hexidecimal input is also supported. + + [% 0xff + 0 %] Prints 255 + + [% 48875.as('%x') %] Prints beeb + +=item Single quoted strings. Returns the string. No variable interpolation happens. [% 'foobar' %] Prints "foobar". - [% '$foo\n' %] Prints "$foo\\n". # the \\n is a literal "\" and a "\n" + [% '$foo\n' %] Prints "$foo\\n". # the \\n is a literal "\" and an "n" [% 'That\'s nice' %] Prints "That's nice". [% str = 'A string' %] Sets the value of str. [% 'A string'.split %] Splits the string on ' ' and returns the list. Note: virtual methods can only be used on literal strings in CET, not in TT. -=item Double quoted string. +=item Double quoted strings. Returns the string. Variable interpolation happens. [% "foobar" %] Prints "foobar". [% "$foo" %] Prints "bar" (assuming the value of foo is bar). - [% "${foo} %] Prints "bar" (assuming the value of foo is bar). + [% "${foo}" %] Prints "bar" (assuming the value of foo is bar). [% "foobar\n" %] Prints "foobar\n". # the \n is a newline. [% str = "Hello" %] Sets the value of str. [% "foo".replace('foo','bar') %] Prints "bar". Note: virtual methods can only be used on literal strings in CET, not in TT. -=item Array Constructor. +=item Array Constructs. [% [1, 2, 3] %] Prints something like ARRAY(0x8309e90). - [% [4, 5, 6].size %] Prints 3. - [% [7, 8, 9].reverse.0 %] Prints 9. [% array1 = [1 .. 3] %] Sets the value of array1. [% array2 = [foo, 'a', []] %] Sets the value of array2. + [% [4, 5, 6].size %] Prints 3. + [% [7, 8, 9].reverse.0 %] Prints 9. + +Note: virtual methods can only be used on array contructs in CET, not in TT. + +=item Quoted Array Constructs. -Note: virtual methods can only be used on array contructors in CET, not in TT. + [% qw/1 2 3/ %] Prints something like ARRAY(0x8309e90). + [% array1 = qw{Foo Bar Baz} %] Sets the value of array1. + [% qw[4 5 6].size %] Prints 3. + [% qw(Red Blue).reverse.0 %] Prints Blue. -=item Hash Constructor. +Note: this works in CET and is planned for TT3. + +=item Hash Constructs. [% {foo => 'bar'} %] Prints something like HASH(0x8305880) + [% hash = {foo => 'bar', c => {}} %] Sets the value of hash. [% {a => 'A', b => 'B'}.size %] Prints 2. [% {'a' => 'A', 'b' => 'B'}.size %] Prints 2. - [% hash = {foo => 'bar', c => {}} %] Sets the value of hash. + [% name = "Tom" %] + [% {Tom => 'You are Tom', + Kay => 'You are Kay'}.$name %] Prints You are Tom -Note: virtual methods can only be used on hash contructors in CET, not in TT. +Note: virtual methods can only be used on hash contructs in CET, not in TT. =head1 EXPRESSIONS -Expressions are one or more variables or literals joined together +Expressions are one or more variables or literals joined together with operators. An expression can be used anywhere a variable can be used -with the exception of the variable name of SET, and the filename of -PROCESS, INCLUDE, WRAPPER, and INSERT. +with the exception of the variable name in the SET directive, and the +filename of PROCESS, INCLUDE, WRAPPER, and INSERT. The following section shows some samples of expressions. For a full list of available operators, please see the section titled OPERATORS. @@ -563,13 +726,16 @@ the "|" means to always call the virtual method or filter rather than looking in the hashref for a key by that name, or trying to call that method on the object. This is similar to how TT3 will function. +Virtual methods are also made available via Virtual Objects which +are discussed in a later section. + =head2 SCALAR VIRTUAL METHODS AND FILTERS The following is the list of builtin virtual methods and filters that can be called on scalar data types. In CET and TT3, filters and -virtual methods are more closely related. In general anywhere a -virtual method can be used a filter can be used also - and vice versa -- all scalar virtual methods can be used as filters. +virtual methods are more closely related than in TT2. In general anywhere a +virtual method can be used a filter can be used also - and likewise all scalar +virtual methods can be used as filters. In addition to the filters listed below, CET will automatically load Template::Filters and use them if Template::Toolkit is installed. @@ -578,8 +744,21 @@ In addition to the scalar virtual methods, any scalar will be automatically converted to a single item list if a list virtual method is called on it. +Scalar virtual methods are also available through the "Text" virtual +object (except for true filters such as eval and redirect). + =over 4 +=item '0' + + [% item = 'foo' %][% item.0 %] Returns self. Allows for scalars to mask as arrays. + +=item as + + [% item.as('%d') %] + +Similar to format. Returns a string formatted with the passed pattern. Default pattern is %s. + =item chunk [% item.chunk(60).join("\n") %] Split string up into a list of chunks of text 60 chars wide. @@ -600,9 +779,13 @@ is called on it. =item eval - [% item.eval %] Process the string as though it was a template. This will start the parsing - engine and will use the same configuration as the current process. CET is several times - faster at doing this than TT is and is considered acceptable. + [% item.eval %] + +Process the string as though it was a template. This will start the parsing +engine and will use the same configuration as the current process. CET is several times +faster at doing this than TT is and is considered acceptable. + +This is a filter and is not available via the Text virtual object. =item evaltt @@ -625,6 +808,10 @@ is called on it. [% item.html %] Performs a very basic html encoding (swaps out &, <, > and " for the html entities) +=item int + + [% item.int %] Return the integer portion of the value (0 if none). + =item lcfirst [% item.lcfirst %] Capitalize the leading letter. @@ -633,6 +820,10 @@ is called on it. [% item.length %] Return the length of the string. +=item list + + [% item.list %] Returns a list with a single value of the item. + =item lower [% item.lower %] Return a lower-casified string. @@ -647,14 +838,25 @@ is called on it. [% item.null %] Do nothing. +=item rand + + [% item = 10; item.rand %] Returns a number greater or equal to 0 but less than 10. + [% 1.rand %] + +Note: This filter is not available as of TT2.15. + =item remove [% item.remove("\s+") %] Same as remove - but is global and replaces with nothing. =item redirect - [% item.redirect("output_file.html") %] - Writes the contents out to the specified file. The filename - must be relative to the OUTPUT_PATH configuration variable and the OUTPUT_PATH variable must be set. + [% item.redirect("output_file.html") %] + +Writes the contents out to the specified file. The filename +must be relative to the OUTPUT_PATH configuration variable and the OUTPUT_PATH variable must be set. + +This is a filter and is not available via the Text virtual object. =item repeat @@ -666,7 +868,7 @@ is called on it. [% item.replace("\s+", " ") %] Globally replace all space with   - [% item.replace("foo", "bar", 0) Replace the first instance of foo with bar. + [% item.replace("foo", "bar", 0) Replace only the first instance of foo with bar. [% item.replace("(\w+)", "($1)") %] Surround all words with parenthesis. @@ -678,7 +880,7 @@ is called on it. [% item.size %] Always returns 1. -=item split => \&vmethod_split, +=item split [% item.split %] Returns an arrayref from the item split on " " @@ -716,12 +918,23 @@ is called on it. =head2 LIST VIRTUAL METHODS -=over 4 - The following methods can be called on an arrayref type data structures (scalar types will automatically promote to a single element list and call these methods if needed): +Additionally, list virtual methods can be accessed via the List +Virtual Object. + +=over 4 + +=item as + + [% mylist.as('%s', ', ') %] + +Passed a pattern and an string to join on. Returns a string of the values of the list +formatted with the passed pattern and joined with the passed string. +Default pattern is %s and the default join string is a space. + =item first [% mylist.first(3) %] Returns a list of the first 3 items in the list. @@ -768,6 +981,13 @@ if needed): [% mylist.push(23) %] Adds an element to the end of the arrayref (the stash is modified). +=item random + + [% mylist.random %] Returns a random item from the list. + [% ['a' .. 'z'].random %] + +Note: This filter is not available as of TT2.15. + =item reverse [% mylist.reverse %] Returns the list in reverse order. @@ -810,8 +1030,19 @@ if needed): The following methods can be called on hash type data structures: +Additionally, list virtual methods can be accessed via the Hash +Virtual Object. + =over 4 +=item as + + [% myhash.as('%s => %s', "\n") %] + +Passed a pattern and an string to join on. Returns a string of the key/value pairs +of the hash formatted with the passed pattern and joined with the passed string. +Default pattern is "%s\t%s" and the default join string is a newline. + =item defined [% myhash.defined('a') %] Checks if a is defined in the hash. @@ -837,6 +1068,14 @@ The following methods can be called on hash type data structures: [% myhash.import(hash2) %] Overlays the keys of hash2 over the keys of myhash. +=item item + + [% myhash.item(key) %] Returns the hashes value for that key. + +=item items + + [% myhash.items %] Returns a list of the key and values (flattened hash) + =item keys [% myhash.keys.join(', ') %] Returns an arrayref of the keys of the hash. @@ -868,14 +1107,100 @@ The following methods can be called on hash type data structures: =back +=head1 VIRTUAL OBJECTS + +TT3 has a concept of Text, List, and Hash virtual objects which provide +direct access to the scalar, list, and hash virtual methods. In the TT3 +engine this will allow for more concise generated code. Because CET does +not generated perl code to be executed later, CET provides for these virtual +objects but does so as more of a namespace (using the methods does not +provide a speed optimization in your template - just may help clarify things). + + [% a = "foo"; a.length %] => 3 + + [% a = "foo"; Text.length(a) %] => 3 + + [% a = Text.new("foo"); a.length %] => 3 + + + [% a = [1 .. 30]; a.size %] => 30 + + [% a = [1 .. 30]; List.size(a) %] => 30 + + [% a = List.new(1 .. 30); a.size %] => 30 + + + [% a = {a => 1, b => 2}; a.size %] => 2 + + [% a = {a => 1, b => 2}; Hash.size(a) %] => 2 + + [% a = Hash.new({a => 1, b => 2}); a.size %] => 2 + + [% a = Hash.new(a => 1, b => 2); a.size %] => 2 + + [% a = Hash.new(a = 1, b = 2); a.size %] => 2 + + [% a = Hash.new('a', 1, 'b', 2); a.size %] => 2 + +One limitation is that if you pass a key named "Text", +"List", or "Hash" in your variable stash - the corresponding +virtual object will be hidden. + +Additionally, you can use all of the Virtual object methods with +the pipe operator. + + [% {a => 1, b => 2} + | Hash.keys + | List.join(", ") %] => a, b + +Again, there aren't any speed optimizations to using the virtual +objects in CET, but it can help clarify the intent in some cases. + +Note: these aren't really objects. All of the "virtual objects" are +references to the $SCALAR_OPS, $LIST_OPS, and $HASH_OPS hashes +found in the $VOBJS hash of CGI::Ex::Template. + =head1 DIRECTIVES -This section contains the alphabetical list of DIRECTIVES available -in the TT language. DIRECTIVES are the "functions" and control -structures that implement the Template Toolkit mini-language. For -further discussion and examples, please refer to the TT directives -documentation. +This section contains the alphabetical list of DIRECTIVES available in +the TT language. DIRECTIVES are the "functions" and control +structures of the Template Toolkit mini-language. For further +discussion and examples beyond what is listed below, please refer to +the TT directives documentation. + [% IF 1 %]One[% END %] + [% FOREACH a = [1 .. 3] %] + a = [% a %] + [% END %] + + [% SET a = 1 %][% SET a = 2 %][% GET a %] + +Multiple directives can be inside the same set of '[%' and '%]' tags +as long as they are separated by space or semi-colons (;). Any block +directive that can also be used as a post-operative directive (such as +IF, WHILE, FOREACH, UNLESS, FILTER, and WRAPPER) must be separated +from preceding directives with a semi-colon if it is being used as a +block directive. It is more safe to always use a semi-colon. Note: +separating by space is only available in CET but is a planned TT3 +feature. + + [% SET a = 1 ; SET a = 2 ; GET a %] + [% SET a = 1 + SET a = 2 + GET a + %] + + [% GET 1 + IF 0 # is a post-operative + GET 2 %] # prints 2 + + [% GET 1; + IF 0 # it is block based + GET 2 + END + %] # prints 1 + +The following is the list of directives. =over 4 @@ -1648,6 +1973,19 @@ A simple fix is to do any of the following: This shouldn't be too much hardship and offers the great return of disambiguating virtual method access. +=item C<++ --> + +Pre and post increment and decrement. My be used as either a prefix +or postfix operator. + + [% ++a %][% ++a %] => 12 + + [% a++ %][% a++ %] => 01 + + [% --a %][% --a %] => -1-2 + + [% a-- %][% a-- %] => 0-1 + =item C<** ^ pow> Binary. X raised to the Y power. This isn't available in TT 2.15. @@ -1658,11 +1996,9 @@ Binary. X raised to the Y power. This isn't available in TT 2.15. Unary not. Negation of the value. -=item C<- unary_minus> +=item C<-> -Unary minus. Returns the value multiplied by -1. The operator -"unary_minus" is used internally by CGI::Ex::Template to provide for - -to be listed in the precedence table twice. +Prefix minus. Returns the value multiplied by -1. [% a = 1 ; b = -a ; b %] => -1 @@ -1744,18 +2080,29 @@ The .. operator is the only operator that returns a list of items. =item C -Trinary. Can be nested with other ?: pairs. +Ternary. Can be nested with other ?: pairs. [% 1 ? 2 : 3 %] => 2 [% 0 ? 2 : 3 %] => 3 +=item C<*= += -= /= **= %= ~=> + +Self-modifying assignment. Sets the left hand side +to the operation of the left hand side and right (clear as mud). +In order to not conflict with SET, FOREACH and other operations, this +operator is only available in parenthesis. + + [% a = 2 %][% a += 3 %] --- [% a %] => --- 5 # is was handled by SET + [% a = 2 %][% (a += 3) %] --- [% a %] => 5 --- 5 + =item C<=> Assignment. Sets the left-hand side to the value of the righthand side. In order to not conflict with SET, FOREACH and other operations, this operator is only available in parenthesis. Returns the value of the righthand side. - [% (a = 1) %] --- [% a %] => 1 --- 1 + [% a = 1 %] --- [% a %] => --- 1 # is was handled by SET + [% (a = 1) %] --- [% a %] => 1 --- 1 =item C @@ -1936,49 +2283,7 @@ compiled template. Variables defined here cannot be overridden. Will have the value 42 compiled in. Constants defined in this way can be chained as in [% -constant.foo.bar.baz %] but may only interpolate values that are set -before the compile process begins. This goes one step beyond TT in -that any variable set in VARIABLES, or PRE_DEFINE, or passed to the -process method are allowed - they are not in TT. Variables defined in -the template are not available during the compile process. - - GOOD: - - CONSTANTS => { - foo => { - bar => {baz => 42}, - bim => 57, - }, - bing => 'baz', - bang => 'bim', - }, - VARIABLES => { - bam => 'bar', - }, - - In the template - - [% constants.foo.${constants.bang} %] - - Will correctly print 57. - - GOOD (non-tt behavior) - - [% constants.foo.$bam.${constants.bing} %] - - CGI::Ex::Template will print 42 because the value of bam is - known at compile time. TT would print '' because the value of $bam - is not yet defined in the TT engine. - - BAD: - - In the template: - - [% bam = 'somethingelse' %] - [% constants.foo.$bam.${constants.bing} %] - - Will still print 42 because the value of bam used comes from - variables defined before the template was compiled. TT will still print ''. +constant.foo.bar.baz %]. =item CONSTANT_NAMESPACE @@ -1987,9 +2292,9 @@ value is 'constants'. =item DEBUG - Takes a list of constants |'ed together which enables different - debugging modes. Alternately the lowercase names may be used (multiple - values joined by a ",". +Takes a list of constants |'ed together which enables different +debugging modes. Alternately the lowercase names may be used +(multiple values joined by a ","). The only supported TT values are: DEBUG_UNDEF (2) - debug when an undefined value is used. @@ -2010,7 +2315,7 @@ directive. =item DEFAULT -The name of a default template file to use if the passed on is not found. +The name of a default template file to use if the passed one is not found. =item DELIMITER @@ -2434,7 +2739,7 @@ hash that contains the parsed tree. Allow for the multitudinous ways that TT parses arguments. This allows for positional as well as named arguments. Named arguments can be separated with a "=" or "=>", and positional arguments should be separated by " " or ",". This only returns an array -of parsed variables. Use vivify_args to translate to the actual values. +of parsed variables. To get the actual values, you must call get_variable on each value. =item C @@ -2470,11 +2775,6 @@ Called when a variable is undefined during a GET directive. This is useful to see if a value that is about to get inserted into the text is undefined. undefined_any is a little too general for most cases. Also, you may pass a coderef via the UNDEFINED_GET configuration variable. -=item C - -Turns an arrayref of arg identities parsed by parse_args and turns -them into the actual values. - =back @@ -2495,7 +2795,7 @@ upon operator precedence. Used to create a "pseudo" context object that allows for portability of TT plugins, filters, and perl blocks that need a context object. -=ITEM C +=item C TT2 Holdover that is used once for binmode setting during a TT2 test. diff --git a/lib/CGI/Ex/Validate.pm b/lib/CGI/Ex/Validate.pm index b0de244..b0c6b4f 100644 --- a/lib/CGI/Ex/Validate.pm +++ b/lib/CGI/Ex/Validate.pm @@ -22,7 +22,7 @@ use vars qw($VERSION @UNSUPPORTED_BROWSERS ); -$VERSION = '2.01'; +$VERSION = '2.02'; $DEFAULT_EXT = 'val'; $QR_EXTRA = qr/^(\w+_error|as_(array|string|hash)_\w+|no_\w+)/; diff --git a/lib/CGI/Ex/validate.js b/lib/CGI/Ex/validate.js index a5014af..a3b98eb 100644 --- a/lib/CGI/Ex/validate.js +++ b/lib/CGI/Ex/validate.js @@ -4,7 +4,7 @@ * Based upon CGI/Ex/Validate.pm v1.14 from Perl * * For instructions on usage, see perldoc of CGI::Ex::Validate * ***----------------------------------------------------------------**/ -// $Revision: 1.34 $ +// $Revision: 1.35 $ function Validate () { this.error = vob_error; @@ -1047,7 +1047,8 @@ document.check_form = function (form, val_hash) { document.load_val_hash(form, val_hash); // attach handler - form.onsubmit = function () {return document.validate(this)}; + var orig_submit = form.onsubmit || function () { return true }; + form.onsubmit = function (e) { return document.validate(this) && orig_submit(e, this) }; } // the end // diff --git a/samples/benchmark/bench_auth.pl b/samples/benchmark/bench_auth.pl index 6afb9d8..2062b28 100644 --- a/samples/benchmark/bench_auth.pl +++ b/samples/benchmark/bench_auth.pl @@ -45,6 +45,7 @@ use CGI::Ex::Dump qw(debug); sub script_name { $0 } sub no_cookie_verify { 1 } sub secure_hash_keys { ['aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa', 'bbbbbbbbbbbbbbbbbbbbbbbbbbb', 'ccc'] } + sub failed_sleep { 0 } } { diff --git a/t/1_validate_07_yaml.t b/t/1_validate_07_yaml.t index 12d1c1f..7dc54c7 100644 --- a/t/1_validate_07_yaml.t +++ b/t/1_validate_07_yaml.t @@ -7,11 +7,11 @@ =cut use strict; -use Test::More tests => 15; +use Test::More tests => 17; SKIP: { -skip("Missing YAML.pm", 15) if ! eval { require 'YAML' }; +skip("Missing YAML.pm", 17) if ! eval { require 'YAML.pm' }; use_ok('CGI::Ex::Validate'); diff --git a/t/1_validate_08_yaml_file.t b/t/1_validate_08_yaml_file.t index e9c3ca0..27c9539 100644 --- a/t/1_validate_08_yaml_file.t +++ b/t/1_validate_08_yaml_file.t @@ -7,11 +7,11 @@ =cut use strict; -use Test::More tests => 22; +use Test::More tests => 21; SKIP: { -skip("Missing YAML.pm", 22) if ! eval { require 'YAML' }; +skip("Missing YAML.pm", 21) if ! eval { require 'YAML.pm' }; use_ok('CGI::Ex::Validate'); diff --git a/t/1_validate_14_untaint.t b/t/1_validate_14_untaint.t index 0af323b..7dff711 100644 --- a/t/1_validate_14_untaint.t +++ b/t/1_validate_14_untaint.t @@ -13,10 +13,16 @@ use FindBin qw($Bin); use lib ($Bin =~ /(.+)/ ? "$1/../lib" : ''); # add bin - but untaint it ### Set up taint checking -sub is_tainted { local $^W = 0; ! eval { eval("#" . substr(join("", @_), 0, 0)); 1; 0 } } +sub is_tainted { local $^W; eval { eval("#" . substr(join("", @_), 0, 0)); 1; } ? 0 : 1 } SKIP: { +my $ok = 1; +if (is_tainted($ok)) { + skip("is_tainted has false positives($@)", 14); +} + + my $taint = join(",", $0, %ENV, @ARGV); if (! is_tainted($taint) && open(my $fh, "/dev/urandom")) { sysread($fh, $taint, 1); @@ -28,10 +34,13 @@ if (! is_tainted($taint)) { ### make sure tainted hash values don't bleed into other values my $form = {}; +if (is_tainted($form)) { + skip("Tainted doesn't work", 14); +} $form->{'foo'} = "123$taint"; $form->{'bar'} = "456$taint"; $form->{'baz'} = "789"; -if (! is_tainted($form->{'foo'})) { +if (! is_tainted($form->{'foo'})) { skip("Tainted hash key didn't work right", 14); } elsif (is_tainted($form->{'baz'})) { # untaint checking doesn't really work diff --git a/t/3_conf_01_write.t b/t/3_conf_01_write.t index c31bfe4..e4fd1b4 100644 --- a/t/3_conf_01_write.t +++ b/t/3_conf_01_write.t @@ -80,7 +80,7 @@ SKIP: { }; SKIP: { - skip("Config::IniHash not found", 2) if ! eval { require Conifg::IniHash }; + skip("Config::IniHash not found", 2) if ! eval { require Config::IniHash }; ### ini likes hash O' hashes $hash->{'one'} = {}; $hash->{'two'} = {}; diff --git a/t/7_template_00_base.t b/t/7_template_00_base.t index f394d67..48472dd 100644 --- a/t/7_template_00_base.t +++ b/t/7_template_00_base.t @@ -14,7 +14,7 @@ BEGIN { }; use strict; -use Test::More tests => 460 - ($is_tt ? 54 : 0); +use Test::More tests => 514 - ($is_tt ? 103 : 0); use Data::Dumper qw(Dumper); use constant test_taint => 0 && eval { require Taint::Runtime }; @@ -182,6 +182,10 @@ process_ok("[% __foo %]2" => '2', {__foo => 1}); process_ok("[% _foo = 1 %][% _foo %]2" => '2'); process_ok("[% foo._bar %]2" => '2', {foo => {_bar =>1}}); +process_ok("[% qw/Foo Bar Baz/.0 %]" => 'Foo') if ! $is_tt; +process_ok('[% [0..10].-1 %]' => '10') if ! $is_tt; +process_ok('[% [0..10].${ 2.3 } %]' => '2') if ! $is_tt; + ###----------------------------------------------------------------### ### variable SETting @@ -242,13 +246,18 @@ process_ok("[% SET foo = ['z'..'a'] %][% foo.6 %]" => ''); process_ok("[% SET foo = ['a'..'z'].reverse %][% foo.6 %]" => 't') if ! $is_tt; process_ok("[% foo = 1 %][% foo %]" => '1'); -process_ok("[% foo = 1 bar = 2 %][% foo %][% bar %]" => '12'); process_ok("[% foo = 1 ; bar = 2 %][% foo %][% bar %]" => '12'); process_ok("[% foo.bar = 2 %][% foo.bar %]" => '2'); process_ok('[% a = "a" %][% (b = a) %][% a %][% b %]' => 'aaa'); process_ok('[% a = "a" %][% (c = (b = a)) %][% a %][% b %][% c %]' => 'aaaa'); +process_ok("[% a = qw{Foo Bar Baz} ; a.2 %]" => 'Baz') if ! $is_tt; + +process_ok("[% foo = 1 bar = 2 %][% foo %][% bar %]" => '12'); +process_ok("[% foo = 1 bar = 2 %][% foo = 3 bar %][% foo %][% bar %]" => '232') if ! $is_tt; +process_ok("[% a = 1 a = a + 2 a %]" => 3) if ! $is_tt; + ###----------------------------------------------------------------### ### Reserved words @@ -296,6 +305,8 @@ process_ok("[% 123.length %]" => 3) if ! $is_tt; process_ok("[% 123.2.length %]" => 5) if ! $is_tt; process_ok("[% -123.2.length %]" => -5) if ! $is_tt; # the - doesn't bind as tight as the dot methods process_ok("[% (-123.2).length %]" => 6) if ! $is_tt; +process_ok("[% a = 23; a.0 %]" => 23) if ! $is_tt; # '0' is a scalar_op +process_ok('[% 1.rand %]' => qr/^0\.\d+$/) if ! $is_tt; process_ok("[% n.repeat %]" => '1', {n => 1}) if ! $is_tt; # tt2 virtual method defaults to 0 process_ok("[% n.repeat(0) %]" => '', {n => 1}); @@ -334,8 +345,36 @@ process_ok('[% "hi" FILTER foo %]' => 'hihi', {tt_config => [FILTERS => {foo => process_ok('[% "hi" FILTER foo %]' => 'hihi', {tt_config => [FILTERS => {foo => [sub {$_[0]x2},0]}]}); process_ok('[% "hi" FILTER foo(2) %]' => 'hihi', {tt_config => [FILTERS => {foo => [sub {my$a=$_[1];sub{$_[0]x$a}},1]}]}); -### this does work - but requires that Template::Filters is installed -#process_ok("[% ' ' | uri %]" => '%20'); +process_ok('[% ["a".."z"].random %]' => qr/^[a-z]/) if ! $is_tt; +process_ok('[% ["a".."z"].${ 26.rand } %]' => qr/^[a-z]/) if ! $is_tt; + +process_ok("[% ' ' | uri %]" => '%20'); + +process_ok('[% "one".as %]' => "one") if ! $is_tt; +process_ok('[% 2.as("%02d") %]' => "02") if ! $is_tt; + +process_ok('[% [1..3].as %]' => "1 2 3") if ! $is_tt; +process_ok('[% [1..3].as("%02d") %]' => '01 02 03') if ! $is_tt; +process_ok('[% [1..3].as("%s", ", ") %]' => '1, 2, 3') if ! $is_tt; + +process_ok('[% {a => "B", c => "D"}.as %]' => "a\tB\nc\tD") if ! $is_tt; +process_ok('[% {a => "B", c => "D"}.as("%s:%s") %]' => "a:B\nc:D") if ! $is_tt; +process_ok('[% {a => "B", c => "D"}.as("%s:%s", "; ") %]' => "a:B; c:D") if ! $is_tt; + +###----------------------------------------------------------------### +### virtual objects + +process_ok('[% a = "foobar" %][% Text.length(a) %]' => 6) if ! $is_tt; +process_ok('[% a = [1 .. 10] %][% List.size(a) %]' => 10) if ! $is_tt; +process_ok('[% a = {a=>"A", b=>"B"} ; Hash.size(a) %]' => 2) if ! $is_tt; + +process_ok('[% a = Text.new("This is a string") %][% a.length %]' => 16) if ! $is_tt; +process_ok('[% a = List.new("one", "two", "three") %][% a.size %]' => 3) if ! $is_tt; +process_ok('[% a = Hash.new("one", "ONE") %][% a.one %]' => 'ONE') if ! $is_tt; +process_ok('[% a = Hash.new(one = "ONE") %][% a.one %]' => 'ONE') if ! $is_tt; +process_ok('[% a = Hash.new(one => "ONE") %][% a.one %]' => 'ONE') if ! $is_tt; + +process_ok('[% {a => 1, b => 2} | Hash.keys | List.join(", ") %]' => 'a, b'); ###----------------------------------------------------------------### ### chomping @@ -357,6 +396,14 @@ process_ok("[% foo -%]\n " => ' '); process_ok("[% foo -%]\n\n\n" => "\n\n"); process_ok("[% foo -%] \n " => ' '); + +###----------------------------------------------------------------### +### concat + +process_ok('[% a = "foo"; a _ "bar" %]' => 'foobar'); +process_ok('[% a = "foo"; a ~ "bar" %]' => 'foobar') if ! $is_tt; +process_ok('[% a = "foo"; a ~= "bar"; a %]' => 'foobar') if ! $is_tt; + ###----------------------------------------------------------------### ### math operations @@ -383,6 +430,29 @@ process_ok("[% 2 * 2 ** 3 %]" => 16) if ! $is_tt; process_ok("[% SET foo = 1 %][% foo + 2 %]" => 3); process_ok("[% SET foo = 1 %][% (foo + 2) %]" => 3); +process_ok("[% a = 1; (a += 2) %]" => 3) if ! $is_tt; +process_ok("[% a = 1; (a -= 2) %]" => -1) if ! $is_tt; +process_ok("[% a = 4; (a /= 2) %]" => 2) if ! $is_tt; +process_ok("[% a = 1; (a *= 2) %]" => 2) if ! $is_tt; +process_ok("[% a = 3; (a **= 2) %]" => 9) if ! $is_tt; +process_ok("[% a = 1; (a %= 2) %]" => 1) if ! $is_tt; + +process_ok('[% a += 1 %]-[% a %]-[% a += 1 %]-[% a %]' => '-1--2') if ! $is_tt; +process_ok('[% (a += 1) %]-[% (a += 1) %]' => '1-2') if ! $is_tt; + +process_ok('[% a = 2; a -= 3; a %]' => '-1') if ! $is_tt; +process_ok('[% a = 2; a *= 3; a %]' => '6') if ! $is_tt; +process_ok('[% a = 2; a /= .5; a %]' => '4') if ! $is_tt; +process_ok('[% a = 8; a %= 3; a %]' => '2') if ! $is_tt; +process_ok('[% a = 2; a **= 3; a %]' => '8') if ! $is_tt; + +process_ok('[% a = 1 %][% ++a %][% a %]' => '22') if ! $is_tt; +process_ok('[% a = 1 %][% a++ %][% a %]' => '12') if ! $is_tt; +process_ok('[% a = 1 %][% --a %][% a %]' => '00') if ! $is_tt; +process_ok('[% a = 1 %][% a-- %][% a %]' => '10') if ! $is_tt; +process_ok('[% a++ FOR [1..3] %]' => '012') if ! $is_tt; +process_ok('[% --a FOR [1..3] %]' => '-1-2-3') if ! $is_tt; + ###----------------------------------------------------------------### ### boolean operations @@ -487,6 +557,8 @@ process_ok("[% FOREACH f = [1..3] %][% IF loop.first %][% LAST %][% END %][% f % process_ok("[% FOREACH f = [1..3] %][% f %][% IF loop.first %][% NEXT %][% END %][% END %]" => '123'); process_ok("[% FOREACH f = [1..3] %][% f %][% IF loop.first %][% LAST %][% END %][% END %]" => '1'); +process_ok('[% a = ["Red", "Blue"] ; FOR [0..3] ; a.${ loop.index % a.size } ; END %]' => 'RedBlueRedBlue') if ! $is_tt; + ### TT is not consistent in what is localized - well it is documented ### if you set a variable in the FOREACH tag, then nothing in the loop gets localized ### if you don't set a variable - everything gets localized @@ -737,3 +809,9 @@ process_ok("[% PERL %] print \$stash->set('a.b.c', 7) [% END %][% a.b.c %]" => ' process_ok("[% BLOCK foo %][% PROCESS bar %][% END %][% BLOCK bar %][% PROCESS foo %][% END %][% PROCESS foo %]" => '') if ! $is_tt; +###----------------------------------------------------------------### +### META + +process_ok("[% template.name %]" => 'input text'); +process_ok("[% META foo = 'bar' %][% template.foo %]" => 'bar'); +process_ok("[% META foo = 'bar' %][% component.foo %]" => 'bar'); diff --git a/t/8_auth_00_base.t b/t/8_auth_00_base.t index 90e6e51..c47492c 100644 --- a/t/8_auth_00_base.t +++ b/t/8_auth_00_base.t @@ -24,6 +24,7 @@ use_ok('CGI::Ex::Auth'); sub script_name { $0 } sub no_cookie_verify { 1 } sub secure_hash_keys { ['aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa', 'bbbbbbbbbbbbbbbbbbbbbbbbbbb', 'ccc'] } + sub failed_sleep { 0 } } { -- 2.45.2