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('filter_register')) {
330 0         0 $self->{r} = $r = $r->filter_register;
331             }
332            
333 0 0 0     0 if ($r->can('filter_input') && $r->can('get_handlers')) {
334 0         0 $self->{filter} = 1;
335             #X: do something with the return code, can't now because
336             # apache constants aren't working on my win32
337 0         0 my($fh, $rc) = $r->filter_input();
338 0         0 $self->{filehandle} = $fh;
339             }
340             } else {
341 0 0       0 if(! $r->can('get_handlers')) {
342 0         0 $self->Error("You need at least mod_perl 1.16 to use SSI filtering");
343             } else {
344 0         0 $self->Error("Apache::Filter was not loaded correctly for using SSI filtering. ".
345             "If you don't want to use filtering, make sure you turn the Filter ".
346             "config option off whereever it's being used");
347             }
348             }
349                 }
350                 
351             # gzip content encoding option by ime@iae.nl 28/4/2000
352 18         183     my $compressgzip_config = &get_dir_config($dir_config, 'CompressGzip');
353 18 50       247     if($compressgzip_config) {
354 0 0       0 if($self->LoadModule('Gzip','Compress::Zlib')) {
355 0         0 $self->{compressgzip} = 1;
356             }
357                 }
358                  
359             # must have global directory into which we put the global.asa
360             # and possibly state files, optimize out the case of . or ..
361 18 100       453     if($self->{global} !~ /^(\.|\.\.)$/) {
362 7 50       160 -d $self->{global} or
363             $self->Error("global path, $self->{global}, is not a directory");
364                 }
365              
366             # includes_dir calculation
367 18 50       250     if($filename =~ m,^((/|[a-zA-Z]:).*[/\\])[^/\\]+?$,) {
368 0         0 $self->{dirname} = $1;
369                 } else {
370 18         686 $self->{dirname} = '.';
371                 }
372 18   50     261     $self->{includes_dir} = [
373             $self->{dirname},
374             $self->{global}, 
375             split(/;/, &config($self, 'IncludesDir') || ''),
376             ];
377              
378             # register cleanup before the state files get set in InitObjects
379             # this way DESTROY gets called every time this script is done
380             # we must cache $self for lookups later
381 18     18   433     &RegisterCleanup($self, sub { $self->DESTROY });
  18         219  
