File Coverage

blib/lib/Apache/ASP/Response.pm
Criterion Covered Total %
statement 269 455 59.1
branch 122 286 42.7
condition 45 113 39.8
subroutine 24 41 58.5
pod 0 32 0.0
total 460 927 49.6


line stmt bran cond sub pod time code
1              
2             package Apache::ASP::Response;
3              
4 14     14   703 use Apache::ASP::Collection;
  14         242  
  14         318  
5              
6 14     14   297 use strict;
  14         132  
  14         187  
7 14     14   210 no strict qw(refs);
  14         131  
  14         172  
8 14     14   201 use vars qw(@ISA @Members %LinkTags $TextHTMLRegexp);
  14         132  
  14         206  
9             @ISA = qw(Apache::ASP::Collection);
10 14     14   240 use Carp qw(confess);
  14         127  
  14         259  
11 14     14   613 use Data::Dumper qw(DumperX);
  14         142  
  14         345  
12 14     14   276 use bytes;
  14         151  
  14         240  
13              
14             @Members = qw( Buffer Clean ContentType Expires ExpiresAbsolute Status );
15              
16             # used for session id auto parsing
17             %LinkTags = (
18             'a' => 'href',
19             'area' => 'href',
20             'form' => 'action',
21             'frame' => 'src',
22             'iframe' => 'src',
23             'img' => 'src',
24             'input' => 'src',
25             'link' => 'href',
26             );
27              
28             $TextHTMLRegexp = '^text/html(;|$)';
29              
30             sub new {
31 18     18 0 205     my $asp = shift;
32              
33 18         214     my $r = $asp->{'r'};
34 18         228     my $out = '';
35              
36 18 50 100     259     my $self = bless
      50        
      33        
37                   {
38                    asp => $asp,
39                    out => \$out,
40             # internal extension allowing various scripts like Session_OnStart
41             # to end the same response
42             # Ended => 0,
43                    CacheControl => 'private',
44                    CH => &config($asp, 'CgiHeaders') || 0,
45             # Charset => undef,
46                    Clean => &config($asp, 'Clean') || 0,
47                    Cookies => bless({}, 'Apache::ASP::Collection'),
48                    ContentType => 'text/html',
49                    'Debug' => $asp->{dbg},
50                    FormFill => &config($asp, 'FormFill'),
51                    IsClientConnected => 1,
52             # PICS => undef,
53             # Status => 200,
54             # header_buffer => '',
55             # header_done => 0,
56                    Buffer => &config($asp, 'BufferingOn', undef, 1),
57                    BinaryRef => \$out,
58                    CompressGzip => ($asp->{compressgzip} and ($asp->{headers_in}->get('Accept-Encoding') =~ /gzip/io)) ? 1 : 0,
59                    r => $r,
60                    headers_out => scalar($r->headers_out()),
61                   };
62              
63 18         346     &IsClientConnected($self); # update now
64              
65 18         220     $self;
66             }
67              
68             sub DeprecatedMemberAccess {
69 0     0 0 0     my($self, $member, $value) = @_;
70 0         0     $self->{asp}->Out(
71             "\$Response->$member() deprecated. Please access member ".
72             "directly with \$Response->{$member} notation"
73             );
74 0         0     $self->{$member} = $value;
75             }
76              
77             # defined the deprecated subs now, so we can loose the AUTOLOAD method
78             # the AUTOLOAD was forcing us to keep the DESTROY around
79             for my $member ( @Members ) {
80                 my $subdef = "sub $member { shift->DeprecatedMemberAccess('$member', shift); }";
81 0     0 0 0     eval $subdef;
  0     0 0 0  
  0     0 0 0  
  0     0 0 0  
  0     0 0 0  
  0     0 0 0  
82                 if($@) {
83             die("error defining Apache::ASP::Response sub -- $subdef -- $@");
84                 }
85             }
86              
87             sub AddHeader {
88 0     0 0 0     my($self, $name, $value) = @_;
89              
90 0         0     my $lc_name = lc($name);
91              
92 0 0       0     if($lc_name eq 'set-cookie') {
93 0         0 $self->{r}->err_headers_out->add($name, $value);
94                 } else {
95             # if we have a member API for this header, set that value instead
96             # to avoid duplicate headers from being sent out
97 0 0       0 if($lc_name eq 'content-type') {
    0          
    0          
98 0         0 $self->{ContentType} = $value;
99             } elsif($lc_name eq 'cache-control') {
100 0         0 $self->{CacheControl} = $value;
101             } elsif($lc_name eq 'expires') {
102 0         0 $self->{ExpiresAbsolute} = $value;
103             } else {
104 0         0 $self->{headers_out}->set($name, $value);
105             }
106                 }
107             }   
108              
109 0     0 0 0 sub AppendToLog { shift->{asp}->Log(@_); }
110             sub Debug {
111 7     7 0 62     my $self = shift;
112 7 50       84     $self->{Debug} && $self->{asp}->Out("[$self->{asp}{basename}]", @_);
113             };
114              
115             sub BinaryWrite {
116 0     0 0 0     $_[0]->Flush();
117 0 0       0     $_[0]->{asp}{dbg} && $_[0]->{asp}->Debug("binary write of ".length($_[1])." bytes");
118 0         0     &Write;
119             }
120              
121 18     18 0 176 sub Clear { my $out = shift->{out}; $$out = ''; }
  18         198  
