# $File: //member/autrijus/Template-Generate/lib/Template/Generate.pm $ $Author: autrijus $
# $Revision: #9 $ $Change: 8169 $ $DateTime: 2003/09/18 06:21:31 $ vim: expandtab shiftwidth=4
package Template::Generate;
$Template::Generate::VERSION = '0.04';
use 5.006001;
use strict;
use warnings;
our $DEBUG;
=head1 NAME
Template::Generate - Generate TT2 templates from data and documents
=head1 VERSION
This document describes version 0.04 of Template::Generate, released
September 18, 2003.
=head1 SYNOPSIS
use Template::Generate;
my $obj = Template::Generate->new;
my $template = $obj->generate(
{
first => 'Autrijus',
last => 'Tang',
score => 55,
} => "(Simon's Blog) Score: 55, Name: Autrijus Tang",
{
first => 'Simon',
last => 'Cozens',
score => 61,
} => "(Simon's Blog) Score: 61, Name: Simon Cozens",
);
# "(Simon's Blog) Score: [% score %], Name: [% first %] [% last %]"
print $template;
=head1 DESCRIPTION
This module generates TT2 templates. It can take data structures and
rendered documents together, and deduce templates that could have
performed the transformation.
It is a companion to B<Template> and B<Template::Extract>; their
relationship is shown below:
Template: ($template + $data) ==> $document # normal
Template::Extract: ($document + $template) ==> $data # tricky
Template::Generate: ($data + $document) ==> $template # very tricky
This module is considered experimental.
=head1 METHODS
=head2 generate($data => $document, $data => $document, ...)
This method takes any number of ($data, $document) pairs, and returns a
sorted list of possible templates that can satisfy all of them. In scalar
context, the template with most variables is returned.
You may set C<$Template::Generate::DEBUG> to a true value to display
generated regular expressions.
=head1 CAVEATS
Currently, the C<generate> method only handles C<[% GET %]> and
C<[% FOREACH %]> directives (both single-level and nested), although
support for C<[% ... %]> is planned in the future.
=cut
sub new {
bless( {}, $_[0] );
}
sub generate {
my $self = shift;
my ( %seen, $final );
while ( my $data = shift ) {
my $document = shift;
my $repeat = keys(%$data);
my ( @each, @this );
do {
push @each, (
@this = _try(
$data,
( ref($document) ? $document : \$document ),
$repeat++,
)
);
} while @this;
%seen = map { $final = $_; $_ => 1 }
grep { !%seen or $seen{$_} } @each
or return;
}
return sort keys %seen if wantarray;
return $final;
}
sub _try {
my ( $data, $document, $repeat ) = @_;
my $regex = "\\A\n";
my $count = 0;
$regex .= _any( \$count );
for ( 1 .. $repeat ) {
$regex .= _match( $data, \$count );
$regex .= _any( \$count );
}
$regex .= "\\z\n";
$regex .= "(??{_validate(\\\@m, \\\@rv, \$data)})\n";
my ( @m, @rv );
{
use re 'eval';
print $regex if $DEBUG;
$regex =~ s/\n//g;
$$document =~ m/$regex/s;
}
return @rv;
}
sub _match {
my ( $data, $count, $prefix, $undef ) = @_;
$prefix ||= '';
my $rv = "(?:\n";
foreach my $key ( sort keys %$data ) {
my $value = $data->{$key};
if ( !ref($value) ) {
$$count++;
my $pat = '(' . quotemeta($value) . ')';
if ($undef) {
$rv .= _set( $pat, $count, "[ undef, \$$$count ]})\n|" );
}
else {
$rv .= _set( $pat, $count, "\\'{$prefix$key}'})\n|" );
}
}
elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
die "Array $key must have at least one element" unless @$value;
my $c1 = ++$$count;
$rv .= _set( '(.*?)', $count, "['[% FOREACH $key %]', \$$$count, '']})" );
$rv .= _match( $value->[0], $count, "$prefix$key}[0]{" );
my $c2 = ++$$count;
$rv .= _set( '(.*?)', $count, "['', \$$$count, '[% END %]']})" );
foreach my $idx ( 1 .. $#$value ) {
++$$count;
$rv .= _set( "(\\$c1)", $count, "[ undef, \$$c1 ]})" );
$rv .= _match(
$value->[$idx],
$count,
"$prefix$key}[$idx]{",
'undef'
);
++$$count;
$rv .= _set( "(\\$c2)", $count, "[ undef, \$$c2 ]})" );
}
$rv .= "|\n";
}
else {
die "Unsupported data type: " . ref($value);
}
}
substr( $rv, -2 ) = ")\n";
return $rv;
}
sub _any {
my $count = shift;
$$count++;
return _set('(.*?)', $count, "\$$$count})");
}
sub _set {
return "$_[0](?{\$m[\$-[${$_[1]}]][${$_[1]}] = $_[2]\n";
}
sub _validate {
my ( $in, $out, $data ) = @_;
my $idx = 0;
my %seen = ();
my $rv = '';
while ( defined( my $ary = $in->[$idx] ) ) {
my $prev = $idx;
foreach my $val (grep defined, @$ary) {
if ( ref($val) eq 'SCALAR' ) {
$seen{$$val} = 1;
my $obj = $data;
my $cur = $$val;
my $pos;
while ($cur) {
if (substr($cur, 0, 1) eq '{') {
$pos = index($cur, '}');
$obj = $obj->{substr($cur, 1, $pos - 1)};
}
elsif (substr($cur, 0, 1) eq '[') {
$pos = index($cur, ']');
$obj = $obj->[substr($cur, 1, $pos - 1)];
}
else {
die "Impossible: $cur";
}
$cur = substr($cur, $pos + 1);
}
$idx += length( $obj );
$rv .= "[% " .
substr( $$val, rindex( $$val, '{' ) + 1, -1 ) .
" %]";
}
elsif ( ref($val) eq 'ARRAY' ) {
$rv .= join( '', @$val ) if @$val == 3;
$idx += length( $val->[1] );
}
else {
$rv .= $val;
$idx += length($val);
}
last unless $prev == $idx;
}
last if $prev == $idx;
}
push @$out, $rv if keys(%seen) == keys(%$data);
return '(?!)';
}
1;
=head1 SEE ALSO
L<Template>, L<Template::Extract>
=head1 AUTHORS
Autrijus Tang E<lt>autrijus@autrijus.orgE<gt>
=head1 COPYRIGHT
Copyright 2003 by Autrijus Tang E<lt>autrijus@autrijus.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<http://www.perl.com/perl/misc/Artistic.html>
=cut