File Coverage

blib/lib/Apache/CacheContent.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

package Apache::CacheContent;

use strict;

$Apache::CacheContent::VERSION = '0.12';
@Apache::CacheContent::ISA = qw(Apache);

use Apache;
use Apache::Constants qw(OK SERVER_ERROR DECLINED);
use Apache::File ();
use Apache::Log ();

sub disk_cache ($$) {
  my ($self, $r) = @_;

  my $log  = $r->server->log;
  my $file = $r->filename;

  # Convert configured minutes to days for -M test.
  my $timeout = $self->ttl($r) / (24*60);

  # Test age of file.
  if (-f $r->finfo && -M _ < $timeout) {
    $log->info("using cache file '$file'");
    return DECLINED;
  }

  # No old file to use, so make a new one.
  $log->info("generating '$file'");

  # First, create a request object from our Capture class below.
  my $fake_r = Apache::CacheContent::Capture->new($r);

  # Call the handler() subroutine of the subclass,
  # but pass it the fake $r so that we get the content back.
  $self->handler($fake_r);

  # Now, write the content from handler() to a file on disk.
  my $fh = Apache::File->new(">$file");

  unless ($fh) {
    $log->error("Cannot open '$file': $!");
    return SERVER_ERROR;
  }

  # Dump the content.
  print $fh $fake_r->data();

  # We need to call close() explicitly here or else
  # the Content-Length header does not get set properly.
  $fh->close;

  # Finally, reset the filename to point to the newly
  # generated file and let Apache's default handler send it.
  $r->filename($file);

  return OK;
}

sub ttl {
  # Get the cache time in minutes.
  # Default to 1 hour.

  return shift->dir_config('CacheTTL') || 60;
}

sub handler {

  my ($self, $r) = @_;

  $r->send_http_header('text/html'); # ignored...

  $r->print(" --- non-subclassed request --- ");
}

# Package that capture's handler output and stash it away.

package Apache::CacheContent::Capture;

@Apache::CacheContent::Capture::ISA = qw(Apache);

sub new {
  my ($class, $r) = @_;

  $r ||= Apache->request;

  tie *STDOUT, $class, $r;

  return tied *STDOUT;
}

sub print {
  # Intercept print so we can stash the data.

  shift->{_data} .= join('', @_);
}

sub data {
  # Return stashed data.

  return shift->{_data};
}

sub send_http_header {
  # no-op - don't send headers from a PerlFixupHandler.
};

# Capture regular print statements.

sub TIEHANDLE {
  my ($class, $r) = @_;

  return bless { _r    => $r,
                 _data => undef
  }, $class;
}

sub PRINT {
  shift->print(@_);
}

1;

__END__