package CGI::Ex::Var; =head1 NAME CGI::Ex::Var - Variable and expression parsing (exprimental) =head1 DESCRIPTION Experimental - The storage structure will change to match CGI::Ex::Template by the next release. =cut ###----------------------------------------------------------------### # Copyright 2006 - Paul Seamons # # Distributed under the Perl Artistic License without warranty # ###----------------------------------------------------------------### use strict; use vars qw( $SCALAR_OPS $FILTER_OPS $LIST_OPS $HASH_OPS $FILTERS $OPERATORS $OP_UNARY $OP_BINARY $OP_TRINARY $QR_OP $QR_OP_UNARY $QR_OP_PARENED $QR_COMMENTS $QR_AQ_NOTDOT $QR_PRIVATE $RT_NAMESPACE $RT_FILTERS $RT_CONTEXT_SUB $RT_DEBUG_UNDEF $RT_UNDEFINED_SUB $RT_OPERATOR_PRECEDENCE $RT_DURING_COMPILE $TT_FILTERS ); use constant trace => 0; BEGIN { $SCALAR_OPS = { chunk => \&vmethod_chunk, collapse => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; s/\s+/ /g; $_ }, defined => sub { 1 }, indent => \&vmethod_indent, 'format' => \&vmethod_format, hash => sub { {value => $_[0]} }, html => sub { local $_ = $_[0]; s/&/&/g; s//>/g; s/\"/"/g; $_ }, lcfirst => sub { lcfirst $_[0] }, length => sub { defined($_[0]) ? length($_[0]) : 0 }, lower => sub { lc $_[0] }, match => \&vmethod_match, null => sub { '' }, 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 $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) }, trim => sub { local $_ = $_[0]; s/^\s+//; s/\s+$//; $_ }, ucfirst => sub { ucfirst $_[0] }, upper => sub { uc $_[0] }, uri => sub { local $_ = $_[0]; s/([^;\/?:@&=+\$,A-Za-z0-9\-_.!~*\'()])/sprintf('%%%02X', ord($1))/eg; $_ }, }; $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 = { 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} }, 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} @_ ] }, nsort => \&vmethod_nsort, pop => sub { pop @{ $_[0] } }, push => sub { my $ref = shift; push @$ref, @_; return '' }, reverse => sub { [ reverse @{ $_[0] } ] }, shift => sub { shift @{ $_[0] } }, size => sub { 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] } ] }, unshift => sub { my $ref = shift; unshift @$ref, @_; return '' }, }; $HASH_OPS = { 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; '' }, keys => sub { [keys %{ $_[0] }] }, list => sub { [$_[0]] }, pairs => sub { [map { {key => $_, value => $_[0]->{$_}} } keys %{ $_[0] } ] }, nsort => sub { my $ref = shift; [sort {$ref->{$a} <=> $ref->{$b} } keys %$ref] }, size => sub { scalar keys %{ $_[0] } }, sort => sub { my $ref = shift; [sort {lc $ref->{$a} cmp lc $ref->{$b}} keys %$ref] }, values => sub { [values %{ $_[0] }] }, }; ### Runtime set variables that control lookups of various pieces of info $RT_NAMESPACE = {}; $RT_FILTERS = {}; $RT_CONTEXT_SUB = sub { {} }; $RT_DEBUG_UNDEF = 0; $RT_OPERATOR_PRECEDENCE = 0; ### setup the operator parsing $OPERATORS ||= [ # name => # order, precedence, symbols, only_in_parens, sub to create [2, 96, ['**', '^', 'pow'], 0, sub {bless(shift(), 'CGI::Ex::_pow')} ], [1, 93, ['!'], 0, sub {bless(shift(), 'CGI::Ex::_not')} ], [1, 93, ['-'], 0, sub {bless(shift(), 'CGI::Ex::_negate')} ], [2, 90, ['*'], 0, sub {bless(shift(), 'CGI::Ex::_mult')} ], [2, 90, ['/'], 0, sub {bless(shift(), 'CGI::Ex::_div')} ], [2, 90, ['div', 'DIV'], 0, sub {bless(shift(), 'CGI::Ex::_intdiv')} ], [2, 90, ['%', 'mod', 'MOD'], 0, sub {bless(shift(), 'CGI::Ex::_mod')} ], [2, 85, ['+'], 0, sub {bless(shift(), 'CGI::Ex::_plus')} ], [2, 85, ['-'], 0, sub {bless(shift(), 'CGI::Ex::_subtr')} ], [2, 85, ['_', '~'], 0, \&_concat ], [2, 80, ['<'], 0, sub {bless(shift(), 'CGI::Ex::_num_lt')} ], [2, 80, ['>'], 0, sub {bless(shift(), 'CGI::Ex::_num_gt')} ], [2, 80, ['<='], 0, sub {bless(shift(), 'CGI::Ex::_num_le')} ], [2, 80, ['>='], 0, sub {bless(shift(), 'CGI::Ex::_num_ge')} ], [2, 80, ['lt'], 0, sub {bless(shift(), 'CGI::Ex::_str_lt')} ], [2, 80, ['gt'], 0, sub {bless(shift(), 'CGI::Ex::_str_gt')} ], [2, 80, ['le'], 0, sub {bless(shift(), 'CGI::Ex::_str_le')} ], [2, 80, ['ge'], 0, sub {bless(shift(), 'CGI::Ex::_str_ge')} ], [2, 75, ['==', 'eq'], 0, sub {bless(shift(), 'CGI::Ex::_eq')} ], [2, 75, ['!=', 'ne'], 0, sub {bless(shift(), 'CGI::Ex::_ne')} ], [2, 70, ['&&'], 0, sub {bless(shift(), 'CGI::Ex::_and')} ], [2, 65, ['||'], 0, sub {bless(shift(), 'CGI::Ex::_or')} ], [2, 60, ['..'], 0, sub {bless(shift(), 'CGI::Ex::_range')} ], [3, 55, ['?', ':'], 0, sub {bless(shift(), 'CGI::Ex::_ifelse')} ], [2, 52, ['='], 1, sub {bless(shift(), 'CGI::Ex::_set')} ], [1, 50, ['not', 'NOT'], 0, sub {bless(shift(), 'CGI::Ex::_not')} ], [2, 45, ['and', 'AND'], 0, sub {bless(shift(), 'CGI::Ex::_and')} ], [2, 40, ['or', 'OR'], 0, sub {bless(shift(), 'CGI::Ex::_or')} ], ]; $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}; 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+$/} @_; $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(); $QR_COMMENTS = '(?-s: \# .* \s*)*'; $QR_AQ_NOTDOT = "(?! \\s* $QR_COMMENTS \\.)"; $QR_PRIVATE = qr/^_/; }; ###----------------------------------------------------------------### sub _var { return bless(shift(), __PACKAGE__ ) } sub _literal { return bless(shift(), 'CGI::Ex::_literal') } sub _hash { return bless(shift(), 'CGI::Ex::_hash' ) } sub _array { return bless(shift(), 'CGI::Ex::_array' ) } sub _concat { return bless(shift(), 'CGI::Ex::_concat' ) } sub _autobox { return bless(shift(), 'CGI::Ex::_autobox') } sub _not { return bless(shift(), 'CGI::Ex::_not' ) } sub throw { require CGI::Ex::Template; CGI::Ex::Template->throw(@_); } ###----------------------------------------------------------------### sub parse_exp { my $str_ref = shift; my $ARGS = shift || {}; ### allow for custom auto_quoting (such as hash constructors) if ($ARGS->{'auto_quote'}) { if ($$str_ref =~ $ARGS->{'auto_quote'}) { my $str = $1; substr($$str_ref, 0, length($str), ''); $$str_ref =~ s{ ^ \s* $QR_COMMENTS }{}ox; return $str; ### allow for auto-quoted $foo or ${foo.bar} type constructs } elsif ($$str_ref =~ s{ ^ \$ (\w+ (?:\.\w+)*) \b \s* $QR_COMMENTS }{}ox || $$str_ref =~ s{ ^ \$\{ \s* ([^\}]+) \} \s* $QR_COMMENTS }{}ox) { my $name = $1; return parse_exp(\$name); } } 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) { return if $ARGS->{'auto_quote'}; # auto_quoted thing was too complicated $has_unary = $1; } my @var; my $is_literal; my $is_construct; my $is_namespace; ### allow for numbers if ($copy =~ s{ ^ ( (?:\d*\.\d+ | \d+) ) \s* $QR_COMMENTS }{}ox) { my $number = $1; push @var, _literal(\ $number); $is_literal = 1; ### looks like a normal variable start } elsif ($copy =~ s{ ^ (\w+) \s* $QR_COMMENTS }{}ox) { push @var, $1; $is_namespace = 1 if $RT_NAMESPACE->{$1}; ### allow for literal strings } elsif ($copy =~ s{ ^ ([\"\']) (|.*?[^\\]) \1 \s* $QR_COMMENTS }{}sox) { if ($1 eq "'") { # no interpolation on single quoted strings my $str = $2; $str =~ s{ \\\' }{\'}xg; push @var, _literal(\ $str); $is_literal = 1; } else { my $str = $2; $str =~ s/\\n/\n/g; $str =~ s/\\t/\t/g; $str =~ s/\\r/\r/g; $str =~ s/\\([\"\$])/$1/g; my @pieces = $ARGS->{'auto_quote'} ? split(m{ (\$\w+ | \$\{ [^\}]+ \}) }x, $str) # autoquoted items get a single $\w+ - no nesting : split(m{ (\$\w+ (?:\.\w+)* | \$\{ [^\}]+ \}) }x, $str); my $n = 0; foreach my $piece (@pieces) { next if ! ($n++ % 2); next if $piece !~ m{ ^ \$ (\w+ (?:\.\w+)*) $ }x && $piece !~ m{ ^ \$\{ \s* ([^\}]+) \} $ }x; my $name = $1; $piece = parse_exp(\$name); } @pieces = grep {defined && length} @pieces; if (@pieces == 1 && ! ref $pieces[0]) { push @var, _literal(\ $pieces[0]); $is_literal = 1; } elsif (! @pieces) { my $str = ''; push @var, _literal(\ $str); $is_literal = 1; } else { push @var, _concat(\@pieces); $is_construct = 1; } } if ($ARGS->{'auto_quote'}){ $$str_ref = $copy; return ${ $var[0] } if $is_literal; return _var([@var, 0]); } ### allow for leading $foo or ${foo.bar} type constructs } elsif ($copy =~ s{ ^ \$ (\w+) \b \s* $QR_COMMENTS }{}ox || $copy =~ s{ ^ \$\{ \s* ([^\}]+) \} \s* $QR_COMMENTS }{}ox) { my $name = $1; push @var, parse_exp(\$name); ### looks like an array constructor } elsif ($copy =~ s{ ^ \[ \s* $QR_COMMENTS }{}ox) { local $RT_OPERATOR_PRECEDENCE = 0; # reset presedence my $arrayref = []; while (defined(my $var = parse_exp(\$copy))) { push @$arrayref, $var; $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox; } $copy =~ s{ ^ \] \s* $QR_COMMENTS }{}ox || throw('parse.missing.square', "Missing close \]", undef, length($$str_ref) - length($copy)); push @var, _array($arrayref); $is_construct = 1; ### looks like a hash constructor } elsif ($copy =~ s{ ^ \{ \s* $QR_COMMENTS }{}ox) { local $RT_OPERATOR_PRECEDENCE = 0; # reset precedence my $hashref = []; while (defined(my $key = parse_exp(\$copy, {auto_quote => qr{ ^ (\w+) $QR_AQ_NOTDOT }xo}))) { $copy =~ s{ ^ = >? \s* $QR_COMMENTS }{}ox; my $val = parse_exp(\$copy); push @$hashref, $key, $val; $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox; } $copy =~ s{ ^ \} \s* $QR_COMMENTS }{}ox || throw('parse.missing.curly', "Missing close \} ($copy)", undef, length($$str_ref) - length($copy)); push @var, _hash($hashref); $is_construct = 1; ### looks like a paren grouper } elsif ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) { local $RT_OPERATOR_PRECEDENCE = 0; # reset precedence my $var = parse_exp(\$copy, {allow_parened_ops => 1}); $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox || throw('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy)); push @var, $var; $is_construct = 1; ### nothing to find - return failure } else { return; } return if $ARGS->{'auto_quote'}; # auto_quoted thing was too complicated ### looks for args for the initial if ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) { local $RT_OPERATOR_PRECEDENCE = 0; # reset precedence my $args = parse_args(\$copy); $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox || throw('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy)); push @var, $args; } else { push @var, 0; } ### allow for nested items while ($copy =~ s{ ^ ( \.(?!\.) | \|(?!\|) ) \s* $QR_COMMENTS }{}ox) { push(@var, $1) if ! $ARGS->{'no_dots'}; ### allow for interpolated variables in the middle - one.$foo.two or one.${foo.bar}.two if ($copy =~ s{ ^ \$(\w+) \s* $QR_COMMENTS }{}ox || $copy =~ s{ ^ \$\{ \s* ([^\}]+)\} \s* $QR_COMMENTS }{}ox) { my $name = $1; my $var = parse_exp(\$name); push @var, $var; } elsif ($copy =~ s{ ^ (\w+) \s* $QR_COMMENTS }{}ox) { push @var, $1; } else { throw('parse', "Not sure how to continue parsing on \"$copy\" ($$str_ref)"); } ### looks for args for the nested item if ($copy =~ s{ ^ \( \s* $QR_COMMENTS }{}ox) { local $RT_OPERATOR_PRECEDENCE = 0; # reset precedence my $args = parse_args(\$copy); $copy =~ s{ ^ \) \s* $QR_COMMENTS }{}ox || throw('parse.missing.paren', "Missing close \)", undef, length($$str_ref) - length($copy)); push @var, $args; } else { push @var, 0; } } ### flatten literals and constants as much as possible my $var; if (@var == 2) { if ($is_literal) { $var = ${ $var[0] }; } elsif ($is_construct) { $var = $var[0]; } else { $var = _var(\@var); } } else { if ($is_construct && ! $var[0]->does_autobox) { $var[0] = _autobox([$var[0]]); } if ($is_namespace) { # attempt to "fold" constant variables into the parse tree local $RT_DURING_COMPILE = 1; $var = _var(\@var)->call({}); } else { $var = _var(\@var); } } ### allow for all "operators" if (! $RT_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) ) { local $RT_OPERATOR_PRECEDENCE = 1; my $op = $1; my $var2 = parse_exp(\$copy); ### allow for unary operator precedence if ($has_unary && (($OP_BINARY->{$op} || $OP_TRINARY->{$op})->[1] < $OP_UNARY->{$has_unary}->[1])) { if ($tree) { if (@$tree == 2) { # only one operator - keep simple things fast $var = $OP_BINARY->{$tree->[0]}->[4]->([$var, $tree->[1]]); } else { unshift @$tree, $var; $var = apply_precedence($tree, $found); } undef $tree; undef $found; } $var = $OP_UNARY->{$has_unary}->[4]->([$var]); undef $has_unary; } ### add the operator to the tree push (@{ $tree ||= [] }, $op, $var2); my $ref = $OP_BINARY->{$op} || $OP_TRINARY->{$op}; $found->{$op} = $ref->[1]; } ### if we found operators - tree the nodes by operator precedence if ($tree) { if (@$tree == 2 && $OP_BINARY->{$tree->[0]}) { # only one operator - keep simple things fast $var = $OP_BINARY->{$tree->[0]}->[4]->([$var, $tree->[1]]); } else { unshift @$tree, $var; $var = apply_precedence($tree, $found); } } } ### allow for unary on non-chained variables if ($has_unary) { $var = $OP_UNARY->{$has_unary}->[4]->([$var]); } $$str_ref = $copy; # commit the changes return $var; } ### this is used to put the parsed variables into the correct operations tree sub apply_precedence { my ($tree, $found) = @_; my @var; my $trees; ### look at the operators we found in the order we found them for my $op (sort {$found->{$a} <=> $found->{$b}} keys %$found) { local $found->{$op}; delete $found->{$op}; my @trees; my @trinary; ### 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; push @trees, [splice @$tree, 0, $i, ()]; # everything up to the operator push @trinary, $tree->[0] if $is_trinary; shift @$tree; # pull off the operator $i = -1; } next if ! @trees; # this iteration didn't have the current operator push @trees, $tree if scalar @$tree; # elements after last operator ### now - for this level split on remaining operators, or add the variable to the tree for my $node (@trees) { if (@$node == 1) { $node = $node->[0]; # single item - its not a tree } elsif (@$node == 3) { my $ref = $OP_BINARY->{$node->[1]} || $OP_TRINARY->{$node->[1]}; $node = $ref->[4]->([$node->[0], $node->[2]]); # single operator - put it straight on } else { $node = apply_precedence($node, $found); # more complicated - recurse } } ### return binary if ($OP_BINARY->{$op}) { my $val = $trees[0]; $val = $OP_BINARY->{$op}->[4]->([$val, $trees[$_]]) for 1 .. $#trees; return $val; } ### return simple trinary if (@trinary == 2) { return $OP_TRINARY->{$op}->[4]->(\@trees); } ### 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 found pair of operators my $node = $OP_TRINARY->{$op}->[4]->([@trees[$i .. $i + 2]]); splice @trees, $i, 3, $node; # replace the previous 3 pieces with the one new node } } return $trees[0]; # at this point the trinary has been reduced to a single operator } throw('parse', "Couldn't apply precedence"); } ### look for arguments - both positional and named sub parse_args { my $str_ref = shift; my $ARGS = shift || {}; my $copy = $$str_ref; my @args; my @named; while (length $$str_ref) { my $copy = $$str_ref; if (defined(my $name = parse_exp(\$copy, {auto_quote => qr{ ^ (\w+) $QR_AQ_NOTDOT }xo})) && $copy =~ s{ ^ = >? \s* $QR_COMMENTS }{}ox) { throw('parse', 'Named arguments not allowed') if $ARGS->{'positional_only'}; my $val = parse_exp(\$copy); $copy =~ s{ ^ , \s* $QR_COMMENTS }{}ox; push @named, $name, $val; $$str_ref = $copy; } elsif (defined(my $arg = parse_exp($str_ref))) { push @args, $arg; $$str_ref =~ s{ ^ , \s* $QR_COMMENTS }{}ox; } else { last; } } ### allow for named arguments to be added also push @args, _hash(\@named) if scalar @named; return \@args; } sub get_exp { ref($_[0]) ? $_[0]->call($_[1]) : $_[0] } sub set_exp { my $var = shift; $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' %]) return $var->set($_[0], $_[1]); } sub dump_parse { my $str = shift; require Data::Dumper; return Data::Dumper::Dumper(parse_exp(\$str)); } sub dump_get { my ($str, $hash) = @_; require Data::Dumper; return Data::Dumper::Dumper(get_exp(parse_exp(\$str), $hash)); } sub dump_set { my ($str, $val, $hash) = @_; $hash ||= {}; require Data::Dumper; set_exp(parse_exp(\$str), $val, $hash); return Data::Dumper::Dumper($hash); } sub vivify_args { my $vars = shift; my $hash = shift; return [map {get_exp($_, $hash)} @$vars]; } ###----------------------------------------------------------------### sub new { my $class = shift; return bless $_[0], $class; } sub does_autobox { 0 } sub call { my $self = shift; my $hash = shift || {}; my $i = 0; ### determine the top level of this particular variable access my $ref = $self->[$i++]; my $args = $self->[$i++]; warn "CGI::Ex::Var::call: begin \"$ref\"\n" if trace; if (ref $ref) { if ($ref->does_autobox) { $ref = $ref->call($hash); } else { $ref = $ref->call($hash); return if $ref =~ $QR_PRIVATE; # don't allow vars that begin with _ $ref = $hash->{$ref}; } } else { if ($RT_DURING_COMPILE) { $ref = $RT_NAMESPACE->{$ref}; } else { return if $ref =~ $QR_PRIVATE; # don't allow vars that begin with _ $ref = $hash->{$ref}; } } my %seen_filters; while (defined $ref) { ### check at each point if the returned thing was a code if (UNIVERSAL::isa($ref, 'CODE')) { my @results = $ref->($args ? (map {get_exp($_, $hash)} @$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 { $ref = undef; last; } } ### descend one chained level last if $i >= $#$self; my $was_dot_call = $self->[$i++] eq '.'; my $name = $self->[$i++]; my $args = $self->[$i++]; warn "CGI::Ex::Var::get_exp: nested \"$name\"\n" if trace; ### allow for named portions of a variable name (foo.$name.bar) if (ref $name) { $name = $name->call($hash); if (! defined $name) { $ref = undef; last; } } if ($name =~ $QR_PRIVATE) { # don't allow vars that begin with _ $ref = undef; last; } ### 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 ? (map {get_exp($_, $hash)} @$args) : ()); } elsif ($LIST_OPS->{$name}) { # auto-promote to list and use list op $ref = $LIST_OPS->{$name}->([$ref], $args ? (map {get_exp($_, $hash)} @$args) : ()); } elsif (my $filter = $RT_FILTERS->{$name} # filter configured in Template args || $FILTER_OPS->{$name} # predefined filters in CET || (UNIVERSAL::isa($name, 'CODE') && $name) # looks like a filter sub passed in the stash || list_filters()->{$name}) { # filter defined in Template::Filters if (UNIVERSAL::isa($filter, 'CODE')) { $ref = eval { $filter->($ref) }; # non-dynamic filter - no args if (my $err = $@) { throw('filter', $err) if ref($err) !~ /Template::Exception$/; die $err; } } elsif (! UNIVERSAL::isa($filter, 'ARRAY')) { throw('filter', "invalid FILTER entry for '$name' (not a CODE ref)"); } elsif (@$filter == 2 && UNIVERSAL::isa($filter->[0], 'CODE')) { # these are the TT style filters eval { my $sub = $filter->[0]; if ($filter->[1]) { # it is a "dynamic filter" that will return a sub ($sub, my $err) = $sub->($RT_CONTEXT_SUB->(), $args ? (map {get_exp($_, $hash)} @$args) : ()); if (! $sub && $err) { throw('filter', $err) if ref($err) !~ /Template::Exception$/; die $err; } elsif (! UNIVERSAL::isa($sub, 'CODE')) { throw('filter', "invalid FILTER for '$name' (not a CODE ref)") if ref($sub) !~ /Template::Exception$/; die $sub; } } $ref = $sub->($ref); }; if (my $err = $@) { throw('filter', $err) if ref($err) !~ /Template::Exception$/; die $err; } } else { # this looks like our vmethods turned into "filters" (a filter stored under a name) throw('filter', 'Recursive filter alias \"$name\"') if $seen_filters{$name} ++; $self = [$name, 0, '|', @$filter, @{$self}[$i..$#$self]]; # splice the filter into our current tree $i = 2; } if (scalar keys %seen_filters && $seen_filters{$self->[$i - 5] || ''}) { throw('filter', "invalid FILTER entry for '".$self->[$i - 5]."' (not a CODE ref)"); } } else { $ref = undef; } } else { ### method calls on objects if (UNIVERSAL::can($ref, 'can')) { my @args = $args ? (map {get_exp($_, $hash)} @$args) : (); my @results = eval { $ref->$name(@args) }; if ($@) { die $@ if ref $@ || $@ !~ /Can\'t locate object method/; } elsif (defined $results[0]) { $ref = ($#results > 0) ? \@results : $results[0]; next; } elsif (defined $results[1]) { die $results[1]; # TT behavior - why not just throw ? } else { $ref = undef; last; } # didn't find a method by that name - so fail down to hash and array access } ### hash member access if (UNIVERSAL::isa($ref, 'HASH')) { if ($was_dot_call && exists($ref->{$name}) ) { $ref = $ref->{$name}; } elsif ($HASH_OPS->{$name}) { $ref = $HASH_OPS->{$name}->($ref, $args ? (map {get_exp($_, $hash)} @$args) : ()); } elsif ($RT_DURING_COMPILE) { return $self; # abort - can't fold namespace variable } else { $ref = undef; } ### array access } elsif (UNIVERSAL::isa($ref, 'ARRAY')) { if ($name =~ /^\d+$/) { $ref = ($name > $#$ref) ? undef : $ref->[$name]; } else { $ref = (! $LIST_OPS->{$name}) ? undef : $LIST_OPS->{$name}->($ref, $args ? (map {get_exp($_, $hash)} @$args) : ()); } } } } # end of while ### allow for undefinedness if (! defined $ref) { if ($RT_DEBUG_UNDEF) { my $chunk = $self->[$i - 2]; $chunk = $chunk->call($hash) if ref $chunk; die "$chunk is undefined\n"; } else { $ref = $self->undefined_any($self); } } return $ref; } sub undefined_any { $RT_UNDEFINED_SUB ? $RT_UNDEFINED_SUB->(@_) : undef } sub set { my ($self, $val, $hash) = @_; my $i = 0; ### determine the top level of this particular variable access my $ref = $self->[$i++]; my $args = $self->[$i++]; if (ref $ref) { $ref = $ref->call($hash); return if ! defined $ref; } return if $ref =~ $QR_PRIVATE; # don't allow vars that begin with _ if ($#$self <= $i) { $hash->{$ref} = $val; return; } else { $ref = $hash->{$ref} ||= {}; } ### let the top level thing be a code block return if UNIVERSAL::isa($ref, 'CODE'); ### vivify the chained levels while (defined $ref && $#$self > $i) { my $was_dot_call = $self->[$i++] eq '.'; my $name = $self->[$i++]; my $args = $self->[$i++]; ### allow for named portions of a variable name (foo.$name.bar) if (ref $name) { $name = $name->call($hash); if (! defined $name) { $ref = undef; last; } } if ($name =~ $QR_PRIVATE) { # don't allow vars that begin with _ return; } ### method calls on objects if (UNIVERSAL::can($ref, 'can')) { my $lvalueish; my @args = $args ? (map {get_exp($_, $hash)} @$args) : (); if ($i >= $#$self) { $lvalueish = 1; push @args, $val; } my @results = eval { $ref->$name(@args) }; if ($@) { die $@ if ref $@ || $@ !~ /Can\'t locate object method/; } elsif (defined $results[0]) { $ref = ($#results > 0) ? \@results : $results[0]; } elsif (defined $results[1]) { die $results[1]; # TT behavior - why not just throw ? } else { $ref = undef; } return if $lvalueish; next; } ### hash member access if (UNIVERSAL::isa($ref, 'HASH')) { if ($#$self <= $i) { $ref->{$name} = $val; return; } else { $ref = $ref->{$name} ||= {}; next; } ### array access } elsif (UNIVERSAL::isa($ref, 'ARRAY')) { if ($name =~ /^\d+$/) { if ($#$self <= $i) { $ref->[$name] = $val; return; } else { $ref = $ref->[$name] ||= {}; next; } } else { 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 ? (map {get_exp($_, $hash)} @$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; } ###----------------------------------------------------------------### ### filters and vmethod definition sub list_filters { return $TT_FILTERS ||= eval { require Template::Filters; $Template::Filters::FILTERS } || {}; } sub vmethod_chunk { my $str = shift; my $size = shift || 1; my @list; if ($size < 0) { # chunk from the opposite end $str = reverse $str; $size = -$size; unshift(@list, scalar reverse $1) while $str =~ /( .{$size} | .+ )/xg; } else { push(@list, $1) while $str =~ /( .{$size} | .+ )/xg; } return \@list; } sub vmethod_indent { my $str = shift; $str = '' if ! defined $str; my $pre = shift; $pre = 4 if ! defined $pre; $pre = ' ' x $pre if $pre =~ /^\d+$/; $str =~ s/^/$pre/mg; return $str; } 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); } 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] : ''; } sub vmethod_nsort { my ($list, $field) = @_; return defined($field) ? [map {$_->[0]} sort {$a->[1] <=> $b->[1]} map {[$_, (ref $_ eq 'HASH' ? $_->{$field} : UNIVERSAL::can($_, $field) ? $_->$field() : $_)]} @$list ] : [sort {$a <=> $b} @$list]; } sub vmethod_repeat { my ($str, $n, $join) = @_; return if ! length $str; $n = 1 if ! defined($n) || ! length $n; $join = '' if ! defined $join; return join $join, ($str) x $n; } ### This method is a combination of my submissions along ### with work from Andy Wardley, Sergey Martynoff, Nik Clayton, and Josh Rosenbaum sub vmethod_replace { my ($text, $pattern, $replace, $global) = @_; $text = '' unless defined $text; $pattern = '' unless defined $pattern; $replace = '' unless defined $replace; $global = 1 unless defined $global; my $expand = sub { my ($chunk, $start, $end) = @_; $chunk =~ s{ \\(\\|\$) | \$ (\d+) }{ $1 ? $1 : ($2 > $#$start || $2 == 0) ? '' : substr($text, $start->[$2], $end->[$2] - $start->[$2]); }exg; $chunk; }; if ($global) { $text =~ s{$pattern}{ $expand->($replace, [@-], [@+]) }eg; } else { $text =~ s{$pattern}{ $expand->($replace, [@-], [@+]) }e; } return $text; } sub vmethod_sort { my ($list, $field) = @_; return defined($field) ? [map {$_->[0]} sort {$a->[1] cmp $b->[1]} map {[$_, lc(ref $_ eq 'HASH' ? $_->{$field} : UNIVERSAL::can($_, $field) ? $_->$field() : $_)]} @$list ] : [map {$_->[0]} sort {$a->[1] cmp $b->[1]} map {[$_, lc $_]} @$list ]; # case insensitive } sub vmethod_splice { my ($ref, $i, $len, @replace) = @_; @replace = @{ $replace[0] } if @replace == 1 && ref $replace[0] eq 'ARRAY'; if (defined $len) { return [splice @$ref, $i || 0, $len, @replace]; } else { return [splice @$ref, $i || 0]; } } sub vmethod_split { my ($str, $pat, @args) = @_; $str = '' if ! defined $str; return defined $pat ? [split $pat, $str, @args] : [split ' ', $str, @args]; } sub filter_eval { my $context = shift; return sub { my $text = shift; return $context->process(\$text); }; } sub filter_redirect { my ($context, $file, $options) = @_; my $path = $context->config->{'OUTPUT_PATH'} || $context->throw('redirect', 'OUTPUT_PATH is not set'); return sub { my $text = shift; if (! -d $path) { require File::Path; File::Path::mkpath($path) || $context->throw('redirect', "Couldn't mkpath \"$path\": $!"); } local *FH; open (FH, ">$path/$file") || $context->throw('redirect', "Couldn't open \"$file\": $!"); if (my $bm = (! $options) ? 0 : ref($options) ? $options->{'binmode'} : $options) { if (+$bm == 1) { binmode FH } else { binmode FH, $bm} } print FH $text; close FH; return ''; }; } ###----------------------------------------------------------------### ### "here be dragons" package CGI::Ex::_literal; sub call { ${ $_[0] } } sub set {} sub does_autobox { 1 } package CGI::Ex::_autobox; sub call { $_[0]->[0]->call($_[1]) } sub set {} sub does_autobox { 1 } package CGI::Ex::_concat; sub call { join "", grep {defined} map {ref($_) ? $_->call($_[1]) : $_} @{ $_[0] } } sub set {} sub does_autobox { 1 } package CGI::Ex::_hash; sub call { return {map {ref($_) ? $_->call($_[1]) : $_} @{ $_[0] }} } sub set {} sub does_autobox { 1 } package CGI::Ex::_array; sub call { return [map {ref($_) ? $_->call($_[1]) : $_} @{ $_[0] }] } sub set {} sub does_autobox { 1 } package CGI::Ex::_set; sub call { my ($var, $val) = @{ $_[0] }; $val = CGI::Ex::Var::get_exp($val, $_[1]); CGI::Ex::Var::set_exp($var, $val, $_[1]); return $val; } sub set {} sub does_autobox { 1 } package CGI::Ex::_not; sub call { ! (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) || '' } sub set {} sub does_autobox { 0 } package CGI::Ex::_and; sub call { (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) && (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) } sub set {} sub does_autobox { 0 } package CGI::Ex::_or; sub call { ((ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) || (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1])) || '' } sub set {} sub does_autobox { 0 } package CGI::Ex::_ifelse; sub call { (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) ? (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) : (ref($_[0]->[2]) ? $_[0]->[2]->call($_[1]) : $_[0]->[2]); } sub set {} sub does_autobox { 0 } package CGI::Ex::_str_lt; sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) lt (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) } sub set {} sub does_autobox { 0 } package CGI::Ex::_str_gt; sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) gt (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) } sub set {} sub does_autobox { 0 } package CGI::Ex::_str_le; sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) le (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) } sub set {} sub does_autobox { 0 } package CGI::Ex::_str_ge; sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) ge (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) } sub set {} sub does_autobox { 0 } package CGI::Ex::_eq; sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) eq (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) } sub set {} sub does_autobox { 0 } package CGI::Ex::_ne; sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) ne (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) } sub set {} sub does_autobox { 0 } package CGI::Ex::_negate; sub call { local $^W; 0 - (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) } sub set {} sub does_autobox { 0 } package CGI::Ex::_pow; sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) ** (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) } sub set {} sub does_autobox { 0 } package CGI::Ex::_mult; sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) * (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) } sub set {} sub does_autobox { 0 } package CGI::Ex::_div; sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) / (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) } sub set {} sub does_autobox { 0 } package CGI::Ex::_intdiv; sub call { local $^W; int( (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) / (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) ) } sub set {} sub does_autobox { 0 } package CGI::Ex::_mod; sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) % (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) } sub set {} sub does_autobox { 0 } package CGI::Ex::_plus; sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) + (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) } sub set {} sub does_autobox { 0 } package CGI::Ex::_subtr; sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) - (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) } sub set {} sub does_autobox { 0 } package CGI::Ex::_num_lt; sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) < (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) } sub set {} sub does_autobox { 0 } package CGI::Ex::_num_gt; sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) > (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) } sub set {} sub does_autobox { 0 } package CGI::Ex::_num_le; sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) <= (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) } sub set {} sub does_autobox { 0 } package CGI::Ex::_num_ge; sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) >= (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) } sub set {} sub does_autobox { 0 } package CGI::Ex::_range; sub call { local $^W; (ref($_[0]->[0]) ? $_[0]->[0]->call($_[1]) : $_[0]->[0]) || 0 .. (ref($_[0]->[1]) ? $_[0]->[1]->call($_[1]) : $_[0]->[1]) || 0 } sub set {} sub does_autobox { 0 } ###----------------------------------------------------------------### =head1 DESCRIPTION Experimental. An attempt for abstracting out a fast parser and hash from CGI::Ex::Template. It is functional - but currently too cumbersome for use in CET. =cut 1;