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