> -----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;