git.sesse.net Git - pr0n/blob - perl/Sesse/pr0n/Templates.pm

   1 package Sesse::pr0n::Templates;
   2 use strict;
   3 use warnings;
   4
   5 use Sesse::pr0n::Common qw(error dberror);
   6 use XML::SAX::Expat;
   7 use XML::SAX::Writer;
   8 use XML::TemplateSAX::Buffer;
   9 use XML::TemplateSAX::Cleaner;
  10 use XML::TemplateSAX::Handler;
  11
  12 BEGIN {
  13         use Exporter ();
  14         our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
  15
  16         $VERSION     = 1.00;
  17         @ISA         = qw(Exporter);
  18         @EXPORT      = qw();
  19         %EXPORT_TAGS = qw();
  20         @EXPORT_OK   = qw();
  21 }
  22 our %dirs;
  23
  24 sub update_dirs {
  25         my $r = shift;
  26         my $base = $r->dir_config('TemplateBase');
  27         %dirs = ();
  28
  29         for my $dir (<$base/*>) {
  30                 next unless -d $dir;
  31                 $dir =~ m#/([^/]+)$#;
  32
  33                 warn "Templates exist for '$1'";
  34                 $dirs{$1} = {};
  35         }
  36 }
  37
  38 sub r_to_dir {
  39         my $r = shift;
  40
  41         if (!defined(%dirs)) {
  42                 update_dirs($r);
  43         }
  44
  45         my $site = $r->get_server_name();
  46         if (defined($dirs{$site})) {
  47                 return $site;
  48         } else {
  49                 return "default";
  50         }
  51 }
  52
  53 sub fetch_template {
  54         my ($r, $template) = @_;
  55
  56         my $dir = r_to_dir($r);
  57         my $cache = $dirs{$dir}{$template};
  58         if (defined($cache) && time - $cache->{'time'} <= 300) {
  59                 return $cache->{'contents'};
  60         }
  61
  62         my $newcache = {};
  63
  64         my $base = $r->dir_config('TemplateBase');
  65         open TEMPLATE, "<$base/$dir/$template"
  66                 or ($dir ne 'default' and open TEMPLATE, "<$base/default/$template")
  67                 or Sesse::pr0n::Common::error($r, "Couldn't open $dir/$template: $!");
  68
  69         local $/;
  70         $newcache->{'contents'} = <TEMPLATE>;
  71
  72         close TEMPLATE;
  73
  74         $newcache->{'time'} = time;
  75         $dirs{$dir}{$template} = $newcache;
  76         return $newcache->{'contents'};
  77 }
  78
  79 sub print_template {
  80         my ($r, $template, $args) = @_;
  81         my $text = fetch_template($r, $template);
  82
  83         # do substitutions
  84         while (my ($key, $value) = each (%$args)) {
  85                 $key = "%" . uc($key) . "%";
  86                 $text =~ s/$key/$value/g;
  87         }
  88
  89         $r->print($text);
  90 }
  91
  92 sub output_page {
  93         my ($r, $page, $params) = @_;
  94
  95         $r->content_type('text/html; charset=utf-8');
  96         $params->{'version'} = $Sesse::pr0n::Common::VERSION;
  97
  98         # build up the XML chain
  99         my $consumer = ModPerlConsumer->new($r);
 100         my $writer = XML::SAX::Writer->new(Output => $consumer);
 101         my $cleaner = XML::TemplateSAX::Cleaner->new(Handler => $writer);
 102         my $filter = XML::TemplateSAX::Handler->new(Handler => $cleaner, Content => $params);
 103         my $parser = XML::SAX::Expat->new(Handler => $filter);
 104
 105         # kick off the parsing
 106         $parser->parse_string(fetch_template($r, $page));
 107 }
 108
 109 # XML consumer for Apache2::Request
 110 package ModPerlConsumer;
 111
 112 our @ISA = qw( XML::SAX::Writer::ConsumerInterface );
 113 sub new {
 114         my ($base, $r) = @_;
 115         return $base->SUPER::new($r);
 116 }
 117
 118 sub output {
 119         my ($self, $text) = @_;
 120         $$self->print($text);
 121 }
 122
 123 1;
 124