line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# $File: //member/autrijus/Template-Generate/lib/Template/Generate.pm $ $Author: autrijus $ |
2
|
|
|
|
|
|
|
# $Revision: #9 $ $Change: 8169 $ $DateTime: 2003/09/18 06:21:31 $ vim: expandtab shiftwidth=4 |
3
|
|
|
|
|
|
|
|
4
|
|
|
|
|
|
|
package Template::Generate; |
5
|
|
|
|
|
|
|
$Template::Generate::VERSION = '0.04'; |
6
|
|
|
|
|
|
|
|
7
|
1
|
|
|
1
|
|
880
|
use 5.006001; |
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
40
|
|
8
|
1
|
|
|
1
|
|
5
|
use strict; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
30
|
|
9
|
1
|
|
|
1
|
|
5
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
417
|
|
10
|
|
|
|
|
|
|
our $DEBUG; |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
=head1 NAME |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
Template::Generate - Generate TT2 templates from data and documents |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
=head1 VERSION |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
This document describes version 0.04 of Template::Generate, released |
19
|
|
|
|
|
|
|
September 18, 2003. |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
=head1 SYNOPSIS |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
use Template::Generate; |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
my $obj = Template::Generate->new; |
26
|
|
|
|
|
|
|
my $template = $obj->generate( |
27
|
|
|
|
|
|
|
{ |
28
|
|
|
|
|
|
|
first => 'Autrijus', |
29
|
|
|
|
|
|
|
last => 'Tang', |
30
|
|
|
|
|
|
|
score => 55, |
31
|
|
|
|
|
|
|
} => "(Simon's Blog) Score: 55, Name: Autrijus Tang", |
32
|
|
|
|
|
|
|
{ |
33
|
|
|
|
|
|
|
first => 'Simon', |
34
|
|
|
|
|
|
|
last => 'Cozens', |
35
|
|
|
|
|
|
|
score => 61, |
36
|
|
|
|
|
|
|
} => "(Simon's Blog) Score: 61, Name: Simon Cozens", |
37
|
|
|
|
|
|
|
); |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
# "(Simon's Blog) Score: [% score %], Name: [% first %] [% last %]" |
40
|
|
|
|
|
|
|
print $template; |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
=head1 DESCRIPTION |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
This module generates TT2 templates. It can take data structures and |
45
|
|
|
|
|
|
|
rendered documents together, and deduce templates that could have |
46
|
|
|
|
|
|
|
performed the transformation. |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
It is a companion to B and B; their |
49
|
|
|
|
|
|
|
relationship is shown below: |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
Template: ($template + $data) ==> $document # normal |
52
|
|
|
|
|
|
|
Template::Extract: ($document + $template) ==> $data # tricky |
53
|
|
|
|
|
|
|
Template::Generate: ($data + $document) ==> $template # very tricky |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
This module is considered experimental. |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
=head1 METHODS |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
=head2 generate($data => $document, $data => $document, ...) |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
This method takes any number of ($data, $document) pairs, and returns a |
62
|
|
|
|
|
|
|
sorted list of possible templates that can satisfy all of them. In scalar |
63
|
|
|
|
|
|
|
context, the template with most variables is returned. |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
You may set C<$Template::Generate::DEBUG> to a true value to display |
66
|
|
|
|
|
|
|
generated regular expressions. |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
=head1 CAVEATS |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
Currently, the C method only handles C<[% GET %]> and |
71
|
|
|
|
|
|
|
C<[% FOREACH %]> directives (both single-level and nested), although |
72
|
|
|
|
|
|
|
support for C<[% ... %]> is planned in the future. |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
=cut |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
sub new { |
77
|
1
|
|
|
1
|
0
|
539
|
bless( {}, $_[0] ); |
78
|
|
|
|
|
|
|
} |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
sub generate { |
81
|
4
|
|
|
4
|
1
|
944
|
my $self = shift; |
82
|
|
|
|
|
|
|
|
83
|
4
|
|
|
|
|
5
|
my ( %seen, $final ); |
84
|
4
|
|
|
|
|
12
|
while ( my $data = shift ) { |
85
|
6
|
|
|
|
|
8
|
my $document = shift; |
86
|
6
|
|
|
|
|
12
|
my $repeat = keys(%$data); |
87
|
6
|
|
|
|
|
6
|
my ( @each, @this ); |
88
|
6
|
|
|
|
|
7
|
do { |
89
|
14
|
50
|
|
|
|
48
|
push @each, ( |
90
|
|
|
|
|
|
|
@this = _try( |
91
|
|
|
|
|
|
|
$data, |
92
|
|
|
|
|
|
|
( ref($document) ? $document : \$document ), |
93
|
|
|
|
|
|
|
$repeat++, |
94
|
|
|
|
|
|
|
) |
95
|
|
|
|
|
|
|
); |
96
|
|
|
|
|
|
|
} while @this; |
97
|
6
|
100
|
|
|
|
9
|
%seen = map { $final = $_; $_ => 1 } |
|
6
|
|
|
|
|
130
|
|
|
10
|
|
|
|
|
57
|
|
98
|
6
|
50
|
|
|
|
14
|
grep { !%seen or $seen{$_} } @each |
99
|
|
|
|
|
|
|
or return; |
100
|
|
|
|
|
|
|
} |
101
|
4
|
100
|
|
|
|
16
|
return sort keys %seen if wantarray; |
102
|
3
|
|
|
|
|
16
|
return $final; |
103
|
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
sub _try { |
106
|
14
|
|
|
14
|
|
20
|
my ( $data, $document, $repeat ) = @_; |
107
|
14
|
|
|
|
|
18
|
my $regex = "\\A\n"; |
108
|
14
|
|
|
|
|
15
|
my $count = 0; |
109
|
|
|
|
|
|
|
|
110
|
14
|
|
|
|
|
24
|
$regex .= _any( \$count ); |
111
|
14
|
|
|
|
|
71
|
for ( 1 .. $repeat ) { |
112
|
44
|
|
|
|
|
76
|
$regex .= _match( $data, \$count ); |
113
|
44
|
|
|
|
|
90
|
$regex .= _any( \$count ); |
114
|
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
|
116
|
14
|
|
|
|
|
18
|
$regex .= "\\z\n"; |
117
|
14
|
|
|
|
|
22
|
$regex .= "(??{_validate(\\\@m, \\\@rv, \$data)})\n"; |
118
|
|
|
|
|
|
|
|
119
|
14
|
|
|
|
|
13
|
my ( @m, @rv ); |
120
|
|
|
|
|
|
|
{ |
121
|
1
|
|
|
1
|
|
5
|
use re 'eval'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
1099
|
|
|
14
|
|
|
|
|
20
|
|
122
|
14
|
50
|
|
|
|
28
|
print $regex if $DEBUG; |
123
|
14
|
|
|
|
|
255
|
$regex =~ s/\n//g; |
124
|
14
|
|
|
|
|
5789
|
$$document =~ m/$regex/s; |
125
|
|
|
|
|
|
|
} |
126
|
14
|
|
|
|
|
109
|
return @rv; |
127
|
|
|
|
|
|
|
} |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
sub _match { |
130
|
56
|
|
|
56
|
|
73
|
my ( $data, $count, $prefix, $undef ) = @_; |
131
|
56
|
|
100
|
|
|
164
|
$prefix ||= ''; |
132
|
56
|
|
|
|
|
57
|
my $rv = "(?:\n"; |
133
|
56
|
|
|
|
|
161
|
foreach my $key ( sort keys %$data ) { |
134
|
132
|
|
|
|
|
185
|
my $value = $data->{$key}; |
135
|
132
|
100
|
|
|
|
273
|
if ( !ref($value) ) { |
|
|
50
|
|
|
|
|
|
136
|
123
|
|
|
|
|
115
|
$$count++; |
137
|
123
|
|
|
|
|
178
|
my $pat = '(' . quotemeta($value) . ')'; |
138
|
123
|
100
|
|
|
|
171
|
if ($undef) { |
139
|
3
|
|
|
|
|
28
|
$rv .= _set( $pat, $count, "[ undef, \$$$count ]})\n|" ); |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
else { |
142
|
120
|
|
|
|
|
279
|
$rv .= _set( $pat, $count, "\\'{$prefix$key}'})\n|" ); |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) { |
146
|
9
|
50
|
|
|
|
24
|
die "Array $key must have at least one element" unless @$value; |
147
|
|
|
|
|
|
|
|
148
|
9
|
|
|
|
|
13
|
my $c1 = ++$$count; |
149
|
9
|
|
|
|
|
29
|
$rv .= _set( '(.*?)', $count, "['[% FOREACH $key %]', \$$$count, '']})" ); |
150
|
|
|
|
|
|
|
|
151
|
9
|
|
|
|
|
42
|
$rv .= _match( $value->[0], $count, "$prefix$key}[0]{" ); |
152
|
|
|
|
|
|
|
|
153
|
9
|
|
|
|
|
14
|
my $c2 = ++$$count; |
154
|
9
|
|
|
|
|
24
|
$rv .= _set( '(.*?)', $count, "['', \$$$count, '[% END %]']})" ); |
155
|
|
|
|
|
|
|
|
156
|
9
|
|
|
|
|
23
|
foreach my $idx ( 1 .. $#$value ) { |
157
|
3
|
|
|
|
|
4
|
++$$count; |
158
|
3
|
|
|
|
|
71
|
$rv .= _set( "(\\$c1)", $count, "[ undef, \$$c1 ]})" ); |
159
|
|
|
|
|
|
|
|
160
|
3
|
|
|
|
|
12
|
$rv .= _match( |
161
|
|
|
|
|
|
|
$value->[$idx], |
162
|
|
|
|
|
|
|
$count, |
163
|
|
|
|
|
|
|
"$prefix$key}[$idx]{", |
164
|
|
|
|
|
|
|
'undef' |
165
|
|
|
|
|
|
|
); |
166
|
|
|
|
|
|
|
|
167
|
3
|
|
|
|
|
5
|
++$$count; |
168
|
3
|
|
|
|
|
10
|
$rv .= _set( "(\\$c2)", $count, "[ undef, \$$c2 ]})" ); |
169
|
|
|
|
|
|
|
} |
170
|
9
|
|
|
|
|
23
|
$rv .= "|\n"; |
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
else { |
173
|
0
|
|
|
|
|
0
|
die "Unsupported data type: " . ref($value); |
174
|
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
|
} |
176
|
56
|
|
|
|
|
103
|
substr( $rv, -2 ) = ")\n"; |
177
|
56
|
|
|
|
|
149
|
return $rv; |
178
|
|
|
|
|
|
|
} |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
sub _any { |
181
|
58
|
|
|
58
|
|
64
|
my $count = shift; |
182
|
58
|
|
|
|
|
64
|
$$count++; |
183
|
58
|
|
|
|
|
135
|
return _set('(.*?)', $count, "\$$$count})"); |
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
sub _set { |
187
|
205
|
|
|
205
|
|
305
|
return "$_[0](?{\$m[\$-[${$_[1]}]][${$_[1]}] = $_[2]\n"; |
|
205
|
|
|
|
|
271
|
|
|
205
|
|
|
|
|
694
|
|
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
sub _validate { |
191
|
14
|
|
|
14
|
|
23
|
my ( $in, $out, $data ) = @_; |
192
|
14
|
|
|
|
|
16
|
my $idx = 0; |
193
|
14
|
|
|
|
|
19
|
my %seen = (); |
194
|
14
|
|
|
|
|
18
|
my $rv = ''; |
195
|
14
|
|
|
|
|
35
|
while ( defined( my $ary = $in->[$idx] ) ) { |
196
|
98
|
|
|
|
|
97
|
my $prev = $idx; |
197
|
98
|
|
|
|
|
234
|
foreach my $val (grep defined, @$ary) { |
198
|
105
|
100
|
|
|
|
290
|
if ( ref($val) eq 'SCALAR' ) { |
|
|
100
|
|
|
|
|
|
199
|
40
|
|
|
|
|
674
|
$seen{$$val} = 1; |
200
|
40
|
|
|
|
|
45
|
my $obj = $data; |
201
|
40
|
|
|
|
|
42
|
my $cur = $$val; |
202
|
40
|
|
|
|
|
40
|
my $pos; |
203
|
40
|
|
|
|
|
67
|
while ($cur) { |
204
|
46
|
100
|
|
|
|
166
|
if (substr($cur, 0, 1) eq '{') { |
|
|
50
|
|
|
|
|
|
205
|
43
|
|
|
|
|
53
|
$pos = index($cur, '}'); |
206
|
43
|
|
|
|
|
74
|
$obj = $obj->{substr($cur, 1, $pos - 1)}; |
207
|
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
elsif (substr($cur, 0, 1) eq '[') { |
209
|
3
|
|
|
|
|
5
|
$pos = index($cur, ']'); |
210
|
3
|
|
|
|
|
7
|
$obj = $obj->[substr($cur, 1, $pos - 1)]; |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
else { |
213
|
0
|
|
|
|
|
0
|
die "Impossible: $cur"; |
214
|
|
|
|
|
|
|
} |
215
|
46
|
|
|
|
|
106
|
$cur = substr($cur, $pos + 1); |
216
|
|
|
|
|
|
|
} |
217
|
40
|
|
|
|
|
45
|
$idx += length( $obj ); |
218
|
40
|
|
|
|
|
94
|
$rv .= "[% " . |
219
|
|
|
|
|
|
|
substr( $$val, rindex( $$val, '{' ) + 1, -1 ) . |
220
|
|
|
|
|
|
|
" %]"; |
221
|
|
|
|
|
|
|
} |
222
|
|
|
|
|
|
|
elsif ( ref($val) eq 'ARRAY' ) { |
223
|
9
|
100
|
|
|
|
28
|
$rv .= join( '', @$val ) if @$val == 3; |
224
|
9
|
|
|
|
|
11
|
$idx += length( $val->[1] ); |
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
else { |
227
|
56
|
|
|
|
|
62
|
$rv .= $val; |
228
|
56
|
|
|
|
|
68
|
$idx += length($val); |
229
|
|
|
|
|
|
|
} |
230
|
105
|
100
|
|
|
|
268
|
last unless $prev == $idx; |
231
|
|
|
|
|
|
|
} |
232
|
98
|
100
|
|
|
|
343
|
last if $prev == $idx; |
233
|
|
|
|
|
|
|
} |
234
|
14
|
100
|
|
|
|
46
|
push @$out, $rv if keys(%seen) == keys(%$data); |
235
|
14
|
|
|
|
|
533
|
return '(?!)'; |
236
|
|
|
|
|
|
|
} |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
1; |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
=head1 SEE ALSO |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
L, L |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
=head1 AUTHORS |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
Autrijus Tang Eautrijus@autrijus.orgE |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
=head1 COPYRIGHT |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
Copyright 2003 by Autrijus Tang Eautrijus@autrijus.orgE. |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
This program is free software; you can redistribute it and/or |
253
|
|
|
|
|
|
|
modify it under the same terms as Perl itself. |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
See L |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
=cut |
258
|
|
|
|
|
|
|
|