###----------------------------------------------------------------###
# See the perldoc in CGI/Ex/Template.pod
-# Copyright 2006 - Paul Seamons #
+# Copyright 2007 - Paul Seamons #
# Distributed under the Perl Artistic License without warranty #
###----------------------------------------------------------------###
);
BEGIN {
- $VERSION = '2.06';
+ $VERSION = '2.09';
$PACKAGE_EXCEPTION = 'CGI::Ex::Template::Exception';
$PACKAGE_ITERATOR = 'CGI::Ex::Template::Iterator';
};
$SCALAR_OPS = {
- '0' => sub { shift },
+ '0' => sub { $_[0] },
as => \&vmethod_as_scalar,
chunk => \&vmethod_chunk,
collapse => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; s/\s+/ /g; $_ },
- defined => sub { 1 },
+ defined => sub { defined $_[0] ? 1 : '' },
indent => \&vmethod_indent,
int => sub { local $^W; int $_[0] },
fmt => \&vmethod_as_scalar,
'format' => \&vmethod_format,
hash => sub { {value => $_[0]} },
html => sub { local $_ = $_[0]; s/&/&/g; s/</</g; s/>/>/g; s/\"/"/g; $_ },
+ item => sub { $_[0] },
lcfirst => sub { lcfirst $_[0] },
length => sub { defined($_[0]) ? length($_[0]) : 0 },
list => sub { [$_[0]] },
remove => sub { vmethod_replace(shift, shift, '', 1) },
repeat => \&vmethod_repeat,
replace => \&vmethod_replace,
- search => sub { my ($str, $pat) = @_; return $str if ! defined $str || ! defined $pat; return scalar $str =~ /$pat/ },
+ search => sub { my ($str, $pat) = @_; return $str if ! defined $str || ! defined $pat; return $str =~ /$pat/ },
size => sub { 1 },
split => \&vmethod_split,
stderr => sub { print STDERR $_[0]; '' },
- substr => sub { my ($str, $i, $len) = @_; defined($len) ? substr($str, $i, $len) : substr($str, $i) },
+ substr => \&vmethod_substr,
trim => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; $_ },
ucfirst => sub { ucfirst $_[0] },
upper => sub { uc $_[0] },
$LIST_OPS = {
as => \&vmethod_as_list,
+ defined => sub { return 1 if @_ == 1; defined $_[0]->[ defined($_[1]) ? $_[1] : 0 ] },
first => sub { my ($ref, $i) = @_; return $ref->[0] if ! $i; return [@{$ref}[0 .. $i - 1]]},
fmt => \&vmethod_as_list,
- grep => sub { my ($ref, $pat) = @_; [grep {/$pat/} @$ref] },
- hash => sub { local $^W; my ($list, $i) = @_; defined($i) ? {map {$i++ => $_} @$list} : {@$list} },
+ grep => sub { local $^W; my ($ref, $pat) = @_; [grep {/$pat/} @$ref] },
+ hash => sub { local $^W; my $list = shift; return {@$list} if ! @_; my $i = shift || 0; return {map {$i++ => $_} @$list} },
+ import => sub { my $ref = shift; push @$ref, grep {defined} map {ref eq 'ARRAY' ? @$_ : undef} @_; '' },
+ item => sub { $_[0]->[ $_[1] || 0 ] },
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] } },
+ max => sub { local $^W; $#{ $_[0] } },
merge => sub { my $ref = shift; return [ @$ref, grep {defined} map {ref eq 'ARRAY' ? @$_ : undef} @_ ] },
new => sub { local $^W; return [@_] },
+ null => sub { '' },
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] } },
+ size => sub { local $^W; scalar @{ $_[0] } },
slice => sub { my ($ref, $a, $b) = @_; $a ||= 0; $b = $#$ref if ! defined $b; return [@{$ref}[$a .. $b]] },
sort => \&vmethod_sort,
splice => \&vmethod_splice,
- unique => sub { my %u; return [ grep { ! $u{$_} ++ } @{ $_[0] } ] },
+ unique => sub { my %u; return [ grep { ! $u{$_}++ } @{ $_[0] } ] },
unshift => sub { my $ref = shift; unshift @$ref, @_; return '' },
};
$HASH_OPS = {
as => \&vmethod_as_hash,
- defined => sub { return '' if ! defined $_[1]; defined $_[0]->{ $_[1] } },
- delete => sub { return '' if ! defined $_[1]; delete $_[0]->{ $_[1] } },
+ defined => sub { return 1 if @_ == 1; defined $_[0]->{ defined($_[1]) ? $_[1] : '' } },
+ delete => sub { my $h = shift; my @v = delete @{ $h }{map {defined($_) ? $_ : ''} @_}; @_ == 1 ? $v[0] : \@v },
each => sub { [%{ $_[0] }] },
- exists => sub { return '' if ! defined $_[1]; exists $_[0]->{ $_[1] } },
+ exists => sub { exists $_[0]->{ defined($_[1]) ? $_[1] : '' } },
fmt => \&vmethod_as_hash,
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} },
+ import => sub { my ($a, $b) = @_; @{$a}{keys %$b} = values %$b if ref($b) eq 'HASH'; '' },
+ item => sub { my ($h, $k) = @_; $k = '' if ! defined $k; $k =~ $QR_PRIVATE ? undef : $h->{$k} },
items => sub { [ %{ $_[0] } ] },
keys => sub { [keys %{ $_[0] }] },
- list => sub { [$_[0]] },
+ list => \&vmethod_list_hash,
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] } ] },
+ null => sub { '' },
+ nsort => sub { my $ref = shift; [sort { $ref->{$a} <=> $ref->{$b}} keys %$ref] },
+ pairs => sub { [map { {key => $_, value => $_[0]->{$_}} } sort 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] }] },
$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;
$EXTRA_COMPILE_EXT = '.sto';
sub play_DUMP {
my ($self, $ident, $node) = @_;
require Data::Dumper;
+ local $Data::Dumper::Sortkeys = 1;
my $info = $self->node_info($node);
my $out;
my $var;
pop @var; # remove the trailing '.'
### look for a plugin_base
- my $base = $self->{'PLUGIN_BASE'} || 'Template::Plugin'; # I'm not maintaining plugins - leave that to TT
- my $package = $self->{'PLUGINS'}->{$module} ? $self->{'PLUGINS'}->{$module}
- : $self->{'PLUGIN_FACTORY'}->{$module} ? $self->{'PLUGIN_FACTORY'}->{$module}
- : "${base}::${module}";
- my $require = "$package.pm";
- $require =~ s|::|/|g;
-
- ### try and load the module - fall back to bare module if allowed
+ my $BASE = $self->{'PLUGIN_BASE'} || 'Template::Plugin'; # I'm not maintaining plugins - leave that to TT
my $obj;
- if ($self->{'PLUGIN_FACTORY'}->{$module} || eval {require $require}) {
- my $shape = $package->load;
- my $context = $self->context;
- my @args = $args ? map { $self->play_expr($_) } @$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->play_expr($args->[0]) : []);
- } elsif (my @packages = grep {lc($package) eq lc($_)} @{ $self->list_plugins({base => $base}) }) {
- foreach my $package (@packages) {
- my $require = "$package.pm";
- $require =~ s|::|/|g;
- eval {require $require} || next;
+
+ foreach my $base (ref($BASE) eq 'ARRAY' ? @$BASE : $BASE) {
+ my $package = $self->{'PLUGINS'}->{$module} ? $self->{'PLUGINS'}->{$module}
+ : $self->{'PLUGIN_FACTORY'}->{$module} ? $self->{'PLUGIN_FACTORY'}->{$module}
+ : "${base}::${module}";
+ my $require = "$package.pm";
+ $require =~ s|::|/|g;
+
+ ### try and load the module - fall back to bare module if allowed
+ if ($self->{'PLUGIN_FACTORY'}->{$module} || eval {require $require}) {
my $shape = $package->load;
my $context = $self->context;
my @args = $args ? map { $self->play_expr($_) } @$args : ();
$obj = $shape->new($context, @args);
- }
- } elsif ($self->{'LOAD_PERL'}) {
- my $require = "$module.pm";
- $require =~ s|::|/|g;
- if (eval {require $require}) {
- my @args = $args ? map { $self->play_expr($_) } @$args : ();
- $obj = $module->new(@args);
+ } elsif (lc($module) eq 'iterator') { # use our iterator if none found (TT's works just fine)
+ $obj = $PACKAGE_ITERATOR->new($args ? $self->play_expr($args->[0]) : []);
+ } elsif (my @packages = grep {lc($package) eq lc($_)} @{ $self->list_plugins({base => $base}) }) {
+ foreach my $package (@packages) {
+ my $require = "$package.pm";
+ $require =~ s|::|/|g;
+ eval {require $require} || next;
+ my $shape = $package->load;
+ my $context = $self->context;
+ my @args = $args ? map { $self->play_expr($_) } @$args : ();
+ $obj = $shape->new($context, @args);
+ }
+ } elsif ($self->{'LOAD_PERL'}) {
+ my $require = "$module.pm";
+ $require =~ s|::|/|g;
+ if (eval {require $require}) {
+ my @args = $args ? map { $self->play_expr($_) } @$args : ();
+ $obj = $module->new(@args);
+ }
}
}
if (! defined $obj) {
}
sub vmethod_as_scalar {
- my ($str, $pat) = @_;
- $pat = '%s' if ! defined $pat;
+ my $str = shift; $str = '' if ! defined $str;
+ my $pat = shift; $pat = '%s' if ! defined $pat;
local $^W;
- return sprintf $pat, $str;
+ return @_ ? sprintf($pat, $_[0], $str)
+ : sprintf($pat, $str);
}
sub vmethod_as_list {
- my ($ref, $pat, $sep) = @_;
- $pat = '%s' if ! defined $pat;
- $sep = ' ' if ! defined $sep;
+ my $ref = shift || return '';
+ my $pat = shift; $pat = '%s' if ! defined $pat;
+ my $sep = shift; $sep = ' ' if ! defined $sep;
local $^W;
- return join($sep, map {sprintf $pat, $_} @$ref);
+ return @_ ? join($sep, map {sprintf $pat, $_[0], $_} @$ref)
+ : 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;
+ my $ref = shift || return '';
+ my $pat = shift; $pat = "%s\t%s" if ! defined $pat;
+ my $sep = shift; $sep = "\n" if ! defined $sep;
local $^W;
- return join($sep, map {sprintf $pat, $_, $ref->{$_}} sort keys %$ref);
+ return ! @_ ? join($sep, map {sprintf $pat, $_, $ref->{$_}} sort keys %$ref)
+ : @_ == 1 ? join($sep, map {sprintf $pat, $_[0], $_, $ref->{$_}} sort keys %$ref) # don't get to pick - it applies to the key
+ : join($sep, map {sprintf $pat, $_[0], $_, $_[1], $ref->{$_}} sort keys %$ref);
}
sub vmethod_chunk {
sub vmethod_format {
my $str = shift; $str = '' if ! defined $str;
my $pat = shift; $pat = '%s' if ! defined $pat;
- return join "\n", map{ sprintf $pat, $_ } split(/\n/, $str);
+ if (@_) {
+ return join "\n", map{ sprintf $pat, $_[0], $_ } split(/\n/, $str);
+ } else {
+ return join "\n", map{ sprintf $pat, $_ } split(/\n/, $str);
+ }
}
+sub vmethod_list_hash {
+ my ($hash, $what) = @_;
+ $what = 'pairs' if ! $what || $what !~ /^(keys|values|each|pairs)$/;
+ return $HASH_OPS->{$what}->($hash);
+}
+
+
sub vmethod_match {
my ($str, $pat, $global) = @_;
return [] if ! defined $str || ! defined $pat;
my @res = $global ? ($str =~ /$pat/g) : ($str =~ /$pat/);
- return (@res >= 2) ? \@res : (@res == 1) ? $res[0] : '';
+ return @res ? \@res : '';
}
sub vmethod_nsort {
sub vmethod_repeat {
my ($str, $n, $join) = @_;
- return if ! length $str;
+ return '' if ! defined $str || ! length $str;
$n = 1 if ! defined($n) || ! length $n;
$join = '' if ! defined $join;
return join $join, ($str) x $n;
@replace = @{ $replace[0] } if @replace == 1 && ref $replace[0] eq 'ARRAY';
if (defined $len) {
return [splice @$ref, $i || 0, $len, @replace];
+ } elsif (defined $i) {
+ return [splice @$ref, $i];
} else {
- return [splice @$ref, $i || 0];
+ return [splice @$ref];
}
}
sub vmethod_split {
- my ($str, $pat, @args) = @_;
+ my ($str, $pat, $lim) = @_;
$str = '' if ! defined $str;
- return defined $pat ? [split $pat, $str, @args] : [split ' ', $str, @args];
+ if (defined $lim) { return defined $pat ? [split $pat, $str, $lim] : [split ' ', $str, $lim] }
+ else { return defined $pat ? [split $pat, $str ] : [split ' ', $str ] }
+}
+
+sub vmethod_substr {
+ my ($str, $i, $len, $replace) = @_;
+ $i ||= 0;
+ return substr($str, $i) if ! defined $len;
+ return substr($str, $i, $len) if ! defined $replace;
+ substr($str, $i, $len, $replace);
+ return $str;
}
sub vmethod_uri {
###----------------------------------------------------------------###
sub dump_parse {
+ my $obj = UNIVERSAL::isa($_[0], __PACKAGE__) ? shift : __PACKAGE__->new;
+ my $str = shift;
+ require Data::Dumper;
+ return Data::Dumper::Dumper($obj->parse_tree(\$str));
+}
+
+sub dump_parse_expr {
my $obj = UNIVERSAL::isa($_[0], __PACKAGE__) ? shift : __PACKAGE__->new;
my $str = shift;
require Data::Dumper;
projects / chaz / p5-CGI-Ex / blobdiff