git.rot13.org Git - webpac2/blob - lib/WebPAC/Output/TT.pm

   1 package WebPAC::Output::TT;
   2
   3 use warnings;
   4 use strict;
   5
   6 use base qw/WebPAC::Common/;
   7
   8 use Template;
   9 use List::Util qw/first/;
  10 use Data::Dump qw/dump/;
  11 use Encode;
  12
  13 =head1 NAME
  14
  15 WebPAC::Output::TT - use Template Toolkit to produce output
  16
  17 =head1 VERSION
  18
  19 Version 0.07
  20
  21 =cut
  22
  23 our $VERSION = '0.07';
  24
  25 =head1 SYNOPSIS
  26
  27 Produce output using Template Toolkit.
  28
  29 =head1 FUNCTIONS
  30
  31 =head2 new
  32
  33 Create new instance.
  34
  35  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
  42 By default, Template Toolkit will C<EVAL_PERL> if included in templates.
  43
  44 =cut
  45
  46 sub new {
  47         my $class = shift;
  48         my $self = {@_};
  49         bless($self, $class);
  50
  51         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->{'filters'},
  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: ",dump($self->{'filters'}));
  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  my $text = $tt->apply(
  73         template => 'text.tt',
  74         data => $ds,
  75         record_uri => 'database/prefix/mfn',
  76  );
  77
  78 It also has follwing template toolikit filter routies defined:
  79
  80 =cut
  81
  82 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 =head3 tt_filter_type
  94
  95 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
  98   [% d('Title') %]
  99   [% d('Author',', ' %]
 100
 101 =cut
 102
 103         sub tt_filter_type {
 104                 my ($data,$type) = @_;
 105
 106                 die "no data?" unless ($data);
 107                 $type ||= 'display';
 108
 109                 my $default_delimiter = {
 110                         'display' => '&#182;<br/>',
 111                         'index' => '\n',
 112                 };
 113
 114                 return sub {
 115
 116                         my ($name,$join) = @_;
 117
 118                         die "no data hash" unless ($data->{'data'} && ref($data->{'data'}) eq 'HASH');
 119                         # Hm? Should we die here?
 120                         return unless ($name);
 121
 122                         my $item = $data->{'data'}->{$name} || return;
 123
 124                         my $v = $item->{$type} || return;
 125
 126                         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                         } else {
 134                                 warn("TT filter $type(): field $name values aren't ARRAY, ignoring");
 135                         }
 136
 137                         return $v;
 138                 }
 139         }
 140
 141         $args->{'d'} = tt_filter_type($args, 'display');
 142         $args->{'display'} = tt_filter_type($args, 'display');
 143
 144 =head3 tt_filter_search
 145
 146 filter to return links to search, usage in TT:
 147
 148   [% search('FieldToDisplay','FieldToSearch','optional delimiter', 'optional_template.tt') %]
 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,$template) = @_;
 161
 162                         # default delimiter
 163                         $delimiter ||= '&#182;<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                         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
 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];
 200                                                 die "can't find value $i for type search in field $search" unless (defined($s));
 201                                         } else {
 202                                                 $s = $item->{'search'}->[0];
 203                                         }
 204                                         #$s =~ s/([^\w.-])/sprintf("%%%02X",ord($1))/eg;
 205                                         $s = __quotemeta( $s );
 206
 207                                         my $d = $item->{'display'}->[$i];
 208                                                 die "can't find value $i for type display in field $display" unless (defined($d));
 209
 210                                         my $template_arg = '';
 211                                         $template_arg = qq{,'$template'} if ($template);
 212
 213                                         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                                 }
 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 =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         };
 278
 279         if ($self->{filters}) {
 280                 $args->{f} = $self->{filters};
 281                 $log->debug("using f.filters");
 282         }
 283
 284         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 }
 294
 295 =head2 to_file
 296
 297 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         data => $ds
 304  );
 305
 306 =cut
 307
 308 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 }
 328
 329
 330 =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 =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 1; # End of WebPAC::Output::TT