File Coverage

blib/lib/Apache/ASP.pm
Criterion Covered Total %
statement 705 1089 64.7
branch 274 568 48.2
condition 80 191 41.9
subroutine 80 100 80.0
pod 5 45 11.1
total 1144 1993 57.4


line stmt bran cond sub pod time code
1              
2             # For documentation for this module, please see the end of this file
3             # or try `perldoc Apache::ASP`
4              
5             package Apache::ASP;
6              
7             $VERSION = 2.59;
8              
9             #require DynaLoader;
10             #@ISA = qw(DynaLoader);
11             #bootstrap Apache::ASP $VERSION;
12              
13 15     15   246 use Digest::MD5 qw(md5_hex);
  15         211  
  15         299  
14 15     15   246 use Cwd qw(cwd);
  15         135  
  15         267  
15              
16             # create multiple entries for this symbols for StatINC
17 15     15   221 use Fcntl qw(:flock O_RDWR O_CREAT);
  15         190  
  15         328  
18              
19             # load these always, but only load ::State, ::Session, ::Application
20             # at runtime in non mod_perl environments since they may not be needed
21 15     15   789 use Apache::ASP::GlobalASA;
  15         167  
  15         409  
22 14     14   623 use Apache::ASP::Response;
  14         174  
  14         381  
23 14     14   785 use Apache::ASP::Request;
  14         227  
  14         464  
24 14     14   529 use Apache::ASP::Server;
  14         177  
  14         354  
25 14     14   503 use Apache::ASP::Date;
  14         161  
  14         418  
26 14     14   6107 use Apache::ASP::Lang::PerlScript;
  14         215  
  14         462  
27              
28 14     14   227 use Carp qw(confess cluck);
  14         150  
  14         246  
29              
30 14     14   2638 use strict;
  14         153  
  14         961  
31 14     14   220 no strict qw(refs);
  14         126  
  14         222  
32 14         229 use vars qw($VERSION
33             %NetConfig %LoadedModules %LoadModuleErrors
34             %Codes %includes %Includes %CompiledIncludes
35             @Objects %Register %XSLT
36             $ServerID $ServerPID $SrandPid
37             $CompileErrorSize $CacheSize @CompileChecksumKeys
38             %ScriptLanguages $ShareDir $INCDir $AbsoluteFileMatch
39             $QuickStartTime
40             $SessionCookieName
41             $LoadModPerl
42             $ModPerl2
43 14     14   210 );
  14         124  
44              
45             # other common modules load now, these are optional though, so we do not error upon failure
46             # just do this once perl mod_perl parent startup
47             unless($LoadModPerl++) {
48                 my @load_modules = qw( Config lib Time::HiRes );
49                 if($ENV{MOD_PERL}) {
50             # Only pre-load these if in a mod_perl environment for sharing memory post fork.
51             # These will not be loaded then for CGI until absolutely necessary at runtime
52             push(@load_modules, qw(
53             mod_perl
54             MLDBM::Serializer::Data::Dumper Devel::Symdump CGI
55             Apache::ASP::StateManager Apache::ASP::Session Apache::ASP::Application
56             Apache::ASP::StatINC Apache::ASP::Error
57             )
58             );
59                 }
60                 
61                 for my $module ( @load_modules ) {
62 14     14   220          eval "use $module ();";
  14     14   126  
  14     14   214  
  14         632  
  14         176  
  14         143  
  14         2543  
  14         138  
  14         134  
63                 }
64              
65                 if($ENV{MOD_PERL}) {
66             $ModPerl2 = ($mod_perl::VERSION >= 1.99);
67             if($ModPerl2) {
68             eval "use Apache::ASP::ApacheCommon ();";
69             die($@) if $@;
70             }
71                 }
72             }
73              
74             ## HEADER TOKEN TWEAK
75             # This must be called outside the above load module block, so that
76             # its gets run whenever this module is loaded
77             # This didn't work in 1.27 mod_perl, with DSO enabled, would
78             # put the Apache::ASP token in front.
79             # eval { &Apache::add_version_component("Apache::ASP/$VERSION"); };
80             # $Apache::Server::AddPerlVersion = 1;
81              
82             #use integer; # don't use screws up important numeric logic
83              
84             @Objects = ('Application', 'Session', 'Response', 'Server', 'Request');
85 4     4 0 59 map { eval "sub $_ { shift->{$_} }" } @Objects;
  0     0 0 0  
  0     0 0 0  
  0     0 0 0  
  2     2 0 37  
