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