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 URI::Escape qw/uri_escape_utf8/;

=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') %]

=cut

        sub tt_filter_search {

                my ($data) = @_;

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

                        my ($display,$search,$delimiter) = @_;
                        
                        # 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 = uri_escape_utf8( $s );

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

                                        push @html, qq{<a href="#" onclick="return search_via_link('$search','$s')">$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;
}


=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	201	use URI::Escape qw/uri_escape_utf8/;
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			[% search('FieldToDisplay','FieldToSearch','optional delimiter') %]
149
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			my ($display,$search,$delimiter) = @_;
161
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			$s = uri_escape_utf8( $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	318	push @html, qq{<a href="#" onclick="return search_via_link('$search','$s')">$d</a>};
206	dpavlin	199	}
207
208			return join($delimiter, @html);
209			} else {
210			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>};
211			my $v = $item->{'display'};
212
213			if ($#{$v} == 0) {
214			$html .= $v->[0];
215			} else {
216			$html .= join($delimiter, @{$v});
217			}
218			return $html;
219			}
220			}
221			}
222
223			$args->{'search'} = tt_filter_search($args);
224
225	dpavlin	239	=head3 load_rec
226
227			Used mostly for onClick events like this:
228
229			<a href="#" onClick="[% load_rec( record_uri, 'template_name.tt') %]>foo</a>
230
231			It will automatically do sanity checking and create correct JavaScript code.
232
233			=cut
234
235			$args->{'load_rec'} = sub {
236			my @errors;
237
238			my $record_uri = shift or push @errors, "record_uri missing";
239			my $template = shift or push @errors, "template missing";
240
241			if ($record_uri !~ m#^[^/]+/[^/]+/[^/]+$#) {
242			push @errors, "invalid format of record_uri: $record_uri";
243			}
244
245			if (@errors) {
246			return "Logger.error('errors in load_rec: " . join(", ", @errors) . "'); return false;";
247			} else {
248			return "load_rec('$record_uri','$template'); return false;";
249			}
250			};
251
252			=head3 load_template
253
254			Used to re-submit search request and load results in different template
255
256			<a href="#" onClick="[% load_template( 'template_name.tt' ) %]">bar</a>
257
258			=cut
259
260			$args->{'load_template'} = sub {
261			my $template = shift or return "Logger.error('load_template missing template name!'); return false;";
262			return "load_template($template); return false;";
263	dpavlin	240	};
264	dpavlin	239
265	dpavlin	16	my $out;
266
267			$self->{'tt'}->process(
268			$args->{'template'},
269			$args,
270			\$out
271			) \|\| $log->logconfess( "apply can't process template: ", $self->{'tt'}->error() );
272
273			return $out;
274	dpavlin	1	}
275
276	dpavlin	16	=head2 to_file
277	dpavlin	1
278	dpavlin	16	Create output from in-memory data structure using Template Toolkit template
279			to a file.
280
281			$tt->to_file(
282			file => 'out.txt',
283			template => 'text.tt',
284	dpavlin	70	data => $ds
285	dpavlin	16	);
286
287	dpavlin	1	=cut
288
289	dpavlin	16	sub to_file {
290			my $self = shift;
291
292			my $args = {@_};
293
294			my $log = $self->_get_logger();
295
296			my $file = $args->{'file'} \|\| $log->logconfess("need file name");
297
298			$log->debug("creating file ",$file);
299
300			open(my $fh, ">", $file) \|\| $log->logdie("can't open output file '$file': $!");
301			print $fh $self->output(
302			template => $args->{'template'},
303			data => $args->{'data'},
304			) \|\| $log->logdie("print: $!");
305			close($fh) \|\| $log->logdie("close: $!");
306
307			return 1;
308	dpavlin	1	}
309
310	dpavlin	16
311	dpavlin	1	=head1 AUTHOR
312
313			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
314
315			=head1 COPYRIGHT & LICENSE
316
317			Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.
318
319			This program is free software; you can redistribute it and/or modify it
320			under the same terms as Perl itself.
321
322			=cut
323
324	dpavlin	16	1; # End of WebPAC::Output::TT