Try to use XML::TemplateSAX. Not too happy with it in this case, though,
[pr0n] / 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