]>
Dogcows Code - chaz/p5-CGI-Ex/blob - lib/CGI/Ex/Var.pm
5 CGI::Ex::Var - Variable and expression parsing (exprimental)
9 Experimental - The storage structure will change to match CGI::Ex::Template by the next release.
13 ###----------------------------------------------------------------###
14 # Copyright 2006 - Paul Seamons #
15 # Distributed under the Perl Artistic License without warranty #
16 ###----------------------------------------------------------------###
44 $RT_OPERATOR_PRECEDENCE
49 use constant trace
=> 0;
53 chunk
=> \
&vmethod_chunk
,
54 collapse
=> sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; s/\s+/ /g; $_ },
56 indent
=> \
&vmethod_indent
,
57 'format' => \
&vmethod_format
,
58 hash
=> sub { {value
=> $_[0]} },
59 html
=> sub { local $_ = $_[0]; s/&/&/g; s/</</g; s/>/>/g; s/\"/"/g; $_ },
60 lcfirst => sub { lcfirst $_[0] },
61 length => sub { defined($_[0]) ? length($_[0]) : 0 },
62 lower
=> sub { lc $_[0] },
63 match
=> \
&vmethod_match
,
65 remove
=> sub { vmethod_replace
(shift, shift, '', 1) },
66 repeat
=> \
&vmethod_repeat
,
67 replace
=> \
&vmethod_replace
,
68 search
=> sub { my ($str, $pat) = @_; return $str if ! defined $str || ! defined $pat; return $str =~ /$pat/ },
70 split => \
&vmethod_split
,
71 stderr
=> sub { print STDERR
$_[0]; '' },
72 substr => sub { my ($str, $i, $len) = @_; defined($len) ? substr($str, $i, $len) : substr($str, $i) },
73 trim
=> sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; $_ },
74 ucfirst => sub { ucfirst $_[0] },
75 upper
=> sub { uc $_[0] },
76 uri
=> sub { local $_ = $_[0]; s/([^;\/?:@&=+\$,A-Za-z0-9\-_.!~*\'()])/sprintf
('%%%02X', ord($1))/eg
; $_ },
79 $FILTER_OPS = { # generally - non-dynamic filters belong in scalar ops
80 eval => [\
&filter_eval
, 1],
81 evaltt
=> [\
&filter_eval
, 1],
82 file
=> [\
&filter_redirect
, 1],
83 redirect
=> [\
&filter_redirect
, 1],
87 first
=> sub { my ($ref, $i) = @_; return $ref->[0] if ! $i; return [@{$ref}[0 .. $i - 1]]},
88 grep => sub { my ($ref, $pat) = @_; [grep {/$pat/} @$ref] },
89 hash
=> sub { my ($list, $i) = @_; defined($i) ? {map {$i++ => $_} @$list} : {@$list} },
90 join => sub { my ($ref, $join) = @_; $join = ' ' if ! defined $join; local $^W; return join $join, @$ref },
91 last => sub { my ($ref, $i) = @_; return $ref->[-1] if ! $i; return [@{$ref}[-$i .. -1]]},
92 list
=> sub { $_[0] },
93 max
=> sub { $#{ $_[0] } },
94 merge
=> sub { my $ref = shift; return [ @$ref, grep {defined} map {ref eq 'ARRAY' ? @$_ : undef} @_ ] },
95 nsort
=> \
&vmethod_nsort
,
96 pop => sub { pop @{ $_[0] } },
97 push => sub { my $ref = shift; push @$ref, @_; return '' },
98 reverse => sub { [ reverse @{ $_[0] } ] },
99 shift => sub { shift @{ $_[0] } },
100 size
=> sub { scalar @{ $_[0] } },
101 slice
=> sub { my ($ref, $a, $b) = @_; $a ||= 0; $b = $#$ref if ! defined $b; return [@{$ref}[$a .. $b]] },
102 sort => \
&vmethod_sort
,
103 splice => \
&vmethod_splice
,
104 unique
=> sub { my %u; return [ grep { ! $u{$_} ++ } @{ $_[0] } ] },
105 unshift => sub { my $ref = shift; unshift @$ref, @_; return '' },
109 defined => sub { return '' if ! defined $_[1]; defined $_[0]->{ $_[1] } },
110 delete => sub { return '' if ! defined $_[1]; delete $_[0]->{ $_[1] } },
111 each => sub { [%{ $_[0] }] },
112 exists => sub { return '' if ! defined $_[1]; exists $_[0]->{ $_[1] } },
113 hash
=> sub { $_[0] },
114 import
=> sub { my ($a, $b) = @_; return '' if ref($b) ne 'HASH'; @{$a}{keys %$b} = values %$b; '' },
115 keys => sub { [keys %{ $_[0] }] },
116 list
=> sub { [$_[0]] },
117 pairs
=> sub { [map { {key
=> $_, value
=> $_[0]->{$_}} } keys %{ $_[0] } ] },
118 nsort
=> sub { my $ref = shift; [sort {$ref->{$a} <=> $ref->{$b} } keys %$ref] },
119 size
=> sub { scalar keys %{ $_[0] } },
120 sort => sub { my $ref = shift; [sort {lc $ref->{$a} cmp lc $ref->{$b}} keys %$ref] },
121 values => sub { [values %{ $_[0] }] },
124 ### Runtime set variables that control lookups of various pieces of info
127 $RT_CONTEXT_SUB = sub { {} };
129 $RT_OPERATOR_PRECEDENCE = 0;
131 ### setup the operator parsing
133 # name => # order, precedence, symbols, only_in_parens, sub to create
134 [2, 96, ['**', '^', 'pow'], 0, sub {bless(shift(), 'CGI::Ex::_pow')} ],
135 [1, 93, ['!'], 0, sub {bless(shift(), 'CGI::Ex::_not')} ],
136 [1, 93, ['-'], 0, sub {bless(shift(), 'CGI::Ex::_negate')} ],
137 [2, 90, ['*'], 0, sub {bless(shift(), 'CGI::Ex::_mult')} ],
138 [2, 90, ['/'], 0, sub {bless(shift(), 'CGI::Ex::_div')} ],
139 [2, 90, ['div', 'DIV'], 0, sub {bless(shift(), 'CGI::Ex::_intdiv')} ],
140 [2, 90, ['%', 'mod', 'MOD'], 0, sub {bless(shift(), 'CGI::Ex::_mod')} ],
141 [2, 85, ['+'], 0, sub {bless(shift(), 'CGI::Ex::_plus')} ],
142 [2, 85, ['-'], 0, sub {bless(shift(), 'CGI::Ex::_subtr')} ],
143 [2, 85, ['_', '~'], 0, \
&_concat
],
144 [2, 80, ['<'], 0, sub {bless(shift(), 'CGI::Ex::_num_lt')} ],
145 [2, 80, ['>'], 0, sub {bless(shift(), 'CGI::Ex::_num_gt')} ],
146 [2, 80, ['<='], 0, sub {bless(shift(), 'CGI::Ex::_num_le')} ],
147 [2, 80, ['>='], 0, sub {bless(shift(), 'CGI::Ex::_num_ge')} ],
148 [2, 80, ['lt'], 0, sub {bless(shift(), 'CGI::Ex::_str_lt')} ],
149 [2, 80, ['gt'], 0, sub {bless(shift(), 'CGI::Ex::_str_gt')} ],
150 [2, 80, ['le'], 0, sub {bless(shift(), 'CGI::Ex::_str_le')} ],
151 [2, 80, ['ge'], 0, sub {bless(shift(), 'CGI::Ex::_str_ge')} ],
152 [2, 75, ['==', 'eq'], 0, sub {bless(shift(), 'CGI::Ex::_eq')} ],
153 [2, 75, ['!=', 'ne'], 0, sub {bless(shift(), 'CGI::Ex::_ne')} ],
154 [2, 70, ['&&'], 0, sub {bless(shift(), 'CGI::Ex::_and')} ],
155 [2, 65, ['||'], 0, sub {bless(shift(), 'CGI::Ex::_or')} ],
156 [2, 60, ['..'], 0, sub {bless(shift(), 'CGI::Ex::_range')} ],
157 [3, 55, ['?', ':'], 0, sub {bless(shift(), 'CGI::Ex::_ifelse')} ],
158 [2, 52, ['='], 1, sub {bless(shift(), 'CGI::Ex::_set')} ],
159 [1, 50, ['not', 'NOT'], 0, sub {bless(shift(), 'CGI::Ex::_not')} ],
160 [2, 45, ['and', 'AND'], 0, sub {bless(shift(), 'CGI::Ex::_and')} ],
161 [2, 40, ['or', 'OR'], 0, sub {bless(shift(), 'CGI::Ex::_or')} ],
164 $OP_UNARY ||= {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] == 1} @$OPERATORS};
165 $OP_BINARY ||= {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] == 2} @$OPERATORS};
166 $OP_TRINARY ||= {map {my $ref = $_; map {$_ => $ref} @{$ref->[2]}} grep {$_->[0] == 3} @$OPERATORS};
167 sub _op_qr
{ # no mixed \w\W operators
169 my $chrs = join '|', map {quotemeta $_} grep {++$used{$_} < 2} grep {/^\W{2,}$/} @_;
170 my $chr = join '', map {quotemeta $_} grep {++$used{$_} < 2} grep {/^\W$/} @_;
171 my $word = join '|', grep {++$used{$_} < 2} grep {/^\w+$/} @_;
172 $chr = "[$chr]" if $chr;
173 $word = "\\b(?:$word)\\b" if $word;
174 return join('|', grep {length} $chrs, $chr, $word) || die "Missing operator regex";
176 sub _build_op_qr
{ _op_qr
(sort map {@{ $_->[2] }} grep {$_->[0] > 1 && ! $_->[3]} @$OPERATORS) } # all binary, trinary, non-parened ops
177 sub _build_op_qr_unary
{ _op_qr
(sort map {@{ $_->[2] }} grep {$_->[0] == 1 } @$OPERATORS) } # unary operators
178 sub _build_op_qr_paren
{ _op_qr
(sort map {@{ $_->[2] }} grep { $_->[3]} @$OPERATORS) } # paren
179 $QR_OP ||= _build_op_qr
();
180 $QR_OP_UNARY ||= _build_op_qr_unary
();
181 $QR_OP_PARENED ||= _build_op_qr_paren
();
183 $QR_COMMENTS = '(?-s: \# .* \s*)*';
184 $QR_AQ_NOTDOT = "(?! \\s* $QR_COMMENTS \\.)";
185 $QR_PRIVATE = qr/^_/;
188 ###----------------------------------------------------------------###
190 sub _var
{ return bless(shift(), __PACKAGE__
) }
191 sub _literal
{ return bless(shift(), 'CGI::Ex::_literal') }
192 sub _hash
{ return bless(shift(), 'CGI::Ex::_hash' ) }
193 sub _array
{ return bless(shift(), 'CGI::Ex::_array' ) }
194 sub _concat
{ return bless(shift(), 'CGI::Ex::_concat' ) }
195 sub _autobox
{ return bless(shift(), 'CGI::Ex::_autobox') }
196 sub _not
{ return bless(shift(), 'CGI::Ex::_not' ) }
199 require CGI
::Ex
::Template
;
200 CGI
::Ex
::Template-
>throw(@_);
203 ###----------------------------------------------------------------###
207 my $ARGS = shift || {};
209 ### allow for custom auto_quoting (such as hash constructors)
210 if ($ARGS->{'auto_quote'}) {
211 if ($$str_ref =~ $ARGS->{'auto_quote'}) {
213 substr($$str_ref, 0, length($str), '');
214 $$str_ref =~ s{ ^ \s* $QR_COMMENTS }{}ox;
216 ### allow for auto-quoted $foo or ${foo.bar} type constructs
217 } elsif ($$str_ref =~ s{ ^ \$ (\w+ (?:\.\w+)*) \b \s* $QR_COMMENTS }{}ox
218 || $$str_ref =~ s{ ^ \$\{ \s* ([^\}]+) \} \s* $QR_COMMENTS }{}ox) {
220 return parse_exp
(\
$name);
224 my $copy = $$str_ref; # copy while parsing to allow for errors
226 ### test for leading unary operators
228 if ($copy =~ s{ ^ ($QR_OP_UNARY) \s* $QR_COMMENTS }{}ox) {
229 return if $ARGS->{'auto_quote'}; # auto_quoted thing was too complicated
238 ### allow for numbers
239 if ($copy =~ s{ ^ ( (?:\d*\.\d+ | \d+) ) \s* $QR_COMMENTS }{}ox) {
241 push @var, _literal
(\
$number);
244 ### looks like a normal variable start
245 } elsif ($copy =~ s{ ^ (\w+) \s* $QR_COMMENTS }{}ox) {
247 $is_namespace = 1 if $RT_NAMESPACE->{$1};
249 ### allow for literal strings
250 } elsif ($copy =~ s{ ^ ([\"\']) (|.*?[^\\]) \1 \s* $QR_COMMENTS }{}sox) {
251 if ($1 eq "'") { # no interpolation on single quoted strings
253 $str =~ s{ \\\' }{\'}xg;
254 push @var, _literal
(\
$str);
261 $str =~ s/\\([\"\$])/$1/g;
262 my @pieces = $ARGS->{'auto_quote'}
263 ? split(m{ (\$\w+ | \$\{ [^\}]+ \
}) }x
, $str) # autoquoted items get a single $\w+ - no nesting
264 : split(m{ (\$\w+ (?:\.\w+)* | \$\{ [^\}]+ \
}) }x
, $str);
266 foreach my $piece (@pieces) {
267 next if ! ($n++ % 2);
268 next if $piece !~ m{ ^ \$ (\w+ (?:\.\w+)*) $ }x
269 && $piece !~ m{ ^ \$\{ \s* ([^\}]+) \
} $ }x
;
271 $piece = parse_exp
(\
$name);
273 @pieces = grep {defined && length} @pieces;
274 if (@pieces == 1 && ! ref $pieces[0]) {
275 push @var, _literal
(\
$pieces[0]);
277 } elsif (! @pieces) {
279 push @var, _literal
(\
$str);
282 push @var, _concat
(\
@pieces);
286 if ($ARGS->{'auto_quote'}){
288 return ${ $var[0] } if $is_literal;
289 return _var
([@var, 0]);
292 ### allow for leading $foo or ${foo.bar} type constructs
293 } elsif ($copy =~ s{ ^ \$ (\w+) \b \s* $QR_COMMENTS }{}ox
294 || $copy =~ s{ ^ \$\{ \s* ([^\}]+) \} \s* $QR_COMMENTS }{}ox) {
296 push @var, parse_exp
(\
$name);
298 ### looks like an array constructor
299 } elsif ($copy =~ s{ ^ \[ \s* $QR_COMMENTS }{}ox) {
300 local $RT_OPERATOR_PRECEDENCE = 0; # reset presedence
302 while (defined(my $var = parse_exp
(\
$copy))) {
303 push @$arrayref, $var;
304 $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
306 $copy =~ s{ ^ \] \s* $QR_COMMENTS }{}ox
307 || throw
('parse.missing.square', "Missing close \]", undef, length($$str_ref) - length($copy));
308 push @var, _array
($arrayref);
311 ### looks like a hash constructor
312 } elsif ($copy =~ s{ ^ \{ \s* $QR_COMMENTS }{}ox) {
313 local $RT_OPERATOR_PRECEDENCE = 0; # reset precedence
315 while (defined(my $key = parse_exp
(\
$copy, {auto_quote
=> qr{ ^ (\w+) $QR_AQ_NOTDOT }xo}))) {
316 $copy =~ s{ ^ = >? \s* $QR_COMMENTS }{}ox;
317 my $val = parse_exp
(\
$copy);
318 push @$hashref, $key, $val;
319 $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
321 $copy =~ s{ ^ \} \s* $QR_COMMENTS }{}ox
322 || throw
('parse.missing.curly', "Missing close \} ($copy)", undef, length($$str_ref) - length($copy));
323 push @var, _hash
($hashref);
326 ### looks like a paren grouper
327 } elsif ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) {
328 local $RT_OPERATOR_PRECEDENCE = 0; # reset precedence
329 my $var = parse_exp
(\
$copy, {allow_parened_ops
=> 1});
330 $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox
331 || throw
('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy));
335 ### nothing to find - return failure
340 return if $ARGS->{'auto_quote'}; # auto_quoted thing was too complicated
342 ### looks for args for the initial
343 if ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) {
344 local $RT_OPERATOR_PRECEDENCE = 0; # reset precedence
345 my $args = parse_args
(\
$copy);
346 $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox
347 || throw
('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy));
353 ### allow for nested items
354 while ($copy =~ s{ ^ ( \.(?!\.) | \|(?!\|) ) \s* $QR_COMMENTS }{}ox) {
355 push(@var, $1) if ! $ARGS->{'no_dots'};
357 ### allow for interpolated variables in the middle - one.$foo.two or one.${foo.bar}.two
358 if ($copy =~ s{ ^ \$(\w+) \s* $QR_COMMENTS }{}ox
359 || $copy =~ s{ ^ \$\{ \s* ([^\}]+)\} \s* $QR_COMMENTS }{}ox) {
361 my $var = parse_exp
(\
$name);
363 } elsif ($copy =~ s{ ^ (\w+) \s* $QR_COMMENTS }{}ox) {
366 throw
('parse', "Not sure how to continue parsing on \"$copy\" ($$str_ref)");
369 ### looks for args for the nested item
370 if ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) {
371 local $RT_OPERATOR_PRECEDENCE = 0; # reset precedence
372 my $args = parse_args
(\
$copy);
373 $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox
374 || throw
('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy));
382 ### flatten literals and constants as much as possible
387 } elsif ($is_construct) {
393 if ($is_construct && ! $var[0]->does_autobox) {
394 $var[0] = _autobox
([$var[0]]);
397 if ($is_namespace) { # attempt to "fold" constant variables into the parse tree
398 local $RT_DURING_COMPILE = 1;
399 $var = _var
(\
@var)->call({});
405 ### allow for all "operators"
406 if (! $RT_OPERATOR_PRECEDENCE) {
409 while ($copy =~ s{ ^ ($QR_OP) \s* $QR_COMMENTS }{}ox ## look for operators - then move along
410 || ($ARGS->{'allow_parened_ops'}
411 && $copy =~ s{ ^ ($QR_OP_PARENED) \s* $QR_COMMENTS }{}ox) ) {
412 local $RT_OPERATOR_PRECEDENCE = 1;
414 my $var2 = parse_exp
(\
$copy);
416 ### allow for unary operator precedence
417 if ($has_unary && (($OP_BINARY->{$op} || $OP_TRINARY->{$op})->[1] < $OP_UNARY->{$has_unary}->[1])) {
419 if (@$tree == 2) { # only one operator - keep simple things fast
420 $var = $OP_BINARY->{$tree->[0]}->[4]->([$var, $tree->[1]]);
422 unshift @$tree, $var;
423 $var = apply_precedence
($tree, $found);
428 $var = $OP_UNARY->{$has_unary}->[4]->([$var]);
432 ### add the operator to the tree
433 push (@{ $tree ||= [] }, $op, $var2);
434 my $ref = $OP_BINARY->{$op} || $OP_TRINARY->{$op};
435 $found->{$op} = $ref->[1];
438 ### if we found operators - tree the nodes by operator precedence
440 if (@$tree == 2 && $OP_BINARY->{$tree->[0]}) { # only one operator - keep simple things fast
441 $var = $OP_BINARY->{$tree->[0]}->[4]->([$var, $tree->[1]]);
443 unshift @$tree, $var;
444 $var = apply_precedence
($tree, $found);
449 ### allow for unary on non-chained variables
451 $var = $OP_UNARY->{$has_unary}->[4]->([$var]);
454 $$str_ref = $copy; # commit the changes
458 ### this is used to put the parsed variables into the correct operations tree
459 sub apply_precedence
{
460 my ($tree, $found) = @_;
464 ### look at the operators we found in the order we found them
465 for my $op (sort {$found->{$a} <=> $found->{$b}} keys %$found) {
467 delete $found->{$op};
471 ### split the array on the current operator
472 for (my $i = 0; $i <= $#$tree; $i ++) {
473 my $is_trinary = $OP_TRINARY->{$op} && grep {$_ eq $tree->[$i]} @{ $OP_TRINARY->{$op}->[2] };
474 next if $tree->[$i] ne $op && ! $is_trinary;
475 push @trees, [splice @$tree, 0, $i, ()]; # everything up to the operator
476 push @trinary, $tree->[0] if $is_trinary;
477 shift @$tree; # pull off the operator
480 next if ! @trees; # this iteration didn't have the current operator
481 push @trees, $tree if scalar @$tree; # elements after last operator
483 ### now - for this level split on remaining operators, or add the variable to the tree
484 for my $node (@trees) {
486 $node = $node->[0]; # single item - its not a tree
487 } elsif (@$node == 3) {
488 my $ref = $OP_BINARY->{$node->[1]} || $OP_TRINARY->{$node->[1]};
489 $node = $ref->[4]->([$node->[0], $node->[2]]); # single operator - put it straight on
491 $node = apply_precedence
($node, $found); # more complicated - recurse
496 if ($OP_BINARY->{$op}) {
498 $val = $OP_BINARY->{$op}->[4]->([$val, $trees[$_]]) for 1 .. $#trees;
502 ### return simple trinary
504 return $OP_TRINARY->{$op}->[4]->(\
@trees);
507 ### reorder complex trinary - rare case
508 while ($#trinary >= 1) {
509 ### if we look starting from the back - the first lead trinary op will always be next to its matching op
510 for (my $i = $#trinary; $i >= 0; $i --) {
511 next if $OP_TRINARY->{$trinary[$i]}->[2]->[1] eq $trinary[$i];
512 my ($op, $op2) = splice @trinary, $i, 2, (); # remove the found pair of operators
513 my $node = $OP_TRINARY->{$op}->[4]->([@trees[$i .. $i + 2]]);
514 splice @trees, $i, 3, $node; # replace the previous 3 pieces with the one new node
517 return $trees[0]; # at this point the trinary has been reduced to a single operator
521 throw
('parse', "Couldn't apply precedence");
524 ### look for arguments - both positional and named
527 my $ARGS = shift || {};
528 my $copy = $$str_ref;
532 while (length $$str_ref) {
533 my $copy = $$str_ref;
534 if (defined(my $name = parse_exp
(\
$copy, {auto_quote
=> qr{ ^ (\w+) $QR_AQ_NOTDOT }xo}))
535 && $copy =~ s{ ^ = >? \s* $QR_COMMENTS }{}ox) {
536 throw
('parse', 'Named arguments not allowed') if $ARGS->{'positional_only'};
537 my $val = parse_exp
(\
$copy);
538 $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
539 push @named, $name, $val;
541 } elsif (defined(my $arg = parse_exp
($str_ref))) {
543 $$str_ref =~ s{ ^ , \s* $QR_COMMENTS }{}ox;
549 ### allow for named arguments to be added also
550 push @args, _hash
(\
@named) if scalar @named;
555 sub get_exp
{ ref($_[0]) ? $_[0]->call($_[1]) : $_[0] }
559 $var = _var
([$var, 0]) if ! ref $var; # allow for the parse tree to store literals - the literal is used as a name (like [% 'a' = 'A' %])
560 return $var->set($_[0], $_[1]);
566 require Data
::Dumper
;
567 return Data
::Dumper
::Dumper
(parse_exp
(\
$str));
571 my ($str, $hash) = @_;
572 require Data
::Dumper
;
573 return Data
::Dumper
::Dumper
(get_exp
(parse_exp
(\
$str), $hash));
577 my ($str, $val, $hash) = @_;
579 require Data
::Dumper
;
580 set_exp
(parse_exp
(\
$str), $val, $hash);
581 return Data
::Dumper
::Dumper
($hash);
587 return [map {get_exp
($_, $hash)} @$vars];
590 ###----------------------------------------------------------------###
594 return bless $_[0], $class;
597 sub does_autobox
{ 0 }
601 my $hash = shift || {};
604 ### determine the top level of this particular variable access
605 my $ref = $self->[$i++];
606 my $args = $self->[$i++];
607 warn "CGI::Ex::Var::call: begin \"$ref\"\n" if trace
;
610 if ($ref->does_autobox) {
611 $ref = $ref->call($hash);
613 $ref = $ref->call($hash);
614 return if $ref =~ $QR_PRIVATE; # don't allow vars that begin with _
615 $ref = $hash->{$ref};
618 if ($RT_DURING_COMPILE) {
619 $ref = $RT_NAMESPACE->{$ref};
621 return if $ref =~ $QR_PRIVATE; # don't allow vars that begin with _
622 $ref = $hash->{$ref};
627 while (defined $ref) {
629 ### check at each point if the returned thing was a code
630 if (UNIVERSAL
::isa
($ref, 'CODE')) {
631 my @results = $ref->($args ? (map {get_exp
($_, $hash)} @$args) : ());
632 if (defined $results[0]) {
633 $ref = ($#results > 0) ? \
@results : $results[0];
634 } elsif (defined $results[1]) {
635 die $results[1]; # TT behavior - why not just throw ?
642 ### descend one chained level
643 last if $i >= $#$self;
644 my $was_dot_call = $self->[$i++] eq '.';
645 my $name = $self->[$i++];
646 my $args = $self->[$i++];
647 warn "CGI::Ex::Var::get_exp: nested \"$name\"\n" if trace
;
649 ### allow for named portions of a variable name (foo.$name.bar)
651 $name = $name->call($hash);
652 if (! defined $name) {
658 if ($name =~ $QR_PRIVATE) { # don't allow vars that begin with _
663 ### allow for scalar and filter access (this happens for every non virtual method call)
665 if ($SCALAR_OPS->{$name}) { # normal scalar op
666 $ref = $SCALAR_OPS->{$name}->($ref, $args ? (map {get_exp
($_, $hash)} @$args) : ());
668 } elsif ($LIST_OPS->{$name}) { # auto-promote to list and use list op
669 $ref = $LIST_OPS->{$name}->([$ref], $args ? (map {get_exp
($_, $hash)} @$args) : ());
671 } elsif (my $filter = $RT_FILTERS->{$name} # filter configured in Template args
672 || $FILTER_OPS->{$name} # predefined filters in CET
673 || (UNIVERSAL
::isa
($name, 'CODE') && $name) # looks like a filter sub passed in the stash
674 || list_filters
()->{$name}) { # filter defined in Template::Filters
676 if (UNIVERSAL
::isa
($filter, 'CODE')) {
677 $ref = eval { $filter->($ref) }; # non-dynamic filter - no args
679 throw
('filter', $err) if ref($err) !~ /Template::Exception$/;
682 } elsif (! UNIVERSAL
::isa
($filter, 'ARRAY')) {
683 throw
('filter', "invalid FILTER entry for '$name' (not a CODE ref)");
685 } elsif (@$filter == 2 && UNIVERSAL
::isa
($filter->[0], 'CODE')) { # these are the TT style filters
687 my $sub = $filter->[0];
688 if ($filter->[1]) { # it is a "dynamic filter" that will return a sub
689 ($sub, my $err) = $sub->($RT_CONTEXT_SUB->(), $args ? (map {get_exp
($_, $hash)} @$args) : ());
690 if (! $sub && $err) {
691 throw
('filter', $err) if ref($err) !~ /Template::Exception$/;
693 } elsif (! UNIVERSAL
::isa
($sub, 'CODE')) {
694 throw
('filter', "invalid FILTER for '$name' (not a CODE ref)")
695 if ref($sub) !~ /Template::Exception$/;
702 throw
('filter', $err) if ref($err) !~ /Template::Exception$/;
705 } else { # this looks like our vmethods turned into "filters" (a filter stored under a name)
706 throw
('filter', 'Recursive filter alias \"$name\"') if $seen_filters{$name} ++;
707 $self = [$name, 0, '|', @$filter, @{$self}[$i..$#$self]]; # splice the filter into our current tree
710 if (scalar keys %seen_filters
711 && $seen_filters{$self->[$i - 5] || ''}) {
712 throw
('filter', "invalid FILTER entry for '".$self->[$i - 5]."' (not a CODE ref)");
720 ### method calls on objects
721 if (UNIVERSAL
::can
($ref, 'can')) {
722 my @args = $args ? (map {get_exp
($_, $hash)} @$args) : ();
723 my @results = eval { $ref->$name(@args) };
725 die $@ if ref $@ || $@ !~ /Can\'t locate object method/;
726 } elsif (defined $results[0]) {
727 $ref = ($#results > 0) ? \
@results : $results[0];
729 } elsif (defined $results[1]) {
730 die $results[1]; # TT behavior - why not just throw ?
735 # didn't find a method by that name - so fail down to hash and array access
738 ### hash member access
739 if (UNIVERSAL
::isa
($ref, 'HASH')) {
740 if ($was_dot_call && exists($ref->{$name}) ) {
741 $ref = $ref->{$name};
742 } elsif ($HASH_OPS->{$name}) {
743 $ref = $HASH_OPS->{$name}->($ref, $args ? (map {get_exp
($_, $hash)} @$args) : ());
744 } elsif ($RT_DURING_COMPILE) {
745 return $self; # abort - can't fold namespace variable
751 } elsif (UNIVERSAL
::isa
($ref, 'ARRAY')) {
752 if ($name =~ /^\d+$/) {
753 $ref = ($name > $#$ref) ? undef : $ref->[$name];
755 $ref = (! $LIST_OPS->{$name}) ? undef : $LIST_OPS->{$name}->($ref, $args ? (map {get_exp
($_, $hash)} @$args) : ());
762 ### allow for undefinedness
763 if (! defined $ref) {
764 if ($RT_DEBUG_UNDEF) {
765 my $chunk = $self->[$i - 2];
766 $chunk = $chunk->call($hash) if ref $chunk;
767 die "$chunk is undefined\n";
769 $ref = $self->undefined_any($self);
776 sub undefined_any
{ $RT_UNDEFINED_SUB ? $RT_UNDEFINED_SUB->(@_) : undef }
779 my ($self, $val, $hash) = @_;
782 ### determine the top level of this particular variable access
783 my $ref = $self->[$i++];
784 my $args = $self->[$i++];
787 $ref = $ref->call($hash);
788 return if ! defined $ref;
791 return if $ref =~ $QR_PRIVATE; # don't allow vars that begin with _
794 $hash->{$ref} = $val;
797 $ref = $hash->{$ref} ||= {};
800 ### let the top level thing be a code block
801 return if UNIVERSAL
::isa
($ref, 'CODE');
803 ### vivify the chained levels
804 while (defined $ref && $#$self > $i) {
805 my $was_dot_call = $self->[$i++] eq '.';
806 my $name = $self->[$i++];
807 my $args = $self->[$i++];
809 ### allow for named portions of a variable name (foo.$name.bar)
811 $name = $name->call($hash);
812 if (! defined $name) {
818 if ($name =~ $QR_PRIVATE) { # don't allow vars that begin with _
822 ### method calls on objects
823 if (UNIVERSAL
::can
($ref, 'can')) {
825 my @args = $args ? (map {get_exp
($_, $hash)} @$args) : ();
830 my @results = eval { $ref->$name(@args) };
832 die $@ if ref $@ || $@ !~ /Can\'t locate object method/;
833 } elsif (defined $results[0]) {
834 $ref = ($#results > 0) ? \
@results : $results[0];
835 } elsif (defined $results[1]) {
836 die $results[1]; # TT behavior - why not just throw ?
840 return if $lvalueish;
844 ### hash member access
845 if (UNIVERSAL
::isa
($ref, 'HASH')) {
847 $ref->{$name} = $val;
850 $ref = $ref->{$name} ||= {};
855 } elsif (UNIVERSAL
::isa
($ref, 'ARRAY')) {
856 if ($name =~ /^\d+$/) {
858 $ref->[$name] = $val;
861 $ref = $ref->[$name] ||= {};
869 } elsif (! ref($ref) && defined($ref)) {
873 ### check at each point if the returned thing was a code
874 if (defined($ref) && UNIVERSAL
::isa
($ref, 'CODE')) {
875 my @results = $ref->($args ? (map {get_exp
($_, $hash)} @$args) : ());
876 if (defined $results[0]) {
877 $ref = ($#results > 0) ? \
@results : $results[0];
878 } elsif (defined $results[1]) {
879 die $results[1]; # TT behavior - why not just throw ?
890 ###----------------------------------------------------------------###
891 ### filters and vmethod definition
894 return $TT_FILTERS ||= eval { require Template
::Filters
; $Template::Filters
::FILTERS
} || {};
899 my $size = shift || 1;
901 if ($size < 0) { # chunk from the opposite end
904 unshift(@list, scalar reverse $1) while $str =~ /( .{$size} | .+ )/xg;
906 push(@list, $1) while $str =~ /( .{$size} | .+ )/xg;
912 my $str = shift; $str = '' if ! defined $str;
913 my $pre = shift; $pre = 4 if ! defined $pre;
914 $pre = ' ' x
$pre if $pre =~ /^\d+$/;
920 my $str = shift; $str = '' if ! defined $str;
921 my $pat = shift; $pat = '%s' if ! defined $pat;
922 return join "\n", map{ sprintf $pat, $_ } split(/\n/, $str);
926 my ($str, $pat, $global) = @_;
927 return [] if ! defined $str || ! defined $pat;
928 my @res = $global ? ($str =~ /$pat/g) : ($str =~ /$pat/);
929 return (@res >= 2) ? \
@res : (@res == 1) ? $res[0] : '';
933 my ($list, $field) = @_;
934 return defined($field)
935 ? [map {$_->[0]} sort {$a->[1] <=> $b->[1]} map {[$_, (ref $_ eq 'HASH' ? $_->{$field}
936 : UNIVERSAL
::can
($_, $field) ? $_->$field()
938 : [sort {$a <=> $b} @$list];
942 my ($str, $n, $join) = @_;
943 return if ! length $str;
944 $n = 1 if ! defined($n) || ! length $n;
945 $join = '' if ! defined $join;
946 return join $join, ($str) x
$n;
949 ### This method is a combination of my submissions along
950 ### with work from Andy Wardley, Sergey Martynoff, Nik Clayton, and Josh Rosenbaum
951 sub vmethod_replace
{
952 my ($text, $pattern, $replace, $global) = @_;
953 $text = '' unless defined $text;
954 $pattern = '' unless defined $pattern;
955 $replace = '' unless defined $replace;
956 $global = 1 unless defined $global;
958 my ($chunk, $start, $end) = @_;
959 $chunk =~ s
{ \\(\\|\
$) | \
$ (\d
+) }{
961 : ($2 > $#$start || $2 == 0) ? ''
962 : substr($text, $start->[$2], $end->[$2] - $start->[$2]);
967 $text =~ s{$pattern}{ $expand->($replace, [@-], [@+]) }eg;
969 $text =~ s{$pattern}{ $expand->($replace, [@-], [@+]) }e;
975 my ($list, $field) = @_;
976 return defined($field)
977 ? [map {$_->[0]} sort {$a->[1] cmp $b->[1]} map {[$_, lc(ref $_ eq 'HASH' ? $_->{$field}
978 : UNIVERSAL
::can
($_, $field) ? $_->$field()
980 : [map {$_->[0]} sort {$a->[1] cmp $b->[1]} map {[$_, lc $_]} @$list ]; # case insensitive
984 my ($ref, $i, $len, @replace) = @_;
985 @replace = @{ $replace[0] } if @replace == 1 && ref $replace[0] eq 'ARRAY';
987 return [splice @$ref, $i || 0, $len, @replace];
989 return [splice @$ref, $i || 0];
994 my ($str, $pat, @args) = @_;
995 $str = '' if ! defined $str;
996 return defined $pat ? [split $pat, $str, @args] : [split ' ', $str, @args];
1000 my $context = shift;
1003 return $context->process(\
$text);
1007 sub filter_redirect
{
1008 my ($context, $file, $options) = @_;
1009 my $path = $context->config->{'OUTPUT_PATH'} || $context->throw('redirect', 'OUTPUT_PATH is not set');
1015 File
::Path
::mkpath
($path) || $context->throw('redirect', "Couldn't mkpath \"$path\": $!");
1018 open (FH
, ">$path/$file") || $context->throw('redirect', "Couldn't open \"$file\": $!");
1019 if (my $bm = (! $options) ? 0 : ref($options) ? $options->{'binmode'} : $options) {
1020 if (+$bm == 1) { binmode FH
}
1021 else { binmode FH
, $bm}
1029 ###----------------------------------------------------------------###
1030 ### "here be dragons"
1032 package CGI
::Ex
::_literal
;
1033 sub call
{ ${ $_[0] } }
1035 sub does_autobox
{ 1 }
1037 package CGI
::Ex
::_autobox
;
1038 sub call
{ $_[0]->[0]->call($_[1]) }
1040 sub does_autobox
{ 1 }
1042 package CGI
::Ex
::_concat
;
1043 sub call
{ join "", grep {defined} map {ref($_) ? $_->call($_[1]) : $_} @{ $_[0] } }
1045 sub does_autobox
{ 1 }
1047 package CGI
::Ex
::_hash
;
1048 sub call
{ return {map {ref($_) ? $_->call($_[1]) : $_} @{ $_[0] }} }
1050 sub does_autobox
{ 1 }
1052 package CGI
::Ex
::_array
;
1053 sub call
{ return [map {ref($_) ? $_->call($_[1]) : $_} @{ $_[0] }] }
1055 sub does_autobox
{ 1 }
1057 package CGI
::Ex
::_set
;
1059 my ($var, $val) = @{ $_[0] };
1060 $val = CGI
::Ex
::Var
::get_exp
($val, $_[1]);
1061 CGI
::Ex
::Var
::set_exp
($var, $val, $_[1]);
1065 sub does_autobox
{ 1 }
1068 package CGI
::Ex
::_not
;
1069 sub call
{ ! (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) || '' }
1071 sub does_autobox
{ 0 }
1073 package CGI
::Ex
::_and
;
1074 sub call
{ (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) && (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1076 sub does_autobox
{ 0 }
1078 package CGI
::Ex
::_or
;
1079 sub call
{ ((ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) || (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1])) || '' }
1081 sub does_autobox
{ 0 }
1083 package CGI
::Ex
::_ifelse
;
1085 (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0])
1086 ? (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1])
1087 : (ref($_[0]->[2]) ? $_[0]->[2]->call($_[1]) : $_[0]->[2]);
1090 sub does_autobox
{ 0 }
1092 package CGI
::Ex
::_str_lt
;
1093 sub call
{ local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) lt (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1095 sub does_autobox
{ 0 }
1097 package CGI
::Ex
::_str_gt
;
1098 sub call
{ local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) gt (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1100 sub does_autobox
{ 0 }
1102 package CGI
::Ex
::_str_le
;
1103 sub call
{ local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) le (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1105 sub does_autobox
{ 0 }
1107 package CGI
::Ex
::_str_ge
;
1108 sub call
{ local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) ge (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1110 sub does_autobox
{ 0 }
1112 package CGI
::Ex
::_eq
;
1113 sub call
{ local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) eq (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1115 sub does_autobox
{ 0 }
1117 package CGI
::Ex
::_ne
;
1118 sub call
{ local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) ne (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1120 sub does_autobox
{ 0 }
1122 package CGI
::Ex
::_negate
;
1123 sub call
{ local $^W; 0 - (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) }
1125 sub does_autobox
{ 0 }
1127 package CGI
::Ex
::_pow
;
1128 sub call
{ local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) ** (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1130 sub does_autobox
{ 0 }
1132 package CGI
::Ex
::_mult
;
1133 sub call
{ local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) * (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1135 sub does_autobox
{ 0 }
1137 package CGI
::Ex
::_div
;
1138 sub call
{ local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) / (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1140 sub does_autobox
{ 0 }
1142 package CGI
::Ex
::_intdiv
;
1143 sub call
{ local $^W; int( (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) / (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) ) }
1145 sub does_autobox
{ 0 }
1147 package CGI
::Ex
::_mod
;
1148 sub call
{ local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) % (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1150 sub does_autobox
{ 0 }
1152 package CGI
::Ex
::_plus
;
1153 sub call
{ local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) + (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1155 sub does_autobox
{ 0 }
1157 package CGI
::Ex
::_subtr
;
1158 sub call
{ local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) - (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1160 sub does_autobox
{ 0 }
1162 package CGI
::Ex
::_num_lt
;
1163 sub call
{ local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) < (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1165 sub does_autobox
{ 0 }
1167 package CGI
::Ex
::_num_gt
;
1168 sub call
{ local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) > (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1170 sub does_autobox
{ 0 }
1172 package CGI
::Ex
::_num_le
;
1173 sub call
{ local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) <= (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1175 sub does_autobox
{ 0 }
1177 package CGI
::Ex
::_num_ge
;
1178 sub call
{ local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) >= (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) }
1180 sub does_autobox
{ 0 }
1182 package CGI
::Ex
::_range
;
1183 sub call
{ local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) || 0 .. (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) || 0 }
1185 sub does_autobox
{ 0 }
1187 ###----------------------------------------------------------------###
1191 Experimental. An attempt for abstracting out a fast parser and hash
1192 from CGI::Ex::Template. It is functional - but currently too
1193 cumbersome for use in CET.
This page took 0.151219 seconds and 4 git commands to generate.