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::Dumper;
use Encode;

=head1 NAME

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

=head1 VERSION

Version 0.06

=cut

our $VERSION = '0.06';

=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->{'filter'},
                EVAL_PERL => 1,
        );
        
        $log->logdie("can't create TT object: $Template::ERROR") unless ($self->{'tt'});

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

        $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'});
                        die "error in TT template: field $display didn't insert anything into search, use d('$display') and not search('$display'...)" unless($item->{'search'});

                        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";
                                        } 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";

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

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

                                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;";
        };

        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	16	use Data::Dumper;
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	318	Version 0.06
20	dpavlin	1
21			=cut
22
23	dpavlin	318	our $VERSION = '0.06';
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			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			FILTERS => $self->{'filter'},
57			EVAL_PERL => 1,
58			);
59
60			$log->logdie("can't create TT object: $Template::ERROR") unless ($self->{'tt'});
61
62			$log->debug("filters defined: ",Dumper($self->{'filter'}));
63
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			die "error in TT template: field $display didn't insert anything into search, use d('$display') and not search('$display'...)" unless($item->{'search'});
173
174			my @warn;
175			foreach my $type (qw/display search/) {
176			push @warn, "field $display type $type values aren't ARRAY" unless (ref($item->{$type}) eq 'ARRAY');
177			}
178
179			if (@warn) {
180			warn("TT filter search(): " . join(",", @warn) . ", skipping");
181			return;
182			}
183			my @html;
184
185			my $d_el = $#{ $item->{'display'} };
186			my $s_el = $#{ $item->{'search'} };
187
188			# easy, both fields have same number of elements or there is just
189			# one search and multiple display
190			if ( $d_el == $s_el \|\| $s_el == 0 ) {
191
192			foreach my $i ( 0 .. $d_el ) {
193
194			my $s;
195			if ($s_el > 0) {
196			$s = $item->{'search'}->[$i] \|\| die "can't find value $i for type search in field $search";
197			} else {
198			$s = $item->{'search'}->[0];
199			}
200	dpavlin	201	#$s =~ s/([^\w.-])/sprintf("%%%02X",ord($1))/eg;
201	dpavlin	331	$s = __quotemeta( $s );
202	dpavlin	199
203			my $d = $item->{'display'}->[$i] \|\| die "can't find value $i for type display in field $display";
204
205	dpavlin	321	my $template_arg = '';
206			$template_arg = qq{,'$template'} if ($template);
207
208			push @html, qq{<a href="#" onclick="return search_via_link('$search','$s'${template_arg})">$d</a>};
209	dpavlin	199	}
210
211			return join($delimiter, @html);
212			} else {
213			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>};
214			my $v = $item->{'display'};
215
216			if ($#{$v} == 0) {
217			$html .= $v->[0];
218			} else {
219			$html .= join($delimiter, @{$v});
220			}
221			return $html;
222			}
223			}
224			}
225
226			$args->{'search'} = tt_filter_search($args);
227
228	dpavlin	239	=head3 load_rec
229
230			Used mostly for onClick events like this:
231
232			<a href="#" onClick="[% load_rec( record_uri, 'template_name.tt') %]>foo</a>
233
234			It will automatically do sanity checking and create correct JavaScript code.
235
236			=cut
237
238			$args->{'load_rec'} = sub {
239			my @errors;
240
241			my $record_uri = shift or push @errors, "record_uri missing";
242			my $template = shift or push @errors, "template missing";
243
244			if ($record_uri !~ m#^[^/]+/[^/]+/[^/]+$#) {
245			push @errors, "invalid format of record_uri: $record_uri";
246			}
247
248			if (@errors) {
249			return "Logger.error('errors in load_rec: " . join(", ", @errors) . "'); return false;";
250			} else {
251			return "load_rec('$record_uri','$template'); return false;";
252			}
253			};
254
255			=head3 load_template
256
257			Used to re-submit search request and load results in different template
258
259			<a href="#" onClick="[% load_template( 'template_name.tt' ) %]">bar</a>
260
261			=cut
262
263			$args->{'load_template'} = sub {
264			my $template = shift or return "Logger.error('load_template missing template name!'); return false;";
265			return "load_template($template); return false;";
266	dpavlin	240	};
267	dpavlin	239
268	dpavlin	16	my $out;
269
270			$self->{'tt'}->process(
271			$args->{'template'},
272			$args,
273			\$out
274			) \|\| $log->logconfess( "apply can't process template: ", $self->{'tt'}->error() );
275
276			return $out;
277	dpavlin	1	}
278
279	dpavlin	16	=head2 to_file
280	dpavlin	1
281	dpavlin	16	Create output from in-memory data structure using Template Toolkit template
282			to a file.
283
284			$tt->to_file(
285			file => 'out.txt',
286			template => 'text.tt',
287	dpavlin	70	data => $ds
288	dpavlin	16	);
289
290	dpavlin	1	=cut
291
292	dpavlin	16	sub to_file {
293			my $self = shift;
294
295			my $args = {@_};
296
297			my $log = $self->_get_logger();
298
299			my $file = $args->{'file'} \|\| $log->logconfess("need file name");
300
301			$log->debug("creating file ",$file);
302
303			open(my $fh, ">", $file) \|\| $log->logdie("can't open output file '$file': $!");
304			print $fh $self->output(
305			template => $args->{'template'},
306			data => $args->{'data'},
307			) \|\| $log->logdie("print: $!");
308			close($fh) \|\| $log->logdie("close: $!");
309
310			return 1;
311	dpavlin	1	}
312
313	dpavlin	16
314	dpavlin	331	=head2 __quotemeta
315
316			Helper to quote JavaScript-friendly characters
317
318			=cut
319
320			sub __quotemeta {
321			local $_ = shift;
322			$_ = decode('iso-8859-2', $_);
323
324			s<([\x{0080}-\x{fffd}]+)>{sprintf '\u%0*v4X', '\u', $1}ge if ( Encode::is_utf8($_) );
325			{
326			use bytes;
327			s<((?:[^ \x21-\x7E]\|(?:\\(?!u)))+)>{sprintf '\x%0*v2X', '\x', $1}ge;
328			}
329
330			s/\\x09/\\t/g;
331			s/\\x0A/\\n/g;
332			s/\\x0D/\\r/g;
333			s/"/\\"/g;
334			s/\\x5C/\\\\/g;
335
336			return $_;
337			}
338
339	dpavlin	1	=head1 AUTHOR
340
341			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
342
343			=head1 COPYRIGHT & LICENSE
344
345			Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.
346
347			This program is free software; you can redistribute it and/or modify it
348			under the same terms as Perl itself.
349
350			=cut
351
352	dpavlin	16	1; # End of WebPAC::Output::TT