Debbugs/Text.pm

   1 # This module is part of debbugs, and is released
   2 # under the terms of the GPL version 2, or any later
   3 # version at your option.
   4 # See the file README and COPYING for more information.
   5 #
   6 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
   7
   8 package Debbugs::Text;
   9
  10 use warnings;
  11 use strict;
  12
  13 =head1 NAME
  14
  15 Debbugs::Text -- General routines for text templates
  16
  17 =head1 SYNOPSIS
  18
  19  use Debbugs::Text qw(:templates);
  20  print fill_in_template(template => 'cgi/foo');
  21
  22 =head1 DESCRIPTION
  23
  24 This module is a replacement for parts of common.pl; subroutines in
  25 common.pl will be gradually phased out and replaced with equivalent
  26 (or better) functionality here.
  27
  28 =head1 BUGS
  29
  30 None known.
  31
  32 =cut
  33
  34
  35 use vars qw($DEBUG $VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT @ISA);
  36 use base qw(Exporter);
  37
  38 BEGIN {
  39      $VERSION = 1.00;
  40      $DEBUG = 0 unless defined $DEBUG;
  41
  42      @EXPORT = ();
  43      %EXPORT_TAGS = (templates => [qw(fill_in_template)],
  44                     );
  45      @EXPORT_OK = ();
  46      Exporter::export_ok_tags(qw(templates));
  47      $EXPORT_TAGS{all} = [@EXPORT_OK];
  48      push @ISA,qw(Safe::Hole::User);
  49 }
  50
  51 use Safe;
  52 use Safe::Hole;
  53 use Text::Template;
  54
  55 use Storable qw(dclone);
  56
  57 use Debbugs::Config qw(:config);
  58
  59 use Params::Validate qw(:types validate_with);
  60 use Carp;
  61 use IO::File;
  62 use Data::Dumper;
  63
  64 our %tt_templates;
  65 our %filled_templates;
  66 our $safe;
  67 our $hole = Safe::Hole->new({});
  68 our $language;
  69
  70 # This function is what is called when someone does include('foo/bar')
  71 # {include('foo/bar')}
  72
  73 sub include {
  74      my $template = shift;
  75      $filled_templates{$template}++;
  76      print STDERR "include template $template language $language safe $safe\n" if $DEBUG;
  77      # Die if we're in a template loop
  78      die "Template loop with $template" if $filled_templates{$template} > 10;
  79      my $filled_tmpl = '';
  80      eval {
  81           $filled_tmpl = fill_in_template(template  => $template,
  82                                           variables => {},
  83                                           language  => $language,
  84                                           safe      => $safe,
  85                                          );
  86      };
  87      if ($@) {
  88           print STDERR "failed to fill template $template: $@";
  89      }
  90      print STDERR "failed to fill template $template\n" if $filled_tmpl eq '' and $DEBUG;
  91      print STDERR "template $template '$filled_tmpl'\n" if $DEBUG;
  92      $filled_templates{$template}--;
  93      return $filled_tmpl;
  94 };
  95
  96
  97 =head2 fill_in_template
  98
  99      print fill_in_template(template => 'template_name',
 100                             variables => \%variables,
 101                             language  => '..'
 102                            );
 103
 104 Reads a template from disk (if it hasn't already been read in) and
 105 fills the template in.
 106
 107 =cut
 108
 109
 110 sub fill_in_template{
 111      my %param = validate_with(params => \@_,
 112                                spec   => {template => SCALAR|HANDLE|SCALARREF,
 113                                           variables => {type => HASHREF,
 114                                                         default => {},
 115                                                        },
 116                                           language  => {type => SCALAR,
 117                                                         default => 'en_US',
 118                                                        },
 119                                           output    => {type => HANDLE,
 120                                                         optional => 1,
 121                                                        },
 122                                           safe      => {type => OBJECT|UNDEF,
 123                                                         optional => 1,
 124                                                        },
 125                                           hole_var  => {type => HASHREF,
 126                                                         optional => 1,
 127                                                        },
 128                                          },
 129                               );
 130      #@param{qw(template variables language safe output hole_var no_safe)} = @_;
 131      if ($DEBUG) {
 132           print STDERR "fill_in_template ";
 133           print STDERR join(" ",map {exists $param{$_}?"$_:$param{$_}":()} keys %param);
 134           print STDERR "\n";
 135      }
 136
 137      # Get the text
 138      my $tt_type = '';
 139      my $tt_source;
 140      if (ref($param{template}) eq 'GLOB' or
 141          ref(\$param{template}) eq 'GLOB') {
 142           $tt_type = 'FILE_HANDLE';
 143           $tt_source = $param{template};
 144           binmode($tt_source,":encoding(UTF-8)");
 145      }
 146      elsif (ref($param{template}) eq 'SCALAR') {
 147           $tt_type = 'STRING';
 148           $tt_source = ${$param{template}};
 149      }
 150      else {
 151           $tt_type = 'FILE';
 152           $tt_source = _locate_text($param{template},$param{language});
 153      }
 154      if (not defined $tt_source) {
 155           die "Unable to find template $param{template} with language $param{language}";
 156      }
 157
 158 #      if (defined $param{safe}) {
 159 #         $safe = $param{safe};
 160 #      }
 161 #      else {
 162 #         print STDERR "Created new safe\n" if $DEBUG;
 163 #         $safe = Safe->new() or die "Unable to create safe compartment";
 164 #         $safe->permit_only(':base_core',':base_loop',':base_mem',
 165 #                            qw(padsv padav padhv padany),
 166 #                            qw(rv2gv refgen srefgen ref),
 167 #                            qw(caller require entereval),
 168 #                            qw(gmtime time sprintf prtf),
 169 #                            qw(sort),
 170 #                           );
 171 #         $safe->share('*STDERR');
 172 #         $safe->share('%config');
 173 #         $hole->wrap(\&Debbugs::Text::include,$safe,'&include');
 174 #         my $root = $safe->root();
 175 #         # load variables into the safe
 176 #         for my $key (keys %{$param{variables}||{}}) {
 177 #              print STDERR "Loading $key\n" if $DEBUG;
 178 #              if (ref($param{variables}{$key})) {
 179 #                   no strict 'refs';
 180 #                   print STDERR $safe->root().'::'.$key,qq(\n) if $DEBUG;
 181 #                   *{"${root}::$key"} = $param{variables}{$key};
 182 #              }
 183 #              else {
 184 #                   no strict 'refs';
 185 #                   ${"${root}::$key"} = $param{variables}{$key};
 186 #              }
 187 #         }
 188 #         for my $key (keys %{exists $param{hole_var}?$param{hole_var}:{}}) {
 189 #              print STDERR "Wraping $key as $param{hole_var}{$key}\n" if $DEBUG;
 190 #              $hole->wrap($param{hole_var}{$key},$safe,$key);
 191 #         }
 192 #      }
 193      $language = $param{language};
 194      my $tt;
 195      if ($tt_type eq 'FILE' and
 196          defined $tt_templates{$tt_source} and
 197          ($tt_templates{$tt_source}{mtime} + 60) < time and
 198          (stat $tt_source)[9] <= $tt_templates{$tt_source}{mtime}
 199         ) {
 200           $tt = $tt_templates{$tt_source}{template};
 201      }
 202      else {
 203          my $passed_source = $tt_source;
 204          my $passed_type = $tt_type;
 205           if ($tt_type eq 'FILE') {
 206                $tt_templates{$tt_source}{mtime} =
 207                     (stat $tt_source)[9];
 208                $passed_source = IO::File->new($tt_source,'r');
 209                binmode($passed_source,":encoding(UTF-8)");
 210                $passed_type = 'FILEHANDLE';
 211           }
 212           $tt = Text::Template->new(TYPE => $passed_type,
 213                                     SOURCE => $passed_source,
 214                                     UNTAINT => 1,
 215                                    );
 216           if ($tt_type eq 'FILE') {
 217                $tt_templates{$tt_source}{template} = $tt;
 218           }
 219      }
 220      if (not defined $tt) {
 221           die "Unable to create Text::Template for $tt_type:$tt_source";
 222      }
 223      my $ret = $tt->fill_in(#SAFE => $safe,
 224                             PACKAGE => 'DTT',
 225                             HASH => {%{$param{variables}//{}},
 226                                      (map {my $t = $_; $t =~ s/^\&//; ($t => $param{hole_var}{$_})}
 227                                       keys %{$param{hole_var}//{}}),
 228                                      include => \&Debbugs::Text::include,
 229                                      config  => \%config,
 230                                     },
 231                             defined $param{output}?(OUTPUT=>$param{output}):(),
 232                            );
 233      if (not defined $ret) {
 234           print STDERR $Text::Template::ERROR;
 235           return '';
 236      }
 237      if ($DEBUG) {
 238           no strict 'refs';
 239           no warnings 'uninitialized';
 240 #         my $temp = $param{nosafe}?'main':$safe->{Root};
 241           print STDERR "Variables for $param{template}\n";
 242 #         print STDERR "Safe $temp\n";
 243 #         print STDERR map {"$_: ".*{$_}."\n"} keys %{"${temp}::"};
 244      }
 245
 246      return $ret;
 247 }
 248
 249 sub _locate_text{
 250      my ($template,$language) = @_;
 251      $template =~ s/\.tmpl$//g;
 252      # if a language doesn't exist, use the en_US template
 253      if (not -e $config{template_dir}.'/'.$language.'/'.$template.'.tmpl') {
 254           $language = 'en_US';
 255      }
 256      my $loc = $config{template_dir}.'/'.$language.'/'.$template.'.tmpl';
 257      if (not -e $loc) {
 258           print STDERR "Unable to locate template $loc\n";
 259           return undef;
 260      }
 261      return $loc;
 262 }
 263
 264 1;