382              
383             #### WAS INIT OBJECTS, REMOVED DECOMP FOR SPEED
384              
385             # GLOBALASA, RESPONSE, REQUEST, SERVER
386             # always create these
387             # global_asa assigns itself to parent object automatically
388 18         248     my $global_asa = &Apache::ASP::GlobalASA::new($self);
389 18         508     $self->{Request} = &Apache::ASP::Request::new($self);
390 18         290     $self->{Response} = &Apache::ASP::Response::new($self);
391             # Server::new() is just one line, so execute directly
392 18         282     $self->{Server} = bless {asp => $self}, 'Apache::ASP::Server';
393             #&Apache::ASP::Server::new($self);
394              
395             # After GlobalASA Init, init the package that this script will execute in
396             # must be here, and not end of new before things like Application_OnStart get run
397             # UniquePackages & NoCache configs do not work together, NoCache wins here
398 18 50       231     if(&config($self, 'UniquePackages')) {
399             # id is not generally useful for the ASP object now, so calculate
400             # it here now, only to twist the package object for this script
401              
402             # pass in basename for where to find the file for InodeNames, and the full path
403             # for the FileId otherwise
404 0         0 my $package = $global_asa->{'package'}.'::'.&FileId($self, $self->{basename}, $self->{filename});
405 0         0 $self->{'package'} = $package;
406 0         0 $self->{init_packages} = ['main', $global_asa->{'package'}, $self->{'package'}];
407                 } else {
408 18         206 $self->{'package'} = $global_asa->{'package'};
409 18         281 $self->{init_packages} = ['main', $global_asa->{'package'}];
410                 }
411              
412 18         340     $self->{state_dir} = &config($self, 'StateDir', undef, $self->{global}.'/.state');
413 18         189     $self->{state_dir} =~ tr///; # untaint
414              
415             # if no state has been config'd, then set up none of the
416             # state objects: Application, Internal, Session
417 18 100       209     unless(&get_dir_config($dir_config, 'NoState')) {
418             # load at runtime for CGI environments, preloaded for mod_perl
419 7         213 require Apache::ASP::StateManager;
420 7         115 &InitState($self);
421                 }
422              
423 18         328     $self;
424             }
425              
426             # called upon every end of connection by RegisterCleanup
427             sub DESTROY {
428 35     35   374     my $self = shift;
429              
430 35 100       2207     return unless $self->{destroy}; # still active object
431 18 100       332     $self->{dbg} && $self->Debug("destroying ASP object $self");
432              
433             # do before undef'ing the object references in main
434 18         159     for my $code ( @{$self->{cleanup}} ) {
  18         329  
435 0 0       0 $self->{dbg} && $self->Debug("executing cleanup $code");
436 0         0 eval { &$code() };
  0         0  
437 0 0       0 $@ && $self->Error("executing cleanup $code error: $@");
438                 }
439              
440 18         233     local $^W = 0; # suppress untie while x inner references warnings
441 18         224     select(STDOUT);
442 18 100       485     untie *RESPONSE if tied *RESPONSE;
443              
444             # can't move this to Request::DESTROY(), then CGI object compatibility
445             # in test ./site/eg/cgi.htm test fails, don't know why, --jc, 12/06/2002
446 18 50       211     untie *STDIN if tied *STDIN;
447              
448             # in case there is a dummy session here by the
449             # end of object execution
450 18 100       308     if($self->{Session}) {
451 7 50       353         if(eval { $self->{Session}->isa('Apache::ASP::Session') }) {
  7         215  
452             # only the cleanup master may cleanup groups now, so OK
453             # to call just CleanupGroups
454 7         127 $self->CleanupGroups();
455             } else {
456 0         0             $self->Debug("$self->{Session} is not an Apache::ASP::Session");
457 0         0             eval { $self->{Session}->DESTROY };
  0         0  
458 0         0             $self->{Session} = undef;
459                     }
460                 }
461              
462             # free file handles here. mod_perl tends to be pretty clingy
463             # to memory
464 18         194     for('Application', 'Internal', 'Session') {
465             # all this stuff in here is very necessary for total cleanup
466             # the DESTROY is the most important, as we need to explicitly free
467             # state objects, just in case anyone else is keeping references to them
468             # But the destroy won't work without first untieing, go figure
469 54 100       3985 next unless defined $self->{$_};
470 21         253 my $tied = tied %{$self->{$_}};
  21         231  
471 21 50       278 next unless $tied;
472 21         172 untie %{$self->{$_}};
  21         678  
473 21         300 $tied->DESTROY(); # call explicit DESTROY
474                 }
475              
476 18 100       2762     if(my $caches = $self->{Caches}) {
477             # default cache size to 10M
478 1   33     13 $self->{cache_size} = &config($self, 'CacheSize') || $CacheSize;
479 1 50       227 if($self->{cache_size} =~ /^([\d\.]+)(M|K|B)?$/) {
480 1         23 my($size, $unit) = ($1, $2);
481 1 50       17 if($unit eq 'M') {
    50          
482 0         0 $size *= 1024*1024;
483             } elsif($unit eq 'K') {
484 1         12 $size *= 1024;
485             }
486 1 50       17 if($size ne $self->{cache_size}) {
487 1 50       12 $self->{dbg} && $self->Debug("converting CacheSize $self->{cache_size} to $size bytes");
488 1         12 $self->{cache_size} = $size;
489             }
490             }
491 1         13 for my $cache (values %$caches) {
492 1         10 my $tied = $cache;
493 1 50 33     27 if($tied->{writes} && $tied->Size > $self->{cache_size}) {
494 1 50       13 $self->{dbg} && $self->Debug("deleting cache $cache, size: ".$tied->Size);
495 1         13 $tied->Delete;
496             } else {
497 0 0       0 $self->{dbg} && $self->Debug("cache $cache OK size, size: ".$tied->Size);
498             }
499 1         17 $tied->DESTROY();
500             }
501                 }
502              
503             # $self->{'dbg'} && $self->Debug("END ASP DESTROY");
504 18 50       687     $self->{Request} && &Apache::ASP::Request::DESTROY($self->{Request});
505 18 50       261     $self->{Server} && ( %{$self->{Server}} = () );
  18         260  
506 18 50       243     $self->{Response} && ( %{$self->{Response}} = () );
  18         447  
507 18         693     %$self = ();
508              
509 18         574     1;
510             }
511              
512             sub RegisterCleanup {
513 18     18 1 170     my $self = shift;
514              
515 18 50       198     if($ModPerl2) {
516 0         0 $self->{r}->pool->cleanup_register(@_);
517                 } else {
518 18         371 $self->{r}->register_cleanup(@_);
519                 }
520             }
521              
522             sub InitPaths {
523              
524             # we load this module just to detect where the shared directory really is
525 14     14   8025     use Apache::ASP::Share::CORE;
  14         186  
  14         1634  
526              
527             # major problem with %INC if we cannot get this information
528 12   50 12 0 174     my $share_path = $INC{'Apache/ASP/Share/CORE.pm'}
529                   || die(q(can't find path for $INC{'Apache/ASP/Share/CORE.pm'}));
530              
531 12         192     $share_path =~ s/CORE\.pm$//s;
532 12 50       478     unless($share_path =~ /$AbsoluteFileMatch/) {
533             # this %ENV manipulation is just to allow cwd() to run in taint check mode
534 0         0 local %ENV = %ENV;
535 0         0 $ENV{PATH} = '/bin:/usr/bin:/usr/sbin';
536 0         0 delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};
537 0         0 my $currdir = cwd();
538 0         0 $share_path = "$currdir/$share_path";
539                 }
540              
541             # not finding the ShareDir creates a hard error, because the Apache/ASP/Share
542             # directory will become one of the fundamental underpinings of the project
543             # People will need to rely on being able to load shared includes, and not have
544             # to discover the lack of loading Share:: at runtime, rather this is a compile
545             # time error.
546 12 50       615     -d $share_path || die("Apache::ASP::Share directory not found. ".
547             "Please make sure to install all the modules that make up the Apache::ASP installation."
548             );
549 12         124     $ShareDir = $share_path;
550              
551             # once we find the $ShareDir, we can truncate the library path
552             # and push it onto @INC with use lib... this is to help with loading
553             # future Apache::ASP::* modules when the lib path it was found at is
554             # relative to some directory. This was needed to have the "make test"
555             # test suite to work which loads libraries from "blib/lib", but Apache::ASP
556             # will chdir() into the script directory so that can ruin this
557             # library lookup.
558             #
559 12         116     my $lib_path = $share_path;
560 12         177     $lib_path =~ s/Apache.ASP.Share.?$//s;
561 12 50       272     -d $lib_path || die("\%INC library path $lib_path not found.");
562 12         120     $INCDir = $lib_path;
563                 
564             # clear taint, for some reason, tr/// or s/^(.*)$/ did not work on perl 5.6.1
565 12         141     $INCDir =~ /^(.*)$/s;
566 12         155     $INCDir = $1;
567              
568             # make sure this gets on @INC at startup, can't hurt
569 14     14   301     eval "use lib qw($INCDir);";
  14         126  
  14         817  
  12         148  
570              
571 12         332     1;
572             }
573              
574             sub FileId {
575 45     45 0 549     my($self, $file, $abs_file, $no_compile_checksum) = @_;
576 45 50       993     $file || die("no file passed to FileId()");
577 45         382     my $id;
578              
579             # calculate compile checksum for file id
580 45 100       678     unless($self->{compile_checksum}) {
581 18         172 my $r = $self->{r};
582 198 100       2065 my $checksum = md5_hex(join('&-+',
583             $VERSION,
584 18         230 map { &config($self, $_) || '' }
585             @CompileChecksumKeys
586             )
587             );
588             # $self->{dbg} && $self->Debug("compile checksum $checksum");
589 18         320 $self->{compile_checksum} = $checksum;
590                 }
591              
592 45 100       553     my $compile_checksum = $no_compile_checksum ? '' : $self->{compile_checksum};
593              
594 45         429     my @inode_stat = ();
595 45 50       532     if($self->{inode_names}) {
596 0         0 @inode_stat = stat($file);
597             # one or the other device or file ids must be not 0
598 0 0 0     0 unless($inode_stat[0] || $inode_stat[1]) {
599 0         0 @inode_stat = ();
600             }
601                 }
602              
603 45 50       562     if(@inode_stat) {
604 0         0 $id = sprintf("____DEV%X_INODE%X",@inode_stat[0,1]);
605 0         0 $id .= 'x'.$compile_checksum;
606                 } else {
607 45 50       881 if($abs_file) {
608 0         0 $file = $abs_file;
609             }
610 45         584 $file =~ s|/+|/|sg;
611 45         1073 $file =~ s/[\Wx]/_/sg;
612 45         465 my $file_name_length = length($file);
613 45 50       1147 if($file_name_length >= 35) {
614 0         0 $id = substr($file, $file_name_length - 35, 36);
615             # only do the hex of the original file to create a unique identifier for the long id
616 0         0 $id .= 'x'.&md5_hex($file.$compile_checksum);
617             } else {
618 45         935 $id = $file.'x'.$compile_checksum;
619             }
620                 }
621              
622 45         731     $id = '__ASP_'.$id;
623             }
624              
625             # defaults to parsing the script's file, or data from a file handle
626             # in the case of filtering, but we can also pass in text to parse,
627             # which is useful for doing includes separately for compiling
628             sub Parse {
629 36     36 0 399     my($self, $file) = @_;
630 36         363     my $file_exists = 0;
631 36         308     my $parse_file = $file;
632 36         336     my $r = $self->{r};
633 36         296     my $data;
634              
635             # get script data, from varied data sources;
636 36 50       450     $file || die("can't parse without file data");
637              
638 36 100       410     $self->{dbg} && $self->Debug("parse file $file");
639             # file can be a filename, scalar ref, or scalar
640 36 100 33     1309     if(ref $file) {
    50 33        
641 13 50       273 if ($file =~ /SCALAR/) {
    0          
642 13         135 $data = $$file;
643             } elsif ($file =~ /GLOB/) {
644 0         0 local $/ = undef;
645 0         0 $data = <$file>
646             }
647                 } elsif((length($file) < 1024) && ($file !~ /^GLOB/) && (-e $file)) {
648             # filename has length < 1024, should be fine across OS's
649 23 100       266 $self->{dbg} && $self->Debug("parsing $file");
650 23         198 $data = ${$self->ReadFile($file)};
  23         295  
651 23         282 $file_exists = 1;
652 23         19971 $self->{parse_file_count}++;
653                 } else {
654 0         0 $data = $file; # raw script, no ref
655                 }
656              
657             # moved parsing config here since not needed for normal
658             # eval execution of scripts after compilation
659 36 100       442     unless($self->{parse_config}) {
660 16         166 $self->{parse_config} = 1;
661 16         311 $self->{compile_includes} = &config($self, 'DynamicIncludes');
662 16         354 $self->{pod_comments} = &config($self, 'PodComments', undef, 1);
663 16         169 $self->{xml_subs_strict} = &config($self, 'XMLSubsStrict');
664             # default XMLSubsPerlArgs to 1 for now, until 3.0
665 16         176 $self->{xml_subs_perl_args} = &config($self, 'XMLSubsPerlArgs', undef, 1);
666              
667             # reduce (pattern) patterns to (?:pattern) to not create $1 side effect
668 16 100       172 if($self->{xml_subs_match} = &config($self, 'XMLSubsMatch')) {
669 6         66 $self->{xml_subs_match} =~ s/\(\?\:([^\)]*)\)/($1)/isg;
670 6         61 $self->{xml_subs_match} =~ s/\(([^\)]*)\)/(?:$1)/isg;
671             }
672              
673 16         266 my $lang = &config($self, 'ScriptLanguage', undef, 'PerlScript');
674 16         189 my $module = "Apache::ASP::Lang::".$lang;
675 16 50       205 unless($ScriptLanguages{$lang}) {
676             # eval "use $module;";
677 0         0 $self->Error("ScriptLanguage for $lang could not be loaded: $@");
678 0         0 return;
679             }
680 16         151 eval {
681 16         331 my $lang_object = $module->new(ASP => $self);
682 16         167 $self->{lang_object} = $lang_object;
683 16         219 $self->{lang_module} = $module;
684 16         176 $self->{lang_language} = $lang;
685 16         238 $self->{lang_comment} = $lang_object->CommentStart;
686             };
687 16 50       189 if($@) {
688 0         0 $self->Error("ScriptLanguage object for $lang failed init: $@");
689 0         0 return;
690             }
691                 }
692              
693 36         480     my $comment = $self->{lang_comment};
694 36 100       391     if(&config($self, 'CgiDoSelf')) {
695 30         2228 $data =~ s,^(.*?)__END__,,so;
696                 }
697              
698             # do both before and after, so =pods can span includes with =pods
699 36 50       574     if($self->{pod_comments}) {
700 36         2084 &PodComments($self, \$data);
701                 }
702              
703             # if compiling includes, then do now before includes conversion
704             # each include will also have its Script_OnParse run on it.
705 36 50 33     533     if($self->{compile_includes} && $self->{GlobalASA}{'exists'}) {
706 0         0 $self->{Server}{ScriptRef} = \$data;
707 0         0 $self->{GlobalASA}->ExecuteEvent('Script_OnParse');
708                 }
709              
710             # do includes as early as possible !! so included text gets done too
711             # this section is for file includes, we do this here instead of ssi
712             # so it can be parsed and compiled with the script
713 36         394     local %includes; # trap recursive includes with this
714              
715             # JUST ONCE
716             # there should only be one of these, <%@ LANGUAGE="PerlScript" %>, rip it out
717             # we keep white space and substitue text in so the perlscript sync's up with lines
718             # only take out the first one
719 36         551     $data =~ s/^\#\![^\n]+(\n\s*)/\<\%$1\%\>/s; #X cgi compat ?
720 36         437     $data =~ s/^(\s*)\<\%(\s*)\@([^\n]*?)\%\>/$1\<\%$2 ; \%\>/so;
721              
722 36         372     my $root_file = $file;
723 36         307     my $line1_added = 0;
724 36         578     my $munge = $data;
725 36         380     $data = '';
726 36         396     my($file_context, $file_line_number, $code_block);
727 36         480     while($munge =~ s/^(.*?)\<!--\#include\s+file\s*=\s*\"?([^\s\"]*?)\"?(\s+args\s*=\s*\"?.*?)?\"?\s*--\>//so) {
728 8         88 $data .= $1; # append the head
729 8         82 my $file = $2;
730              
731             # only need all this if we are in inline include mode
732 8         65 my $head_data;
733 8 50       85 if (! $self->{compile_includes}) {
734 8         78 $head_data = $1;
735              
736 8 100       76 unless($line1_added) {
737 2         16 $line1_added = 1;
738 2 50       26 $head_data = ($file_exists ? "<% \n#line 1 $root_file\n %>" : '').$head_data;
739             }
740              
741 8 100       114 if ($head_data =~ s/.*\n\#line (\d+) ([^\n]+)\n(\%\>)?//s) {
742 6         52 $file_line_number = $1;
743 6         57 $file_context = $2;
744 6 100       64 $code_block = $3 ? 0 : 1;
745             }
746 8         107 $file_line_number += $head_data =~ s/\n//sg;
747 8         76 $head_data =~ s/\<\%.*?\%\>//sg;
748             # print STDERR "HEAD: $head_data\n";
749 8         82 my $code_blocks_open = $head_data =~ s/\<\%//sg;
750 8         105 my $code_blocks_closed = $head_data =~ s/\%\>//sg;
751 8         66 $code_block += $code_blocks_open;
752 8         67 $code_block -= $code_blocks_closed;
753 8 50       80 if (($code_block < 0)) {
754 0         0 $code_block = 0; # stray percents like height=100%> kinds of tags
755             }
756              
757             # print STDERR "CODEBLOCK: $code_block $file; open $code_blocks_open closed $code_blocks_closed\n";
758             # print STDERR "FILE CONTEXT: $file_context LINENO: $file_line_number\n\n";
759             }
760              
761             # compiled include args handling
762 8         73 my $has_args = $3;
763 8         67 my $args = undef;
764 8 50       75 if($has_args) {
765 0         0 $args = $has_args;
766 0         0 $args =~ s/^\s+args\s*\=\s*\"?//sgo;
767             }
768              
769             # global directory, as well as includes dirs
770 8         79 my $include = &SearchDirs($self, $file);
771 8 50       78 unless(defined $include) {
772 0         0 $self->Error("include file with name $file does not exist");
773 0         0 return;
774             }
775 8 50       78 if($self->{dbg}) {
776 0 0       0 if($include ne $file) {
777 0 0       0 $self->{dbg} && $self->Debug("found $file at $include");
778             }
779             }
780              
781             # trap the includes here, at 100 levels like perl debugger
782 8 50 33     104 if(defined($args) || $self->{compile_includes}) {
783             # because the script is literally different whether there
784             # are includes or not, whether we are compiling includes
785             # need to be part of the script identifier, so the global
786             # caching does not return a script with different preferences.
787 0   0     0 $args ||= '';
788 0 0       0 $self->{dbg} && $self->Debug("runtime exec of dynamic include $file args (".
789             ($args).')');
790 0         0 $data .= "<% \$Response->Include('$include', $args); %>";
791            
792             # compile include now, so Loading() works for dynamic includes too
793 0 0       0 unless($self->CompileInclude($include)) {
794 0         0 $self->Error("compiling include $include failed when compiling script");
795             }
796             } else {
797 8 50       332 $self->{dbg} && $self->Debug("inlining include $include");
798             # DEFAULT, not compile includes, or inline includes,
799             # the included text is inlined directly into the script
800 8 50       106 if($includes{$include}++ > 100) {
801 0         0 $self->Error("Recursive include detected for $include 100 levels deep! ".
802             "Your includes are including each other. If you ".
803             "are getting this error with a legitimate use of includes ".
804             "please mail support about this error "
805             );
806 0         0 return;
807             }
808            
809             # put the included text into what we are parsing, allows for
810             # includes having includes
811 8 50 33     138 if ($file_exists && $parse_file) {
812 8         70 $self->{parse_inline_count}++;
813 8 50       76 $self->{dbg} && $self->Debug("include $include found for file $parse_file");
814 8         137 $Apache::ASP::Includes{$parse_file}->{$include} = time();
815             }
816 8         64 my $text = ${$self->ReadFile($include)};
  8         85  
817 8         100 $text =~ s/\n$//sg;
818 8         72 $text =~ s/^\#\![^\n]+(\n\n?)/$1/s; #X cgi compat ?
819             ;
820 8 100       87 if ($text =~ /\n/s) {
821 5 100       49 my $code_open = $code_block ? '' : '<%';
822 5 100       48 my $code_close = $code_block ? '' : '%>';
823 5 50       67 my $file_context_edge = $file_context ?
824             $code_open."\n#line $file_line_number $file_context\n".$code_close : '';
825 5         174 $munge =
826             $code_open."\n#line 1 $include\n".$code_close.
827             $text .
828             $file_context_edge .
829             $munge;
830             } else {
831             # if inserting less than one line of text, then don't
832             # do line renumbering
833 3         104 $munge = $text . $munge;
834             }
835             }
836                 }
837 36         400     $data .= $munge; # append what's left
838             # print STDERR $file."\n\n".$data."\n\n";
839              
840              
841             # so we have the full script for people
842 36 50       427     if(! $self->{compile_includes}) {
843             # do pod comments again if we have any included files
844 36 100 66     482 if(%includes && $self->{pod_comments}) {
845 2         21 &PodComments($self, \$data);
846             }
847 36 50       503 if($self->{GlobalASA}{'exists'}) {
848 36         496 $self->{Server}{ScriptRef} = \$data;
849 36         623 $self->{GlobalASA}->ExecuteEvent('Script_OnParse');
850             }
851                 }
852              
853             # $self->Debug("parsing includes done $self->{'basename'}");
854              
855             # strip carriage returns; do this as early as possible, but after includes
856             # since we want to rip out the carriage returns from them too, these
857             # changes should make things Win & Mac compatible
858             # my $CRLF = "\015\012";
859 36         2895     $data =~ s/\015?\012/\n/sgo;
860 36         756     $data =~ s/\s+$//so; # strip trailing white space
861              
862 36         410     my $script = &ParseHelper($self, \$data, 1);
863 36 100       430     if($script) {
864 35 100       499 my $strict = $self->{use_strict} ? "use strict;" : "no strict";
865 35 100       994 $$script = join(";;",
866             $strict,
867             "use vars qw(\$".join(" \$",@Apache::ASP::Objects).')',
868             ($file_exists ? "\n#line 1 $root_file\n" : ''),
869             $$script,
870             );
871             return {
872 35         625 is_perl => 1,
873             data => $script,
874             };
875                 } else {
876             return {
877 1         16 is_raw => 1,
878             data => \$data,
879             };
880                 }
881             }
882              
883             sub ParseHelper {
884 38     38 0 430     my($self, $data, $check_static_file) = @_;
885 38         321     my($script, $text, $perl);
886              
887 38 100       417     if($self->{xml_subs_match}) {
888 8         74 my $start = $$data;
889 8 50       80 $self->{dbg} && $self->Debug("start parse of data", length($$data));
890 8         87 $$data = $self->ParseXMLSubs($$data);
891             # print STDERR "START $start\n\n";
892             # print STDERR "END $$data\n\n";
893                 }
894              
895             # we only do this check the first time we call ParseHelper() from
896             # Parse() with $check_static_file set. Calls from ParseXMLSubs()
897             # will leave this off. This is where we start to throw data
898             # back that lets the system render a static file as is instead
899             # of executing it as a per subroutine.
900 38 100 100     765     return if ($check_static_file && $$data !~ /\<\%.*?\%\>/s);
901              
902 37         329     my(@out, $perl_block, $last_perl_block);
903 37         356     $$data .= "<%;;;%>"; # always end with some perl code for parsing.
904              
905             # can't do it for <%= %><% %> constructions
906             # $$data =~ s/\%\>(\s*)\<\%/;$1/isg; # compress close code blocks, move white space to code
907              
908 37         696     while($$data =~ s/^(.*?)\<\%(.*?)\%\>//so) {
909 84         1283 ($text, $perl) = ($1,$2);
910 84 100       1200 $perl_block = ($perl =~ /^\s*\=(.*)$/so) ? 0 : 1;
911 84         858 my $perl_scalar = $1;
912              
913             # with some extra text parsing, we remove asp formatting from
914             # influencing the generated html formatting, in particular
915             # dealing with perl blocks and new lines
916 84 100       832 if($text) {
917             # don't touch the white space, to preserve line numbers
918 30         266 $text =~ s/\\/\\\\/gso;
919 30         255 $text =~ s/\'/\\\'/gso;
920              
921 30 100       375 if($last_perl_block) {
922 12         103 $last_perl_block = 0;
923             }
924              
925 30         333 push(@out, "\'".$text."\'")
926             }
927              
928 84 50       2798 if($perl) {
929 84 100       864 if(! $perl_block) {
930             # we have a scalar assignment here
931 13         270 push(@out, '('.$perl_scalar.')');
932             } else {
933 71         635 $last_perl_block = 1;
934 71 100       685 if(@out) {
935             # we pass by reference here with the idea that we are not
936             # copying the HTML twice this way. This might be large
937             # saving on a typical site with rich HTML headers & footers
938 43         535 $script .= '&Apache::ASP::WriteRef($main::Response, \('.join('.', @out).'));';
939             # $script .= '$main::Response->{Bit} = \('.join('.', @out).');';
940             # $script .= '($main::Response->{Buffer} && ! $main::Response->{Ended}) ? '.
941             # '${$main::Response->{out}} .= ${$main::Response->{Bit}} : '.
942             # '$main::Response->WriteRef($main::Response->{Bit}); ';
943 43         398 @out = ();
944             }
945              
946             # allow old <% #comment %> style to still work, but we
947             # need to insert a newline at the end of the comment for
948             # it to still exist, with the lines now being sync'd up
949             # if these old comments still exist, they perl script
950             # will be off by one line from the asp script
951 71 100       942 if ($perl !~ /\n\s*$/so) {
952 43 50       624 if($perl =~ /\#[^\n]*$/so) {
953             # print STDERR "NEW adding newline to [$perl]\n";
954 0         0 $perl .= "\n";
955             }
956             }
957              
958             # skip if the perl code is just a placeholder
959 71 100       817 unless($perl eq ';;;') {
960             # print STDERR "PERL, adding ; to [$perl]\n";
961 34         742 $script .= $perl . '; ';
962             }
963             }
964             }
965                 }
966              
967 37         391     \$script;
968             }
969              
970             sub ParseXMLSubs {
971 8     8 0 81     my($self, $data) = @_;
972              
973 8         74     $data = &CodeTagEncode($self, $data);
974              
975 8 50       86     unless($self->{xslt}) {
976 8         199 $data =~ s|\s*\<\?xml\s+version\s*\=[^\>]+\?\>||is;
977                 }
978             # (?<!\s|\>) ... use later when robustifying XMLSubs
979 8         135     $data =~ s@\<\s*($self->{xml_subs_match})(\s+[^\>]*)?/\>
  0         0  
  0         0  
980 0         0 @ {
981 0         0 my($func, $args) = ($1, $2);
982 0         0 $args = &CodeTagDecode($self, $args);
983 0 0       0 $func =~ s/\:+/\:\:/g;
984 0   0     0 $func =~ s/\-/\_/g;
985 0         0 $args && ($args = &ParseXMLSubsArgs($self, $args));
986 0         0 $args ||= '';
987             $self->{xmlsubs_compiled_tag_short}++;
988             "<% &$func({ $args }, ''); %>"
989             } @sgex;
990              
991 8         64     while (1) {
992             # \<\s*($self->{xml_subs_match})(\s+[^\>]*)?\>(?!.*\<\s*\1[^\>]*\>)(.*?)\<\/\1\s*>
993 10 100       207 last unless $data =~ s@
  2         18  
  2         30  
994 2         44 \<\s*($self->{xml_subs_match})(\s+[^\>]*)?\>(?!.*?\<\s*\1[^\>]*\>)(.*?)\<\/\1\s*>
995 2         27 @ {
996 2 50       21 my($func, $args, $text) = ($1, $2, $3);
997 2   50     22 $args = &CodeTagDecode($self, $args);
998 2         19 $func =~ s/\:+/\:\:/g;
999 2         18 $args && ($args = &ParseXMLSubsArgs($self, $args));
1000             $args ||= '';
1001 2 50       52 $self->{xmlsubs_compiled_tag_long}++;
1002             $text = &CodeTagDecode($self, $text);
1003 2         19
1004 2         27 if($text =~ m/\<\%|\<($self->{xml_subs_match})/) {
1005             # parse again, and control output buffer for this level
1006 2         30 $self->{xmlsubs_compiled_tag_recurse_parse}++;
1007             my $sub_script = &ParseHelper($self, \$text, 0);
1008             # my $sub_script = \$text;
1009             $text = (
1010             ' &{sub{ my $out = ""; '.
1011             'local $Response->{out} = local $Response->{BinaryRef} = \$out; '.
1012             'local *Apache::ASP::Response::Flush = *Apache::ASP::Response::Null; '.
1013             $$sub_script .
1014 0         0 ' ; ${$Response->{out}}; }} '
1015 0         0 );
1016 0         0 } else {
1017             # raw text
1018             $text =~ s/\\/\\\\/gso;
1019 2         80 $text =~ s/\'/\\\'/gso;
1020             $text = "'$text'";
1021             }
1022            
1023             "<% &$func({ $args }, $text); %>"
1024             } @sgex;
1025                 }
1026              
1027 8         75     $data = &CodeTagDecode($self, $data);
1028              
1029             # print STDERR "\nXMLSubs:\n$data\n\n";
1030              
1031 8         96     $data;
1032             }
1033              
1034             sub CodeTagEncode {
1035 8     8 0 78     my($self, $data) = @_;
1036             # return $data;
1037              
1038 8 50       80     if(defined $data) {
1039 8         128        $data =~ s@\<\%(.*?)\%\>@
1040 8         64 {
  8         112  
1041 8         116 my $temp = $self->{Server}->HTMLEncode($1);
1042             "[-AsP-[".$temp."]-AsP-]";
1043             }
1044             @esgx;
1045                 }
1046 8         90     $data;
1047             }
1048              
1049             sub CodeTagDecode {
1050 12     12 0 118     my($self, $data) = @_;
1051             # return $data;
1052              
1053 12 100       115     if(defined $data) {
1054 10         150        $data =~ s@\[\-AsP\-\[(.*?)\]\-AsP\-\]@
1055 8         63 {
  8         95  
1056 8         172 my $temp = $self->{Server}->HTMLDecode($1);
1057             "<%".$temp."%>";
1058             }
1059             @esgx;
1060                 }
1061              
1062 12         129     $data;
1063             }
1064              
1065             sub ParseXMLSubsArgs {
1066 0     0 0 0     my($self, $args) = @_;
1067 0   0     0     $args ||= '';
1068              
1069 0 0       0     if ($self->{xml_subs_strict}) {
    0          
1070 0         0 my %args;
1071 0         0 while ($args =~ s/(\s*)([^\s]+)(\s*)\=\s*([\'\"])(.*?)(\4)\s*//s) {
1072 0         0 $args{$2} = $5;
1073             }
1074 0         0 $args = join(', ', map { "'$_' => '$args{$_}'" } keys %args);
  0         0  
1075                 } elsif($self->{xml_subs_perl_args}) {
1076 0         0 $args =~ s/(\s*)([^\s]+?)(\s*)\=(\s*[^\s]+)/,$1'$2'$3\=\>$4/sg;
1077 0         0 $args =~ s/^(\s*),/$1/s;
1078                 } else {
1079 0         0 my %args;
1080 0         0 while ($args =~ s/(\s*)([^\s]+?)(\s*)\=\s*([\'\"])(.*?)(\4)\s*//s) {
1081 0         0 my($key, $value) = ($2, $5);
1082             # we go through the pain of @value_bits so that someone can
1083             # pass in non scalar data to XMLSubs args like:
1084             # <my:tag data="<%= [ 'data' ] %>" />
1085             # As long as the <%= %> bits are flush against the
1086             #
1087 0         0 my @value_bits;
1088 0         0 while($value =~ s/^(.*?)<\%\=(.*?)\%\>/
1089 0 0       0 {
  0         0  
1090 0         0 length($1) && push(@value_bits, "'$1'");
1091 0         0 push(@value_bits, "($2)");
1092             ''; # return nothing to replace with
1093             }
1094             /exs
1095 0         0 ) { 1 };
1096 0 0       0 length($value) && push(@value_bits, "'$value'");
1097 0         0 $args{$key} = join('.', @value_bits);
1098             }
1099 0         0 $args = join(', ', map { "'$_' => $args{$_}" } keys %args);
  0         0  
1100                 }
1101              
1102             # print STDERR "ARGS: $args\n";
1103 0         0     $args;
1104             }
1105              
1106             sub PodComments {
1107 38     38 1 368     my $data = $_[1];
1108                 
1109             # we do a little extra work to sync pod comment lines up, we do this
1110             # by wiping out the pod comments, and replacing them with the equivalent
1111             # number of newlines
1112 38         934     $$data =~ s/\015?\012/\n/sgo;
1113 38         576     $$data =~ s,(^|\n)(\=pod\n.*?\n\=cut\n),
1114 0         0 {
  0         0  
1115 0         0 my $pod = $1.$2;
1116 0         0 $pod =~ s/[^\n]+//sg;
1117             $pod;
1118             }
1119             ,sgex;
1120                 
1121 38         378     $data;
1122             }
1123              
1124             sub SearchDirs {
1125 47     47 0 491     my($self, $file) = @_;
1126 47 50       543     return unless defined $file;
1127              
1128 47         471     my $share_search;
1129 47 50       510     if($file =~ s/^Share:://) {
1130 0         0 $share_search = 1;
1131                 }
1132              
1133 47         525     my @includes_dir = @{$self->{includes_dir}};
  47         910  
1134 47 50       604     if($share_search) {
1135 0         0 push(@includes_dir, $ShareDir);
1136                 }
1137              
1138             # optimization for includes in tight for loops, a typical usage,
1139             # to save on the stats per request. This must occur after @include_dir
1140             # per lookup because @includes_dir may change during the request
1141             #
1142 47         1382     my $cache_key = join('||', $file, @includes_dir);
1143 47 100       2998     if(my $path = $self->{search_dirs_cache}{$cache_key}) {
1144             # $self->Debug("found $path search cached for $file, key $cache_key");
1145 24         323 return $path;
1146                 }
1147              
1148             # test & return if absolute
1149 23 50       1102     if($file =~ m,^/|^[a-zA-Z]\:,) {
1150 0 0 0     0 if(-e $file && ! -d _) {
1151 0         0 return $file;
1152             } else {
1153 0         0 return undef;
1154             }
1155                 }
1156              
1157 23         231     for my $dir (@includes_dir) {
1158 24         301 my $path = "$dir/$file";
1159 24         421 $path =~ s|/+|/|isg;
1160 24 100 66     885 if(-e $path && ! -d _) {
1161 22         286 $self->{search_dirs_cache}{$cache_key} = $path;
1162 22         323 return $path;
1163             }
1164                 }
1165              
1166 1         14     undef;
1167             }
1168              
1169             sub RegisterIncludes {
1170 0     0 0 0     my($self, $script) = @_;
1171              
1172             # compile includes at compile time, for prefork parse optimization
1173 0         0     my $copy = $$script;
1174 0         0     $copy =~ s/\$Response\-\>Include\([\'\"]([^\$]+?)[\'\"]/
1175 0         0 {
  0         0  
1176             my $include = $1;
1177 0 0       0 # prevent recursion
1178 0         0 unless($self->{register_includes}{$include}) {
1179 0         0 $self->{register_includes}{$include} = 1;
1180 0         0 local $self->{compile_error} = undef;
1181 0         0 local $self->{compile_eval} = undef;
  0         0  
1182 0 0       0 my $code = eval { $self->CompileInclude($include); };
1183 0 0       0 my $debug = $code ? "success" : "error: $@";
1184             $self->{dbg} && $self->Debug("register include $include with $debug");
1185 0         0 }
1186             '';
1187             }
1188             /exsgi;
1189             }
1190              
1191             sub CompileInclude {
1192 41     41 0 1211     my($self, $include, $package, $is_base_script) = @_;
1193 41         366     my($include_ref, $mtime, $subid);
1194              
1195 41         430     local $self->{use_strict} = $self->{use_strict};
1196 41 50       615     if($include =~ /^Share::/) {
1197             # Share:: components must always run under UseStrict
1198 0         0 $self->{use_strict} = 1;
1199                 }
1200                 
1201 41 100       503     if ( ref $include ) {
1202             # $self->{dbg} && $self->Debug("compiling scalar data $include for include");
1203 13         134 $include_ref = $include;
1204             # $include = $$include;
1205                 } else { # file here
1206 28 100       356 if($is_base_script) {
1207             # if its the base script being executed, then we already know
1208             # it exists because of earlier file tests, and do not need to
1209             # search for it
1210             #
1211             # leave $include alone
1212             } else {
1213             # streamlined, SearchDirs now caches per request
1214 12         129 my $file = &SearchDirs($self, $include);
1215 12 100       130 die("no include $include") unless defined $file;
1216 11         101 $include = $file;
1217             }
1218              
1219             # treat as anonymous subroutine compilation like data passed in
1220             # as a scalar ref as above if we have NoCache set
1221 27 50       389 if($self->{no_cache}) {
1222 0         0 $include = $self->ReadFile($include);
1223 0         0 $include_ref = $include;
1224 0         0 goto COMPILE_INCLUDE_PARSE;
1225             }
1226              
1227 27         514 my $id = &FileId($self, $include);
1228 27   66     531 $subid = ($package || $self->{GlobalASA}{'package'})."::$id".'xINC';
1229              
1230 27         492 my $compiled = $Apache::ASP::CompiledIncludes{$subid};
1231 27 50 66     392 if($compiled && ! $self->{stat_scripts}) {
1232 0 0       0 $self->{dbg} && $self->Debug("no stat: found cached code for include $id");
1233 0         0 return $compiled;
1234             }
1235            
1236             # return cached code if include hasn't been modified recently
1237 27         8215 $mtime = (stat($include))[9];
1238 27 100 66     370 if($compiled && ($compiled->{mtime} > $mtime)) {
1239             # $self->Debug("found cached code for include $id");
1240              
1241             # now check for changed includes, return if not changed
1242 4         38 my $includes_changed = 0;
1243 4 50       46 if(my $includes = $Apache::ASP::Includes{$include}) {
1244 0         0 for my $k (keys %$includes) {
1245 0   0     0 my $v = $includes->{$k} || 0;
1246 0         0 my @stat = stat($k);
1247 0 0       0 if(@stat) {
1248 0 0       0 if($stat[9] >= $v) {
1249 0 0       0 $self->{dbg} && $self->Debug("file $k mtime changed from $v to $stat[9]");
1250 0         0 $includes_changed = 1;
1251 0         0 last;
1252             }
1253             } else {
1254 0 0       0 $self->{dbg} && $self->Debug("can't get mtime for file $k: $!");
1255 0         0 $includes_changed = 1;
1256 0         0 last;
1257             }
1258             }
1259             }
1260              
1261 4 50       43 if(! $includes_changed) {
1262 4         56 return $compiled;
1263             } else {
1264 0 0       0 $self->{dbg} && $self->Debug("includes changed for $include, recompiling");
1265             }
1266             }
1267                 }
1268              
1269 36         465 COMPILE_INCLUDE_PARSE:
1270                 
1271                 my $parse_data = $self->Parse($include);
1272 36         360     my $no_cache = $self->{no_cache};
1273 36         317     my $data;
1274              
1275             # use Data::Dumper qw(Dumper);
1276             # print STDERR Dumper($include, $parse_data);
1277             # $self->Debug($self);
1278              
1279 36 100       1199     if ($parse_data->{is_perl}) {
    50          
1280 35         495        my $sub = $self->CompilePerl($parse_data->{data}, $subid, $package);
1281              
1282             # for perl with subs in it, do not cache the code compilation
1283             # to help prevent my closure problems for newbies, --jc 2/11/2003
1284 35 50       377        unless($no_cache) {
1285 35         456 $no_cache = $self->TestForSubs($parse_data->{data});
1286 35 100       407 if($no_cache) {
1287 3         38 $self->Debug("test for subs returned $no_cache, no_cache = $no_cache");
1288             }
1289                    }
1290              
1291 35 100       382        if ($sub) {
1292 34   66     979 $data = {
1293             mtime => time(),
1294             code => $sub,
1295                                 perl => $parse_data->{data},
1296             file => $include_ref || $include,
1297             };
1298                    }
1299                 } elsif($parse_data->{is_raw}) {
1300 1   33     45        $data = {
1301                             mtime => time(),
1302                             code => $parse_data->{data},
1303                             perl => $parse_data->{data},
1304                             file => $include_ref || $include,
1305                            };
1306                 } else {
1307 0         0 $data = undef;
1308                 }
1309              
1310 36 100 100     793     if ($data && $subid && ! $no_cache) { # for a returned code ref, don't cache
      100        
1311 20         229 $Apache::ASP::CompiledIncludes{$subid} = $data;
1312                 }
1313              
1314 36         541     $data;
1315             }
1316              
1317             sub UndefRoutine {
1318 23     23 0 514     my($self, $subid) = @_;
1319              
1320 23         332     my $code = \&{$subid};
  23         879  
1321 23 50       311     if($code) {
1322 23 100       488 $self->{dbg} && $self->Debug("undefing sub $subid code $code");
1323 23         258 undef(&$code); # method for perl 5.6.1
1324 23         229 undef($code);  # older perls ??
1325                 }
1326             }
1327              
1328             sub ReadFile {
1329 43     43 0 540     my($self, $file) = @_;
1330              
1331 43         410     local *READFILE;
1332 43 50       7457     open(READFILE, $file) || $self->Error("can't open file $file for reading");
1333 43         620     local $/ = undef;
1334 43         7452     my $data = <READFILE>;
1335 43         990     close READFILE;
1336              
1337 43         1275     \$data;
1338             }
1339              
1340             # if the $file is an absolute path, then just return the file
1341             # if the $file is a relative path, concat it with the passed in directory
1342             sub AbsPath {
1343 18     18 0 197