122              
123             sub Cookies {
124 2     2 0 20     my($self, $name, $key, $value) = @_;
125 2 50 33     34     if(defined($name) && defined($key) && defined($value)) {
    0 33        
    0 0        
126 2         25 $self->{Cookies}{$name}{$key} = $value;
127                 } elsif(defined($name) && defined($key)) {
128             # we are assigning cookie with name the value of key
129 0 0       0 if(ref $key) {
130             # if a hash, set the values in it to the keys values
131             # we don't just assign the ref directly since for PerlScript
132             # compatibility
133 0         0 while(my($k, $v) = each %{$key}) {
  0         0  
134 0         0 $self->{Cookies}{$name}{$k} = $v;
135             }
136             } else {
137 0         0 $self->{Cookies}{$name}{Value} = $key;
138             }
139                 } elsif(defined($name)) {
140             # if the cookie was just stored as the name value, then we will
141             # will convert it into its hash form now, so we can store other
142             # things. We will probably be storing other things now, since
143             # we are referencing the cookie directly
144 0   0     0 my $cookie = $self->{Cookies}{$name} || {};
145 0 0       0 $cookie = ref($cookie) ? $cookie : { Value => $cookie };
146 0         0 $self->{Cookies}{$name} = bless $cookie, 'Apache::ASP::Collection';
147                 } else {
148 0         0 $self->{Cookies};
149                 }
150             }
151              
152             sub End {
153 6     6 0 55     my $self = shift;
154             # by not calling EndSoft(), but letting it be called naturally after
155             # Execute() in hander(), we allow more natural Buffer flushing to occur
156             # even if we are in a situation where Flush() has been made null like
157             # in an XMLSubs or cached or trapped include
158             # &EndSoft($self);
159 6         55     eval { goto APACHE_ASP_EXECUTE_END; };
  6         187  
160             }
161              
162             sub EndSoft {
163 16     16 0 157     my $self = shift;
164 16 100       2285     return if $self->{Ended}++;
165 14         229     &Flush($self);
166             }
167              
168             sub Flush {
169 14     14 0 134     my $self = shift;
170 14         140     my $asp = $self->{asp};
171 14         129     my $out = $self->{out};
172 14         181     local $| = 1;
173              
174             # Script_OnFlush event handler
175 14 50       245     $asp->{GlobalASA}{'exists'} &&
176                   $asp->{GlobalASA}->ScriptOnFlush();
177              
178             # XSLT Processing, check for errors so PrettyError() can call Flush()
179 14 50 33     306     if($asp->{xslt} && ! $asp->{errs}) {
180 0 0       0 $asp->{dbg} && $asp->Debug("pre xslt $out length: ".length($$out));
181 0         0 $self->FlushXSLT;
182 0 0       0 $asp->{dbg} && $asp->Debug("post xslt $out length: ".length($$out));
183 0 0       0 return if $asp->{errs};
184                 }
185              
186             # FormFill
187 14 50 33     262     if ($self->{FormFill} && ! $asp->{errs}) {
188 0         0 $self->FormFill;
189 0 0       0 return if $asp->{errs};
190                 }
191              
192 14 50 33     403     if($self->{Clean} and $self->{ContentType} =~ /$TextHTMLRegexp/o) {
193             # by checking defined, we just check once
194 0 0       0 unless(defined $Apache::ASP::CleanSupport) {
195 0         0 eval 'use HTML::Clean';
196 0 0       0 if($@) {
197 0         0 $self->{asp}->Log("Error loading module HTML::Clean with Clean set to $self->{Clean}. ".
198             "Make user you have HTML::Clean installed properly. Error: $@");
199 0         0 $Apache::ASP::CleanSupport = 0;
200             } else {
201 0         0 $Apache::ASP::CleanSupport = 1;
202             }
203             }
204              
205             # if we can't clean, we simply ignore
206 0 0       0 if($Apache::ASP::CleanSupport) {
207 0         0 my $h = HTML::Clean->new($out, $self->{Clean});
208 0 0       0 if($h) {
209 0         0 $h->strip();
210             } else {
211 0         0 $self->{asp}->Error("clean error: $! $@");
212             }
213             }
214                 }
215              
216             ## Session query auto parsing for cookieless sessions
217 14 50 66     428     if(
      66        
      33        
218                    $asp->{Session}
219                    and ! $asp->{session_cookie}
220                    and $asp->{session_url_parse}
221                    and ($self->{ContentType} =~ /^text/i)
222                   )
223                   {
224 0         0 $self->SessionQueryParse();
225                   }
226              
227 14 50       236     if($self->{Ended}) {
228             # log total request time just once at the end
229             # and append to html like Cocoon, per user request
230 14   33     136 my $total_time = sprintf('%7.5f', ( eval { &Time::HiRes::time() } || time() ) - $asp->{start_time});
  14         1256  
231 14 100       236 $asp->{dbg} && $asp->Debug("page executed in $total_time seconds");
232 14         159 $asp->{total_time} = $total_time;
233              
234 14 50       183 if(&config($asp, 'TimeHiRes')) {
235 0 0       0 if($self->{ContentType} =~ /$TextHTMLRegexp/o) {
236 0 0       0 if(&config($asp, 'Debug')) {
237 0         0 $$out .= "\n<!-- Apache::ASP v".$Apache::ASP::VERSION." served page in $total_time seconds -->";
238             }
239             }
240             }
241                 }
242              
243             # HEADERS AFTER CLEAN, so content-length would be calculated correctly
244             # if this is the first writing from the page, flush a newline, to
245             # get the headers out properly
246 14 100       179     if(! $self->{header_done}) {
247             # if no headers and the script has ended, we know that the
248             # the script has not been flushed yet, which would at least
249             # occur with buffering on
250 13 50       240 if($self->{Ended}) {
251             # compression & content-length settings will kill filters
252             # after Apache::ASP
253 13 50       204 if(! $asp->{filter}) {
254             # gzip the buffer if CompressGzip && browser accepts it &&
255             # the script is flushed once
256 13 50 33     195 if($self->{CompressGzip} && $asp->LoadModule('Gzip','Compress::Zlib')) {
257 0         0 $self->{headers_out}->set('Content-Encoding','gzip');
258 0         0 $$out = Compress::Zlib::memGzip($out);
259             }
260              
261 13         258 $self->{headers_out}->set('Content-Length', length($$out));
262             }
263             }
264            
265 13         147 &SendHeaders($self);
266                 }
267              
268 14 50       303     if($asp->{filter}) {
269 0         0 print STDOUT $$out;
270                 } else {
271             # just in case IsClientConnected is set incorrectly, still try to print
272             # the worst thing is some extra error messages in the error_log ...
273             # there have been spurious error reported with the IsClientConnected
274             # code since it was introduced, and this will limit the errors ( if any are left )
275             # to the users explicitly using this functionality, --jc 11/29/2001
276             #
277             # if($self->{IsClientConnected}) {
278 14 50 33     234 if(! defined $self->{Status} or ($self->{Status} >= 200 and $self->{Status} < 400)) {
      66        
279 14         223 $self->{r}->print($$out);
280             }
281             # }
282                 }
283              
284             # update after flushes only, expensive call
285 14 50       265     $self->{Ended} || &IsClientConnected($self);
286              
287             # supposedly this is more efficient than undeffing, since
288             # the string does not let go of its allocated memory buffer
289 14         157     $$out = '';
290              
291 14         210     1;
292             }
293              
294             sub FormFill {
295 0     0 0 0     my $self = shift;
296 0         0     my $asp = $self->{asp};
297              
298 0 0       0     $asp->{dbg} && $asp->Debug("form fill begin");
299 0 0