86              
87             # use regexp directly, not sub for speed
88             $AbsoluteFileMatch = '^(/|[a-zA-Z]:)';
89             $CacheSize = 1024*1024*10;
90             $SessionCookieName = 'session-id';
91              
92             # ServerID creates a unique identifier for the server
93             srand();
94             $ServerID = substr(md5_hex($$.rand().time().(-M('..')||'').(-M('/')||'')), 0, 16);
95             $ServerPID  = $$;
96              
97             # DEFAULT VALUES
98             $Apache::ASP::CompileErrorSize = 500;
99             @CompileChecksumKeys = qw ( Global DynamicIncludes UseStrict XMLSubsMatch XMLSubsPerlArgs XMLSubsStrict GlobalPackage UniquePackages IncludesDir InodeNames PodComments );
100              
101             %ScriptLanguages = (
102             'PerlScript' => 1,
103             );
104              
105             &InitPaths();
106              
107             %Apache::ASP::LoadModuleErrors =
108               (
109                'Filter' =>
110                "Apache::Filter was not loaded correctly for using SSI filtering. ".
111                "If you don't want to use filtering, make sure you turn the Filter ".
112                "config option off whereever it's being used",
113              
114                Clean => undef,
115                
116                CreateObject =>
117                'OLE-active objects not supported for this platform, '.
118                'try installing Win32::OLE',
119                
120                 Gzip =>
121                'Compress::Zlib is needed to make gzip content-encoding work, '.
122                'If you want to use this feature, get yourself the latest '.
123                'Compress::Zlib from CPAN. ',
124                
125                HiRes => undef,
126              
127                FormFill =>
128                'HTML::FillInForm is needed to use the FormFill feature '.
129                'for auto filling forms with $Response->Form() data',
130              
131                MailAlert => undef,
132                
133                SendMail => "No mailing support",
134                
135                StateDB =>
136                'cannot load StateDB '.
137                'must be a valid perl module with a db tied hash interface '.
138                'such as: SDBM_File (default), or DB_File',
139                
140                StateSerializer =>
141                'cannot load StateSerializer '.
142                'must be a valid serializing perl module for use with MLDBM '.
143                'such as Data::Dumper (default), or Storable',
144              
145                StatINC => "You need this module for StatINC, please download it from CPAN",
146                
147                'Cache' => "You need this module for xml output caching",
148              
149                XSLT => 'Cannot load XML::XSLT. Try installing the module.',
150              
151               );
152              
153              
154             sub handler {
155 16     16 0 230     my($package, $r) = @_;
156 16         842     my $status = 200;
157                 
158             # allows it to be called as an object method
159 16 100       215     ref $package and $r = $package;
160              
161             # default to Apache request object if not passed in, for possible DSO fix
162             # rarely happens, but just in case
163 16         135     my $filename;
164 16 50       154     unless($filename = eval { $r->filename }) {
  16         250  
165 0 0       0         my $rtest = $ModPerl2 ? Apache2::RequestUtil->request() : Apache->request();
166 0 0       0 if($filename = eval { $rtest->filename }) {
  0         0  
167 0         0 $r = $rtest;
168             } else {
169 0         0 return &DSOError($rtest);
170             }
171                 }
172              
173             # better error checking ?
174 16   33     187     $filename ||= $r->filename();
175             # using _ is optimized to use last stat() record
176 16 50 33     615     return(404) if (! -e $filename or -d _);
177              
178             # alias $0 to filename, bind to glob for bug workaround
179 16         192     local *0 = \$filename;
180              
181             # ASP object creation, a lot goes on in there!
182             # method call used for speed optimization, as OO calls are slow
183 16         301     my $self = &Apache::ASP::new('Apache::ASP', $r, $filename);
184              
185             # for runtime use/require library loads from global/INCDir
186             # do this in the handler section to cover all the execution stages
187             # following object set up as possible.
188 16         386     local @INC = ($self->{global}, $INCDir, @INC);
189              
190             # Execute if no errors
191 16 50       289     $self->{errs} || &Run($self);
192                 
193             # moved print of object to the end, so we'll pick up all the
194             # runtime config directives set while the code is running
195              
196 16 100       248     $self->{dbg} && $self->Debug("ASP Done Processing $self", $self );
197              
198             # error processing
199 16 50       324     if($self->{errs}) {
200 0         0 require Apache::ASP::Error;
201 0         0 $status = $self->ProcessErrors;
202                 }
203              
204             # XX return code of 302 hangs server on WinNT
205             # STATUS hook back to Apache
206 16         197     my $response = $self->{Response};
207 16 50 66     521     if($status != 500 and defined $response->{Status} and $response->{Status} != 302) {
      66        
208             # if still default then set to what has been set by the
209             # developer
210 0         0 $status = $response->{Status};
211                 }
212              
213             # X: we DESTROY in register_cleanup, but if we are filtering, and we
214             # handle a virtual request to an asp app, we need to free up the
215             # the locked resources now, or the session requests will collide
216             # a performance hack would be to share an asp object created between
217             # virtual requests, but don't worry about it for now since using SSI
218             # is not really performance oriented anyway.
219             #
220             # If we are not filtering, we let RegisterCleanup get it, since
221             # there will be a perceived performance increase on the client side
222             # since the connection is terminated before the garabage collection is run.
223             #
224             # Also need to destroy if we return a 500, as we could be serving an
225             # error doc next, before the cleanup phase
226              
227 16 50 33     591     if($self->{filter} || ($status == 500) || ( $r->isa('Apache::ASP::CGI'))) {
      33        
228 16         349 $self->DESTROY();
229                 }
230              
231 16 50       245     if($status eq '200') {
232 16         154 $status = 0; # OK status code is default unless there was an internal error
233                 }
234              
235 16         380     $status;
236             }
237              
238             sub Warn {
239 0 0 0 0 0 0     shift if(ref($_[0]) or $_[0] eq 'Apache::ASP');
240 0         0     print STDERR "[ASP WARN] ", @_;
241             }
242              
243             sub new {
244 18     18 0 285     my($class, $r, $filename) = @_;
245 18 50       223     $r || die("need Apache->request() object to Apache::ASP->new(\$r)");
246              
247             # $StartTime is set by asp-perl early on before modules are loaded
248             # for more accurate per time tracking. Unset, so this init load time does
249             # not get used more than once.
250 18         162     my $start_time;
251 18 50       322     if($QuickStartTime) {
252 0         0 $start_time = $QuickStartTime;
253 0         0 $QuickStartTime = undef;
254                 } else {
255 18   33     190 $start_time = eval { &Time::HiRes::time(); } || time();
  18         1033  
256                 }
257              
258 18         341     local $SIG{__DIE__} = \&Carp::confess;
259             # like cgi, operate in the scripts directory
260 18   100     211     $filename ||= $r->filename();
261 18         942     $filename =~ m|^(.*?[/\\]?)([^/\\]+)$|;
262 18   100     450     my $dirname = $1 || '.';
263 18         210     my $basename = $2;
264 18 50       616     chdir($dirname) || die("can't chdir to $dirname: $!");
265              
266             # temp object just to call config() on, do not bless since we
267             # do not want the object to be DESTROY()'d
268 18         300     my $dir_config = $r->dir_config;
269 18         315     my $headers_in = $r->headers_in;
270 18         267     my $self = { r => $r, dir_config => $dir_config };
271              
272             # global is the default for the state dir and also
273             # a default lib path for perl, as well as where global.asa
274             # can be found
275 18   100     243     my $global = &get_dir_config($dir_config, 'Global') || '.';
276 18         216     $global = &AbsPath($global, $dirname);
277              
278             # asp object is handy for passing state around
279 18 50 100     292     $self = bless
280                   {
281                    'basename' => $basename,
282                    'cleanup' => [],
283                    'dbg' => &get_dir_config($dir_config, 'Debug') || 0, # debug level
284                    'destroy' => 1,
285                    'dir_config' => $dir_config,
286                    'headers_in' => $headers_in,
287                    filename => $filename,
288                    global => $global,
289                    global_package => &get_dir_config($dir_config, 'GlobalPackage'),
290                    inode_names => &get_dir_config($dir_config, 'InodeNames'),
291                    no_cache => &get_dir_config($dir_config, 'NoCache'),
292                    'r' => $r, # apache request object
293                    start_time => $start_time,
294                    stat_scripts => &config($self, 'StatScripts', undef, 1),
295                    stat_inc => &get_dir_config($dir_config, 'StatINC'),
296                    stat_inc_match => &get_dir_config($dir_config, 'StatINCMatch'),
297                    use_strict => &get_dir_config($dir_config, 'UseStrict'),
298                    win32 => ($^O eq 'MSWin32') ? 1 : 0,
299                    xslt => &get_dir_config($dir_config, 'XSLT'),
300                   }, $class;
301              
302             # Only if debug is negative do we kick out all the internal stuff
303 18 100       258     if($self->{dbg}) {
304 1 50       13 if($self->{dbg} < 0) {
305 0         0 *Debug = *Out;
306 0         0 $self->{dbg} = -1 * $self->{dbg};
307             } else {
308 1         11 *Debug = *Null;
309             }
310 1         28 $self->Debug('RUN ASP (v'. $VERSION .") for $self->{filename}");
311              
312                 } else {
313 17         211 *Debug = *Null;
314                 }
315                 
316             # Ken said no need for seed ;), now we just make sure its called post fork
317             # Patch from Ime suggested no need for %SrandPid, just srand() again when $$ has changed
318 18 100 66     362     unless($SrandPid && $SrandPid == $$) {
319 12 100       198 $self->{dbg} && $self->Debug("call srand() post fork");
320 12         720 srand();
321 12         133 $SrandPid = $$;
322                 }
323              
324             # filtering support
325 18         288     my $filter_config = &get_dir_config($dir_config, 'Filter');
326 18 50       235     if($filter_config) {
327 0 0       0         if($self->LoadModules('Filter', 'Apache::Filter')) {
328             # new filter_register with Apache::Filter 1.013
329 0 0       0 if($r->can