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