3e65a9a9217767f9bb7592a4e6f917023c3aacea
[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
7 BEGIN {
8         use Exporter ();
9         our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
10
11         $VERSION     = 1.00;
12         @ISA         = qw(Exporter);
13         @EXPORT      = qw();
14         %EXPORT_TAGS = qw();
15         @EXPORT_OK   = qw();
16 }
17 our %dirs;
18
19 sub update_dirs {
20         my $r = shift;
21         my $base = $r->dir_config('TemplateBase');
22         %dirs = ();
23         
24         for my $dir (<$base/*>) {
25                 next unless -d $dir;
26                 $dir =~ m#/([^/]+)$#;
27                 
28                 warn "Templates exist for '$1'";
29                 $dirs{$1} = {};
30         }
31 }
32
33 sub r_to_dir {
34         my $r = shift;
35
36         if (!defined(%dirs)) {
37                 update_dirs($r);
38         }
39         
40         my $site = $r->get_server_name();
41         if (defined($dirs{$site})) {
42                 return $site;
43         } else {
44                 return "default";
45         }
46 }
47
48 sub fetch_template {
49         my ($r, $template) = @_;
50
51         my $dir = r_to_dir($r);
52         my $cache = $dirs{$dir}{$template};
53         if (defined($cache) && time - $cache->{'time'} <= 300) {
54                 return $cache->{'contents'};
55         }
56
57         my $newcache = {};
58
59         my $base = $r->dir_config('TemplateBase');
60         open TEMPLATE, "<$base/$dir/$template"
61                 or ($dir ne 'default' and open TEMPLATE, "<$base/default/$template")
62                 or Sesse::pr0n::Common::error($r, "Couldn't open $dir/$template: $!");
63
64         local $/;
65         $newcache->{'contents'} = <TEMPLATE>;
66
67         close TEMPLATE;
68
69         $newcache->{'time'} = time;
70         $dirs{$dir}{$template} = $newcache;
71         return $newcache->{'contents'};
72 }
73
74 sub process_template {
75         my ($r, $template, $args) = @_;
76         my $text = fetch_template($r, $template);
77
78         # do substitutions
79         while (my ($key, $value) = each (%$args)) {
80                 $key = "%" . uc($key) . "%";
81                 $text =~ s/$key/$value/g;
82         }
83
84         return $text;
85 }
86
87 sub print_template {
88         my ($r, $template, $args) = @_;
89         $r->print(process_template($r, $template, $args));
90 }
91
92 1;
93