package BSE::Template;
use strict;
use Squirrel::Template;
-use Carp 'confess';
+use Carp qw(confess cluck);
+use Config ();
-sub get_page {
- my ($class, $template, $cfg, $acts, $base_template) = @_;
+our $VERSION = "1.007";
+
+sub templater {
+ my ($class, $cfg, $rsets) = @_;
+
+ my @conf_dirs = $class->template_dirs($cfg);
+ my @dirs;
+ if ($rsets && @$rsets) {
+ for my $set (@$rsets) {
+ push @dirs, map "$_/$set", @conf_dirs;
+ }
+ push @dirs, @conf_dirs;
+ }
+ else {
+ @dirs = @conf_dirs;
+ }
+
+ my %opts =
+ (
+ template_dir => \@dirs,
+ utf8 => $cfg->utf8,
+ charset => $cfg->charset,
+ formats =>
+ {
+ html => sub {
+ require BSE::Util::HTML;
+ return BSE::Util::HTML::escape_html($_[0]);
+ },
+ uri => sub {
+ require BSE::Util::HTML;
+ return BSE::Util::HTML::escape_uri($_[0]);
+ },
+ },
+ );
+ if ($cfg->entry("basic", "cache_templates")) {
+ require BSE::Cache;
+ $opts{cache} = BSE::Cache->load($cfg);
+ }
+
+ $opts{preload} = $cfg->entry("basic", "preload_template");
+
+ return Squirrel::Template->new(%opts);
+}
+
+sub _get_filename {
+ my ($class, $cfg, $template) = @_;
- my @dirs = $class->template_dirs($cfg);
my $file = $cfg->entry('templates', $template) || $template;
$file =~ /\.\w+$/ or $file .= ".tmpl";
-
- my $obj = Squirrel::Template->new(template_dir => \@dirs);
+ return $file;
+}
+
+sub get_page {
+ my ($class, $template, $cfg, $acts, $base_template, $rsets, $vars) = @_;
+
+ my $file = $class->_get_filename($cfg, $template);
+ my $obj = $class->templater($cfg, $rsets);
my $out;
if ($base_template) {
- eval {
- $out = $obj->show_page(undef, $file, $acts);
- };
- if ($@) {
- if ($@ =~ /Cannot find template/) {
- print STDERR "Could not find requested template $file, trying $base_template\n";
- $file = $cfg->entry('templates', $base_template) || $base_template;
- $file =~ /\.\w+$/ or $file .= ".tmpl";
- $out = $obj->show_page(undef, $file, $acts);
- }
- else {
- print STDERR "** Eval error: $@\n";
- $out = "<html><body>There was an error producing this page - please contect the webmaster.</body></html>\n";
- }
+ unless ($class->find_source($template, $cfg)) {
+ $template = $base_template;
+ $file = $class->_get_filename($cfg, $template);
}
}
- else {
- $out = $obj->show_page(undef, $file, $acts);
- }
-
- $out;
+ return $obj->show_page(undef, $file, $acts, undef, undef, $vars);
}
sub replace {
- my ($class, $source, $cfg, $acts) = @_;
+ my ($class, $source, $cfg, $acts, $vars) = @_;
- my @dirs = $class->template_dirs($cfg);
- my $obj = Squirrel::Template->new(template_dir => \@dirs);
+ my $obj = $class->templater($cfg);
+
+ $obj->replace_template($source, $acts, undef, undef, $vars);
+}
+
+sub charset {
+ my ($class, $cfg) = @_;
- $obj->replace_template($source, $acts);
+ return $cfg->charset;
+}
+
+sub utf8 {
+ my ($class, $cfg) = @_;
+
+ return $cfg->utf8;
}
sub html_type {
my ($class, $cfg) = @_;
my $type = "text/html";
- my $charset = $cfg->entry('html', 'charset');
- $charset = 'iso-8859-1' unless defined $charset;
+ my $charset = $class->charset($cfg);
return $type . "; charset=$charset";
}
}
sub get_response {
- my ($class, $template, $cfg, $acts, $base_template) = @_;
+ my ($class, $template, $cfg, $acts, $base_template, $rsets, $vars) = @_;
+
+ my $content = $class->get_page($template, $cfg, $acts,
+ $base_template, $rsets, $vars);
+
+ return $class->make_response($content, $class->get_type($cfg, $template));
+}
+
+sub make_response {
+ my ($class, $content, $type) = @_;
+
+ if ($type =~ /\bcharset=([\w-]+)/) {
+ my $charset = $1;
+
+ require Encode;
+ Encode->import();
+ my $cfg = BSE::Cfg->single;
+ my $check = $cfg->entry("utf8", "check", Encode::FB_DEFAULT());
+ $check = oct($check) if $check =~ /^0/;
+
+ $content = Encode::encode($charset, $content, $check);
+ }
my $result =
{
- type => $class->get_type($cfg, $template),
- content => scalar($class->get_page($template, $cfg, $acts, $base_template)),
+ type => $type,
+ content => $content,
};
push @{$result->{headers}}, "Content-Length: ".length($result->{content});
- $result;
+ return $result;
}
sub get_refresh {
my ($class, $url, $cfg) = @_;
- # the commented out headers were meant to help Opera, but they didn't
return
{
- type=>$class->html_type($cfg),
- content=>"<html></html>",
- headers=>[ qq/Refresh: 0; url=$url/,
- #qq/Cache-Control: no-store, no-cache, must-revalidate, post-check=0, pre-check=0, max-age=0/,
- #qq/Pragma: no-cache/,
- #qq/Expires: Thu, 01 Jan 1970 00:00:00 GMT/
- ],
+ content => '',
+ headers => [
+ "Location: $url",
+ "Status: 303"
+ ],
+ };
+}
+
+sub get_moved {
+ my ($class, $url, $cfg) = @_;
+
+ return
+ {
+ content => '',
+ headers => [
+ "Location: $url",
+ "Status: 301"
+ ],
};
}
ref($cfg) eq 'BSE::Cfg'
or confess "Invalid cfg $cfg supplied\n";
+ my $path_sep = $Config::Config{path_sep};
+
my $base = $cfg->entryVar('paths', 'templates');
+ my @dirs = split /\Q$path_sep/, $base;
my $local = $cfg->entry('paths', 'local_templates');
- my @dirs = ( $base );
- unshift @dirs, $local if $local;
+ if ($local) {
+ unshift @dirs, split /\Q$path_sep/,
+ $cfg->entryVar('paths', 'local_templates');
+ }
@dirs;
}
my $path = $class->find_source($template, $cfg)
or confess "Cannot find template $template";
- open SOURCE, "< $path"
+ open my $source, "< $path"
or confess "Cannot open template $path: $!";
- binmode SOURCE;
- my $html = do { local $/; <SOURCE> };
- close SOURCE;
+ binmode $source;
+ if ($cfg->utf8) {
+ my $charset = $cfg->charset;
+ binmode $source, ":encoding($charset)";
+ }
+ my $html = do { local $/; <$source> };
+ close $source;
$html;
}
sub output_result {
my ($class, $req, $result) = @_;
+ $class->output_resultc($req->cfg, $result);
+}
+
+sub output_resultc {
+ my ($class, $cfg, $result) = @_;
+
+ $result
+ or return;
+
select STDOUT;
$| = 1;
- push @{$result->{headers}}, "Content-Type: $result->{type}";
- push @{$result->{headers}}, $req->extra_headers;
+ push @{$result->{headers}}, "Content-Type: $result->{type}"
+ if $result->{type};
+ my $add_cache_control = $cfg->entry('basic', 'no_cache_dynamic', 1);
+ if (defined $result->{no_cache_dynamic}) {
+ $add_cache_control = $result->{no_cache_dynamic};
+ }
+ if ($add_cache_control) {
+ for my $header (@{$result->{headers}}) {
+ if ($header =~ /^cache-control:/i) {
+ $add_cache_control = 0;
+ last;
+ }
+ }
+ if ($add_cache_control) {
+ push @{$result->{headers}}, "Cache-Control: no-cache";
+ }
+ }
+
+ if ($result->{content_filename}) {
+ # at some point, if we have a FEP like perlbal of nginx we might
+ # get it to serve the file instead
+ if (open my $fh, "<", $result->{content_filename}) {
+ binmode $fh;
+ $result->{content_fh} = $fh;
+ }
+ else {
+ print STDERR "$ENV{SCRIPT_NAME}: ** cannot open file $result->{content_filename}: $!\n";
+ $result->{content} = "* Internal error";
+ }
+ }
+
+ if (!grep /^content-length:/i, @{$result->{headers}}) {
+ my $length;
+ if (defined $result->{content}) {
+ $length = length $result->{content};
+ }
+ if (defined $result->{content_fh}) {
+ # this may need to change if we support byte ranges
+ $length += -s $result->{content_fh};
+ }
+
+ if (defined $length) {
+ push @{$result->{headers}}, "Content-Length: $length";
+ }
+ }
if (exists $ENV{GATEWAY_INTERFACE}
&& $ENV{GATEWAY_INTERFACE} =~ /^CGI-Perl\//) {
require Apache;
my $r = Apache->request or die;
- $r->send_cgi_header(join("\n", @{$result->{headers}})."\n");
+ $r->send_cgi_header(join("\n", @{$result->{headers}})."\n\n");
}
else {
print "$_\n" for @{$result->{headers}};
print "\n";
}
- print $result->{content};
+ if (defined $result->{content}) {
+ if ($result->{content} =~ /([^\x00-\xff])/) {
+ cluck "Wide character in content (\\x{", sprintf("%X", ord $1), "})";
+ }
+ print $result->{content};
+ }
+ elsif ($result->{content_fh}) {
+ # in the future this could be updated to support byte ranges
+ local $/ = \16384;
+ my $fh = $result->{content_fh};
+ binmode $fh;
+ while (my $data = <$fh>) {
+ print $data;
+ }
+ }
+ else {
+ print STDERR "$ENV{SCRIPT_NAME}: ** No content supplied\n";
+ print "** Internal error\n";
+ }
+
+ if ($result->{content}
+ && $result->{type} =~ m(text/html|application/xhtml\+xml)
+ && $cfg->entry("html", "validate", 0)) {
+ require BSE::Util::ValidateHTML;
+ BSE::Util::ValidateHTML->validate($cfg, $result);
+ }
}
1;
projects / bse.git / blobdiff