The only way I know of to actually find out if the header has been printed to to examine the CGI object itself.

$ perl -MData::Dumper -e "use CGI; my $q = CGI->new;print $q->header; 
+print Dumper($q)"
Content-Type: text/html; charset=ISO-8859-1

$VAR1 = bless( {
                 '.header_printed' => '1',
                 '.charset' => 'ISO-8859-1',
                 '.parameters' => [],
                 '.fieldnames' => {}
               }, 'CGI' );
[download]

use CGI;
my $q = new CGI;

# do a whole bunch of stuff

print "header printed!" if exists $q->{'.header_printed'};
[download]

Cheers,
Ovid

Join the Perlmonks Setiathome Group or just click on the the link and check out our stats.

Any idea where I can find doc on this feature? Searching through perldoc and I don't see it anywhere...nor does /HEADERS

"A man's maturity -- consists in having found again the seriousness on
+e
had as a child, at play."                                   --Nietzsch
+e
[download]

As far as I know, this is not documented in Perldoc or in the CGI POD. In fact, I don't know how I found out about it. It's just something I picked up. You can see how it works by examing the CGI.pm source code, but bring along some aspirin :)

I even went out to Lincoln Stein's home page and I can't find a reference there in his official docs. Sorry :(

Cheers,
Ovid

Join the Perlmonks Setiathome Group or just click on the the link and check out our stats.

use CGI::Carp qw(fatalsToBrowser set_message);
    BEGIN {
       sub handle_errors {
          my $msg = shift;
          print "<h1>Oh gosh</h1>";
          print "Got an error: $msg";
      }
      set_message(\&handle_errors);
    }
[download]

=Blue
...you might be eaten by a grue...

CGI::Carp has no idea if a header has been printed already. It always prints a new header.

As far as I know, there's no way to tell if something has already been sent down standard output. You'll just need to have things which cooperate. {grin}

-- Randal L. Schwartz, Perl hacker

Tom Christensen offers a good way to filter in the Perl Cookbook in chapter 16.5 (Filtering Your Own Output) by forking open on your own STDOUT and then having the child process filter STDIN to STDOUT.

#!/usr/bin/perl -w

use strict;

use CGI;

oneheader();

my $q = new CGI;

print $q->header;
print $q->header;

close(STDOUT);
exit;

sub oneheader
{
    my $pid;
    my $seen = 0;
    return if $pid = open(STDOUT, "|-");
    die "cannot fork: $!" unless defined $pid;
    while(<STDIN>)
    {
        if(m/^Content-Type/)
        {
            print unless $seen;
            $seen = 1;
        }
        else
        {
             print;
        }
    }
    exit;
}
[download]

Which produces:

(offline mode: enter name=value pairs on standard input)
Content-Type: text/html

(yep, thats two blank lines)

---

Another method is to tie a file handle and select it. This requires that you play nice and don't try to fool it by printing something in multiple chunks. This will also fail if CGI::Carp dosn't print to the selected filehandle but rather STDOUT directly. Please forgive me for not doing the return value from PRINT nicely and failing to implement PRINTF and WRITE.

#!/usr/bin/perl -w

use strict;
use CGI;

tie *FILTER, "OneHeader";

my $q = new CGI;

select FILTER;

print $q->header;
print $q->header;

print "Foo!\n";

exit;

package OneHeader;
sub TIEHANDLE
{
    my $class = shift;
    my $me = 0;
    bless \$me, $class;
}

sub PRINT
{
    my $self = shift;
    foreach my $item (@_)
    {
        if($item =~ m/^Content-Type/)
        {
            if(not $$self)
            {
                $$self = 1;
                print STDOUT $item;
            }
        }
        else
        {
            print STDOUT $item;
        }
    }
    1;
}

1;
[download]

The output of this method is:

(offline mode: enter name=value pairs on standard input)
Content-Type: text/html

Foo!

Just looked at the code for CGI::Carp and it always specifies the filehandle that it prints to. Thus the tie method will require additional twists to get it to work. Still, the essence is there.

--
$you = new YOU;
honk() if $you->love(perl)

print 
    $q->header(),
    $q->start_html(-title=>"R3: edit ads",
           -style=>{-code=>&css()});
$q->{header_was_sent}++;
[download]

sub error {
    my (@msgs) = @_;
    my $firstline = shift(@msgs);
    if (!$q->{header_was_sent}) {
    print
        $q->header(), 
        $q->start_html(-title=>"R3: error", -style=>{-code=>&css()});
    }
    print

    "<br><marquee><font class=\"error\"> Need help?  Something busted?
+ Confused?  Email the error message below to XXXXXXXXXXXXXXX </font><
+/marquee><br>",
    "<h1 class=\"error\"> Error: $firstline </h1><h2 class=\"error\">"
+,
    scalar(localtime), "<br>",
    join ("<br>",@msgs), "</h2>\n";
    print $q->end_html;
    exit(0);
}
[download]

  my @inqs = @{$dbh_g->selectcol_arrayref($sql,undef,$adid)} or &error
+("Bad selectcol in get_inqs", $sql, $dbh_g->errstr);
[download]