+2.10 2007-04-27
+ * Allow for fully regex grammar based engine.
+ * Move to generic operator parse tree. All constructs are now only arrayrefs.
+ This should allow for easy porting to other languages.
+ * Allow for nested tags [% "[% 2 %]" | eval %].
+ * Added back in references in Template - but fast and simple.
+ * Allow for regex based TAGS.
+ * Allow for "unquoted" in TAGS.
+ * Catch parsing bug in "1 - + 2" in Template.
+ * Fix minor bug in Template qw() construct.
+ * Re-added ANYCASE support.
+ * Added V1DOLLAR support.
+ * Remove GROUP support from CGI::Ex::Validate.
+ * Allow for crypted passwords to work in Auth.
+
2.09 2007-04-05
* Add more documentation about file paths
* Allow for base_dir_abs to return a single value, or an arrayref of values, or
samples/benchmark/bench_conf_writers.pl
samples/benchmark/bench_jsondump.pl
samples/benchmark/bench_method_calling.pl
+samples/benchmark/bench_operator_storage.pl
samples/benchmark/bench_optree.pl
samples/benchmark/bench_template.pl
samples/benchmark/bench_template_tag_parser.pl
samples/benchmark/bench_validation.pl
samples/benchmark/bench_various_templaters.pl
-samples/conf_path_1/apples.pl
-samples/conf_path_1/oranges.pl
-samples/conf_path_3/apples.pl
-samples/conf_path_3/oranges.pl
+samples/benchmark/bench_various_templaters.pl.out
samples/devel/dprof_conf.d
samples/devel/dprof_template.d
samples/devel/dprof_validation.d
samples/generate_js.pl
-samples/html1.htm
-samples/html2.htm
samples/index.cgi
samples/js_validate_1.html
samples/js_validate_2.html
samples/js_validate_3.html
samples/memory_template.pl
-samples/perl1.pl
-samples/perl2.pl
-samples/yaml1.val
-samples/yaml2.val
-samples/yaml3.val
samples/yaml_js_1.html
samples/yaml_js_2.html
samples/yaml_js_3.html
t/1_validate_00_base.t
t/1_validate_03_cgi.t
t/1_validate_05_types.t
-t/1_validate_06_groups.t
t/1_validate_07_yaml.t
-t/1_validate_08_yaml_file.t
t/1_validate_11_no_extra.t
t/1_validate_12_change.t
t/1_validate_14_untaint.t
t/2_fill_19_complex.t
t/2_fill_20_switcharoo.t
t/3_conf_00_base.t
-t/3_conf_01_write.t
t/4_app_00_base.t
t/5_dump_00_base.t
t/6_die_00_base.t
# 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.09
+version: 2.10
version_from: lib/CGI/Ex.pm
installdirs: site
requires:
use base qw(Exporter);
BEGIN {
- $VERSION = '2.09';
+ $VERSION = '2.10';
$PREFERRED_CGI_MODULE ||= 'CGI';
@EXPORT = ();
@EXPORT_OK = qw(get_form
use vars qw($VERSION);
BEGIN {
- $VERSION = '2.09';
+ $VERSION = '2.10';
Time::HiRes->import('time') if eval {require Time::HiRes};
eval {require Scalar::Util};
use Digest::MD5 qw(md5_hex);
use CGI::Ex;
-$VERSION = '2.09';
+$VERSION = '2.10';
###----------------------------------------------------------------###
if ( (defined($data->{'use_plaintext'}) ? $data->{'use_plaintext'} : $self->use_plaintext) # ->use_plaintext is true if ->use_crypt is
|| (defined($data->{'use_crypt'}) && $data->{'use_crypt'})
|| (defined($data->{'type'}) && $data->{'type'} eq 'crypt')) {
- $token = $data->{'user'} .'/'. $data->{'real_pass'};
+ my $pass = defined($data->{'test_pass'}) ? $data->{'test_pass'} : $data->{'real_pass'};
+ $token = $data->{'user'} .'/'. $pass;
### all other types go to cram - secure_hash_cram, cram, plaintext and md5
} else {
);
@EXPORT_OK = qw(conf_read conf_write in_cache);
-$VERSION = '2.09';
+$VERSION = '2.10';
$DEFAULT_EXT = 'conf';
use CGI::Ex::Dump qw(debug ctrace dex_html);
BEGIN {
- $VERSION = '2.09';
+ $VERSION = '2.10';
$SHOW_TRACE = 0 if ! defined $SHOW_TRACE;
$IGNORE_EVAL = 0 if ! defined $IGNORE_EVAL;
$EXTENDED_ERRORS = 1 if ! defined $EXTENDED_ERRORS;
use strict;
use Exporter;
-$VERSION = '2.09';
+$VERSION = '2.10';
@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);
use base qw(Exporter);
BEGIN {
- $VERSION = '2.09';
+ $VERSION = '2.10';
@EXPORT = qw(form_fill);
@EXPORT_OK = qw(fill form_fill html_escape get_tagval_by_key swap_tagval_by_key);
};
use base qw(Exporter);
BEGIN {
- $VERSION = '2.09';
+ $VERSION = '2.10';
@EXPORT = qw(JSONDump);
@EXPORT_OK = @EXPORT;
$QR_PRIVATE
$PACKAGE_EXCEPTION $PACKAGE_ITERATOR $PACKAGE_CONTEXT $PACKAGE_STASH $PACKAGE_PERL_HANDLE
+ $MAX_EVAL_RECURSE $MAX_MACRO_RECURSE
$WHILE_MAX
$EXTRA_COMPILE_EXT
$DEBUG
);
BEGIN {
- $VERSION = '2.09';
+ $VERSION = '2.10';
$PACKAGE_EXCEPTION = 'CGI::Ex::Template::Exception';
$PACKAGE_ITERATOR = 'CGI::Ex::Template::Iterator';
$PACKAGE_CONTEXT = 'CGI::Ex::Template::_Context';
$PACKAGE_STASH = 'CGI::Ex::Template::_Stash';
$PACKAGE_PERL_HANDLE = 'CGI::Ex::Template::EvalPerlHandle';
+ $MAX_EVAL_RECURSE = 50;
+ $MAX_MACRO_RECURSE = 50;
$TAGS = {
- default => ['[%', '%]'], # default
- template => ['[%', '%]'], # default
- metatext => ['%%', '%%'], # Text::MetaText
- star => ['[*', '*]'], # TT alternate
- php => ['<?', '?>'], # PHP
- asp => ['<%', '%>'], # ASP
- mason => ['<%', '>' ], # HTML::Mason
- html => ['<!--', '-->'], # HTML comments
+ asp => ['<%', '%>' ], # ASP
+ default => ['\[%', '%\]' ], # default
+ html => ['<!--', '-->' ], # HTML comments
+ mason => ['<%', '>' ], # HTML::Mason
+ metatext => ['%%', '%%' ], # Text::MetaText
+ php => ['<\?', '\?>' ], # PHP
+ star => ['\[\*', '\*\]' ], # TT alternate
+ template1 => ['[\[%]%', '%[%\]]'], # allow TT1 style
};
$SCALAR_OPS = {
INSERT => [\&parse_INSERT, \&play_INSERT],
LAST => [sub {}, \&play_control],
MACRO => [\&parse_MACRO, \&play_MACRO],
- META => [undef, sub {}],
- METADEF => [undef, \&play_METADEF],
+ META => [undef, \&play_META],
NEXT => [sub {}, \&play_control],
PERL => [\&parse_PERL, \&play_PERL, 1],
PROCESS => [\&parse_PROCESS, \&play_PROCESS],
WRAPPER => [\&parse_WRAPPER, \&play_WRAPPER, 1, 1],
#name #parse_sub #play_sub #block #postdir #continue #move_to_front
};
- $QR_DIRECTIVE = qr{ ^ (\w+|\|) (?= $|[\s;\#]) }x;
### setup the operator parsing
$OPERATORS = [
# type precedence symbols action (undef means play_operator will handle)
- ['postfix', 99, ['++'], undef ],
- ['postfix', 99, ['--'], undef ],
- ['prefix', 98, ['++'], undef ],
- ['prefix', 98, ['--'], undef ],
+ ['prefix', 99, ['\\'], undef ],
+ ['postfix', 98, ['++'], undef ],
+ ['postfix', 98, ['--'], undef ],
+ ['prefix', 97, ['++'], undef ],
+ ['prefix', 97, ['--'], undef ],
['right', 96, ['**', 'pow'], sub { $_[0] ** $_[1] } ],
['prefix', 93, ['!'], sub { ! $_[0] } ],
['prefix', 93, ['-'], sub { @_ == 1 ? 0 - $_[0] : $_[0] - $_[1] } ],
['left', 90, ['%', 'mod', 'MOD'], sub { $_[0] % $_[1] } ],
['left', 85, ['+'], sub { $_[0] + $_[1] } ],
['left', 85, ['-'], sub { @_ == 1 ? 0 - $_[0] : $_[0] - $_[1] } ],
- ['left', 85, ['~', '_'], sub { join "", @_ } ],
+ ['left', 85, ['~', '_'], undef ],
['none', 80, ['<'], sub { $_[0] < $_[1] } ],
['none', 80, ['>'], sub { $_[0] > $_[1] } ],
['none', 80, ['<='], 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] } ],
['left', 45, ['and', 'AND'], undef ],
['right', 40, ['or', 'OR'], undef ],
- ['', 0, ['hash'], sub { return {@_}; } ],
- ['', 0, ['array'], sub { return [@_] } ],
+ ['', 0, ['{}'], undef ],
+ ['', 0, ['[]'], undef ],
];
$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_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 '|', reverse sort map {quotemeta $_} grep {++$used{$_} < 2} grep {/^\W{2,}$/} @_;
+ my $chrs = join '|', reverse sort map {quotemeta $_} grep {++$used{$_} < 2} grep {! /\{\}|\[\]/} 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;
$QR_OP_PREFIX = _build_op_qr_prefix();
$QR_OP_ASSIGN = _build_op_qr_assign();
+ $QR_DIRECTIVE = '( [a-zA-Z]+\b | \| )';
$QR_COMMENTS = '(?-s: \# .* \s*)*';
$QR_FILENAME = '([a-zA-Z]]:/|/)? [\w\-\.]+ (?:/[\w\-\.]+)*';
$QR_NUM = '(?:\d*\.\d+ | \d+) (?: [eE][+-]\d+ )?';
$QR_PRIVATE = qr/^[_.]/;
$WHILE_MAX = 1000;
- $EXTRA_COMPILE_EXT = '.sto';
+ $EXTRA_COMPILE_EXT = '.sto2';
eval {require Scalar::Util};
};
sub new {
my $class = shift;
my $args = ref($_[0]) ? { %{ shift() } } : {@_};
+
+ ### allow for lowercase args
+ if (my @keys = grep {/^[a-z][a-z_]+$/} keys %$args) {
+ @{ $args }{ map { uc $_ } @keys } = delete @{ $args }{ @keys };
+ }
+
my $self = bless $args, $class;
### "enable" debugging - we only support DEBUG_DIRS and DEBUG_UNDEF
my $_tree = $ref->{'_tree'};
foreach my $node (@$_tree) {
next if ! ref $node;
- next if $node->[0] eq 'METADEF';
+ next if $node->[0] eq 'META';
last if $node->[0] ne 'BLOCK';
next if $block_name ne $node->[3];
$doc->{'_content'} = $ref->{'_content'};
return $doc;
}
+###----------------------------------------------------------------###
+
sub parse_tree {
my $self = shift;
my $str_ref = shift;
my $STYLE = $self->{'TAG_STYLE'} || 'default';
my $START = $self->{'START_TAG'} || $TAGS->{$STYLE}->[0];
my $END = $self->{'END_TAG'} || $TAGS->{$STYLE}->[1];
- my $len_s = length $START;
- my $len_e = length $END;
+ local $self->{'_end_tag'} = $END;
my @tree; # the parsed tree
my $pointer = \@tree; # pointer to current tree to handle nested blocks
local $self->{'_state'} = \@state; # allow for items to introspect (usually BLOCKS)
local $self->{'_in_perl'}; # no interpolation in perl
my @move_to_front; # items that need to be declared first (usually BLOCKS)
- my @meta; # place to store any found meta information (to go into METADEF)
- my $i = 0; # start index
- my $j = 0; # end index
- my $last = 0; # previous end index
+ my @meta; # place to store any found meta information (to go into META)
my $post_chomp = 0; # previous post_chomp setting
- my $continue; # multiple directives in the same tag
+ my $continue = 0; # flag for multiple directives in the same tag
my $post_op; # found a post-operative DIRECTIVE
my $capture; # flag to start capture
my $func;
my $node;
- my $tag;
+ my $mark;
+ local pos $$str_ref = 0;
+
while (1) {
### continue looking for information in a semi-colon delimited tag
if ($continue) {
- $i = $continue;
- $node = [undef, $i, $j];
+ $node = [undef, pos($$str_ref), undef];
### look through the string using index
} else {
- $i = index($$str_ref, $START, $last);
- last if $i == -1; # no start tag found - we are done
- if ($last != $i) { # found a text portion - chomp it, interpolate it and store it
- my $text = substr($$str_ref, $last, $i - $last);
- my $_last = $last;
+ $$str_ref =~ m{ \G (.*?) $START }gcxs
+ || last;
+
+ ### found a text portion - chomp it, interpolate it and store it
+ if (length $1) {
+ my $text = $1;
+
+ if ($text =~ m{ ($END) }xs) {
+ my $char = pos($$str_ref) + $-[1] + 1;
+ $self->throw('parse', "Found unmatched closing tag \"$1\"", undef, $char);
+ }
+
+ my $_last = pos $$str_ref;
if ($post_chomp) {
if ($post_chomp == 1) { $_last += length($1) if $text =~ s{ ^ ([^\S\n]* \n) }{}x }
elsif ($post_chomp == 2) { $_last += length($1) + 1 if $text =~ s{ ^ (\s+) }{ }x }
$self->interpolate_node($pointer, $_last) if $self->{'INTERPOLATE'};
}
}
- $j = index($$str_ref, $END, $i + $len_s);
- $last = $j + $len_e;
- if ($j == -1) { # missing closing tag
- $last = length($$str_ref);
- last;
- }
- $tag = substr($$str_ref, $i + $len_s, $j - ($i + $len_s));
- $node = [undef, $i + $len_s, $j];
+
+ $node = [undef, pos($$str_ref), undef];
### take care of whitespace and comments flags
- my $pre_chomp = $tag =~ s{ ^ ([+=~-]) }{}x ? $1 : $self->{'PRE_CHOMP'};
- $post_chomp = $tag =~ s{ ([+=~-]) $ }{}x ? $1 : $self->{'POST_CHOMP'};
+ my $pre_chomp = $$str_ref =~ m{ \G ([+=~-]) }gcx ? $1 : $self->{'PRE_CHOMP'};
$pre_chomp =~ y/-=~+/1230/ if $pre_chomp;
- $post_chomp =~ y/-=~+/1230/ if $post_chomp;
if ($pre_chomp && $pointer->[-1] && ! ref $pointer->[-1]) {
if ($pre_chomp == 1) { $pointer->[-1] =~ s{ (?:\n|^) [^\S\n]* \z }{}x }
elsif ($pre_chomp == 2) { $pointer->[-1] =~ s{ (\s+) \z }{ }x }
elsif ($pre_chomp == 3) { $pointer->[-1] =~ s{ (\s+) \z }{}x }
splice(@$pointer, -1, 1, ()) if ! length $pointer->[-1]; # remove the node if it is zero length
}
- if ($tag =~ /^\#/) { # leading # means to comment the entire section
+ if ($$str_ref =~ m{ \G \# }gcx) { # leading # means to comment the entire section
+ $$str_ref =~ m{ \G (.*?) ($END) }gcxs # brute force - can't comment tags with nested %]
+ || $self->throw('parse', "Missing closing tag", undef, pos($$str_ref));
$node->[0] = '#';
+ $node->[2] = pos($$str_ref) - length($2);
push @$pointer, $node;
next;
}
- $tag =~ s{ ^ \s+ $QR_COMMENTS }{}ox;
- }
-
- if (! length $tag) {
- undef $continue;
- undef $post_op;
- next;
+ $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo;
}
### look for DIRECTIVES
- if ($tag =~ $QR_DIRECTIVE # find a word
- && $DIRECTIVES->{$1} ) { # is it a directive
- $node->[0] = $func = $1;
- $tag =~ s{ ^ (\w+ | \|) \s* $QR_COMMENTS }{}ox;
+ if ($$str_ref =~ m{ \G $QR_DIRECTIVE }gcxo # find a word
+ && ($func = $self->{'ANYCASE'} ? uc($1) : $1)
+ && ($DIRECTIVES->{$func}
+ || ((pos($$str_ref) -= length $1) && 0))
+ ) { # is it a directive
+ $node->[0] = $func;
+ $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcx;
### store out this current node level
if ($post_op) { # on a post operator - replace the original node with the new one - store the old in the new
### anything that behaves as a block ending
if ($func eq 'END' || $DIRECTIVES->{$func}->[4]) { # [4] means it is a continuation block (ELSE, CATCH, etc)
if (! @state) {
- $self->throw('parse', "Found an $func tag while not in a block", $node);
+ $self->throw('parse', "Found an $func tag while not in a block", $node, pos($$str_ref));
}
my $parent_node = pop @state;
### continuation block - such as an elsif
} else {
- $node->[3] = eval { $DIRECTIVES->{$func}->[0]->($self, \$tag, $node) };
+ $node->[3] = eval { $DIRECTIVES->{$func}->[0]->($self, $str_ref, $node) };
if (my $err = $@) {
$err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node;
die $err;
}
} elsif ($func eq 'TAGS') {
- if ($tag =~ / ^ (\w+) /x && $TAGS->{$1}) {
- $tag =~ s{ ^ (\w+) \s* $QR_COMMENTS }{}ox;
- ($START, $END) = @{ $TAGS->{$1} };
- } elsif ($tag =~ s{ ^ (\S+) \s+ (\S+) \s* $QR_COMMENTS }{}ox) {
- ($START, $END) = ($1, $2);
+ my $end;
+ if ($$str_ref =~ m{
+ \G (\w+) # tags name
+ \s* $QR_COMMENTS # optional comments
+ ([+~=-]?) ($END) # forced close
+ }gcx) {
+ my $ref = $TAGS->{lc $1} || $self->throw('parse', "Invalid TAGS name \"$1\"", undef, pos($$str_ref));
+ ($START, $END) = @$ref;
+ ($post_chomp, $end) = ($2, $3);
+
+ } elsif ($$str_ref =~ m{
+ \G (\S+) \s+ (\S+) # two non-space things
+ (?:\s+(un|)quoted?)? # optional unquoted adjective
+ \s* $QR_COMMENTS # optional comments
+ ([+~=-]?) ($END) # forced close
+ }gcxo) {
+ ($START, $END, my $unquote, $post_chomp, $end) = ($1, $2, $3, $4, $5);
+ for ($START, $END) {
+ if ($unquote) { eval { "" =~ /$_/; 1 } || $self->throw('parse', "Invalid TAGS \"$_\": $@", undef, pos($$str_ref)) }
+ else { $_ = quotemeta $_ }
+ }
+ } else {
+ $self->throw('parse', "Invalid TAGS", undef, pos($$str_ref));
}
- $len_s = length $START;
- $len_e = length $END;
+ $post_chomp ||= $self->{'POST_CHOMP'};
+ $post_chomp =~ y/-=~+/1230/ if $post_chomp;
+
+ $node->[2] = pos($$str_ref) - length($end);
+ $continue = 0;
+ $post_op = undef;
+
+ $self->{'_end_tag'} = $END; # need to keep track so parse_expr knows when to stop
+ next;
} elsif ($func eq 'META') {
- my $args = $self->parse_args(\$tag);
+ my $args = $self->parse_args($str_ref);
my $hash;
if (($hash = $self->play_expr($args->[-1]))
&& UNIVERSAL::isa($hash, 'HASH')) {
### all other "normal" tags
} else {
- $node->[3] = eval { $DIRECTIVES->{$func}->[0]->($self, \$tag, $node) };
+ $node->[3] = eval { $DIRECTIVES->{$func}->[0]->($self, $str_ref, $node) };
if (my $err = $@) {
$err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node;
die $err;
}
}
+ #} elsif (1) {
+ # $node->[0] = 'GET';
+ # $node->[2] = $node->[1] + 5;
+ # $node->[3] = ['one',0];
+ # $$str_ref =~ m{ $END }gcx;
+ # push @$pointer, $node;
+ # next;
+
### allow for bare variable getting and setting
- } elsif (defined(my $var = $self->parse_expr(\$tag))) {
+ } elsif (defined(my $var = $self->parse_expr($str_ref))) {
push @$pointer, $node;
- if ($tag =~ s{ ^ ($QR_OP_ASSIGN) >? \s* $QR_COMMENTS }{}ox) {
+ if ($$str_ref =~ m{ \G ($QR_OP_ASSIGN) >? \s* $QR_COMMENTS }gcxo) {
$node->[0] = 'SET';
- $node->[3] = eval { $DIRECTIVES->{'SET'}->[0]->($self, \$tag, $node, $1, $var) };
+ $node->[3] = eval { $DIRECTIVES->{'SET'}->[0]->($self, $str_ref, $node, $1, $var) };
if (my $err = $@) {
$err->node($node) if UNIVERSAL::can($err, 'node') && ! $err->node;
die $err;
$node->[3] = $var;
}
+ ### now look for the closing tag
+ } elsif ($$str_ref =~ m{ \G ([+=~-]?) ($END) }gcxs) {
+ my $end = $2;
+ $post_chomp = $1 || $self->{'POST_CHOMP'};
+ $post_chomp =~ y/-=~+/1230/ if $post_chomp;
+
+ $node->[2] = pos($$str_ref) - length($end);
+ $continue = 0;
+ $post_op = undef;
+
} else { # error
- my $all = substr($$str_ref, $i + $len_s, $j - ($i + $len_s));
+ my $all = substr($$str_ref, $node->[1], pos($$str_ref) - $node->[1]);
$all =~ s/^\s+//;
$all =~ s/\s+$//;
$self->throw('parse', "Not sure how to handle tag \"$all\"", $node);
undef $capture;
}
+ ### look for the closing tag again
+ if ($$str_ref =~ m{ \G ([+=~-]?) ($END) }gcxs) {
+ my $end = $2;
+ $post_chomp = $1 || $self->{'POST_CHOMP'};
+ $post_chomp =~ y/-=~+/1230/ if $post_chomp;
+
+ $node->[2] = pos($$str_ref) - length($end);
+ $continue = 0;
+ $post_op = undef;
+ next;
+ }
+
+ ### we always continue - and always record our position now
+ $continue = 1;
+ $node->[2] = pos $$str_ref;
+
### we are flagged to start capturing the output of the next directive - set it up
if ($node->[6]) {
- $continue = $j - length $tag;
- $node->[2] = $continue;
$post_op = undef;
$capture = $node;
### semi-colon = end of statement - we will need to continue parsing this tag
- } elsif ($tag =~ s{ ^ ; \s* $QR_COMMENTS }{}ox) {
- $continue = $j - length $tag;
- $node->[2] = $continue;
- $post_op = undef;
-
- ### looking at a post operator ([% u FOREACH u IN [1..3] %])
- } elsif ($tag =~ $QR_DIRECTIVE # find a word
- && $DIRECTIVES->{$1} # is it a directive
- && $DIRECTIVES->{$1}->[3]) { # it is a post operative directive
- $continue = $j - length $tag;
- $node->[2] = $continue;
- $post_op = $node;
-
- ### unlink TT2 - look for another directive
- } elsif (length $tag) {
- #$self->throw('parse', "Found trailing info \"$tag\"", $node);
- $continue = $j - length $tag;
- $node->[2] = $continue;
+ } elsif ($$str_ref =~ m{ \G ; \s* $QR_COMMENTS }gcxo) {
$post_op = undef;
} else {
- $continue = undef;
- $post_op = undef;
+ ### looking at a post operator ([% u FOREACH u IN [1..3] %])
+ $mark = pos $$str_ref;
+ if ($$str_ref =~ m{ \G $QR_DIRECTIVE }gcxo # find a word without advancing position
+ && ($func = $self->{'ANYCASE'} ? uc($1) : $1)
+ && (($DIRECTIVES->{$func} # and its a directive
+ && $DIRECTIVES->{$func}->[3]) # that can be post operative
+ || ((pos($$str_ref) = $mark) && 0)) # otherwise rollback
+ ) {
+ $post_op = $node; # store flag so next loop puts items in this node
+ pos($$str_ref) = $mark;
+
+ } else {
+ $post_op = undef;
+ }
}
}
unshift @tree, @move_to_front;
}
if (@meta) {
- unshift @tree, ['METADEF', 0, 0, {@meta}];
+ unshift @tree, ['META', 0, 0, {@meta}];
}
if ($#state > -1) {
}
### pull off the last text portion - if any
- if ($last != length($$str_ref)) {
- my $text = substr($$str_ref, $last, length($$str_ref) - $last);
- my $_last = $last;
+ if (pos($$str_ref) != length($$str_ref)) {
+ my $text = substr $$str_ref, pos($$str_ref);
+
+ if ($text =~ m{ ($END) }xs) {
+ my $char = pos($$str_ref) + $-[1] + 1;
+ $self->throw('parse', "Found unmatched closing tag \"$1\"", undef, $char);
+ }
+
+ my $_last = pos($$str_ref);
if ($post_chomp) {
if ($post_chomp == 1) { $_last += length($1) if $text =~ s{ ^ ([^\S\n]* \n) }{}x }
elsif ($post_chomp == 2) { $_last += length($1) + 1 if $text =~ s{ ^ (\s+) }{ }x }
return \@tree;
}
-sub execute_tree {
- my ($self, $tree, $out_ref) = @_;
-
- # node contains (0: DIRECTIVE,
- # 1: start_index,
- # 2: end_index,
- # 3: parsed tag details,
- # 4: sub tree for block types
- # 5: continuation sub trees for sub continuation block types (elsif, else, etc)
- # 6: flag to capture next directive
- for my $node (@$tree) {
- ### text nodes are just the bare text
- if (! ref $node) {
- warn "NODE: TEXT\n" if trace;
- $$out_ref .= $node if defined $node;
- next;
- }
-
- warn "NODE: $node->[0] (char $node->[1])\n" if trace;
- $$out_ref .= $self->debug_node($node) if $self->{'_debug_dirs'} && ! $self->{'_debug_off'};
-
- my $val = $DIRECTIVES->{$node->[0]}->[1]->($self, $node->[3], $node, $out_ref);
- $$out_ref .= $val if defined $val;
- }
-}
-
-###----------------------------------------------------------------###
-
sub parse_expr {
my $self = shift;
my $str_ref = shift;
my $ARGS = shift || {};
+ my $is_aq = $ARGS->{'auto_quote'} ? 1 : 0;
### allow for custom auto_quoting (such as hash constructors)
- if ($ARGS->{'auto_quote'}) {
- if ($$str_ref =~ $ARGS->{'auto_quote'}) {
- my $str = $1;
- substr($$str_ref, 0, length($str), '');
- $$str_ref =~ s{ ^ \s* $QR_COMMENTS }{}ox;
- return $str;
+ if ($is_aq) {
+ if ($$str_ref =~ m{ \G $ARGS->{'auto_quote'} \s* $QR_COMMENTS }gcx) {
+ return $1;
+
### allow for auto-quoted $foo or ${foo.bar} type constructs
- } elsif ($$str_ref =~ s{ ^ \$ (\w+ (?:\.\w+)*) \b \s* $QR_COMMENTS }{}ox
- || $$str_ref =~ s{ ^ \$\{ \s* ([^\}]+) \} \s* $QR_COMMENTS }{}ox) {
+ } elsif ($$str_ref =~ m{ \G \$ (\w+ (?:\.\w+)*) \b \s* $QR_COMMENTS }gcxo) {
my $name = $1;
return $self->parse_expr(\$name);
+
+ } elsif ($$str_ref =~ m{ \G \$\{ \s* }gcx) {
+ my $var = $self->parse_expr($str_ref);
+ $$str_ref =~ m{ \G \s* \} \s* $QR_COMMENTS }gcxo
+ || $self->throw('parse', 'Missing close "}" from "${"', undef, pos($$str_ref));
+ return $var;
}
}
- my $copy = $$str_ref; # copy while parsing to allow for errors
### test for leading prefix operators
my $has_prefix;
- while ($copy =~ s{ ^ ($QR_OP_PREFIX) \s* $QR_COMMENTS }{}ox) {
- return if $ARGS->{'auto_quote'}; # auto_quoted thing was too complicated
+ my $mark = pos $$str_ref;
+ while (! $is_aq && $$str_ref =~ m{ \G ($QR_OP_PREFIX) }gcxo) {
push @{ $has_prefix }, $1;
+ $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo;
}
my @var;
my $is_namespace;
### allow hex
- if ($copy =~ s{ ^ 0x ( [a-fA-F0-9]+ ) \s* $QR_COMMENTS }{}ox) {
+ if ($$str_ref =~ m{ \G 0x ( [a-fA-F0-9]+ ) \s* $QR_COMMENTS }gcxo) {
my $number = eval { hex $1 } || 0;
push @var, \ $number;
$is_literal = 1;
### allow for numbers
- } elsif ($copy =~ s{ ^ ( $QR_NUM ) \s* $QR_COMMENTS }{}ox) {
+ } elsif ($$str_ref =~ m{ \G ( $QR_NUM ) \s* $QR_COMMENTS }gcxo) {
my $number = $1;
push @var, \ $number;
$is_literal = 1;
### allow for quoted array constructor
- } elsif ($copy =~ s{ ^ qw (\W) \s* }{}x) {
+ } elsif (! $is_aq && $$str_ref =~ m{ \G qw (\W) \s* }gcxo) {
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));
+ $$str_ref =~ m{ \G (.*?) \Q$quote\E \s* $QR_COMMENTS }gcxs
+ || $self->throw('parse.missing.array_close', "Missing close \"$quote\"", undef, pos($$str_ref));
my $str = $1;
$str =~ s{ ^ \s+ | \s+ $ }{}x;
- my $arrayref = ['array', split /\s+/, $str];
- push @var, \ $arrayref;
+ push @var, [undef, '[]', split /\s+/, $str];
### looks like a normal variable start
- } elsif ($copy =~ s{ ^ (\w+) \s* $QR_COMMENTS }{}ox) {
+ } elsif ($$str_ref =~ m{ \G (\w+) \s* $QR_COMMENTS }gcxo) {
push @var, $1;
$is_namespace = 1 if $self->{'NAMESPACE'} && $self->{'NAMESPACE'}->{$1};
### allow for literal strings
- } elsif ($copy =~ s{ ^ ([\"\']) (|.*?[^\\]) \1 \s* $QR_COMMENTS }{}sox) {
+ } elsif ($$str_ref =~ m{ \G ([\"\']) (|.*?[^\\]) \1 \s* $QR_COMMENTS }gcxos) {
if ($1 eq "'") { # no interpolation on single quoted strings
my $str = $2;
$str =~ s{ \\\' }{\'}xg;
$str =~ s/\\n/\n/g;
$str =~ s/\\t/\t/g;
$str =~ s/\\r/\r/g;
- $str =~ s/\\([\"\$])/$1/g;
+ $str =~ s/\\"/"/g;
my @pieces = $ARGS->{'auto_quote'}
- ? split(m{ (\$\w+ | \$\{ [^\}]+ \}) }x, $str) # autoquoted items get a single $\w+ - no nesting
- : split(m{ (\$\w+ (?:\.\w+)* | \$\{ [^\}]+ \}) }x, $str);
+ ? split(m{ (?: ^ | (?<!\\)) (\$\w+ | \$\{ .*? (?<!\\) \}) }x, $str) # autoquoted items get a single $\w+ - no nesting
+ : split(m{ (?: ^ | (?<!\\)) (\$\w+ (?:\.\w+)* | \$\{ .*? (?<!\\) \}) }x, $str);
my $n = 0;
foreach my $piece (@pieces) {
+ $piece =~ s/\\\$/\$/g;
next if ! ($n++ % 2);
next if $piece !~ m{ ^ \$ (\w+ (?:\.\w+)*) $ }x
- && $piece !~ m{ ^ \$\{ \s* ([^\}]+) \} $ }x;
+ && $piece !~ m{ ^ \$\{ \s* (.*?) (?<!\\) \} $ }x;
my $name = $1;
+ $name =~ s/\\\}/\}/g;
$piece = $self->parse_expr(\$name);
- }
+ }
@pieces = grep {defined && length} @pieces;
if (@pieces == 1 && ! ref $pieces[0]) {
push @var, \ $pieces[0];
push @var, \ '';
$is_literal = 1;
} else {
- push @var, \ ['~', @pieces];
+ push @var, [undef, '~', @pieces];
}
}
- if ($ARGS->{'auto_quote'}){
- $$str_ref = $copy;
+ if ($is_aq) {
+ #$$str_ref = $copy; # TODO ?
return ${ $var[0] } if $is_literal;
push @var, 0;
return \@var;
}
- ### allow for leading $foo or ${foo.bar} type constructs
- } elsif ($copy =~ s{ ^ \$ (\w+) \b \s* $QR_COMMENTS }{}ox
- || $copy =~ s{ ^ \$\{ \s* ([^\}]+) \} \s* $QR_COMMENTS }{}ox) {
- my $name = $1;
- push @var, $self->parse_expr(\$name);
+ ### allow for leading $foo type constructs
+ } elsif ($$str_ref =~ m{ \G \$ (\w+) \b \s* $QR_COMMENTS }gcxo) {
+ if ($self->{'V1DOLLAR'}) {
+ push @var, $1;
+ $is_namespace = 1 if $self->{'NAMESPACE'} && $self->{'NAMESPACE'}->{$1};
+ } else {
+ push @var, [$1, 0];
+ }
+
+ ### allow for ${foo.bar} type constructs
+ } elsif ($$str_ref =~ m{ \G \$\{ \s* }gcx) {
+ push @var, $self->parse_expr($str_ref);
+ $$str_ref =~ m{ \G \s* \} \s* $QR_COMMENTS }gcxo
+ || $self->throw('parse', 'Missing close "}" from "${"', undef, pos($$str_ref));
### looks like an array constructor
- } elsif ($copy =~ s{ ^ \[ \s* $QR_COMMENTS }{}ox) {
+ } elsif (! $is_aq && $$str_ref =~ m{ \G \[ \s* $QR_COMMENTS }gcxo) {
local $self->{'_operator_precedence'} = 0; # reset presedence
- my $arrayref = ['array'];
- while (defined(my $var = $self->parse_expr(\$copy))) {
+ my $arrayref = [undef, '[]'];
+ while (defined(my $var = $self->parse_expr($str_ref))) {
push @$arrayref, $var;
- $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
+ $$str_ref =~ m{ \G , \s* $QR_COMMENTS }gcxo;
}
- $copy =~ s{ ^ \] \s* $QR_COMMENTS }{}ox
- || $self->throw('parse.missing.square_bracket', "Missing close \]", undef, length($$str_ref) - length($copy));
- push @var, \ $arrayref;
+ $$str_ref =~ m{ \G \] \s* $QR_COMMENTS }gcxo
+ || $self->throw('parse.missing.square_bracket', "Missing close \]", undef, pos($$str_ref));
+ push @var, $arrayref;
### looks like a hash constructor
- } elsif ($copy =~ s{ ^ \{ \s* $QR_COMMENTS }{}ox) {
+ } elsif (! $is_aq && $$str_ref =~ m{ \G \{ \s* $QR_COMMENTS }gcxo) {
local $self->{'_operator_precedence'} = 0; # reset precedence
- my $hashref = ['hash'];
- while (defined(my $key = $self->parse_expr(\$copy, {auto_quote => qr{ ^ (\w+) $QR_AQ_NOTDOT }xo}))) {
- $copy =~ s{ ^ = >? \s* $QR_COMMENTS }{}ox;
- my $val = $self->parse_expr(\$copy);
+ my $hashref = [undef, '{}'];
+ while (defined(my $key = $self->parse_expr($str_ref, {auto_quote => "(\\w+) $QR_AQ_NOTDOT"}))) {
+ $$str_ref =~ m{ \G = >? \s* $QR_COMMENTS }gcxo;
+ my $val = $self->parse_expr($str_ref);
push @$hashref, $key, $val;
- $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
+ $$str_ref =~ m{ \G , \s* $QR_COMMENTS }gcxo;
}
- $copy =~ s{ ^ \} \s* $QR_COMMENTS }{}ox
- || $self->throw('parse.missing.curly_bracket', "Missing close \} ($copy)", undef, length($$str_ref) - length($copy));
- push @var, \ $hashref;
+ $$str_ref =~ m{ \G \} \s* $QR_COMMENTS }gcxo
+ || $self->throw('parse.missing.curly_bracket', "Missing close \}", undef, pos($$str_ref));
+ push @var, $hashref;
### looks like a paren grouper
- } elsif ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) {
+ } elsif (! $is_aq && $$str_ref =~ m{ \G \( \s* $QR_COMMENTS }gcxo) {
local $self->{'_operator_precedence'} = 0; # reset precedence
- my $var = $self->parse_expr(\$copy, {allow_parened_ops => 1});
- $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox
- || $self->throw('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy));
+ my $var = $self->parse_expr($str_ref, {allow_parened_ops => 1});
+
+ $$str_ref =~ m{ \G \) \s* $QR_COMMENTS }gcxo
+ || $self->throw('parse.missing.paren', "Missing close \)", undef, pos($$str_ref));
@var = @$var;
- pop(@var); # pull off the trailing args of the paren group
+ pop @var; # pull off the trailing args of the paren group
+ # TODO - we could forward lookahed for a period or pipe
### nothing to find - return failure
} else {
return;
}
- return if $ARGS->{'auto_quote'}; # auto_quoted thing was too complicated
+ return if $is_aq; # auto_quoted thing was too complicated
### looks for args for the initial
- if ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) {
+ if ($$str_ref =~ m{ \G \( \s* $QR_COMMENTS }gcxo) {
local $self->{'_operator_precedence'} = 0; # reset precedence
- my $args = $self->parse_args(\$copy);
- $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox
- || $self->throw('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy));
+ my $args = $self->parse_args($str_ref, {is_parened => 1});
+ $$str_ref =~ m{ \G \) \s* $QR_COMMENTS }gcxo
+ || $self->throw('parse.missing.paren', "Missing close \)", undef, pos($$str_ref));
push @var, $args;
} else {
push @var, 0;
}
### allow for nested items
- while ($copy =~ s{ ^ ( \.(?!\.) | \|(?!\|) ) \s* $QR_COMMENTS }{}ox) {
+ while ($$str_ref =~ m{ \G ( \.(?!\.) | \|(?!\|) ) \s* $QR_COMMENTS }gcxo) {
push(@var, $1) if ! $ARGS->{'no_dots'};
- ### allow for interpolated variables in the middle - one.$foo.two or one.${foo.bar}.two
- if ($copy =~ s{ ^ \$(\w+) \s* $QR_COMMENTS }{}ox
- || $copy =~ s{ ^ \$\{ \s* ([^\}]+)\} \s* $QR_COMMENTS }{}ox) {
- my $name = $1;
- my $var = $self->parse_expr(\$name);
- push @var, $var;
+ ### allow for interpolated variables in the middle - one.$foo.two
+ if ($$str_ref =~ m{ \G \$ (\w+) \b \s* $QR_COMMENTS }gcxo) {
+ push @var, $self->{'V1DOLLAR'} ? $1 : [$1, 0];
+
+ ### or one.${foo.bar}.two
+ } elsif ($$str_ref =~ m{ \G \$\{ \s* }gcx) {
+ push @var, $self->parse_expr($str_ref);
+ $$str_ref =~ m{ \G \s* \} \s* $QR_COMMENTS }gcxo
+ || $self->throw('parse', 'Missing close "}" from "${"', undef, pos($$str_ref));
### allow for names
- } elsif ($copy =~ s{ ^ (-? \w+) \s* $QR_COMMENTS }{}ox) {
+ } elsif ($$str_ref =~ m{ \G (-? \w+) \s* $QR_COMMENTS }gcxo) {
push @var, $1;
} else {
- $self->throw('parse', "Not sure how to continue parsing on \"$copy\" ($$str_ref)");
+ $self->throw('parse', "Not sure how to continue parsing", undef, pos($$str_ref));
}
### looks for args for the nested item
- if ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) {
+ if ($$str_ref =~ m{ \G \( \s* $QR_COMMENTS }gcxo) {
local $self->{'_operator_precedence'} = 0; # reset precedence
- my $args = $self->parse_args(\$copy);
- $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox
- || $self->throw('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy));
+ my $args = $self->parse_args($str_ref, {is_parened => 1});
+ $$str_ref =~ m{ \G \) \s* $QR_COMMENTS }gcxo
+ || $self->throw('parse.missing.paren', "Missing close \)", undef, pos($$str_ref));
push @var, $args;
} else {
push @var, 0;
}
### flatten literals and constants as much as possible
- my $var = ($is_literal && $#var == 1) ? ${ $var[0] }
- : $is_namespace ? $self->play_expr(\@var, {is_namespace_during_compile => 1})
- : \@var;
+ my $var;
+ if ($is_literal) {
+ $var = ${ $var[0] };
+ if ($#var != 1) {
+ $var[0] = [undef, '~', $var];
+ $var = \@var;
+ }
+ } elsif ($is_namespace) {
+ $var = $self->play_expr(\@var, {is_namespace_during_compile => 1});
+ } else {
+ $var = \@var;
+ }
### allow for all "operators"
if (! $self->{'_operator_precedence'}) {
my $tree;
my $found;
- 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;
+ while (1) {
+ my $mark = pos $$str_ref;
+ if ($self->{'_end_tag'} && $$str_ref =~ m{ \G [+=~-]? $self->{'_end_tag'} }gcx) {
+ pos($$str_ref) = $mark;
+ last;
+ } elsif ($$str_ref !~ m{ \G ($QR_OP) }gcxo) {
+ pos($$str_ref) = $mark;
+ last;
+ }
+ if ($OP_ASSIGN->{$1} && ! $ARGS->{'allow_parened_ops'}) { # only allow assignment in parens
+ pos($$str_ref) = $mark;
last;
}
-
local $self->{'_operator_precedence'} = 1;
my $op = $1;
+ $$str_ref =~ m{ \G \s* $QR_COMMENTS }gcxo;
### allow for postfix - doesn't check precedence - someday we might change - but not today (only affects post ++ and --)
if ($OP_POSTFIX->{$op}) {
- $var = [\ [$op, $var, 1], 0]; # cheat - give a "second value" to postfix ops
+ $var = [[undef, $op, $var, 1], 0]; # cheat - give a "second value" to postfix ops
next;
### allow for prefix operator precedence
} elsif ($has_prefix && $OP->{$op}->[1] < $OP_PREFIX->{$has_prefix->[-1]}->[1]) {
if ($tree) {
if ($#$tree == 1) { # only one operator - keep simple things fast
- $var = [\ [$tree->[0], $var, $tree->[1]], 0];
+ $var = [[undef, $tree->[0], $var, $tree->[1]], 0];
} else {
unshift @$tree, $var;
$var = $self->apply_precedence($tree, $found);
undef $tree;
undef $found;
}
- $var = [ \ [ $has_prefix->[-1], $var ], 0 ];
+ $var = [[undef, $has_prefix->[-1], $var ], 0];
if (! @$has_prefix) { undef $has_prefix } else { pop @$has_prefix }
}
### add the operator to the tree
- my $var2 = $self->parse_expr(\$copy);
+ my $var2 = $self->parse_expr($str_ref, {from_here => 1});
+ $self->throw('parse', 'Missing variable after "'.$op.'"', undef, pos($$str_ref)) if ! defined $var2;
push (@{ $tree ||= [] }, $op, $var2);
$found->{$OP->{$op}->[1]}->{$op} = 1; # found->{precedence}->{op}
}
### if we found operators - tree the nodes by operator precedence
if ($tree) {
if (@$tree == 2) { # only one operator - keep simple things fast
- $var = [\ [$tree->[0], $var, $tree->[1]], 0];
+ $var = [[undef, $tree->[0], $var, $tree->[1]], 0];
} else {
unshift @$tree, $var;
$var = $self->apply_precedence($tree, $found);
### allow for prefix on non-chained variables
if ($has_prefix) {
- $var = [ \ [ $_, $var ], 0 ] for reverse @$has_prefix;
+ $var = [[undef, $_, $var], 0] for reverse @$has_prefix;
}
- $$str_ref = $copy; # commit the changes
return $var;
}
if (@$node == 1) {
$node = $node->[0]; # single item - its not a tree
} elsif (@$node == 3) {
- $node = [ \ [ $node->[1], $node->[0], $node->[2] ], 0 ]; # single operator - put it straight on
+ $node = [[undef, $node->[1], $node->[0], $node->[2]], 0]; # single operator - put it straight on
} else {
$node = $self->apply_precedence($node, $found); # more complicated - recurse
}
if (@exprs == 3) {
$self->throw('parse', "Ternary operator mismatch") if $ops[0] ne $op;
$self->throw('parse', "Ternary operator mismatch") if ! $ops[1] || $ops[1] eq $op;
- return [ \ [ $op, @exprs ], 0 ];
+ return [[undef, $op, @exprs], 0];
}
for (my $i = $#ops; $i >= 0; $i --) {
next if $OP->{$ops[$i]}->[2]->[1] eq $ops[$i];
my ($op, $op2) = splice @ops, $i, 2, (); # remove the pair of operators
- my $node = [ \ [$op, @exprs[$i .. $i + 2] ], 0 ];
+ my $node = [[undef, $op, @exprs[$i .. $i + 2]], 0];
splice @exprs, $i, 3, $node;
}
}
} elsif ($type eq 'right' || $type eq 'assign') {
my $val = $exprs[-1];
- $val = [ \ [ $ops[$_ - 1], $exprs[$_], $val ], 0 ] for reverse (0 .. $#exprs - 1);
+ $val = [[undef, $ops[$_ - 1], $exprs[$_], $val], 0] for reverse (0 .. $#exprs - 1);
return $val;
} else {
my $val = $exprs[0];
- $val = [ \ [ $ops[$_ - 1], $val, $exprs[$_] ], 0 ] for (1 .. $#exprs);
+ $val = [[undef, $ops[$_ - 1], $val, $exprs[$_]], 0] for (1 .. $#exprs);
return $val;
}
my $self = shift;
my $str_ref = shift;
my $ARGS = shift || {};
- my $copy = $$str_ref;
my @args;
my @named;
- while (length $$str_ref) {
- my $copy = $$str_ref;
- if (defined(my $name = $self->parse_expr(\$copy, {auto_quote => qr{ ^ (\w+) $QR_AQ_NOTDOT }xo}))
- && $copy =~ s{ ^ = >? \s* $QR_COMMENTS }{}ox) {
- $self->throw('parse', 'Named arguments not allowed') if $ARGS->{'positional_only'};
- my $val = $self->parse_expr(\$copy);
- $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
+ while (1) {
+ my $mark = pos $$str_ref;
+ if (! $ARGS->{'is_parened'}
+ && $$str_ref =~ m{ \G $QR_DIRECTIVE (?: \s+ | (?: \s* $QR_COMMENTS (?: ;|[+=~-]?$self->{'_end_tag'}))) }gcxo
+ && ((pos($$str_ref) = $mark) || 1) # always revert
+ && $DIRECTIVES->{$self->{'ANYCASE'} ? uc($1) : $1} # looks like a directive - we are done
+ ) {
+ last;
+ }
+
+ if (defined(my $name = $self->parse_expr($str_ref, {auto_quote => "(\\w+) $QR_AQ_NOTDOT"}))
+ && ($$str_ref =~ m{ \G = >? \s* $QR_COMMENTS }gcxo # see if we also match assignment
+ || ((pos $$str_ref = $mark) && 0)) # if not - we need to rollback
+ ) {
+ $self->throw('parse', 'Named arguments not allowed', undef, $mark) if $ARGS->{'positional_only'};
+ my $val = $self->parse_expr($str_ref);
+ $$str_ref =~ m{ \G , \s* $QR_COMMENTS }gcxo;
push @named, $name, $val;
- $$str_ref = $copy;
} elsif (defined(my $arg = $self->parse_expr($str_ref))) {
push @args, $arg;
- $$str_ref =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
+ $$str_ref =~ m{ \G , \s* $QR_COMMENTS }gcxo;
} else {
last;
}
}
### allow for named arguments to be added also
- push @args, [\ ['hash', @named], 0] if scalar @named;
+ push @args, [[undef, '{}', @named], 0] if scalar @named;
return \@args;
}
return if $self->{'_in_perl'};
### split on variables while keeping the variables
- my @pieces = split m{ (?: ^ | (?<! \\)) (\$\w+ (?:\.\w+)* | \$\{ [^\}]+ \}) }x, $tree->[-1];
+ my @pieces = split m{ (?: ^ | (?<! \\)) (\$\w+ (?:\.\w+)* | \$\{ .*? (?<!\\) \}) }x, $tree->[-1];
if ($#pieces <= 0) {
$tree->[-1] =~ s{ \\ ([\"\$]) }{$1}xg;
return;
my $n = 0;
foreach my $piece (@pieces) {
$offset += length $piece; # we track the offset to make sure DEBUG has the right location
+ $piece =~ s{ \\ ([\"\$]) }{$1}xg;
if (! ($n++ % 2)) { # odds will always be text chunks
next if ! length $piece;
- $piece =~ s{ \\ ([\"\$]) }{$1}xg;
push @sub_tree, $piece;
} elsif ($piece =~ m{ ^ \$ (\w+ (?:\.\w+)*) $ }x
- || $piece =~ m{ ^ \$\{ \s* ([^\}]+) \} $ }x) {
+ || $piece =~ m{ ^ \$\{ \s* (.*?) (?<!\\) \} $ }x) {
my $name = $1;
+ $name =~ s/\\\}/\}/g;
push @sub_tree, ['GET', $offset - length($piece), $offset, $self->parse_expr(\$name)];
} else {
$self->throw('parse', "Parse error during interpolate node");
###----------------------------------------------------------------###
+sub execute_tree {
+ my ($self, $tree, $out_ref) = @_;
+
+ # node contains (0: DIRECTIVE,
+ # 1: start_index,
+ # 2: end_index,
+ # 3: parsed tag details,
+ # 4: sub tree for block types
+ # 5: continuation sub trees for sub continuation block types (elsif, else, etc)
+ # 6: flag to capture next directive
+ for my $node (@$tree) {
+ ### text nodes are just the bare text
+ if (! ref $node) {
+ warn "NODE: TEXT\n" if trace;
+ $$out_ref .= $node if defined $node;
+ next;
+ }
+
+ warn "NODE: $node->[0] (char $node->[1])\n" if trace;
+ $$out_ref .= $self->debug_node($node) if $self->{'_debug_dirs'} && ! $self->{'_debug_off'};
+
+ my $val = $DIRECTIVES->{$node->[0]}->[1]->($self, $node->[3], $node, $out_ref);
+ $$out_ref .= $val if defined $val;
+ }
+}
+
sub play_expr {
### allow for the parse tree to store literals
return $_[1] if ! ref $_[1];
my $args = $var->[$i++];
warn "play_expr: 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);
+ if (! defined $name->[0]) { # operator
+ return $self->play_operator($name) if wantarray && $name->[1] eq '..';
+ $ref = $self->play_operator($name);
} else { # a named variable access (ie via $name.foo)
$name = $self->play_expr($name);
if (defined $name) {
return if $name =~ $QR_PRIVATE; # don't allow vars that begin with _
+ return \$self->{'_vars'}->{$name} if $i >= $#$var && $ARGS->{'return_ref'} && ! ref $self->{'_vars'}->{$name};
$ref = $self->{'_vars'}->{$name};
}
}
$ref = $self->{'NAMESPACE'}->{$name};
} else {
return if $name =~ $QR_PRIVATE; # don't allow vars that begin with _
+ return \$self->{'_vars'}->{$name} if $i >= $#$var && $ARGS->{'return_ref'} && ! ref $self->{'_vars'}->{$name};
$ref = $self->{'_vars'}->{$name};
$ref = $VOBJS->{$name} if ! defined $ref;
}
### check at each point if the rurned thing was a code
if (UNIVERSAL::isa($ref, 'CODE')) {
+ return $ref if $i >= $#$var && $ARGS->{'return_ref'};
my @results = $ref->($args ? map { $self->play_expr($_) } @$args : ());
if (defined $results[0]) {
$ref = ($#results > 0) ? \@results : $results[0];
### method calls on objects
if ($was_dot_call && UNIVERSAL::can($ref, 'can')) {
+ return $ref if $i >= $#$var && $ARGS->{'return_ref'};
my @args = $args ? map { $self->play_expr($_) } @$args : ();
my @results = eval { $ref->$name(@args) };
if ($@) {
### hash member access
if (UNIVERSAL::isa($ref, 'HASH')) {
if ($was_dot_call && exists($ref->{$name}) ) {
+ return \ $ref->{$name} if $i >= $#$var && $ARGS->{'return_ref'} && ! ref $ref->{$name};
$ref = $ref->{$name};
} elsif ($HASH_OPS->{$name}) {
$ref = $HASH_OPS->{$name}->($ref, $args ? map { $self->play_expr($_) } @$args : ());
} elsif ($ARGS->{'is_namespace_during_compile'}) {
return $var; # abort - can't fold namespace variable
} else {
+ return \ $ref->{$name} if $i >= $#$var && $ARGS->{'return_ref'};
$ref = undef;
}
### array access
} elsif (UNIVERSAL::isa($ref, 'ARRAY')) {
if ($name =~ m{ ^ -? $QR_NUM $ }ox) {
+ return \ $ref->[$name] if $i >= $#$var && $ARGS->{'return_ref'} && ! ref $ref->[$name];
$ref = $ref->[$name];
} elsif ($LIST_OPS->{$name}) {
$ref = $LIST_OPS->{$name}->($ref, $args ? map { $self->play_expr($_) } @$args : ());
my $ref = $var->[$i++];
my $args = $var->[$i++];
if (ref $ref) {
- if (ref($ref) eq 'ARRAY') { # named access (ie via $name.foo)
- $ref = $self->play_expr($ref);
- if (defined $ref && $ref !~ $QR_PRIVATE) { # don't allow vars that begin with _
- if ($#$var <= $i) {
- return $self->{'_vars'}->{$ref} = $val;
- } else {
- $ref = $self->{'_vars'}->{$ref} ||= {};
- }
+ ### non-named types can't be set
+ return if ref($ref) ne 'ARRAY' || ! defined $ref->[0];
+
+ # named access (ie via $name.foo)
+ $ref = $self->play_expr($ref);
+ if (defined $ref && $ref !~ $QR_PRIVATE) { # don't allow vars that begin with _
+ if ($#$var <= $i) {
+ return $self->{'_vars'}->{$ref} = $val;
} else {
- return;
+ $ref = $self->{'_vars'}->{$ref} ||= {};
}
- } else { # all other types can't be set
+ } else {
return;
}
} elsif (defined $ref) {
###----------------------------------------------------------------###
sub play_operator {
- my $self = shift;
- my $tree = shift;
+ my ($self, $tree) = @_;
+ ### $tree looks like [undef, '+', 4, 5]
- if ($OP_DISPATCH->{$tree->[0]}) {
+ if ($OP_DISPATCH->{$tree->[1]}) {
local $^W;
- if ($OP_ASSIGN->{$tree->[0]}) {
- my $val = $OP_DISPATCH->{$tree->[0]}->( $self->play_expr($tree->[1]), $self->play_expr($tree->[2]) );
- $self->set_variable($tree->[1], $val);
+ if ($OP_ASSIGN->{$tree->[1]}) {
+ my $val = $OP_DISPATCH->{$tree->[1]}->($self->play_expr($tree->[2]), $self->play_expr($tree->[3]));
+ $self->set_variable($tree->[2], $val);
return $val;
} else {
- return $OP_DISPATCH->{$tree->[0]}->( map { $self->play_expr($tree->[$_]) } 1 .. $#$tree );
+ return $OP_DISPATCH->{$tree->[1]}->(@$tree == 3 ? $self->play_expr($tree->[2]) : ($self->play_expr($tree->[2]), $self->play_expr($tree->[3])));
}
}
- my $op = $tree->[0];
+ my $op = $tree->[1];
### do custom and short-circuitable operators
if ($op eq '=') {
- my $val = $self->play_expr($tree->[2]);
- $self->set_variable($tree->[1], $val);
+ my $val = $self->play_expr($tree->[3]);
+ $self->set_variable($tree->[2], $val);
return $val;
} elsif ($op eq '||' || $op eq 'or' || $op eq 'OR') {
- return $self->play_expr($tree->[1]) || $self->play_expr($tree->[2]) || '';
+ return $self->play_expr($tree->[2]) || $self->play_expr($tree->[3]) || '';
} elsif ($op eq '&&' || $op eq 'and' || $op eq 'AND') {
- my $var = $self->play_expr($tree->[1]) && $self->play_expr($tree->[2]);
+ my $var = $self->play_expr($tree->[2]) && $self->play_expr($tree->[3]);
return $var ? $var : 0;
} elsif ($op eq '?') {
local $^W;
- return $self->play_expr($tree->[1]) ? $self->play_expr($tree->[2]) : $self->play_expr($tree->[3]);
+ return $self->play_expr($tree->[2]) ? $self->play_expr($tree->[3]) : $self->play_expr($tree->[4]);
+
+ } elsif ($op eq '~' || $op eq '_') {
+ local $^W;
+ my $s = '';
+ $s .= $self->play_expr($tree->[$_]) for 2 .. $#$tree;
+ return $s;
+
+ } elsif ($op eq '[]') {
+ return [map {$self->play_expr($tree->[$_])} 2 .. $#$tree];
+
+ } elsif ($op eq '{}') {
+ local $^W;
+ my @e;
+ push @e, $self->play_expr($tree->[$_]) for 2 .. $#$tree;
+ return {@e};
} elsif ($op eq '++') {
local $^W;
- my $val = 0 + $self->play_expr($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
+ my $val = 0 + $self->play_expr($tree->[2]);
+ $self->set_variable($tree->[2], $val + 1);
+ return $tree->[3] ? $val : $val + 1; # ->[3] is set to 1 during parsing of postfix ops
} elsif ($op eq '--') {
local $^W;
- my $val = 0 + $self->play_expr($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
+ my $val = 0 + $self->play_expr($tree->[2]);
+ $self->set_variable($tree->[2], $val - 1);
+ return $tree->[3] ? $val : $val - 1; # ->[3] is set to 1 during parsing of postfix ops
+
+ } elsif ($op eq '\\') {
+ my $var = $tree->[2];
+
+ my $ref = $self->play_expr($var, {return_ref => 1});
+ return $ref if ! ref $ref;
+ return sub { sub { $$ref } } if ref $ref eq 'SCALAR' || ref $ref eq 'REF';
+
+ my $self_copy = $self;
+ eval {require Scalar::Util; Scalar::Util::weaken($self_copy)};
+
+ my $last = ['temp deref key', $var->[-1] ? [@{ $var->[-1] }] : 0];
+ return sub { sub { # return a double sub so that the current play_expr will return a coderef
+ local $self_copy->{'_vars'}->{'temp deref key'} = $ref;
+ $last->[-1] = (ref $last->[-1] ? [@{ $last->[-1] }, @_] : [@_]) if @_;
+ return $self->play_expr($last);
+ } };
}
$self->throw('operator', "Un-implemented operation $op");
###----------------------------------------------------------------###
sub parse_BLOCK {
- my ($self, $tag_ref, $node) = @_;
+ my ($self, $str_ref, $node) = @_;
my $block_name = '';
- if ($$tag_ref =~ s{ ^ (\w+ (?: :\w+)*) \s* (?! [\.\|]) }{}x
- || $$tag_ref =~ s{ ^ '(|.*?[^\\])' \s* (?! [\.\|]) }{}x
- || $$tag_ref =~ s{ ^ "(|.*?[^\\])" \s* (?! [\.\|]) }{}x
+ if ($$str_ref =~ m{ \G (\w+ (?: :\w+)*) \s* (?! [\.\|]) }gcx
+ || $$str_ref =~ m{ \G '(|.*?[^\\])' \s* (?! [\.\|]) }gcx
+ || $$str_ref =~ m{ \G "(|.*?[^\\])" \s* (?! [\.\|]) }gcx
) {
$block_name = $1;
### allow for nested blocks to have nested names
sub play_CALL { $DIRECTIVES->{'GET'}->[1]->(@_); return }
sub parse_CASE {
- my ($self, $tag_ref) = @_;
- return if $$tag_ref =~ s{ ^ DEFAULT \s* }{}x;
- return $self->parse_expr($tag_ref);
+ my ($self, $str_ref) = @_;
+ return if $$str_ref =~ m{ \G DEFAULT \s* }gcx;
+ return $self->parse_expr($str_ref);
}
sub parse_CATCH {
- my ($self, $tag_ref) = @_;
- return $self->parse_expr($tag_ref, {auto_quote => qr{ ^ (\w+ (?: \.\w+)*) $QR_AQ_SPACE }xo});
+ my ($self, $str_ref) = @_;
+ return $self->parse_expr($str_ref, {auto_quote => "(\\w+ (?: \\.\\w+)*) $QR_AQ_SPACE"});
}
sub play_control {
}
sub parse_DEBUG {
- my ($self, $tag_ref) = @_;
- $$tag_ref =~ s{ ^ (on | off | format) \s* }{}xi || $self->throw('parse', "Unknown DEBUG option");
+ my ($self, $str_ref) = @_;
+ $$str_ref =~ m{ \G ([Oo][Nn] | [Oo][Ff][Ff] | [Ff][Oo][Rr][Mm][Aa][Tt]) \s* }gcx
+ || $self->throw('parse', "Unknown DEBUG option", undef, pos($$str_ref));
my $ret = [lc($1)];
if ($ret->[0] eq 'format') {
- $$tag_ref =~ s{ ^ ([\"\']) (|.*?[^\\]) \1 \s* }{}xs || $self->throw('parse', "Missing format string");
+ $$str_ref =~ m{ \G ([\"\']) (|.*?[^\\]) \1 \s* }gcxs
+ || $self->throw('parse', "Missing format string", undef, pos($$str_ref));
$ret->[1] = $2;
}
return $ret;
}
sub parse_DUMP {
- my ($self, $tag_ref) = @_;
- my $ref = $self->parse_expr($tag_ref);
+ my ($self, $str_ref) = @_;
+ my $ref = $self->parse_expr($str_ref);
return $ref;
}
}
sub parse_FILTER {
- my ($self, $tag_ref) = @_;
+ my ($self, $str_ref) = @_;
my $name = '';
- if ($$tag_ref =~ s{ ^ ([^\W\d]\w*) \s* = \s* }{}x) {
+ if ($$str_ref =~ m{ \G ([^\W\d]\w*) \s* = \s* }gcx) {
$name = $1;
}
- my $filter = $self->parse_expr($tag_ref);
+ my $filter = $self->parse_expr($str_ref);
$filter = '' if ! defined $filter;
return [$name, $filter];
eval { $self->execute_tree($sub_tree, \$out) };
die $@ if $@ && ref($@) !~ /Template::Exception$/;
- my $var = [\$out, 0, '|', @$filter]; # make a temporary var out of it
+ my $var = [[undef, '~', $out], 0, '|', @$filter]; # make a temporary var out of it
return $DIRECTIVES->{'GET'}->[1]->($self, $var, $node, $out_ref);
}
sub parse_FOREACH {
- my ($self, $tag_ref) = @_;
- my $items = $self->parse_expr($tag_ref);
+ my ($self, $str_ref) = @_;
+ my $items = $self->parse_expr($str_ref);
my $var;
- if ($$tag_ref =~ s{ ^ (= | [Ii][Nn]\b) \s* }{}x) {
+ if ($$str_ref =~ m{ \G (= | [Ii][Nn]\b) \s* }gcx) {
$var = [@$items];
- $items = $self->parse_expr($tag_ref);
+ $items = $self->parse_expr($str_ref);
}
return [$var, $items];
}
}
sub parse_GET {
- my ($self, $tag_ref) = @_;
- my $ref = $self->parse_expr($tag_ref);
- $self->throw('parse', "Missing variable name") if ! defined $ref;
+ my ($self, $str_ref) = @_;
+ my $ref = $self->parse_expr($str_ref);
+ $self->throw('parse', "Missing variable name", undef, pos($$str_ref)) if ! defined $ref;
return $ref;
}
}
sub parse_IF {
- my ($self, $tag_ref) = @_;
- return $self->parse_expr($tag_ref);
+ my ($self, $str_ref) = @_;
+ return $self->parse_expr($str_ref);
}
sub play_IF {
sub parse_INCLUDE { $DIRECTIVES->{'PROCESS'}->[0]->(@_) }
sub play_INCLUDE {
- my ($self, $tag_ref, $node, $out_ref) = @_;
+ my ($self, $str_ref, $node, $out_ref) = @_;
### localize the swap
my $swap = $self->{'_vars'};
my $blocks = $self->{'BLOCKS'};
local $self->{'BLOCKS'} = {%$blocks};
- my $str = $DIRECTIVES->{'PROCESS'}->[1]->($self, $tag_ref, $node, $out_ref);
+ my $str = $DIRECTIVES->{'PROCESS'}->[1]->($self, $str_ref, $node, $out_ref);
return $str;
}
}
sub parse_MACRO {
- my ($self, $tag_ref, $node) = @_;
- my $copy = $$tag_ref;
+ my ($self, $str_ref, $node) = @_;
- my $name = $self->parse_expr(\$copy, {auto_quote => qr{ ^ (\w+) $QR_AQ_NOTDOT }xo});
- $self->throw('parse', "Missing macro name") if ! defined $name;
+ my $name = $self->parse_expr($str_ref, {auto_quote => "(\\w+) $QR_AQ_NOTDOT"});
+ $self->throw('parse', "Missing macro name", undef, pos($$str_ref)) if ! defined $name;
if (! ref $name) {
$name = [ $name, 0 ];
}
my $args;
- if ($copy =~ s{ ^ \( \s* }{}x) {
- $args = $self->parse_args(\$copy, {positional_only => 1});
- $copy =~ s { ^ \) \s* }{}x || $self->throw('parse.missing', "Missing close ')'");
+ if ($$str_ref =~ m{ \G \( \s* }gcx) {
+ $args = $self->parse_args($str_ref, {positional_only => 1});
+ $$str_ref =~ m{ \G \) \s* }gcx || $self->throw('parse.missing', "Missing close ')'", undef, pos($$str_ref));
}
$node->[6] = 1; # set a flag to keep parsing
- $$tag_ref = $copy;
return [$name, $args];
}
my $copy = $self_copy->{'_vars'};
local $self_copy->{'_vars'}= {%$copy};
+ ### prevent recursion
+ local $self_copy->{'_macro_recurse'} = $self_copy->{'_macro_recurse'} || 0;
+ $self_copy->throw('macro_recurse', "MAX_MACRO_RECURSE $MAX_MACRO_RECURSE reached")
+ if ++$self_copy->{'_macro_recurse'} > ($self_copy->{'MAX_MACRO_RECURSE'} || $MAX_MACRO_RECURSE);
+
+
### set arguments
my $named = pop(@_) if $_[-1] && UNIVERSAL::isa($_[-1],'HASH') && $#_ > $#$args;
my @positional = @_;
return;
}
-sub play_METADEF {
+sub play_META {
my ($self, $hash) = @_;
my $ref;
if ($self->{'_top_level'}) {
}
sub parse_PROCESS {
- my ($self, $tag_ref) = @_;
+ my ($self, $str_ref) = @_;
my $info = [[], []];
- while (defined(my $filename = $self->parse_expr($tag_ref, {
- auto_quote => qr{ ^ ($QR_FILENAME | \w+ (?: :\w+)* ) $QR_AQ_SPACE }xo,
+ while (defined(my $filename = $self->parse_expr($str_ref, {
+ auto_quote => "($QR_FILENAME | \\w+ (?: :\\w+)* ) $QR_AQ_SPACE",
}))) {
push @{$info->[0]}, $filename;
- last if $$tag_ref !~ s{ ^ \+ \s* }{}x;
+ last if $$str_ref !~ m{ \G \+ \s* $QR_COMMENTS }gcxo;
}
- ### allow for post process variables
- while (length $$tag_ref) {
- last if $$tag_ref =~ / ^ (\w+) (?: ;|$|\s)/x && $DIRECTIVES->{$1}; ### looks like a directive - we are done
+ ### we can almost use parse_args - except we allow for nested key names (foo.bar) here
+ while (1) {
+ my $mark = pos $$str_ref;
+ if ($$str_ref =~ m{ \G $QR_DIRECTIVE (?: \s+ | (?: \s* $QR_COMMENTS (?: ;|[+=~-]?$self->{'_end_tag'}))) }gcxo) {
+ pos($$str_ref) = $mark;
+ last if $DIRECTIVES->{$self->{'ANYCASE'} ? uc $1 : $1}; # looks like a directive - we are done
+ }
+ if ($$str_ref =~ m{ \G [+=~-]? $self->{'_end_tag'} }gcx) {
+ pos($$str_ref) = $mark;
+ last;
+ }
+
+ my $var = $self->parse_expr($str_ref);
- my $var = $self->parse_expr($tag_ref);
last if ! defined $var;
- if ($$tag_ref !~ s{ ^ = >? \s* }{}x) {
- $self->throw('parse.missing.equals', 'Missing equals while parsing args');
+ if ($$str_ref !~ m{ \G = >? \s* }gcx) {
+ $self->throw('parse.missing.equals', 'Missing equals while parsing args', undef, pos($$str_ref));
}
- my $val = $self->parse_expr($tag_ref);
+ my $val = $self->parse_expr($str_ref);
push @{$info->[1]}, [$var, $val];
- $$tag_ref =~ s{ ^ , \s* $QR_COMMENTS }{}ox if $val;
+ $$str_ref =~ m{ \G , \s* $QR_COMMENTS }gcxo if $val;
}
return $info;
### set passed args
foreach (@$args) {
- my ($key, $val) = @$_;
- $val = $self->play_expr($val);
+ my $key = $_->[0];
+ my $val = $self->play_expr($_->[1]);
if (ref($key) && @$key == 2 && $key->[0] eq 'import' && UNIVERSAL::isa($val, 'HASH')) { # import ?! - whatever
foreach my $key (keys %$val) {
$self->set_variable([$key,0], $val->{$key});
}
sub parse_SET {
- my ($self, $tag_ref, $node, $initial_op, $initial_var) = @_;
+ my ($self, $str_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
+ if ($$str_ref =~ m{ \G $QR_DIRECTIVE }gcx # find a word
+ && ((pos($$str_ref) -= length($1)) || 1) # always revert
+ && $DIRECTIVES->{$self->{'ANYCASE'} ? uc $1 : $1}) { # make sure its 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_expr($tag_ref)]];
+ return [[$initial_op, $initial_var, $self->parse_expr($str_ref)]];
}
}
- while (length $$tag_ref) {
- my $set = $self->parse_expr($tag_ref);
+ while (1) {
+ my $set = $self->parse_expr($str_ref);
last if ! defined $set;
- if ($$tag_ref =~ s{ ^ ($QR_OP_ASSIGN) >? \s* }{}x) {
+ if ($$str_ref =~ m{ \G ($QR_OP_ASSIGN) >? \s* }gcx) {
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
+ if ($$str_ref =~ m{ \G $QR_DIRECTIVE }gcx # find a word
+ && ((pos($$str_ref) -= length($1)) || 1) # always revert
+ && $DIRECTIVES->{$self->{'ANYCASE'} ? uc $1 : $1}) { # make sure its 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_expr($tag_ref)];
+ push @SET, [$op, $set, $self->parse_expr($str_ref)];
}
} else {
push @SET, ['=', $set, undef];
}
sub parse_THROW {
- my ($self, $tag_ref, $node) = @_;
- my $name = $self->parse_expr($tag_ref, {auto_quote => qr{ ^ (\w+ (?: \.\w+)*) $QR_AQ_SPACE }xo});
- $self->throw('parse.missing', "Missing name in THROW", $node) if ! $name;
- my $args = $self->parse_args($tag_ref);
+ my ($self, $str_ref, $node) = @_;
+ my $name = $self->parse_expr($str_ref, {auto_quote => "(\\w+ (?: \\.\\w+)*) $QR_AQ_SPACE"});
+ $self->throw('parse.missing', "Missing name in THROW", $node, pos($$str_ref)) if ! $name;
+ my $args = $self->parse_args($str_ref);
return [$name, $args];
}
sub parse_UNLESS {
my $ref = $DIRECTIVES->{'IF'}->[0]->(@_);
- return [ \ [ '!', $ref ], 0 ];
+ return [[undef, '!', $ref], 0];
}
sub play_UNLESS { return $DIRECTIVES->{'IF'}->[1]->(@_) }
sub parse_USE {
- my ($self, $tag_ref) = @_;
+ my ($self, $str_ref) = @_;
my $var;
- my $copy = $$tag_ref;
- if (defined(my $_var = $self->parse_expr(\$copy, {auto_quote => qr{ ^ (\w+) $QR_AQ_NOTDOT }xo}))
- && $copy =~ s{ ^ = >? \s* $QR_COMMENTS }{}ox) {
+ my $mark = pos $$str_ref;
+ if (defined(my $_var = $self->parse_expr($str_ref, {auto_quote => "(\\w+) $QR_AQ_NOTDOT"}))
+ && ($$str_ref =~ m{ \G = >? \s* $QR_COMMENTS }gcxo # make sure there is assignment
+ || ((pos $$str_ref = $mark) && 0)) # otherwise we need to rollback
+ ) {
$var = $_var;
- $$tag_ref = $copy;
}
- $copy = $$tag_ref;
- my $module = $self->parse_expr(\$copy, {auto_quote => qr{ ^ (\w+ (?: (?:\.|::) \w+)*) $QR_AQ_NOTDOT }xo});
- $self->throw('parse', "Missing plugin name while parsing $$tag_ref") if ! defined $module;
+ my $module = $self->parse_expr($str_ref, {auto_quote => "(\\w+ (?: (?:\\.|::) \\w+)*) $QR_AQ_NOTDOT"});
+ $self->throw('parse', "Missing plugin name while parsing $$str_ref", undef, pos($$str_ref)) if ! defined $module;
$module =~ s/\./::/g;
my $args;
- my $open = $copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox;
- $args = $self->parse_args(\$copy);
+ my $open = $$str_ref =~ m{ \G \( \s* $QR_COMMENTS }gcxo;
+ $args = $self->parse_args($str_ref, {is_parened => $open});
if ($open) {
- $copy =~ s { ^ \) \s* $QR_COMMENTS }{}ox || $self->throw('parse.missing', "Missing close ')'");
+ $$str_ref =~ m{ \G \) \s* $QR_COMMENTS }gcxo || $self->throw('parse.missing', "Missing close ')'", undef, pos($$str_ref));
}
- $$tag_ref = $copy;
return [$var, $module, $args];
}
if (exists $self->{'PROCESS'}) {
### load the meta data for the top document
my $doc = $self->load_parsed_tree($content) || {};
- my $meta = ($doc->{'_tree'} && ref($doc->{'_tree'}->[0]) && $doc->{'_tree'}->[0]->[0] eq 'METADEF')
+ my $meta = ($doc->{'_tree'} && ref($doc->{'_tree'}->[0]) && $doc->{'_tree'}->[0]->[0] eq 'META')
? $doc->{'_tree'}->[0]->[3] : {};
$copy->{'template'} = $doc;
my ($self, $node) = @_;
my $doc = $self->{'_vars'}->{'component'};
my $i = $node->[1];
- my $j = $node->[2] || return ''; # METADEF can be 0
+ my $j = $node->[2] || return ''; # META can be 0
$doc->{'_content'} ||= do { my $s = $self->slurp($doc->{'_filename'}) ; \$s };
my $s = substr(${ $doc->{'_content'} }, $i, $j - $i);
$s =~ s/^\s+//;
sub filter_eval {
my $context = shift;
+
return sub {
+ ### prevent recursion
+ my $t = $context->_template;
+ local $t->{'_eval_recurse'} = $t->{'_eval_recurse'} || 0;
+ $context->throw('eval_recurse', "MAX_EVAL_RECURSE $MAX_EVAL_RECURSE reached")
+ if ++$t->{'_eval_recurse'} > ($t->{'MAX_EVAL_RECURSE'} || $MAX_EVAL_RECURSE);
+
+
my $text = shift;
return $context->process(\$text);
};
if (my $node = $self->node) {
# $msg .= " (In tag $node->[0] starting at char ".($node->[1] + $self->offset).")";
}
+ if ($self->type =~ /^parse/) {
+ $msg .= " (At char ".$self->offset.")";
+ }
return $msg;
}
there will continue to be code sharing between the two projects. (Acutally
I will try and keep applicable fixes in sync with TT).
+CGI::Ex::Template uses a recursive regex based grammar (early versions
+before the 2.10 release did not). This allows for the embedding of opening
+and closing tags inside other tags (as in [% a = "[% 1 + 2 %]" ; a|eval %]).
+The individual methods such as parse_expr and play_expr may be used by external
+applications to add TT style variable parsing to other applications.
+
Most of the standard Template::Toolkit documentation covering directives,
variables, configuration, plugins, filters, syntax, and vmethods should
apply to CET just fine (This pod tries to explain everything - but there is
In general the following statements are true:
If you load a new Template object each time and pass a filename, CET
- is around 4 times faster.
+ is around 3.5 times faster.
If you load a new Template object and pass a string ref, CET
- is around 3.5 times faster.
+ is around 3 times faster.
If you load a new Template object and use CACHE_EXT, CET
is around 1.5 times faster.
then CET is 50% faster.
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%
- faster than CET with a new object compiling each time.
+ then CET is about as fast. But if you use CGI::Ex::Template::XS,
+ the CETX is faster still (about twice as fast as CET).
It is pretty hard to beat the speed of XS stash with compiled in
memory templates. Many systems don't have access to those so
CET may make more sense. Hopefully as TT is revised, many of the CET
speed advantages can be incorporated so that the core TT is just as
-fast or faster.
+fast or faster. This was last updated at version 2.10 of CET and
+2.18 of TT.
So should you use CGI::Ex::Template ? Well, try it out. It may
give you no visible improvement. Or it could.
[% (a ~ b).length %]
- [% "hi".repeat(3) %]
+ [% "hi".repeat(3) %] # = hihihi
- [% {a => b}.size %]
+ [% {a => b}.size %] # = 1
=item The "${" and "}" variable interpolators can contain expressions,
not just variables.
[% color = qw/Red Blue/; FOR [1..4] ; color.${ loop.index % color.size } ; END %]
# = RedBlueRedBlue
+=item Tags can be nested.
+
+ [% f = "[% (1 + 2) %]" %][% f|eval %] # = 3
+
=item Arrays can be accessed with non-integer numbers.
[% [0..10].${ 2.3 } %] # = 3
=item CET does not generate Perl code.
-It generates an "opcode" tree.
+It generates an "opcode" tree. The opcode tree is an arrayref
+of scalars and array refs nested as deeply as possible. This "simple"
+structure could be shared TT implementations in other languages
+via JSON or YAML.
=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 eval_filter and MACRO recursion protection
+
+You can control the nested nature of eval_filter and MACRO
+recursion using the MAX_EVAL_RECURSE and MAX_MACRO_RECURSE
+configuration items.
+
=item There is no context.
CET provides a context object that mimics the Template::Context
=item There is no grammar.
-CET has its own built in recursive grammar system.
+CET has its own built-in recursive regex based grammar system.
=item There is no VIEW directive.
-
-=item There are no references.
-
-There were in initial beta tests, but it was decided to remove the little used feature which
-took a length of code to implement.
-
=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.
-=item There is no ANYCASE configuration item.
-
-There was in initial beta tests, but it was dropped in favor of consistent parsing syntax (and
-a minimal amount of speedup).
-
-=item There is no V1DOLLAR configuration item.
-
-This is a TT version 1 compatibility item and is not available in CET.
-
=back
=head1 VARIABLES
CGI::Ex::Template=HASH(0x814dc28)
- $VAR1 = [ \[ '+', '1', '2' ], 0 ];
+ $VAR1 = [ [ undef, '+', '1', '2' ], 0 ];
Each type of data (string, array and hash) have virtual methods
associated with them. Virtual methods allow for access to functions
Note: virtual methods can only be used on literal strings in CET, not in TT.
+You may also embed the current tags in strings (CET only).
+
+ [% '[% 1 + 2 %]' | eval %] Prints "3"
+
=item Double quoted strings.
Returns the string. Variable interpolation happens.
Note: virtual methods can only be used on literal strings in CET, not in TT.
+You may also embed the current tags in strings (CET only).
+
+ [% "[% 1 + 2 %]" | eval %] Prints "3"
+
=item Array Constructs.
[% [1, 2, 3] %] Prints something like ARRAY(0x8309e90).
The named tags are (duplicated from TT):
- template => ['[%', '%]'], # default
- metatext => ['%%', '%%'], # Text::MetaText
- star => ['[*', '*]'], # TT alternate
- php => ['<?', '?>'], # PHP
- asp => ['<%', '%>'], # ASP
- mason => ['<%', '>' ], # HTML::Mason
- html => ['<!--', '-->'], # HTML comments
+ asp => ['<%', '%>' ], # ASP
+ default => ['\[%', '%\]' ], # default
+ html => ['<!--', '-->' ], # HTML comments
+ mason => ['<%', '>' ], # HTML::Mason
+ metatext => ['%%', '%%' ], # Text::MetaText
+ php => ['<\?', '\?>' ], # PHP
+ star => ['\[\*', '\*\]' ], # TT alternate
+ template1 => ['[\[%]%', '%[%\]]'], # allow TT1 style
+
+If custom tags are supplied, by default they are escaped using
+quotemeta. If a third argument is given and is equal to "unquoted",
+then no quoting takes place on the new tags.
+
+ [% TAGS [<] [>] %] matches "[<] tag [>]"
+
+ [% TAGS [<] [>] unquoted %] matches "< tag >"
+
+ [% TAGS ** ** %] matches "** tag **"
+
+ [% TAGS ** ** unquoted %] Throws an exception.
=item C<THROW>
Would print:
- $VAR1 = [ \[ '*', '2', '3' ], 0 ];
+ $VAR1 = [ [ undef, '*', '2', '3' ], 0 ];
See the PLUGIN_BASE, and PLUGINS configuration items.
This shouldn't be too much hardship and offers the great return of disambiguating
virtual method access.
+=item C<\>
+
+Unary. The reference operator. Not well publicized in TT. Stores a reference
+to a variable for use later. Can also be used to "alias" long names.
+
+ [% f = 7 ; foo = \f ; f = 8 ; foo %] => 8
+
+ [% foo = \f.g.h.i.j.k; f.g.h.i.j.k = 7; foo %] => 7
+
+ [% f = "abcd"; foo = \f.replace("ab", "-AB-") ; foo %] => -AB-cd
+
+ [% f = "abcd"; foo = \f.replace("bc") ; foo("-BC-") %] => a-BC-d
+
+ [% f = "abcd"; foo = \f.replace ; foo("cd", "-CD-") %] => ab-CD-
+
=item C<++ -->
Pre and post increment and decrement. My be used as either a prefix
Right associative. Lower precedence version of the '||' operator.
-=item C<hash>
+=item C<{}>
This operator is not used in TT. It is used internally
by CGI::Ex::Template to delay the creation of a hash until the
execution of the compiled template.
-=item C<array>
+=item C<[]>
This operator is not used in TT. It is used internally
by CGI::Ex::Template to delay the creation of an array until the
These variables should be passed to the "new" constructor.
- my $obj = CGI::Ex::Template->new(
- VARIABLES => \%hash_of_variables,
- AUTO_RESET => 0,
- TRIM => 1,
- POST_CHOMP => "=",
- PRE_CHOMP => "-",
- );
+ my $obj = CGI::Ex::Template->new(
+ VARIABLES => \%hash_of_variables,
+ AUTO_RESET => 0,
+ TRIM => 1,
+ POST_CHOMP => "=",
+ PRE_CHOMP => "-",
+ );
=over 4
Boolean. Default false. Are absolute paths allowed for included files.
+=item ANYCASE
+
+Allow directive matching to be case insensitive.
+
+ [% get 23 %] prints 23 with ANYCASE => 1
+
=item AUTO_RESET
Boolean. Default 1. Clear blocks that were set during the process method.
A hashref of blocks that can be used by the process method.
- BLOCKS => {
- block_1 => sub { ... }, # coderef that returns a block
- block_2 => 'A String', # simple string
- },
+ BLOCKS => {
+ block_1 => sub { ... }, # coderef that returns a block
+ block_2 => 'A String', # simple string
+ },
Note that a Template::Document cannot be supplied as a value (TT
supports this). However, it is possible to supply a value that is
[% IF 1 %]The variable $variable had a value ${var.value}[% END %]
-
=item LOAD_PERL
Indicates if the USE directive can fall back and try and load a perl module
if the indicated module was not found in the PLUGIN_BASE path. See the
USE directive.
+=item MAX_EVAL_RECURSE (CET only)
+
+Will use $CGI::Ex::Template::MAX_EVAL_RECURSE if not present. Default is 50.
+Prevents runaway on the following:
+
+ [% f = "[% f|eval %]" %][% f|eval %]
+
+=item MAX_MACRO_RECURSE (CET only)
+
+Will use $CGI::Ex::Template::MAX_MACRO_RECURSE if not present. Default is 50.
+Prevents runaway on the following:
+
+ [% MACRO f BLOCK %][% f %][% END %][% f %]
+
=item NAMESPACE
No Template::Namespace::Constants support. Hashref of hashrefs representing
You can also sub class the module and override the undefined_get method.
+=item V1DOLLAR
+
+This allows for some compatibility with TT1 templates. The only real
+behavior change is that [% $foo %] becomes the same as [% foo %]. The
+following is a basic table of changes invoked by using V1DOLLAR.
+
+ With V1DOLLAR Equivalent Without V1DOLLAR (Normal default)
+ "[% foo %]" "[% foo %]"
+ "[% $foo %]" "[% foo %]"
+ "[% ${foo} %]" "[% ${foo} %]"
+ "[% foo.$bar %]" "[% foo.bar %]"
+ "[% ${foo.bar} %]" "[% ${foo.bar} %]"
+ "[% ${foo.$bar} %]" "[% ${foo.bar} %]"
+ "Text: $foo" "Text: $foo"
+ "Text: ${foo}" "Text: ${foo}"
+ "Text: ${$foo}" "Text: ${foo}"
+
=item VARIABLES
A hashref of variables to initialize the template stash with. These
=over 4
-=item ANYCASE
-
-This will not be supported. You will have to use the full case directive names.
-(It was in the beta code but was removed prior to release).
-
=item WRAPPER
This will be supported - just not done yet.
This will be supported - just not done yet.
-=item V1DOLLAR
-
-This will not be supported.
-
=item LOAD_TEMPLATES
CGI::Ex::Template has its own mechanism for loading and storing
one.${two().three} [ 'one', 0, '.', ['two', [], '.', 'three', 0], 0]
2.34 2.34
"one" "one"
- "one"|length [ \"one", 0, '|', 'length', 0 ]
- "one $a two" [ \ [ '~', 'one ', ['a', 0], ' two' ], 0 ]
- [0, 1, 2] [ \ [ 'array', 0, 1, 2 ], 0 ]
- [0, 1, 2].size [ \ [ 'array', 0, 1, 2 ], 0, '.', 'size', 0 ]
- ['a', a, $a ] [ \ [ 'array', 'a', ['a', 0], [['a', 0], 0] ], 0]
- {a => 'b'} [ \ [ 'hash', 'a', 'b' ], 0 ]
- {a => 'b'}.size [ \ [ 'hash', 'a', 'b' ], 0, '.', 'size', 0 ]
- {$a => b} [ \ [ 'hash', ['a', 0], ['b', 0] ], 0 ]
- 1 + 2 [ \ [ '+', 1, 2 ], 0]
- a + b [ \ [ '+', ['a', 0], ['b', 0] ], 0 ]
- a * (b + c) [ \ [ '*', ['a', 0], [ \ ['+', ['b', 0], ['c', 0]], 0 ]], 0 ]
- (a + b) [ \ [ '+', ['a', 0], ['b', 0] ]], 0 ]
- (a + b) * c [ \ [ '*', [ \ [ '+', ['a', 0], ['b', 0] ], 0 ], ['c', 0] ], 0 ]
- a ? b : c [ \ [ '?', ['a', 0], ['b', 0], ['c', 0] ], 0 ]
- a || b || c [ \ [ '||', ['a', 0], [ \ [ '||', ['b', 0], ['c', 0] ], 0 ] ], 0 ]
- ! a [ \ [ '!', ['a', 0] ], 0 ]
+ "one"|length [ [ undef, '~', "one" ], 0, '|', 'length', 0 ]
+ "one $a two" [ [ undef, '~', 'one ', ['a', 0], ' two' ], 0 ]
+ [0, 1, 2] [ [ undef, '[]', 0, 1, 2 ], 0 ]
+ [0, 1, 2].size [ [ undef, '[]', 0, 1, 2 ], 0, '.', 'size', 0 ]
+ ['a', a, $a ] [ [ undef, '[]', 'a', ['a', 0], [['a', 0], 0] ], 0]
+ {a => 'b'} [ [ undef, '{}', 'a', 'b' ], 0 ]
+ {a => 'b'}.size [ [ undef, '{}', 'a', 'b' ], 0, '.', 'size', 0 ]
+ {$a => b} [ [ undef, '{}', ['a', 0], ['b', 0] ], 0 ]
+ 1 + 2 [ [ undef, '+', 1, 2 ], 0]
+ a + b [ [ undef, '+', ['a', 0], ['b', 0] ], 0 ]
+ a * (b + c) [ [ undef, '*', ['a', 0], [ [undef, '+', ['b', 0], ['c', 0]], 0 ]], 0 ]
+ (a + b) [ [ undef, '+', ['a', 0], ['b', 0] ]], 0 ]
+ (a + b) * c [ [ undef, '*', [ [undef, '+', ['a', 0], ['b', 0] ], 0 ], ['c', 0] ], 0 ]
+ a ? b : c [ [ undef, '?', ['a', 0], ['b', 0], ['c', 0] ], 0 ]
+ a || b || c [ [ undef, '||', ['a', 0], [ [undef, '||', ['b', 0], ['c', 0] ], 0 ] ], 0 ]
+ ! a [ [ undef, '!', ['a', 0] ], 0 ]
Some notes on the parsing.
Operators are parsed as part of the variable and become part of the variable tree.
- Operators are stored in the variable tree using a reference to the arrayref - which
+ Operators are stored in the variable tree using an operator identity array which
+ contains undef as the first value, the operator, and the operator arguments. This
allows for quickly descending the parsed variable tree and determining that the next
node is an operator.
=item C<dump_parse>
-This method allows for returning a Data::Dumper dump of a parsed template. It is mainly used for testing.
+This method allows for returning a Data::Dumper dump of a parsed
+template. It is mainly used for testing.
=item C<dump_parse_expr>
-This method allows for returning a Data::Dumper dump of a parsed variable. It is mainly used for testing.
+This method allows for returning a Data::Dumper dump of a parsed
+variable. It is mainly used for testing.
=item C<exception>
=item C<play_expr>
-Turns a variable identity array into the parsed variable. This
-method is also responsible for playing operators and running virtual methods
-and filters. The method could more accurately be called play_expression.
+Play the parsed expression. Turns a variable identity array into the
+parsed variable. This method is also responsible for playing
+operators and running virtual methods and filters. The variable
+identity array may also contain literal values, or operator identity
+arrays.
=item C<include_filename>
=item C<play_operator>
-Used to execute any found operators
+Used to execute any found operators. The single argument is
+an operator identy returned by the parse_expr method (if the expression
+contained an operator). Normally you would just call play_expr
+instead and it will call play_operator if the structure
+contains an operator.
=item C<_process>
@UNSUPPORTED_BROWSERS
);
-$VERSION = '2.09';
+$VERSION = '2.10';
$DEFAULT_EXT = 'val';
$QR_EXTRA = qr/^(\w+_error|as_(array|string|hash)_\w+|no_\w+)/;
@UNSUPPORTED_BROWSERS = (qr/MSIE\s+5.0\d/i);
-use CGI::Ex::Conf ();
-
###----------------------------------------------------------------###
sub new {
- my $class = shift || __PACKAGE__;
- my $self = (@_ && ref($_[0])) ? shift : {@_};
+ my $class = shift;
+ my $self = ref($_[0]) ? shift : {@_};
- ### allow for global defaults
- foreach (keys %DEFAULT_OPTIONS) {
- $self->{$_} = $DEFAULT_OPTIONS{$_} if ! exists $self->{$_};
- }
+ $self = {%DEFAULT_OPTIONS, %$self} if scalar keys %DEFAULT_OPTIONS;
return bless $self, $class;
}
###----------------------------------------------------------------###
sub cgix {
- my $self = shift;
- return $self->{cgix} ||= do {
- require CGI::Ex;
- CGI::Ex->new;
- };
+ my $self = shift;
+ return $self->{'cgix'} ||= do {
+ require CGI::Ex;
+ CGI::Ex->new;
+ };
}
### the main validation routine
sub validate {
- my $self = (! ref($_[0])) ? shift->new # $class->validate
- : UNIVERSAL::isa($_[0], __PACKAGE__) ? shift # $self->validate
- : __PACKAGE__->new; # &validate
- my $form = shift || die "Missing form hash";
- my $val_hash = shift || die "Missing validation hash";
- my $what_was_validated = shift; # allow for extra arrayref that stores what was validated
-
- ### turn the form into a form if it is really a CGI object
- if (! ref($form)) {
- die "Invalid form hash or cgi object";
- } elsif(! UNIVERSAL::isa($form,'HASH')) {
- local $self->{cgi_object} = $form;
- $form = $self->cgix->get_form($form);
- }
+ my $self = (! ref($_[0])) ? shift->new # $class->validate
+ : UNIVERSAL::isa($_[0], __PACKAGE__) ? shift # $self->validate
+ : __PACKAGE__->new; # &validate
+ my $form = shift || die "Missing form hash";
+ my $val_hash = shift || die "Missing validation hash";
+ my $what_was_validated = shift; # allow for extra arrayref that stores what was validated
+
+ ### turn the form into a form hash if doesn't look like one already
+ die "Invalid form hash or cgi object" if ! ref $form;
+ if (ref $form ne 'HASH') {
+ local $self->{cgi_object} = $form;
+ $form = $self->cgix->get_form($form);
+ }
+
+ ### make sure the validation is a hashref
+ ### get_validation handle odd types
+ if (ref $val_hash ne 'HASH') {
+ $val_hash = $self->get_validation($val_hash) if ref $val_hash ne 'SCALAR' || ! ref $val_hash;
+ die "Validation groups must be a hashref" if ref $val_hash ne 'HASH';
+ }
- ### get the validation - let get_validation deal with types
- ### if a ref is not passed - assume it is a filename
- $val_hash = $self->get_validation($val_hash);
-
- ### allow for validation passed as single group hash, single group array,
- ### or array of group hashes or group arrays
- my @ERRORS = ();
- my %EXTRA = ();
- my @USED_GROUPS = ();
- my $group_order = UNIVERSAL::isa($val_hash,'HASH') ? [$val_hash] : $val_hash;
- foreach my $group_val (@$group_order) {
- die "Validation groups must be a hashref" if ! UNIVERSAL::isa($group_val,'HASH');
- my $title = $group_val->{'group title'};
- my $validate_if = $group_val->{'group validate_if'};
+ ### parse keys that are group arguments - and those that are keys to validate
+ my %ARGS;
+ my @field_keys = grep { /^(?:group|general)\s+(\w+)/
+ ? do {$ARGS{$1} = $val_hash->{$_} ; 0}
+ : 1 }
+ sort keys %$val_hash;
### only validate this group if it is supposed to be checked
- next if $validate_if && ! $self->check_conditional($form, $validate_if);
- push @USED_GROUPS, $group_val;
-
- ### If the validation items were not passed as an arrayref.
- ### Look for a group order and then fail back to the keys of the group.
- ### We will keep track of what was added using %found - the keys will
- ### be the hash signatures of the field_val hashes (ignore the hash internals).
- my @field_keys;
- my @group_keys;
- foreach (sort keys %$group_val) {
- /^(group|general)\s+(\w+)/ ? push(@group_keys, [$1, $2, $_]) : push(@field_keys, $_);
- }
- my $fields = $group_val->{'group fields'};
- if ($fields) { # if I passed group fields array - use it
- die "'group fields' must be an arrayref" if ! UNIVERSAL::isa($fields,'ARRAY');
- } else { # other wise - create our own array
- my @fields = ();
- if (my $order = $group_val->{'group order'} || \@field_keys) {
- die "Validation 'group order' must be an arrayref" if ! UNIVERSAL::isa($order,'ARRAY');
- foreach my $field (@$order) {
- my $field_val = exists($group_val->{$field}) ? $group_val->{$field}
- : ($field eq 'OR') ? 'OR' : die "No element found in group for $field";
- if (ref $field_val && ! $field_val->{'field'}) {
- $field_val = { %$field_val, 'field' => $field }; # copy the values to add the key
- }
- push @fields, $field_val;
+ return if $ARGS{'validate_if'} && ! $self->check_conditional($form, $ARGS{'validate_if'});
+
+ ### Look first for items in 'group fields' or 'group order'
+ my $fields;
+ if ($fields = $ARGS{'fields'} || $ARGS{'order'}) {
+ my $type = $ARGS{'fields'} ? 'group fields' : 'group order';
+ die "Validation '$type' must be an arrayref when passed"
+ if ! UNIVERSAL::isa($fields, 'ARRAY');
+ my @temp;
+ foreach my $field (@$fields) {
+ die "Non-defined value in '$type'" if ! defined $field;
+ if (ref $field) {
+ die "Found nonhashref value in '$type'" if ref($field) ne 'HASH';
+ die "Element missing \"field\" key/value in '$type'" if ! defined $field->{'field'};
+ push @temp, $field;
+ } elsif ($field eq 'OR') {
+ push @temp, 'OR';
+ } else {
+ die "No element found in '$type' for $field" if ! exists $val_hash->{$field};
+ die "Found nonhashref value in '$type'" if ref($val_hash->{$field}) ne 'HASH';
+ push @temp, { %{ $val_hash->{$field} }, field => $field }; # copy the values to add the key
+ }
}
- }
- $fields = \@fields;
+ $fields = \@temp;
+
+ ### limit the keys that need to be searched to those not in fields or order
+ my %found = map { $_->{'field'} => 1 } @temp;
+ @field_keys = grep { ! $found{$_} } @field_keys;
}
- ### double check which field_vals have been used so far
- ### add any remaining field_vals from the order
+ ### add any remaining field_vals from our original hash
### this is necessary for items that weren't in group fields or group order
- my %found = map {$_->{'field'} => 1} @$fields;
foreach my $field (@field_keys) {
- next if $found{$field};
- my $field_val = $group_val->{$field};
- die "Found a nonhashref value on field $field" if ! UNIVERSAL::isa($field_val, 'HASH');
- $field_val->{'field'} = $field if ! defined $field_val->{'field'};
- push @$fields, $field_val;
+ die "Found nonhashref value for field $field" if ref($val_hash->{$field}) ne 'HASH';
+ if (defined $val_hash->{$field}->{'field'}) {
+ push @$fields, $val_hash->{$field}->{'field'};
+ } else {
+ push @$fields, { %{$val_hash->{$field}}, field => $field };
+ }
}
### Finally we have our arrayref of hashrefs that each have their 'field' key
### now lets do the validation
my $found = 1;
- my @errors = ();
- my $hold_error; # hold the error for a moment - to allow for an "Or" operation
- foreach (my $i = 0; $i <= $#$fields; $i ++) {
- my $ref = $fields->[$i];
- if (! ref($ref) && $ref eq 'OR') {
- $i ++ if $found; # if found skip the OR altogether
- $found = 1; # reset
- next;
- }
- $found = 1;
- die "Missing field key during normal validation" if ! $ref->{'field'};
- local $ref->{'was_validated'} = 1;
- my @err = $self->validate_buddy($form, $ref->{'field'}, $ref);
- if (delete($ref->{'was_validated'}) && $what_was_validated) {
- push @$what_was_validated, $ref;
- }
+ my @errors;
+ my $hold_error; # hold the error for a moment - to allow for an "OR" operation
+ foreach (my $i = 0; $i < @$fields; $i++) {
+ my $ref = $fields->[$i];
+ if (! ref($ref) && $ref eq 'OR') {
+ $i++ if $found; # if found skip the OR altogether
+ $found = 1; # reset
+ next;
+ }
+ $found = 1;
+ die "Missing field key during normal validation" if ! $ref->{'field'};
+ local $ref->{'was_validated'} = 1;
+ my $err = $self->validate_buddy($form, $ref->{'field'}, $ref);
+ if ($ref->{'was_validated'} && $what_was_validated) {
+ push @$what_was_validated, $ref;
+ }
- ### test the error - if errors occur allow for OR - if OR fails use errors from first fail
- if (scalar @err) {
- if ($i < $#$fields && ! ref($fields->[$i + 1]) && $fields->[$i + 1] eq 'OR') {
- $hold_error = \@err;
+ ### test the error - if errors occur allow for OR - if OR fails use errors from first fail
+ if ($err) {
+ if ($i < $#$fields && ! ref($fields->[$i + 1]) && $fields->[$i + 1] eq 'OR') {
+ $hold_error = $err;
+ } else {
+ push @errors, $hold_error ? @$hold_error : @$err;
+ $hold_error = undef;
+ }
} else {
- push @errors, $hold_error ? @$hold_error : @err;
- $hold_error = undef;
+ $hold_error = undef;
}
- } else {
- $hold_error = undef;
- }
}
push(@errors, @$hold_error) if $hold_error; # allow for final OR to work
- ### add on errors as requested
- if ($#errors != -1) {
- push @ERRORS, $title if $title;
- push @ERRORS, @errors;
- }
- ### add on general options, and group options if errors in group occurred
- foreach (@group_keys) {
- my ($type, $short_key, $full_key) = @$_;
- next if $type eq 'group' && ($#errors == -1 || $short_key =~ /^(field|order|title)$/);
- $EXTRA{$short_key} = $group_val->{$full_key};
+ ### optionally check for unused keys in the form
+ if ($ARGS{no_extra_fields} || $self->{no_extra_fields}) {
+ my %keys = map { ($_->{'field'} => 1) } @$fields; # %{ $self->get_validation_keys($val_hash) };
+ foreach my $key (sort keys %$form) {
+ next if $keys{$key};
+ push @errors, [$key, 'no_extra_fields', {}, undef];
+ }
}
- }
- ### store any extra items from self
- $EXTRA{$_} = $self->{$_} for grep {/$QR_EXTRA/o} keys %$self;
-
- ### allow for checking for unused keys
- if ($EXTRA{no_extra_fields}) {
- my $which = ($EXTRA{no_extra_fields} =~ /used/i) ? 'used' : 'all';
- my $ref = ($which eq 'all') ? $val_hash : \@USED_GROUPS;
- my $keys = $self->get_validation_keys($ref);
- foreach my $key (sort keys %$form) {
- next if $keys->{$key};
- push @ERRORS, [$key, 'no_extra_fields', {}, undef];
+ ### return what they want
+ if (@errors) {
+ my @copy = grep {/$QR_EXTRA/o} keys %$self;
+ @ARGS{@copy} = @{ $self }{@copy};
+ unshift @errors, $ARGS{'title'} if $ARGS{'title'};
+ my $err_obj = $self->new_error(\@errors, \%ARGS);
+ die $err_obj if $ARGS{'raise_error'};
+ return $err_obj;
+ } else {
+ return;
}
- }
-
- ### return what they want
- if ($#ERRORS != -1) {
- my $err_obj = $self->new_error(\@ERRORS, \%EXTRA);
- die $err_obj if $EXTRA{'raise_error'};
- return $err_obj;
- } else {
- return wantarray ? () : undef;
- }
}
sub new_error {
### allow for optional validation on groups and on individual items
sub check_conditional {
- my ($self, $form, $ifs, $N_level, $ifs_match) = @_;
-
- $N_level ||= 0;
- $N_level ++; # prevent too many recursive checks
+ my ($self, $form, $ifs, $ifs_match) = @_;
### can pass a single hash - or an array ref of hashes
if (! $ifs) {
$ifs = [$ifs];
}
+ local $self->{'_check_conditional'} = 1;
+
### run the if options here
### multiple items can be passed - all are required unless OR is used to separate
my $found = 1;
my $field = $ref->{'field'} || die "Missing field key during validate_if (possibly used a reference to a main hash *foo -> &foo)";
$field =~ s/\$(\d+)/defined($ifs_match->[$1]) ? $ifs_match->[$1] : ''/eg if $ifs_match;
- my @err = $self->validate_buddy($form, $field, $ref, $N_level);
- $found = 0 if scalar @err;
+ my $errs = $self->validate_buddy($form, $field, $ref);
+ $found = 0 if $errs;
}
return $found;
}
### this is where the main checking goes on
sub validate_buddy {
my $self = shift;
- my ($form, $field, $field_val, $N_level, $ifs_match) = @_;
- $N_level ||= 0;
- $N_level ++; # prevent too many recursive checks
- die "Max dependency level reached $N_level" if $N_level > 10;
+ my ($form, $field, $field_val, $ifs_match) = @_;
+
+ local $self->{'_recurse'} = ($self->{'_recurse'} || 0) + 1;
+ die "Max dependency level reached 10" if $self->{'_recurse'} > 10;
my @errors = ();
my $types = [sort keys %$field_val];
### allow for not running some tests in the cgi
if ($field_val->{'exclude_cgi'}) {
delete $field_val->{'was_validated'};
- return wantarray ? @errors : $#errors + 1;
+ return 0;
}
### allow for field names that contain regular expressions
foreach my $_field (sort keys %$form) {
next if ($not && $_field =~ m/(?$opt:$pat)/) || (! $not && $_field !~ m/(?$opt:$pat)/);
my @match = (undef, $1, $2, $3, $4, $5); # limit to the matches
- push @errors, $self->validate_buddy($form, $_field, $field_val, $N_level, \@match);
+ my $errs = $self->validate_buddy($form, $_field, $field_val, \@match);
+ push @errors, @$errs if $errs;
}
- return wantarray ? @errors : $#errors + 1;
+ return @errors ? \@errors : 0;
}
my $values = UNIVERSAL::isa($form->{$field},'ARRAY') ? $form->{$field} : [$form->{$field}];
foreach my $type (grep {/^validate_if_?\d*$/} @$types) {
$n_vif ++;
my $ifs = $field_val->{$type};
- my $ret = $self->check_conditional($form, $ifs, $N_level, $ifs_match);
+ my $ret = $self->check_conditional($form, $ifs, $ifs_match);
$needs_val ++ if $ret;
}
if (! $needs_val && $n_vif) {
delete $field_val->{'was_validated'};
- return wantarray ? @errors : $#errors + 1;
+ return 0;
}
### check for simple existence
if (! $is_required) {
foreach my $type (grep {/^required_if_?\d*$/} @$types) {
my $ifs = $field_val->{$type};
- next if ! $self->check_conditional($form, $ifs, $N_level, $ifs_match);
+ next if ! $self->check_conditional($form, $ifs, $ifs_match);
$is_required = $type;
last;
}
}
if ($is_required
&& ($n_values == 0 || ($n_values == 1 && (! defined($values->[0]) || ! length $values->[0])))) {
- return 1 if ! wantarray;
- push @errors, [$field, $is_required, $field_val, $ifs_match];
- return @errors;
+ return [] if $self->{'_check_conditional'};
+ return [[$field, $is_required, $field_val, $ifs_match]];
}
### min values check
my $n = exists($field_val->{'min_values'}) ? $field_val->{'min_values'} || 0 : 0;
if ($n_values < $n) {
- return 1 if ! wantarray;
- push @errors, [$field, 'min_values', $field_val, $ifs_match];
- return @errors;
+ return [] if $self->{'_check_conditional'};
+ return [[$field, 'min_values', $field_val, $ifs_match]];
}
### max values check
$field_val->{'max_values'} = 1 if ! exists $field_val->{'max_values'};
$n = $field_val->{'max_values'} || 0;
if ($n_values > $n) {
- return 1 if ! wantarray;
- push @errors, [$field, 'max_values', $field_val, $ifs_match];
- return @errors;
+ return [] if $self->{'_check_conditional'};
+ return [[$field, 'max_values', $field_val, $ifs_match]];
}
### max_in_set and min_in_set checks
}
if ( ($minmax eq 'min' && $n > 0)
|| ($minmax eq 'max' && $n < 0)) {
- return 1 if ! wantarray;
- push @errors, [$field, $type, $field_val, $ifs_match];
- return @errors;
+ return [] if $self->{'_check_conditional'};
+ return [[$field, $type, $field_val, $ifs_match]];
}
}
}
$found = 1 if defined($value) && $_ eq $value;
}
if (! $found) {
- return 1 if ! wantarray;
+ return [] if $self->{'_check_conditional'};
push @errors, [$field, 'enum', $field_val, $ifs_match];
}
$content_checked = 1;
$success = 1; # occurs if they are both undefined
}
if ($not ? $success : ! $success) {
- return 1 if ! wantarray;
+ return [] if $self->{'_check_conditional'};
push @errors, [$field, $type, $field_val, $ifs_match];
}
$content_checked = 1;
if (exists $field_val->{'min_len'}) {
my $n = $field_val->{'min_len'};
if (! defined($value) || length($value) < $n) {
- return 1 if ! wantarray;
+ return [] if $self->{'_check_conditional'};
push @errors, [$field, 'min_len', $field_val, $ifs_match];
}
}
if (exists $field_val->{'max_len'}) {
my $n = $field_val->{'max_len'};
if (defined($value) && length($value) > $n) {
- return 1 if ! wantarray;
+ return [] if $self->{'_check_conditional'};
push @errors, [$field, 'max_len', $field_val, $ifs_match];
}
}
if ( ( $not && ( defined($value) && $value =~ m/(?$opt:$pat)/))
|| (! $not && (! defined($value) || $value !~ m/(?$opt:$pat)/))
) {
- return 1 if ! wantarray;
+ return [] if $self->{'_check_conditional'};
push @errors, [$field, $type, $field_val, $ifs_match];
}
}
die "Not sure how to compare \"$comp\"";
}
if (! $test) {
- return 1 if ! wantarray;
+ return [] if $self->{'_check_conditional'};
push @errors, [$field, $type, $field_val, $ifs_match];
}
}
$field_val->{"${type}_error_if"} = 1 if ! defined $field_val->{"${type}_error_if"};
if ( (! $return && $field_val->{"${type}_error_if"})
|| ($return && ! $field_val->{"${type}_error_if"}) ) {
- return 1 if ! wantarray;
+ return [] if $self->{'_check_conditional'};
push @errors, [$field, $type, $field_val, $ifs_match];
}
$content_checked = 1;
foreach my $type (grep {/^custom_?\d*$/} @$types) {
my $check = $field_val->{$type};
next if UNIVERSAL::isa($check, 'CODE') ? &$check($field, $value, $field_val, $type) : $check;
- return 1 if ! wantarray;
+ return [] if $self->{'_check_conditional'};
push @errors, [$field, $type, $field_val, $ifs_match];
$content_checked = 1;
}
### do specific type checks
foreach my $type (grep {/^type_?\d*$/} @$types) {
if (! $self->check_type($value,$field_val->{'type'},$field,$form)){
- return 1 if ! wantarray;
+ return [] if $self->{'_check_conditional'};
push @errors, [$field, $type, $field_val, $ifs_match];
}
$content_checked = 1;
}
### all done - time to return
- return wantarray ? @errors : $#errors + 1;
+ return @errors ? \@errors : 0;
}
###----------------------------------------------------------------###
###----------------------------------------------------------------###
sub get_validation {
- my $self = shift;
- my $val = shift;
- return CGI::Ex::Conf::conf_read($val, {html_key => 'validation', default_ext => $DEFAULT_EXT});
+ my $self = shift;
+ my $val = shift;
+ require CGI::Ex::Conf;
+ return CGI::Ex::Conf::conf_read($val, {html_key => 'validation', default_ext => $DEFAULT_EXT});
}
### returns all keys from all groups - even if group has validate_if
my $self = shift;
my $val_hash = shift;
my $form = shift; # with optional form - will only return keys in validated groups
- my %keys = ();
- ### if a form was passed - make sure it is a hashref
+ ### turn the form into a form hash if doesn't look like one already
if ($form) {
- if (! ref($form)) {
- die "Invalid form hash or cgi object";
- } elsif(! UNIVERSAL::isa($form,'HASH')) {
- require CGI::Ex;
- $form = CGI::Ex->new->get_form($form);
- }
+ die "Invalid form hash or cgi object" if ! ref $form;
+ if (ref $form ne 'HASH') {
+ local $self->{cgi_object} = $form;
+ $form = $self->cgix->get_form($form);
+ }
}
- my $refs = $self->get_validation($val_hash);
- $refs = [$refs] if ! UNIVERSAL::isa($refs,'ARRAY');
- foreach my $group_val (@$refs) {
- die "Group found that was not a hashref" if ! UNIVERSAL::isa($group_val, 'HASH');
+ ### make sure the validation is a hashref
+ ### get_validation handle odd types
+ if (ref $val_hash ne 'HASH') {
+ $val_hash = $self->get_validation($val_hash) if ref $val_hash ne 'SCALAR' || ! ref $val_hash;
+ die "Validation groups must be a hashref" if ref $val_hash ne 'HASH';
+ }
- ### if form is passed, check to see if the group passed validation
- if ($form) {
- my $validate_if = $group_val->{'group validate_if'};
- next if $validate_if && ! $self->check_conditional($form, $validate_if);
+ ### parse keys that are group arguments - and those that are keys to validate
+ my %ARGS;
+ my @field_keys = grep { /^(?:group|general)\s+(\w+)/
+ ? do {$ARGS{$1} = $val_hash->{$_} ; 0}
+ : 1 }
+ sort keys %$val_hash;
+
+ ### only validate this group if it is supposed to be checked
+ return if $form && $ARGS{'validate_if'} && ! $self->check_conditional($form, $ARGS{'validate_if'});
+
+ ### Look first for items in 'group fields' or 'group order'
+ my %keys;
+ if (my $fields = $ARGS{'fields'} || $ARGS{'order'}) {
+ my $type = $ARGS{'fields'} ? 'group fields' : 'group order';
+ die "Validation '$type' must be an arrayref when passed"
+ if ! UNIVERSAL::isa($fields, 'ARRAY');
+ foreach my $field (@$fields) {
+ die "Non-defined value in '$type'" if ! defined $field;
+ if (ref $field) {
+ die "Found nonhashref value in '$type'" if ref($field) ne 'HASH';
+ die "Element missing \"field\" key/value in '$type'" if ! defined $field->{'field'};
+ $keys{$field->{'field'}} = $field->{'name'} || 1;
+ } elsif ($field eq 'OR') {
+ } else {
+ die "No element found in '$type' for $field" if ! exists $val_hash->{$field};
+ die "Found nonhashref value in '$type'" if ref($val_hash->{$field}) ne 'HASH';
+ $keys{$field} = $val_hash->{$field}->{'name'} || 1;
+ }
}
+ }
- if ($group_val->{"group fields"}) {
- die "Group fields must be an arrayref" if ! UNIVERSAL::isa($group_val->{"group fields"}, 'ARRAY');
- foreach my $field_val (@{ $group_val->{"group fields"} }) {
- next if ! ref($field_val) && $field_val eq 'OR';
- die "Field_val must be a hashref" if ! UNIVERSAL::isa($field_val, 'HASH');
- my $key = $field_val->{'field'} || die "Missing field key in field_val hashref";
- $keys{$key} = $field_val->{'name'} || 1;
- }
- } elsif ($group_val->{"group order"}) {
- die "Group order must be an arrayref" if ! UNIVERSAL::isa($group_val->{"group order"}, 'ARRAY');
- foreach my $key (@{ $group_val->{"group order"} }) {
- my $field_val = $group_val->{$key};
- next if ! $field_val && $key eq 'OR';
- die "Field_val for $key must be a hashref" if ! UNIVERSAL::isa($field_val, 'HASH');
- $key = $field_val->{'field'} if $field_val->{'field'};
- $keys{$key} = $field_val->{'name'} || 1;
+ ### add any remaining field_vals from our original hash
+ ### this is necessary for items that weren't in group fields or group order
+ foreach my $field (@field_keys) {
+ next if $keys{$field};
+ die "Found nonhashref value for field $field" if ref($val_hash->{$field}) ne 'HASH';
+ if (defined $val_hash->{$field}->{'field'}) {
+ $keys{$val_hash->{$field}->{'field'}} = $val_hash->{$field}->{'name'} || 1;
+ } else {
+ $keys{$field} = $val_hash->{$field}->{'name'} || 1;
}
- }
-
- ### get all others
- foreach my $key (keys %$group_val) {
- next if $key =~ /^(general|group)\s/;
- my $field_val = $group_val->{$key};
- next if ! UNIVERSAL::isa($field_val, 'HASH');
- $keys{$key} = $field_val->{'name'} || 1;
- }
}
return \%keys;
use overload '""' => \&as_string;
sub new {
- my $class = shift || __PACKAGE__;
- my $errors = shift;
- my $extra = shift || {};
- die "Missing or invalid arrayref" if ! UNIVERSAL::isa($errors, 'ARRAY');
- die "Missing or invalid hashref" if ! UNIVERSAL::isa($extra, 'HASH');
- return bless {errors => $errors, extra => $extra}, $class;
+ my ($class, $errors, $extra) = @_;
+ die "Missing or invalid errors arrayref" if ref $errors ne 'ARRAY';
+ die "Missing or invalid extra hashref" if ref $extra ne 'HASH';
+ return bless {errors => $errors, extra => $extra}, $class;
}
sub as_string {
millions of possible types, while still giving the capability for the
developer to add their own types.
-CGI::Ex::Validate can work in a simple way like all of the other
-validators do. However, it also allows for grouping of validation
-items and conditional validation of groups or individual items. This
-is more in line with the normal validation procedures for a website.
-
It also has full support for providing the same validation in javascript.
It provides methods for attaching the javascript to existing forms.
+As opposed to other kitchen sync validation modules, CGI::Ex::Validate
+offers the simple types of validation, and makes it easy to add your
+own custom types.
+
=head1 METHODS
=over 4
=item C<validate>
Arguments are a form hashref or cgi object, a validation hashref or
-filename, and an optional what_was_validated arrayref. If a CGI
-object is passed, CGI::Ex::get_form will be called on that object to
-turn it into a hashref. If a filename is given for the validation,
-get_validation will be called on that filename. If the
-what_was_validated_arrayref is passed - it will be populated (pushed)
-with the field hashes that were actually validated (anything that was
-skipped because of validate_if will not be in the array).
+filename, and an optional what_was_validated arrayref (discussed
+further later on). If a CGI object is passed, CGI::Ex::get_form will
+be called on that object to turn it into a hashref. If a filename is
+given for the validation, get_validation will be called on that
+filename. If the what_was_validated_arrayref is passed - it will be
+populated (pushed) with the field hashes that were actually validated
+(anything that was skipped because of validate_if will not be in the
+array).
If the form passes validation, validate will return undef. If it
fails validation, it will return a CGI::Ex::Validate::Error object.
-If the 'raise_error' general option has been set, validate will die
+If the 'raise_error' option has been set, validate will die
with a CGI::Ex::validate::Error object as the value.
my $err_obj = $self->validate($form, $val_hash);
# OR #
- $self->{raise_error} = 1; # raise error can also be listed in the
- val_hash eval { $self->validate($form, $val_hash) }; if ($@) { my
- $err_obj = $@; }
+ $self->{raise_error} = 1; # can also be listed in the val_hash
+ eval { $self->validate($form, $val_hash) };
+ if ($@) { my $err_obj = $@; }
=item C<generate_js>
-Requires JSON or YAML to work properly (see L<JSON> or L<YAML>).
+Works with CGI::Ex::JSONDump, but can also work with JSON or YAML
+if desired (see L<JSON> or L<YAML>).
Takes a validation hash, a form name, and an optional javascript uri
path and returns Javascript that can be embedded on a page and will
-perform identical validations as the server side. The validation can
-be any validation hash (or arrayref of hashes. The form name must be
+perform identical validations as the server side. The form name must be
the name of the form that the validation will act upon - the name is
used to register an onsubmit function. The javascript uri path is
-used to embed the locations two external javascript source files.
-
+used to embed the locations of javascript source files included
+with the CGI::Ex distribution.
The javascript uri path is highly dependent upon the server
configuration and therefore must be configured manually. It may be
code, generate_js will look in $JS_URI_PATH_YAML and
$JS_URI_PATH_VALIDATE. If either of these are not set, generate_js
will default to "$JS_URI_PATH/CGI/Ex/yaml_load.js" and
-"$JS_URI_PATH/CGI/Ex/validate.js".
+"$JS_URI_PATH/CGI/Ex/validate.js" (Note: yaml_load is only needed
+if the flags no_jsondump and no_json have been set).
$self->generate_js($val_hash, 'my_form', "/cgi-bin/js")
# would generate something like the following...
- <script src="/cgi-bin/js/CGI/Ex/yaml_load.js"></script>
<script src="/cgi-bin/js/CGI/Ex/validate.js"></script>
... more js follows ...
- $CGI::Ex::Validate::JS_URI_PATH = "/stock/js";
- $CGI::Ex::Validate::JS_URI_PATH_YAML = "/js/yaml_load.js";
+ $CGI::Ex::Validate::JS_URI_PATH = "/stock/js";
$self->generate_js($val_hash, 'my_form')
# would generate something like the following...
- <script src="/js/yaml_load.js"></script>
<script src="/stock/js/CGI/Ex/validate.js"></script>
... more js follows ...
Referencing yaml_load.js and validate.js can be done in any of
several ways. They can be copied to or symlinked to a fixed location
-in the servers html directory. They can also be printed out by a cgi.
+in the server's html directory. They can also be printed out by a cgi.
The method C<-E<gt>print_js> has been provided in CGI::Ex for printing
js files found in the perl hierarchy. See L<CGI::Ex> for more details.
The $JS_URI_PATH of "/cgi-bin/js" could contain the following:
=head1 VALIDATION HASH
-The validation hash may be passed as a perl a hashref or as a
+The validation hash may be passed as a hashref or as a
filename, or as a YAML document string. If it is a filename, it will
be translated into a hash using the %EXT_HANDLER for the extension on
the file. If there is no extension, it will use $DEFAULT_EXT as a
-default.
-
-The validation "hash" may also be an arrayref of hashrefs. In this
-case, each arrayref is treated as a group and is validated separately.
-A group can have a validate_if function that allows for that
-particular group to apply only if certain conditions are met.
+default. CGI::Ex::Conf is used for the reading of files.
-=head1 GROUPS
+Keys matching the regex m/^(general|group)\s+(\w+)$/ are reserved and
+are counted as GROUP OPTIONS. Other keys (if any, should be field names
+that need validation).
-Each hashref that is passed as a validation hash is treated as a
-group. Keys matching the regex m/^group\s+(\w+)$/ are reserved and
-are counted as GROUP OPTIONS. Keys matching the regex m/^general\s+(\w+)$/
-are reserved and are counted as GENERAL OPTIONS. Other keys (if
-any, should be keys that need validation).
+If the GROUP OPTION 'group validate_if' is set, the validation will only
+be validated if the conditions are met. If 'group validate_if' is not
+specified, then the validation will proceed.
-If the GROUP OPTION 'group validate_if' is set, the group will only
-be validated if the conditions are met. Any group with out a validate_if
-fill be automatically validated.
-
-Each of the items listed in the group will be validated. The
+Each of the items listed in the validation will be validated. The
validation order is determined in one of three ways:
=over 4
=back
-Each of the individual field validation hashrefs should contain the
-types listed in VALIDATION TYPES.
-
Optionally the 'group fields' or the 'group order' may contain the
word 'OR' as a special keyword. If the item preceding 'OR' fails
validation the item after 'OR' will be tested instead. If the item
'group order' => [qw(zip OR postalcode state OR region)],
-Each individual validation hashref will operate on the field contained
+Each individual field validation hashref will operate on the field contained
in the 'field' key. This key may also be a regular expression in the
form of 'm/somepattern/'. If a regular expression is used, all keys
-matching that pattern will be validated.
+matching that pattern will be validated. If the field key is
+not specified, the key from the top level hash will be used.
+
+ foobar => { # "foobar" is not used as key because field is specified
+ field => 'real_key_name',
+ required => 1,
+ },
+ real_key_name2 => {
+ required => 1,
+ },
+
+Each of the individual field validation hashrefs should contain the
+types listed in VALIDATION TYPES.
=head1 VALIDATION TYPES
Returns an array or arrayref (depending on scalar context) of errors that
occurred in the order that they occurred. Individual groups may have a heading
and the entire validation will have a heading (the default heading can be changed
-via the 'as_array_title' general option). Each error that occurred is a separate
-item and are pre-pended with 'as_array_prefix' (which is a general option - default
+via the 'as_array_title' group option). Each error that occurred is a separate
+item and are pre-pended with 'as_array_prefix' (which is a group option - default
is ' '). The as_array_ options may also be set via a hashref passed to as_array.
as_array_title defaults to 'Please correct the following items:'.
=item C<as_hash>
Returns a hash or hashref (depending on scalar context) of errors that
-occurred. Each key is the field name of the form that failed validation with
-'as_hash_suffix' added on as a suffix. as_hash_suffix is available as a general option
-and may also be passed in via a hashref as the only argument to as_hash.
-The default value is '_error'. The values of the hash are arrayrefs of errors
-that occurred to that form element.
-
-By default as_hash will return the values of the hash as arrayrefs (a list of the errors
-that occurred to that key). It is possible to also return the values as strings.
-Three options are available for formatting: 'as_hash_header' which will be pre-pended
-onto the error string, 'as_hash_footer' which will be appended, and 'as_hash_join' which
-will be used to join the arrayref. The only argument required to force the
-stringification is 'as_hash_join'.
+occurred. Each key is the field name of the form that failed
+validation with 'as_hash_suffix' added on as a suffix. as_hash_suffix
+is available as a group option and may also be passed in via a
+hashref as the only argument to as_hash. The default value is
+'_error'. The values of the hash are arrayrefs of errors that
+occurred to that form element.
+
+By default as_hash will return the values of the hash as arrayrefs (a
+list of the errors that occurred to that key). It is possible to also
+return the values as strings. Three options are available for
+formatting: 'as_hash_header' which will be pre-pended onto the error
+string, 'as_hash_footer' which will be appended, and 'as_hash_join'
+which will be used to join the arrayref. The only argument required
+to force the stringification is 'as_hash_join'.
### if this returns the following
my $hash = $err_obj->as_hash;
=head1 GROUP OPTIONS
-Any key in a validation hash matching the pattern m/^group\s+(\w+)$/
-is considered a group option. The current know options are:
+Any key in a validation hash matching the pattern
+m/^(group|general)\s+(\w+)$/ is considered a group option (the reason
+that either group or general may be used is that CGI::Ex::Validate
+used to have the concept of validation groups - these were not
+commonly used so support has been deprecated as of the 2.10 release).
+Group options will also be looked for in the Validate object ($self)
+and can be set when instantiating the object ($self->{raise_error} is
+equivalent to $valhash->{'group raise_error'}). The current know
+options are:
+
+Options may also be set globally before calling validate by
+populating the %DEFAULT_OPTIONS global hash.
=over 4
-=item C<'group title'>
+=item C<title>
Used as a group section heading when as_array or as_string is called
by the error object.
-=item C<'group order'>
-
-Order in which to validate key/value pairs of group.
-
-=item C<'group fields'>
-
-Arrayref of validation items to validate.
+ 'group title' => 'Title of errors',
-=item C<'group validate_if'>
+=item C<order>
-Conditions that will be checked to see if the group should be validated.
-If no validate_if option is found, the group will be validated.
-
-=back
-
-=head1 GENERAL OPTIONS
+Order in which to validate key/value pairs of group.
-Any key in a validation hash matching the pattern m/^general\s+(\w+)$/
-is considered a general option. General options will also be looked
-for in the Validate object ($self) and can be set when instantiating
-the object ($self->{raise_error} is equivalent to
-$valhash->{'general raise_error'}). The current know options are:
+ 'group order' => [qw(user pass email OR phone)],
-General options may be set in any group using the syntax:
+=item C<fields>
- 'general general_option_name' => 'general_option_value'
+Arrayref of validation items to validate.
-They will only be set if the group's validate_if is successful or
-if the group does not have a validate_if. It is also possible to set
-a "group general" option using the following syntax:
+ 'group fields' => [{
+ field => 'field1',
+ required => 1,
+ }, {
+ field => 'field2',
+ required => 1,
+ }],
- 'group general_option_name' => 'general_option_value'
+=item C<validate_if>
-These items will only be set if the group fails validation.
-If a group has a validate_if block and passes validation, the group
-items will not be used. This is so that a failed section can have
-its own settings. Note though that the last option found will be
-used and that items set in $self override those set in the validation
-hash.
+If specified - the entire hashref will only be validated if
+the "if" conditions are met.
-Options may also be set globally before calling validate by
-populating the %DEFAULT_OPTIONS global hash.
+ 'group validate_if => {field => 'email', required => 1},
-=over 4
+This group would only validate all fields if the email field
+was present.
-=item C<'general raise_error'>
+=item C<raise_error>
If raise_error is true, any call to validate that fails validation
will die with an error object as the value.
-=item C<'general no_extra_fields'>
+=item C<no_extra_fields>
If no_extra_fields is true, validate will add errors for any field found
in form that does not have a field_val hashref in the validation hash.
in a validate_if or required_if statement will not be included. You must
have an explicit entry for each key.
-=item C<'general \w+_error'>
+=item C<\w+_error>
These items allow for an override of the default errors.
- 'general required_error' => '$name is really required',
- 'general max_len_error' => '$name must be shorter than $value characters',
+ 'group required_error' => '$name is really required',
+ 'group max_len_error' => '$name must be shorter than $value characters',
# OR #
my $self = CGI::Ex::Validate->new({
max_len_error => '$name must be shorter than $value characters',
});
-=item C<'general as_array_title'>
+=item C<as_array_title>
Used as the section title for all errors that occur, when as_array
or as_string is called by the error object.
-=item C<'general as_array_prefix'>
+=item C<as_array_prefix>
Used as prefix to individual errors that occur, when as_array
or as_string is called by the error object. Each individual error
will be prefixed with this string. Headings will not be prefixed.
Default is ' '.
-=item C<'general as_string_join'>
+=item C<as_string_join>
When as_string is called, the values from as_array will be joined with
as_string_join. Default value is "\n".
-=item C<'general as_string_header'>
+=item C<as_string_header>
If set, will be pre-pended onto the string when as_string is called.
-=item C<'general as_string_footer'>
+=item C<as_string_footer>
If set, will be pre-pended onto the string when as_string is called.
-=item C<'general as_hash_suffix'>
+=item C<as_hash_suffix>
Added on to key names during the call to as_hash. Default is '_error'.
-=item C<'general as_hash_join'>
+=item C<as_hash_join>
By default, as_hash will return hashref values that are errors joined with
the default as_hash_join value of <br />. It can also return values that are
arrayrefs of the errors. This can be done by setting as_hash_join to a non-true value
(for example '')
-=item C<'general as_hash_header'>
+=item C<as_hash_header>
If as_hash_join has been set to a true value, as_hash_header may be set to
a string that will be pre-pended on to the error string.
-=item C<'general as_hash_footer'>
+=item C<as_hash_footer>
If as_hash_join has been set to a true value, as_hash_footer may be set to
a string that will be postpended on to the error string.
-=item C<'general no_inline'>
+=item C<no_inline>
If set to true, the javascript validation will not attempt to generate inline
errors. Default is true. Inline errors are independent of confirm and alert
errors.
-=item C<'general no_confirm'>
+ 'general no_inline' => 1,
+
+=item C<no_confirm>
If set to true, the javascript validation will try to use an alert instead
of a confirm to inform the user of errors. Alert and confirm are independent
or inline errors. Default is false.
-=item C<'general no_alert'>
+ 'general no_confirm' => 1,
+
+=item C<no_alert>
If set to true, the javascript validation will not show an alert box
when errors occur. Default is false. This option only comes into
no_inline, no_confirm, and no_alert all to 1, it is suggested that at
least one of the error reporting facilities is left on.
-=back
-
-It is possible to have a group that contains nothing but general options.
+ 'general no_alert' => 1,
- my $val_hash = [
- {'general error_title' => 'The following things went wrong',
- 'general error_prefix' => ' - ',
- 'general raise_error' => 1,
- 'general name_suffix' => '_foo_error',
- 'general required_error' => '$name is required',
- },
- {'group title' => 'User Information',
- username => {required => 1},
- email => {required => 1},
- password => {required => 1},
- },
- ];
+=back
=head1 JAVASCRIPT
client side as on the server side. Errors can be shown in any
combination of inline and confirm, inline and alert, inline only,
confirm only, alert only, and none. These combinations are controlled
-by the general options no_inline, no_confirm, and no_alert.
+by the group options no_inline, no_confirm, and no_alert.
Javascript validation can be generated for a page using the
C<-E<gt>generate_js> Method of CGI::Ex::Validate. It is also possible
to store the validation inline with the html. This can be done by
--- /dev/null
+#!/usr/bin/perl -w
+
+=head1 NAME
+
+bench_operator_storage.pl - Look at different ways of storing operators and how to call them
+
+=cut
+
+use strict;
+use Benchmark qw(cmpthese timethese);
+use CGI::Ex::Dump qw(debug);
+use constant skip_execute => 1;
+
+my $total_size = eval { require Devel::Size } ? sub { Devel::Size::total_size($_[0]) } : sub { "Skip Devel::Size check" };
+
+###----------------------------------------------------------------###
+### check basic setting speed - almost irrelvant as we are in the 300_000's
+
+my $set_w_ref = sub { my $s = [ \ [ '+', 4, 5], 0] };
+my $set_undef = sub { my $s = [ [undef, '+', 4, 5], 0] };
+my $set_array = sub { my $s = [ [[ '+', 4, 5]], 0] };
+my $set_arra2 = sub { my $s = [ [[], '+', 4, 5], 0] };
+my $set_bless = sub { my $s = [ bless([ '+', 4, 5],'CGI::Ex::Template::Op::foo'), 0] };
+
+print "Set_w_ref size: ". $total_size->($set_w_ref->()) ."\n";
+print "Set_undef size: ". $total_size->($set_undef->()) ."\n";
+print "Set_array size: ". $total_size->($set_array->()) ."\n";
+print "Set_arra2 size: ". $total_size->($set_arra2->()) ."\n";
+print "Set_bless size: ". $total_size->($set_bless->()) ."\n";
+
+cmpthese timethese -1, {
+ set_w_ref => $set_w_ref,
+ set_undef => $set_undef,
+ set_array => $set_array,
+ set_arra2 => $set_arra2,
+ set_bless => $set_bless,
+};
+
+###----------------------------------------------------------------###
+### time basic variable checking
+
+my $check_w_ref = sub {
+ my $s = shift;
+ if (ref $s eq 'REF') {
+ $s = $$s->[0] eq '..' ? 1 : 2;
+ } else {
+ $s = 0;
+ }
+};
+
+my $check_undef = sub {
+ my $s = shift;
+ if (! defined $s->[0]) {
+ $s = $s->[1] eq '..' ? 1 : 2;
+ } else {
+ $s = 0;
+ }
+};
+
+cmpthese timethese -1, {
+ w_ref_pos => sub { $check_w_ref->(\ ['+', 4, 5]) },
+ w_ref_dots => sub { $check_w_ref->(\ ['..', 4, 5]) },
+ w_ref_neg => sub { $check_w_ref->(['a', 0]) },
+ undef_pos => sub { $check_undef->([undef, '+', 4, 5]) },
+ undef_dots => sub { $check_undef->([undef, '..', 4, 5]) },
+ undef_neg => sub { $check_undef->(['a', 0]) },
+};
+
+###----------------------------------------------------------------###
+### check for calling speed
+
+my $play_w_ref = sub {
+ my $tree = shift;
+ my $op = $tree->[0];
+ my @args = ($tree->[1], $tree->[2]);
+};
+
+my $play_undef = sub {
+ my $tree = shift;
+ my $op = $tree->[1];
+ my @args = ($tree->[2], $tree->[3]);
+};
+
+my $play_undef2 = sub {
+ my $op = shift;
+ my @args = @_;
+};
+
+my $call_w_ref = sub {
+ my $s = shift;
+ return $play_w_ref->($$s);
+};
+
+my $call_undef = sub {
+ my $s = shift;
+ return $play_undef->($s);
+};
+
+my $call_undef2 = sub {
+ my $s = shift;
+ return $play_undef2->(@$s[1..$#$s]);
+};
+
+
+cmpthese timethese -1, {
+ small_w_ref => sub { $call_w_ref->(\ ['~', 1 .. 2]) },
+ med___w_ref => sub { $call_w_ref->(\ ['~', 1 .. 200]) },
+ large_w_ref => sub { $call_w_ref->(\ ['~', 1 .. 2000]) },
+ small_undef => sub { $call_undef->([undef, '~', 1 .. 2]) },
+ med___undef => sub { $call_undef->([undef, '~', 1 .. 200]) },
+ large_undef => sub { $call_undef->([undef, '~', 1 .. 2000]) },
+ small_undef2 => sub { $call_undef2->([undef, '~', 1 .. 2]) },
+ med___undef2 => sub { $call_undef2->([undef, '~', 1 .. 200]) },
+ large_undef2 => sub { $call_undef2->([undef, '~', 1 .. 2000]) },
+};
'43_filteruri' => "[% ' ' | uri %]", # 132% # 550% # 379% # 471% # 12524.4/s #
'44_filterevl' => "[% foo | eval %]", # 303% # 530% # 434% # 478% # 5475.5/s #
'45_capture' => "[% foo = BLOCK %]Hi[% END %][% foo %]", # 102% # 386% # 291% # 304% # 10606.5/s #
- '46_complex' => "$longer_template", # 60% # 290% # 160% # 270% # 1054.3/s #
- '47_hello2000' => "$hello2000", # 2% # 136% # 39% # 115% # 184.8/s #
+ '46_refs' => "[% b = \\code(1); b(2) %]", # 60% # 270% # 239% # 174% # 6451.9/s #
+ '47_complex' => "$longer_template", # 60% # 290% # 160% # 270% # 1054.3/s #
+ '48_hello2000' => "$hello2000", # 2% # 136% # 39% # 115% # 184.8/s #
# overall # 95% # 406% # 251% # 346% #
use Benchmark qw(timethese cmpthese countit timestr);
use IO::Socket;
-my $str = "--[% one %][% two %]--\n";
+my $str;
+$str = "--[% one %][% two %]--\n";
# Benchmark: running grammar, index, index2, match, split for at least 2 CPU seconds...
# grammar: 4 wallclock secs ( 2.04 usr + 0.00 sys = 2.04 CPU) @ 36585.78/s (n=74635)
# index: 4 wallclock secs ( 2.12 usr + 0.00 sys = 2.12 CPU) @ 81146.23/s (n=172030)
# index2 71675/s 98% 96% 24% -- -12%
# index 81146/s 124% 122% 41% 13% --
-#my $str = ((" "x1000)."[% one %]\n")x10;
+$str = ((" "x1000)."[% one %]\n")x10;
# Benchmark: running grammar, index, index2, match, split for at least 2 CPU seconds...
# grammar: 3 wallclock secs ( 2.10 usr + 0.00 sys = 2.10 CPU) @ 689.52/s (n=1448)
# index: 3 wallclock secs ( 2.10 usr + 0.00 sys = 2.10 CPU) @ 10239.52/s (n=21503)
# index2 10095/s 1364% 101% 50% -- -1%
# index 10240/s 1385% 104% 52% 1% --
-#my $str = ((" "x10)."[% one %]\n")x1000;
+#$str = ((" "x10)."[% one %]\n")x1000;
# Benchmark: running grammar, index, index2, match, split for at least 2 CPU seconds...
# grammar: 3 wallclock secs ( 2.10 usr + 0.01 sys = 2.11 CPU) @ 81.52/s (n=172)
# index: 4 wallclock secs ( 2.11 usr + 0.01 sys = 2.12 CPU) @ 207.55/s (n=440)
my $START = quotemeta '[%';
my $END = quotemeta '%]';
- my $in_tag;
local pos($_[0]) = 0;
while (1) {
### find the start tag
- if (! $in_tag) {
- if ($_[0] =~ /\G (.*?) $START /gcxs) {
- $new .= $1;
- $in_tag = 1;
- next;
- } else {
- $new .= substr $_[0], pos($_[0]);
- last;
- }
- }
+ last if $_[0] !~ /\G (.*?) $START /gcxs;
+ $new .= $1;
- ### end
- if ($_[0] =~ /\G $END /gcx) {
- $in_tag = 0;
+ if ($_[0] !~ /\G (.*?) $END /gcxs) {
+ die "Unmatched $START tag";
}
+ $new .= "($1)";
+ }
+ return pos($_[0]) ? $new . substr($_[0], pos $_[0]) : $_[0];
+}
- if ($_[0] =~ /\G (\s*\w+\s*) /gcx) {
- my $tag = $1;
- $new .= "($tag)";
+### a regex grammar type matcher
+sub parse_grammar2 {
+ my $new = '';
+ my $START = quotemeta '[%';
+ my $END = quotemeta '%]';
+
+ local pos $_[0] = 0;
+ my $last = 0;
+ while (1) {
+ ### find the start tag
+ last if $_[0] !~ / ($START) /gcxs;
+ my $i = pos $_[0];
+ $new .= substr $_[0], $last, $i - length($1) - $last;
+
+ if ($_[0] !~ / ($END) /gcxs) {
+ die "Unmatched $START tag";
}
+ $last = pos $_[0];
+ my $j = $last - length $1;
+ $new .= "(".substr($_[0], $i, $j - $i).")";
}
- return $new;
+ return pos($_[0]) ? $new . substr($_[0], pos $_[0]) : $_[0];
+}
+
+### use a regular expression to go through the string bruteforce
+sub parse_pos_array {
+ my $new = '';
+ my $START = '[%';
+ my $END = '%]';
+
+ local pos($_[0]) = 0;
+ my @start1;
+ my @start2;
+ while ($_[0] =~ /(\Q$START\E)/g) { push @start1, $-[1]; push @start2, $+[1] }
+
+ local pos($_[0]) = 0;
+ my @end1;
+ my @end2;
+ while ($_[0] =~ /(\Q$END\E)/g) { push @end1, $-[1]; push @end2, $+[1] }
+
+ my $last = 0;
+ while (1) {
+ last if ! @start1;
+ my $i = shift @start1;
+ my $i2 = shift @start2;
+
+ $new .= substr($_[0], $last, $i - $last);
+
+ die "Unclosed tag" if ! @end1;
+ my $j = shift @end1;
+ my $j2 = shift @end2;
+
+ my $tag = substr($_[0], $i2, $j - $i2);
+ $new.= "($tag)";
+
+ $last = $j2;
+ }
+ return $last ? $new . substr($_[0], $last) : $_[0];
}
###----------------------------------------------------------------###
#print parse_grammar($str);
#print "---\n";
#print parse_index($str);
-die "parse_split didn't match" if parse_split($str) ne parse_match($str);
-die "parse_grammar didn't match" if parse_grammar($str) ne parse_match($str);
-die "parse_index didn't match" if parse_index($str) ne parse_match($str);
-die "parse_index2 didn't match" if parse_index2($str) ne parse_match($str);
+#print "---\n";
+#print parse_pos_array($str);
+#exit;
+die "parse_split didn't match" if parse_split($str) ne parse_match($str);
+die "parse_grammar didn't match" if parse_grammar($str) ne parse_match($str);
+die "parse_grammar2 didn't match" if parse_grammar2($str) ne parse_match($str);
+die "parse_index didn't match" if parse_index($str) ne parse_match($str);
+die "parse_index2 didn't match" if parse_index2($str) ne parse_match($str);
+die "parse_pos_array didn't match" if parse_pos_array($str) ne parse_match($str);
#exit;
### and run them
cmpthese timethese (-2, {
- index => sub { parse_index($str) },
- index2 => sub { parse_index2($str) },
- match => sub { parse_match($str) },
- split => sub { parse_split($str) },
- grammar => sub { parse_grammar($str) },
+ index => sub { parse_index($str) },
+ index2 => sub { parse_index2($str) },
+ match => sub { parse_match($str) },
+ split => sub { parse_split($str) },
+ grammar => sub { parse_grammar($str) },
+ grammar2 => sub { parse_grammar2($str) },
+ pos_array => sub { parse_pos_array($str) },
});
cmpthese (-2,{
cgi_ex => sub { my $t = CGI::Ex::Validate->validate($form, $val_hash_ce) },
data_val => sub { my $t = Data::FormValidator->check($form, $val_hash_df) },
- homegrown => sub { my $t = scalar keys %{ check_form($form) } },
+ homegrown => sub { my $t = check_form($form) },
},'auto');
cmpthese (-2,{
cgi_ex => sub { my $t = CGI::Ex::Validate->validate($form, $val_hash_ce)->as_hash },
data_val => sub { my $t = Data::FormValidator->check($form, $val_hash_df)->msgs },
- homegrown => sub { my $t = check_form($form) },
+ homegrown => sub { my $t = scalar keys %{ check_form($form) } },
},'auto');
### Home grown solution blows the others away - but lacks features
#
# Benchmark: running cgi_ex, data_val, homegrown for at least 2 CPU seconds...
-# cgi_ex: 2 wallclock secs ( 2.12 usr + 0.00 sys = 2.12 CPU) @ 1430.66/s (n=3033)
-# data_val: 2 wallclock secs ( 2.01 usr + 0.00 sys = 2.01 CPU) @ 2588.56/s (n=5203)
-# homegrown: 2 wallclock secs ( 2.19 usr + 0.01 sys = 2.20 CPU) @ 54733.18/s (n=120413)
+# cgi_ex: 2 wallclock secs ( 2.08 usr + 0.01 sys = 2.09 CPU) @ 2045.93/s (n=4276)
+# data_val: 2 wallclock secs ( 2.15 usr + 0.00 sys = 2.15 CPU) @ 3496.28/s (n=7517)
+# homegrown: 2 wallclock secs ( 2.09 usr + 0.01 sys = 2.10 CPU) @ 81919.52/s (n=172031)
# Rate cgi_ex data_val homegrown
-# cgi_ex 1431/s -- -45% -97%
-# data_val 2589/s 81% -- -95%
-# homegrown 54733/s 3726% 2014% --
+# cgi_ex 2046/s -- -41% -98%
+# data_val 3496/s 71% -- -96%
+# homegrown 81920/s 3904% 2243% --
# Benchmark: running cgi_ex, data_val, homegrown for at least 2 CPU seconds...
-# cgi_ex: 2 wallclock secs ( 2.10 usr + 0.00 sys = 2.10 CPU) @ 1218.57/s (n=2559)
-# data_val: 2 wallclock secs ( 2.14 usr + 0.00 sys = 2.14 CPU) @ 2092.99/s (n=4479)
-# homegrown: 2 wallclock secs ( 2.14 usr + 0.00 sys = 2.14 CPU) @ 56267.76/s (n=120413)
+# cgi_ex: 2 wallclock secs ( 2.11 usr + 0.00 sys = 2.11 CPU) @ 1696.68/s (n=3580)
+# data_val: 2 wallclock secs ( 2.04 usr + 0.00 sys = 2.04 CPU) @ 2845.10/s (n=5804)
+# homegrown: 2 wallclock secs ( 2.01 usr + 0.00 sys = 2.01 CPU) @ 83674.13/s (n=168185)
# Rate cgi_ex data_val homegrown
-# cgi_ex 1219/s -- -42% -98%
-# data_val 2093/s 72% -- -96%
-# homegrown 56268/s 4518% 2588% --
+# cgi_ex 1697/s -- -40% -98%
+# data_val 2845/s 68% -- -97%
+# homegrown 83674/s 4832% 2841% --
use Template;
use Template::Stash;
+use Template::Stash::XS;
use Text::Template;
+use HTML::Template;
+use HTML::Template::Expr;
+use HTML::Template::JIT;
use CGI::Ex::Dump qw(debug);
use CGI::Ex::Template;
+use CGI::Ex::Template::XS;
use POSIX qw(tmpnam);
use File::Path qw(mkpath rmtree);
-my $dir = tmpnam;
+my $dir = tmpnam;
+my $dir2 = "$dir.cache";
mkpath($dir);
-END {rmtree $dir};
+mkpath($dir2);
+END {rmtree $dir; rmtree $dir2};
my @dirs = ($dir);
my $form = {
###----------------------------------------------------------------###
-my $stash_w = {
- shell => {
- header => "This is a header",
- footer => "This is a footer",
- start => "<html>",
- end => "<end>",
- foo => $form->{'foo'},
- },
- a => {
- stuff => [qw(one two three four)],
- },
-};
-
my $stash_t = {
shell_header => "This is a header",
shell_footer => "This is a footer",
a_stuff => [qw(one two three four)],
};
+my $stash_ht = {
+ shell_header => "This is a header",
+ shell_footer => "This is a footer",
+ shell_start => "<html>",
+ shell_end => "<end>",
+ a_stuff => [map {{name => $_}} qw(one two three four)],
+};
+
$FOO::shell_header = $FOO::shell_footer = $FOO::shell_start = $FOO::shell_end = $FOO::a_stuff;
$FOO::shell_header = "This is a header";
$FOO::shell_footer = "This is a footer";
###----------------------------------------------------------------###
+### TT style template
-my $content_w = q{[shell.header]
-[shell.start]
-
-[if shell.foo q{
-This is some text.
-}]
-
-[loop i a.stuff.length q{[a.stuff]}]
-[form.pass_in_something]
-
-[shell.end]
-[shell.footer]
-};
-
-my $content_t = q{[% shell_header %]
+my $content_tt = q{[% shell_header %]
[% shell_start %]
[% IF foo %]
[% shell_footer %]
};
-my $content_h = q{<TMPL_VAR NAME=shell_header>
-[% shell_start %]
+if (open (my $fh, ">$dir/foo.tt")) {
+ print $fh $content_tt;
+ close $fh;
+}
-[% IF foo %]
+###----------------------------------------------------------------###
+### HTML::Template style
+
+my $content_ht = q{<TMPL_VAR NAME=shell_header>
+<TMPL_VAR NAME=shell_start>
+
+<TMPL_IF NAME=foo>
This is some text.
-[% END %]
+</TMPL_IF>
-[% FOREACH i IN a_stuff %][% i %][% END %]
-[% pass_in_something %]
+<TMPL_LOOP NAME=a_stuff><TMPL_VAR NAME=name></TMPL_LOOP>
+<TMPL_VAR NAME=pass_in_something>
-[% shell_end %]
-[% shell_footer %]
+<TMPL_VAR NAME=shell_end>
+<TMPL_VAR NAME=shell_footer>
};
-if (open (my $fh, ">$dir/foo.tt")) {
- print $fh $content_t;
+if (open (my $fh, ">$dir/foo.ht")) {
+ print $fh $content_ht;
close $fh;
}
+###----------------------------------------------------------------###
+### Text::Template style template
+
my $content_p = q{{$shell_header}
{$shell_start}
{$shell_footer}
};
-#my $wrap = WrapEx->new({
-# dirs => \@dirs,
-# W => $stash_w,
-# form => [$form],
-#});
+###----------------------------------------------------------------###
+### setup the objects
+
+my $tt = Template->new({
+ INCLUDE_PATH => \@dirs,
+ STASH => Template::Stash->new($stash_t),
+});
- my $tt = Template->new({
+my $ttx = Template->new({
INCLUDE_PATH => \@dirs,
- STASH => Template::Stash->new($stash_t),
+ STASH => Template::Stash::XS->new($stash_t),
});
my $ct = CGI::Ex::Template->new({
VARIABLES => $stash_t,
});
+my $ctx = CGI::Ex::Template::XS->new({
+ INCLUDE_PATH => \@dirs,
+ VARIABLES => $stash_t,
+});
+
my $pt = Text::Template->new(TYPE => 'STRING', SOURCE => $content_p, HASH => $form);
-###----------------------------------------------------------------###
-### make sure everything is ok
+my $ht = HTML::Template->new(type => 'scalarref', source => \$content_ht);
+$ht->param($stash_ht);
+$ht->param($form);
+
+my $hte = HTML::Template::Expr->new(type => 'scalarref', source => \$content_ht);
+$hte->param($stash_ht);
+$hte->param($form);
-#my $out_wr = $content_w;
-#$wrap->wrap(\$out_wr);
+my $ht_c = HTML::Template->new(type => 'filename', source => "foo.ht", cache => 1, path => \@dirs);
+$ht_c->param($stash_ht);
+$ht_c->param($form);
+
+my $ht_j = HTML::Template::JIT->new(filename => "foo.ht", path => \@dirs, jit_path => $dir2);
+$ht_j->param($stash_ht);
+$ht_j->param($form);
+
+###----------------------------------------------------------------###
+### make sure everything is ok by trying it once
my $out_tt = "";
-$tt->process(\$content_t, $form, \$out_tt);
+$tt->process(\$content_tt, $form, \$out_tt);
+
+my $out_ttx = "";
+$ttx->process(\$content_tt, $form, \$out_ttx);
my $out_ct = "";
-$ct->process(\$content_t, $form, \$out_ct);
+$ct->process(\$content_tt, $form, \$out_ct);
+
+my $out_ctx = "";
+$ctx->process(\$content_tt, $form, \$out_ctx);
my $out_c2 = "";
$ct->process('foo.tt', $form, \$out_c2);
my $out_c3 = '';
-$ct->process_simple(\$content_t, {%$stash_t, %$form}, \$out_c3);
+$ct->process_simple(\$content_tt, {%$stash_t, %$form}, \$out_c3);
my $out_pt = $pt->fill_in(PACKAGE => 'FOO', HASH => $form);
-if ($out_wr ne $out_tt) {
- debug $out_wr, $out_tt;
- die "Wrap didn't match tt";
-}
+my $out_ht = $ht->output;
+my $out_hte = $hte->output;
+my $out_htc = $ht_c->output;
+my $out_htj = $ht_j->output;
+
if ($out_ct ne $out_tt) {
debug $out_ct, $out_tt;
die "CGI::Ex::Template didn't match tt";
}
+if ($out_ctx ne $out_tt) {
+ debug $out_ctx, $out_tt;
+ die "CGI::Ex::Template::XS didn't match tt";
+}
+if ($out_ttx ne $out_tt) {
+ debug $out_ttx, $out_tt;
+ die "Template::Stash::XS didn't match tt";
+}
if ($out_c2 ne $out_tt) {
debug $out_c2, $out_tt;
die "CGI::Ex::Template from file didn't match tt";
debug $out_pt, $out_tt;
die "Text Template didn't match tt";
}
+if ($out_ht ne $out_tt) {
+ debug $out_ht, $out_tt;
+ die "HTML::Template didn't match tt";
+}
+if ($out_hte ne $out_tt) {
+ debug $out_hte, $out_tt;
+ die "HTML::Template::Expr didn't match tt";
+}
+if ($out_htc ne $out_tt) {
+ debug $out_htc, $out_tt;
+ die "HTML::Template::Expr didn't match tt";
+}
+if ($out_htj ne $out_tt) {
+ debug $out_htj, $out_tt;
+ die "HTML::Template::JIT didn't match tt";
+}
###----------------------------------------------------------------###
-cmpthese timethese (-2, {
-# wrap => sub {
-# my $out = $content_w;
-# $wrap->wrap(\$out);
-# },
- TemplateToolkit => sub {
+my $tests = {
+ TT_str => sub {
+ my $tt = Template->new({
+ INCLUDE_PATH => \@dirs,
+ STASH => Template::Stash->new($stash_t),
+ });
+ my $out = "";
+ $tt->process(\$content_tt, $form, \$out);
+ },
+ TT_mem => sub {
+ my $out = "";
+ $tt->process('foo.tt', $form, \$out);
+ },
+ TT_compile => sub {
+ my $tt = Template->new({
+ INCLUDE_PATH => \@dirs,
+ STASH => Template::Stash->new($stash_t),
+ COMPILE_DIR => $dir2,
+ });
my $out = "";
- $tt->process(\$content_t, $form, \$out);
+ $tt->process('foo.tt', $form, \$out);
},
- CET => sub {
+
+ TTX_str => sub {
+ my $tt = Template->new({
+ INCLUDE_PATH => \@dirs,
+ STASH => Template::Stash::XS->new($stash_t),
+ });
my $out = "";
- $ct->process(\$content_t, $form, \$out);
+ $tt->process(\$content_tt, $form, \$out);
+ },
+ TTX_mem => sub {
+ my $out = "";
+ $ttx->process('foo.tt', $form, \$out);
+ },
+ TTX_compile => sub {
+ my $tt = Template->new({
+ INCLUDE_PATH => \@dirs,
+ STASH => Template::Stash::XS->new($stash_t),
+ COMPILE_DIR => $dir2,
+ });
+ my $out = "";
+ $tt->process('foo.tt', $form, \$out);
+ },
+
+ CET_str => sub {
+ my $ct = CGI::Ex::Template->new({
+ INCLUDE_PATH => \@dirs,
+ VARIABLES => $stash_t,
+ });
+ my $out = "";
+ $ct->process(\$content_tt, $form, \$out);
},
CET_mem => sub {
my $out = "";
$ct->process('foo.tt', $form, \$out);
},
- CET_process_s => sub {
+ CET_compile => sub {
+ my $ct = CGI::Ex::Template->new({
+ INCLUDE_PATH => \@dirs,
+ VARIABLES => $stash_t,
+ COMPILE_DIR => $dir2,
+ });
my $out = '';
- $ct->process_simple(\$content_t, {%$stash_t, %$form}, \$out);
+ $ct->process('foo.tt', $form, \$out);
},
- CET_cache => sub {
- my $ct = CGI::Ex::Template->new({
+
+ CTX_str => sub {
+ my $ct = CGI::Ex::Template::XS->new({
INCLUDE_PATH => \@dirs,
- STASH => Template::Stash->new($stash_t),
- CACHE_DIR => $dir,
+ VARIABLES => $stash_t,
+ });
+ my $out = "";
+ $ct->process(\$content_tt, $form, \$out);
+ },
+ CTX_mem => sub {
+ my $out = "";
+ $ctx->process('foo.tt', $form, \$out);
+ },
+ CTX_compile => sub {
+ my $ct = CGI::Ex::Template::XS->new({
+ INCLUDE_PATH => \@dirs,
+ VARIABLES => $stash_t,
+ COMPILE_DIR => $dir2,
});
my $out = '';
- $ct->process('foo.tt', {%$stash_t, %$form}, \$out);
+ $ct->process('foo.tt', $form, \$out);
},
+
TextTemplate => sub {
+ my $pt = Text::Template->new(
+ TYPE => 'STRING',
+ SOURCE => $content_p,
+ HASH => $form);
my $out = $pt->fill_in(PACKAGE => 'FOO', HASH => $form);
},
- TextTemplate2 => sub {
- my $out = $pt->fill_in(PACKAGE => 'FOO', HASH => {%$stash_t, %$form});
+
+ HT_str => sub {
+ my $ht = HTML::Template->new(type => 'scalarref', source => \$content_ht);
+ $ht->param($stash_ht);
+ $ht->param($form);
+ my $out = $ht->output;
},
-});
+ HT_mem => sub {
+ my $ht = HTML::Template->new(type => 'filename', source => "foo.ht", path => \@dirs, cache => 1);
+ $ht->param($stash_ht);
+ $ht->param($form);
+ my $out = $ht->output;
+ },
+ HT_compile => sub {
+ my $ht = HTML::Template->new(type => 'filename', source => "foo.ht", file_cache => 1, path => \@dirs, file_cache_dir => $dir2);
+ $ht->param($stash_ht);
+ $ht->param($form);
+ my $out = $ht->output;
+ },
+
+ HTE_str => sub {
+ my $ht = HTML::Template::Expr->new(type => 'scalarref', source => \$content_ht);
+ $ht->param($stash_ht);
+ $ht->param($form);
+ my $out = $ht->output;
+ },
+ HTE_mem => sub {
+ my $ht = HTML::Template::Expr->new(type => 'filename', source => "foo.ht", path => \@dirs, cache => 1);
+ $ht->param($stash_ht);
+ $ht->param($form);
+ my $out = $ht->output;
+ },
+
+ HTJ_compile => sub {
+ my $ht = HTML::Template::JIT->new(filename => "foo.ht", path => \@dirs, jit_path => $dir2);
+ $ht->param($stash_ht);
+ $ht->param($form);
+ my $out = $ht->output;
+ },
+};
+
+
+my %mem_tests = map {($_ => $tests->{$_})} qw(TT_mem TTX_mem CET_mem HT_mem HTE_mem CTX_mem);
+my %cpl_tests = map {($_ => $tests->{$_})} qw(TT_compile TTX_compile CET_compile HT_compile HTJ_compile CTX_compile);
+my %str_tests = map {($_ => $tests->{$_})} qw(TT_str TTX_str CET_str HT_str HTE_str TextTemplate CTX_str);
+
+print "------------------------------------------------------------------------\n";
+print "From a string or scalarref tests\n";
+cmpthese timethese (-2, \%str_tests);
+
+print "------------------------------------------------------------------------\n";
+print "Compiled and cached on the file system tests\n";
+cmpthese timethese (-2, \%cpl_tests);
+
+print "------------------------------------------------------------------------\n";
+print "Cached in memory tests\n";
+cmpthese timethese (-2, \%mem_tests);
+
+print "------------------------------------------------------------------------\n";
+print "All variants together\n";
+cmpthese timethese (-2, $tests);
###----------------------------------------------------------------###
--- /dev/null
+------------------------------------------------------------------------
+From a string or scalarref tests
+Benchmark: running CET_str, CTX_str, HTE_str, HT_str, TTX_str, TT_str, TextTemplate for at least 2 CPU seconds...
+ CET_str: 2 wallclock secs ( 1.99 usr + 0.01 sys = 2.00 CPU) @ 1302.50/s (n=2605)
+ CTX_str: 2 wallclock secs ( 2.11 usr + 0.00 sys = 2.11 CPU) @ 1592.42/s (n=3360)
+ HTE_str: 3 wallclock secs ( 2.10 usr + 0.00 sys = 2.10 CPU) @ 894.76/s (n=1879)
+ HT_str: 2 wallclock secs ( 2.12 usr + 0.00 sys = 2.12 CPU) @ 1345.75/s (n=2853)
+ TTX_str: 3 wallclock secs ( 2.06 usr + 0.01 sys = 2.07 CPU) @ 295.17/s (n=611)
+ TT_str: 2 wallclock secs ( 2.08 usr + 0.00 sys = 2.08 CPU) @ 280.77/s (n=584)
+TextTemplate: 3 wallclock secs ( 2.21 usr + 0.00 sys = 2.21 CPU) @ 1653.85/s (n=3655)
+ Rate TT_str TTX_str HTE_str CET_str HT_str CTX_str TextTemplate
+TT_str 281/s -- -5% -69% -78% -79% -82% -83%
+TTX_str 295/s 5% -- -67% -77% -78% -81% -82%
+HTE_str 895/s 219% 203% -- -31% -34% -44% -46%
+CET_str 1302/s 364% 341% 46% -- -3% -18% -21%
+HT_str 1346/s 379% 356% 50% 3% -- -15% -19%
+CTX_str 1592/s 467% 439% 78% 22% 18% -- -4%
+TextTemplate 1654/s 489% 460% 85% 27% 23% 4% --
+------------------------------------------------------------------------
+Compiled and cached on the file system tests
+Benchmark: running CET_compile, CTX_compile, HTJ_compile, HT_compile, TTX_compile, TT_compile for at least 2 CPU seconds...
+CET_compile: 2 wallclock secs ( 2.05 usr + 0.04 sys = 2.09 CPU) @ 2157.89/s (n=4510)
+CTX_compile: 2 wallclock secs ( 2.03 usr + 0.10 sys = 2.13 CPU) @ 3132.39/s (n=6672)
+HTJ_compile: 3 wallclock secs ( 2.00 usr + 0.08 sys = 2.08 CPU) @ 5580.77/s (n=11608)
+HT_compile: 2 wallclock secs ( 2.05 usr + 0.06 sys = 2.11 CPU) @ 1792.42/s (n=3782)
+TTX_compile: 3 wallclock secs ( 1.96 usr + 0.05 sys = 2.01 CPU) @ 784.08/s (n=1576)
+TT_compile: 2 wallclock secs ( 2.02 usr + 0.05 sys = 2.07 CPU) @ 688.89/s (n=1426)
+ Rate TT_compile TTX_compile HT_compile CET_compile CTX_compile HTJ_compile
+TT_compile 689/s -- -12% -62% -68% -78% -88%
+TTX_compile 784/s 14% -- -56% -64% -75% -86%
+HT_compile 1792/s 160% 129% -- -17% -43% -68%
+CET_compile 2158/s 213% 175% 20% -- -31% -61%
+CTX_compile 3132/s 355% 299% 75% 45% -- -44%
+HTJ_compile 5581/s 710% 612% 211% 159% 78% --
+------------------------------------------------------------------------
+Cached in memory tests
+Benchmark: running CET_mem, CTX_mem, HTE_mem, HT_mem, TTX_mem, TT_mem for at least 2 CPU seconds...
+ CET_mem: 3 wallclock secs ( 2.07 usr + 0.03 sys = 2.10 CPU) @ 3409.05/s (n=7159)
+ CTX_mem: 2 wallclock secs ( 2.03 usr + 0.04 sys = 2.07 CPU) @ 6106.28/s (n=12640)
+ HTE_mem: 3 wallclock secs ( 2.08 usr + 0.02 sys = 2.10 CPU) @ 1358.57/s (n=2853)
+ HT_mem: 3 wallclock secs ( 2.08 usr + 0.02 sys = 2.10 CPU) @ 2456.67/s (n=5159)
+ TTX_mem: 3 wallclock secs ( 2.15 usr + 0.00 sys = 2.15 CPU) @ 3120.47/s (n=6709)
+ TT_mem: 1 wallclock secs ( 2.04 usr + 0.02 sys = 2.06 CPU) @ 2162.62/s (n=4455)
+ Rate HTE_mem TT_mem HT_mem TTX_mem CET_mem CTX_mem
+HTE_mem 1359/s -- -37% -45% -56% -60% -78%
+TT_mem 2163/s 59% -- -12% -31% -37% -65%
+HT_mem 2457/s 81% 14% -- -21% -28% -60%
+TTX_mem 3120/s 130% 44% 27% -- -8% -49%
+CET_mem 3409/s 151% 58% 39% 9% -- -44%
+CTX_mem 6106/s 349% 182% 149% 96% 79% --
+------------------------------------------------------------------------
+All variants together
+Benchmark: running CET_compile, CET_mem, CET_str, CTX_compile, CTX_mem, CTX_str, HTE_mem, HTE_str, HTJ_compile, HT_compile, HT_mem, HT_str, TTX_compile, TTX_mem, TTX_str, TT_compile, TT_mem, TT_str, TextTemplate for at least 2 CPU seconds...
+CET_compile: 3 wallclock secs ( 1.95 usr + 0.07 sys = 2.02 CPU) @ 2237.13/s (n=4519)
+ CET_mem: 2 wallclock secs ( 2.11 usr + 0.02 sys = 2.13 CPU) @ 3361.50/s (n=7160)
+ CET_str: 2 wallclock secs ( 2.02 usr + 0.00 sys = 2.02 CPU) @ 1287.62/s (n=2601)
+CTX_compile: 3 wallclock secs ( 1.99 usr + 0.08 sys = 2.07 CPU) @ 3098.55/s (n=6414)
+ CTX_mem: 2 wallclock secs ( 2.17 usr + 0.06 sys = 2.23 CPU) @ 6426.01/s (n=14330)
+ CTX_str: 3 wallclock secs ( 2.12 usr + 0.00 sys = 2.12 CPU) @ 1649.06/s (n=3496)
+ HTE_mem: 2 wallclock secs ( 2.01 usr + 0.02 sys = 2.03 CPU) @ 1427.09/s (n=2897)
+ HTE_str: 3 wallclock secs ( 2.18 usr + 0.00 sys = 2.18 CPU) @ 924.31/s (n=2015)
+HTJ_compile: 2 wallclock secs ( 2.06 usr + 0.08 sys = 2.14 CPU) @ 5424.30/s (n=11608)
+HT_compile: 3 wallclock secs ( 2.05 usr + 0.06 sys = 2.11 CPU) @ 1696.21/s (n=3579)
+ HT_mem: 3 wallclock secs ( 2.00 usr + 0.09 sys = 2.09 CPU) @ 2334.93/s (n=4880)
+ HT_str: 3 wallclock secs ( 2.00 usr + 0.00 sys = 2.00 CPU) @ 1293.00/s (n=2586)
+TTX_compile: 2 wallclock secs ( 2.12 usr + 0.05 sys = 2.17 CPU) @ 787.10/s (n=1708)
+ TTX_mem: 3 wallclock secs ( 2.07 usr + 0.00 sys = 2.07 CPU) @ 3098.55/s (n=6414)
+ TTX_str: 3 wallclock secs ( 2.36 usr + 0.00 sys = 2.36 CPU) @ 284.32/s (n=671)
+TT_compile: 3 wallclock secs ( 2.10 usr + 0.03 sys = 2.13 CPU) @ 669.48/s (n=1426)
+ TT_mem: 3 wallclock secs ( 2.08 usr + 0.01 sys = 2.09 CPU) @ 2041.15/s (n=4266)
+ TT_str: 2 wallclock secs ( 2.07 usr + 0.00 sys = 2.07 CPU) @ 284.06/s (n=588)
+TextTemplate: 3 wallclock secs ( 2.10 usr + 0.00 sys = 2.10 CPU) @ 1669.52/s (n=3506)
+ Rate TT_str TTX_st TT_co TTX_c HTE_s CET_s HT_st HTE_m CTX_s TextT HT_co TT_me CET_c HT_me CTX_c TTX_m CET_m HTJ_c CTX_mem
+TT_str 284/s -- -0% -58% -64% -69% -78% -78% -80% -83% -83% -83% -86% -87% -88% -91% -91% -92% -95% -96%
+TTX_str 284/s 0% -- -58% -64% -69% -78% -78% -80% -83% -83% -83% -86% -87% -88% -91% -91% -92% -95% -96%
+TT_compile 669/s 136% 135% -- -15% -28% -48% -48% -53% -59% -60% -61% -67% -70% -71% -78% -78% -80% -88% -90%
+TTX_compile 787/s 177% 177% 18% -- -15% -39% -39% -45% -52% -53% -54% -61% -65% -66% -75% -75% -77% -85% -88%
+HTE_str 924/s 225% 225% 38% 17% -- -28% -29% -35% -44% -45% -46% -55% -59% -60% -70% -70% -73% -83% -86%
+CET_str 1288/s 353% 353% 92% 64% 39% -- -0% -10% -22% -23% -24% -37% -42% -45% -58% -58% -62% -76% -80%
+HT_str 1293/s 355% 355% 93% 64% 40% 0% -- -9% -22% -23% -24% -37% -42% -45% -58% -58% -62% -76% -80%
+HTE_mem 1427/s 402% 402% 113% 81% 54% 11% 10% -- -13% -15% -16% -30% -36% -39% -54% -54% -58% -74% -78%
+CTX_str 1649/s 481% 480% 146% 110% 78% 28% 28% 16% -- -1% -3% -19% -26% -29% -47% -47% -51% -70% -74%
+TextTemplate 1670/s 488% 487% 149% 112% 81% 30% 29% 17% 1% -- -2% -18% -25% -28% -46% -46% -50% -69% -74%
+HT_compile 1696/s 497% 497% 153% 116% 84% 32% 31% 19% 3% 2% -- -17% -24% -27% -45% -45% -50% -69% -74%
+TT_mem 2041/s 619% 618% 205% 159% 121% 59% 58% 43% 24% 22% 20% -- -9% -13% -34% -34% -39% -62% -68%
+CET_compile 2237/s 688% 687% 234% 184% 142% 74% 73% 57% 36% 34% 32% 10% -- -4% -28% -28% -33% -59% -65%
+HT_mem 2335/s 722% 721% 249% 197% 153% 81% 81% 64% 42% 40% 38% 14% 4% -- -25% -25% -31% -57% -64%
+CTX_compile 3099/s 991% 990% 363% 294% 235% 141% 140% 117% 88% 86% 83% 52% 39% 33% -- -0% -8% -43% -52%
+TTX_mem 3099/s 991% 990% 363% 294% 235% 141% 140% 117% 88% 86% 83% 52% 39% 33% 0% -- -8% -43% -52%
+CET_mem 3362/s 1083% 1082% 402% 327% 264% 161% 160% 136% 104% 101% 98% 65% 50% 44% 8% 8% -- -38% -48%
+HTJ_compile 5424/s 1810% 1808% 710% 589% 487% 321% 320% 280% 229% 225% 220% 166% 142% 132% 75% 75% 61% -- -16%
+CTX_mem 6426/s 2162% 2160% 860% 716% 595% 399% 397% 350% 290% 285% 279% 215% 187% 175% 107% 107% 91% 18% --
=cut
use strict;
-use Test::More tests => 17;
+use Test::More tests => 5;
SKIP: {
-skip("Missing YAML.pm", 17) if ! eval { require 'YAML.pm' };
+skip("Missing YAML.pm", 5) if ! eval { require 'YAML.pm' };
use_ok('CGI::Ex::Validate');
ok(! $e);
-### three groups, some with validate_if's - using arrayref
-$v = '
-- group validate_if: foo
- bar:
- required: 1
-- group validate_if: hem
- haw: { required: 1 }
-- raspberry:
- required: 1
-';
-
-$e = validate({}, $v);
-ok($e);
-
-$e = validate({
- raspberry => 'tart',
-}, $v);
-ok(! $e);
-
-$e = validate({
- foo => 1,
- raspberry => 'tart',
-}, $v);
-ok($e);
-
-$e = validate({
- foo => 1,
- bar => 1,
- raspberry => 'tart',
-}, $v);
-ok(! $e);
-
-$e = validate({
- foo => 1,
- bar => 1,
- hem => 1,
- raspberry => 'tart',
-}, $v);
-ok($e);
-
-$e = validate({
- foo => 1,
- bar => 1,
- hem => 1,
- haw => 1,
- raspberry => 'tart',
-}, $v);
-ok(! $e);
-
-
-### three groups, some with validate_if's - using documents
-$v = '---
-group validate_if: foo
-bar:
- required: 1
----
-group validate_if: hem
-haw: { required: 1 }
----
-raspberry:
- required: 1
-';
-
-$e = validate({}, $v);
-ok($e);
-
-$e = validate({
- raspberry => 'tart',
-}, $v);
-ok(! $e);
-
-$e = validate({
- foo => 1,
- raspberry => 'tart',
-}, $v);
-ok($e);
-
-$e = validate({
- foo => 1,
- bar => 1,
- raspberry => 'tart',
-}, $v);
-ok(! $e);
-
-$e = validate({
- foo => 1,
- bar => 1,
- hem => 1,
- raspberry => 'tart',
-}, $v);
-ok($e);
-
-$e = validate({
- foo => 1,
- bar => 1,
- hem => 1,
- haw => 1,
- raspberry => 'tart',
-}, $v);
-ok(! $e);
-
-} # end of SKIP
+};
=cut
use strict;
-use Test::More tests => 21;
+use Test::More tests => 13;
use_ok('CGI::Ex::Validate');
###----------------------------------------------------------------###
### test single group for extra fields
-$v = [
-{
- 'general no_extra_fields' => 'all',
+$v = {
+ 'group no_extra_fields' => 1,
foo => {max_len => 10},
-},
-];
+};
$e = validate({}, $v);
ok(! $e);
### test on failed validate if
-$v = [
-{
- 'general no_extra_fields' => 'all',
+$v = {
+ 'group no_extra_fields' => 1,
'group validate_if' => 'baz',
foo => {max_len => 10},
-},
-];
+};
$e = validate({}, $v);
ok(! $e);
ok(! $e);
### test on successful validate if
-$v = [
-{
- 'general no_extra_fields' => 'all',
+$v = {
+ 'group no_extra_fields' => 1,
'group validate_if' => 'baz',
foo => {max_len => 10},
baz => {max_len => 10},
-},
-];
+};
$e = validate({baz => 1}, $v);
ok(! $e);
$e = validate({baz => 1, bar => "bar"}, $v);
ok($e);
-### test on multiple groups, some with validate if
-$v = [
-{
- 'general no_extra_fields' => 'all',
- 'group validate_if' => 'baz',
- foo => {max_len => 10},
- baz => {max_len => 10},
-},
-{
- 'group validate_if' => 'hem',
- haw => {max_len => 10},
-},
-];
-
-$e = validate({haw => 1, baz => 1}, $v);
-ok(! $e);
-
-$e = validate({haw => 1, baz => 1, foo => "foo"}, $v);
-ok(! $e);
-
-$e = validate({haw => 1, baz => 1, foo => "foo", bar => "bar"}, $v);
-ok($e);
-
-$e = validate({haw => 1, baz => 1, bar => "bar"}, $v);
-ok($e);
-
-
-### test on multiple groups, some with validate if
-$v = [
-{
- 'general no_extra_fields' => 'used',
- 'group validate_if' => 'baz',
- foo => {max_len => 10},
- baz => {max_len => 10},
-},
-{
- 'group validate_if' => 'hem',
- haw => {max_len => 10},
-},
-];
-
-$e = validate({haw => 1, baz => 1}, $v);
-ok($e);
-
-$e = validate({haw => 1, baz => 1, foo => "foo"}, $v);
-ok($e);
-
-$e = validate({haw => 1, baz => 1, foo => "foo", bar => "bar"}, $v);
-ok($e);
-
-$e = validate({haw => 1, baz => 1, bar => "bar"}, $v);
-ok($e);
###----------------------------------------------------------------###
-$v = [
-{
+$v = {
foo => {
max_len => 10,
replace => 's/[^\d]//g',
},
-},
-];
+};
$e = validate({
foo => '123-456-7890',
}, $v);
-ok(! $e);
+ok(! $e, "Didn't get error");
my $form = {
};
$e = validate($form, $v);
-ok(! $e && $form->{key1} eq 'Bunch of characters');
+ok(! $e && $form->{key1} eq 'Bunch of characters', "No error and key1 updated");
$v = {
key2 => {
};
$e = validate($form, $v);
-ok(! $e && $form->{key2} eq '(123) 456-7890');
-
+ok(! $e && $form->{key2} eq '(123) 456-7890', "No error and phone updated");
$v = {
key2 => {
};
$e = validate($form, $v);
-ok($e && $form->{key2} eq '');
+ok($e && $form->{key2} eq '', "Error with all replaced");
=cut
use strict;
-use Test::More tests => 24;
+use Test::More tests => 2;
use_ok('CGI::Ex::Conf');
-my $dir = __FILE__;
-$dir =~ tr|\\|/|; # should probably use File::Spec
-$dir =~ s|[^/]+$|../samples| || die "Couldn't determine dir";
-$dir =~ s|^t/|./t/|; # to satisfy conf
-
-my $obj = CGI::Ex::Conf->new({
- paths => ["$dir/conf_path_1", "$dir/conf_path_3"],
-});
-
-### most test for the reading of files
-### are actually performed in the validation tests
-
+my $obj = CGI::Ex::Conf->new;
ok($obj);
-my $hash = $obj->read('apples.pl');
-ok($hash);
-ok($hash->{quantity});
-
-$hash = $obj->read('apples.pl');
-ok($hash);
-ok($hash->{quantity});
-
-
-local $CGI::Ex::Conf::DIRECTIVE = 'FIRST';
-$hash = $obj->read('apples.pl');
-ok($hash);
-ok($hash->{quantity} == 20);
-ok($hash->{foo} eq 'file1');
-
-local $CGI::Ex::Conf::DIRECTIVE = 'LAST';
-$hash = $obj->read('apples.pl');
-ok($hash);
-ok($hash->{quantity} == 30);
-ok($hash->{foo} eq 'file2');
-
-$hash = $obj->read('apples.pl', {directive => 'MERGE'});
-ok($hash);
-ok($hash->{quantity} == 30);
-ok($hash->{foo} eq 'file1'); # has immutable value
-
-
-local $obj->{directive} = 'FIRST';
-$hash = $obj->read('oranges.pl');
-ok($hash);
-ok($hash->{quantity} == 20);
-ok($hash->{foo} eq 'file1');
-
-local $obj->{directive} = 'LAST';
-$hash = $obj->read('oranges.pl');
-ok($hash);
-ok($hash->{quantity} == 30);
-ok($hash->{foo} eq 'file2');
-
-local $obj->{directive} = 'MERGE';
-$hash = $obj->read('oranges.pl');
-ok($hash);
-ok($hash->{quantity} == 20); # has immutable key so all values are immutable
-ok($hash->{foo} eq 'file1'); # has immutable key so all values are immutable
-
-
+### TODO - re-enable more fileside tests
use vars qw($module $is_tt);
BEGIN {
- $module = 'CGI::Ex::Template'; #real 0m1.113s #user 0m0.416s #sys 0m0.016s
-# $module = 'Template'; #real 0m3.022s #user 0m1.168s #sys 0m0.024s
+ $module = 'CGI::Ex::Template'; #real 0m0.885s #user 0m0.432s #sys 0m0.004s
+# $module = 'Template'; #real 0m2.133s #user 0m1.108s #sys 0m0.024s
$is_tt = $module eq 'Template';
};
use strict;
-use Test::More tests => ! $is_tt ? 662 : 519;
+use Test::More tests => ! $is_tt ? 740 : 579;
use Data::Dumper qw(Dumper);
use constant test_taint => 0 && eval { require Taint::Runtime };
my $vars = shift;
my $obj = shift || $module->new(@{ $vars->{tt_config} || [] }); # new object each time
my $out = '';
+ my $line = (caller)[2];
Taint::Runtime::taint(\$str) if test_taint;
$obj->process(\$str, $vars, \$out);
my $ok = ref($test) ? $out =~ $test : $out eq $test;
- ok($ok, "\"$str\" => \"$out\"" . ($ok ? '' : " - should've been \"$test\""));
- my $line = (caller)[2];
+ ok($ok, "Line $line \"$str\" => \"$out\"" . ($ok ? '' : " - should've been \"$test\""));
warn "# process_ok called at line $line.\n" if ! $ok;
print $obj->error if ! $ok && $obj->can('error');
print Dumper $obj->parse_tree(\$str) if ! $ok && $obj->can('parse_tree');
exit if ! $ok;
+ return $obj;
}
###----------------------------------------------------------------###
}
my $obj = Foo2->new;
-
+my $vars;
###----------------------------------------------------------------###
-### variable GETting
+print "### GET ##############################################################\n";
process_ok("[% foo %]" => "");
process_ok("[% foo %]" => "7", {foo => 7});
process_ok("[% \"hi \${foo}\" %]" => 'hi 7', {foo => 7});
process_ok("[% 'hi \$foo' %]" => 'hi $foo', {foo => 7});
process_ok("[% 'hi \${foo}' %]" => 'hi ${foo}', {foo => 7});
+process_ok("[% 7 %]" => 7);
+process_ok("[% -7 %]" => -7);
process_ok("[% \"hi \${foo.seven}\" %]" => 'hi 7', {foo => $obj});
process_ok("[% \"hi \${foo.echo(7)}\" %]" => 'hi 7', {foo => $obj});
process_ok('[% [0..10].${ 2.3 } %]' => '2') if ! $is_tt;
###----------------------------------------------------------------###
-### variable SETting
+print "### SET ##############################################################\n";
process_ok("[% SET foo bar %][% foo %]" => '');
process_ok("[% SET foo = 1 %][% foo %]" => '1');
process_ok("[% SET foo = [-10..-1] %][% foo.6 %]" => -4);
process_ok("[% SET foo = [1..10, 21..30] %][% foo.12 %]" => 23) if ! $is_tt;
process_ok("[% SET foo = [..100] bar = 7 %][% bar %][% foo.0 %]" => '');
-process_ok("[% SET foo = [100..] bar = 7 %][% bar %][% foo.0 %]" => 7) if ! $is_tt;
+process_ok("[% SET foo = [100..] bar = 7 %][% bar %][% foo.0 %]" => '');
process_ok("[% SET foo = ['a'..'z'] %][% foo.6 %]" => 'g');
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 ; 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" %]|[% (b = a) %]|[% a %]|[% b %]' => '|a|a|a');
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("[% a = 1 a = a + 2 a %]" => 3) if ! $is_tt;
###----------------------------------------------------------------###
-### Reserved words
+print "### reserved words ###################################################\n";
-my $vars = {
+$vars = {
GET => 'named_get',
get => 'lower_named_get',
named_get => 'value of named_get',
process_ok("[% BLOCK foo %]hi[% END %][% PROCESS foo IF GET %]" => 'hi', $vars) if ! $is_tt;
###----------------------------------------------------------------###
-### CALL and DEFAULT
+print "### CALL / DEFAULT ###################################################\n";
process_ok("[% DEFAULT foo = 7 %][% foo %]" => 7);
process_ok("[% SET foo = 5 %][% DEFAULT foo = 7 %][% foo %]" => 5);
ok($t == 3, "CALL method actually called var");
###----------------------------------------------------------------###
-### virtual method tests
+print "### scalar vmethods ##################################################\n";
-# scalar vmethods
process_ok("[% n.0 %]" => '7', {n => 7}) if ! $is_tt;
process_ok("[% n.as %]" => '7', {n => 7}) if ! $is_tt;
process_ok("[% n.as('%02d') %]" => '07', {n => 7}) if ! $is_tt;
process_ok("[% n.split(u,2).join('|') %]" => "a| b c", {n => "a b c", u => undef}) if $is_tt;
process_ok("[% n.split('/').join('|') %]" => "a|b|c", {n => "a/b/c"});
process_ok("[% n.split('/', 2).join('|') %]" => "a|b/c", {n => "a/b/c"});
-process_ok("[% n.stderr %]" => "", {n => "# testing stderr ... ok\n"});
+process_ok("[% n.stderr %]" => "", {n => "# testing stderr ... ok\r"});
process_ok("[% n|trim %]" => "a b", {n => ' a b '}); # TT2 filter
process_ok("[% n|ucfirst %]" => 'Foo', {n => "foo"}); # TT2 filter
process_ok("[% n|upper %]" => 'FOO', {n => "foo"}); # TT2 filter
process_ok("[% n|uri %]" => 'a%20b', {n => "a b"}); # TT2 filter
-# list vmethods
+###----------------------------------------------------------------###
+print "### list vmethods ####################################################\n";
+
process_ok("[% a.as %]" => '2 3', {a => [2,3]}) if ! $is_tt;
process_ok("[% a.as('%02d') %]" => '02 03', {a => [2,3]}) if ! $is_tt;
process_ok("[% a.as('%02d',' ') %]" => '02 03', {a => [2,3]}) if ! $is_tt;
process_ok("[% a.unique.join %]" => '2 3', {a => [2,3,3,3,2]});
process_ok("[% a.unshift(3) %][% a.join %]" => '3 2 3', {a => [2, 3]});
-# hash vmethods
+###----------------------------------------------------------------###
+print "### hash vmethods ####################################################\n";
+
process_ok("[% h.as %]" => "b\tB\nc\tC", {h => {b => "B", c => "C"}}) if ! $is_tt;
process_ok("[% h.as('%s => %s') %]" => "b => B\nc => C", {h => {b => "B", c => "C"}}) if ! $is_tt;
process_ok("[% h.as('%s => %s', '|') %]" => "b => B|c => C", {h => {b => "B", c => "C"}}) if ! $is_tt;
process_ok("[% h.values.sort.join %]" => "1 2", {h => {a => 1, b=> 2}});
###----------------------------------------------------------------###
-### more virtual methods / filters
+print "### more virtual methods / filters ###################################\n";
process_ok("[% [0 .. 10].reverse.1 %]" => 9) if ! $is_tt;
process_ok("[% {a => 'A'}.a %]" => 'A') if ! $is_tt;
process_ok('[% {1=>2,3=>4}.fmt("%*s:%*s", "|", 3, 3) %]' => ' 1: 2| 3: 4') if ! $is_tt;
###----------------------------------------------------------------###
-### virtual objects
+print "### virtual objects ##################################################\n";
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 => 1, b => 2} | Hash.keys | List.join(", ") %]' => 'a, b') if ! $is_tt;
###----------------------------------------------------------------###
-### chomping
+print "### chomping #########################################################\n";
process_ok(" [% foo %]" => ' ');
process_ok(" [%- foo %]" => '');
process_ok("[% foo -%]\n\n\n" => "\n\n");
process_ok("[% foo -%] \n " => ' ');
-
###----------------------------------------------------------------###
-### concat
+print "### string operators #################################################\n";
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
+print "### math operators ###################################################\n";
process_ok("[% 1 + 2 %]" => 3);
process_ok("[% 1 + 2 + 3 %]" => 6);
process_ok('[% --a FOR [1..3] %]' => '-1-2-3') if ! $is_tt;
###----------------------------------------------------------------###
-### boolean operations
+print "### boolean operators ################################################\n";
process_ok("[% 5 && 6 %]" => 6);
process_ok("[% 5 || 6 %]" => 5);
process_ok("[% 0 ? 1 ? 1 + 2 * 3 : 1 + 2 * 4 : 1 + 2 * 5 %]" => '11');
###----------------------------------------------------------------###
-### blocks
+print "### BLOCK / PROCESS / INCLUDE#########################################\n";
process_ok("[% PROCESS foo %]" => '');
process_ok("[% BLOCK foo %]" => '');
process_ok("[% BLOCK foo %]hi [% one %] there[% END %][% INCLUDE foo one = 'two' %][% one %]" => 'hi two there');
###----------------------------------------------------------------###
-### if/unless/elsif/else
+print "### IF / UNLESS / ELSIF / ELSE #######################################\n";
process_ok("[% IF 1 %]Yes[% END %]" => 'Yes');
process_ok("[% IF 0 %]Yes[% END %]" => '');
process_ok("[% UNLESS 1 %]Yes[% ELSIF 0 %]No[% ELSE %]hmm[% END %]" => 'hmm');
###----------------------------------------------------------------###
-### comments
+print "### comments #########################################################\n";
process_ok("[%# one %]" => '', {one => 'ONE'});
process_ok("[%#\n one %]" => '', {one => 'ONE'});
process_ok("[%# BLOCK one %]two[% END %]three" => '');
###----------------------------------------------------------------###
-### foreach, next, last
+print "### FOREACH / NEXT / LAST ############################################\n";
process_ok("[% FOREACH foo %]" => '');
process_ok("[% FOREACH foo %][% END %]" => '');
process_ok("[% FOREACH i = [1..3] %][% loop.size %][% END %][% loop.size %]" => '3331') if $is_tt;
###----------------------------------------------------------------###
-### while
+print "### WHILE ############################################################\n";
process_ok("[% WHILE foo %]" => '');
process_ok("[% WHILE foo %][% END %]" => '');
process_ok("[% f = 10 a = 2; WHILE (a=f); f = f - 1 ; f ; a=3; END ; a%]" => '98765432100');
###----------------------------------------------------------------###
-### stop, return, clear
+print "### STOP / RETURN / CLEAR ############################################\n";
process_ok("[% STOP %]" => '');
process_ok("One[% STOP %]Two" => 'One');
process_ok("[% FOREACH f = [1..3] %][% IF loop.last %][% CLEAR %][% END %][% f %][% END %]" => '3');
###----------------------------------------------------------------###
-### multiple-directives
+print "### multiple statements in same tag ##################################\n";
process_ok("[% GET foo; GET foo %]" => '11', {foo => 1});
process_ok('[% FOREACH f = [1..3]; 1; END %]' => '111');
process_ok('[% FOREACH f = [1..3]; f + 1; END %]' => '234');
###----------------------------------------------------------------###
-### post opererator
+print "### post opererative directives ######################################\n";
process_ok("[% GET foo IF 1 %]" => '1', {foo => 1});
process_ok("[% f FOREACH f = [1..3] %]" => '123');
process_ok("[% BLOCK bar %][% foo %][% foo = foo - 1 %][% END %][% PROCESS bar WHILE foo %]" => '321', {foo => 3});
###----------------------------------------------------------------###
-### capturing
+print "### capturing ########################################################\n";
process_ok("[% foo = BLOCK %]Hi[% END %][% foo %][% foo %]" => 'HiHi');
process_ok("[% BLOCK foo %]Hi[% END %][% bar = PROCESS foo %]-[% bar %]" => '-Hi');
process_ok("[% foo = IF 1 %]Hi[% END %][% foo %]" => 'Hi');
###----------------------------------------------------------------###
-### tags
+print "### TAGS #############################################################\n";
+
+process_ok("[% TAGS asp %]<% 1 + 2 %>" => 3);
+process_ok("[% TAGS default %][% 1 + 2 %]" => 3);
+process_ok("[% TAGS html %]<!-- 1 + 2 -->" => '3');
+process_ok("[% TAGS mason %]<% 1 + 2 >" => 3);
+process_ok("[% TAGS metatext %]%% 1 + 2 %%" => 3);
+process_ok("[% TAGS php %]<? 1 + 2 ?>" => 3);
+process_ok("[% TAGS star %][* 1 + 2 *]" => 3);
+process_ok("[% TAGS template1 %][% 1 + 2 %]" => 3);
+process_ok("[% TAGS template1 %]%% 1 + 2 %%" => 3);
-process_ok("[% TAGS html %]<!-- 1 + 2 -->" => '3');
-process_ok("[% TAGS <!-- --> %]<!-- 1 + 2 -->" => '3');
process_ok("[% TAGS html %] <!--- 1 + 2 -->" => '3');
process_ok("[% TAGS html %]<!-- 1 + 2 --->" => '3') if ! $is_tt;
process_ok("[% TAGS html %]<!-- 1 + 2 --->\n" => '3');
+process_ok("[% BLOCK foo %][% TAGS html %]<!-- 1 + 2 --><!-- END --><!-- PROCESS foo --> <!-- 1 + 2 -->" => '3 3');
process_ok("[% BLOCK foo %][% TAGS html %]<!-- 1 + 2 -->[% END %][% PROCESS foo %] [% 1 + 2 %]" => '');
+process_ok("[% TAGS <!-- --> %]<!-- 1 + 2 -->" => '3');
+
+process_ok("[% TAGS [<] [>] %][<] 1 + 2 [>]" => 3);
+process_ok("[% TAGS [<] [>] unquoted %]< 1 + 2 >" => 3) if ! $is_tt;
+process_ok("[% TAGS ** ** %]** 1 + 2 **" => 3);
+process_ok("[% TAGS ** ** quoted %]** 1 + 2 **" => 3);
+process_ok("[% TAGS ** ** unquoted %]** 1 + 2 **" => "") if ! $is_tt;
+
###----------------------------------------------------------------###
-### switch
+print "### SWITCH / CASE ####################################################\n";
process_ok("[% SWITCH 1 %][% END %]hi" => 'hi');
process_ok("[% SWITCH 1 %][% CASE %]bar[% END %]hi" => 'barhi');
process_ok("[% SWITCH '1.0' %][% CASE [1..10] %]bar[% END %]hi" => 'barhi') if ! $is_tt;
###----------------------------------------------------------------###
-### try/throw/catch/final
+print "### TRY / THROW / CATCH / FINAL ######################################\n";
process_ok("[% TRY %][% END %]hi" => 'hi');
process_ok("[% TRY %]Foo[% END %]hi" => 'Foohi');
process_ok("[% TRY %][% THROW foo %][% CATCH %][% error.info %][% END %]" => 'foo');
###----------------------------------------------------------------###
-### named args
+print "### named args #######################################################\n";
process_ok("[% foo(bar = 'one', baz = 'two') %]" => "baronebaztwo",
{foo=>sub{my $n=$_[-1];join('',map{"$_$n->{$_}"} sort keys %$n)}});
{foo=>sub{my $n=$_[-1];join('',map{"$_$n->{$_}"} sort keys %$n)}});
###----------------------------------------------------------------###
-### use
+print "### USE ##############################################################\n";
my @config_p = (PLUGIN_BASE => 'MyTestPlugin', LOAD_PERL => 1);
process_ok("[% USE son_of_gun_that_does_not_exist %]one" => '', {tt_config => \@config_p});
process_ok("[% USE Foo %]one" => 'one', {tt_config => \@config_p});
###----------------------------------------------------------------###
-### macro
+print "### MACRO ############################################################\n";
process_ok("[% MACRO foo PROCESS bar %][% BLOCK bar %]Hi[% END %][% foo %]" => 'Hi');
process_ok("[% MACRO foo BLOCK %]Hi[% END %][% foo %]" => 'Hi');
process_ok("[%n=1%][% MACRO foo BLOCK %]Hi[% n = 2%][% END %][% foo %][%n%]" => 'Hi1');
process_ok("[% MACRO foo(n) FOREACH i=[1..n] %][% i %][% END %][% foo(3) %]" => '123');
+process_ok('[% MACRO f BLOCK %]>[% TRY; f ; CATCH ; "caught" ; END %][% END %][% f %]' => '>>>caught', {tt_config => [MAX_MACRO_RECURSE => 3]}) if ! $is_tt;
+
###----------------------------------------------------------------###
-### debug;
+print "### DEBUG ############################################################\n";
process_ok("\n\n[% one %]" => "\n\n\n## input text line 3 : [% one %] ##\nONE", {one=>'ONE', tt_config => ['DEBUG' => 8]});
process_ok("[% one %]" => "\n## input text line 1 : [% one %] ##\nONE", {one=>'ONE', tt_config => ['DEBUG' => 8]});
process_ok("[% TRY %][% abc.def %][% CATCH %][% error %][% END %]" => "undef error - def is undefined\n", {abc => {}, tt_config => ['DEBUG' => 2]});
###----------------------------------------------------------------###
-### constants
+print "### constants ########################################################\n";
my @config_c = (
CONSTANTS => {
bam => 'bar',
},
);
-process_ok("[% constants.harry %]" => 'do_this_once', {tt_config => \@config_c});
+process_ok("[% constants.harry %]" => 'do_this_once', {constants => {harry => 'foo'}, tt_config => \@config_c});
process_ok("[% constants.harry.length %]" => '12', {tt_config => \@config_c});
process_ok("[% SET constants.something = 1 %][% constants.something %]one" => '1one', {tt_config => \@config_c});
process_ok("[% SET constants.harry = 1 %][% constants.harry %]one" => 'do_this_onceone', {tt_config => \@config_c});
process_ok("[% constants.foo.\$bam.\${constants.bing} %]" => '42', {tt_config => [@config_c]}) if ! $is_tt;
process_ok("[% bam = 'somethingelse' %][% constants.foo.\$bam.\${constants.bing} %]" => '42', {tt_config => [@config_c]}) if ! $is_tt;
+process_ok('[% constants.${"harry"} %]' => 'do_this_once', {constants => {harry => 'foo'}, tt_config => \@config_c});
+process_ok('[% ${"constants"}.harry %]' => 'foo', {constants => {harry => 'foo'}, tt_config => \@config_c}) if ! $is_tt;
+process_ok('[% ${"constants"}.harry %]' => 'do_this_once', {constants => {harry => 'foo'}, tt_config => \@config_c}) if $is_tt;
+process_ok('[% ${"con${\\"s\\"}tants"}.harry %]' => 'foo', {constants => {harry => 'foo'}, tt_config => \@config_c}) if ! $is_tt;
+
###----------------------------------------------------------------###
-### interpolate / anycase / trim
+print "### INTERPOLATE / ANYCASE / TRIM #####################################\n";
process_ok("Foo \$one Bar" => 'Foo ONE Bar', {one => 'ONE', tt_config => ['INTERPOLATE' => 1]});
process_ok("[% PERL %] my \$n=7; print \$n [% END %]" => '7', {tt_config => ['INTERPOLATE' => 1, 'EVAL_PERL' => 1]});
process_ok("[% GET %]" => '', {GET => 'ONE'});
process_ok("[% GET GET %]" => 'ONE', {GET => 'ONE'}) if ! $is_tt;
+process_ok("[% get one %]" => 'ONE', {one => 'ONE', tt_config => ['ANYCASE' => 1]});
+process_ok("[% get %]" => '', {get => 'ONE', tt_config => ['ANYCASE' => 1]});
+process_ok("[% get get %]" => 'ONE', {get => 'ONE', tt_config => ['ANYCASE' => 1]}) if ! $is_tt;
process_ok("[% BLOCK foo %]\nhi\n[% END %][% PROCESS foo %]" => "\nhi\n");
process_ok("[% BLOCK foo %]\nhi[% END %][% PROCESS foo %]" => "hi", {tt_config => [TRIM => 1]});
process_ok("A[% TRY %]\nhi\n[% END %]" => "A\nhi", {tt_config => [TRIM => 1]});
###----------------------------------------------------------------###
-### perl
+print "### V1DOLLAR #########################################################\n";
+
+process_ok('[% a %]|[% $a %]|[% ${ a } %]|[% ${ "a" } %]' => 'A|bar|bar|A', {a => 'A', A => 'bar'});
+process_ok('[% a %]|[% $a %]|[% ${ a } %]|[% ${ "a" } %]' => 'A|A|bar|A', {a => 'A', A => 'bar', tt_config => [V1DOLLAR => 1]});
+
+$vars = {a => {b => {c=>'Cb'}, B => {c=>'CB'}}, b => 'B', Cb => 'bar', CB => 'Bar'};
+process_ok('[% a.b.c %]|[% $a.b.c %]|[% a.$b.c %]|[% ${ a.b.c } %]' => 'Cb||CB|bar', $vars);
+process_ok('[% a.b.c %]|[% $a.b.c %]|[% a.$b.c %]|[% ${ a.b.c } %]' => 'Cb|Cb|Cb|bar', {%$vars, tt_config => [V1DOLLAR => 1]});
+
+process_ok('[% "$a" %]|$a|[% "${a}" %]|${a}' => 'A|$a|A|${a}', {a => 'A', A => 'bar'});
+process_ok('[% "$a" %]|$a|[% "${a}" %]|${a}' => 'A|$a|A|${a}', {a => 'A', A => 'bar', tt_config => [V1DOLLAR => 1]});
+process_ok('[% "$a" %]|$a|[% "${a}" %]|${a}' => 'A|A|A|A', {a => 'A', A => 'bar', tt_config => [INTERPOLATE => 1]});
+process_ok('[% "$a" %]|$a|[% "${a}" %]|${a}' => 'A|A|A|A', {a => 'A', A => 'bar', tt_config => [V1DOLLAR => 1, INTERPOLATE => 1]});
+
+process_ok('[% constants.a %]|[% $constants.a %]|[% constants.$a %]' => 'A|A|A', {tt_config => [V1DOLLAR => 1, CONSTANTS => {a => 'A'}]});
+
+###----------------------------------------------------------------###
+print "### configuration ####################################################\n";
+
+process_ok('[% a = 7 %]$a' => 7, {tt_config => ['INTERPOLATE' => 1]});
+process_ok('[% a = 7 %]$a' => 7, {tt_config => ['interpolate' => 1]}) if ! $is_tt;
+
+###----------------------------------------------------------------###
+print "### PERL #############################################################\n";
process_ok("[% TRY %][% PERL %][% END %][% CATCH ; error; END %]" => 'perl error - EVAL_PERL not set');
process_ok("[% PERL %] print \"[% one %]\" [% END %]" => 'ONE', {one => 'ONE', tt_config => ['EVAL_PERL' => 1]});
process_ok("[% PERL %] print \$stash->set('a.b.c', 7) [% END %][% a.b.c %]" => '77', {tt_config => ['EVAL_PERL' => 1]});
###----------------------------------------------------------------###
-### recursion prevention
+print "### recursion prevention #############################################\n";
process_ok("[% BLOCK foo %][% PROCESS bar %][% END %][% BLOCK bar %][% PROCESS foo %][% END %][% PROCESS foo %]" => '') if ! $is_tt;
###----------------------------------------------------------------###
-### META
+print "### META #############################################################\n";
process_ok("[% template.name %]" => 'input text');
process_ok("[% META foo = 'bar' %][% template.foo %]" => 'bar');
process_ok("[% META foo = 'bar' %][% component.foo %]" => 'bar');
+
+###----------------------------------------------------------------###
+print "### references #######################################################\n";
+
+process_ok("[% a=3; b=\\a; b; a %]" => 33);
+process_ok("[% a=3; b=\\a; a=7; b; a %]" => 77);
+
+process_ok("[% a={}; a.1=7; b=\\a.1; b; a.1 %]" => '77');
+process_ok("[% a={}; a.1=7; b=\\a.20; a.20=7; b; a.20 %]" => '77');
+
+process_ok("[% a=[]; a.1=7; b=\\a.1; b; a.1 %]" => '77');
+process_ok("[% a=[]; a.1=7; b=\\a.20; a.20=7; b; a.20 %]" => '77');
+
+process_ok("[% \\a %]" => qr/^CODE/, {a => sub { return "a sub [@_]" } });
+process_ok("[% b=\\a; b %]" => 'a sub []', {a => sub { return "a sub [@_]" } });
+process_ok("[% b=\\a(1); b %]" => 'a sub [1]', {a => sub { return "a sub [@_]" } });
+process_ok("[% b=\\a; b(2) %]" => 'a sub [2]', {a => sub { return "a sub [@_]" } });
+process_ok("[% b=\\a(1); b(2) %]" => 'a sub [1 2]', {a => sub { return "a sub [@_]" } });
+process_ok("[% f=\\j.k; j.k=7; f %]" => '7', {j => {k => 3}});
+
+process_ok('[% a = "a" ; f = {a=>"A",b=>"B"} ; foo = \f.$a ; foo %]' => 'A');
+process_ok('[% a = "a" ; f = {a=>"A",b=>"B"} ; foo = \f.$a ; a = "b" ; foo %]' => 'A');
+process_ok('[% a = "ab" ; f = "abcd"; foo = \f.replace(a, "-AB-") ; a = "cd"; foo %]' => '-AB-cd');
+process_ok('[% a = "ab" ; f = "abcd"; foo = \f.replace(a, "-AB-").replace("-AB-", "*") ; a = "cd"; foo %]' => '*cd');
+
+process_ok('[% a = "ab" ; f = "abcd"; foo = \f.replace(a, "-AB-") ; f = "ab"; foo %]' => '-AB-cd');
+process_ok('[% a = "ab" ; f = "abcd"; foo = \f.replace(a, "-AB-").replace("-AB-", "*") ; f = "ab"; foo %]' => '*cd');
+
+###----------------------------------------------------------------###
+print "### embedded items ###################################################\n";
+
+process_ok('[% " \" " %]' => ' " ');
+process_ok('[% " \$foo " %]' => ' $foo ');
+process_ok('[% " \${foo} " %]' => ' ${foo} ');
+process_ok('[% " \n " %]' => " \n ");
+process_ok('[% " \t " %]' => " \t ");
+process_ok('[% " \r " %]' => " \r ");
+
+process_ok("[% ' \\' ' %]" => " ' ");
+process_ok("[% ' \\r ' %]" => ' \r ');
+process_ok("[% ' \\n ' %]" => ' \n ');
+process_ok("[% ' \\t ' %]" => ' \t ');
+process_ok("[% ' \$foo ' %]" => ' $foo ');
+
+process_ok('[% A = "bar" ; ${ "A" } %]' => 'bar');
+process_ok('[% A = "bar" ; "(${ A })" %]' => '(bar)');
+process_ok('[% A = "bar" ; ${ {a => "A"}.a } %]' => 'bar') if ! $is_tt;
+process_ok('[% A = "bar" ; "(${ {a => \"A\"\\}.a })" %]' => '(A)') if ! $is_tt;
+process_ok('[% A = "bar" ; "(${ \\${ {a => \"A\"\\}.a \\} })" %]' => '(bar)') if ! $is_tt;
+process_ok('[% A = "bar" %](${ {a => \"A\"\\}.a })' => '(A)', {tt_config => [INTERPOLATE => 1]}) if ! $is_tt;
+process_ok('[% A = "bar" %](${ \\${ {a => \"A\"\\}.a \\} })' => '(bar)', {tt_config => [INTERPOLATE => 1]}) if ! $is_tt;
+
+process_ok('[% "[%" %]' => '[%') if ! $is_tt;
+process_ok('[% "%]" %]' => '%]') if ! $is_tt;
+process_ok('[% a = "[% %]" %][% a %]' => '[% %]') if ! $is_tt;
+process_ok('[% "[% 1 + 2 %]" | eval %]' => '3') if ! $is_tt;
+
+process_ok('[% qw([% 1 + 2 %]).join %]' => '[% 1 + 2 %]') if ! $is_tt;
+process_ok('[% qw([% 1 + 2 %]).join.eval %]' => '3') if ! $is_tt;
+
+process_ok('[% f = ">[% TRY; f.eval ; CATCH; \'caught\' ; END %]"; f.eval %]' => '>>>>>caught', {tt_config => [MAX_EVAL_RECURSE => 5]}) if ! $is_tt;
+process_ok('[% f = ">[% TRY; f.eval ; CATCH; \'foo\' ; END %]"; f.eval;f.eval %]' => '>>foo>>foo', {tt_config => [MAX_EVAL_RECURSE => 2]}) if ! $is_tt;
+
+###----------------------------------------------------------------###
+print "### DONE #############################################################\n";
projects / chaz / p5-CGI-Ex / commitdiff
