File Coverage

blib/lib/Apache/ASP/GlobalASA.pm
Criterion Covered Total %
statement 80 127 63.0
branch 37 60 61.7
condition 8 19 42.1
subroutine 10 15 66.7
pod 0 11 0.0
total 135 232 58.2


line stmt bran cond sub pod time code
1              
2             package Apache::ASP::GlobalASA;
3              
4             # GlobalASA Object
5             # global.asa processes, whether or not there is a global.asa file.
6             # if there is not one, the code is left blank, and empty routines
7             # are filled in
8              
9 14     14   235 use strict;
  14         191  
  14         371  
10 14     14   269 no strict qw(refs);
  14         251  
  14         250  
11 14     14   246 use vars qw(%stash *stash @ISA @Routines);
  14         215  
  14         243  
12              
13             # these define the default routines that get parsed out of the
14             # GLOBAL.ASA file
15             @Routines =
16                 (
17                  "Application_OnStart",
18                  "Application_OnEnd",
19                  "Session_OnStart",
20                  "Session_OnEnd",
21                  "Script_OnStart",
22                  "Script_OnEnd",
23                  "Script_OnParse",
24                  "Script_OnFlush"
25                  );
26             my $match_events = join('|', @Routines);
27              
28             sub new {
29 18   50 18 0 276     my $asp = shift || die("no asp passed to GlobalASA");
30              
31 18         256     my $filename = $asp->{global}.'/global.asa';
32 18         309     my $id = &Apache::ASP::FileId($asp, $asp->{global}, undef, 1);
33 18 50       650     my $package = $asp->{global_package} ? $asp->{global_package} : "Apache::ASP::Compiles::".$id;
34 18         263     $id .= 'x'.$package; # need to recompile when either file or namespace changes
35              
36             # make sure that when either the file or package changes, that we
37             # update the global.asa compilation
38              
39 18         317     my $self = bless {
40             asp => $asp,
41             'package' => $package,
42             # filename => $filename,
43             # id => $id,
44                 };
45              
46             # assign early, since something like compiling reference the global asa,
47             # and we need to do that in here
48 18         192     $asp->{GlobalASA} = $self;
49              
50 18 100       433     $asp->{dbg} && $asp->Debug("GlobalASA package $self->{'package'}");
51 18         578     my $compiled = $Apache::ASP::Compiled{$id};
52 18 50 66     665     if($compiled && ! $asp->{stat_scripts}) {
53              
54             # $asp->{dbg} && $asp->Debug("no stat: GlobalASA already compiled");
55 0         0 $self->{'exists'} = $compiled->{'exists'};
56 0         0 $self->{'compiled'} = $compiled; # for event lookups
57 0         0 return $self;
58                 }
59              
60 18 100       371     if($compiled) {
61             # $asp->{dbg} && $asp->Debug("global.asa was cached for $id");
62                 } else {
63 12 100       413 $asp->{dbg} && $asp->Debug("global.asa was not cached for $id");
64 12         168 $compiled = $Apache::ASP::Compiled{$id} = { mtime => 0, 'exists' => 0 };
65                 }
66 18         252     $self->{compiled} = $compiled;
67                 
68 18         618     my $exists = $self->{'exists'} = -e $filename;
69 18         172     my $changed = 0;
70 18 50 33     748     if(! $exists && ! $compiled->{'exists'}) {
    50 33        
    100 66        
71             # fastest exit for simple case of no global.asa
72 0         0 return $self;
73                 } elsif(! $exists && $compiled->{'exists'}) {
74             # if the global.asa disappeared
75 0         0 $changed = 1;
76                 } elsif($exists && ! $compiled->{'exists'}) {
77             # if global.asa reappeared
78 12         119 $changed = 1;
79                 } else {
80 6 50       130 $self->{mtime} = $exists ? (stat(_))[9] : 0;
81 6 50       96 if($self->{mtime} > $compiled->{mtime}) {
82             # if the modification time is greater than the compile time
83 0         0 $changed = 1;
84             }
85                 }
86 18 100       475     $changed || return($self);
87              
88 12 50       164     my $code = $exists ? ${$asp->ReadFile($filename)} : "";
  12         254  
89 12 100       498     my $strict = $asp->{use_strict} ? "use strict" : "no strict";
90              
91 12 100       6954     if($code =~ s/\<script[^>]*\>((.*)\s+sub\s+($match_events).*)\<\/script\>/$1/isg) {
92 10         177 $asp->Debug("script tags removed from $filename for IIS PerlScript compatibility");
93                 }
94                 $code = (
95 12         722 "\n#line 1 $filename\n".
96             join(" ;; ",
97             "package $self->{'package'};",
98             $strict,
99             "use vars qw(\$".join(" \$",@Apache::ASP::Objects).');',
100             "use lib qw($self->{asp}->{global});",
101             $code,
102             'sub exit { $main::Response->End(); } ',
103             "no lib qw($self->{asp}->{global});",
104             '1;',
105             )
106             );
107              
108 12 100       326     $asp->{dbg} && $asp->Debug("compiling global.asa $self->{'package'} $id exists $exists", $self, '---', $compiled);
109 12         779     $code =~ /^(.*)$/s;
110 12         210     $code = $1;
111              
112             # turn off $^W to suppress warnings about reloading subroutines
113             # which is a valid use of global.asa. We cannot just undef
114             # all the events possible in global.asa, as global.asa can be
115             # used as a general package library for the web application
116             # --jc, 9/6/2002
117 12         167     local $^W = 0;
118              
119             # only way to catch strict errors here
120 12 100       1161     if($asp->{use_strict}) {
121 4     0   976 local $SIG{__WARN__} = sub { die("maybe use strict error: ", @_) };
  0         0  
122 4         54 eval $code;
123                 } else {
124 8         312 eval $code;
125                 }
126              
127             # if we have success compiling, then update the compile time
128 12 50       174     if(! $@) {
129             # if file mod times are bad, we need to use them anyway
130             # for relative comparison, time() was used here before, but
131             # doesn't work
132 12   33     1047 $compiled->{mtime} = $self->{mtime} || (stat($filename))[9];
133            
134             # remember whether the file really exists
135 12         179 $compiled->{'exists'} = $exists;
136            
137             # we cache whether the code was compiled so we can do quick
138             # lookups before executing it
139 12         149 my $routines = {};
140 12         119 local *stash = *{"$self->{'package'}::"};
  12         205  
141 12         133 for(@Routines) {
142 96 100       1360 if($stash{$_}) {
143 52         670 $routines->{$_} = 1;
144             }
145             }
146 12         157 $compiled->{'routines'} = $routines;
147 12         270 $asp->Debug('global.asa routines', $routines);
148 12         168 $self->{'compiled'} = $compiled;
149                 } else {
150 0         0 $asp->CompileErrorThrow($code, "errors compiling global.asa: $@");
151                 }
152              
153 12         274     $self;
154             }
155              
156             sub IsCompiled {
157 0     0 0 0     my($self, $routine) = @_;
158 0         0     $self->{'compiled'}{routines}{$routine};
159             }
160              
161             sub ExecuteEvent {
162 90     90 0 986     my($self, $event) = @_;
163 90 100       1431     if($self->{'compiled'}{routines}{$event}) {
164 37         512 $self->{'asp'}->Execute($event);
165                 }
166             }
167              
168             sub SessionOnStart {
169 7     7 0 255     my $self = shift;
170 7         91     my $asp = $self->{asp};
171 7         65     my $zero_sessions = 0;
172              
173 7 50       91     if($asp->{session_count}) {
174 0         0 $asp->{Internal}->LOCK();
175 0   0     0 my $session_count = $asp->{Internal}{SessionCount} || 0;
176 0 0       0 if($session_count <= 0) {
177 0         0 $asp->{Internal}{SessionCount} = 1;
178 0         0 $zero_sessions = 1;
179             } else {
180 0         0 $asp->{Internal}{SessionCount} = $session_count + 1;
181             }
182 0         0 $asp->{Internal}->UNLOCK();
183                 }
184              
185             #X: would like to run application startup code here after
186             # zero sessions is true, but doesn't seem to account for
187             # case of busy server, then 10 minutes later user comes in...
188             # since group cleanup happens after session, Application
189             # never starts. Its only when a user times out his own
190             # session, and comes back that this code would kick in.
191                 
192 7         111     $asp->Debug("Session_OnStart", {session => $asp->{Session}->SessionID});
193 7         1929     $self->ExecuteEvent('Session_OnStart');
194             }
195              
196             sub SessionOnEnd {
197 0     0 0 0     my($self, $id) = @_;
198 0         0     my $asp = $self->{asp};
199 0         0     my $internal = $asp->{Internal};
200              
201             # session count tracking
202 0 0       0     if($asp->{session_count}) {
203 0         0 $internal->LOCK();
204 0 0       0 if((my $count = $internal->{SessionCount}) > 0) {
205 0         0 $internal->{SessionCount} = $count - 1;
206             } else {
207 0         0 $internal->{SessionCount} = 0;
208             }
209 0         0 $internal->UNLOCK();
210                 }
211              
212             # only retie session if there is a Session_OnEnd event to execute
213 0 0       0     if($self->IsCompiled('Session_OnEnd')) {
214 0         0 my $old_session = $asp->{Session};
215 0         0 my $dead_session;
216 0 0       0 if($id) {
217 0         0 $dead_session = &Apache::ASP::Session::new($asp, $id);
218 0         0 $asp->{Session} = $dead_session;
219             } else {
220 0         0 $dead_session = $old_session;
221             }
222            
223 0 0       0 $asp->{dbg} && $asp->Debug("Session_OnEnd", {session => $dead_session->SessionID()});
224 0         0 $self->ExecuteEvent('Session_OnEnd');
225 0         0 $asp->{Session} = $old_session;
226            
227 0 0       0 if($id) {
228 0         0 untie %{$dead_session};
  0         0  
229             }
230                 }
231              
232 0         0     1;
233             }
234              
235             sub ApplicationOnStart {
236 1     1 0 9     my $self = shift;
237 1         14     $self->{asp}->Debug("Application_OnStart");
238 1         9     %{$self->{asp}{Application}} = ();
  1         29  
239 1         16     $self->ExecuteEvent('Application_OnStart');
240             }
241              
242             sub ApplicationOnEnd {
243 0     0 0 0     my $self = shift;
244 0         0     my $asp = $self->{asp};
245 0         0     $asp->Debug("Application_OnEnd");
246 0         0     $self->ExecuteEvent('Application_OnEnd');
247 0         0     %{$self->{asp}{Application}} = ();
  0         0  
248              
249             # PROBLEM, since we are not resetting ASP objects
250             # every execute now, useless code anyway
251              
252             # delete $asp->{Internal}{'application'};
253             # local $^W = 0;
254             # my $tied = tied %{$asp->{Application}};
255             # untie %{$asp->{Application}};
256             # $tied->DESTROY(); # call explicit DESTROY
257             # $asp->{Application} = &Apache::ASP::Application::new($self->{asp})
258             # || $self->Error("can't get application state");
259             }
260              
261             sub ScriptOnStart {
262 16     16 0 170     my $self = shift;
263 16 100       325     $self->{asp}{dbg} && $self->{asp}->Debug("Script_OnStart");
264 16         239     $self->ExecuteEvent('Script_OnStart');
265             }
266              
267             sub ScriptOnEnd {
268 16     16 0 153     my $self = shift;
269 16 100       749     $self->{asp}{dbg} && $self->{asp}->Debug("Script_OnEnd");
270 16         196     $self->ExecuteEvent('Script_OnEnd');
271             }
272              
273             sub ScriptOnFlush {
274 14     14 0 128     my $self = shift;
275 14 100       198     $self->{asp}{dbg} && $self->{asp}->Debug("Script_OnFlush");
276 14         192     $self->ExecuteEvent('Script_OnFlush');
277             }
278              
279             sub EventsList {
280 0     0 0       @Routines;
281             }
282              
283             1;
284