Extension of HTML::Template.pm to use objects which have param() accessor as loop parameters

Template.pm

# -*- mode: perl; coding: utf-8; -*-
package My::HTML::Template;
use Encode qw/ decode_utf8 /;
use UNIVERSAL;
use base qw/ HTML::Template /;
use utf8;
use strict;
use warnings;

=head1 NAME

My::HTML::Template

=head1 DESCRIPTION

C<HTML::Template> の拡張．

=cut
sub new {
    my $class = shift;
    my %option = @_;
    push( @_, filter => \&_utf8_filter ) unless $option{filter};
    push( @_, default_escape => 'HTML' ) unless $option{default_escape};
    my $new = $class->SUPER::new( @_ );
    $new;
}

sub _utf8_filter {
    my $ref = shift;
    $$ref = &decode_utf8( $$ref );
}

=head1 METHODS

=over 4

=item output

テンプレートを出力する．

ループに対して，オブジェクトを関連付けることができるように拡張されている．

    <table>
    <tmpl_loop name="users">
      <tr><td><tmpl_var name="uid"></td></tr>
    </tmpl_loop>
    </table>

というテンプレートに対して，

    $this->param( users => \@user );

という使い方ができる．ここで，C<@user> は C<uid> という属性を持つオブジェ
クトのリストである．

=cut
sub output {
    my $tmpl = shift;
    for my $name ( $tmpl->param ){
        next unless $tmpl->query( name => $name ) eq 'LOOP';
        my $ref = $tmpl->param( $name );
        $tmpl->param( $name => &_expand_loop( $tmpl, $ref, $name ) );
    }
    $tmpl->SUPER::output( @_ );
}

sub _expand_loop {
    my $tmpl = shift;
    my $ref = shift;
    my @name = @_;
    my @param = grep( !/\A__(?:first|inner|last|counter|odd)__\Z/, $tmpl->query( loop => \@name ) );
    my %loop;
    for my $p ( @param ){
        if( $tmpl->query( name => [@name, $p] ) eq 'LOOP' ){
            $loop{$p}++;
        }
    }
    my @buf;
    for( my $i = 0; $ref->[$i]; $i++ ){
        my $can = eval { $ref->[$i]->can('param') };
        my %new;
        for my $p ( @param ){
            if( $loop{$p} ){
                $new{$p} = &_expand_loop( $tmpl, $ref->[$i]->{$p}, @name, $p );
            } elsif( $can ){
                $new{$p} = $ref->[$i]->param($p);
            } else {
                $new{$p} = $ref->[$i]->{$p};
            }
        }
        push( @buf, \%new );
    }
    \@buf;
}

1;