X-Git-Url: https://git.dogcows.com/gitweb?a=blobdiff_plain;f=lib%2FCGI%2FEx%2FTemplate.pm;h=48e900a44f7dc8f66b128a683e8475a3c4ceeca9;hb=8a1796477c5a835d8c124cfa8504909dc786d93b;hp=52d92a07054174edc0763cd70ce2c0ab247df88b;hpb=48c4840be1f154e262de2c161cb86dc5000dfe47;p=chaz%2Fp5-CGI-Ex diff --git a/lib/CGI/Ex/Template.pm b/lib/CGI/Ex/Template.pm index 52d92a0..48e900a 100644 --- a/lib/CGI/Ex/Template.pm +++ b/lib/CGI/Ex/Template.pm @@ -2,7 +2,7 @@ package CGI::Ex::Template; ###----------------------------------------------------------------### # See the perldoc in CGI/Ex/Template.pod -# Copyright 2006 - Paul Seamons # +# Copyright 2007 - Paul Seamons # # Distributed under the Perl Artistic License without warranty # ###----------------------------------------------------------------### @@ -39,7 +39,7 @@ use vars qw($VERSION ); BEGIN { - $VERSION = '2.05'; + $VERSION = '2.09'; $PACKAGE_EXCEPTION = 'CGI::Ex::Template::Exception'; $PACKAGE_ITERATOR = 'CGI::Ex::Template::Iterator'; @@ -59,17 +59,18 @@ BEGIN { }; $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; $_ }, + item => sub { $_[0] }, lcfirst => sub { lcfirst $_[0] }, length => sub { defined($_[0]) ? length($_[0]) : 0 }, list => sub { [$_[0]] }, @@ -81,11 +82,11 @@ BEGIN { 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] }, @@ -101,46 +102,51 @@ BEGIN { $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] }] }, @@ -276,10 +282,12 @@ BEGIN { $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'; + + eval {require Scalar::Util}; }; ###----------------------------------------------------------------### @@ -1676,6 +1684,7 @@ sub parse_DUMP { 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; @@ -1936,7 +1945,8 @@ sub play_MACRO { $sub_tree = $sub_tree->[0]->[4]; } - my $self_copy = $self->weak_copy; + my $self_copy = $self; + eval {require Scalar::Util; Scalar::Util::weaken($self_copy)}; ### install a closure in the stash that will handle the macro $self->set_variable($name, sub { @@ -2376,38 +2386,41 @@ sub play_USE { 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) { @@ -2778,20 +2791,6 @@ sub list_plugins { }; } -### get a copy of self without circular refs for use in closures -sub weak_copy { - my $self = shift; - my $self_copy; - if (eval { require Scalar::Util } - && defined &Scalar::Util::weaken) { - $self_copy = $self; - Scalar::Util::weaken($self_copy); - } else { - $self_copy = bless {%$self}, ref($self); # hackish way to avoid circular refs on old perls (pre 5.8) - } - return $self_copy; -} - sub debug_node { my ($self, $node) = @_; my $info = $self->node_info($node); @@ -2859,26 +2858,30 @@ sub define_vmethod { } 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 { @@ -2906,14 +2909,25 @@ sub vmethod_indent { 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 { @@ -2927,7 +2941,7 @@ 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; @@ -2972,15 +2986,27 @@ sub vmethod_splice { @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 { @@ -3025,6 +3051,13 @@ sub filter_redirect { ###----------------------------------------------------------------### 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;