File Coverage

blib/lib/Apache/ASP/Server.pm
Criterion Covered Total %
statement 28 95 29.5
branch 3 36 8.3
condition 0 25 0.0
subroutine 6 17 35.3
pod 0 15 0.0
total 37 188 19.7


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