File Coverage

blib/lib/Plack/App/CGIBin/Streaming/Request.pm
Criterion Covered Total %
statement 107 114 93.8
branch 25 28 89.2
condition 1 3 33.3
subroutine 21 26 80.7
pod 5 6 83.3
total 159 177 89.8


line stmt bran cond sub pod time code
1             package Plack::App::CGIBin::Streaming::Request;
2              
3 22     22   592 use 5.014;
  22         77  
  22         723  
4 22     22   124 use strict;
  22         222  
  22         812  
5 22     22   100 use warnings;
  22         31  
  22         681  
6 22     22   106 no warnings 'uninitialized';
  22         38  
  22         635  
7 22     22   100 use Carp;
  22         43  
  22         1648  
8              
9             # my %trace=
10             # (
11             # new=>sub {warn "NEW: @_"},
12             # header=>sub {warn "HEADER: @_"},
13             # flush=>sub {warn "FLUSH: @_"},
14             # status_out=>sub {warn "STATUS OUT: @_"},
15             # content=>sub {warn "CONTENT: @_"},
16             # finalize_start=>sub {warn "FINALIZE START: @_"},
17             # finalize_end=>sub {warn "FINALIZE END: @_"},
18             # );
19             # use constant TRACE=>sub {
20             # my $what=shift;
21             # local $SIG{__WARN__};
22             # $trace{$what} and $trace{$what}->(@_);
23             # } ;
24              
25 22     22   115 use constant TRACE=>0;
  22         56  
  22         3579  
