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

   1 package BSE::Template;
   2 use strict;
   3 use Squirrel::Template;
   4 use Carp 'confess';
   5
   6 sub get_page {
   7   my ($class, $template, $cfg, $acts, $base_template, $rsets) = @_;
   8
   9   my @conf_dirs = $class->template_dirs($cfg);
  10   my $file = $cfg->entry('templates', $template) || $template;
  11   $file =~ /\.\w+$/ or $file .= ".tmpl";
  12   my @dirs;
  13   if ($rsets && @$rsets) {
  14     for my $set (@$rsets) {
  15       push @dirs, map "$_/$set", @conf_dirs;
  16     }
  17     push @dirs, @conf_dirs;
  18   }
  19   else {
  20     @dirs = @conf_dirs;
  21   }
  22
  23   my $obj = Squirrel::Template->new(template_dir => \@dirs);
  24
  25   my $out;
  26   if ($base_template) {
  27     eval {
  28       $out = $obj->show_page(undef, $file, $acts);
  29     };
  30     if ($@) {
  31       if ($@ =~ /Cannot find template/) {
  32         print STDERR "Could not find requested template $file, trying $base_template\n";
  33         $file = $cfg->entry('templates', $base_template) || $base_template;
  34         $file =~ /\.\w+$/ or $file .= ".tmpl";
  35         $out = $obj->show_page(undef, $file, $acts);
  36       }
  37       else {
  38         print STDERR "** Eval error: $@\n";
  39         $out = "<html><body>There was an error producing this page - please contect the webmaster.</body></html>\n";
  40       }
  41     }
  42   }
  43   else {
  44     $out = $obj->show_page(undef, $file, $acts);
  45   }
  46
  47
  48   $out;
  49 }
  50
  51 sub replace {
  52   my ($class, $source, $cfg, $acts) = @_;
  53
  54   my @dirs = $class->template_dirs($cfg);
  55   my $obj = Squirrel::Template->new(template_dir => \@dirs);
  56
  57   $obj->replace_template($source, $acts);
  58 }
  59
  60 sub html_type {
  61   my ($class, $cfg) = @_;
  62
  63   my $type = "text/html";
  64   my $charset = $cfg->entry('html', 'charset');
  65   $charset = 'iso-8859-1' unless defined $charset;
  66   return $type . "; charset=$charset";
  67 }
  68
  69 sub get_type {
  70   my ($class, $cfg, $template) = @_;
  71
  72   return $cfg->entry("template types", $template)
  73     || $class->html_type($cfg);
  74 }
  75
  76 sub show_page {
  77   my ($class, $template, $cfg, $acts, $base_template) = @_;
  78
  79   $class->show_literal($class->get_page($template, $cfg, $acts, $base_template), $cfg);
  80 }
  81
  82 sub show_replaced {
  83   my ($class, $source, $cfg, $acts) = @_;
  84
  85   $class->show_literal($class->replace($source, $cfg, $acts), $cfg);
  86 }
  87
  88 sub show_literal {
  89   my ($class, $text, $cfg) = @_;
  90
  91   my $type = $class->html_type($cfg);
  92
  93   print "Content-Type: $type\n\n";
  94   print $text;
  95 }
  96
  97 sub get_response {
  98   my ($class, $template, $cfg, $acts, $base_template, $rsets) = @_;
  99
 100   my $result =
 101     {
 102      type => $class->get_type($cfg, $template),
 103      content => scalar($class->get_page($template, $cfg, $acts,
 104                                         $base_template, $rsets)),
 105     };
 106   push @{$result->{headers}}, "Content-Length: ".length($result->{content});
 107
 108   $result;
 109 }
 110
 111 sub get_refresh {
 112   my ($class, $url, $cfg) = @_;
 113
 114
 115   return
 116     {
 117      content => '',
 118      headers => [
 119                  "Location: $url",
 120                  "Status: 303"
 121                 ],
 122     };
 123
 124   # the commented out headers were meant to help Opera, but they didn't
 125   return
 126     {
 127      type=>$class->html_type($cfg),
 128      content=>"<html></html>",
 129      headers=>[ qq/Refresh: 0; url=$url/,
 130                 #qq/Cache-Control: no-store, no-cache, must-revalidate, post-check=0, pre-check=0, max-age=0/,
 131                 #qq/Pragma: no-cache/,
 132                 #qq/Expires: Thu, 01 Jan 1970 00:00:00 GMT/
 133               ],
 134     };
 135 }
 136
 137 sub template_dirs {
 138   my ($class, $cfg) = @_;
 139
 140   ref($cfg) eq 'BSE::Cfg'
 141     or confess "Invalid cfg $cfg supplied\n";
 142
 143   my $base = $cfg->entryVar('paths', 'templates');
 144   my $local = $cfg->entry('paths', 'local_templates');
 145   my @dirs = ( $base );
 146   unshift @dirs, $local if $local;
 147
 148   @dirs;
 149 }
 150
 151 sub find_source {
 152   my ($class, $template, $cfg) = @_;
 153
 154   my @dirs = $class->template_dirs($cfg);
 155
 156   my $file = $cfg->entry('templates', $template) || $template;
 157   $file =~ /\.\w+$/ or $file .= ".tmpl";
 158
 159   for my $dir (@dirs) {
 160     return "$dir/$file" if -f "$dir/$file";
 161   }
 162
 163   return;
 164 }
 165
 166 sub get_source {
 167   my ($class, $template, $cfg) = @_;
 168
 169   my $path = $class->find_source($template, $cfg)
 170     or confess "Cannot find template $template";
 171   open SOURCE, "< $path"
 172     or confess "Cannot open template $path: $!";
 173   binmode SOURCE;
 174   my $html = do { local $/; <SOURCE> };
 175   close SOURCE;
 176
 177   $html;
 178 }
 179
 180 sub output_result {
 181   my ($class, $req, $result) = @_;
 182
 183   $result
 184     or return;
 185
 186   select STDOUT;
 187   $| = 1;
 188   push @{$result->{headers}}, "Content-Type: $result->{type}"
 189     if $result->{type};
 190   push @{$result->{headers}}, $req->extra_headers;
 191   my $add_cache_control = 1;
 192   for my $header (@{$result->{headers}}) {
 193     if ($header =~ /^cache-control:/i) {
 194       $add_cache_control = 0;
 195       last;
 196     }
 197   }
 198   if ($add_cache_control) {
 199     push @{$result->{headers}}, "Cache-Control: no-cache";
 200   }
 201   if (exists $ENV{GATEWAY_INTERFACE}
 202       && $ENV{GATEWAY_INTERFACE} =~ /^CGI-Perl\//) {
 203     require Apache;
 204     my $r = Apache->request or die;
 205     $r->send_cgi_header(join("\n", @{$result->{headers}})."\n\n");
 206   }
 207   else {
 208     print "$_\n" for @{$result->{headers}};
 209     print "\n";
 210   }
 211   print $result->{content};
 212 }
 213
 214 1;