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 / Server.pm < prev    next >
Encoding:
Perl POD Document  |  2003-02-10  |  4.0 KB  |  177 lines
  1.  
  2. package Apache::ASP::Server;
  3. use strict;
  4. use vars qw($OLESupport);
  5.  
  6. sub new {
  7.     bless {asp => $_[0]};
  8. }
  9.  
  10. sub CreateObject {
  11.     my($self, $name) = @_;
  12.     my $asp = $self->{asp};
  13.  
  14.     # dynamically load OLE at request time, especially since
  15.     # at server startup, this seems to fail with "start_mutex" error
  16.     #
  17.     # no reason to preload this unix style when module loads
  18.     # because in win32, threaded model does not need this prefork 
  19.     # parent httpd compilation
  20.     #
  21.     unless(defined $OLESupport) {
  22.     eval 'use Win32::OLE';
  23.     if($@) {
  24.         $OLESupport = 0;
  25.     } else {
  26.         $OLESupport = 1;
  27.     }
  28.     }
  29.  
  30.     unless($OLESupport) {
  31.     die "OLE-active objects not supported for this platform, ".
  32.         "try installing Win32::OLE";
  33.     }
  34.  
  35.     unless($name) {
  36.     die "no object to create";
  37.     }
  38.  
  39.     Win32::OLE->new($name);
  40. }
  41.  
  42. sub Execute {
  43.     my $self = shift;
  44.     $self->{asp}{Response}->Include(@_);
  45. }
  46.  
  47. sub File {
  48.     shift->{asp}{filename};
  49. }
  50.  
  51. sub Transfer {
  52.     my $self = shift;
  53.     $self->{asp}{Response}->Include(@_);
  54.     $self->{asp}{Response}->End;
  55. }
  56.  
  57. # shamelessly ripped off from CGI.pm, by Lincoln D. Stein.
  58. sub URLEncode {
  59.     my $toencode = $_[1];
  60.     $toencode =~ s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/esg;
  61.     $toencode;
  62. }
  63.  
  64. sub HTMLDecode {
  65.     my($self, $decode) = @_;
  66.     
  67.     $decode=~s/>/>/sg;
  68.     $decode=~s/</</sg;
  69.     $decode=~s/'/'/sg;
  70.     $decode=~s/"/\"/sg;
  71.     $decode=~s/&/\&/sg;
  72.     
  73.     $decode;
  74. }
  75.  
  76. sub HTMLEncode {
  77.     my($self, $toencode) = @_;
  78.     return '' unless defined $toencode;
  79.  
  80.     my $data_ref;
  81.     if(ref $toencode) {
  82.     $data_ref = $toencode;
  83.     } else {
  84.     $data_ref = \$toencode;
  85.     }
  86.  
  87.     $$data_ref =~ s/&/&/sg;
  88.     $$data_ref =~ s/\"/"/sg;
  89.     $$data_ref =~ s/\'/'/sg;
  90.     $$data_ref =~ s/>/>/sg;
  91.     $$data_ref =~ s/</</sg;
  92.  
  93.     ref($toencode) ? $data_ref : $$data_ref;
  94. }
  95.  
  96. sub RegisterCleanup {
  97.     my($self, $code) = @_;
  98.     if(ref($code) =~ /^CODE/) {
  99.     $self->{asp}{dbg} && $self->{asp}->Debug("RegisterCleanup() called", caller());
  100.     push(@{$self->{asp}{cleanup}}, $code);
  101.     } else {
  102.     $self->{asp}->Error("$code need to be a perl sub reference, see README");
  103.     }
  104. }
  105.  
  106. sub MapInclude {
  107.     my($self, $file) = @_;
  108.     $self->{asp}->SearchDirs($file);
  109. }
  110.  
  111. sub MapPath {
  112.     my($self, $path) = @_;
  113.     my $subr = $self->{asp}{r}->lookup_uri($path);
  114.     $subr ? $subr->filename : undef;
  115. }
  116.  
  117. *SendMail = *Mail;
  118. sub Mail {
  119.     shift->{asp}->SendMail(@_);
  120. }
  121.  
  122. sub URL {
  123.     my($self, $url, $params) = @_;
  124.     
  125.     if($url =~ s/\?(.*)$//is) {
  126.         my $old_params = $self->{asp}{Request}->ParseParams($1);
  127.         $params = { %$old_params, %$params };
  128.     }
  129.  
  130.     my $asp = $self->{asp};
  131.     if($asp->{session_url} && $asp->{session_id} && ! $asp->{session_cookie}) {
  132.     my $match = $asp->{session_url_match};
  133.     if(
  134.        # if we have match expression, try it
  135.        ($match && $url =~ /$match/)
  136.        # then if server path, check matches cookie space 
  137.        || ($url =~ m|^/| and $url =~ m|^$asp->{cookie_path}|)
  138.        # then do all local paths, matching NOT some URI PROTO
  139.        || ($url !~ m|^[^\?\/]+?:|)
  140.       ) 
  141.       {
  142.           # this should overwrite an incorrectly passed in data
  143.           $params->{$Apache::ASP::SessionCookieName} = $asp->{session_id};
  144.       }
  145.     }
  146.  
  147.     my($k,$v, @query);
  148.  
  149.     # changed to use sort so this function outputs the same URL every time
  150.     for my $k ( sort keys %$params ) {
  151.     my $v = $params->{$k};
  152.     # inline the URLEncode function for speed
  153.     $k =~ s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/egs;
  154.     my @values = (ref($v) and ref($v) eq 'ARRAY') ? @$v : ($v);
  155.     for my $value ( @values ) {
  156.         $value =~ s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/egs;
  157.         push(@query, $k.'='.$value);
  158.     }
  159.     }
  160.     if(@query) {
  161.     $url .= '?'.join('&', @query);
  162.     }
  163.  
  164.     $url;
  165. }
  166.  
  167. sub XSLT {
  168.     my($self, $xsl_data, $xml_data) = @_;
  169.     $self->{asp}->XSLT($xsl_data, $xml_data);
  170. }
  171.  
  172. sub Config {
  173.     shift->{asp}->config(@_);
  174. }
  175.  
  176. 1;
  177.