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.03

=cut

our $VERSION = '0.03';

=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
 );

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, <<__JS_LINK_SEARCH__
<a href="#" onclick="new Ajax.Updater( 'results',  '/search/results?$search=$s', { asynchronous: 1,onLoading: function(request){show_searching();},onLoaded: function(request){hide_searching();} } ) ; return false">$d</a>
__JS_LINK_SEARCH__
                                }

                                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);

        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	201	Version 0.03
20	dpavlin	1
21			=cut
22
23	dpavlin	201	our $VERSION = '0.03';
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	70	data => $ds
75	dpavlin	21	);
76	dpavlin	16
77	dpavlin	45	It also has follwing template toolikit filter routies defined:
78
79	dpavlin	1	=cut
80
81	dpavlin	16	sub apply {
82			my $self = shift;
83
84			my $args = {@_};
85
86			my $log = $self->_get_logger();
87
88			foreach my $a (qw/template data/) {
89			$log->logconfess("need $a") unless ($args->{$a});
90			}
91
92	dpavlin	45	=head3 tt_filter_type
93	dpavlin	42
94	dpavlin	199	filter to return values of specified from $ds, usage from TT template is in form
95			C<d('FieldName','delimiter')>, where C<delimiter> is optional, like this:
96	dpavlin	45
97	dpavlin	199	[% d('Title') %]
98			[% d('Author',', ' %]
99
100	dpavlin	45	=cut
101
102	dpavlin	43	sub tt_filter_type {
103			my ($data,$type) = @_;
104
105			die "no data?" unless ($data);
106			$type \|\|= 'display';
107	dpavlin	42
108	dpavlin	43	my $default_delimiter = {
109			'display' => '¶<br/>',
110			'index' => '\n',
111			};
112	dpavlin	42
113	dpavlin	43	return sub {
114	dpavlin	42
115	dpavlin	43	my ($name,$join) = @_;
116	dpavlin	42
117	dpavlin	70	die "no data hash" unless ($data->{'data'} && ref($data->{'data'}) eq 'HASH');
118	dpavlin	62	# Hm? Should we die here?
119			return unless ($name);
120	dpavlin	43
121	dpavlin	70	my $item = $data->{'data'}->{$name} \|\| return;
122	dpavlin	43
123			my $v = $item->{$type} \|\| return;
124	dpavlin	42
125	dpavlin	43	if (ref($v) eq 'ARRAY') {
126			if ($#{$v} == 0) {
127			$v = $v->[0];
128			} else {
129			$join = $default_delimiter->{$type} unless defined($join);
130			$v = join($join, @{$v});
131			}
132	dpavlin	199	} else {
133			warn("TT filter $type(): field $name values aren't ARRAY, ignoring");
134	dpavlin	42	}
135	dpavlin	45
136	dpavlin	43	return $v;
137	dpavlin	42	}
138			}
139
140	dpavlin	43	$args->{'d'} = tt_filter_type($args, 'display');
141	dpavlin	199	$args->{'display'} = tt_filter_type($args, 'display');
142	dpavlin	42
143	dpavlin	199	=head3 tt_filter_search
144
145			filter to return links to search, usage in TT:
146
147			[% search('FieldToDisplay','FieldToSearch','optional delimiter') %]
148
149			=cut
150
151			sub tt_filter_search {
152
153			my ($data) = @_;
154
155			die "no data?" unless ($data);
156
157			return sub {
158
159			my ($display,$search,$delimiter) = @_;
160
161			# default delimiter
162			$delimiter \|\|= '¶<br/>',
163
164			die "no data hash" unless ($data->{'data'} && ref($data->{'data'}) eq 'HASH');
165			# Hm? Should we die here?
166			return unless ($display);
167
168			my $item = $data->{'data'}->{$display} \|\| return;
169
170			return unless($item->{'display'});
171			die "error in TT template: field $display didn't insert anything into search, use d('$display') and not search('$display'...)" unless($item->{'search'});
172
173			my @warn;
174			foreach my $type (qw/display search/) {
175			push @warn, "field $display type $type values aren't ARRAY" unless (ref($item->{$type}) eq 'ARRAY');
176			}
177
178			if (@warn) {
179			warn("TT filter search(): " . join(",", @warn) . ", skipping");
180			return;
181			}
182			my @html;
183
184			my $d_el = $#{ $item->{'display'} };
185			my $s_el = $#{ $item->{'search'} };
186
187			# easy, both fields have same number of elements or there is just
188			# one search and multiple display
189			if ( $d_el == $s_el \|\| $s_el == 0 ) {
190
191			foreach my $i ( 0 .. $d_el ) {
192
193			my $s;
194			if ($s_el > 0) {
195			$s = $item->{'search'}->[$i] \|\| die "can't find value $i for type search in field $search";
196			} else {
197			$s = $item->{'search'}->[0];
198			}
199	dpavlin	201	#$s =~ s/([^\w.-])/sprintf("%%%02X",ord($1))/eg;
200			$s = uri_escape_utf8( $s );
201	dpavlin	199
202			my $d = $item->{'display'}->[$i] \|\| die "can't find value $i for type display in field $display";
203
204			push @html, <<__JS_LINK_SEARCH__
205			<a href="#" onclick="new Ajax.Updater( 'results', '/search/results?$search=$s', { asynchronous: 1,onLoading: function(request){show_searching();},onLoaded: function(request){hide_searching();} } ) ; return false">$d</a>
206			__JS_LINK_SEARCH__
207			}
208
209			return join($delimiter, @html);
210			} else {
211			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>};
212			my $v = $item->{'display'};
213
214			if ($#{$v} == 0) {
215			$html .= $v->[0];
216			} else {
217			$html .= join($delimiter, @{$v});
218			}
219			return $html;
220			}
221			}
222			}
223
224			$args->{'search'} = tt_filter_search($args);
225
226	dpavlin	16	my $out;
227
228			$self->{'tt'}->process(
229			$args->{'template'},
230			$args,
231			\$out
232			) \|\| $log->logconfess( "apply can't process template: ", $self->{'tt'}->error() );
233
234			return $out;
235	dpavlin	1	}
236
237	dpavlin	16	=head2 to_file
238	dpavlin	1
239	dpavlin	16	Create output from in-memory data structure using Template Toolkit template
240			to a file.
241
242			$tt->to_file(
243			file => 'out.txt',
244			template => 'text.tt',
245	dpavlin	70	data => $ds
246	dpavlin	16	);
247
248	dpavlin	1	=cut
249
250	dpavlin	16	sub to_file {
251			my $self = shift;
252
253			my $args = {@_};
254
255			my $log = $self->_get_logger();
256
257			my $file = $args->{'file'} \|\| $log->logconfess("need file name");
258
259			$log->debug("creating file ",$file);
260
261			open(my $fh, ">", $file) \|\| $log->logdie("can't open output file '$file': $!");
262			print $fh $self->output(
263			template => $args->{'template'},
264			data => $args->{'data'},
265			) \|\| $log->logdie("print: $!");
266			close($fh) \|\| $log->logdie("close: $!");
267
268			return 1;
269	dpavlin	1	}
270
271	dpavlin	16
272	dpavlin	1	=head1 AUTHOR
273
274			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
275
276			=head1 COPYRIGHT & LICENSE
277
278			Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.
279
280			This program is free software; you can redistribute it and/or modify it
281			under the same terms as Perl itself.
282
283			=cut
284
285	dpavlin	16	1; # End of WebPAC::Output::TT