← Back to branch summary

~ubuntu-branches/ubuntu/edgy/libapache2-mod-perl2/edgy

« back to all changes in this revision

Viewing changes to lib/Apache/porting.pm

  • Committer: Bazaar Package Importer
  • Author(s): Andres Salomon
  • Date: 2005-08-12 01:40:38 UTC
  • mfrom: (1.1.2 upstream) (2.1.1 sarge)
  • Revision ID: james.westby@ubuntu.com-20050812014038-gjigefs55pqx4qc8
Tags: 2.0.1-3
Grr.  Really include perl.conf file; it got lost due to diff not
wanting to add an empty file.

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/Apache/porting.pm
1
 
# Copyright 2003-2004 The Apache Software Foundation
2
 
#
3
 
# Licensed under the Apache License, Version 2.0 (the "License");
4
 
# you may not use this file except in compliance with the License.
5
 
# You may obtain a copy of the License at
6
 
#
7
 
#     http://www.apache.org/licenses/LICENSE-2.0
8
 
#
9
 
# Unless required by applicable law or agreed to in writing, software
10
 
# distributed under the License is distributed on an "AS IS" BASIS,
11
 
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
12
 
# See the License for the specific language governing permissions and
13
 
# limitations under the License.
14
 
#
15
 
package Apache::porting;
16
 
 
17
 
use strict;
18
 
use warnings FATAL => 'all';
19
 
 
20
 
use Carp 'croak';
21
 
 
22
 
use ModPerl::MethodLookup ();
23
 
use Apache::ServerUtil;
24
 
 
25
 
use Apache::Const -compile => 'OK';
26
 
 
27
 
our $AUTOLOAD;
28
 
 
29
 
### methods ###
30
 
# handle:
31
 
# - removed and replaced methods
32
 
# - hinting the package names in which methods reside
33
 
 
34
 
my %avail_methods = map { $_ => 1 } 
35
 
    (ModPerl::MethodLookup::avail_methods(),
36
 
     ModPerl::MethodLookup::avail_methods_compat());
37
 
 
38
 
# XXX: unfortunately it doesn't seem to be possible to install
39
 
# *UNIVERSAL::AUTOLOAD at the server startup, httpd segfaults,
40
 
# child_init seems to be the first stage where it works.
41
 
Apache->server->push_handlers(PerlChildInitHandler => \&porting_autoload);
42
 
 
43
 
sub porting_autoload {
44
 
    *UNIVERSAL::AUTOLOAD = sub {
45
 
        # This is a porting module, no compatibility layers are allowed in
46
 
        # this zone
47
 
        croak("Apache::porting can't be used with Apache::compat")
48
 
            if exists $ENV{"Apache/compat.pm"};
49
 
 
50
 
        (my $method = $AUTOLOAD) =~ s/.*:://;
51
 
 
52
 
        # we skip DESTROY methods
53
 
        return if $method eq 'DESTROY';
54
 
 
55
 
        # we don't handle methods that we don't know about
56
 
        croak "Undefined subroutine $AUTOLOAD called"
57
 
            unless defined $method && exists $avail_methods{$method};
58
 
 
59
 
        my ($hint, @modules) =
60
 
            ModPerl::MethodLookup::lookup_method($method, @_);
61
 
        $hint ||= "Can't find method $AUTOLOAD";
62
 
        croak $hint;
63
 
    };
64
 
 
65
 
    return Apache::OK;
66
 
}
67
 
 
68
 
### packages ###
69
 
# handle:
70
 
# - removed and replaced packages
71
 
 
72
 
my %packages = (
73
 
     'Apache::Constants' => [qw(Apache::Const)],
74
 
     'Apache::Table'     => [qw(APR::Table)],
75
 
     'Apache::File'      => [qw(Apache::Response Apache::RequestRec)],
76
 
     'Apache'            => [qw(ModPerl::Util Apache::Module)],
77
 
);
78
 
 
79
 
BEGIN {
80
 
    sub my_require {
81
 
        my $package = $_[0];
82
 
        $package =~ s|/|::|g;
83
 
        $package =~ s|.pm$||;
84
 
 
85
 
        # this picks the original require (which could be overriden
86
 
        # elsewhere, so we don't lose that) because we haven't
87
 
        # overriden it yet
88
 
        return require $_[0] unless $packages{$package};
89
 
 
90
 
        my $msg = "mod_perl 2.0 API doesn't include package '$package'.";
91
 
        my @replacements = @{ $packages{$package}||[] };
92
 
        if (@replacements) {
93
 
            $msg .= " The package '$package' has moved to " .
94
 
                join " ", map qq/'$_'/, @replacements;
95
 
        }
96
 
        croak $msg;
97
 
    };
98
 
 
99
 
    *CORE::GLOBAL::require = sub (*) { my_require($_[0])};
100
 
}
101
 
 
102
 
1;