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 / StatINC.pm < prev    next >
Encoding:
Perl POD Document  |  2002-10-31  |  6.7 KB  |  224 lines
  1.  
  2. package Apache::ASP;
  3.  
  4. # quickly decomped out of Apache::ASP just to optionally load
  5. # it at runtime for CGI programs ( which shouldn't need it anyway )
  6. # will still precompile this for mod_perl
  7.  
  8. use strict;
  9. use vars qw( $StatINCReady $StatINCInit %Stat $StatStartTime );
  10.  
  11. $StatStartTime = time();
  12.  
  13. # Apache::StatINC didn't quite work right, so writing own
  14. sub StatINCRun {
  15.     my $self = shift;
  16.     my $stats = 0;
  17.  
  18.     # include necessary libs, without nice error message...
  19.     # we only do this once if successful, to speed up code a bit,
  20.     # and load success bool into global. otherwise keep trying
  21.     # to generate consistent error messages
  22.     unless($StatINCReady) {
  23.     my $ready = 1;
  24.     for('Devel::Symdump') {
  25.         eval "use $_";
  26.         if($@) {
  27.         $ready = 0;
  28.         $self->Error("You need $_ to use StatINC: $@ ... ".
  29.                  "Please download it from your nearest CPAN");
  30.         }
  31.     }
  32.     $StatINCReady = $ready;
  33.     }
  34.     return unless $StatINCReady;
  35.     
  36.     # make sure that we have pre-registered all the modules before
  37.     # this only happens on the first request of a new process
  38.     unless($StatINCInit) {
  39.     $StatINCInit = 1;
  40.     $self->Debug("statinc init");
  41.     $self->StatRegisterAll();    
  42.     }
  43.  
  44.     while(my($key,$file) = each %INC) {
  45.     if($self->{stat_inc_match} && defined $Stat{$file}) {
  46.         # we skip only if we have already registered this file
  47.         # we need to register the codes so we don't undef imported symbols
  48.         next unless ($key =~ /$self->{stat_inc_match}/);
  49.     }
  50.  
  51.     next unless (-e $file); # sometimes there is a bad file in the %INC
  52.     my $mtime = (stat($file))[9];
  53.  
  54.     # its ok if this block is CPU intensive, since it should only happen
  55.     # when modules get changed, and that should be infrequent on a production site
  56.     if(! defined $Stat{$file}) {
  57.         $self->{dbg} && $self->Debug("loading symbols first time", { $key => $file});
  58.         $self->StatRegister($key, $file, $mtime);        
  59.     } elsif($mtime > $Stat{$file}) {
  60.         $self->{dbg} && $self->Debug("reloading", {$key => $file});
  61.         $stats++; # count files we have reloaded
  62.         $self->StatRegisterAll();
  63.         
  64.         # we need to explicitly re-register a namespace that 
  65.         # we are about to undef, in case any imports happened there
  66.         # since last we checked, so we don't delete duplicate symbols
  67.         $self->StatRegister($key, $file, $mtime);
  68.  
  69.         my $class = &File2Class($key);
  70.         my $sym = Devel::Symdump->new($class);
  71.  
  72.         my $function;
  73.         my $is_global_package = $class eq $self->{GlobalASA}{'package'} ? 1 : 0;
  74.         my @global_events_list = $self->{GlobalASA}->EventsList;
  75.  
  76.         for $function ($sym->functions()) {
  77.         my $code = \&{$function};
  78.  
  79.         if($function =~ /::O_[^:]+$/) {
  80.             $self->Debug("skipping undef of troublesome $function");
  81.             next;
  82.         }
  83.  
  84.         if($Apache::ASP::Codes{$code}{count} > 1) {
  85.             $self->Debug("skipping undef of multiply defined $function: $code");
  86.             next;
  87.         }
  88.  
  89.         if($is_global_package) {
  90.             # skip undef if id is an include or script 
  91.             if($function =~ /::__ASP_/) {
  92.             $self->Debug("skipping undef compiled ASP sub $function");
  93.             next;
  94.             }
  95.  
  96.             if(grep($function eq $class."::".$_, @global_events_list)) {
  97.             $self->Debug("skipping undef global event $function");
  98.             next;
  99.             }
  100.  
  101.             if($Apache::ASP::ScriptSubs{$function}) {
  102.             $self->Debug("skipping undef script subroutine $function");
  103.             next;
  104.             }
  105.  
  106.         }
  107.  
  108.         $self->{dbg} && $self->Debug("undef code $function: $code");
  109.  
  110.         undef(&$code); # method for perl 5.6.1
  111.         delete $Apache::ASP::Codes{$code};
  112.         undef($code);  # older perls
  113.         }
  114.  
  115.         # extract the lib, just incase our @INC went away
  116.         (my $lib = $file) =~ s/$key$//g;
  117.         push(@INC, $lib);
  118.  
  119.         # don't use "use", since we don't want symbols imported into ASP
  120.         delete $INC{$key};
  121.         $self->Debug("loading $key with require");
  122.         eval { require($key); }; 
  123.         if($@) {
  124.         $INC{$key} = $file; # make sure we keep trying to reload it
  125.         $self->Error("can't require/reload $key: $@");
  126.         next;
  127.         }
  128.  
  129.         # if this was the same module as the global.asa package,
  130.         # then we need to reload the global.asa, since we just 
  131.         # undef'd the subs
  132.         if($is_global_package) {
  133.         # we just undef'd the global.asa routines, so these too 
  134.         # must be recompiled
  135.         $self->Debug("reloading global.asa file after clearing package namespace");
  136.         delete $Apache::ASP::Compiled{$self->{GlobalASA}{'id'}};
  137.         &Apache::ASP::GlobalASA::new($self);
  138.         }
  139.  
  140.         $self->StatRegister($key, $file, $mtime);
  141.  
  142.         # we want to register INC now in case any new libs were
  143.         # added when this module was reloaded
  144.         $self->StatRegisterAll();
  145.     }
  146.     }
  147.  
  148.     $stats;
  149. }
  150.  
  151. sub StatRegister {
  152.     my($self, $key, $file, $mtime) = @_;
  153.  
  154.     # keep track of times
  155.     $Stat{$file} = $mtime; 
  156.     
  157.     # keep track of codes, don't undef on codes
  158.     # with multiple refs, since these are exported
  159.     my $class = &File2Class($key);
  160.  
  161.     # we skip Apache stuff as on some platforms (RedHat 6.0)
  162.     # Apache::OK seems to error when getting its code ref
  163.     # these shouldn't be reloaded anyway, as they are internal to 
  164.     # modperl and should require a full server restart
  165.     if($class eq 'Apache' or $class eq 'Apache::Constants') {
  166.     $self->Debug("skipping StatINC register of $class");
  167.     return;
  168.     }
  169.  
  170.     $self->{dbg} && $self->Debug("stat register of $key $file $class");
  171.     if($class eq 'CGI') {
  172.     # must compensate for its autoloading behavior, and 
  173.     # precompile all the routines, so we can register them
  174.     # and not delete them later
  175.     CGI->compile(':all');
  176.     }
  177.  
  178.     my $sym = Devel::Symdump->new($class);
  179.     my $function;
  180.     for $function ($sym->functions()) {
  181.     my $code = \&{$function};
  182.     unless($code =~ /CODE/) {
  183.         $self->Debug("no code ref for function $function");
  184.         next;
  185.     }
  186.  
  187.     # don't update if we already have this code defined for this func.
  188.     next if $Apache::ASP::Codes{$code}{funcs}{$function}; 
  189.  
  190. #    $self->Debug("code $code for $function");
  191.     $Apache::ASP::Codes{$code}{count}++;
  192.     $Apache::ASP::Codes{$code}{libs}{$key}++;
  193.     $Apache::ASP::Codes{$code}{funcs}{$function}++;
  194.     }
  195.  
  196.     1;
  197. }
  198.  
  199. sub StatRegisterAll {
  200.     my $self = shift;
  201.     # we make sure that all modules that are loaded are registered
  202.     # so we don't undef exported subroutines, when we reload 
  203.     my($key, $file);
  204.     while(($key,$file) = each %INC) {
  205.     next if defined $Stat{$file};
  206.     next unless -e $file;
  207.     # we use the module load time to init, in case it was
  208.     # pulled in with PerlModule, and has changed since,
  209.     # so it won't break with a graceful restart
  210.     $self->StatRegister($key, $file, $StatStartTime - 1);
  211.     }
  212.  
  213.     1;
  214. }
  215.  
  216. sub File2Class {
  217.     my $file = shift;
  218.     return $file unless $file =~ s,\.pm$,,;
  219.     $file =~ s,/,::,g;
  220.     $file;
  221. }
  222.  
  223. 1;
  224.