File Coverage

blib/lib/HTML/Template/Plugin/Dot.pm

Criterion	Covered	Total	%
statement	119	124	95.9
branch	71	88	80.6
condition	31	39	79.4
subroutine	12	12	100.0
pod			n/a
total	233	263	88.5

package HTML::Template::Plugin::Dot;
use vars qw/$VERSION/;
$VERSION = '1.00';
use strict;
use Scalar::Util qw/blessed/;

use Carp;
use Data::Dumper;
use Regexp::Common qw/balanced delimited number/;
use Scalar::Util qw/reftype/;
use base 'Exporter';

sub import {
        # my $caller = scalar(caller);
        HTML::Template::Pluggable->add_trigger('middle_param', \&_dot_notation);
		goto &Exporter::import;
}

sub _dot_notation {
    my $self = shift;
    my $options = $self->{options};
    my $param_map = $self->{param_map};

	# carp("dot_notation called for $_[0]");
	# carp("param map: ", Dumper($param_map));
    # @_ has already been setup for us by the time we're called.

    for (my $x = 0; $x <= $#_; $x += 2) {
        my $param = $options->{case_sensitive} ? $_[$x] : lc $_[$x];
        my $value = $_[($x + 1)];

        # necessary to cooperate with plugin system
        next if ($self->{param_map_done}{$param} and not $self->{num_vars_left_in_loop});

        my ($exists,@dot_matches) = _exists_in_tmpl($param_map, $param);
        # We don't have to worry about "die on bad params", because that will be handled
        # by HTML::Template's param().
        next unless $exists;

        my $value_type = ref($value);
        if (@dot_matches) {
            for (@dot_matches) {
				# carp("calling _param_to_tmpl for $_, $param, $value");
                my $value_for_tmpl = _param_to_tmpl($self,$_,$param,$value);
                my $dot_value_type = ref($value_for_tmpl);
				# carp("_param_to_tmpl returned '$value_for_tmpl' for '$_', '$param', '$value'");
                unless (defined($dot_value_type) and length($dot_value_type) and ($dot_value_type eq 'ARRAY'
                       or (ref($value_for_tmpl) and (ref($value_for_tmpl) !~ /^(CODE)|(HASH)|(SCALAR)$/) and $value_for_tmpl->isa('ARRAY')))) {
					(ref($param_map->{$_}) eq 'HTML::Template::VAR') or
						croak("HTML::Template::param() : attempt to set parameter '$param' with a scalar - parameter is not a TMPL_VAR!");
                    ${$param_map->{$_}} = $value_for_tmpl;
                }
				else {
					(ref($param_map->{$_}) eq 'HTML::Template::LOOP') or
						croak("HTML::Template::param() : attempt to set parameter '$param' with an array ref - parameter is not a TMPL_LOOP!");
					$param_map->{$_}[HTML::Template::LOOP::PARAM_SET] = $value_for_tmpl;
				}

                # Necessary for plugin system compatibility
                $self->{num_vars_left_in_loop} -= 1;
                $self->{param_map_done}{$param} = $value; # store the object for future reference
            }
        }
        # We still need to care about tmpl_loops that aren't dot matches so we can adjust their loops
        elsif (defined($value_type) and length($value_type) and ($value_type eq 'ARRAY'
                            or ((ref($value) !~ /^(CODE)|(HASH)|(SCALAR)$/) and $value->isa('ARRAY')))) {
			(ref($param_map->{$param}) eq 'HTML::Template::LOOP') or
				croak("HTML::Template::param() : attempt to set parameter '$param' with an array ref - parameter is not a TMPL_LOOP!");

			#  TODO: Use constant names instead of "0"
			$self->{num_vars_left_in_loop} += keys %{ $param_map->{$param}[HTML::Template::LOOP::TEMPLATE_HASH]{'0'}{'param_map'} } if exists $param_map->{$param}[HTML::Template::LOOP::TEMPLATE_HASH]{'0'};

		}
		else {
			(ref($param_map->{$param}) eq 'HTML::Template::VAR') or
				croak("HTML::Template::param() : attempt to set parameter '$param' with a scalar - parameter is not a TMPL_VAR!");
			# intetionally /don't/ set the values for non-dot notation  params,
			# and don't mark them as done, just that they exist.
			$self->{num_vars_left_in_loop} -= 1;
		}
	}
}

