view release on metacpan or  search on metacpan

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

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

    return ($nph, $no_cache, \@headers);    
}


## FROM CGI::Util ##
# This internal routine creates date strings suitable for use in
# cookies and HTTP headers.  (They differ, unfortunately.)
# Thanks to Mark Fisher for this.
sub expires {
    my($time,$format) = @_;
    $format ||= 'http';

    my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
    my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;

    # pass through preformatted dates for the sake of expire_calc()
    $time = expire_calc($time);
    return $time unless $time =~ /^\d+$/;

    # make HTTP/cookie date string from GMT'ed time
    # (cookies use '-' as date separator, HTTP uses ' ')
    my($sc) = ' ';
    $sc = '-' if $format eq "cookie";
    my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
    $year += 1900;
    return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
                   $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
}

## FROM CGI::Util ##
# This internal routine creates an expires time exactly some number of