view release on metacpan or  search on metacpan

lib/Ambrosia/CommonGatewayInterface/ApacheRequest.pm  view on Meta::CPAN

    my ($nph, $no_cache, $header) = prepare_header(@_);

    if ( $self->IS_OK )
    {
        $self->__core->status(&HTTP_OK);
    }
    elsif( $self->IS_REDIRECT )
    {
        $self->__core->status(&HTTP_MOVED_TEMPORARILY);
    }
    elsif( $self->IS_ERROR )
    {
        $self->__core->status(&HTTP_INTERNAL_SERVER_ERROR);
    }

    $self->__core->send_http_header if $nph;
    $self->__core->no_cache if $no_cache;
    $self->__core->send_cgi_header(join(crlf(), @$header, crlf()));

    return '';
}

################################################################################

sub crlf() { "\r\n"; }

sub prepare_header
{
    my %params = @_;
    my @headers = ();
    my $type = 'Content-Type: text/html';
    my $charset = '';
    my $date;
    my $nph;
    my $status;
    my $no_cache;

    foreach ( keys %params )
    {
        /-?([[:alnum:]]+)(?:[-_](\w+))?/;
        my $k = uc($1 . ($2 ? ('-' . $2) : ''));

        if ( $k eq 'TYPE' || $k eq 'CONTENT-TYPE')
        {
            $type = 'Content-Type: ' . $params{$_};
        }
        elsif( $k eq 'CHARSET' )
        {
            $charset = $params{$_};
        }
        elsif( $k eq 'PRAGMA')
        {
            $no_cache = $params{$_};
        }
        elsif( $k eq 'COOKIE' || $k eq 'COOKIES' )
        {
            my @cookies = ref $params{$_} eq 'ARRAY' ? @{$params{$_}} : $params{$_};
            foreach (@cookies)
            {
                my $cs = eval { $_->can('as_string') and $_->as_string; } || $_;
                push @headers, 'Set-Cookie: ' . $cs if $cs;
            }
            $date = 1;
        }
        elsif( $k eq 'STATUS' )
        {
            $status = $params{$_};
            push @headers, 'Status: ' . $status;
        }
        elsif( $k eq 'EXPIRES' )
        {
            push @headers, 'Expires: ' . expires($params{$_},'http');
            $date = 1;
        }
        elsif( $k eq 'P3P' )
        {
            my $p3p = $params{$_};
            push @headers, 'P3P: policyref="/w3c/p3p.xml", CP="'
                    . (ref($p3p) eq 'ARRAY' ? (join ' ', @$p3p) : $p3p) . '"';
        }
        elsif( $k eq 'NPH' )
        {
            my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
            $nph = $protocol . crlf();
            $date = 1;
        }
        elsif( $k eq 'TARGET' )
        {
            push @headers, 'Window-Target: ' . $params{$_};
        }
        elsif( $k eq 'ATTACHMENT' )
        {
            push @headers, 'Content-Disposition: attachment; filename="' . $params{$_} . '"';
        }
        elsif( $k eq 'URI' )
        {
            push @headers, 'Location: ' . $params{$_};
        }
        else
        {
            /-?([[:alnum:]]+)(?:[-_](\w+))?/;
            push @headers, ($1 . ($2 ? ('-' . $2) :'')) . ': ' . $params{$_};
        }
    }

    if ( defined $nph )
    {
        $nph .= ($status || '200 OK') . 'Server: ' . $ENV{SERVER_SOFTWARE};
    }

    if ($charset && $type !~ /\bcharset\b/)
    {
        $type .= '; charset=' . $charset;
    }

    push @headers, $type;

    if ( $date )
    {
        push @headers, 'Date: ' . expires(0, 'http');
    }