view release on metacpan or  search on metacpan

HEADRegistry.pm  view on Meta::CPAN

package Apache::HEADRegistry;

use Apache::Constants qw(DONE);
use Apache::RegistryNG;
use strict;

@Apache::HEADRegistry::ISA = qw(Apache::RegistryNG);

$Apache::HEADRegistry::VERSION = '0.01';

sub new {

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

  $r ||= Apache->request;

  tie *STDOUT, $class, $r;

  return tied *STDOUT;
}

sub PRINT {

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

  my $r = $self->{r};

  # we're emulating mod_cgi, where there is no auto-dereferencing...
  my $data = join '', @data;

  my $dlm = "\015?\012"; # a bit borrowed from LWP::UserAgent
  my ($key, $value);

  unless ($r->sent_header) {
    # if we have already sent the headers, no reason to scan the output

    while((my $header, $data) = split /$dlm/, $data, 2) {
      # scan the incoming data for headers

      if ($header && $header =~ m/^(\S+?):\s*(.*)$/) {
        # if the data looks like a header, add it to the header table

        ($key, $value) = ($1, $2);

        last unless $key;

        $r->cgi_header_out($key, $value);
      }
      else {
        # since we're done with the headers, send them along...

        $r->send_http_header;
        $r->sent_header(DONE);

        last;
      }
    }
  }

  # if this is a HEAD request, we're done
  return if $r->header_only;

  # otherwise, send whatever data we have left to the client
  $r->write_client($data);
}

# note that the perltie manpage is wrong - no need to append a newline
# verified by #p5p (thanks rafael :) and fixed in bleedperl
sub PRINTF {

  my $self = shift;

  $self->PRINT(sprintf(shift, @_));
}

# BINMODE and CLOSE are both no-ops in Apache.xs
sub BINMODE {};
sub CLOSE {};


sub TIEHANDLE {

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

  return bless { r => $r }, $class;
}

1;

__END__

=head1 NAME 

Apache::HEADRegistry - Apache::Registry drop-in for HEAD requests

=head1 SYNOPSIS

httpd.conf:

 PerlModule Apache::HEADRegsitry