File Coverage

blib/lib/FCGI/Buffer.pm
Criterion Covered Total %
statement 334 814 41.0
branch 148 504 29.3
condition 68 251 27.0
subroutine 24 28 85.7
pod 5 5 100.0
total 579 1602 36.1


line stmt bran cond sub pod time code
1             package FCGI::Buffer;
2              
3 10     10   3201418 use strict;
  10         68  
  10         270  
4 10     10   48 use warnings;
  10         15  
  10         262  
5              
6             # FIXME: save_to treats ?arg1=a&arg2=b and ?arg2=b&arg1=a as different
7             # FIXME: save_to treats /cgi-bin/foo.fcgi and /cgi-bin2/foo.fcgi as the same
8              
9 10     10   62 use Digest::MD5;
  10         23  
  10         367  
10 10     10   53 use File::Path;
  10         15  
  10         497  
11 10     10   59 use File::Spec;
  10         21  
  10         203  
12 10     10   3178 use IO::String;
  10         20717  
  10         213  
13 10     10   3868 use CGI::Info;
  10         522759  
  10         81  
14 10     10   478 use Carp;
  10         21  
  10         543  
15 10     10   3957 use HTTP::Date;
  10         33576  
  10         546  
16 10     10   14108 use DBI;
  10         165593  
  10         766  
17              
18             =head1 NAME
19              
20             FCGI::Buffer - Verify, Cache and Optimise FCGI Output
21              
22             =head1 VERSION
23              
24             Version 0.15
25              
26             =cut
27              
28             our $VERSION = '0.15';
29              
30             =head1 SYNOPSIS
31              
32             FCGI::Buffer verifies the HTML that you produce by passing it through
33             C<HTML::Lint>.
34              
35             FCGI::Buffer optimises FCGI programs by reducing, filtering and compressing
36             output to speed up the transmission and by nearly seamlessly making use of
37             client and server caches.
38              
39             To make use of client caches, that is to say to reduce needless calls
40             to your server asking for the same data:
41              
42             use FCGI;
43             use FCGI::Buffer;
44             # ...
45             my $request = FCGI::Request();
46             while($request->FCGI::Accept() >= 0) {
47             my $buffer = FCGI::Buffer->new();
48             $buffer->init(
49             optimise_content => 1,
50             lint_content => 0,
51             );
52             # ...
53             }
54              
55             To also make use of server caches, that is to say to save regenerating
56             output when different clients ask you for the same data, you will need
57             to create a cache.
58             But that's simple:
59              
60             use FCGI;
61             use CHI;
62             use FCGI::Buffer;
63              
64             # ...
65             my $request = FCGI::Request();
66             while($request->FCGI::Accept() >= 0) {
67             my $buffer = FCGI::Buffer->new();
68             $buffer->init(
69             optimise_content => 1,
70             lint_content => 0,
71             cache => CHI->new(driver => 'File')
72             );
73             if($buffer->is_cached()) {
74             # Nothing has changed - use the version in the cache
75             $request->Finish();
76             next;
77             # ...
78             }
79             }
80              
81             To temporarily prevent the use of server-side caches, for example whilst
82             debugging before publishing a code change, set the NO_CACHE environment variable
83             to any non-zero value.
84             If you get errors about Wide characters in print it means that you've
85             forgotten to emit pure HTML on non-ascii characters.
86             See L<HTML::Entities>.
87             As a hack work around you could also remove accents and the like by using
88             L<Text::Unidecode>,
89             which works well but isn't really what you want.
90              
91             =head1 SUBROUTINES/METHODS
92              
93             =cut
94              
95 10     10   74 use constant MIN_GZIP_LEN => 32;
  10         17  
  10         91703  