26              
27             our @attr;
28              
29             our $DEFAULT_CONTENT_TYPE='text/plain';
30             our $DEFAULT_MAX_BUFFER=8000;
31              
32             BEGIN {
33 22     22   110 @attr=(qw/env responder writer _buffer _buflen _headers max_buffer
34             content_type filter_before filter_after on_status_output
35             parse_headers _header_buffer status notes on_flush on_finalize
36             suppress_flush binmode_ok/);
37 22         56 for (@attr) {
38 418         473 my $attr=$_;
39 22     22   122 no strict 'refs';
  22         37  
  22         2183  
40 418         27299 *{__PACKAGE__.'::'.$attr}=sub : lvalue {
41 3668     3668   4818 my $I=$_[0];
42 3668 100       7972 $I->{$attr}=$_[1] if @_>1;
43 3668         10588 $I->{$attr};
44 418         1014 };
45             }
46             }
47              
48             sub new {
49 22     22 0 583 my $class=shift;
50 22   33     143 $class=ref($class) || $class;
51             my $self=bless {
52             content_type=>$DEFAULT_CONTENT_TYPE,
53             max_buffer=>$DEFAULT_MAX_BUFFER,
54 3315     3315   4247 filter_before=>sub{},
55 3323     3323   9176 filter_after=>sub{},
56 18     18   104 on_status_output=>sub{},
57 3     3   8 on_flush=>sub{},
58 14     14   29 on_finalize=>sub{},
59 22         1135 notes=>+{},
60             _headers=>[],
61             _buffer=>[],
62             _buflen=>0,
63             status=>200,
64             }, $class;
65              
66 22         122 for( my $i=0; $i<@_; $i+=2 ) {
67 103         241 my $method=$_[$i];
68 103         446 $self->$method($_[$i+1]);
69             }
70              
71 22         63 if (TRACE) {
72             (ref(TRACE) eq 'CODE'
73             ? TRACE->(new=>$self)
74             : warn "NEW $self");
75             }
76              
77 22         175 return $self;
78             }
79              
80             sub print_header {
81 51     51 1 199 my $self = shift;
82              
83 51 50       226 croak "KEY => VALUE pairs expected" if @_%2;
84 51 50       276 croak "It's too late to set a HTTP header" if $self->{writer};
85              
86 51         81 if (TRACE) {
87             (ref(TRACE)
88             ? TRACE->(header=>$self, @_)
89             : warn "print_header $self: @_");
90             }
91              
92 51         261 push @{$self->{_headers}}, @_;
  51         322  
93             }
94              
95             sub print_content {
96 3347     3347 1 11288 my $self = shift;
97              
98 3347 100       7634 if ($self->{parse_headers}) {
99 14         135 $self->{_header_buffer}.=join('', @_);
100 14         473 while( $self->{_header_buffer}=~s/\A(\S+)[ \t]*:[ \t]*(.+?)\r?\n// ) {
101 34         138 my ($hdr, $val)=($1, $2);
102 34 100       330 if ($hdr=~/\Astatus\z/i) {
    100          
103 12         119 $self->{status}=$val;
104             } elsif ($hdr=~/\Acontent-type\z/i) {
105 14         102 $self->{content_type}=$val;
106             } else {
107 8         31 $self->print_header($hdr, $val);
108             }
109             }
110 14 50       161 if ($self->{_header_buffer}=~s/\A\r?\n//) {
111 14         49 delete $self->{parse_headers}; # done
112 14 100       111 $self->print_content(delete $self->{_header_buffer})
113             if length $self->{_header_buffer};
114             }
115 14         50 return;
116             }
117              
118 3333         6146 my @data=@_;
119 3333         7345 $self->{filter_before}->($self, \@data);
120              
121 3333         4918 my $len = 0;
122 3333         10033 $len += length $_ for @data;
123              
124 3333         3941 if (TRACE) {
125             (ref(TRACE)
126             ? TRACE->(content=>$self, @data)
127             : warn "print_content $self: $len bytes");
128             }
129              
130 3333         3865 push @{$self->{_buffer}}, @data;
  3333         8301  
131 3333         4870 $len += $self->{_buflen};
132 3333         4964 $self->{_buflen}=$len;
133              
134 3333 100       8013 if ($len > $self->{max_buffer}) {
135 8         21 local $self->{suppress_flush};
136 8         33 $self->flush;
137             }
138              
139 3333         7951 $self->filter_after->($self, \@data);
140             }
141              
142             sub _status_out {
143 22     22   132 my $self = shift;
144 22         34 my $is_done = shift;
145              
146 22         128 if (TRACE) {
147             (ref(TRACE)
148             ? TRACE->(status_out=>$self, $is_done)
149             : warn "status_out $self: $self->{status}");
150             }
151              
152 22         96 $self->print_header('Content-Type', $self->{content_type});
153 22 100       113 $self->print_header('Content-Length', $self->{_buflen})
154             if $is_done;
155 22         70 $self->on_status_output->($self);
156              
157 22 100       196 $self->{writer}=$self->{responder}->([$self->{status},
158             $self->{_headers},
159             $is_done ? $self->{_buffer}: ()]);
160             }
161              
162             sub status_written {
163 0     0 1 0 my $self = shift;
164 0         0 return !!$self->{writer};
165             }
166              
167             sub flush {
168 19     19 1 42 my $self = shift;
169 19 100       27 return 0 unless @{$self->{_buffer}};
  19         159  
170              
171 18         109 if (TRACE) {
172             (ref(TRACE)
173             ? TRACE->(flush=>$self)
174             : warn "flush $self");
175             }
176              
177 18 100       79 $self->_status_out unless $self->{writer};
178              
179 18         2942 $self->{writer}->write(join '', @{$self->{_buffer}});
  18         509  
180 18         2570 @{$self->{_buffer}}=();
  18         174  
181 18         34 $self->{_buflen}=0;
182              
183 18         79 $self->{on_flush}->($self);
184              
185 18         42 return 0;
186             }
187              
188             sub finalize {
189 22     22 1 48 my $self = shift;
190              
191 22         31 if (TRACE) {
192             (ref(TRACE)
193             ? TRACE->(finalize_start=>$self)
194             : warn "finalize start $self");
195             }
196              
197 22         105 $self->{on_finalize}->($self);
198 22 100       7591 if ($self->{writer}) {
199 9         38 $self->{writer}->write(join '', @{$self->{_buffer}});
  9         287  
200 9         818 $self->{writer}->close;
201             } else {
202 13         68 $self->_status_out(1);
203             }
204              
205 22         75530 if (TRACE) {
206             (ref(TRACE)
207             ? TRACE->(finalize_end=>$self)
208             : warn "finalize end $self");
209             }
210              
211 22         825 %$self=();
212 22         317 bless $self, 'Plack::App::CGIBin::Streaming::Request::Demolished';
213             }
214              
215             package # prevent CPAN indexing
216             Plack::App::CGIBin::Streaming::Request::Demolished;
217 22     22   132 use strict;
  22         35  
  22         2589  
218              
219             sub AUTOLOAD {
220 0     0     our $AUTOLOAD;
221 0           die "Calling $AUTOLOAD on a demolished request.";
222             }
223              
224 0     0     sub flush {}
225 0     0     sub finalize {}
226 0     0     sub DESTROY {}
227              
228             1;
229              
230             __END__