DMAKI / Gungho-0.09005 / lib / Gungho / Request / http.pm 

            

              
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
—
100
101
102
103
104
105
106
107
108
109
110
111
112
113

              
# $Id: /mirror/gungho/lib/Gungho/Request/http.pm 2473 2007-09-04T07:08:58.221716Z lestrrat  $
#
# Copyright (c) 2007 Daisuke Maki <daisuke@endeworks.jp>
# All rightsreserved.
package Gungho::Request::http;
use strict;
use warnings;
use base qw(Gungho::Base);
__PACKAGE__->mk_accessors($_) for qw(peer_http_version send_te keep_alive);
my $CRLF = "\015\012";
sub new
{
    my $class = shift;
    $class->next::method(peer_http_version => "1.0", send_te => 0, @_);
}
sub prepare_request{}
sub format
{
    my $self    = shift;
    my $request = shift;
    $self->prepare_request($request);
    my $method  = $request->method || 'GET';
    my $uri     = $request->uri->path || '/';
    my $content = (@_ % 2) ? pop : "";
    for ($method, $uri) {
        require Carp;
        Carp::croak("Bad method or uri") if /\s/ || !length;
    }
     
    my $protocol = $request->protocol || 'HTTP/1.1';
    my ($ver)    = ($protocol =~ /(\d+\.\d+)\s*$/);
    my $peer_ver = $self->peer_http_version || "1.0";
     
    my @h;
    my @connection;
    my %given = (host => $request->header('Host') || 0, "content-length" => 0, "te" => 0);
    while (@_) {
        my($k, $v) = splice(@_, 0, 2);
        my $lc_k = lc($k);
        if ($lc_k eq "connection") {
            $v =~ s/^\s+//;
            $v =~ s/\s+$//;
            push(@connection, split(/\s*,\s*/, $v));
            next;
        }
        if (exists $given{$lc_k}) {
            $given{$lc_k}++;
        }
        push(@h, "$k: $v");
    }
     
    if (length($content) && !$given{'content-length'}) {
        push(@h, "Content-Length: " . length($content));
    }
     
    my @h2;
    if ($given{te}) {
        push(@connection, "TE") unless grep lc($_) eq "te", @connection;
    } elsif ($self->send_te && zlib_ok()) {
        # gzip is less wanted since the Compress::Zlib interface for
        # it does not really allow chunked decoding to take place easily.
        push(@h2, "TE: deflate,gzip;q=0.3");
        push(@connection, "TE");
    }
    unless (grep lc($_) eq "close", @connection) {
        if ($self->keep_alive) {
            if ($peer_ver eq "1.0") {
                # from looking at Netscape's headers
                push(@h2, "Keep-Alive: 300");
                unshift(@connection, "Keep-Alive");
            }
        } else {
            push(@connection, "close") if $ver ge "1.1";
        }
    }
    push(@h2, "Connection: " . join(", ", @connection)) if @connection;
    unless ($given{host}) {
        my $h = $request->uri->host;
        push(@h2, "Host: $h") if $h;
    }
    return join($CRLF, "$method $uri HTTP/$ver", @h2, @h, "", $content);
}
1;
__END__
=head1 NAME
Gungho::Request::http - HTTP specific utilities
=head1 METHODS
=head2 new
=head2 prepare_request
=head2 format
=cut