RE: Apache::Registry HTTP HEAD "feature" fix ;-)

[Geoffrey Young]

> -----Original Message-----
> From: Jean-Michel Hiver [mailto:[EMAIL PROTECTED]]
> Sent: Monday, November 26, 2001 9:38 AM
> To: [EMAIL PROTECTED]
> Subject: Re: Apache::Registry HTTP HEAD "feature" fix ;-)
> 
> 
> > well, I just gave you a patch that worked :)  basically, it 
> only provides a
> > solution for mod_cgi compatible scripts, but if you're 
> using the mod_perl
> > API then it is up to you to check $r->header_only and take 
> appropriate
> > action...
> 
> True, however your patch also means that it's necessary to recompile
> stuff, which is not always possible. In addition (and as an exercise)
> I'd be happy to find a clean Perl way to do it.
> 

this should work for scripts that only use print() (without the patch I sent
yesterday :)

--Geoff

package My::HEADRegistry;

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

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

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);
  local $_;

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

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

      if ($_ && /^(\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);
      }
    }
  }

  # send the headers unless we've already sent them
  $r->send_http_header && $r->sent_header(DONE)
    unless $r->sent_header;

  # 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);
}

sub TIEHANDLE {

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

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