# Check to see if a param exists in the template, with support for dot notation
# returns an an array
#  - bool for any matches
#  - array of keys with dot notation that matched.
sub _exists_in_tmpl {
    my ($param_map,$param) = @_;
    return 1 if exists $param_map->{$param};
    if (my @matching_dot_tokes = grep { /^$param\./ } keys %$param_map) { # (?:\s*[fF][oO][rR]\s+[_a-z]\w*\s+[Ii][nN]\s+)? after the ^ can be used for supporting "for cd in artist.cds" style loops
        return (1, @matching_dot_tokes);
    }
    else {
        return undef;
    }
}

# =head2 _param_to_tmpl()
#
#  my $result = _param_to_tmpl($pluggable,$tmpl_token_name,$param_name,$param_value);
#
# Returns the right thing to put in the template given a token name, a param name
# and a param value. Returns undef if this template token name and param name
# don't match.
#
# The template token name supports the dot notation, which means that method
# calls and nested hashes are expanded.
#
# However, first we check for a literal match, for backwards compatibility with
# HTML::Template.
#
# =cut

sub _param_to_tmpl {
    my ($self,$toke_name,$param_name,$param_value) = @_;

	# carp("_param_to_tmpl called for '$toke_name', '$param_name', '$param_value'");
    # This clause may not be needed because the non-dot-notation
    # cases are handled elsewhere.
    if ($toke_name eq $param_name) {
		# carp("toke equals param: $toke_name == $param_name");
        return $param_value;
    }
    elsif (my ($one, $the_rest) = split /\./, $toke_name, 2) {
		# my $loopmap_name = 'this'; # default for mapping array elements for loop vars
		# $loopmap_name = $1 if $one =~ s/^\s*[fF][oO][rR]\s+([_a-z]\w*)\s+[Ii][nN]\s+//; the "for x in y" style
        if ($one eq $param_name) {
			my $loopmap_name = 'this'; # default for mapping array elements for loop vars
			$loopmap_name = $1 if $the_rest =~ s/\s*:\s*([_a-z]\w*)\s*$//;

            # NOTE: we do the can-can because UNIVSERAL::isa($something, 'UNIVERSAL')
            # doesn't appear to work with CGI, returning true for the first call
            # and false for all subsequent calls.
            # This is exactly what TT does.

			# Rhesa (Thu Aug  4 18:33:30 CEST 2005)
			# Patch for mixing method calls and attribute access mixing,
			# and optional parameter lists!
			#
			# First we're setting $ref to $param_value
			#
			# We're going to loop over $the_rest by finding anything that matches
			# - a valid identifier $id ( [_a-z]\w* )
			# - optionally followed by something resembling an argument list $data
			# - optionally followed by a dot or $
			# then we're checking if
			# - $ref is an object
			#	- if we can call $id on it
			#	  - in this case we further parse the argument list for strings
			#	  or numbers or references to other h-t params
			#	- or if it's an attribute
			# - or a hashref and we have no $data
			# We'll use the result of that operation for $ref as long as there are dots
			# followed by an identifier

			my $ref = $param_value;
            $self->{param_map_done}{$one} ||= $ref;
			my $want_loop = ref($self->{param_map}{$toke_name}) eq 'HTML::Template::LOOP';
			my(@results); # keeps return values from dot operations
		THE_REST:
			while( $the_rest =~ s/^
						([_a-z]\w*)				# an identifier
						($RE{balanced})?		# optional param list
						(?:\.|$)				# dot or end of string
					//xi ) {
				my ($id, $data) = ($1, $2);
				if (ref($ref) and blessed($ref)) {
					# carp("$ref is an object, and its ref=", ref($ref), Dumper($ref));
					if($ref->can($id)) {
						my @args = ();
                        # carp "Calling $id on ", ref($ref), " with $data";
						if($data) {
							$data =~ s/^\(// and $data =~ s/\)$//;
							while( $data ) {
								if ($data =~ s/
									^\s*
									(
										$RE{delimited}{-delim=>q{'"`}}	# a string
										|
										$RE{num}{real}					# or a number
									)
									(?:,\s*)?
									//xi
								) {
									my $m = $1;
									$m =~ s/^["'`]//; $m =~ s/["'`]$//;
                                    # carp "found string or numeric argument $m";
									push @args, $m;
								}
								elsif( $data =~ s/
									^\s*
									(									# ($1) a sub-expression of the form "object.method(args)"
										([_a-z]\w*)						# ($2) the object in question
										(?:
											\.
											[_a-z]\w*					# method name
											$RE{balanced}?				# optional argument list
										)*
									)
									(?:,\s*)?
									//xi
								) {
									my ($m, $o) = ($1, $2);
									# carp("found subexpression '$m' with '$o'");
                                    # carp Dumper($self->{param_map}), Dumper($self->{param_map_done});
									if( exists($self->{param_map}->{$m}) ) {
										my $prev = $self->param($m);
										# carp("found '$prev' for '$m' in param_map");
										push @args, $prev;
									}
									elsif( exists($self->{param_map_done}{$o}) ) {
										my $prev = _param_to_tmpl($self, $m, $o, $self->{param_map_done}{$o});
										# carp("found '$prev' for '$o' in param_map_done");
										push @args, $prev;
									}
									else {
										croak("Attempt to reference nonexisting parameter '$m' in argument list to '$id' in dot expression '$toke_name': $m is not a TMPL_VAR!");
									}
								}
								else {
									# local $,= ', ';
									# carp("Parsing is in some weird state. args so far are '@args'. data = '$data'. id='$id'");
									last;
								}
							}
							croak("Bare word '$data' not allowed in argument list to '$id' in dot expression '$toke_name'") if $data;
						}
						# carp("calling '$id' on '$ref' with '@args'");
						eval {
							if($the_rest or !$want_loop) {
                                $one .= ".$id";
								$ref = $ref->$id(@args);
                                $self->{param_map_done}{$one} ||= $ref;
							} else {
								@results = $ref->$id(@args);
							}
						};
                        if($@) {
                            if( $self->{options}{die_on_bad_params} ) {
                                croak("Error invoking $ref->$id(@args): $@");
                            } else {
                                carp("Error invoking $ref->$id(@args): $@");
                                @results = ();
                                $ref = $self->{param_map_done}{$one} = '';
                                $the_rest = '';
                                last THE_REST;
                            }
                        }
					}
					elsif(reftype($ref) eq'HASH') {
						croak("Can't access hash key '$id' with a parameter list! ($data)") if $data;

						if($the_rest or !$want_loop) {
							$ref = exists( $ref->{$id} ) ? $ref->{$id} : undef;
						} else {
							@results = exists( $ref->{$id} ) ? $ref->{$id} : ();
						}
					}
					else {
						croak("Don't know what to do with reference '$ref', identifier '$id' and data '$data', giving up.");
					}
				}
				elsif(ref($ref) eq 'HASH') {
					# carp("accessing key $id on $ref");
					if($the_rest or !$want_loop) {
						$ref = exists( $ref->{$id} ) ? $ref->{$id} : undef;
					} else {
						@results = exists( $ref->{$id} ) ? $ref->{$id} : ();
					}
				}

				# carp("setting ref for id=$id, toke=$toke_name, param=$param_name, and param map wants a ", ref($self->{param_map}{$toke_name}), " What we got is ", ref($ref), ", results is ", scalar(@results));

			}

			if(!$the_rest and $want_loop) {
				$ref = ($#results==0 and ref($results[0]) eq 'ARRAY') ? $results[0] : \@results;
			}

			croak("Trailing characters '$the_rest' in dot expression '$toke_name'") if $the_rest;
			# carp("we got $ref. the rest = $the_rest");

            if($want_loop) { # fixup the array to a conformant data structure
                my @arr = (reftype($ref) eq 'ARRAY') ? @$ref : ($ref);
                return [ map { {$loopmap_name => $_} } @arr ];
             } else {
                $ref = scalar(@$ref) if ref($ref) eq 'ARRAY';
                return $ref;
            }
		}
        # no match. give up.
        else {
			# carp("No match: one=$one, param_name=$param_name, the rest=$the_rest");
            return undef;
        }
    }
    # no dots and no literal match: give up
    else {
		# carp("No dots, no literal match: toke=$toke_name, name=$param_name, value=$param_value");
        return undef;
    }

}

1;

__END__