WebPAC/Output/TT.pm

package WebPAC::Output::TT;

use warnings;
use strict;

use base qw/WebPAC::Common/;

use Template;
use List::Util qw/first/;
use Data::Dump qw/dump/;
use Encode;

=head1 NAME

WebPAC::Output::TT - use Template Toolkit to produce output

=head1 VERSION

Version 0.07

=cut

our $VERSION = '0.07';

=head1 SYNOPSIS

Produce output using Template Toolkit.

=head1 FUNCTIONS

=head2 new

Create new instance.

 my $tt = new WebPAC::Output::TT(
        include_path => '/path/to/conf/output/tt',
        filters => {
                filter_1 => sub { uc(shift) },
        },
 );

By default, Template Toolkit will C<EVAL_PERL> if included in templates.

=cut

sub new {
        my $class = shift;
        my $self = {@_};
        bless($self, $class);

        my $log = $self->_get_logger;

        # create Template toolkit instance
        $self->{'tt'} = Template->new(
                INCLUDE_PATH => $self->{'include_path'},
                #FILTERS => $self->{'filters'},
                EVAL_PERL => 1,
        );
        
        $log->logdie("can't create TT object: $Template::ERROR") unless ($self->{'tt'});

        $log->debug("filters defined: ",dump($self->{'filters'}));

        $self ? return $self : return undef;
}


=head2 apply

Create output from in-memory data structure using Template Toolkit template.

 my $text = $tt->apply(
        template => 'text.tt',
        data => $ds,
        record_uri => 'database/prefix/mfn',
 );

It also has follwing template toolikit filter routies defined:

=cut

