home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / porting.pm < prev    next >
Encoding:
Perl POD Document  |  2003-08-08  |  2.5 KB  |  89 lines
  1. package Apache::porting;
  2.  
  3. use strict;
  4. use warnings FATAL => 'all';
  5.  
  6. use Carp 'croak';
  7.  
  8. use ModPerl::MethodLookup ();
  9. use Apache::ServerUtil;
  10.  
  11. use Apache::Const -compile => 'OK';
  12.  
  13. our $AUTOLOAD;
  14.  
  15. ### methods ###
  16. # handle:
  17. # - removed and replaced methods
  18. # - hinting the package names in which methods reside
  19.  
  20. my %avail_methods = map { $_ => 1 } 
  21.     (ModPerl::MethodLookup::avail_methods(),
  22.      ModPerl::MethodLookup::avail_methods_compat());
  23.  
  24. # XXX: unfortunately it doesn't seem to be possible to install
  25. # *UNIVERSAL::AUTOLOAD at the server startup, httpd segfaults,
  26. # child_init seems to be the first stage where it works.
  27. Apache->server->push_handlers(PerlChildInitHandler => \&porting_autoload);
  28.  
  29. sub porting_autoload {
  30.     *UNIVERSAL::AUTOLOAD = sub {
  31.         # This is a porting module, no compatibility layers are allowed in
  32.         # this zone
  33.         croak("Apache::porting can't be used with Apache::compat")
  34.             if exists $ENV{"Apache/compat.pm"};
  35.  
  36.         (my $method = $AUTOLOAD) =~ s/.*:://;
  37.  
  38.         # we skip DESTROY methods
  39.         return if $method eq 'DESTROY';
  40.  
  41.         # we don't handle methods that we don't know about
  42.         croak "Undefined subroutine $AUTOLOAD called"
  43.             unless defined $method && exists $avail_methods{$method};
  44.  
  45.         my ($hint, @modules) =
  46.             ModPerl::MethodLookup::lookup_method($method, @_);
  47.         $hint ||= "Can't find method $AUTOLOAD";
  48.         croak $hint;
  49.     };
  50.  
  51.     return Apache::OK;
  52. }
  53.  
  54. ### packages ###
  55. # handle:
  56. # - removed and replaced packages
  57.  
  58. my %packages = (
  59.      'Apache::Constants' => [qw(Apache::Const)],
  60.      'Apache::Table'     => [qw(APR::Table)],
  61.      'Apache::File'      => [qw(Apache::Response Apache::RequestRec)],
  62.      'Apache'            => [qw(ModPerl::Util Apache::Module)],
  63. );
  64.  
  65. BEGIN {
  66.     sub my_require {
  67.         my $package = $_[0];
  68.         $package =~ s|/|::|g;
  69.         $package =~ s|.pm$||;
  70.  
  71.         # this picks the original require (which could be overriden
  72.         # elsewhere, so we don't lose that) because we haven't
  73.         # overriden it yet
  74.         return require $_[0] unless $packages{$package};
  75.  
  76.         my $msg = "mod_perl 2.0 API doesn't include package '$package'.";
  77.         my @replacements = @{ $packages{$package}||[] };
  78.         if (@replacements) {
  79.             $msg .= " The package '$package' has moved to " .
  80.                 join " ", map qq/'$_'/, @replacements;
  81.         }
  82.         croak $msg;
  83.     };
  84.  
  85.     *CORE::GLOBAL::require = sub (*) { my_require($_[0])};
  86. }
  87.  
  88. 1;
  89.