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       0     $asp->LoadModule('FormFill', 'HTML::FillInForm') || return;
300 0         0     my $ref = $self->{BinaryRef};
301              
302 0         0     $$ref =~ s/(\<form[^\>]*\>.*?\<\/form\>)/
303 0         0 {
  0         0  
304 0 0       0 my $form = $1;
305 0         0 my $start_length = $asp->{dbg} ? length($form) : undef;
306 0         0 eval {
307 0         0 my $fif = HTML::FillInForm->new();
308             $form = $fif->fill(
309             scalarref => \$form,
310             fdat => $asp->{Request}{Form},
311 0 0       0 );
312 0         0 };
313             if($@) {
314 0 0       0 $asp->CompileErrorThrow($form, "form fill failed: $@");
315             } else {
316             $asp->{dbg} &&
317             $asp->Debug("form fill for form of start length $start_length ".
318 0         0 "end length ".length($form));
319             }
320             $form;
321             }
322             /iexsg;
323              
324 0         0     1;
325             }
326              
327             sub FlushXSLT {
328 0     0 0 0     my $self = shift;
329 0         0     my $asp = $self->{asp};
330 0         0     my $xml_out = $self->{BinaryRef};
331 0 0       0     return unless length($$xml_out); # could happen after a redirect
332              
333 0   0     0     $asp->{xslt_match} = &config($asp, 'XSLTMatch') || '^.';
334 0 0       0     return unless ($asp->{filename} =~ /$asp->{xslt_match}/);
335              
336             ## XSLT FETCH & CACHE
337 0 0       0     $asp->{dbg} && $asp->Debug("xslt processing with $asp->{xslt}");
338 0         0     my $xsl_dataref = $self->TrapInclude($asp->{xslt});
339 0 0       0     $asp->{dbg} && $asp->Debug(length($$xsl_dataref)." bytes in XSL $xsl_dataref");
340 0 0       0     return if($asp->{errs});
341              
342             ## XSLT XML RENDER
343 0         0     eval {
344 0         0 my $xslt_data = $asp->XSLT($xsl_dataref, $xml_out);
345 0 0       0 $asp->{dbg} && $asp->Debug("xml_out $xml_out length ".length($$xml_out)." set to $xslt_data length ".
346             length($$xslt_data));
347 0         0 ${$self->{BinaryRef}} = $$xslt_data;
  0         0  
348                 };
349 0 0       0     if($@) {
350 0         0 $@ =~ s/^\s*//s;
351 0         0 $asp->Error("XSLT/XML processing error: $@");
352 0         0 return;
353                 }
354              
355 0         0     1;
356             }
357              
358             sub IsClientConnected {
359 25     25 0 245     my $self = shift;
360 25 50       286     return(0) if ! $self->{IsClientConnected};
361              
362             # must init Request first for the aborted test to be meaningful.
363             # it seems that under mod_perl 1.25, apache 1.20 on a fast local network,
364             # if $r->connection->aborted is checked on a file upload before $Request
365             # is initialized, then aborted will return true, even under normal use.
366             # This causes a file upload script to not render any output. It may be that this
367             # check was done too fast for apache, where it might have still been setting
368             # up the upload, so not to check the outbound client connection yet
369             #
370 25 50       298     unless($self->{asp}{Request}) {
371 0         0 $self->{asp}->Out("need to init Request object before running Response->IsClientConnected");
372 0         0 return 1;
373                 }
374              
375             # IsClientConnected ? Might already be disconnected for busy site, if
376             # a user hits stop/reload
377 25         415     my $conn = $self->{r}->connection;
378 25 50       480     my $is_connected = $conn->aborted ? 0 : 1;
379              
380 25 50       348     if($is_connected) {
381 25         231 my $fileno = eval { $conn->fileno };
  25         404  
382 25 50       326 if(defined $fileno) {
383             # sleep 3;
384             # my $s = IO::Select->new($fileno);
385             # $is_connected = $s->can_read(0) ? 0 : 1;
386              
387             # much faster than IO::Select interface() which calls
388             # a few perl OO methods to construct & then can_read()
389 0         0 my $bits = '';
390 0         0 vec($bits, $fileno, 1) = 1;
391 0 0       0 $is_connected = select($bits, undef, undef, 0) > 0 ? 0 : 1;
392 0 0       0 if(! $is_connected) {
393 0 0       0 $self->{asp}{dbg} && $self->{asp}->Debug("client is no longer connected, detected via Apache->request->connetion->fileno");
394             }
395             }
396                 }
397              
398 25         238     $self->{IsClientConnected} = $is_connected;
399 25 50       332     if(! $is_connected) {
400 0 0       0 $self->{asp}{dbg} && $self->{asp}->Debug("client is no longer connected");
401                 }
402              
403 25         240     $is_connected;
404             }
405              
406             # use the apache internal redirect? Thought that would be counter
407             # to portability, but is still something to consider
408             sub Redirect {
409 3     3 0 29     my($self, $location) = @_;
410 3         30     my $asp = $self->{asp};
411 3         75     my $r = $self->{r};
412              
413 3 50       36     $asp->{dbg} && $asp->Debug('redirect called', {location=>$location});
414                 
415             # X: maybe this instead, so no session-id on normal redirects?
416             # if($asp->{Session}) {
417             # $location = $asp->{Server}->URL($location);
418              
419 3 50 33     33     if($asp->{Session} and $asp->{session_url_parse}) {
420 0         0 $location = &SessionQueryParseURL($self, $location);
421 0 0       0 $asp->{dbg} && $asp->Debug("new location after session query parsing $location");
422                 }
423              
424 3         52     $r->headers_out->set('Location', $location);
425 3         39     $self->{Status} = 302;
426 3         48     $r->status(302);
427              
428             # Always SendHeaders() immediately for a Redirect() ... only in a SoftRedirect
429             # will execution continue. Since we call SendHeaders here, instead of
430             # Flush() a Redirect() will still work even in a XMLSubs call where Flush is
431             # trapped to Null()
432 3         31     &SendHeaders($self);
433              
434             # if we have soft redirects, keep processing page after redirect
435 3 100       40     if(&config($asp, 'SoftRedirect')) {
436 1         14 $asp->Debug("redirect is soft, headers already sent");
437                 } else {
438             # do we called End() or EndSoft() here? As of v 2.33, End() will
439             # just jump to the end of Execute(), so if we were in a XMLSubs
440             # and called End() after doing a Clear() there would still be
441             # output the gets flushed out from before the XMLSubs, to prevent
442             # this we clear the buffer now, and called EndSoft() in this case.
443             # Finally we also call End() so we will jump out of the executing code.
444             #
445 2         22 &Clear($self);
446 2         19 $self->{Ended} = 1; # just marked Ended so future EndSoft() cannot be called
447             # &EndSoft($self);
448 2         19 &End($self);
449                 }
450              
451 1         11     1;
452             }
453              
454             sub SendHeaders {
455 16     16 0 153     my $self = shift;
456 16         222     my $r = $self->{r};
457 16         178     my $asp = $self->{asp};
458 16         179     my $dbg = $asp->{dbg};
459 16         147     my $status = $self->{Status};
460              
461 16 50       224     return if $self->{header_done};
462 16         157     $self->{header_done} = 1;
463              
464 16 100       201     $dbg && $asp->Debug('building headers');
465 16 100       184     $r->status($status) if defined($status);
466              
467             # for command line script
468 16 50       211     return if &config($asp, 'NoHeaders');
469              
470 16 50 66     347     if(defined $status and $status == 401) {
471 0 0       0 $dbg && $asp->Debug("status 401, note basic auth failure realm ".$r->auth_name);
472              
473             # we can't send out headers, and let Apache use the 401 error doc
474             # But this is fine, once authorization is OK, then the headers
475             # will go out correctly, so things like sessions will work fine.
476 0         0 $r->note_basic_auth_failure;
477 0         0 return;
478                 } else {
479 16 50 66     226 $dbg && defined $status && $self->{asp}->Debug("status $status");
480                 }
481              
482 16 50       202     if(defined $self->{Charset}) {
483 0         0 $r->content_type($self->{ContentType}.'; charset='.$self->{Charset});
484                 } else {
485 16         293 $r->content_type($self->{ContentType}); # add content-type
486                 }
487              
488 16 100       164     if(%{$self->{'Cookies'}}) {
  16         204  
489 1         30 &AddCookieHeaders($self);     # do cookies
490                 }
491              
492             # do the expiration time
493 16 50       291     if(defined $self->{Expires}) {
    50          
494 0         0 my $ttl = $self->{Expires};
495 0         0 $r->headers_out->set('Expires', &Apache::ASP::Date::time2str(time()+$ttl));
496 0 0       0 $dbg && $self->{asp}->Debug("expires in $self->{Expires}");
497                 } elsif(defined $self->{ExpiresAbsolute}) {
498 0         0 my $date = $self->{ExpiresAbsolute};
499 0         0 my $time = &Apache::ASP::Date::str2time($date);
500 0 0       0 if(defined $time) {
501 0         0 $r->headers_out->set('Expires', &Apache::ASP::Date::time2str($time));
502             } else {
503 0         0 confess("Response->ExpiresAbsolute(): date format $date not accepted");
504             }
505                 }
506              
507             # do the Cache-Control header
508 16         254     $r->headers_out->set('Cache-Control', $self->{CacheControl});
509                 
510             # do PICS header
511 16 50       210     defined($self->{PICS}) && $r->headers_out->set('PICS-Label', $self->{PICS});
512                 
513             # don't send headers with filtering, since filter will do this for
514             # all the modules once
515             # doug sanctioned this one
516 16 50       190     unless($r->headers_out->get("Content-type")) {
517             # if filtering, we don't send out a header from ASP
518             # this means that Filtered scripts can use CGI headers
519             # we order the test this way in case Ken comes on
520             # board with setting header_out, in which case the test
521             # will fail early
522 16 50 33     334 if(! $asp->{filter} && (! defined $status or $status >= 200 && $status < 400)) {
      66        
      33        
523 16 100       191 $dbg && $asp->Debug("sending cgi headers");
524 16 100       192 if(defined $self->{header_buffer}) {
525             # we have taken in cgi headers
526 1         19 $r->send_cgi_header($self->{header_buffer} . "\n");
527 1         9 $self->{header_buffer} = undef;
528             } else {
529 15 50       163 unless($Apache::ASP::ModPerl2) {
530             # don't need this for mod_perl2 it seems from Apache::compat
531 15         229 $r->send_http_header();
532             }
533             }
534             }
535                 }
536              
537 16         211     1;
538             }
539              
540             # do cookies, try our best to emulate cookie collections
541             sub AddCookieHeaders {
542 1     1 0 10     my $self = shift;
543 1         10     my $cookies = $self->{'Cookies'};
544 1         11     my $dbg = $self->{asp}{dbg};
545              
546             # print STDERR Data::Dumper::DumperX($cookies);
547              
548 1         9     my($cookie_name, $cookie);
549 1         9     for $cookie_name (sort keys %{$cookies}) {
  1         20  
550             # skip key used for session id
551 3 50       32 if($Apache::ASP::SessionCookieName eq $cookie_name) {
552 0         0 confess("You can't use $cookie_name for a cookie name ".
553             "since it is reserved for session management"
554             );
555             }
556            
557 3         28 my($k, $v, @data, $header, %dict, $is_ref, $cookie, $old_k);
558            
559 3         27 $cookie = $cookies->{$cookie_name};
560 3 100       85 unless(ref $cookie) {
561 1         14 $cookie->{Value} = $cookie;
562             } 
563 3   100     35 $cookie->{Path} ||= '/';
564            
565 3         43 for $k (sort keys %$cookie) {
566 10         113 $v = $cookie->{$k};
567 10         146 $old_k = $k;
568 10         95 $k = lc $k;
569            
570             # print STDERR "$k ---> $v\n\n";
571              
572 10 100 66     129 if($k eq 'secure' and $v) {
    100          
    100          
    100          
    100          
573 1         12 $data[4] = 'secure';
574             } elsif($k eq 'domain') {
575 1         13 $data[3] = "$k=$v";
576             } elsif($k eq 'value') {
577             # we set the value later, nothing for now
578             } elsif($k eq 'expires') {
579 1         10 my $time;
580             # only the date form of expires is portable, the
581             # time vals are nice features of this implementation
582 1 50       15 if($v =~ /^\-?\d+$/) {
583             # if expires is a perl time val
584 0 0       0 if($v > time()) {
585             # if greater than time now, it is absolute
586 0         0 $time = $v;
587             } else {
588             # small, relative time, add to time now
589 0         0 $time = $v + time();
590             }
591             } else {
592             # it is a string format, PORTABLE use
593 1         14 $time = &Apache::ASP::Date::str2time($v);
594             }
595            
596 1         131 my $date = &Apache::ASP::Date::time2str($time);
597 1 50       39 $dbg && $self->{asp}->Debug("setting cookie expires",
598             {from => $v, to=> $date}
599             );
600 1         10 $v = $date;
601 1         13 $data[1] = "$k=$v";
602             } elsif($k eq 'path') {
603 3         32 $data[2] = "$k=$v";
604             } else {
605 2 50 66     30 if(defined($cookie->{Value}) && ! (ref $cookie->{Value})) {
606             # if the cookie value is just a string, its not a dict
607             } else {
608             # cookie value is a dict, add to it
609 2         54 $cookie->{Value}{$old_k} = $v;
610             }
611             } 
612             }
613            
614 3         60 my $server = $self->{asp}{Server}; # for the URLEncode routine
615 3 100 66     44 if(defined($cookie->{Value}) && (! ref $cookie->{Value})) {
616 2         28 $cookie->{Value} = $server->URLEncode($cookie->{Value});
617             } else {
618 1         9 my @dict;
619 1         9 for my $k ( sort keys %{$cookie->{Value}} ) {
  1         37  
620 2         20 my $v = $cookie->{Value}{$k};
621 2         22 push(@dict, $server->URLEncode($k) . '=' . $server->URLEncode($v));
622             }
623 1         15 $cookie->{Value} = join('&', @dict);
624             }
625 3         34 $data[0] = $server->URLEncode($cookie_name) . "=$cookie->{Value}";
626            
627             # have to clean the data now of undefined values, but
628             # keeping the position is important to stick to the Cookie-Spec
629 3         26 my @cookie;
630 3         29 for(0..4) {
631 15 100       141 next unless $data[$_];
632 9         87 push(@cookie, $data[$_]);
633             }
634 3         35 my $cookie_header = join('; ', @cookie);
635              
636 3         38 $self->{r}->err_headers_out->add('Set-Cookie', $cookie_header);
637 3 50       41 $dbg && $self->{asp}->Debug({cookie_header=>$cookie_header});
638                 }
639             }
640              
641             # with the WriteRef vs. Write abstration, direct calls
642             # to write might slow a little, but more common static
643             # html calls to WriteRef will be saved the HTML copy
644             sub Write {
645 24     24 0 293     my $self = shift;
646                 
647 24         3115     my $dataref;
648 24 50       361     if(@_ > 1) {
649 0   0     0 $, ||= ''; # non-standard use, so init here
650 0         0 my $data = join($,, @_);
651 0         0 $dataref = \$data;
652                 } else {
653             # $_[0] ||= '';
654 24 50       333 $dataref = defined($_[0]) ? \$_[0] : \'';
655                 }
656              
657 24         2060     &WriteRef($self, $dataref);
658              
659 24         258     1;
660             }
661              
662             # \'';
663              
664             *Apache::ASP::WriteRef = *WriteRef;
665             sub WriteRef {
666 95     95 0 973     my($self, $dataref) = @_;
667              
668             # allows us to end a response, but still execute code in event
669             # handlers which might have output like Script_OnStart / Script_OnEnd
670 95 50       979     return if $self->{Ended};
671             # my $content_out = $self->{out};
672              
673 95 100       1584     if($self->{CH}) {
674             # CgiHeaders may change the reference to the dataref, because
675             # dataref is a read-only scalar ref of static data, and CgiHeaders
676             # may need to change it
677 3         31 $dataref = $self->CgiHeaders($dataref);
678                 }
679              
680             # add dataref to buffer
681 95         834     ${$self->{out}} .= $$dataref;
  95         1342  
682                 
683             # do we flush now? not if we are buffering
684 95 50 33     1301     if(! $self->{'Buffer'} && ! $self->{'FormFill'}) {
685             # we test for whether anything is in the buffer since
686             # this way we can keep reading headers before flushing
687             # them out
688 0         0 &Flush($self);
689                 }
690              
691 95         1122     1;
692             }
693             *write = *Write;
694              
695             # alias printing to the response object
696 18     18   172 sub TIEHANDLE { $_[1]; }
697             *PRINT = *Write;
698             sub PRINTF {
699 0     0   0     my($self, $format, @list) = @_;
700 0         0     my $output = sprintf($format, @list);
701 0         0     $self->WriteRef(\$output);
702             }
703              
704             sub CgiHeaders {
705 3     3 0 26     my($self, $dataref) = @_;
706 3         26     my $content_out = $self->{out};
707              
708             # work on the headers while the header hasn't been done
709             # and while we don't have anything in the buffer yet
710             #
711             # also added a test for the content type being text/html or
712             #
713 3 100 33     86     if($self->{CH} && ! $self->{header_done} && ! $$content_out
      66        
      66        
714                    && ($self->{ContentType} =~ /$TextHTMLRegexp/o))
715                   {
716             # -1 to catch the null at the end maybe
717 2         27 my @headers = split(/\n/, $$dataref, -1);
718            
719             # first do status line
720 2         20 my $status = $headers[0];
721 2 50       20 if($status =~ m|HTTP/\d\.\d\s*(\d*)|o) {
722 0         0 $self->{Status} = $1;
723 0         0 shift @headers;
724             }
725            
726 2         54 while(@headers) {
727 5         46 my $out = shift @headers;
728 5 100       51 next unless $out; # skip the blank that comes after the last newline
729            
730 2 100       26 if($out =~ /^[^\s]+\: /) { # we are a header
731 1 50       13 unless(defined $self->{header_buffer}) {
732 1         12 $self->{header_buffer} .= '';
733             }
734 1         12 $self->{header_buffer} .= "$out\n";
735             } else {
736 1         10 unshift(@headers, $out);
737 1         11 last;
738             }
739             }
740            
741             # take remaining non-headers & set the data to them joined back up
742 2         22 my $data_left = join("\n", @headers);
743 2         20 $dataref = \$data_left;
744                   }
745              
746 3         78     $dataref;
747             }
748              
749 0     0 0 0 sub Null {};
750             sub TrapInclude {
751 26     26 0 274     my($self, $file) = (shift, shift);
752                 
753 26         306     my $out = "";
754 26         272     local $self->{out} = local $self->{BinaryRef} = \$out;
755 26         368     local $self->{Ended} = 0;
756 26         273     local *Apache::ASP::Response::Flush = *Null;
757 26         276     $self->Include($file, @_);
758              
759 26         1434     \$out;
760             }
761              
762             sub Include {
763 42     42 0 565     my $self = shift;
764 42         376     my $file = shift;
765 42         555     my $asp = $self->{asp};
766              
767 42         367     my($cache, $cache_key, $cache_expires, $cache_clear);
768 42 100 66     751     if(ref($file) && ref($file) eq 'HASH') {
769 34         320 my $data = $file;
770 34   33     486 $file = $data->{File}
771             || $asp->Error("no File key passed to Include(), keys ".join(',', keys %$file));
772 34 50       325 $asp->{dbg} && $asp->Debug("file $file from HASH ref in Include()");
773            
774 34 50       338 if($data->{Cache}) {
775 34         278 $cache = 1;
776 34         300 $cache_expires = $data->{'Expires'};
777 34         286 $cache_clear = $data->{'Clear'};
778 34         926 my $file_data = '';
779 34 100       367 if(ref($file)) {
780 23         224 $file_data = 'INCLUDE SCALAR REF '.$$file;
781             } else {
782 11         157 my $real_file = $asp->SearchDirs($file);
783 11         407 $file_data = 'INCLUDE FILE '.(stat($real_file))[9].' //\\ :: '.$real_file.' //\\ :: '.$file;
784             }
785 34 100       365 if($data->{Key}) {
786 27         413 $cache_key = $file_data .' //\\ :: '.DumperX($data->{Key});
787 27 50       300 $asp->{dbg} && $asp->Debug("include cache key length ".length($cache_key)." with extra Key data");
788             } else {
789 7 50       76 $asp->{dbg} && $asp->Debug("include cache key length ".length($file_data));
790 7         63 $cache_key = $file_data;
791             }
792 34         714 $cache_key .= ' //\\ COMPILE CHECKSUM :: '.$asp->{compile_checksum};
793 34         387 $cache_key .= ' //\\ ARGS :: '.DumperX(@_);
794 34 100       383 if(! $cache_clear) {
795 31         1625 my $rv = $asp->Cache('Response', \$cache_key, undef, $data->{Expires}, $data->{LastModified});
796 31 100       450 if($rv) {
797 17 50       158 if(! eval { ($rv->{RV} && $rv->{OUT}) }) {
  17 50       468  
798 0 0       0 $asp->{dbg} && $self->Debug("cache item invalid: $@");
799             } else {
800 17 50       185 $asp->{dbg} && $asp->Debug("found include $file output in cache");
801 17         297 $self->WriteRef($rv->{OUT});
802 17         148 my $rv_data = $rv->{RV};
803 17 100       323 return wantarray ? @$rv_data : $rv_data->[0];
804             }
805             }
806             }
807             }
808                 }
809              
810 25         581     my $_CODE = $asp->CompileInclude($file);
811 24 100       293     unless(defined $_CODE) {
812 1         11 die("error including $file, not compiled: $@");
813                 }
814              
815 23         223     $asp->{last_compile_include_data} = $_CODE;
816 23         262     my $eval = $_CODE->{code};
817              
818             # exit early for cached static file
819 23 100       313     if(ref $eval eq 'SCALAR') {
820 2 50       23        $asp->{dbg} && $asp->Debug("static file data cached, not compiled, length: ".length($$eval));
821 2         24        $self->WriteRef($eval);
822 2         20        return;
823                 }
824              
825 21 100       224     $asp->{dbg} && $asp->Debug("executing $eval");
826              
827 21         190     my @rc;
828 21 100       203     if($cache) {
829 17         175 my $out = "";
830             {
831 17         141 local $self->{out} = local $self->{BinaryRef} = \$out;
  17         217  
832 17         167 local $self->{Ended} = 0;
833 17         208 local *Apache::ASP::Response::Flush = *Null;
834 17         150 @rc = eval { &$eval(@_) };
  17         229  
835 17 50 0     188 $asp->{dbg} && $asp->Debug("caching $file output expires: ".($cache_expires || ''));
836 17         301 $asp->Cache('Response', \$cache_key, { RV => [ @rc ], OUT => \$out }, $cache_expires);
837             }
838 17         314 $self->WriteRef(\$out);
839                 } else {
840 4         35 @rc = eval { &$eval(@_) };
  4         50  
841                 }
842 21 50       263     if($@) {
843 0         0 my $code = $_CODE;
844 0         0 die "error executing code for include $code->{file}: $@; compiled to $code->{perl}";
845                 }
846 21 100       237     $asp->{dbg} && $asp->Debug("done executing include code $eval");
847              
848 21 100       289     wantarray ? @rc : $rc[0];
849             }
850              
851             sub ErrorDocument {
852 0     0 0       my($self, $error_code, $uri) = @_;
853 0               $self->{'r'}->custom_response($error_code, $uri);
854             }
855              
856             sub SessionQueryParse {
857 0     0 0       my $self = shift;
858              
859             # OPTIMIZE MATCH: a is first in the sort, so this is fairly well optimized,
860             # putting img up at the front doesn't seem to make a different in the speed
861 0               my $tags_grep = join('|', sort keys %LinkTags);
862 0               my $new_content = ''; # we are going to rebuild this content
863 0               my $content_ref = $self->{out};
864 0               my $asp = $self->{asp};
865 0 0             $asp->{dbg} && $asp->Debug("parsing session id into url query strings");
866              
867             # update quoted links in script location.href settings too
868             # if not quoted, then maybe script expressions
869                 $$content_ref =~
870 0                 s/(\<script.*?\>[^\<]*location\.href\s*\=[\"\'])([^\"\']+?)([\"\'])
  0            
871             /$1.&SessionQueryParseURL($self, $2).$3
872             /isgex;
873                 
874 0               while(1) {
875             # my emacs perl mode doesn't like ${$doc->{content}}
876 0 0         last unless ($$content_ref =~ s/
877             ^(.*?) # html head
878             \< # start
879             \s*($tags_grep)\s+ # tag itself
880             ([^>]+) # descriptors
881             \> # end
882             //isxo
883             );
884            
885 0           my($head, $tag, $temp_attribs) = ($1, lc($2), $3);
886 0           my $element = "<$2 $temp_attribs>";
887 0           my %attribs;
888            
889 0           while($temp_attribs =~ s/^\s*([^\s=]+)\s*\=?//so) {
890 0           my $key = lc $1;
891 0           my $value;
892 0 0         if($temp_attribs =~ s/^\s*\"([^\"]*)\"\s*//so) {
    0          
    0          
893 0           $value = $1;
894             } elsif ($temp_attribs =~ s/^\s*\'([^\']*)\'\s*//so) {
895             # apparently browsers support single quoting values
896 0           $value = $1;
897             } elsif($temp_attribs =~ s/^\s*([^\s]*)\s*//so) {
898             # sometimes there are mal-formed URL's
899 0           $value = $1;
900 0           $value =~ s/\"//sgo;
901             }
902 0           $attribs{$key} = $value;
903             }
904            
905             # GET URL from tag attribs finally
906 0           my $rel_url = $attribs{$LinkTags{$tag}};
907             # $asp->Debug($rel_url, $element, \%attribs);
908 0 0         if(defined $rel_url) {
909 0           my $new_url = &SessionQueryParseURL($self, $rel_url);
910             # escape all special characters so they are not interpreted
911 0 0         if($new_url ne $rel_url) {
912 0           $rel_url =~ s/([\W])/\\$1/sg;
913 0           $element =~ s|($LinkTags{$tag}\s*\=\s*[\"\']?)$rel_url|$1$new_url|isg;
914             # $asp->Debug("parsed new element $element");
915             }
916             }
917            
918 0           $new_content .= $head . $element;
919                 }
920                 
921             # $asp->Debug($$content_ref);
922 0               $new_content .= $$content_ref;
923 0               $$content_ref = $new_content;
924 0               1;
925             }
926              
927             sub SessionQueryParseURL {
928 0     0 0       my($self, $rel_url) = @_;
929 0               my $asp = $self->{asp};
930 0               my $match = $asp->{session_url_parse_match};
931              
932 0 0 0           if(
      0        
      0        
      0        
933             # if we have match expression, try it
934                    ($match && $rel_url =~ /$match/)
935             # then if server path, check matches cookie space
936                    || ($rel_url =~ m|^/| and $rel_url =~ m|^$asp->{cookie_path}|)
937             # then do all local paths, matching NOT some URI PROTO
938                    || ($rel_url !~ m|^[^\?\/]+?:|)
939                   )
940                   {
941 0           my($query, $new_url, $frag);
942 0 0         if($rel_url =~ /^([^\?]+)(\?([^\#]*))?(\#.*)?$/) {
943 0                         $new_url = $1;
944 0 0                       $query = defined $3 ? $3 : '';
945 0           $frag = $4;
946             } else {
947 0           $new_url = $rel_url;
948 0           $query = '';
949             }
950              
951             # for the split, we do not need to handle other entity references besides &amp;
952             # because &, =, and ; should be the only special characters in the query string
953             # and the only of these characters that are represented by an entity reference
954             # is & as &amp; ... the rest of the special characters that might be encoded
955             # in a URL should be URI escaped
956             # --jc 2/10/2003
957 0           my @new_query_parts;
958 0 0         map {
959 0           (! /^$Apache::ASP::SessionCookieName\=/) && push(@new_query_parts, $_);
960             }
961             split(/&amp;|&/, $query);
962              
963 0           my $new_query = join('&amp;',
964             @new_query_parts,
965             $Apache::ASP::SessionCookieName.'='.$asp->{session_id}
966             );
967 0           $new_url .= '?'.$new_query;
968 0 0         if($frag) {
969 0           $new_url .= $frag;
970             }
971 0 0         $asp->{dbg} && $asp->Debug("parsed session into $new_url");
972 0           $new_url;
973                   } else {
974 0           $rel_url;
975                   }
976             }
977              
978             *config = *Apache::ASP::config;
979              
980             1;
981