home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / Response.pm < prev    next >
Encoding:
Perl POD Document  |  2003-05-07  |  29.6 KB  |  975 lines
  1.  
  2. package Apache::ASP::Response;
  3.  
  4. use Apache::ASP::Collection;
  5.  
  6. use strict;
  7. no strict qw(refs);
  8. use vars qw(@ISA @Members %LinkTags $TextHTMLRegexp);
  9. @ISA = qw(Apache::ASP::Collection);
  10. use Carp qw(confess);
  11. use Data::Dumper qw(DumperX);
  12.  
  13. @Members = qw( Buffer Clean ContentType Expires ExpiresAbsolute Status );
  14.  
  15. # used for session id auto parsing
  16. %LinkTags = (
  17.          'a' => 'href',
  18.          'area' => 'href',
  19.          'form' => 'action',
  20.          'frame' => 'src',
  21.          'iframe' => 'src',
  22.          'img' => 'src',
  23.          'input' => 'src',
  24.          'link' => 'href',
  25.         );
  26.  
  27. $TextHTMLRegexp = '^text/html(;|$)';
  28.  
  29. sub new {
  30.     my $asp = shift;
  31.  
  32.     my $r = $asp->{'r'};
  33.     my $out = '';
  34.  
  35.     my $self = bless 
  36.       {
  37.        asp => $asp,
  38.        out => \$out,
  39.        # internal extension allowing various scripts like Session_OnStart
  40.        # to end the same response
  41.        #       Ended => 0, 
  42.        CacheControl => 'private',
  43.        CH => &config($asp, 'CgiHeaders') || 0,
  44.        #       Charset => undef,
  45.        Clean => &config($asp, 'Clean') || 0,
  46.        Cookies => bless({}, 'Apache::ASP::Collection'),
  47.        ContentType => 'text/html',
  48.        'Debug' => $asp->{dbg},
  49.        FormFill => &config($asp, 'FormFill'),
  50.        IsClientConnected => 1,
  51.        #       PICS => undef,
  52.        #       Status => 200,
  53.        #       header_buffer => '',
  54.        #       header_done => 0,
  55.        Buffer => &config($asp, 'BufferingOn', undef, 1),
  56.        BinaryRef => \$out,
  57.        CompressGzip => ($asp->{compressgzip} and ($asp->{headers_in}->get('Accept-Encoding') =~ /gzip/io)) ? 1 : 0,
  58.        r => $r,
  59.        headers_out => scalar($r->headers_out()),
  60.       };
  61.  
  62.     &IsClientConnected($self); # update now
  63.  
  64.     $self;
  65. }
  66.  
  67. sub DeprecatedMemberAccess {
  68.     my($self, $member, $value) = @_;
  69.     $self->{asp}->Out(
  70.               "\$Response->$member() deprecated.  Please access member ".
  71.               "directly with \$Response->{$member} notation"
  72.              );
  73.     $self->{$member} = $value;
  74. }
  75.  
  76. # defined the deprecated subs now, so we can loose the AUTOLOAD method
  77. # the AUTOLOAD was forcing us to keep the DESTROY around
  78. for my $member ( @Members ) {
  79.     my $subdef = "sub $member { shift->DeprecatedMemberAccess('$member', shift); }";
  80.     eval $subdef;
  81.     if($@) {
  82.     die("error defining Apache::ASP::Response sub -- $subdef -- $@");
  83.     }
  84. }
  85.  
  86. sub AddHeader { 
  87.     my($self, $name, $value) = @_;   
  88.  
  89.     my $lc_name = lc($name);
  90.  
  91.     if($lc_name eq 'set-cookie') {
  92.     $self->{r}->err_headers_out->add($name, $value);
  93.     } else {
  94.     # if we have a member API for this header, set that value instead 
  95.     # to avoid duplicate headers from being sent out
  96.     if($lc_name eq 'content-type') {
  97.         $self->{ContentType} = $value;
  98.     } elsif($lc_name eq 'cache-control') {
  99.         $self->{CacheControl} = $value;
  100.     } elsif($lc_name eq 'expires') {
  101.         $self->{ExpiresAbsolute} = $value;
  102.     } else {
  103.         $self->{headers_out}->set($name, $value);
  104.     }
  105.     }
  106. }   
  107.  
  108. sub AppendToLog { shift->{asp}->Log(@_); }
  109. sub Debug { 
  110.     my $self = shift;
  111.     $self->{Debug} && $self->{asp}->Out("[$self->{asp}{basename}]", @_);
  112. };
  113.  
  114. sub BinaryWrite {
  115.     $_[0]->Flush();
  116.     $_[0]->{asp}{dbg} && $_[0]->{asp}->Debug("binary write of ".length($_[1])." bytes");
  117.     &Write;
  118. }
  119.  
  120. sub Clear { my $out = shift->{out}; $$out = ''; }
  121.  
  122. sub Cookies {
  123.     my($self, $name, $key, $value) = @_;
  124.     if(defined($name) && defined($key) && defined($value)) {
  125.     $self->{Cookies}{$name}{$key} = $value;
  126.     } elsif(defined($name) && defined($key)) {
  127.     # we are assigning cookie with name the value of key
  128.     if(ref $key) {
  129.         # if a hash, set the values in it to the keys values
  130.         # we don't just assign the ref directly since for PerlScript 
  131.         # compatibility
  132.         while(my($k, $v) = each %{$key}) {
  133.         $self->{Cookies}{$name}{$k} = $v;
  134.         }
  135.     } else {
  136.         $self->{Cookies}{$name}{Value} = $key;        
  137.     }
  138.     } elsif(defined($name)) {
  139.     # if the cookie was just stored as the name value, then we will
  140.     # will convert it into its hash form now, so we can store other
  141.     # things.  We will probably be storing other things now, since
  142.     # we are referencing the cookie directly
  143.     my $cookie = $self->{Cookies}{$name} || {};
  144.     $cookie = ref($cookie) ? $cookie : { Value => $cookie };
  145.     $self->{Cookies}{$name} = bless $cookie, 'Apache::ASP::Collection';    
  146.     } else {
  147.     $self->{Cookies};
  148.     }
  149. }
  150.  
  151. sub End {
  152.     my $self = shift;
  153.     # by not calling EndSoft(), but letting it be called naturally after
  154.     # Execute() in hander(), we allow more natural Buffer flushing to occur
  155.     # even if we are in a situation where Flush() has been made null like
  156.     # in an XMLSubs or cached or trapped include
  157. #    &EndSoft($self);
  158.     eval { goto APACHE_ASP_EXECUTE_END; };
  159. }
  160.  
  161. sub EndSoft {
  162.     my $self = shift;
  163.     return if $self->{Ended}++;
  164.     &Flush($self);
  165. }
  166.  
  167. sub Flush {
  168.     my $self = shift;
  169.     my $asp = $self->{asp};
  170.     my $out = $self->{out};
  171.     local $| = 1;
  172.  
  173.     # Script_OnFlush event handler
  174.     $asp->{GlobalASA}{'exists'} &&
  175.       $asp->{GlobalASA}->ScriptOnFlush();
  176.  
  177.     # XSLT Processing, check for errors so PrettyError() can call Flush()
  178.     if($asp->{xslt} && ! $asp->{errs}) {
  179.     $asp->{dbg} && $asp->Debug("pre xslt $out length: ".length($$out));
  180.     $self->FlushXSLT;
  181.     $asp->{dbg} && $asp->Debug("post xslt $out length: ".length($$out));
  182.     return if $asp->{errs};
  183.     }
  184.  
  185.     # FormFill
  186.     if ($self->{FormFill} && ! $asp->{errs}) {
  187.     $self->FormFill;
  188.     return if $asp->{errs};
  189.     }
  190.  
  191.     if($self->{Clean} and $self->{ContentType} =~ /$TextHTMLRegexp/o) {
  192.     # by checking defined, we just check once
  193.     unless(defined $Apache::ASP::CleanSupport) {
  194.         eval 'use HTML::Clean';
  195.         if($@) {
  196.         $self->{asp}->Log("Error loading module HTML::Clean with Clean set to $self->{Clean}. ".
  197.                   "Make user you have HTML::Clean installed properly. Error: $@");
  198.         $Apache::ASP::CleanSupport = 0;
  199.         } else {
  200.         $Apache::ASP::CleanSupport = 1;
  201.         }
  202.     }
  203.  
  204.     # if we can't clean, we simply ignore    
  205.     if($Apache::ASP::CleanSupport) {
  206.         my $h = HTML::Clean->new($out, $self->{Clean});
  207.         if($h) {
  208.         $h->strip();
  209.         } else {
  210.         $self->{asp}->Error("clean error: $! $@");
  211.         }
  212.     }
  213.     }
  214.  
  215.     ## Session query auto parsing for cookieless sessions
  216.     if(
  217.        $asp->{Session} 
  218.        and ! $asp->{session_cookie} 
  219.        and $asp->{session_url_parse} 
  220.        and ($self->{ContentType} =~ /^text/i)
  221.       ) 
  222.       {
  223.       $self->SessionQueryParse();
  224.       }
  225.  
  226.     if($self->{Ended}) {
  227.     # log total request time just once at the end
  228.     # and append to html like Cocoon, per user request
  229.     my $total_time = sprintf('%7.5f', ( eval { &Time::HiRes::time() } || time() ) - $asp->{start_time});
  230.     $asp->{dbg} && $asp->Debug("page executed in $total_time seconds");
  231.     $asp->{total_time} = $total_time;
  232.  
  233.     if(&config($asp, 'TimeHiRes')) {
  234.         if($self->{ContentType} =~ /$TextHTMLRegexp/o) {
  235.         if(&config($asp, 'Debug')) {
  236.             $$out .= "\n<!-- Apache::ASP v".$Apache::ASP::VERSION." served page in $total_time seconds -->";
  237.         }
  238.         }
  239.     }
  240.     }
  241.  
  242.     # HEADERS AFTER CLEAN, so content-length would be calculated correctly
  243.     # if this is the first writing from the page, flush a newline, to 
  244.     # get the headers out properly
  245.     if(! $self->{header_done}) {
  246.     # if no headers and the script has ended, we know that the 
  247.     # the script has not been flushed yet, which would at least
  248.     # occur with buffering on
  249.     if($self->{Ended}) {
  250.         # compression & content-length settings will kill filters
  251.         # after Apache::ASP
  252.         if(! $asp->{filter}) {
  253.         # gzip the buffer if CompressGzip && browser accepts it &&
  254.         # the script is flushed once
  255.         if($self->{CompressGzip} && $asp->LoadModule('Gzip','Compress::Zlib')) {
  256.             $self->{headers_out}->set('Content-Encoding','gzip');
  257.             $$out = Compress::Zlib::memGzip($out);
  258.         }
  259.  
  260.         $self->{headers_out}->set('Content-Length', length($$out));
  261.         }
  262.     }
  263.     
  264.     &SendHeaders($self);
  265.     }
  266.  
  267.     if($asp->{filter}) {
  268.     print STDOUT $$out;
  269.     } else {
  270.     # just in case IsClientConnected is set incorrectly, still try to print
  271.     # the worst thing is some extra error messages in the error_log ...
  272.     # there have been spurious error reported with the IsClientConnected
  273.     # code since it was introduced, and this will limit the errors ( if any are left )
  274.     # to the users explicitly using this functionality, --jc 11/29/2001
  275.     #
  276. #    if($self->{IsClientConnected}) {
  277.         if(! defined $self->{Status} or ($self->{Status} >= 200 and $self->{Status} < 400)) {
  278.         $self->{r}->print($$out);
  279.         }
  280. #    }
  281.     }
  282.  
  283.     # update after flushes only, expensive call
  284.     $self->{Ended} || &IsClientConnected($self);
  285.  
  286.     # supposedly this is more efficient than undeffing, since
  287.     # the string does not let go of its allocated memory buffer
  288.     $$out = ''; 
  289.  
  290.     1;
  291. }
  292.  
  293. sub FormFill {
  294.     my $self = shift;
  295.     my $asp = $self->{asp};
  296.  
  297.     $asp->{dbg} && $asp->Debug("form fill begin");
  298.     $asp->LoadModule('FormFill', 'HTML::FillInForm') || return;
  299.     my $ref = $self->{BinaryRef};
  300.  
  301.     $$ref =~ s/(\<form[^\>]*\>.*?\<\/form\>)/
  302.          {
  303.          my $form = $1;
  304.          my $start_length = $asp->{dbg} ? length($form) : undef;
  305.          eval {
  306.              my $fif = HTML::FillInForm->new();
  307.              $form = $fif->fill(
  308.                     scalarref => \$form,
  309.                     fdat =>    $asp->{Request}{Form},
  310.                     );
  311.          };
  312.          if($@) {
  313.              $asp->CompileErrorThrow($form, "form fill failed: $@");
  314.          } else {
  315.              $asp->{dbg} && 
  316.              $asp->Debug("form fill for form of start length $start_length ".
  317.                      "end length ".length($form));
  318.          }
  319.          $form;
  320.          }        
  321.          /iexsg;
  322.  
  323.     1;
  324. }
  325.  
  326. sub FlushXSLT {
  327.     my $self = shift;
  328.     my $asp = $self->{asp};
  329.     my $xml_out = $self->{BinaryRef};
  330.     return unless length($$xml_out); # could happen after a redirect
  331.  
  332.     $asp->{xslt_match} = &config($asp, 'XSLTMatch') || '^.';
  333.     return unless ($asp->{filename} =~ /$asp->{xslt_match}/);
  334.  
  335.     ## XSLT FETCH & CACHE
  336.     $asp->{dbg} && $asp->Debug("xslt processing with $asp->{xslt}");
  337.     my $xsl_dataref = $self->TrapInclude($asp->{xslt});
  338.     $asp->{dbg} && $asp->Debug(length($$xsl_dataref)." bytes in XSL $xsl_dataref");
  339.     return if($asp->{errs});
  340.  
  341.     ## XSLT XML RENDER
  342.     eval {
  343.     my $xslt_data = $asp->XSLT($xsl_dataref, $xml_out);
  344.     $asp->{dbg} && $asp->Debug("xml_out $xml_out length ".length($$xml_out)." set to $xslt_data length ".
  345.                    length($$xslt_data));
  346.     ${$self->{BinaryRef}} = $$xslt_data;
  347.     };
  348.     if($@) {
  349.     $@ =~ s/^\s*//s;
  350.     $asp->Error("XSLT/XML processing error: $@");
  351.     return;
  352.     }
  353.  
  354.     1;
  355. }
  356.  
  357. sub IsClientConnected {
  358.     my $self = shift;
  359.     return(0) if ! $self->{IsClientConnected};
  360.  
  361.     # must init Request first for the aborted test to be meaningful.
  362.     # it seems that under mod_perl 1.25, apache 1.20 on a fast local network,
  363.     # if $r->connection->aborted is checked on a file upload before $Request 
  364.     # is initialized, then aborted will return true, even under normal use.  
  365.     # This causes a file upload script to not render any output.  It may be that this
  366.     # check was done too fast for apache, where it might have still been setting
  367.     # up the upload, so not to check the outbound client connection yet
  368.     # 
  369.     unless($self->{asp}{Request}) {
  370.     $self->{asp}->Out("need to init Request object before running Response->IsClientConnected");
  371.     return 1;
  372.     }
  373.  
  374.     # IsClientConnected ?  Might already be disconnected for busy site, if
  375.     # a user hits stop/reload
  376.     my $conn = $self->{r}->connection;
  377.     my $is_connected = $conn->aborted ? 0 : 1;
  378.  
  379.     if($is_connected) {
  380.     my $fileno = eval { $conn->fileno };
  381.     if(defined $fileno) {
  382.         #    sleep 3;
  383.         #        my $s = IO::Select->new($fileno);
  384.         #        $is_connected = $s->can_read(0) ? 0 : 1;
  385.  
  386.         # much faster than IO::Select interface() which calls
  387.         # a few perl OO methods to construct & then can_read()
  388.         my $bits = '';
  389.         vec($bits, $fileno, 1) = 1;
  390.         $is_connected = select($bits, undef, undef, 0) > 0 ? 0 : 1;
  391.         if(! $is_connected) {
  392.         $self->{asp}{dbg} && $self->{asp}->Debug("client is no longer connected, detected via Apache->request->connetion->fileno");
  393.         }
  394.     }
  395.     }
  396.  
  397.     $self->{IsClientConnected} = $is_connected;
  398.     if(! $is_connected) {
  399.     $self->{asp}{dbg} && $self->{asp}->Debug("client is no longer connected");
  400.     }
  401.  
  402.     $is_connected;
  403. }
  404.  
  405. # use the apache internal redirect?  Thought that would be counter
  406. # to portability, but is still something to consider
  407. sub Redirect {
  408.     my($self, $location) = @_;
  409.     my $asp = $self->{asp};
  410.     my $r = $self->{r};
  411.  
  412.     $asp->{dbg} && $asp->Debug('redirect called', {location=>$location});
  413.     if($asp->{Session} and $asp->{session_url_parse}) {
  414.     $location = &SessionQueryParseURL($self, $location);
  415.     $asp->{dbg} && $asp->Debug("new location after session query parsing $location");
  416.     }
  417.        
  418.     $r->headers_out->set('Location', $location);
  419.     $self->{Status} = 302;
  420.     $r->status(302);
  421.  
  422.     # Always SendHeaders() immediately for a Redirect() ... only in a SoftRedirect
  423.     # will execution continue.  Since we call SendHeaders here, instead of 
  424.     # Flush() a Redirect() will still work even in a XMLSubs call where Flush is
  425.     # trapped to Null()
  426.     &SendHeaders($self);
  427.  
  428.     # if we have soft redirects, keep processing page after redirect
  429.     if(&config($asp, 'SoftRedirect')) {
  430.     $asp->Debug("redirect is soft, headers already sent");
  431.     } else {
  432.     # do we called End() or EndSoft() here?  As of v 2.33, End() will
  433.     # just jump to the end of Execute(), so if we were in a XMLSubs
  434.     # and called End() after doing a Clear() there would still be 
  435.     # output the gets flushed out from before the XMLSubs, to prevent
  436.     # this we clear the buffer now, and called EndSoft() in this case.
  437.     # Finally we also call End() so we will jump out of the executing code.
  438.     #
  439.     &Clear($self);
  440.     $self->{Ended} = 1; # just marked Ended so future EndSoft() cannot be called
  441. #    &EndSoft($self);
  442.     &End($self);
  443.     }
  444.  
  445.     1;
  446. }
  447.  
  448. sub SendHeaders {
  449.     my $self = shift;
  450.     my $r = $self->{r};
  451.     my $asp = $self->{asp};
  452.     my $dbg = $asp->{dbg};
  453.     my $status = $self->{Status};
  454.  
  455.     return if $self->{header_done};
  456.     $self->{header_done} = 1;
  457.  
  458.     $dbg && $asp->Debug('building headers');
  459.     $r->status($status) if defined($status);
  460.  
  461.     # for command line script
  462.     return if &config($asp, 'NoHeaders');
  463.  
  464.     if(defined $status and $status == 401) {
  465.     $dbg && $asp->Debug("status 401, note basic auth failure realm ".$r->auth_name);
  466.  
  467.     # we can't send out headers, and let Apache use the 401 error doc
  468.     # But this is fine, once authorization is OK, then the headers
  469.     # will go out correctly, so things like sessions will work fine.
  470.     $r->note_basic_auth_failure;
  471.     return;
  472.     } else {
  473.     $dbg && defined $status && $self->{asp}->Debug("status $status");
  474.     }
  475.  
  476.     if(defined $self->{Charset}) {
  477.     $r->content_type($self->{ContentType}.'; charset='.$self->{Charset});
  478.     } else {
  479.     $r->content_type($self->{ContentType}); # add content-type
  480.     }
  481.  
  482.     if(%{$self->{'Cookies'}}) {
  483.     &AddCookieHeaders($self);     # do cookies
  484.     }
  485.  
  486.     # do the expiration time
  487.     if(defined $self->{Expires}) {
  488.     my $ttl = $self->{Expires};
  489.     $r->headers_out->set('Expires', &Apache::ASP::Date::time2str(time()+$ttl));
  490.     $dbg && $self->{asp}->Debug("expires in $self->{Expires}");
  491.     } elsif(defined $self->{ExpiresAbsolute}) {
  492.     my $date = $self->{ExpiresAbsolute};
  493.     my $time = &Apache::ASP::Date::str2time($date);
  494.     if(defined $time) {
  495.         $r->headers_out->set('Expires', &Apache::ASP::Date::time2str($time));
  496.     } else {
  497.         confess("Response->ExpiresAbsolute(): date format $date not accepted");
  498.     }
  499.     }
  500.  
  501.     # do the Cache-Control header
  502.     $r->headers_out->set('Cache-Control', $self->{CacheControl});
  503.     
  504.     # do PICS header
  505.     defined($self->{PICS}) && $r->headers_out->set('PICS-Label', $self->{PICS});
  506.     
  507.     # don't send headers with filtering, since filter will do this for
  508.     # all the modules once
  509.     # doug sanctioned this one
  510.     unless($r->headers_out->get("Content-type")) {
  511.     # if filtering, we don't send out a header from ASP
  512.     # this means that Filtered scripts can use CGI headers
  513.     # we order the test this way in case Ken comes on
  514.     # board with setting header_out, in which case the test 
  515.     # will fail early       
  516.     if(! $asp->{filter} && (! defined $status or $status >= 200 && $status < 400)) {
  517.         $dbg && $asp->Debug("sending cgi headers");
  518.         if(defined $self->{header_buffer}) {
  519.         # we have taken in cgi headers
  520.         $r->send_cgi_header($self->{header_buffer} . "\n");
  521.         $self->{header_buffer} = undef;
  522.         } else {
  523.         unless($Apache::ASP::ModPerl2) {
  524.             # don't need this for mod_perl2 it seems from Apache::compat
  525.             $r->send_http_header();
  526.         }
  527.         }
  528.     }
  529.     }
  530.  
  531.     1;
  532. }
  533.  
  534. # do cookies, try our best to emulate cookie collections
  535. sub AddCookieHeaders {
  536.     my $self = shift;
  537.     my $cookies = $self->{'Cookies'};
  538.     my $dbg = $self->{asp}{dbg};
  539.  
  540. #    print STDERR Data::Dumper::DumperX($cookies);
  541.  
  542.     my($cookie_name, $cookie);
  543.     for $cookie_name (sort keys %{$cookies}) {
  544.     # skip key used for session id
  545.     if($Apache::ASP::SessionCookieName eq $cookie_name) {
  546.         confess("You can't use $cookie_name for a cookie name ".
  547.             "since it is reserved for session management"
  548.             );
  549.     }
  550.     
  551.     my($k, $v, @data, $header, %dict, $is_ref, $cookie, $old_k);
  552.     
  553.     $cookie = $cookies->{$cookie_name};
  554.     unless(ref $cookie) {
  555.         $cookie->{Value} = $cookie;
  556.     } 
  557.     $cookie->{Path} ||= '/';
  558.     
  559.     for $k (sort keys %$cookie) {
  560.         $v = $cookie->{$k};
  561.         $old_k = $k;
  562.         $k = lc $k;
  563.         
  564. #        print STDERR "$k ---> $v\n\n";
  565.  
  566.         if($k eq 'secure' and $v) {
  567.         $data[4] = 'secure';
  568.         } elsif($k eq 'domain') {
  569.         $data[3] = "$k=$v";
  570.         } elsif($k eq 'value') {
  571.         # we set the value later, nothing for now
  572.         } elsif($k eq 'expires') {
  573.         my $time;
  574.         # only the date form of expires is portable, the 
  575.         # time vals are nice features of this implementation
  576.         if($v =~ /^\-?\d+$/) { 
  577.             # if expires is a perl time val
  578.             if($v > time()) { 
  579.             # if greater than time now, it is absolute
  580.             $time = $v;
  581.             } else {
  582.             # small, relative time, add to time now
  583.             $time = $v + time();
  584.             }
  585.         } else {
  586.             # it is a string format, PORTABLE use
  587.             $time = &Apache::ASP::Date::str2time($v);
  588.         }
  589.         
  590.         my $date = &Apache::ASP::Date::time2str($time);
  591.         $dbg && $self->{asp}->Debug("setting cookie expires", 
  592.                         {from => $v, to=> $date}
  593.                        );
  594.         $v = $date;
  595.         $data[1] = "$k=$v";
  596.         } elsif($k eq 'path') {
  597.         $data[2] = "$k=$v";
  598.         } else {
  599.         if(defined($cookie->{Value}) && ! (ref $cookie->{Value})) {
  600.             # if the cookie value is just a string, its not a dict
  601.         } else {
  602.             # cookie value is a dict, add to it
  603.             $cookie->{Value}{$old_k} = $v;
  604.         }            
  605.         } 
  606.     }
  607.     
  608.     my $server = $self->{asp}{Server}; # for the URLEncode routine
  609.     if(defined($cookie->{Value}) && (! ref $cookie->{Value})) {
  610.         $cookie->{Value} = $server->URLEncode($cookie->{Value});
  611.     } else {
  612.         my @dict;
  613.         for my $k ( sort keys %{$cookie->{Value}} ) {
  614.         my $v = $cookie->{Value}{$k};
  615.         push(@dict, $server->URLEncode($k) . '=' . $server->URLEncode($v));
  616.         }
  617.         $cookie->{Value} = join('&', @dict);
  618.     }
  619.     $data[0] = $server->URLEncode($cookie_name) . "=$cookie->{Value}";
  620.     
  621.     # have to clean the data now of undefined values, but
  622.     # keeping the position is important to stick to the Cookie-Spec
  623.     my @cookie;
  624.     for(0..4) {    
  625.         next unless $data[$_];
  626.         push(@cookie, $data[$_]);
  627.     }        
  628.     my $cookie_header = join('; ', @cookie);
  629.  
  630.     $self->{r}->err_headers_out->add('Set-Cookie', $cookie_header);
  631.     $dbg && $self->{asp}->Debug({cookie_header=>$cookie_header});
  632.     }
  633. }
  634.  
  635. # with the WriteRef vs. Write abstration, direct calls 
  636. # to write might slow a little, but more common static 
  637. # html calls to WriteRef will be saved the HTML copy
  638. sub Write {
  639.     my $self = shift;
  640.     
  641.     my $dataref;
  642.     if(@_ > 1) {
  643.     $, ||= ''; # non-standard use, so init here
  644.     my $data = join($,, @_);
  645.     $dataref = \$data;
  646.     } else {
  647. #    $_[0] ||= '';
  648.     $dataref = defined($_[0]) ? \$_[0] : \'';
  649.     }
  650.  
  651.     &WriteRef($self, $dataref);
  652.  
  653.     1;
  654. }
  655.  
  656. # \'';
  657.  
  658. *Apache::ASP::WriteRef = *WriteRef;
  659. sub WriteRef {
  660.     my($self, $dataref) = @_;
  661.  
  662.     # allows us to end a response, but still execute code in event
  663.     # handlers which might have output like Script_OnStart / Script_OnEnd
  664.     return if $self->{Ended};
  665. #    my $content_out = $self->{out};
  666.  
  667.     if($self->{CH}) {
  668.     # CgiHeaders may change the reference to the dataref, because
  669.     # dataref is a read-only scalar ref of static data, and CgiHeaders
  670.     # may need to change it
  671.     $dataref = $self->CgiHeaders($dataref);
  672.     }
  673.  
  674.     # add dataref to buffer
  675.     ${$self->{out}} .= $$dataref;
  676.     
  677.     # do we flush now?  not if we are buffering
  678.     if(! $self->{'Buffer'} && ! $self->{'FormFill'}) {
  679.     # we test for whether anything is in the buffer since
  680.     # this way we can keep reading headers before flushing
  681.     # them out
  682.     &Flush($self);
  683.     }
  684.  
  685.     1;
  686. }
  687. *write = *Write;
  688.  
  689. # alias printing to the response object
  690. sub TIEHANDLE { $_[1]; }
  691. *PRINT = *Write;
  692. sub PRINTF {
  693.     my($self, $format, @list) = @_;   
  694.     my $output = sprintf($format, @list);
  695.     $self->WriteRef(\$output);
  696. }
  697.  
  698. sub CgiHeaders {
  699.     my($self, $dataref) = @_;
  700.     my $content_out = $self->{out};
  701.  
  702.     # work on the headers while the header hasn't been done
  703.     # and while we don't have anything in the buffer yet
  704.     #
  705.     # also added a test for the content type being text/html or
  706.     # 
  707.     if($self->{CH} && ! $self->{header_done} && ! $$content_out 
  708.        && ($self->{ContentType} =~ /$TextHTMLRegexp/o)) 
  709.       {
  710.       # -1 to catch the null at the end maybe
  711.       my @headers = split(/\n/, $$dataref, -1); 
  712.       
  713.       # first do status line
  714.       my $status = $headers[0];
  715.       if($status =~ m|HTTP/\d\.\d\s*(\d*)|o) {
  716.           $self->{Status} = $1; 
  717.           shift @headers;
  718.       }
  719.       
  720.       while(@headers) {
  721.           my $out = shift @headers;
  722.           next unless $out; # skip the blank that comes after the last newline
  723.           
  724.           if($out =~ /^[^\s]+\: /) { # we are a header
  725.           unless(defined $self->{header_buffer}) {
  726.               $self->{header_buffer} .= '';
  727.           }
  728.           $self->{header_buffer} .= "$out\n";
  729.           } else {
  730.           unshift(@headers, $out);
  731.           last;
  732.           }
  733.       }
  734.       
  735.       # take remaining non-headers & set the data to them joined back up
  736.       my $data_left = join("\n", @headers);
  737.       $dataref = \$data_left;
  738.       }
  739.  
  740.     $dataref;
  741. }
  742.  
  743. sub Null {};
  744. sub TrapInclude {
  745.     my($self, $file) = (shift, shift);
  746.     
  747.     my $out = "";
  748.     local $self->{out} = local $self->{BinaryRef} = \$out;
  749.     local $self->{Ended} = 0;
  750.     local *Apache::ASP::Response::Flush = *Null;
  751.     $self->Include($file, @_);
  752.  
  753.     \$out;
  754. }
  755.  
  756. sub Include {    
  757.     my $self = shift;
  758.     my $file = shift;
  759.     my $asp = $self->{asp};
  760.  
  761.     my($cache, $cache_key, $cache_expires, $cache_clear);
  762.     if(ref($file) && ref($file) eq 'HASH') {
  763.     my $data = $file;
  764.     $file = $data->{File} 
  765.       || $asp->Error("no File key passed to Include(), keys ".join(',', keys %$file));
  766.     $asp->{dbg} && $asp->Debug("file $file from HASH ref in Include()");
  767.     
  768.     if($data->{Cache}) {
  769.         $cache = 1;
  770.         $cache_expires = $data->{'Expires'};
  771.         $cache_clear = $data->{'Clear'};
  772.         my $file_data = '';
  773.         if(ref($file)) {
  774.         $file_data = 'INCLUDE SCALAR REF '.$$file;
  775.         } else {
  776.         my $real_file = $asp->SearchDirs($file);
  777.         $file_data = 'INCLUDE FILE '.(stat($real_file))[9].' //\\ :: '.$real_file.' //\\ :: '.$file;
  778.         }
  779.         if($data->{Key}) {
  780.         $cache_key = $file_data .' //\\ :: '.DumperX($data->{Key});
  781.         $asp->{dbg} && $asp->Debug("include cache key length ".length($cache_key)." with extra Key data");
  782.         } else {
  783.         $asp->{dbg} && $asp->Debug("include cache key length ".length($file_data));
  784.         $cache_key = $file_data;
  785.         }
  786.         $cache_key .= ' //\\ COMPILE CHECKSUM :: '.$asp->{compile_checksum};
  787.         $cache_key .= ' //\\ ARGS :: '.DumperX(@_);
  788.         if(! $cache_clear) {
  789.         my $rv = $asp->Cache('Response', \$cache_key, undef, $data->{Expires}, $data->{LastModified});
  790.         if($rv) {
  791.             if(! eval { ($rv->{RV} && $rv->{OUT}) }) {
  792.             $asp->{dbg} && $self->Debug("cache item invalid: $@");
  793.             } else {
  794.             $asp->{dbg} && $asp->Debug("found include $file output in cache");
  795.             $self->WriteRef($rv->{OUT});
  796.             my $rv_data = $rv->{RV};
  797.             return wantarray ? @$rv_data : $rv_data->[0];
  798.             }
  799.         }
  800.         }
  801.     }
  802.     }
  803.  
  804.     my $_CODE = $asp->CompileInclude($file);
  805.     unless(defined $_CODE) {
  806.     die("error including $file, not compiled: $@");
  807.     }
  808.  
  809.     $asp->{last_compile_include_data} = $_CODE;
  810.     my $eval = $_CODE->{code};
  811.  
  812.     # exit early for cached static file
  813.     if(ref $eval eq 'SCALAR') {
  814.        $asp->{dbg} && $asp->Debug("static file data cached, not compiled, length: ".length($$eval));
  815.        $self->WriteRef($eval);
  816.        return;
  817.     }
  818.  
  819.     $asp->{dbg} && $asp->Debug("executing $eval");    
  820.  
  821.     my @rc;
  822.     if($cache) {
  823.     my $out = "";
  824.     {
  825.         local $self->{out} = local $self->{BinaryRef} = \$out;
  826.         local $self->{Ended} = 0;
  827.         local *Apache::ASP::Response::Flush = *Null;
  828.         @rc = eval { &$eval(@_) };
  829.         $asp->{dbg} && $asp->Debug("caching $file output expires: ".($cache_expires || ''));
  830.         $asp->Cache('Response', \$cache_key, { RV => [ @rc ], OUT => \$out }, $cache_expires);
  831.     }
  832.     $self->WriteRef(\$out);
  833.     } else {
  834.     @rc = eval { &$eval(@_) };
  835.     }
  836.     if($@) {
  837.     my $code = $_CODE;
  838.     die "error executing code for include $code->{file}: $@; compiled to $code->{perl}";
  839.     }
  840.     $asp->{dbg} && $asp->Debug("done executing include code $eval");
  841.  
  842.     wantarray ? @rc : $rc[0];
  843. }
  844.  
  845. sub ErrorDocument {
  846.     my($self, $error_code, $uri) = @_;
  847.     $self->{'r'}->custom_response($error_code, $uri); 
  848. }
  849.  
  850. sub SessionQueryParse {
  851.     my $self = shift;
  852.  
  853.     # OPTIMIZE MATCH: a is first in the sort, so this is fairly well optimized, 
  854.     # putting img up at the front doesn't seem to make a different in the speed
  855.     my $tags_grep = join('|', sort keys %LinkTags); 
  856.     my $new_content = ''; # we are going to rebuild this content
  857.     my $content_ref = $self->{out};
  858.     my $asp = $self->{asp};    
  859.     $asp->{dbg} && $asp->Debug("parsing session id into url query strings");
  860.  
  861.     # update quoted links in script location.href settings too
  862.     # if not quoted, then maybe script expressions
  863.     $$content_ref =~ 
  864.       s/(\<script.*?\>[^\<]*location\.href\s*\=[\"\'])([^\"\']+?)([\"\'])
  865.     /$1.&SessionQueryParseURL($self, $2).$3
  866.       /isgex;
  867.     
  868.     while(1) {
  869.     # my emacs perl mode doesn't like ${$doc->{content}}
  870.     last unless ($$content_ref =~ s/
  871.              ^(.*?)               # html head 
  872.              \<                   # start
  873.              \s*($tags_grep)\s+  # tag itself
  874.              ([^>]+)              # descriptors    
  875.              \>                   # end
  876.              //isxo
  877.              );
  878.     
  879.     my($head, $tag, $temp_attribs) = ($1, lc($2), $3);
  880.     my $element = "<$2 $temp_attribs>";    
  881.     my %attribs;
  882.     
  883.     while($temp_attribs =~ s/^\s*([^\s=]+)\s*\=?//so) {
  884.         my $key = lc $1;
  885.         my $value;
  886.         if($temp_attribs =~ s/^\s*\"([^\"]*)\"\s*//so) {
  887.         $value = $1;
  888.         } elsif ($temp_attribs =~ s/^\s*\'([^\']*)\'\s*//so) {
  889.         # apparently browsers support single quoting values
  890.         $value = $1;
  891.         } elsif($temp_attribs =~ s/^\s*([^\s]*)\s*//so) {
  892.         # sometimes there are mal-formed URL's
  893.         $value = $1;
  894.         $value =~ s/\"//sgo;
  895.         }
  896.         $attribs{$key} = $value;
  897.     }
  898.     
  899.     # GET URL from tag attribs finally
  900.     my $rel_url = $attribs{$LinkTags{$tag}};
  901. #    $asp->Debug($rel_url, $element, \%attribs);
  902.     if(defined $rel_url) {
  903.         my $new_url = &SessionQueryParseURL($self, $rel_url);
  904.         # escape all special characters so they are not interpreted
  905.         if($new_url ne $rel_url) {
  906.         $rel_url =~ s/([\W])/\\$1/sg;
  907.         $element =~ s|($LinkTags{$tag}\s*\=\s*[\"\']?)$rel_url|$1$new_url|isg;
  908. #        $asp->Debug("parsed new element $element");
  909.         }
  910.     }
  911.     
  912.     $new_content .= $head . $element;
  913.     }
  914.     
  915. #    $asp->Debug($$content_ref);
  916.     $new_content .= $$content_ref;
  917.     $$content_ref = $new_content;
  918.     1;
  919. }
  920.  
  921. sub SessionQueryParseURL {
  922.     my($self, $rel_url) = @_;
  923.     my $asp = $self->{asp};    
  924.     my $match = $asp->{session_url_parse_match};
  925.  
  926.     if(
  927.        # if we have match expression, try it
  928.        ($match && $rel_url =~ /$match/)
  929.        # then if server path, check matches cookie space 
  930.        || ($rel_url =~ m|^/| and $rel_url =~ m|^$asp->{cookie_path}|)
  931.        # then do all local paths, matching NOT some URI PROTO
  932.        || ($rel_url !~ m|^[^\?\/]+?:|)
  933.       )
  934.       {
  935.       my($query, $new_url, $frag);
  936.       if($rel_url =~ /^([^\?]+)(\?([^\#]*))?(\#.*)?$/) {
  937.               $new_url = $1;
  938.               $query = defined $3 ? $3 : '';
  939.           $frag = $4;
  940.       } else {
  941.           $new_url = $rel_url;
  942.           $query = '';
  943.       }
  944.  
  945.       # for the split, we do not need to handle other entity references besides &
  946.       # because &, =, and ; should be the only special characters in the query string
  947.       # and the only of these characters that are represented by an entity reference
  948.       # is & as & ... the rest of the special characters that might be encoded 
  949.       # in a URL should be URI escaped
  950.       # --jc 2/10/2003
  951.       my @new_query_parts;
  952.       map {
  953.           (! /^$Apache::ASP::SessionCookieName\=/) && push(@new_query_parts, $_);
  954.       }
  955.         split(/&|&/, $query);
  956.  
  957.       my $new_query = join('&', 
  958.                    @new_query_parts,
  959.                    $Apache::ASP::SessionCookieName.'='.$asp->{session_id}
  960.                   );
  961.       $new_url .= '?'.$new_query;
  962.       if($frag) {
  963.           $new_url .= $frag;
  964.       }
  965.       $asp->{dbg} && $asp->Debug("parsed session into $new_url");
  966.       $new_url;
  967.       } else {
  968.       $rel_url;
  969.       }
  970. }
  971.  
  972. *config = *Apache::ASP::config;
  973.  
  974. 1;
  975.