moved qdb here because matt is lazy
[public/www-new.git] / pub / qdb / util / gzip.pl
1 #!/usr/bin/perl
2
3 ###############################################################################
4 # Chirpy! 0.3, a quote management system                                      #
5 # Copyright (C) 2005-2007 Tim De Pauw <ceetee@users.sourceforge.net>          #
6 ###############################################################################
7 # This program is free software; you can redistribute it and/or modify it     #
8 # under the terms of the GNU General Public License as published by the Free  #
9 # Software Foundation; either version 2 of the License, or (at your option)   #
10 # any later version.                                                          #
11 #                                                                             #
12 # This program is distributed in the hope that it will be useful, but WITHOUT #
13 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or       #
14 # FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for   #
15 # more details.                                                               #
16 #                                                                             #
17 # You should have received a copy of the GNU General Public License along     #
18 # with this program; if not, write to the Free Software Foundation, Inc., 51  #
19 # Franklin St, Fifth Floor, Boston, MA  02110-1301  USA                       #
20 ###############################################################################
21
22 ###############################################################################
23 # gzip.pl                                                                     #
24 # Provides compression for certain files, relying on .htaccess directives     #
25 ###############################################################################
26 # $Id:: gzip.pl 291 2007-02-05 21:24:46Z ceetee                             $ #
27 ###############################################################################
28
29 use strict;
30 use warnings;
31
32 use CGI;
33 use CGI::Carp qw/fatalsToBrowser/;
34
35 use constant MODULES => [
36         'HTTP::Date',
37         'Digest::MD5',
38         'Compress::Zlib'
39 ];
40 use constant CACHE_DIR => 'src/cache/gzip';
41 use constant MIME_TYPES => {
42         'css' => 'text/css',
43         'js' => 'text/javascript'
44 };
45
46 my $cgi = new CGI();
47 my $uri = $cgi->param('uri');
48 my $filename = $cgi->param('filename');
49
50 foreach my $module (@{MODULES()}) {
51         eval 'require ' . $module;
52         &redirect()
53                 if ($@);
54 }
55
56 unless (-d CACHE_DIR) {
57         mkdir CACHE_DIR, 0777
58                 or &redirect();
59 }
60
61 &redirect()
62         unless (defined $uri && $ENV{'REDIRECT_URL'} eq $uri);
63
64 &redirect()
65         unless (defined $filename && -s $filename);
66
67 my $file_date = (stat($filename))[9];
68
69 my $md5 = Digest::MD5::md5_hex($filename);
70 my $etag = '"' . $md5 . '-' . sprintf('%x', $file_date) . '"';
71
72 my $ims = $cgi->http('If-Modified-Since');
73 my $inm = $cgi->http('If-None-Match');
74
75 if ((defined $ims || defined $inm)
76 && ((defined $ims && $file_date <= HTTP::Date::str2time($ims))
77 || (defined $inm && $etag eq $inm))) {
78         print $cgi->header(-status => '304 Not Modified');
79         exit;
80 }
81
82 my $cache_file = CACHE_DIR . '/' . $md5;
83 my $contents;
84 if (!-f $cache_file || (stat($cache_file))[9] < $file_date) {
85         $contents = Compress::Zlib::memGzip(&get_file_contents($filename));
86         &put_file_contents($cache_file, $contents);
87 }
88 else {
89         $contents = &get_file_contents($cache_file);
90 }
91
92 my $extension;
93 $filename =~ /([^.]+)$/ and $extension = $1;
94 my $ctype = (defined $extension && exists MIME_TYPES->{$extension}
95         ? MIME_TYPES->{$extension} : 'text/plain');
96
97 print $cgi->header(
98         -type => $ctype,
99         -Last_Modified => HTTP::Date::time2str($file_date),
100         -ETag => $etag,
101         -Content_Encoding => 'gzip',
102         -Content_Length => length($contents)
103 );
104 binmode STDOUT;
105 print $contents;
106
107 sub redirect {
108         print $cgi->header(-Location => $uri . '?nogzip');
109         exit;
110 }
111
112 sub get_file_contents {
113         my $filename = shift;
114         local $/ = undef;
115         local *FILE;
116         open(FILE, '<', $filename)
117                 or die 'Failed to read "' . $filename . '": ' . $!;
118         my $contents = <FILE>;
119         close(FILE);
120         return $contents;
121 }
122
123 sub put_file_contents {
124         my ($filename, $contents) = @_;
125         local *FILE;
126         open(FILE, '>', $filename)
127                 or die 'Failed to write to "' . $filename . '": ' . $!;
128         print FILE $contents;
129         close(FILE);
130 }
131
132 ###############################################################################