home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / GlobalASA.pm < prev    next >
Encoding:
Perl POD Document  |  2002-12-06  |  8.2 KB  |  284 lines
  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. use strict;
  10. no strict qw(refs);
  11. use vars qw(%stash *stash @ISA @Routines);
  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.     my $asp = shift || die("no asp passed to GlobalASA");
  30.  
  31.     my $filename = $asp->{global}.'/global.asa';
  32.     my $id = &Apache::ASP::FileId($asp, $asp->{global}, undef, 1);
  33.     my $package = $asp->{global_package} ? $asp->{global_package} : "Apache::ASP::Compiles::".$id;
  34.     $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.     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.     $asp->{GlobalASA} = $self;
  49.  
  50.     $asp->{dbg} && $asp->Debug("GlobalASA package $self->{'package'}");
  51.     my $compiled = $Apache::ASP::Compiled{$id};
  52.     if($compiled && ! $asp->{stat_scripts}) {
  53.  
  54. #    $asp->{dbg} && $asp->Debug("no stat: GlobalASA already compiled");
  55.     $self->{'exists'} = $compiled->{'exists'};
  56.     $self->{'compiled'} = $compiled; # for event lookups
  57.     return $self;
  58.     }
  59.  
  60.     if($compiled) {
  61. #    $asp->{dbg} && $asp->Debug("global.asa was cached for $id");
  62.     } else {
  63.     $asp->{dbg} && $asp->Debug("global.asa was not cached for $id");
  64.     $compiled = $Apache::ASP::Compiled{$id} = { mtime => 0, 'exists' => 0 };
  65.     }
  66.     $self->{compiled} = $compiled;
  67.     
  68.     my $exists = $self->{'exists'} = -e $filename;
  69.     my $changed = 0;
  70.     if(! $exists && ! $compiled->{'exists'}) {
  71.     # fastest exit for simple case of no global.asa
  72.     return $self;
  73.     } elsif(! $exists && $compiled->{'exists'}) {
  74.     # if the global.asa disappeared
  75.     $changed = 1;
  76.     } elsif($exists && ! $compiled->{'exists'}) {
  77.     # if global.asa reappeared
  78.     $changed = 1;
  79.     } else {
  80.     $self->{mtime} = $exists ? (stat(_))[9] : 0;
  81.     if($self->{mtime} > $compiled->{mtime}) {
  82.         # if the modification time is greater than the compile time
  83.         $changed = 1;
  84.     }
  85.     }
  86.     $changed || return($self);
  87.  
  88.     my $code = $exists ? ${$asp->ReadFile($filename)} : "";
  89.     my $strict = $asp->{use_strict} ? "use strict" : "no strict";
  90.  
  91.     if($code =~ s/\<script[^>]*\>((.*)\s+sub\s+($match_events).*)\<\/script\>/$1/isg) {
  92.     $asp->Debug("script tags removed from $filename for IIS PerlScript compatibility");
  93.     }
  94.     $code = (
  95.          "\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.     $asp->{dbg} && $asp->Debug("compiling global.asa $self->{'package'} $id exists $exists", $self, '---', $compiled);
  109.     $code =~ /^(.*)$/s;
  110.     $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.     local $^W = 0;
  118.  
  119.     # only way to catch strict errors here    
  120.     if($asp->{use_strict}) { 
  121.     local $SIG{__WARN__} = sub { die("maybe use strict error: ", @_) };
  122.     eval $code;
  123.     } else {
  124.     eval $code;
  125.     }
  126.  
  127.     # if we have success compiling, then update the compile time
  128.     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.     $compiled->{mtime} = $self->{mtime} || (stat($filename))[9];
  133.     
  134.     # remember whether the file really exists
  135.     $compiled->{'exists'} = $exists;
  136.     
  137.     # we cache whether the code was compiled so we can do quick
  138.     # lookups before executing it
  139.     my $routines = {};
  140.     local *stash = *{"$self->{'package'}::"};
  141.     for(@Routines) {
  142.         if($stash{$_}) {
  143.         $routines->{$_} = 1;
  144.         }
  145.     }
  146.     $compiled->{'routines'} = $routines;
  147.     $asp->Debug('global.asa routines', $routines);
  148.     $self->{'compiled'} = $compiled;
  149.     } else {
  150.     $asp->CompileErrorThrow($code, "errors compiling global.asa: $@");
  151.     }
  152.  
  153.     $self;
  154. }
  155.  
  156. sub IsCompiled {
  157.     my($self, $routine) = @_;
  158.     $self->{'compiled'}{routines}{$routine};
  159. }
  160.  
  161. sub ExecuteEvent {
  162.     my($self, $event) = @_;
  163.     if($self->{'compiled'}{routines}{$event}) {
  164.     $self->{'asp'}->Execute($event);
  165.     }
  166. }
  167.  
  168. sub SessionOnStart {
  169.     my $self = shift;
  170.     my $asp = $self->{asp};
  171.     my $zero_sessions = 0;
  172.  
  173.     if($asp->{session_count}) {
  174.     $asp->{Internal}->LOCK();
  175.     my $session_count = $asp->{Internal}{SessionCount} || 0;
  176.     if($session_count <= 0) {
  177.         $asp->{Internal}{SessionCount} = 1;    
  178.         $zero_sessions = 1;
  179.     } else {
  180.         $asp->{Internal}{SessionCount} = $session_count + 1;
  181.     }
  182.     $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.     $asp->Debug("Session_OnStart", {session => $asp->{Session}->SessionID});
  193.     $self->ExecuteEvent('Session_OnStart');
  194. }
  195.  
  196. sub SessionOnEnd {
  197.     my($self, $id) = @_;
  198.     my $asp = $self->{asp};
  199.     my $internal = $asp->{Internal};
  200.  
  201.     # session count tracking
  202.     if($asp->{session_count}) {
  203.     $internal->LOCK();
  204.     if((my $count = $internal->{SessionCount}) > 0) {
  205.         $internal->{SessionCount} = $count - 1;
  206.     } else {
  207.         $internal->{SessionCount} = 0;
  208.     }        
  209.     $internal->UNLOCK();
  210.     }
  211.  
  212.     # only retie session if there is a Session_OnEnd event to execute
  213.     if($self->IsCompiled('Session_OnEnd')) {
  214.     my $old_session = $asp->{Session};
  215.     my $dead_session;
  216.     if($id) {
  217.         $dead_session = &Apache::ASP::Session::new($asp, $id);
  218.         $asp->{Session} = $dead_session;
  219.     } else {
  220.         $dead_session = $old_session;
  221.     }
  222.     
  223.     $asp->{dbg} && $asp->Debug("Session_OnEnd", {session => $dead_session->SessionID()});
  224.     $self->ExecuteEvent('Session_OnEnd');
  225.     $asp->{Session} = $old_session;
  226.     
  227.     if($id) {
  228.         untie %{$dead_session};
  229.     }
  230.     }
  231.  
  232.     1;
  233. }
  234.  
  235. sub ApplicationOnStart {
  236.     my $self = shift;
  237.     $self->{asp}->Debug("Application_OnStart");
  238.     %{$self->{asp}{Application}} = (); 
  239.     $self->ExecuteEvent('Application_OnStart');
  240. }
  241.  
  242. sub ApplicationOnEnd {
  243.     my $self = shift;
  244.     my $asp = $self->{asp};
  245.     $asp->Debug("Application_OnEnd");
  246.     $self->ExecuteEvent('Application_OnEnd');
  247.     %{$self->{asp}{Application}} = (); 
  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.     my $self = shift;
  263.     $self->{asp}{dbg} && $self->{asp}->Debug("Script_OnStart");
  264.     $self->ExecuteEvent('Script_OnStart');
  265. }
  266.  
  267. sub ScriptOnEnd {
  268.     my $self = shift;
  269.     $self->{asp}{dbg} && $self->{asp}->Debug("Script_OnEnd");
  270.     $self->ExecuteEvent('Script_OnEnd');
  271. }
  272.  
  273. sub ScriptOnFlush {
  274.     my $self = shift;
  275.     $self->{asp}{dbg} && $self->{asp}->Debug("Script_OnFlush");
  276.     $self->ExecuteEvent('Script_OnFlush');
  277. }
  278.  
  279. sub EventsList {
  280.     @Routines;
  281. }
  282.  
  283. 1;
  284.