site/cgi-bin/modules/BSE/Template.pm

   1 package BSE::Template;
   2 use strict;
   3 use Squirrel::Template;
   4 use Carp qw(confess cluck);
   5 use Config ();
   6
   7 our $VERSION = "1.006";
   8
   9 sub templater {
  10   my ($class, $cfg, $rsets) = @_;
  11
  12   my @conf_dirs = $class->template_dirs($cfg);
  13   my @dirs;
  14   if ($rsets && @$rsets) {
  15     for my $set (@$rsets) {
  16       push @dirs, map "$_/$set", @conf_dirs;
  17     }
  18     push @dirs, @conf_dirs;
  19   }
  20   else {
  21     @dirs = @conf_dirs;
  22   }
  23
  24   my %opts =
  25     (
  26      template_dir => \@dirs,
  27      utf8 => $cfg->utf8,
  28      charset => $cfg->charset,
  29      formats =>
  30      {
  31       html => sub {
  32         require BSE::Util::HTML;
  33         return BSE::Util::HTML::escape_html($_[0]);
  34       },
  35       uri => sub {
  36         require BSE::Util::HTML;
  37         return BSE::Util::HTML::escape_uri($_[0]);
  38       },
  39      },
  40     );
  41   if ($cfg->entry("basic", "cache_templates")) {
  42     require BSE::Cache;
  43     $opts{cache} = BSE::Cache->load($cfg);
  44   }
  45
  46   $opts{preload} = $cfg->entry("basic", "preload_template");
  47
  48   return Squirrel::Template->new(%opts);
  49 }
  50
  51 sub _get_filename {
  52   my ($class, $cfg, $template) = @_;
  53
  54   my $file = $cfg->entry('templates', $template) || $template;
  55   $file =~ /\.\w+$/ or $file .= ".tmpl";
  56
  57   return $file;
  58 }
  59
  60 sub get_page {
  61   my ($class, $template, $cfg, $acts, $base_template, $rsets, $vars) = @_;
  62
  63   my $file = $class->_get_filename($cfg, $template);
  64   my $obj = $class->templater($cfg, $rsets);
  65
  66   my $out;
  67   if ($base_template) {
  68     unless ($class->find_source($template, $cfg)) {
  69       $template = $base_template;
  70       $file = $class->_get_filename($cfg, $template);
  71     }
  72   }
  73
  74   return $obj->show_page(undef, $file, $acts, undef, undef, $vars);
  75 }
  76
  77 sub replace {
  78   my ($class, $source, $cfg, $acts) = @_;
  79
  80   my $obj = $class->templater($cfg);
  81
  82   $obj->replace_template($source, $acts);
  83 }
  84
  85 sub charset {
  86   my ($class, $cfg) = @_;
  87
  88   return $cfg->charset;
  89 }
  90
  91 sub utf8 {
  92   my ($class, $cfg) = @_;
  93
  94   return $cfg->utf8;
  95 }
  96
  97 sub html_type {
  98   my ($class, $cfg) = @_;
  99
 100   my $type = "text/html";
 101   my $charset = $class->charset($cfg);
 102   return $type . "; charset=$charset";
 103 }
 104
 105 sub get_type {
 106   my ($class, $cfg, $template) = @_;
 107
 108   return $cfg->entry("template types", $template)
 109     || $class->html_type($cfg);
 110 }
 111
 112 sub show_page {
 113   my ($class, $template, $cfg, $acts, $base_template) = @_;
 114
 115   $class->show_literal($class->get_page($template, $cfg, $acts, $base_template), $cfg);
 116 }
 117
 118 sub show_replaced {
 119   my ($class, $source, $cfg, $acts) = @_;
 120
 121   $class->show_literal($class->replace($source, $cfg, $acts), $cfg);
 122 }
 123
 124 sub show_literal {
 125   my ($class, $text, $cfg) = @_;
 126
 127   my $type = $class->html_type($cfg);
 128
 129   print "Content-Type: $type\n\n";
 130   print $text;
 131 }
 132
 133 sub get_response {
 134   my ($class, $template, $cfg, $acts, $base_template, $rsets, $vars) = @_;
 135
 136   my $content = $class->get_page($template, $cfg, $acts,
 137                                  $base_template, $rsets, $vars);
 138
 139   return $class->make_response($content, $class->get_type($cfg, $template));
 140 }
 141
 142 sub make_response {
 143   my ($class, $content, $type) = @_;
 144
 145   if ($type =~ /\bcharset=([\w-]+)/) {
 146     my $charset = $1;
 147
 148     require Encode;
 149     Encode->import();
 150     my $cfg = BSE::Cfg->single;
 151     my $check = $cfg->entry("utf8", "check", Encode::FB_DEFAULT());
 152     $check = oct($check) if $check =~ /^0/;
 153
 154     $content = Encode::encode($charset, $content, $check);
 155   }
 156
 157   my $result =
 158     {
 159      type => $type,
 160      content => $content,
 161     };
 162   push @{$result->{headers}}, "Content-Length: ".length($result->{content});
 163
 164   return $result;
 165 }
 166
 167 sub get_refresh {
 168   my ($class, $url, $cfg) = @_;
 169
 170   return
 171     {
 172      content => '',
 173      headers => [
 174                  "Location: $url",
 175                  "Status: 303"
 176                 ],
 177     };
 178 }
 179
 180 sub get_moved {
 181   my ($class, $url, $cfg) = @_;
 182
 183   return
 184     {
 185      content => '',
 186      headers => [
 187                  "Location: $url",
 188                  "Status: 301"
 189                 ],
 190     };
 191 }
 192
 193 sub template_dirs {
 194   my ($class, $cfg) = @_;
 195
 196   ref($cfg) eq 'BSE::Cfg'
 197     or confess "Invalid cfg $cfg supplied\n";
 198
 199   my $path_sep = $Config::Config{path_sep};
 200
 201   my $base = $cfg->entryVar('paths', 'templates');
 202   my @dirs = split /\Q$path_sep/, $base;
 203   my $local = $cfg->entry('paths', 'local_templates');
 204   if ($local) {
 205     unshift @dirs, split /\Q$path_sep/,
 206       $cfg->entryVar('paths', 'local_templates');
 207   }
 208
 209   @dirs;
 210 }
 211
 212 sub find_source {
 213   my ($class, $template, $cfg) = @_;
 214
 215   my @dirs = $class->template_dirs($cfg);
 216
 217   my $file = $cfg->entry('templates', $template) || $template;
 218   $file =~ /\.\w+$/ or $file .= ".tmpl";
 219
 220   for my $dir (@dirs) {
 221     return "$dir/$file" if -f "$dir/$file";
 222   }
 223
 224   return;
 225 }
 226
 227 sub get_source {
 228   my ($class, $template, $cfg) = @_;
 229
 230   my $path = $class->find_source($template, $cfg)
 231     or confess "Cannot find template $template";
 232   open my $source, "< $path"
 233     or confess "Cannot open template $path: $!";
 234   binmode $source;
 235   if ($cfg->utf8) {
 236     my $charset = $cfg->charset;
 237     binmode $source, ":encoding($charset)";
 238   }
 239   my $html = do { local $/; <$source> };
 240   close $source;
 241
 242   $html;
 243 }
 244
 245 sub output_result {
 246   my ($class, $req, $result) = @_;
 247
 248   $class->output_resultc($req->cfg, $result);
 249 }
 250
 251 sub output_resultc {
 252   my ($class, $cfg, $result) = @_;
 253
 254   $result
 255     or return;
 256
 257   select STDOUT;
 258   $| = 1;
 259   push @{$result->{headers}}, "Content-Type: $result->{type}"
 260     if $result->{type};
 261   my $add_cache_control = $cfg->entry('basic', 'no_cache_dynamic', 1);
 262   if (defined $result->{no_cache_dynamic}) {
 263     $add_cache_control = $result->{no_cache_dynamic};
 264   }
 265   if ($add_cache_control) {
 266     for my $header (@{$result->{headers}}) {
 267       if ($header =~ /^cache-control:/i) {
 268         $add_cache_control = 0;
 269         last;
 270       }
 271     }
 272     if ($add_cache_control) {
 273       push @{$result->{headers}}, "Cache-Control: no-cache";
 274     }
 275   }
 276
 277   if ($result->{content_filename}) {
 278     # at some point, if we have a FEP like perlbal of nginx we might
 279     # get it to serve the file instead
 280     if (open my $fh, "<", $result->{content_filename}) {
 281       binmode $fh;
 282       $result->{content_fh} = $fh;
 283     }
 284     else {
 285       print STDERR "$ENV{SCRIPT_NAME}: ** cannot open file $result->{content_filename}: $!\n";
 286       $result->{content} = "* Internal error";
 287     }
 288   }
 289
 290   if (!grep /^content-length:/i, @{$result->{headers}}) {
 291     my $length;
 292     if (defined $result->{content}) {
 293       $length = length $result->{content};
 294     }
 295     if (defined $result->{content_fh}) {
 296       # this may need to change if we support byte ranges
 297       $length += -s $result->{content_fh};
 298     }
 299
 300     if (defined $length) {
 301       push @{$result->{headers}}, "Content-Length: $length";
 302     }
 303   }
 304   if (exists $ENV{GATEWAY_INTERFACE}
 305       && $ENV{GATEWAY_INTERFACE} =~ /^CGI-Perl\//) {
 306     require Apache;
 307     my $r = Apache->request or die;
 308     $r->send_cgi_header(join("\n", @{$result->{headers}})."\n\n");
 309   }
 310   else {
 311     print "$_\n" for @{$result->{headers}};
 312     print "\n";
 313   }
 314   if (defined $result->{content}) {
 315     if ($result->{content} =~ /([^\x00-\xff])/) {
 316       cluck "Wide character in content (\\x{", sprintf("%X", ord $1), "})";
 317     }
 318     print $result->{content};
 319   }
 320   elsif ($result->{content_fh}) {
 321     # in the future this could be updated to support byte ranges
 322     local $/ = \16384;
 323     my $fh = $result->{content_fh};
 324     binmode $fh;
 325     while (my $data = <$fh>) {
 326       print $data;
 327     }
 328   }
 329   else {
 330     print STDERR "$ENV{SCRIPT_NAME}: ** No content supplied\n";
 331     print "** Internal error\n";
 332   }
 333
 334   if ($result->{content}
 335       && $result->{type} =~ m(text/html|application/xhtml\+xml)
 336       && $cfg->entry("html", "validate", 0)) {
 337     require BSE::Util::ValidateHTML;
 338     BSE::Util::ValidateHTML->validate($cfg, $result);
 339   }
 340 }
 341
 342 1;