96              
97             =head2 new
98              
99             Create an FCGI::Buffer object. Do one of these for each FCGI::Accept.
100              
101             =cut
102              
103             # FIXME: Call init() on any arguments that are given
104             sub new {
105 37     37 1 148967 my $class = shift;
106              
107 37 100       121 return unless($class);
108              
109 36         189 my $buf = IO::String->new();
110              
111 36         1853 my $rc = {
112             buf => $buf,
113             old_buf => select($buf),
114             generate_304 => 1,
115             generate_last_modified => 1,
116             compress_content => 1,
117             optimise_content => 0,
118             lint_content => 0,
119             };
120             # $rc->{o} = ();
121              
122 36 100 100     212 if($ENV{'SERVER_PROTOCOL'} &&
123             ($ENV{'SERVER_PROTOCOL'} eq 'HTTP/1.1')) {
124 20         60 $rc->{generate_etag} = 1;
125             } else {
126 16         53 $rc->{generate_etag} = 0;
127             }
128              
129 36         140 return bless $rc, $class;
130             }
131              
132             sub DESTROY {
133 36 50 33 36   5244 if(defined($^V) && ($^V ge 'v5.14.0')) {
134 36 50       130 return if ${^GLOBAL_PHASE} eq 'DESTRUCT'; # >= 5.14.0 only
135             }
136 36         109 my $self = shift;
137              
138 36 100       106 if($self->{'logger'}) {
139 1         7 $self->{'logger'}->info('In DESTROY');
140             }
141 36         141 select($self->{old_buf});
142 36 50 33     160 if((!defined($self->{buf})) || (!defined($self->{buf}->getpos()))) {
143             # Unlikely
144 0 0       0 if($self->{'logger'}) {
145 0         0 $self->{'logger'}->info('Nothing to send');
146             }
147 0         0 return;
148             }
149 36         495 my $pos = $self->{buf}->getpos();
150 36         323 $self->{buf}->setpos(0);
151 36         499 my $buf;
152 36         119 read($self->{buf}, $buf, $pos);
153 36         688 my $headers;
154 36         288 ($headers, $self->{body}) = split /\r?\n\r?\n/, $buf, 2;
155              
156 36 100       102 if($self->{'logger'}) {
157 1 50       5 if($ENV{'HTTP_IF_NONE_MATCH'}) {
158 0         0 $self->{logger}->debug("HTTP_IF_NONE_MATCH: $ENV{HTTP_IF_NONE_MATCH}");
159             }
160 1 50       4 if($ENV{'HTTP_IF_MODIFIED_SINCE'}) {
161 0         0 $self->{logger}->debug("HTTP_IF_MODIFIED_SINCE: $ENV{HTTP_IF_MODIFIED_SINCE}");
162             }
163 1         11 $self->{logger}->debug("Generate_etag = $self->{generate_etag}",
164             "Generate_304 = $self->{generate_304}",
165             "Generate_last_modified = $self->{generate_last_modified}");
166             }
167 36 100 66     127 unless($headers || $self->is_cached()) {
168 3 50       11 if($self->{'logger'}) {
169 0         0 $self->{'logger'}->debug('There was no output');
170             }
171 3         16 return;
172             }
173 33 100 100     167 if($ENV{'REQUEST_METHOD'} && ($ENV{'REQUEST_METHOD'} eq 'HEAD')) {
174 1         3 $self->{send_body} = 0;
175             } else {
176 32         100 $self->{send_body} = 1;
177             }
178              
179 33 50       77 if($headers) {
180 33         82 $self->_set_content_type($headers);
181             }
182              
183 33 100 66     180 if(defined($self->{body}) && ($self->{body} eq '')) {
    100          
184             # E.g. if header of Location is given with no body, for
185             # redirection
186 2         7 delete $self->{body};
187 2 50       9 if($self->{cache}) {
188             # Don't try to retrieve it below from the cache
189 0         0 $self->{send_body} = 0;
190             }
191             } elsif(defined($self->{content_type})) {
192 28         49 my @content_type = @{$self->{content_type}};
  28         78  
193 28 50 33     285 if(defined($content_type[0]) && (lc($content_type[0]) eq 'text') && (lc($content_type[1]) =~ /^html/) && defined($self->{body})) {
      33        
      33        
194 28 100       79 if($self->{optimise_content}) {
195             # require HTML::Clean;
196 25         1123 require HTML::Packer; # Overkill using HTML::Clean and HTML::Packer...
197              
198 25 50       19622 if($self->{'logger'}) {
199 0         0 $self->{'logger'}->trace('Packer');
200             }
201              
202 25         51 my $oldlength = length($self->{body});
203 25         34 my $newlength;
204              
205 25 100       62 if($self->{optimise_content} == 1) {
206 24         57 $self->_optimise_content();
207             } else {
208 1         2 while(1) {
209 3         8 $self->_optimise_content();
210 3         4 $newlength = length($self->{body});
211 3 100       6 last if ($newlength >= $oldlength);
212 2         3 $oldlength = $newlength;
213             }
214             }
215              
216             # If we're on http://www.example.com and have a link
217             # to http://www.example.com/foo/bar.htm, change the
218             # link to /foo/bar.htm - there's no need to include
219             # the site name in the link
220 25 100       71 unless(defined($self->{info})) {
221 22 50       48 if($self->{cache}) {
222 0         0 $self->{info} = CGI::Info->new({ cache => $self->{cache} });
223             } else {
224 22         142 $self->{info} = CGI::Info->new();
225             }
226             }
227              
228 25         490 my $href = $self->{info}->host_name();
229 25         9124 my $protocol = $self->{info}->protocol();
230              
231 25 100       284 unless($protocol) {
232 10         18 $protocol = 'http';
233             }
234              
235 25         198 $self->{body} =~ s/<a\s+?href="$protocol:\/\/$href"/<a href="\/"/gim;
236 25         154 $self->{body} =~ s/<a\s+?href="$protocol:\/\/$href/<a href="/gim;
237 25         109 $self->{body} =~ s/<a\s+?href="$protocol:\/\//<a href="\/\//gim;
238              
239             # If we're in "/cgi-bin/foo.cgi?arg1=a" replace
240             # "/cgi-bin/foo.cgi?arg2=b" with "?arg2=b"
241              
242 25 100       77 if(my $script_name = $ENV{'SCRIPT_NAME'}) {
243 18 50       63 if($script_name =~ /^\//) {
244 18         109 $self->{body} =~ s/<a\s+?href="$script_name(\?.+)?"/<a href="$1"/gim;
245             }
246             }
247              
248             # TODO use URI->path_segments to change links in
249             # /aa/bb/cc/dd.htm which point to /aa/bb/ff.htm to
250             # ../ff.htm
251              
252             # TODO: <img border=0 src=...>
253 25         122 $self->{body} =~ s/<img\s+?src="$protocol:\/\/$href"/<img src="\/"/gim;
254 25         105 $self->{body} =~ s/<img\s+?src="$protocol:\/\/$href/<img src="/gim;
255              
256             # Don't use HTML::Clean because of RT402
257             # my $h = new HTML::Clean(\$self->{body});
258             # # $h->compat();
259             # $h->strip();
260             # my $ref = $h->data();
261              
262             # Don't always do javascript 'best' since it's confused
263             # by the common <!-- HIDE technique.
264 25         91 my $options = {
265             remove_comments => 1,
266             remove_newlines => 0,
267             do_stylesheet => 'minify'
268             };
269 25 100       76 if($self->{optimise_content} >= 2) {
270 1         3 $options->{do_javascript} = 'best';
271 1         3 $self->{body} =~ s/(<script.*?>)\s*<!--/$1/gi;
272 1         3 $self->{body} =~ s/\/\/-->\s*<\/script>/<\/script>/gi;
273 1         14 $self->{body} =~ s/(<script.*?>)\s+/$1/gi;
274             }
275 25         139 $self->{body} = HTML::Packer->init()->minify(\$self->{body}, $options);
276 25 100       317880 if($self->{optimise_content} >= 2) {
277             # Change document.write("a"); document.write("b")
278             # into document.write("a"+"b");
279 1         2 while(1) {
280 1         22 $self->{body} =~ s/<script\s*?type\s*?=\s*?"text\/javascript"\s*?>(.*?)document\.write\((.+?)\);\s*?document\.write\((.+?)\)/<script type="text\/JavaScript">${1}document.write($2+$3)/igs;
281 1         3 $newlength = length($self->{body});
282 1 50       5 last if ($newlength >= $oldlength);
283 0         0 $oldlength = $newlength;
284             }
285             }
286             }
287 28 100       131 if($self->{lint_content}) {
288 3         21 require HTML::Lint;
289 3         22 HTML::Lint->import;
290              
291 3 50       17 if($self->{'logger'}) {
292 0         0 $self->{'logger'}->trace('Lint');
293             }
294 3         13 my $lint = HTML::Lint->new();
295 3         55 $lint->parse($self->{body});
296 3         4756 $lint->eof();
297              
298 3 100       361 if($lint->errors) {
299 1         15 $headers = 'Status: 500 Internal Server Error';
300 1         2 @{$self->{o}} = ('Content-type: text/plain');
  1         4  
301 1         3 $self->{body} = '';
302 1         4 foreach my $error ($lint->errors) {
303 3         21 my $errtext = $error->where() . ': ' . $error->errtext() . "\n";
304 3         145 warn($errtext);
305 3         20 $self->{body} .= $errtext;
306             }
307             }
308             }
309             }
310             }
311              
312 33 100 66     265 if(defined($headers) && ($headers =~ /^Status: (\d+)/m)) {
    100          
313 1         5 $self->{status} = $1;
314             } elsif(defined($self->{info})) {
315 25         112 $self->{status} = $self->{info}->status();
316             } else {
317 7         14 $self->{status} = 200;
318             }
319              
320 33 100       217 if($self->{'logger'}) {
321 1         6 $self->{'logger'}->debug("Initial status = $self->{status}");
322             }
323              
324             # Generate the eTag before compressing, since the compressed data
325             # includes the mtime field which changes thus causing a different
326             # Etag to be generated
327 33 100 100     195 if($ENV{'SERVER_PROTOCOL'} &&
      100        
      66        
328             ($ENV{'SERVER_PROTOCOL'} eq 'HTTP/1.1') &&
329             $self->{generate_etag} && defined($self->{body})) {
330             # encode to avoid "Wide character in subroutine entry"
331 11         75 require Encode;
332 11         25 $self->{_encode_loaded} = 1;
333 11         95 $self->{etag} = '"' . Digest::MD5->new->add(Encode::encode_utf8($self->{body}))->hexdigest() . '"';
334 11 100 100     219 if($ENV{'HTTP_IF_NONE_MATCH'} && $self->{generate_304} && ($self->{status} == 200)) {
      66        
335 2         7 $self->_check_if_none_match();
336             }
337             }
338              
339 33         56 my $dbh;
340 33 50       78 if(my $save_to = $self->{save_to}) {
341 0         0 my $sqlite_file = File::Spec->catfile($save_to->{directory}, 'fcgi.buffer.sql');
342 0 0       0 if($self->{logger}) {
343 0         0 $self->{logger}->debug("save_to sqlite file: $sqlite_file");
344             }
345 0 0       0 if(!-r $sqlite_file) {
346 0 0       0 if(!-d $save_to->{directory}) {
347 0         0 mkdir $save_to->{directory};
348             }
349 0         0 $dbh = DBI->connect("dbi:SQLite:dbname=$sqlite_file", undef, undef);
350 0 0       0 if($self->{save_to}->{create_table}) {
351 0         0 $dbh->prepare('CREATE TABLE fcgi_buffer(key char PRIMARY KEY, language char, browser_type char, path char UNIQUE NOT NULL, uri char NOT NULL, creation timestamp NOT NULL)')->execute();
352             }
353             } else {
354 0         0 $dbh = DBI->connect("dbi:SQLite:dbname=$sqlite_file", undef, undef);
355             }
356             }
357              
358 33         101 my $encoding = $self->_should_gzip();
359 33         72 my $unzipped_body = $self->{body};
360              
361 33 100       77 if(defined($unzipped_body)) {
362 31 50       92 my $range = $ENV{'Range'} ? $ENV{'Range'} : $ENV{'HTTP_RANGE'};
363              
364 31 100 66     87 if($range && !$self->{cache}) {
365             # TODO: Partials
366 3 50       17 if($range =~ /^bytes=(\d*)-(\d*)/) {
367 3 100 100     24 if($1 && $2) {
    100          
    50          
368 1         6 $self->{body} = substr($self->{body}, $1, $2-$1);
369             } elsif($1) {
370 1         6 $self->{body} = substr($self->{body}, $1);
371             } elsif($2) {
372 1         6 $self->{body} = substr($self->{body}, 0, $2);
373             }
374 3         7 $unzipped_body = $self->{body};
375 3         6 $self->{'status'} = 206;
376             }
377             }
378 31         118 $self->_compress({ encoding => $encoding });
379             }
380              
381 33 50       147 if($self->{cache}) {
    100          
382 0         0 require Storable;
383              
384 0         0 my $cache_hash;
385 0         0 my $key = $self->_generate_key();
386              
387             # Cache unzipped version
388 0 0       0 if(!defined($self->{body})) {
389 0 0       0 if($self->{send_body}) {
390 0         0 $self->{cobject} = $self->{cache}->get_object($key);
391 0 0       0 if(defined($self->{cobject})) {
392 0         0 $cache_hash = Storable::thaw($self->{cobject}->value());
393 0         0 $headers = $cache_hash->{'headers'};
394 0         0 $self->_set_content_type($headers);
395 0         0 @{$self->{o}} = ("X-FCGI-Buffer-$VERSION: Hit");
  0         0  
396 0 0       0 if($self->{info}) {
397 0         0 my $host_name = $self->{info}->host_name();
398 0         0 push @{$self->{o}}, "X-Cache: HIT from $host_name";
  0         0  
399 0         0 push @{$self->{o}}, "X-Cache-Lookup: HIT from $host_name";
  0         0  
400             } else {
401 0         0 push @{$self->{o}}, 'X-Cache: HIT';
  0         0  
402 0         0 push @{$self->{o}}, 'X-Cache-Lookup: HIT';
  0         0  
403             }
404             } else {
405 0         0 carp "Error retrieving data for key $key";
406             }
407             }
408              
409             # Nothing has been output yet, so we can check if it's
410             # OK to send 304 if possible
411 0 0 0     0 if($self->{send_body} && $ENV{'SERVER_PROTOCOL'} &&
      0        
      0        
      0        
412             ($ENV{'SERVER_PROTOCOL'} eq 'HTTP/1.1') &&
413             $self->{generate_304} && ($self->{status} == 200)) {
414 0 0       0 if($ENV{'HTTP_IF_MODIFIED_SINCE'}) {
415             $self->_check_modified_since({
416             since => $ENV{'HTTP_IF_MODIFIED_SINCE'},
417             modified => $self->{cobject}->created_at()
418 0         0 });
419             }
420             }
421 0 0 0     0 if($self->{send_body} && ($self->{status} == 200)) {
422 0         0 $self->{body} = $cache_hash->{'body'};
423 0 0       0 if($dbh) {
424 0         0 my $changes = $self->_save_to($self->{body}, $dbh);
425 0 0 0     0 if($changes && (my $ttl = $self->{save_to}->{ttl})) {
426 0         0 push @{$self->{o}}, 'Expires: ' . HTTP::Date::time2str(time + $ttl);
  0         0  
427             }
428             }
429 0 0       0 if(!defined($self->{body})) {
430             # Panic
431 0         0 $headers = 'Status: 500 Internal Server Error';
432 0         0 @{$self->{o}} = ('Content-type: text/plain');
  0         0  
433 0         0 $self->{body} = "Can't retrieve body for key $key, cache_hash contains:\n";
434 0         0 foreach my $k (keys %{$cache_hash}) {
  0         0  
435 0         0 $self->{body} .= "\t$k\n";
436             }
437              
438 0 0       0 if($dbh) {
439 0         0 my $query = "SELECT DISTINCT path FROM fcgi_buffer WHERE key = '$key'";
440 0         0 my $sth = $dbh->prepare($query);
441 0 0       0 if($self->{logger}) {
442 0         0 $self->{logger}->debug($query);
443             }
444 0 0 0     0 if($sth->execute() && (my $href = $sth->fetchrow_hashref())) {
445 0 0       0 if(my $path = $href->{'path'}) {
446 0         0 unlink($path);
447             }
448             }
449 0         0 $query = "DELETE FROM fcgi_buffer WHERE key = '$key'";
450 0         0 $dbh->do($query);
451 0 0       0 if($self->{logger}) {
452 0         0 $self->{logger}->debug($query);
453             }
454             }
455              
456 0         0 $self->{cache}->remove($key);
457              
458 0 0       0 if($self->{logger}) {
459 0         0 $self->{logger}->error("Can't retrieve body for key $key");
460             } else {
461 0         0 carp "Can't retrieve body for key $key";
462             }
463 0         0 warn($self->{body});
464 0         0 $self->{send_body} = 0;
465 0         0 $self->{status} = 500;
466             }
467             }
468 0 0 0     0 if($self->{send_body} && $ENV{'SERVER_PROTOCOL'} &&
      0        
      0        
469             ($ENV{'SERVER_PROTOCOL'} eq 'HTTP/1.1') &&
470             ($self->{status} == 200)) {
471 0 0 0     0 if($ENV{'HTTP_IF_NONE_MATCH'} && $self->{generate_etag}) {
472 0 0       0 if(!defined($self->{etag})) {
473 0 0       0 unless($self->{_encode_loaded}) {
474 0         0 require Encode;
475 0         0 $self->{_encode_loaded} = 1;
476             }
477 0         0 $self->{etag} = '"' . Digest::MD5->new->add(Encode::encode_utf8($self->{body}))->hexdigest() . '"';
478             }
479 0         0 $self->_check_if_none_match();
480             }
481             }
482 0 0       0 if($self->{status} == 200) {
483 0         0 $encoding = $self->_should_gzip();
484 0 0       0 if($self->{send_body}) {
485 0 0 0     0 if($self->{generate_etag} && !defined($self->{etag}) && ((!defined($headers)) || ($headers !~ /^ETag: /m))) {
      0        
      0        
486 0         0 $self->{etag} = '"' . Digest::MD5->new->add(Encode::encode_utf8($self->{body}))->hexdigest() . '"';
487             }
488 0         0 $self->_compress({ encoding => $encoding });
489             }
490             }
491 0         0 my $cannot_304 = !$self->{generate_304};
492 0 0       0 unless($self->{etag}) {
493 0 0 0     0 if(defined($headers) && ($headers =~ /^ETag: "([a-z0-9]{32})"/m)) {
494 0         0 $self->{etag} = $1;
495             } else {
496 0         0 $self->{etag} = $cache_hash->{'etag'};
497             }
498             }
499 0 0 0     0 if($ENV{'HTTP_IF_NONE_MATCH'} && $self->{send_body} && ($self->{status} != 304) && $self->{generate_304}) {
      0        
      0        
500 0 0       0 if(!$self->_check_if_none_match()) {
501 0         0 $cannot_304 = 1;
502             }
503             }
504 0 0       0 if($self->{cobject}) {
505 0 0 0     0 if($ENV{'HTTP_IF_MODIFIED_SINCE'} && ($self->{status} != 304) && !$cannot_304) {
      0        
506             $self->_check_modified_since({
507             since => $ENV{'HTTP_IF_MODIFIED_SINCE'},
508             modified => $self->{cobject}->created_at()
509 0         0 });
510             }
511 0 0 0     0 if(($self->{status} == 200) && $self->{generate_last_modified}) {
512 0 0       0 if($self->{logger}) {
513 0         0 $self->{logger}->debug('Set Last-Modified to ', HTTP::Date::time2str($self->{cobject}->created_at()));
514             }
515 0         0 push @{$self->{o}}, "Last-Modified: " . HTTP::Date::time2str($self->{cobject}->created_at());
  0         0  
516             }
517             }
518             } else {
519             # Not in the server side cache
520 0 0       0 if($self->{status} == 200) {
521 0         0 my $changes = $self->_save_to($unzipped_body, $dbh);
522              
523 0 0       0 unless($self->{cache_age}) {
524             # It would be great if CHI::set()
525             # allowed the time to be 'lru' for least
526             # recently used.
527 0         0 $self->{cache_age} = '10 minutes';
528             }
529 0         0 $cache_hash->{'body'} = $unzipped_body;
530 0 0 0     0 if($changes && $encoding) {
531 0         0 $self->_compress({ encoding => $encoding });
532             }
533 0 0 0     0 if($self->{o} && scalar(@{$self->{o}})) {
  0 0 0     0  
534             # Remember, we're storing the UNzipped
535             # version in the cache
536 0         0 my $c;
537 0 0 0     0 if(defined($headers) && length($headers)) {
538 0         0 $c = "$headers\r\n" . join("\r\n", @{$self->{o}});
  0         0  
539             } else {
540 0         0 $c = join("\r\n", @{$self->{o}});
  0         0  
541             }
542 0         0 $c =~ s/^Content-Encoding: .+$//mg;
543 0         0 $c =~ s/^Vary: Accept-Encoding.*\r?$//mg;
544 0         0 $c =~ s/\n+/\n/gs;
545 0 0       0 if(length($c)) {
546 0         0 $cache_hash->{'headers'} = $c;
547             }
548             } elsif(defined($headers) && length($headers)) {
549 0         0 $headers =~ s/^Content-Encoding: .+$//mg;
550 0         0 $headers =~ s/^Vary: Accept-Encoding.*\r?$//mg;
551 0         0 $headers =~ s/\n+/\n/gs;
552 0 0       0 if(length($headers)) {
553 0         0 $cache_hash->{'headers'} = $headers;
554             }
555             }
556 0 0 0     0 if($self->{generate_etag} && defined($self->{etag})) {
557 0         0 $cache_hash->{'etag'} = $self->{etag};
558             }
559             # TODO: Support the Expires header
560             # if($headers !~ /^Expires: /m))) {
561             # }
562 0 0       0 if($self->{logger}) {
563 0         0 $self->{logger}->debug("Store $key in the cache, age = ", $self->{cache_age}, ' ', length($cache_hash->{'body'}), ' bytes');
564             }
565 0         0 $self->{cache}->set($key, Storable::freeze($cache_hash), $self->{cache_age});
566              
567             # Create a static page with the information and link to that in the output
568             # HTML
569 0 0 0     0 if($dbh && $self->{info} && $self->{save_to} && (my $request_uri = $ENV{'REQUEST_URI'})) {
      0        
      0        
570 0         0 my $query = "SELECT DISTINCT creation FROM fcgi_buffer WHERE key = ?";
571 0 0       0 if($self->{logger}) {
572 0         0 $self->{logger}->debug("$query: $key");
573             }
574 0         0 my $sth = $dbh->prepare($query);
575 0         0 $sth->execute($key);
576 0 0       0 if(my $href = $sth->fetchrow_hashref()) {
577 0 0       0 if(my $ttl = $self->{save_to}->{ttl}) {
578 0         0 push @{$self->{o}}, 'Expires: ' .
579 0         0 HTTP::Date::time2str($href->{'creation'} + $ttl);
580             }
581             } else {
582 0         0 my $dir = $self->{save_to}->{directory};
583 0         0 my $browser_type = $self->{info}->browser_type();
584 0         0 my $language;
585 0 0       0 if($self->{'lingua'}) {
586 0         0 $language = $self->{lingua}->language();
587 0 0       0 if($language =~ /([\w\s]+)/i) {
588 0         0 $language = $1; # Untaint
589             }
590             } else {
591 0         0 $language = 'default';
592             }
593 0         0 my $bdir = File::Spec->catfile($dir, $browser_type);
594 0 0       0 if($bdir =~ /^([\/\\])(.+)$/) {
595 0         0 $bdir = "$1$2"; # Untaint
596             }
597 0         0 my $ldir = File::Spec->catfile($bdir, $language);
598 0         0 my $sdir = File::Spec->catfile($ldir, $self->{info}->script_name());
599 0 0       0 if($self->{logger}) {
600 0         0 $self->{logger}->debug("Create paths to $sdir");
601             }
602 0         0 File::Path::make_path($sdir);
603 0         0 my $path = File::Spec->catfile($sdir, $self->{info}->as_string() . '.html');
604 0 0       0 if($path =~ /^(.+)$/) {
605 0         0 $path = $1; # Untaint
606 0         0 $path =~ tr/[\|;]/_/;
607             }
608 0 0       0 if(open(my $fout, '>', $path)) {
609 0         0 my $u = $request_uri;
610 0         0 $u =~ s/\?/\\?/g;
611 0         0 $u =~ s/\)/\\)/g;
612 0         0 my $copy = $unzipped_body;
613 0         0 my $changes = ($copy =~ s/<a\s+href="$u"/<a href="$path"/gi);
614              
615             # handle <a href="?arg3=4">Call self with different args</a>
616 0         0 my $script_name = $ENV{'SCRIPT_NAME'};
617 0         0 $copy =~ s/<a\s+href="(\?.+?)"/<a href="$script_name$1"/gi;
618              
619             # Avoide Wide character
620 0 0       0 unless($self->{_encode_loaded}) {
621 0         0 require Encode;
622 0         0 $self->{_encode_loaded} = 1;
623             }
624 0         0 print $fout Encode::encode_utf8($copy);
625 0         0 close $fout;
626             # Do INSERT OR REPLACE in case another program has
627             # got in first,
628 0         0 $query = "INSERT OR REPLACE INTO fcgi_buffer(key, language, browser_type, path, uri, creation) VALUES('$key', '$language', '$browser_type', '$path', '$request_uri', strftime('\%s','now'))";
629 0 0       0 if($self->{logger}) {
630 0         0 $self->{logger}->debug($query);
631             }
632 0         0 $dbh->prepare($query)->execute();
633              
634 0 0 0     0 if($changes && (my $ttl = $self->{save_to}->{ttl})) {
635 0         0 push @{$self->{o}}, 'Expires: ' . HTTP::Date::time2str(time + $ttl);
  0         0  
636             }
637             } else {
638 0 0       0 if($self->{logger}) {
639 0         0 $self->{logger}->warn("Can't create $path");
640             }
641             }
642             }
643             }
644 0 0       0 if($self->{generate_last_modified}) {
645 0         0 $self->{cobject} = $self->{cache}->get_object($key);
646 0 0       0 if(defined($self->{cobject})) {
647 0         0 push @{$self->{o}}, "Last-Modified: " . HTTP::Date::time2str($self->{cobject}->created_at());
  0         0  
648             } else {
649 0         0 push @{$self->{o}}, "Last-Modified: " . HTTP::Date::time2str(time);
  0         0  
650             }
651             }
652             }
653 0 0       0 if($self->{info}) {
654 0         0 my $host_name = $self->{info}->host_name();
655 0 0       0 if(defined($self->{x_cache})) {
656 0         0 push @{$self->{o}}, 'X-Cache: ' . $self->{x_cache} . " from $host_name";
  0         0  
657             } else {
658 0         0 push @{$self->{o}}, "X-Cache: MISS from $host_name";
  0         0  
659             }
660 0         0 push @{$self->{o}}, "X-Cache-Lookup: MISS from $host_name";
  0         0  
661             } else {
662 0 0       0 if(defined($self->{x_cache})) {
663 0         0 push @{$self->{o}}, 'X-Cache: ' . $self->{x_cache};
  0         0  
664             } else {
665 0         0 push @{$self->{o}}, 'X-Cache: MISS';
  0         0  
666             }
667 0         0 push @{$self->{o}}, 'X-Cache-Lookup: MISS';
  0         0  
668             }
669 0         0 push @{$self->{o}}, "X-FCGI-Buffer-$VERSION: Miss";
  0         0  
670             }
671             # We don't need it any more, so give Perl a chance to
672             # tidy it up seeing as we're in the destructor
673 0         0 delete $self->{cache};
674             } elsif($self->{info}) {
675 26         94 my $host_name = $self->{info}->host_name();
676 26         263 push @{$self->{o}}, ("X-Cache: MISS from $host_name", "X-Cache-Lookup: MISS from $host_name");
  26         123  
677 26 50 33     81 if($self->_save_to($unzipped_body, $dbh) && $encoding) {
678 0         0 $self->_compress({ encoding => $encoding });
679             }
680             } else {
681 7         11 push @{$self->{o}}, ('X-Cache: MISS', 'X-Cache-Lookup: MISS');
  7         25  
682             }
683              
684 33 100 33     194 if($self->{generate_etag} && ((!defined($headers)) || ($headers !~ /^ETag: /m))) {
      66        
685 11 50 0     30 if(defined($self->{etag})) {
    0 0        
      0        
      0        
686 11         15 push @{$self->{o}}, "ETag: $self->{etag}";
  11         35  
687 11 50       29 if($self->{logger}) {
688 0         0 $self->{logger}->debug("Set ETag to $self->{etag}");
689             }
690             } elsif($self->{logger} && (($self->{status} == 200) || $self->{status} == 304) && $self->{body} && !$self->is_cached()) {
691             # open(my $fout, '>>', '/tmp/FCGI-bug');
692             # print $fout "BUG: ETag not generated, status $self->{status}:\n",
693             # $headers,
694             # 'x' x 40,
695             # defined($self->{body}) ? $self->{body} : "body is empty\n",
696             # 'x' x 40,
697             # "\n";
698 0         0 $self->{logger}->warn("BUG: ETag not generated, status $self->{status}");
699             }
700             }
701              
702 33         54 my $body_length;
703 33 100       84 if(defined($self->{body})) {
704 31 100       110 if(utf8::is_utf8($self->{body})) {
705 1         5 utf8::encode($self->{body});
706             }
707 31         52 $body_length = length($self->{body});
708             } else {
709 2         5 $body_length = 0;
710             }
711              
712 33 50 33     128 if(defined($headers) && length($headers)) {
713             # Put the original headers first, then those generated within
714             # FCGI::Buffer
715 33         58 unshift @{$self->{o}}, split(/\r\n/, $headers);
  33         147  
716 33 100 100     159 if($self->{body} && $self->{send_body}) {
717 29 50       42 unless(grep(/^Content-Length: \d/, @{$self->{o}})) {
  29         144  
718 29         45 push @{$self->{o}}, "Content-Length: $body_length";
  29         94  
719             }
720             }
721 33 100       59 unless(grep(/^Status: \d/, @{$self->{o}})) {
  33         148  
722 30         1356 require HTTP::Status;
723 30         18451 HTTP::Status->import();
724              
725 30         89 push @{$self->{o}}, 'Status: ' . $self->{status} . ' ' . HTTP::Status::status_message($self->{status});
  30         169  
726             }
727             } else {
728 0         0 push @{$self->{o}}, "X-FCGI-Buffer-$VERSION: No headers";
  0         0  
729             }
730              
731 33 100 100     271 if($body_length && $self->{send_body}) {
732 29         46 push @{$self->{o}}, ('', $self->{body});
  29         72  
733             }
734              
735             # XXXXXXXXXXXXXXXXXXXXXXX
736 33 50       47 if(0) {
737             # This code helps to debug Wide character prints
738             my $wideCharWarningsIssued = 0;
739             my $widemess;
740             $SIG{__WARN__} = sub {
741 0     0   0 $wideCharWarningsIssued += "@_" =~ /Wide character in .../;
742 0         0 $widemess = "@_";
743 0 0       0 if($self->{logger}) {
744 0         0 $self->{logger}->fatal($widemess);
745 0         0 my $i = 1;
746 0         0 $self->{logger}->trace('Stack Trace');
747 0         0 while((my @call_details = (caller($i++)))) {
748 0         0 $self->{logger}->trace($call_details[1], ':', $call_details[2], ' in function ', $call_details[3]);
749             }
750             }
751 0         0 CORE::warn(@_); # call the builtin warn as usual
752             };
753              
754             if(scalar @{$self->{o}}) {
755             print join("\r\n", @{$self->{o}});
756             if($wideCharWarningsIssued) {
757             my $mess = join("\r\n", @{$self->{o}});
758             $mess =~ /[^\x00-\xFF]/;
759             open(my $fout, '>>', '/tmp/NJH');
760             print $fout "$widemess:\n",
761             $mess,
762             'x' x 40,
763             "\n";
764             close $fout;
765             }
766             }
767 0         0 } elsif(scalar @{$self->{o}}) {
  33         86  
768 33         45 print join("\r\n", @{$self->{o}});
  33         1643  
769             }
770             # XXXXXXXXXXXXXXXXXXXXXXX
771              
772 33 100 100     656 if((!$self->{send_body}) || !defined($self->{body})) {
773 4         87 print "\r\n\r\n";
774             }
775             }
776              
777             sub _check_modified_since {
778 0     0   0 my $self = shift;
779              
780 0 0       0 if($self->{logger}) {
781 0         0 $self->{logger}->trace('In _check_modified_since');
782             }
783              
784 0 0       0 if(!$self->{generate_304}) {
785 0         0 return;
786             }
787 0         0 my $params = shift;
788              
789 0 0       0 if(!defined($$params{since})) {
790 0         0 return;
791             }
792 0         0 my $s = HTTP::Date::str2time($$params{since});
793 0 0       0 if(!defined($s)) {
794 0 0       0 if($self->{logger}) {
795 0         0 $self->{logger}->info("$$params{since} is not a valid date");
796             }
797 0         0 return;
798             }
799              
800 0         0 my $age = $self->_my_age();
801 0 0       0 if(!defined($age)) {
802 0 0       0 if($self->{logger}) {
803 0         0 $self->{logger}->info("Can't determine my age");
804             }
805 0         0 return;
806             }
807 0 0       0 if($age > $s) {
808 0 0       0 if($self->{logger}) {
809 0         0 $self->{logger}->debug('_check_modified_since: script has been modified');
810             }
811             # Script has been updated so it may produce different output
812 0         0 return;
813             }
814              
815 0 0       0 if($self->{logger}) {
816 0         0 $self->{logger}->debug("_check_modified_since: Compare $$params{modified} with $s");
817             }
818 0 0       0 if($$params{modified} <= $s) {
819 0         0 push @{$self->{o}}, "Status: 304 Not Modified";
  0         0  
820 0         0 $self->{status} = 304;
821 0         0 $self->{send_body} = 0;
822 0 0       0 if($self->{logger}) {
823 0         0 $self->{logger}->debug('Set status to 304');
824             }
825             }
826             }
827              
828             # Reduce output, e.g. remove superfluous white-space.
829             sub _optimise_content {
830 27     27   51 my $self = shift;
831              
832             # FIXME: regex bad, HTML parser good
833             # Regexp::List - wow!
834 27         1088 $self->{body} =~ s/(((\s+|\r)\n|\n(\s+|\+)))/\n/g;
835             # $self->{body} =~ s/\r\n/\n/gs;
836             # $self->{body} =~ s/\s+\n/\n/gs;
837             # $self->{body} =~ s/\n+/\n/gs;
838             # $self->{body} =~ s/\n\s+|\s+\n/\n/g;
839 27         103 $self->{body} =~ s/\<\/div\>\s+\<div/\<\/div\>\<div/gis;
840             # $self->{body} =~ s/\<\/p\>\s\<\/div/\<\/p\>\<\/div/gis;
841             # $self->{body} =~ s/\<div\>\s+/\<div\>/gis; # Remove spaces after <div>
842 27         8539 $self->{body} =~ s/(<div>\s+|\s+<div>)/<div>/gis;
843 27         92 $self->{body} =~ s/\s+<\/div\>/\<\/div\>/gis; # Remove spaces before </div>
844 27         488 $self->{body} =~ s/\s+\<p\>|\<p\>\s+/\<p\>/im; # TODO <p class=
845 27         499 $self->{body} =~ s/\s+\<\/p\>|\<\/p\>\s+/\<\/p\>/gis;
846 27         94 $self->{body} =~ s/<html>\s+<head>/<html><head>/is;
847 27         131 $self->{body} =~ s/\s*<\/head>\s+<body>\s*/<\/head><body>/is;
848 27         76 $self->{body} =~ s/<html>\s+<body>/<html><body>/is;
849 27         82 $self->{body} =~ s/<body>\s+/<body>/is;
850 27         86 $self->{body} =~ s/\s+\<\/html/\<\/html/is;
851 27         86 $self->{body} =~ s/\s+\<\/body/\<\/body/is;
852 27         156 $self->{body} =~ s/\s(\<.+?\>\s\<.+?\>)/$1/;
853             # $self->{body} =~ s/(\<.+?\>\s\<.+?\>)\s/$1/g;
854 27         67 $self->{body} =~ s/\<p\>\s/\<p\>/gi;
855 27         62 $self->{body} =~ s/\<\/p\>\s\<p\>/\<\/p\>\<p\>/gi;
856 27         63 $self->{body} =~ s/\<\/tr\>\s\<tr\>/\<\/tr\>\<tr\>/gi;
857 27         66 $self->{body} =~ s/\<\/td\>\s\<\/tr\>/\<\/td\>\<\/tr\>/gi;
858 27         99 $self->{body} =~ s/\<\/td\>\s*\<td\>/\<\/td\>\<td\>/gis;
859 27         74 $self->{body} =~ s/\<\/tr\>\s\<\/table\>/\<\/tr\>\<\/table\>/gi;
860 27         84 $self->{body} =~ s/\<br\s?\/?\>\s?\<p\>/\<p\>/gi;
861 27         68 $self->{body} =~ s/\<br\>\s+/\<br\>/gi;
862 27         76 $self->{body} =~ s/\s+\<br/\<br/gi;
863 27         56 $self->{body} =~ s/\<br\s?\/\>\s/\<br \/\>/gi;
864 27         148 $self->{body} =~ s/[ \t]+/ /gs; # Remove duplicate space, don't use \s+ it breaks JavaScript
865 27         75 $self->{body} =~ s/\s\<p\>/\<p\>/gi;
866 27         73 $self->{body} =~ s/\s\<script/\<script/gi;
867 27         444 $self->{body} =~ s/(<script>\s|\s<script>)/<script>/gis;
868 27         406 $self->{body} =~ s/(<\/script>\s|\s<\/script>)/<\/script>/gis;
869 27         66 $self->{body} =~ s/\<td\>\s/\<td\>/gi;
870 27         98 $self->{body} =~ s/\s+\<a\shref="(.+?)"\>\s?/ <a href="$1">/gis;
871 27         110 $self->{body} =~ s/\s?<a\shref=\s"(.+?)"\>/ <a href="$1">/gis;
872 27         81 $self->{body} =~ s/\s+<\/a\>\s+/<\/a> /gis;
873 27         677 $self->{body} =~ s/(\s?<hr>\s+|\s+<hr>\s?)/<hr>/gis;
874             # $self->{body} =~ s/\s<hr>/<hr>/gis;
875             # $self->{body} =~ s/<hr>\s/<hr>/gis;
876 27         66 $self->{body} =~ s/<\/li>\s+<li>/<\/li><li>/gis;
877 27         61 $self->{body} =~ s/<\/li>\s+<\/ul>/<\/li><\/ul>/gis;
878 27         56 $self->{body} =~ s/<ul>\s+<li>/<ul><li>/gis;
879 27         62 $self->{body} =~ s/\s+<\/li>/<\/li>/gis;
880 27         56 $self->{body} =~ s/\<\/option\>\s+\<option/\<\/option\>\<option/gis;
881 27         87 $self->{body} =~ s/<title>\s*(.+?)\s*<\/title>/<title>$1<\/title>/is;
882 27         127 $self->{body} =~ s/<\/center>\s+<center>/ /gis;
883             }
884              
885             # Create a key for the cache
886             sub _generate_key {
887 0     0   0 my $self = shift;
888 0 0       0 if($self->{cache_key}) {
889 0         0 return $self->{cache_key};
890             }
891 0 0       0 unless(defined($self->{info})) {
892 0         0 $self->{info} = CGI::Info->new({ cache => $self->{cache} });
893             }
894              
895 0         0 my $key = $self->{info}->browser_type() . '::' . $self->{info}->domain_name() . '::' . $self->{info}->script_name() . '::' . $self->{info}->as_string();
896              
897 0 0       0 if($self->{lingua}) {
898 0         0 $key .= '::' . $self->{lingua}->language();
899             }
900 0 0       0 if($ENV{'HTTP_COOKIE'}) {
901             # Different states of the client are stored in different caches
902             # Don't put different Google Analytics in different caches, and anyway they
903             # would be wrong
904 0         0 foreach my $cookie(split(/;/, $ENV{'HTTP_COOKIE'})) {
905 0 0       0 unless($cookie =~ /^__utm[abcz]/) {
906 0         0 $key .= "::$cookie";
907             }
908             }
909             }
910              
911             # Honour the Vary headers
912 0         0 my $headers = $self->{'headers'};
913 0 0 0     0 if($headers && ($headers =~ /^Vary: .*$/m)) {
914 0 0       0 if(defined($self->{logger})) {
915 0         0 $self->{logger}->debug('Found Vary header');
916             }
917 0         0 foreach my $h1(split(/\r?\n/, $headers)) {
918 0         0 my ($h1_name, $h1_value) = split /\:\s*/, $h1, 2;
919 0 0       0 if(lc($h1_name) eq 'vary') {
920 0         0 foreach my $h2(split(/\r?\n/, $headers)) {
921 0         0 my ($h2_name, $h2_value) = split /\:\s*/, $h2, 2;
922 0 0       0 if($h2_name eq $h1_value) {
923 0         0 $key .= "::$h2_value";
924 0         0 last;
925             }
926             }
927             }
928             }
929             }
930 0         0 $key =~ s/\//::/g;
931 0         0 $key =~ s/::::/::/g;
932 0         0 $key =~ s/::$//;
933 0 0       0 if(defined($self->{logger})) {
934 0         0 $self->{logger}->trace("Returning $key");
935             }
936 0         0 $self->{cache_key} = $key;
937 0         0 return $key;
938             }
939              
940             =head2 init
941              
942             Set various options and override default values.
943              
944             # Put this toward the top of your program before you do anything
945             # By default, generate_tag, generate_304 and compress_content are ON,
946             # optimise_content and lint_content are OFF. Set optimise_content to 2 to
947             # do aggressive JavaScript optimisations which may fail.
948             use FCGI::Buffer;
949              
950             my $buffer = FCGI::Buffer->new()->init({
951             generate_etag => 1, # make good use of client's cache
952             generate_last_modified => 1, # more use of client's cache
953             compress_content => 1, # if gzip the output
954             optimise_content => 0, # optimise your program's HTML, CSS and JavaScript
955             cache => CHI->new(driver => 'File'), # cache requests
956             cache_key => 'string', # key for the cache
957             cache_age => '10 minutes', # how long to store responses in the cache
958             logger => $self->{logger},
959             lint_content => 0, # Pass through HTML::Lint
960             generate_304 => 1, # When appropriate, generate 304: Not modified
961             save_to => { directory => '/var/www/htdocs/save_to', ttl => 600, create_table => 1 },
962             info => CGI::Info->new(),
963             lingua => CGI::Lingua->new(),
964             });
965              
966             If no cache_key is given, one will be generated which may not be unique.
967             The cache_key should be a unique value dependent upon the values set by the
968             browser.
969              
970             The cache object will be an object that understands get_object(),
971             set(), remove() and created_at() messages, such as an L<CHI> object. It is
972             used as a server-side cache to reduce the need to rerun database accesses.
973              
974             Items stay in the server-side cache by default for 10 minutes.
975             This can be overridden by the cache_control HTTP header in the request, and
976             the default can be changed by the cache_age argument to init().
977              
978             Save_to is feature which stores output of dynamic pages to your
979             htdocs tree and replaces future links that point to that page with static links
980             to avoid going through CGI at all.
981             Ttl is set to the number of seconds that the static pages are deemed to
982             be live for, the default is 10 minutes.
983             If set to 0, the page is live forever.
984             To enable save_to, a info and lingua arguments must also be given.
985             It works best when cache is also given.
986             Only use where output is guaranteed to be the same with a given set of arguments
987             (the same criteria for enabling generate_304).
988             You can turn it off on a case by case basis thus:
989              
990             my $params = CGI::Info->new()->params();
991             if($params->{'send_private_email'}) {
992             $buffer->init('save_to' => undef);
993             }
994              
995             Info is an optional argument to give information about the FCGI environment, e.g.
996             a L<CGI::Info> object.
997              
998             Logger will be an object that understands debug() such as an L<Log::Log4perl>
999             object.
1000              
1001             To generate a last_modified header, you must give a cache object.
1002              
1003             Init allows a reference of the options to be passed. So both of these work:
1004             use FCGI::Buffer;
1005             #...
1006             my $buffer = FCGI::Buffer->new();
1007             $b->init(generate_etag => 1);
1008             $b->init({ generate_etag => 1, info => CGI::Info->new() });
1009              
1010             Generally speaking, passing by reference is better since it copies less on to
1011             the stack.
1012              
1013             If you give a cache to init() then later give cache => undef,
1014             the server side cache is no longer used.
1015             This is useful when you find an error condition when creating your HTML
1016             and decide that you no longer wish to store the output in the cache.
1017              
1018             =cut
1019              
1020             sub init {
1021 31     31 1 7558 my $self = shift;
1022 31 100       115 my %params = (ref($_[0]) eq 'HASH') ? %{$_[0]} : @_;
  22         80  
1023              
1024             # Safe options - can be called at any time
1025 31 100       102 if(defined($params{generate_etag})) {
1026 9         18 $self->{generate_etag} = $params{generate_etag};
1027             }
1028 31 50       81 if(defined($params{generate_last_modified})) {
1029 0         0 $self->{generate_last_modified} = $params{generate_last_modified};
1030             }
1031 31 100       63 if(defined($params{compress_content})) {
1032 1         4 $self->{compress_content} = $params{compress_content};
1033             }
1034 31 50       76 if(defined($params{optimise_content})) {
1035 31         54 $self->{optimise_content} = $params{optimise_content};
1036             }
1037 31 100       71 if(defined($params{lint_content})) {
1038 4         6 $self->{lint_content} = $params{lint_content};
1039             }
1040 31 100       64 if(defined($params{logger})) {
1041 1         2 $self->{logger} = $params{logger};
1042             }
1043 31 50       67 if(defined($params{lingua})) {
1044 0         0 $self->{lingua} = $params{lingua};
1045             }
1046              
1047 31 50 33     151 if(defined($params{save_to}) && $self->can_cache()) {
    50 33        
1048 0 0       0 if(my $dir = $params{'save_to'}->{'directory'}) {
1049 0 0       0 if(! -d $dir) {
1050 0         0 Carp::carp("$dir isn't a directory");
1051 0         0 return;
1052             }
1053 0 0       0 if(! -w $dir) {
1054 0         0 Carp::carp("$dir isn't writeable");
1055 0         0 return;
1056             }
1057             }
1058 0         0 $self->{save_to} = $params{save_to};
1059 0 0       0 if(!exists($params{save_to})) {
1060 0         0 $self->{save_to} = 600;
1061             }
1062             } elsif(exists($params{'save_to'}) && !defined($params{'save_to'})) {
1063 0         0 delete $self->{'save_to'};
1064             }
1065 31 100       65 if(defined($params{generate_304})) {
1066 3         7 $self->{generate_304} = $params{generate_304};
1067             }
1068 31 100 66     89 if(defined($params{info}) && (!defined($self->{info}))) {
1069 4         8 $self->{info} = $params{info};
1070             }
1071              
1072             # Unsafe options - must be called before output has been started
1073 31         116 my $pos = $self->{buf}->getpos;
1074 31 50       334 if($pos > 0) {
1075 0 0       0 if(defined($self->{logger})) {
1076 0         0 my @call_details = caller(0);
1077 0         0 $self->{logger}->warn("Too late to call init, $pos characters have been printed, caller line $call_details[2] of $call_details[1]");
1078             } else {
1079             # Must do Carp::carp instead of carp for Test::Carp
1080 0         0 Carp::carp "Too late to call init, $pos characters have been printed";
1081             }
1082             }
1083 31 50 33     79 if(exists($params{cache}) && $self->can_cache()) {
1084 0 0       0 if(defined($ENV{'HTTP_CACHE_CONTROL'})) {
1085 0         0 my $control = $ENV{'HTTP_CACHE_CONTROL'};
1086 0 0       0 if(defined($self->{logger})) {
1087 0         0 $self->{logger}->debug("cache_control = $control");
1088             }
1089 0 0       0 if($control =~ /^max-age\s*=\s*(\d+)$/) {
1090             # There is an argument not to do this
1091             # since one client will affect others
1092 0         0 $self->{cache_age} = "$1 seconds";
1093 0 0       0 if(defined($self->{logger})) {
1094 0         0 $self->{logger}->debug("cache_age = $self->{cache_age}");
1095             }
1096             }
1097             }
1098 0   0     0 $self->{cache_age} ||= $params{cache_age};
1099 0 0 0     0 if((!defined($params{cache})) && defined($self->{cache})) {
1100 0 0       0 if(defined($self->{logger})) {
1101 0 0       0 if($self->{cache_key}) {
1102 0         0 $self->{logger}->debug('disabling cache ', $self->{cache_key});
1103             } else {
1104 0         0 $self->{logger}->debug('disabling cache');
1105             }
1106             }
1107 0         0 delete $self->{cache};
1108             } else {
1109 0         0 $self->{cache} = $params{cache};
1110             }
1111 0 0       0 if(defined($params{cache_key})) {
1112 0         0 $self->{cache_key} = $params{cache_key};
1113             }
1114             }
1115              
1116 31         110 return $self;
1117             }
1118              
1119             sub import {
1120             # my $class = shift;
1121 9     9   136 shift;
1122              
1123 9 50       2679 return unless scalar(@_);
1124              
1125 0         0 init(@_);
1126             }
1127              
1128             =head2 set_options
1129              
1130             Synonym for init, kept for historical reasons.
1131              
1132             =cut
1133              
1134             sub set_options {
1135 11     11 1 6844 my $self = shift;
1136 11 100       47 my %params = (ref($_[0]) eq 'HASH') ? %{$_[0]} : @_;
  8         36  
1137              
1138 11         38 $self->init(\%params);
1139             }
1140              
1141             =head2 can_cache
1142              
1143             Returns true if the server is allowed to store the results locally.
1144             This is the value of X-Cache in the returned header.
1145              
1146             =cut
1147              
1148             sub can_cache {
1149 6     6 1 1896 my $self = shift;
1150              
1151 6 50       24 if(defined($self->{x_cache})) {
1152 0         0 return ($self->{x_cache} eq 'HIT');
1153             }
1154 6 50 33     45 if(defined($ENV{'NO_CACHE'}) || defined($ENV{'NO_STORE'})) {
1155 0         0 $self->{x_cache} = 'MISS';
1156 0         0 return 0;
1157             }
1158 6 50       23 if(defined($ENV{'HTTP_CACHE_CONTROL'})) {
1159 0         0 my $control = $ENV{'HTTP_CACHE_CONTROL'};
1160 0 0       0 if(defined($self->{logger})) {
1161 0         0 $self->{logger}->debug("cache_control = $control");
1162             }
1163             # TODO: check Authorization header not present
1164 0 0 0     0 if(($control eq 'no-store') ||
      0        
      0        
1165             ($control eq 'no-cache') ||
1166             ($control eq 'max-age=0') ||
1167             ($control eq 'private')) {
1168 0         0 $self->{x_cache} = 'MISS';
1169 0         0 return 0;
1170             }
1171             }
1172 6         15 $self->{x_cache} = 'HIT';
1173 6         23 return 1;
1174             }
1175              
1176             =head2 is_cached
1177              
1178             Returns true if the output is cached. If it is then it means that all of the
1179             expensive routines in the FCGI script can be by-passed because we already have
1180             the result stored in the cache.
1181              
1182             # Put this toward the top of your program before you do anything
1183              
1184             # Example key generation - use whatever you want as something
1185             # unique for this call, so that subsequent calls with the same
1186             # values match something in the cache
1187             use CGI::Info;
1188             use CGI::Lingua;
1189             use FCGI::Buffer;
1190              
1191             my $i = CGI::Info->new();
1192             my $l = CGI::Lingua->new(supported => ['en']);
1193              
1194             # To use server side caching you must give the cache argument, however
1195             # the cache_key argument is optional - if you don't give one then one will
1196             # be generated for you
1197             my $buffer = FCGI::Buffer->new();
1198             if($buffer->can_cache()) {
1199             $buffer->init(
1200             cache => CHI->new(driver => 'File'),
1201             cache_key => $i->domain_name() . '/' . $i->script_name() . '/' . $i->as_string() . '/' . $l->language()
1202             );
1203             if($buffer->is_cached()) {
1204             # Output will be retrieved from the cache and sent automatically
1205             exit;
1206             }
1207             }
1208             # Not in the cache, so now do our expensive computing to generate the
1209             # results
1210             print "Content-type: text/html\n";
1211             # ...
1212              
1213             =cut
1214              
1215             sub is_cached {
1216 11     11 1 1061 my $self = shift;
1217              
1218 11 50       40 unless($self->{cache}) {
1219 11 50       30 if($self->{logger}) {
1220 0         0 $self->{logger}->debug("is_cached: cache hasn't been enabled");
1221             }
1222 11         44 return 0;
1223             }
1224              
1225 0         0 my $key = $self->_generate_key();
1226              
1227 0 0       0 if($self->{logger}) {
1228 0         0 $self->{logger}->debug("is_cached: looking for key = $key");
1229             }
1230 0         0 $self->{cobject} = $self->{cache}->get_object($key);
1231 0 0       0 unless($self->{cobject}) {
1232 0 0       0 if($self->{logger}) {
1233 0         0 $self->{logger}->debug('not found in cache');
1234             }
1235 0         0 return 0;
1236             }
1237 0 0       0 unless($self->{cobject}->value($key)) {
1238 0 0       0 if($self->{logger}) {
1239 0         0 $self->{logger}->warn('is_cached: object is in the cache but not the data');
1240             }
1241 0         0 delete $self->{cobject};
1242 0         0 return 0;
1243             }
1244              
1245             # If the script has changed, don't use the cache since we may produce
1246             # different output
1247 0         0 my $age = $self->_my_age();
1248 0 0       0 unless(defined($age)) {
1249 0 0       0 if($self->{logger}) {
1250 0         0 $self->{logger}->debug("Can't determine script's age");
1251             }
1252             # Can't determine the age. Play it safe an assume we're not
1253             # cached
1254 0         0 delete $self->{cobject};
1255 0         0 return 0;
1256             }
1257 0 0       0 if($age > $self->{cobject}->created_at()) {
1258             # Script has been updated so it may produce different output
1259 0 0       0 if($self->{logger}) {
1260 0         0 $self->{logger}->debug('Script has been updated');
1261             }
1262 0         0 delete $self->{cobject};
1263             # Nothing will be in date and all new searches would miss
1264             # anyway, so may as well clear it all
1265             # FIXME: RT104471
1266             # $self->{cache}->clear();
1267 0         0 return 0;
1268             }
1269 0 0       0 if($self->{logger}) {
1270 0         0 $self->{logger}->debug('Script is in the cache');
1271             }
1272 0         0 return 1;
1273             }
1274              
1275             sub _my_age {
1276 0     0   0 my $self = shift;
1277              
1278 0 0       0 if($self->{script_mtime}) {
1279 0         0 return $self->{script_mtime};
1280             }
1281 0 0       0 unless(defined($self->{info})) {
1282 0 0       0 if($self->{cache}) {
1283 0         0 $self->{info} = CGI::Info->new({ cache => $self->{cache} });
1284             } else {
1285 0         0 $self->{info} = CGI::Info->new();
1286             }
1287             }
1288              
1289 0         0 my $path = $self->{info}->script_path();
1290 0 0       0 unless(defined($path)) {
1291 0         0 return;
1292             }
1293              
1294 0         0 my @statb = stat($path);
1295 0         0 $self->{script_mtime} = $statb[9];
1296 0         0 return $self->{script_mtime};
1297             }
1298              
1299             sub _should_gzip {
1300 33     33   52 my $self = shift;
1301              
1302 33 100 100     193 if($self->{compress_content} && ($ENV{'HTTP_ACCEPT_ENCODING'} || $ENV{'HTTP_TE'})) {
      100        
1303 2 50       8 if(defined($self->{content_type})) {
1304 2         4 my @content_type = @{$self->{content_type}};
  2         7  
1305 2 50       9 if($content_type[0] ne 'text') {
1306 0         0 return '';
1307             }
1308             }
1309 2 100       11 my $accept = lc($ENV{'HTTP_ACCEPT_ENCODING'} ? $ENV{'HTTP_ACCEPT_ENCODING'} : $ENV{'HTTP_TE'});
1310 2         12 foreach my $method(split(/,\s?/, $accept)) {
1311 2 50 66     16 if(($method eq 'gzip') || ($method eq 'x-gzip') || ($method eq 'br')) {
      66        
1312 2         8 return $method;
1313             }
1314             }
1315             }
1316              
1317 31         76 return '';
1318             }
1319              
1320             sub _set_content_type {
1321 33     33   50 my $self = shift;
1322 33         58 my $headers = shift;
1323              
1324 33         118 foreach my $header (split(/\r?\n/, $headers)) {
1325 33         142 my ($header_name, $header_value) = split /\:\s*/, $header, 2;
1326 33 100       128 if (lc($header_name) eq 'content-type') {
1327 30         99 my @content_type = split /\//, $header_value, 2;
1328 30         73 $self->{content_type} = \@content_type;
1329 30         85 return;
1330             }
1331             }
1332             }
1333              
1334             sub _compress()
1335             {
1336 31     31   54 my $self = shift;
1337 31 50       89 my %params = (ref($_[0]) eq 'HASH') ? %{$_[0]} : @_;
  31         161  
1338              
1339 31         74 my $encoding = $params{encoding};
1340              
1341 31 100 66     106 if((length($encoding) == 0) || (length($self->{body}) < MIN_GZIP_LEN)) {
1342 29         83 return;
1343             }
1344              
1345 2 100       9 if($encoding eq 'gzip') {
    50          
1346 1         657 require Compress::Zlib;
1347 1         54147 Compress::Zlib->import;
1348              
1349             # Avoid 'Wide character in memGzip'
1350 1 50       14 unless($self->{_encode_loaded}) {
1351 1         599 require Encode;
1352 1         9831 $self->{_encode_loaded} = 1;
1353             }
1354 1         5 my $nbody = Compress::Zlib::memGzip(\Encode::encode_utf8($self->{body}));
1355 1 50       432 if(length($nbody) < length($self->{body})) {
1356 0         0 $self->{body} = $nbody;
1357 0 0       0 unless(grep(/^Content-Encoding: gzip/, @{$self->{o}})) {
  0         0  
1358 0         0 push @{$self->{o}}, 'Content-Encoding: gzip';
  0         0  
1359             }
1360 0 0       0 unless(grep(/^Vary: Accept-Encoding/, @{$self->{o}})) {
  0         0  
1361 0         0 push @{$self->{o}}, 'Vary: Accept-Encoding';
  0         0  
1362             }
1363             }
1364             } elsif($encoding eq 'br') {
1365 1         510 require IO::Compress::Brotli;
1366 1         1433 IO::Compress::Brotli->import();
1367              
1368 1 50       8 unless($self->{_encode_loaded}) {
1369 0         0 require Encode;
1370 0         0 $self->{_encode_loaded} = 1;
1371             }
1372 1         5 my $nbody = IO::Compress::Brotli::bro(Encode::encode_utf8($self->{body}));
1373 1 50       2116 if(length($nbody) < length($self->{body})) {
1374 1         5 $self->{body} = $nbody;
1375 1 50       3 unless(grep(/^Content-Encoding: br/, @{$self->{o}})) {
  1         6  
1376 1         2 push @{$self->{o}}, 'Content-Encoding: br';
  1         4  
1377             }
1378 1 50       3 unless(grep(/^Vary: Accept-Encoding/, @{$self->{o}})) {
  1         6  
1379 1         2 push @{$self->{o}}, 'Vary: Accept-Encoding';
  1         5  
1380             }
1381             }
1382             }
1383             }
1384              
1385             sub _check_if_none_match {
1386 2     2   4 my $self = shift;
1387              
1388 2 50       7 if($self->{logger}) {
1389 0         0 $self->{logger}->debug("Compare $ENV{HTTP_IF_NONE_MATCH} with $self->{etag}");
1390             }
1391 2 50       8 if($ENV{'HTTP_IF_NONE_MATCH'} eq $self->{etag}) {
1392 2         3 push @{$self->{o}}, 'Status: 304 Not Modified';
  2         8  
1393 2         5 $self->{send_body} = 0;
1394 2         3 $self->{status} = 304;
1395 2 50       6 if($self->{logger}) {
1396 0         0 $self->{logger}->debug('Set status to 304');
1397             }
1398 2         5 return 1;
1399             }
1400 0 0 0     0 if($self->{cache} && $self->{logger} && $self->{logger}->is_debug()) {
      0        
1401 0         0 my $cached_copy = $self->{cache}->get($self->_generate_key());
1402              
1403 0 0 0     0 if($cached_copy && $self->{body}) {
1404 0         0 require Text::Diff;
1405 0         0 Text::Diff->import();
1406              
1407 0         0 $cached_copy = Storable::thaw($cached_copy)->{body};
1408 0         0 my $diffs = diff(\$self->{body}, \$cached_copy);
1409 0         0 $self->{logger}->debug('diffs: ', $diffs);
1410             } else {
1411 0         0 $self->{logger}->debug('Nothing to compare');
1412             }
1413             }
1414 0         0 return 0;
1415             }
1416              
1417             # replace dynamic links with static links
1418             sub _save_to {
1419 26     26   69 my ($self, $unzipped_body, $dbh) = @_;
1420              
1421 26 0 33     107 return 0 unless($dbh && $self->{info} && (my $request_uri = $ENV{'REQUEST_URI'}));
      0        
1422 0 0         return 0 if(!defined($unzipped_body));
1423              
1424 0           my $query;
1425 0           my $copy = $unzipped_body;
1426 0           my $changes = 0;
1427 0           my $creation;
1428             my %seen_links;
1429 0           while($unzipped_body =~ /<a\shref="(.+?)"/gis) {
1430 0           my $link = $1;
1431 0 0         next if($seen_links{$link}); # Already updated in the copy
1432 0           $seen_links{$link} = 1;
1433 0           $link =~ tr/[\|;]/_/;
1434              
1435 0           my $search_uri = $link;
1436 0 0         if($search_uri =~ /^\?/) {
1437             # CGI script has links to itself
1438             # $search_uri = "${request_uri}${link}";
1439 0           my $r = $request_uri;
1440 0           $r =~ s/\?.*$//;
1441 0           $search_uri = "${r}$link";
1442             } else {
1443 0 0         next if($link =~ /^https?:\/\//); # FIXME: skips full URLs to ourself
1444             # Though optimise_content fixes that
1445 0 0         next if($link =~ /.html?$/);
1446 0 0         next if($link =~ /.jpg$/);
1447 0 0         next if($link =~ /.gif$/);
1448             }
1449 0 0         if($self->{save_to}->{ttl}) {
1450 0           $query = "SELECT DISTINCT path, creation FROM fcgi_buffer WHERE uri = ? AND language = ? AND browser_type = ? AND creation >= strftime('\%s','now') - " . $self->{save_to}->{ttl};
1451             } else {
1452 0           $query = "SELECT DISTINCT path, creation FROM fcgi_buffer WHERE uri = ? AND language = ? AND browser_type = ?";
1453             }
1454 0 0         if($self->{logger}) {
1455 0           $self->{logger}->debug("$query: $search_uri, ", $self->{lingua}->language(), ', ', $self->{info}->browser_type());
1456             }
1457 0 0         if(defined(my $sth = $dbh->prepare($query))) {
    0          
1458 0           $sth->execute($search_uri, $self->{lingua}->language(), $self->{info}->browser_type());
1459 0 0         if(my $href = $sth->fetchrow_hashref()) {
1460 0 0         if(my $path = $href->{'path'}) {
1461 0 0         if(-r $path) {
1462 0 0         if($self->{logger}) {
1463 0           $self->{logger}->debug("Changing links from $link to $path");
1464             }
1465 0           $link =~ s/\?/\\?/g;
1466 0           my $rootdir = $self->{info}->rootdir();
1467 0           $path = substr($path, length($rootdir));
1468 0           $changes += ($copy =~ s/<a\s+href="$link">/<a href="$path">/gis);
1469             # Find the first link that will expire and use that
1470 0 0 0       if((!defined($creation)) || ($href->{'creation'} < $creation)) {
1471 0           $creation = $href->{'creation'};
1472             }
1473             } else {
1474 0           $query = "DELETE FROM fcgi_buffer WHERE path = ?";
1475 0           $dbh->prepare($query)->execute($path);
1476 0 0         if($self->{logger}) {
1477 0           $self->{logger}->warn("Remove entry for non-existant file $path");
1478             }
1479             }
1480             }
1481             }
1482             } elsif($self->{logger}) {
1483 0           $self->{logger}->warn("failed to prepare '$query'");
1484             }
1485             }
1486 0           my $expiration = 0;
1487 0 0 0       if(defined($creation) && (my $ttl = $self->{save_to}->{ttl})) {
1488 0           $expiration = $creation + $ttl;
1489             }
1490 0 0 0       if($changes && (($expiration == 0) || ($expiration >= time))) {
    0 0        
      0        
1491 0 0         if($self->{logger}) {
1492             # $self->{logger}->debug("$changes links now point to static pages");
1493 0 0         if($changes == 1) {
1494 0 0         if($self->{'save_to'}->{'ttl'}) {
1495 0           $self->{logger}->info('1 link now points to a static page for ', $expiration - time, 's');
1496             } else {
1497 0           $self->{logger}->info('1 link now points to a static page');
1498             }
1499             } else {
1500 0           $self->{logger}->info("$changes links now point to static pages");
1501             }
1502             }
1503 0           $unzipped_body = $copy;
1504 0           $self->{'body'} = $unzipped_body;
1505 0 0         if(my $ttl = $self->{save_to}->{ttl}) {
1506 0           push @{$self->{o}}, 'Expires: ' . HTTP::Date::time2str($creation + $ttl);
  0            
1507             }
1508             } elsif($expiration && ($expiration < time)) {
1509             # Delete the save_to files
1510 0 0         if($self->{save_to}->{ttl}) {
1511 0           $query = "SELECT path FROM fcgi_buffer WHERE creation < strftime('\%s','now') - " . $self->{save_to}->{ttl};
1512             } else {
1513 0           $query = 'SELECT path FROM fcgi_buffer'; # Hmm, I suspect this is overkill
1514             }
1515 0           my $sth = $dbh->prepare($query);
1516 0           $sth->execute();
1517 0           while(my $href = $sth->fetchrow_hashref()) {
1518 0 0         if(my $path = $href->{'path'}) {
1519 0 0         if($self->{logger}) {
1520 0           $self->{logger}->debug("unlink $path");
1521             }
1522 0           unlink $path;
1523             }
1524             }
1525 0 0         if($self->{save_to}->{ttl}) {
1526 0           $query = "DELETE FROM fcgi_buffer WHERE creation < strftime('\%s','now') - " . $self->{save_to}->{ttl};
1527             } else {
1528 0           $query = 'DELETE FROM fcgi_buffer'; # Hmm, I suspect this is overkill
1529             }
1530 0 0         if($self->{logger}) {
1531 0           $self->{logger}->debug($query);
1532             }
1533 0           $dbh->prepare($query)->execute();
1534             # } else {
1535             # Old code
1536             # if($self->{save_to}->{ttl}) {
1537             # $query = "SELECT DISTINCT path, creation FROM fcgi_buffer WHERE key = '$key' AND creation >= strftime('\%s','now') - " . $self->{save_to}->{ttl};
1538             # } else {
1539             # $query = "SELECT DISTINCT path, creation FROM fcgi_buffer WHERE key = '$key'";
1540             # }
1541             # my $sth = $dbh->prepare($query);
1542             # $sth->execute();
1543             # my $href = $sth->fetchrow_hashref();
1544             # if(my $path = $href->{'path'}) {
1545             # # FIXME: don't do this if we've passed the TTL, and if we are clean
1546             # # up the database and remove the static page
1547             # $request_uri =~ s/\?/\\?/g;
1548             # if(($unzipped_body =~ s/<a href="$request_uri"/<a href="$path"/gi) > 0) {
1549             # $self->{'body'} = $unzipped_body;
1550             # if(my $ttl = $self->{save_to}->{ttl}) {
1551             # push @{$self->{o}}, 'Expires: ' . HTTP::Date::time2str($href->{creation} + $ttl);
1552             # }
1553             # }
1554             # }
1555             }
1556 0           return $changes;
1557             }
1558              
1559             =head1 AUTHOR
1560              
1561             Nigel Horne, C<< <njh at bandsman.co.uk> >>
1562              
1563             =head1 BUGS
1564              
1565             FCGI::Buffer should be safe even in scripts which produce lots of different
1566             output, e.g. e-commerce situations.
1567             On such pages, however, I strongly urge to setting generate_304 to 0 and
1568             sending the HTTP header "Cache-Control: no-cache".
1569              
1570             When using L<Template>, ensure that you don't use it to output to STDOUT,
1571             instead you will need to capture into a variable and print that.
1572             For example:
1573              
1574             my $output;
1575             $template->process($input, $vars, \$output) || ($output = $template->error());
1576             print $output;
1577              
1578             Can produce buggy JavaScript if you use the <!-- HIDING technique.
1579             This is a bug in L<JavaScript::Packer>, not FCGI::Buffer.
1580              
1581             Mod_deflate can confuse this when compressing output.
1582             Ensure that deflation is off for .pl files:
1583              
1584             SetEnvIfNoCase Request_URI \.(?:gif|jpe?g|png|pl)$ no-gzip dont-vary
1585              
1586             If you request compressed output then uncompressed output (or vice
1587             versa) on input that produces the same output, the status will be 304.
1588             The letter of the spec says that's wrong, so I'm noting it here, but
1589             in practice you should not see this happen or have any difficulties
1590             because of it.
1591              
1592             FCGI::Buffer has not been tested against FastCGI.
1593              
1594             I advise adding FCGI::Buffer as the last use statement so that it is
1595             cleared up first. In particular it should be loaded after
1596             L<Log::Log4Perl>, if you're using that, so that any messages it
1597             produces are printed after the HTTP headers have been sent by
1598             FCGI::Buffer;
1599              
1600             Save_to doesn't understand links in JavaScript, which means that if you use self-calling
1601             CGIs which are loaded as a static page they may point to the wrong place.
1602             The workaround is to avoid self-calling CGIs in JavaScript
1603              
1604             Please report any bugs or feature requests to C<bug-fcgi-buffer at rt.cpan.org>,
1605             or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=FCGI-Buffer>.
1606             I will be notified, and then you'll automatically be notified of progress on
1607             your bug as I make changes.
1608              
1609             The lint operation only works on HTML4, because of a restriction in L<HTML::Lint>.
1610              
1611             =head1 SEE ALSO
1612              
1613             CGI::Buffer, HTML::Packer, HTML::Lint
1614              
1615             =head1 SUPPORT
1616              
1617             You can find documentation for this module with the perldoc command.
1618              
1619             perldoc FCGI::Buffer
1620              
1621             You can also look for information at:
1622              
1623             =over 4
1624              
1625             =item * RT: CPAN's request tracker
1626              
1627             L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=FCGI-Buffer>
1628              
1629             =item * CPAN Ratings
1630              
1631             L<http://cpanratings.perl.org/d/FCGI-Buffer>
1632              
1633             =item * Search CPAN
1634              
1635             L<http://search.cpan.org/dist/FCGI-Buffer/>
1636              
1637             =back
1638              
1639             =head1 ACKNOWLEDGEMENTS
1640              
1641             The inspiration and code for some of this is cgi_buffer by Mark
1642             Nottingham: L<https://www.mnot.net/blog/2003/04/24/etags>.
1643              
1644             =head1 LICENSE AND COPYRIGHT
1645              
1646             The licence for cgi_buffer is:
1647              
1648             "(c) 2000 Copyright Mark Nottingham <mnot@pobox.com>
1649              
1650             This software may be freely distributed, modified and used,
1651             provided that this copyright notice remain intact.
1652              
1653             This software is provided 'as is' without warranty of any kind."
1654              
1655             The rest of the program is Copyright 2015-2020 Nigel Horne,
1656             and is released under the following licence: GPL2
1657              
1658             =cut
1659              
1660             1; # End of FCGI::Buffer