sub apply {
        my $self = shift;

        my $args = {@_};

        my $log = $self->_get_logger();

        foreach my $a (qw/template data/) {
                $log->logconfess("need $a") unless ($args->{$a});
        }

=head3 tt_filter_type

filter to return values of specified from $ds, usage from TT template is in form
C<d('FieldName','delimiter')>, where C<delimiter> is optional, like this:

  [% d('Title') %]
  [% d('Author',', ' %]

=cut

        sub tt_filter_type {
                my ($data,$type) = @_;
                
                die "no data?" unless ($data);
                $type ||= 'display';

                my $default_delimiter = {
                        'display' => '&#182;<br/>',
                        'index' => '\n',
                };

                return sub {

                        my ($name,$join) = @_;

                        die "no data hash" unless ($data->{'data'} && ref($data->{'data'}) eq 'HASH');
                        # Hm? Should we die here?
                        return unless ($name);

                        my $item = $data->{'data'}->{$name} || return;

                        my $v = $item->{$type} || return;

                        if (ref($v) eq 'ARRAY') {
                                if ($#{$v} == 0) {
                                        $v = $v->[0];
                                } else {
                                        $join = $default_delimiter->{$type} unless defined($join);
                                        $v = join($join, @{$v});
                                }
                        } else {
                                warn("TT filter $type(): field $name values aren't ARRAY, ignoring");
                        }

                        return $v;
                }
        }

        $args->{'d'} = tt_filter_type($args, 'display');
        $args->{'display'} = tt_filter_type($args, 'display');

=head3 tt_filter_search

filter to return links to search, usage in TT:

  [% search('FieldToDisplay','FieldToSearch','optional delimiter', 'optional_template.tt') %]

=cut

        sub tt_filter_search {

                my ($data) = @_;

                die "no data?" unless ($data);
                
                return sub {

                        my ($display,$search,$delimiter,$template) = @_;
                        
                        # default delimiter
                        $delimiter ||= '&#182;<br/>',

                        die "no data hash" unless ($data->{'data'} && ref($data->{'data'}) eq 'HASH');
                        # Hm? Should we die here?
                        return unless ($display);

                        my $item = $data->{'data'}->{$display} || return;

                        return unless($item->{'display'});
                        if (! $item->{'search'}) {
                                warn "error in TT template: field $display didn't insert anything into search, use d('$display') and not search('$display'...)";
                                return;
                        }

                        my @warn;
                        foreach my $type (qw/display search/) {
                                push @warn, "field $display type $type values aren't ARRAY" unless (ref($item->{$type}) eq 'ARRAY');
                        }

                        if (@warn) {
                                warn("TT filter search(): " . join(",", @warn) . ", skipping");
                                return;
                        }
                        my @html;

                        my $d_el = $#{ $item->{'display'} };
                        my $s_el = $#{ $item->{'search'} }; 

                        # easy, both fields have same number of elements or there is just
                        # one search and multiple display
                        if ( $d_el == $s_el || $s_el == 0 ) {

                                foreach my $i ( 0 .. $d_el ) {

                                        my $s;
                                        if ($s_el > 0) {
                                                $s = $item->{'search'}->[$i];
                                                die "can't find value $i for type search in field $search" unless (defined($s));
                                        } else {
                                                $s = $item->{'search'}->[0];
                                        }
                                        #$s =~ s/([^\w.-])/sprintf("%%%02X",ord($1))/eg;
                                        $s = __quotemeta( $s );

                                        my $d = $item->{'display'}->[$i];
                                                die "can't find value $i for type display in field $display" unless (defined($d));

                                        my $template_arg = '';
                                        $template_arg = qq{,'$template'} if ($template);

                                        if ($s && ! $d) {
                                                $d = $s;
                                        } elsif (! $s && $d) {
                                                $s = $d;
                                        }

                                        push @html, qq{<a href="#" onclick="return search_via_link('$search','$s'${template_arg})">$d</a>} if ($s && $d);
                                }

                                return join($delimiter, @html);
                        } else {
                                my $html = qq{<div class="notice">WARNING: we should really support if there is $d_el display elements and $s_el search elements, but currently there is no nice way to do so, so we will just display values</div>};
                                my $v = $item->{'display'};

                                if ($#{$v} == 0) {
                                        $html .= $v->[0];
                                } else {
                                        $html .= join($delimiter, @{$v});
                                }
                                return $html;
                        }
                }
        }

        $args->{'search'} = tt_filter_search($args);

=head3 load_rec

Used mostly for onClick events like this:

  <a href="#" onClick="[% load_rec( record_uri, 'template_name.tt') %]>foo</a>

It will automatically do sanity checking and create correct JavaScript code.

=cut

        $args->{'load_rec'} = sub {
                my @errors;

                my $record_uri = shift or push @errors, "record_uri missing";
                my $template = shift or push @errors, "template missing";

                if ($record_uri !~ m#^[^/]+/[^/]+/[^/]+$#) {
                        push @errors, "invalid format of record_uri: $record_uri";
                }

                if (@errors) {
                        return "Logger.error('errors in load_rec: " . join(", ", @errors) . "'); return false;";
                } else {
                        return "load_rec('$record_uri','$template'); return false;";
                }
        };

=head3 load_template

Used to re-submit search request and load results in different template

  <a href="#" onClick="[% load_template( 'template_name.tt' ) %]">bar</a>

=cut

        $args->{'load_template'} = sub {
                my $template = shift or return "Logger.error('load_template missing template name!'); return false;";
                return "load_template($template); return false;";
        };

        if ($self->{filters}) {
                $args->{f} = $self->{filters};
                $log->debug("using f.filters");
        }

        my $out;

        $self->{'tt'}->process(
                $args->{'template'},
                $args,
                \$out
        ) || $log->logconfess( "apply can't process template: ", $self->{'tt'}->error() );

        return $out;
}

=head2 to_file

Create output from in-memory data structure using Template Toolkit template
to a file.

 $tt->to_file(
        file => 'out.txt',
        template => 'text.tt',
        data => $ds
 );

=cut

sub to_file {
        my $self = shift;

        my $args = {@_};

        my $log = $self->_get_logger();

        my $file = $args->{'file'} || $log->logconfess("need file name");

        $log->debug("creating file ",$file);

        open(my $fh, ">", $file) || $log->logdie("can't open output file '$file': $!");
        print $fh $self->output(
                template => $args->{'template'},
                data => $args->{'data'},
        ) || $log->logdie("print: $!");
        close($fh) || $log->logdie("close: $!");

        return 1;
}


=head2 __quotemeta

Helper to quote JavaScript-friendly characters

=cut

sub __quotemeta {
        local $_ = shift;
        $_ = decode('iso-8859-2', $_);

        s<([\x{0080}-\x{fffd}]+)>{sprintf '\u%0*v4X', '\u', $1}ge if ( Encode::is_utf8($_) );
        {
                use bytes;  
                s<((?:[^ \x21-\x7E]|(?:\\(?!u)))+)>{sprintf '\x%0*v2X', '\x', $1}ge;
        }

        s/\\x09/\\t/g;
        s/\\x0A/\\n/g;
        s/\\x0D/\\r/g;
        s/"/\\"/g;
        s/\\x5C/\\\\/g;

        return $_;
}

=head1 AUTHOR

Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>

=head1 COPYRIGHT & LICENSE

Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1; # End of WebPAC::Output::TT
1	dpavlin	16	package WebPAC::Output::TT;
2	dpavlin	1
3			use warnings;
4			use strict;
5
6	dpavlin	16	use base qw/WebPAC::Common/;
7
8			use Template;
9	dpavlin	42	use List::Util qw/first/;
10	dpavlin	887	use Data::Dump qw/dump/;
11	dpavlin	331	use Encode;
12	dpavlin	16
13	dpavlin	1	=head1 NAME
14
15	dpavlin	16	WebPAC::Output::TT - use Template Toolkit to produce output
16	dpavlin	1
17			=head1 VERSION
18
19	dpavlin	347	Version 0.07
20	dpavlin	1
21			=cut
22
23	dpavlin	347	our $VERSION = '0.07';
24	dpavlin	1
25			=head1 SYNOPSIS
26
27	dpavlin	16	Produce output using Template Toolkit.
28	dpavlin	1
29	dpavlin	16	=head1 FUNCTIONS
30	dpavlin	1
31	dpavlin	16	=head2 new
32	dpavlin	1
33	dpavlin	16	Create new instance.
34	dpavlin	1
35	dpavlin	16	my $tt = new WebPAC::Output::TT(
36			include_path => '/path/to/conf/output/tt',
37			filters => {
38			filter_1 => sub { uc(shift) },
39			},
40			);
41	dpavlin	1
42	dpavlin	16	By default, Template Toolkit will C<EVAL_PERL> if included in templates.
43	dpavlin	1
44	dpavlin	16	=cut
45	dpavlin	1
46	dpavlin	16	sub new {
47			my $class = shift;
48	dpavlin	347	my $self = {@_};
49			bless($self, $class);
50	dpavlin	1
51	dpavlin	16	my $log = $self->_get_logger;
52
53			# create Template toolkit instance
54			$self->{'tt'} = Template->new(
55			INCLUDE_PATH => $self->{'include_path'},
56	dpavlin	347	#FILTERS => $self->{'filters'},
57	dpavlin	16	EVAL_PERL => 1,
58			);
59
60			$log->logdie("can't create TT object: $Template::ERROR") unless ($self->{'tt'});
61
62	dpavlin	887	$log->debug("filters defined: ",dump($self->{'filters'}));
63	dpavlin	16
64			$self ? return $self : return undef;
65			}
66
67
68			=head2 apply
69
70			Create output from in-memory data structure using Template Toolkit template.
71
72	dpavlin	21	my $text = $tt->apply(
73			template => 'text.tt',
74	dpavlin	239	data => $ds,
75			record_uri => 'database/prefix/mfn',
76	dpavlin	21	);
77	dpavlin	16
78	dpavlin	45	It also has follwing template toolikit filter routies defined:
79
80	dpavlin	1	=cut
81
82	dpavlin	16	sub apply {
83			my $self = shift;
84
85			my $args = {@_};
86
87			my $log = $self->_get_logger();
88
89			foreach my $a (qw/template data/) {
90			$log->logconfess("need $a") unless ($args->{$a});
91			}
92
93	dpavlin	45	=head3 tt_filter_type
94	dpavlin	42
95	dpavlin	199	filter to return values of specified from $ds, usage from TT template is in form
96			C<d('FieldName','delimiter')>, where C<delimiter> is optional, like this:
97	dpavlin	45
98	dpavlin	199	[% d('Title') %]
99			[% d('Author',', ' %]
100
101	dpavlin	45	=cut
102
103	dpavlin	43	sub tt_filter_type {
104			my ($data,$type) = @_;
105
106			die "no data?" unless ($data);
107			$type \|\|= 'display';
108	dpavlin	42
109	dpavlin	43	my $default_delimiter = {
110			'display' => '¶<br/>',
111			'index' => '\n',
112			};
113	dpavlin	42
114	dpavlin	43	return sub {
115	dpavlin	42
116	dpavlin	43	my ($name,$join) = @_;
117	dpavlin	42
118	dpavlin	70	die "no data hash" unless ($data->{'data'} && ref($data->{'data'}) eq 'HASH');
119	dpavlin	62	# Hm? Should we die here?
120			return unless ($name);
121	dpavlin	43
122	dpavlin	70	my $item = $data->{'data'}->{$name} \|\| return;
123	dpavlin	43
124			my $v = $item->{$type} \|\| return;
125	dpavlin	42
126	dpavlin	43	if (ref($v) eq 'ARRAY') {
127			if ($#{$v} == 0) {
128			$v = $v->[0];
129			} else {
130			$join = $default_delimiter->{$type} unless defined($join);
131			$v = join($join, @{$v});
132			}
133	dpavlin	199	} else {
134			warn("TT filter $type(): field $name values aren't ARRAY, ignoring");
135	dpavlin	42	}
136	dpavlin	45
137	dpavlin	43	return $v;
138	dpavlin	42	}
139			}
140
141	dpavlin	43	$args->{'d'} = tt_filter_type($args, 'display');
142	dpavlin	199	$args->{'display'} = tt_filter_type($args, 'display');
143	dpavlin	42
144	dpavlin	199	=head3 tt_filter_search
145
146			filter to return links to search, usage in TT:
147
148	dpavlin	320	[% search('FieldToDisplay','FieldToSearch','optional delimiter', 'optional_template.tt') %]
149	dpavlin	199
150			=cut
151
152			sub tt_filter_search {
153
154			my ($data) = @_;
155
156			die "no data?" unless ($data);
157
158			return sub {
159
160	dpavlin	320	my ($display,$search,$delimiter,$template) = @_;
161	dpavlin	199
162			# default delimiter
163			$delimiter \|\|= '¶<br/>',
164
165			die "no data hash" unless ($data->{'data'} && ref($data->{'data'}) eq 'HASH');
166			# Hm? Should we die here?
167			return unless ($display);
168
169			my $item = $data->{'data'}->{$display} \|\| return;
170
171			return unless($item->{'display'});
172	dpavlin	341	if (! $item->{'search'}) {
173			warn "error in TT template: field $display didn't insert anything into search, use d('$display') and not search('$display'...)";
174			return;
175			}
176	dpavlin	199
177			my @warn;
178			foreach my $type (qw/display search/) {
179			push @warn, "field $display type $type values aren't ARRAY" unless (ref($item->{$type}) eq 'ARRAY');
180			}
181
182			if (@warn) {
183			warn("TT filter search(): " . join(",", @warn) . ", skipping");
184			return;
185			}
186			my @html;
187
188			my $d_el = $#{ $item->{'display'} };
189			my $s_el = $#{ $item->{'search'} };
190
191			# easy, both fields have same number of elements or there is just
192			# one search and multiple display
193			if ( $d_el == $s_el \|\| $s_el == 0 ) {
194
195			foreach my $i ( 0 .. $d_el ) {
196
197			my $s;
198			if ($s_el > 0) {
199	dpavlin	376	$s = $item->{'search'}->[$i];
200			die "can't find value $i for type search in field $search" unless (defined($s));
201	dpavlin	199	} else {
202			$s = $item->{'search'}->[0];
203			}
204	dpavlin	201	#$s =~ s/([^\w.-])/sprintf("%%%02X",ord($1))/eg;
205	dpavlin	331	$s = __quotemeta( $s );
206	dpavlin	199
207	dpavlin	376	my $d = $item->{'display'}->[$i];
208			die "can't find value $i for type display in field $display" unless (defined($d));
209	dpavlin	199
210	dpavlin	321	my $template_arg = '';
211			$template_arg = qq{,'$template'} if ($template);
212
213	dpavlin	376	if ($s && ! $d) {
214			$d = $s;
215			} elsif (! $s && $d) {
216			$s = $d;
217			}
218
219			push @html, qq{<a href="#" onclick="return search_via_link('$search','$s'${template_arg})">$d</a>} if ($s && $d);
220	dpavlin	199	}
221
222			return join($delimiter, @html);
223			} else {
224			my $html = qq{<div class="notice">WARNING: we should really support if there is $d_el display elements and $s_el search elements, but currently there is no nice way to do so, so we will just display values</div>};
225			my $v = $item->{'display'};
226
227			if ($#{$v} == 0) {
228			$html .= $v->[0];
229			} else {
230			$html .= join($delimiter, @{$v});
231			}
232			return $html;
233			}
234			}
235			}
236
237			$args->{'search'} = tt_filter_search($args);
238
239	dpavlin	239	=head3 load_rec
240
241			Used mostly for onClick events like this:
242
243			<a href="#" onClick="[% load_rec( record_uri, 'template_name.tt') %]>foo</a>
244
245			It will automatically do sanity checking and create correct JavaScript code.
246
247			=cut
248
249			$args->{'load_rec'} = sub {
250			my @errors;
251
252			my $record_uri = shift or push @errors, "record_uri missing";
253			my $template = shift or push @errors, "template missing";
254
255			if ($record_uri !~ m#^[^/]+/[^/]+/[^/]+$#) {
256			push @errors, "invalid format of record_uri: $record_uri";
257			}
258
259			if (@errors) {
260			return "Logger.error('errors in load_rec: " . join(", ", @errors) . "'); return false;";
261			} else {
262			return "load_rec('$record_uri','$template'); return false;";
263			}
264			};
265
266			=head3 load_template
267
268			Used to re-submit search request and load results in different template
269
270			<a href="#" onClick="[% load_template( 'template_name.tt' ) %]">bar</a>
271
272			=cut
273
274			$args->{'load_template'} = sub {
275			my $template = shift or return "Logger.error('load_template missing template name!'); return false;";
276			return "load_template($template); return false;";
277	dpavlin	240	};
278	dpavlin	239
279	dpavlin	347	if ($self->{filters}) {
280			$args->{f} = $self->{filters};
281			$log->debug("using f.filters");
282			}
283
284	dpavlin	16	my $out;
285
286			$self->{'tt'}->process(
287			$args->{'template'},
288			$args,
289			\$out
290			) \|\| $log->logconfess( "apply can't process template: ", $self->{'tt'}->error() );
291
292			return $out;
293	dpavlin	1	}
294
295	dpavlin	16	=head2 to_file
296	dpavlin	1
297	dpavlin	16	Create output from in-memory data structure using Template Toolkit template
298			to a file.
299
300			$tt->to_file(
301			file => 'out.txt',
302			template => 'text.tt',
303	dpavlin	70	data => $ds
304	dpavlin	16	);
305
306	dpavlin	1	=cut
307
308	dpavlin	16	sub to_file {
309			my $self = shift;
310
311			my $args = {@_};
312
313			my $log = $self->_get_logger();
314
315			my $file = $args->{'file'} \|\| $log->logconfess("need file name");
316
317			$log->debug("creating file ",$file);
318
319			open(my $fh, ">", $file) \|\| $log->logdie("can't open output file '$file': $!");
320			print $fh $self->output(
321			template => $args->{'template'},
322			data => $args->{'data'},
323			) \|\| $log->logdie("print: $!");
324			close($fh) \|\| $log->logdie("close: $!");
325
326			return 1;
327	dpavlin	1	}
328
329	dpavlin	16
330	dpavlin	331	=head2 __quotemeta
331
332			Helper to quote JavaScript-friendly characters
333
334			=cut
335
336			sub __quotemeta {
337			local $_ = shift;
338			$_ = decode('iso-8859-2', $_);
339
340			s<([\x{0080}-\x{fffd}]+)>{sprintf '\u%0*v4X', '\u', $1}ge if ( Encode::is_utf8($_) );
341			{
342			use bytes;
343			s<((?:[^ \x21-\x7E]\|(?:\\(?!u)))+)>{sprintf '\x%0*v2X', '\x', $1}ge;
344			}
345
346			s/\\x09/\\t/g;
347			s/\\x0A/\\n/g;
348			s/\\x0D/\\r/g;
349			s/"/\\"/g;
350			s/\\x5C/\\\\/g;
351
352			return $_;
353			}
354
355	dpavlin	1	=head1 AUTHOR
356
357			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
358
359			=head1 COPYRIGHT & LICENSE
360
361			Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.
362
363			This program is free software; you can redistribute it and/or modify it
364			under the same terms as Perl itself.
365
366			=cut
367
368	dpavlin	16	1; # End of WebPAC::Output::TT