← Back to branch summary

~ubuntu-branches/ubuntu/saucy/libpoe-component-client-http-perl/saucy

« back to all changes in this revision

Viewing changes to lib/POE/Filter/HTTPHead.pm

  • Committer: Bazaar Package Importer
  • Author(s): Jonathan Yu
  • Date: 2010-02-15 11:59:10 UTC
  • mfrom: (1.1.9 upstream) (2.1.8 sid)
  • Revision ID: james.westby@ubuntu.com-20100215115910-rksbre6vm9je85ya
Tags: 0.895-1
* New upstream release
* Update copyright to new DEP5 format
* Simplify shebang-fixing override
* Refresh whatis patch

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/POE/Filter/HTTPHead.pm
11
11
sub WORK_RESPONSE    () { 2 }
12
12
sub PROTOCOL_VERSION () { 3 }
13
13
 
14
 
sub STATE_STATUS () { 0x00 }  # waiting for a status line
 
14
sub STATE_STATUS () { 0x01 }  # waiting for a status line
15
15
sub STATE_HEADER () { 0x02 }  # gotten status, looking for header or end
16
16
 
17
17
sub DEBUG () { 0 }
32
32
sub get_one_start {
33
33
  my ($self, $chunks) = @_;
34
34
 
 
35
        # We're receiving newline-terminated lines.  Strip off any carriage
 
36
        # returns that might be left over.
 
37
        s/\x0D$// foreach @$chunks;
 
38
        s/^\x0D// foreach @$chunks;
 
39
 
35
40
  push (@{$self->[FRAMING_BUFFER]}, @$chunks);
36
41
  #warn "now got ", scalar @{$self->[FRAMING_BUFFER]}, " lines";
37
42
}
39
44
sub get_one {
40
45
  my $self = shift;
41
46
 
42
 
  #warn "in get_one";
43
 
  while (defined (my $line = shift (@{$self->[FRAMING_BUFFER]}))) {
44
 
    DEBUG and warn "LINE $line";
45
 
    if ($self->[CURRENT_STATE] == STATE_STATUS) {
46
 
      DEBUG and warn "in status";
47
 
      # Expect a status line.
48
 
      if ($line =~ m|^(?:HTTP/(\d+\.\d+) )?(\d{3})\s*(.+)?$|) {
49
 
        $self->[PROTOCOL_VERSION] = $1 if defined $1;
50
 
        $self->[WORK_RESPONSE] = HTTP::Response->new ($2, $3);
51
 
        $self->[WORK_RESPONSE]->protocol('HTTP/' . $self->[PROTOCOL_VERSION]);
52
 
        $self->[CURRENT_STATE] = STATE_HEADER;
53
 
      }
54
 
      else {
55
 
        # assume HTTP/0.9
56
 
        my $resp = HTTP::Response->new (
57
 
          '200', 'OK', ['Content-Type' => 'text/html'], $line
58
 
        );
59
 
        $resp->protocol('HTTP/0.9');
60
 
        return [ $resp ];
61
 
      }
62
 
    }
63
 
    else {
64
 
      if ($line eq '') {
65
 
        $self->[CURRENT_STATE] = STATE_STATUS;
66
 
        DEBUG and warn "return response";
67
 
        return [$self->[WORK_RESPONSE]];
68
 
      }
69
 
      DEBUG and warn "in headers";
70
 
      unless (@{$self->[FRAMING_BUFFER]} > 0) {
71
 
        unshift (@{$self->[FRAMING_BUFFER]}, $line);
72
 
        return [];
73
 
      }
74
 
      DEBUG and warn "got more lines";
75
 
      while ($self->[FRAMING_BUFFER]->[0] && $self->[FRAMING_BUFFER]->[0] =~ /^[\t ]/) {
76
 
        my $next_line = shift (@{$self->[FRAMING_BUFFER]});
77
 
        $next_line =~ s/^[\t ]+//;
78
 
        $line .= $next_line;
79
 
      }
80
 
      #warn "unfolded one: $line";
81
 
      if (
82
 
        $line =~ m{
83
 
        ^
84
 
        ([^\x00-\x19()<>@,;:\\""\/\[\]\?={}\x20\t]+):
85
 
        \s*([^\x00-\x07\x09-\x19]+)
86
 
        $
87
 
        }x
88
 
      ) {
89
 
        $self->[WORK_RESPONSE]->push_header($1, $2)
90
 
      }
91
 
    }
92
 
  }
93
 
  return [];
 
47
        # Process lines while we have them.
 
48
        LINE: while (@{$self->[FRAMING_BUFFER]}) {
 
49
                my $line = shift @{$self->[FRAMING_BUFFER]};
 
50
 
 
51
                # Waiting for a status line.
 
52
                if ($self->[CURRENT_STATE] == STATE_STATUS) {
 
53
                        DEBUG and warn "----- Waiting for a status line.\n";
 
54
 
 
55
                        # Does the line look like a status line?
 
56
                        if ($line =~ m|^(?:HTTP/(\d+\.\d+) )?(\d{3})\s*(.+)?$|) {
 
57
                                $self->[PROTOCOL_VERSION] = $1 if defined $1;
 
58
                                $self->[WORK_RESPONSE] = HTTP::Response->new ($2, $3);
 
59
                                $self->[WORK_RESPONSE]->protocol('HTTP/' . $self->[PROTOCOL_VERSION]);
 
60
                                $self->[CURRENT_STATE] = STATE_HEADER;
 
61
 
 
62
                                # We're done with the line.  Try the next one.
 
63
                                DEBUG and warn "Got a status line.\n";
 
64
                                next LINE;
 
65
                        }
 
66
 
 
67
                        # We have a line, but it doesn't look like a HTTP/1.1 status
 
68
                        # line.  Assume it's an HTTP/0.9 response and fabricate headers.
 
69
                        # Also, put the line back.  It's part of the content.
 
70
                        DEBUG and warn "Faking HTTP/0.9 headers (first line not status).\n";
 
71
                        my $resp = HTTP::Response->new (
 
72
                                '200', 'OK', ['Content-Type' => 'text/html'], $line
 
73
                        );
 
74
                        $resp->protocol('HTTP/0.9');
 
75
                        #unshift @{$self->[FRAMING_BUFFER]}, $line;
 
76
                        return [ $resp ];
 
77
                }
 
78
 
 
79
                # A blank line signals the end of headers.
 
80
                if ($line =~ /^\s*$/) {
 
81
                        DEBUG and warn "Got a blank line.  End of headers.\n";
 
82
                        $self->[CURRENT_STATE] = STATE_STATUS;
 
83
                        return [$self->[WORK_RESPONSE]];
 
84
                }
 
85
 
 
86
                # We have a potential header line.  Try to identify it's end.
 
87
                my $i = 0;
 
88
                CONTINUATION: while ($i < @{$self->[FRAMING_BUFFER]}) {
 
89
                        # Forward-looking line begins with whitespace.  It's a
 
90
                        # continuation of the previous line.
 
91
                        $i++, next CONTINUATION if $self->[FRAMING_BUFFER]->[$i] =~ /^\s+\S/;
 
92
 
 
93
                        DEBUG and warn "Found end of header ($i)\n";
 
94
 
 
95
                        # Forward-looking line isn't a continuation line.  All buffer
 
96
                        # lines before it are part of the current header.
 
97
                        if ($i) {
 
98
                                $line .= $_ foreach (
 
99
                                        map { s/^\s+//; $_ }
 
100
                                        splice(@{$self->[FRAMING_BUFFER]}, 0, $i)
 
101
                                );
 
102
                        }
 
103
 
 
104
                        DEBUG and warn "Full header read: $line\n";
 
105
 
 
106
                        # And parse the line.
 
107
                        if (
 
108
                                $line =~ m{
 
109
                                        ^
 
110
                                        ([^\x00-\x19()<>@,;:\\""\/\[\]\?={}\x20\t]+):
 
111
                                        \s*([^\x00-\x07\x09-\x19]+)
 
112
                                        $
 
113
                                }x
 
114
                        ) {
 
115
                                DEBUG and warn "  header($1) value($2)\n";
 
116
                                $self->[WORK_RESPONSE]->push_header($1, $2)
 
117
                        }
 
118
 
 
119
                        next LINE;
 
120
                }
 
121
 
 
122
                # We didn't find a complete header.  Put the line back, and wait
 
123
                # for more input.
 
124
                DEBUG and warn "Incomplete header. Waiting for more.\n";
 
125
                unshift @{$self->[FRAMING_BUFFER]}, $line;
 
126
                return [];
 
127
        }
 
128
 
 
129
        # Didn't return anything else, so we don't have anything.
 
130
        return [];
94
131
}
95
132
 
96
133
#=for future
137
174
=cut
138
175
 
139
176
use vars qw($VERSION);
140
 
$VERSION = '0.893';
 
177
$VERSION = '0.895';
141
178
 
142
179
use base qw(POE::Filter::Stackable);
143
180
use POE::Filter::Line;
152
189
sub new {
153
190
  my $type = shift;
154
191
 
 
192
        # Look for EOL defined as linefeed.  We'll strip off possible
 
193
        # carriage returns in HTTPHead_Line's get_one_start().
 
194
 
155
195
  my $self = $type->SUPER::new(
156
196
    Filters => [
157
 
      POE::Filter::Line->new,
 
197
      POE::Filter::Line->new(Literal => "\x0A"),
158
198
      POE::Filter::HTTPHead_Line->new,
159
199
    ],
160
200
  );