lib/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 Exporter qw(import);
  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 Text::Xslate qw(html_builder);
  51
  52 use Storable qw(dclone);
  53
  54 use Debbugs::Config qw(:config);
  55
  56 use Params::Validate qw(:types validate_with);
  57 use Carp;
  58 use IO::File;
  59 use Data::Dumper;
  60
  61 ### for %text_xslate_functions
  62 use POSIX;
  63 use Debbugs::CGI qw(html_escape);
  64 use Scalar::Util;
  65 use Debbugs::Common qw(make_list);
  66 use Debbugs::Status;
  67
  68 our %tt_templates;
  69 our %filled_templates;
  70 our $language;
  71
  72
  73 sub __output_select_options {
  74     my ($options,$value) = @_;
  75     my @options = @{$options};
  76     my $output = '';
  77     while (@options) {
  78         my ($o_value) = shift @options;
  79         if (ref($o_value)) {
  80             for (@{$o_value}) {
  81                 unshift @options,
  82                     ($_,$_);
  83             }
  84             next;
  85         }
  86         my $name = shift @options;
  87         my $selected = '';
  88         if (defined $value and $o_value eq $value) {
  89             $selected = ' selected';
  90         }
  91         $output .= q(<option value=").html_escape($o_value).qq("$selected>).
  92             html_escape($name).qq(</option>\n);
  93     }
  94     return $output;
  95 }
  96
  97 sub __text_xslate_functions {
  98     return
  99         {gm_strftime => sub {POSIX::strftime($_[0],gmtime)},
 100          package_links => html_builder(\&Debbugs::CGI::package_links),
 101          bug_links => html_builder(\&Debbugs::CGI::bug_links),
 102          looks_like_number => \&Scalar::Util::looks_like_number,
 103          isstrongseverity => \&Debbugs::Status::isstrongseverity,
 104          secs_to_english => \&Debbugs::Common::secs_to_english,
 105          maybelink => \&Debbugs::CGI::maybelink,
 106          # add in a few utility routines
 107          duplicate_array =>  sub {
 108              my @r = map {($_,$_)} make_list(@{$_[0]});
 109              return @r;
 110          },
 111          output_select_options => html_builder(\&__output_select_options),
 112          make_list => \&make_list,
 113         };
 114 }
 115 sub __text_xslate_functions_text {
 116     return
 117        {bugurl =>
 118         sub{
 119             return "$_[0]: ".
 120                 $config{cgi_domain}.'/'.
 121                 Debbugs::CGI::bug_links(bug=>$_[0],
 122                                         links_only => 1,
 123                                        );
 124         },
 125        };
 126 }
 127
 128
 129
 130 ### this function removes leading spaces from line-start code strings and spaces
 131 ### before <:- and spaces after -:>
 132 sub __html_template_prefilter {
 133     my $text = shift;
 134     $text =~ s/^\s+:/:/mg;
 135     $text =~ s/((?:^:[^\n]*\n)?)\s*(<:-)/$1$2/mg;
 136     $text =~ s/(-:>)\s+(^:|)/$1.(length($2)?"\n$2":'')/emg;
 137     return $text;
 138 }
 139
 140
 141 =head2 fill_in_template
 142
 143      print fill_in_template(template => 'template_name',
 144                             variables => \%variables,
 145                             language  => '..'
 146                            );
 147
 148 Reads a template from disk (if it hasn't already been read in) andf
 149 ills the template in.
 150
 151 =cut
 152
 153 sub fill_in_template{
 154      my %param = validate_with(params => \@_,
 155                                spec   => {template => SCALAR,
 156                                           variables => {type => HASHREF,
 157                                                         default => {},
 158                                                        },
 159                                           language  => {type => SCALAR,
 160                                                         default => 'en_US',
 161                                                        },
 162                                           output    => {type => HANDLE,
 163                                                         optional => 1,
 164                                                        },
 165                                           hole_var  => {type => HASHREF,
 166                                                         optional => 1,
 167                                                        },
 168                                           output_type => {type => SCALAR,
 169                                                           default => 'html',
 170                                                          },
 171                                          },
 172                               );
 173      # Get the text
 174      my $output_type = $param{output_type};
 175      my $language = $param{language};
 176      my $template = $param{template};
 177      $template .= '.tx' unless $template =~ /\.tx$/;
 178      my $tt;
 179      if (not exists $tt_templates{$output_type}{$language} or
 180          not defined $tt_templates{$output_type}{$language}
 181         ) {
 182          $tt_templates{$output_type}{$language} =
 183              Text::Xslate->new(# cache in template_cache or temp directory
 184                                cache_dir => $config{template_cache} //
 185                                File::Temp::tempdir(CLEANUP => 1),
 186                                # default to the language, but fallback to en_US
 187                                path => [$config{template_dir}.'/'.$language.'/',
 188                                         $config{template_dir}.'/en_US/',
 189                                        ],
 190                                suffix => '.tx',
 191                                ## use html or text specific functions
 192                                function =>
 193                                ($output_type eq 'html' ? __text_xslate_functions() :
 194                                 __text_xslate_functions_text()),
 195                                syntax => 'Kolon',
 196                                module => ['Text::Xslate::Bridge::Star',
 197                                           'Debbugs::Text::XslateBridge',
 198                                          ],
 199                                type   => $output_type,
 200                                ## use the html-specific pre_process_handler
 201                                $output_type eq 'html'?
 202                                (pre_process_handler => \&__html_template_prefilter):(),
 203                               )
 204                  or die "Unable to create Text::Xslate";
 205      }
 206      $tt = $tt_templates{$output_type}{$language};
 207      my $ret =
 208          $tt->render($template,
 209                     {time => time,
 210                      %{$param{variables}//{}},
 211                      config  => \%config,
 212                     });
 213      if (exists $param{output}) {
 214          print {$param{output}} $ret;
 215          return '';
 216      }
 217      return $ret;
 218 }
 219
 220 1;