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 }
  49
  50 use Safe;
  51 use Text::Template;
  52
  53 use Storable qw(dclone);
  54
  55 use Debbugs::Config qw(:config);
  56
  57 use Params::Validate qw(:types validate_with);
  58 use Carp;
  59 use IO::File;
  60 use Data::Dumper;
  61
  62 =head2 fill_in_template
  63
  64      print fill_in_template(template => 'template_name',
  65                             variables => \%variables,
  66                             language  => '..'
  67                            );
  68
  69 Reads a template from disk (if it hasn't already been read in) and
  70 fills the template in.
  71
  72 =cut
  73
  74 our %tt_templates;
  75 our %filled_templates;
  76 our $safe;
  77 our $hole;
  78 our $language;
  79 sub fill_in_template{
  80      my %param = validate_with(params => \@_,
  81                                spec   => {template => SCALAR|HANDLE|SCALARREF,
  82                                           variables => {type => HASHREF,
  83                                                         default => {},
  84                                                        },
  85                                           language  => {type => SCALAR,
  86                                                         default => 'en_US',
  87                                                        },
  88                                           output    => {type => HANDLE,
  89                                                         optional => 1,
  90                                                        },
  91                                           safe      => {type => OBJECT,
  92                                                         optional => 1,
  93                                                        },
  94                                           hole_var  => {type => HASHREF,
  95                                                         optional => 1,
  96                                                        },
  97                                          },
  98                               );
  99      return _fill_in_template(@param{qw(template variables language safe output hole_var)});
 100 }
 101
 102
 103 sub include {
 104      my $template = shift;
 105      $filled_templates{$template}++;
 106      print STDERR "include template $template language $language safe $safe\n" if $DEBUG;
 107      # Die if we're in a template loop
 108      die "Template loop with $template" if $filled_templates{$template} > 10;
 109      my $filled_tmpl;
 110      eval {
 111           $filled_tmpl = Debbugs::Text::_fill_in_template($template,
 112                                                           {},
 113                                                           $language,
 114                                                           $safe,
 115                                                           undef,
 116                                                           {},
 117                                                           1
 118                                                          );
 119      };
 120      if ($@) {
 121           print STDERR "failed to fill template $template: $@";
 122      }
 123      print STDERR "failed to fill template $template\n" if $filled_tmpl eq '' and $DEBUG;
 124      print STDERR "template $template '$filled_tmpl'\n" if $DEBUG;
 125      $filled_templates{$template}--;
 126      return $filled_tmpl;
 127 };
 128
 129 sub _fill_in_template{
 130      my %param;
 131      @param{qw(template variables language safe output hole_var no_safe)} = @_;
 132      print STDERR "_fill template $param{template} language $param{language} safe $param{safe}\n"
 133           if $DEBUG;
 134
 135      # Get the text
 136      my $tt_type = '';
 137      my $tt_source;
 138      if (ref($param{template}) eq 'GLOB' or
 139          ref(\$param{template}) eq 'GLOB') {
 140           $tt_type = 'FILE_HANDLE';
 141           $tt_source = $param{template};
 142      }
 143      elsif (ref($param{template}) eq 'SCALAR') {
 144           $tt_type = 'STRING';
 145           $tt_source = ${$param{template}};
 146      }
 147      else {
 148           $tt_type = 'FILE';
 149           $tt_source = _locate_text($param{template},$param{language});
 150      }
 151      if (not defined $tt_source) {
 152           die "Unable to find template $param{template} with language $param{language}";
 153      }
 154
 155      if (defined $param{safe}) {
 156           $safe = $param{safe};
 157           if (not defined $hole) {
 158                $hole = Safe::Hole->new();
 159           }
 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->deny_only();
 165           my @modules = ('Text::Template' => undef,
 166                          # This doesn't work yet; have to figure it out
 167                          #'Debbugs::Config' => [qw(:globals :config)],
 168                         );
 169           while (my ($module,$param) = splice (@modules,0,2)) {
 170                print STDERR "Eval $module\n" if $DEBUG;
 171                my $code = '';
 172                if (not defined $param) {
 173                     $code = "use $module;";
 174                }
 175                else {
 176                     $code = "use $module ".(join(',',map {"q($_)"} @{$param})).';';
 177                }
 178                $safe->reval($code);
 179                print STDERR "Error while attempting to eval '$code': $@" if $@;
 180           }
 181           $safe->permit_only(':base_core',':base_io',':base_mem',':base_loop',
 182                              qw(padsv padav padhv padany),
 183                              qw(rv2gv refgen srefgen ref),
 184                             );
 185           $safe->share('$language','%tt_templates','$safe','$variables','%filled_templates');
 186           $safe->share('*STDERR');
 187           $safe->share('&_fill_in_template');
 188           $safe->share('%config');
 189           $safe->share('&include');
 190           my $root = $safe->root();
 191           # load variables into the safe
 192           for my $key (keys %{$param{variables}||{}}) {
 193                print STDERR "Loading $key\n" if $DEBUG;
 194                if (ref($param{variables}{$key})) {
 195                     no strict 'refs';
 196                     print STDERR $safe->root().'::'.$key,qq(\n) if $DEBUG;
 197                     *{"${root}::$key"} = $param{variables}{$key};
 198                }
 199                else {
 200                     no strict 'refs';
 201                     ${"${root}::$key"} = $param{variables}{$key};
 202                }
 203           }
 204           for my $key (keys %{$param{hole_var}||{}}) {
 205                $hole->wrap($param{hole_var}{$key},$safe,$key);
 206           }
 207      }
 208      #$safe->deny_only();
 209      # perldoc Opcode; for details
 210      $language = $param{language};
 211      my $tt;
 212      if ($tt_type eq 'FILE' and
 213          defined $tt_templates{$tt_source} and
 214          (stat $tt_source)[9] > $tt_templates{$tt_source}{mtime}
 215         ) {
 216           $tt = $tt_templates{$tt_source}{template};
 217      }
 218      else {
 219           if ($tt_type eq 'FILE') {
 220                $tt_templates{$tt_source}{mtime} =
 221                     (stat $tt_source)[9];
 222           }
 223           $tt = Text::Template->new(TYPE => $tt_type,
 224                                     SOURCE => $tt_source,
 225                                    );
 226           if ($tt_type eq 'FILE') {
 227                $tt_templates{$tt_source}{template} = $tt;
 228           }
 229      }
 230      if (not defined $tt) {
 231           die "Unable to create Text::Template for $tt_type:$tt_source";
 232      }
 233      my $ret = $tt->fill_in(#(defined $param{nosafe} and $param{nosafe})?():(HASH=>$param{variables}),
 234                             (defined $param{nosafe} and $param{nosafe})?():(SAFE=>$safe),
 235                             #SAFE => $safe,
 236                             (defined $param{nosafe} and $param{nosafe})?(PACKAGE => 'main'):(),
 237                             defined $param{output}?(OUTPUT=>$param{output}):(),
 238                            );
 239      if (not defined $ret) {
 240           print STDERR $Text::Template::ERROR;
 241           return '';
 242      }
 243      if ($DEBUG) {
 244           no strict 'refs';
 245           no warnings 'uninitialized';
 246           my $temp = $param{nosafe}?'main':$safe->{Root};
 247           print STDERR "Variables for $param{template}\n";
 248           print STDERR "Safe $temp\n";
 249           print STDERR map {"$_:${$_}\n"} keys %{"${temp}::"};
 250           print STDERR ${"${temp}::search_value"},qq(\n);
 251      }
 252
 253      return $ret;
 254 }
 255
 256 sub _locate_text{
 257      my ($template,$language) = @_;
 258      $template =~ s/\.tmpl$//g;
 259      # if a language doesn't exist, use the en_US template
 260      if (not -e $config{template_dir}.'/'.$language.'/'.$template.'.tmpl') {
 261           $language = 'en_US';
 262      }
 263      my $loc = $config{template_dir}.'/'.$language.'/'.$template.'.tmpl';
 264      if (not -e $loc) {
 265           print STDERR "Unable to locate template $loc\n";
 266           return undef;
 267      }
 268      return $loc;
 269 }
 270
 271 1;