1# please insert nothing before this line: -*- mode: cperl; cperl-indent-level: 4; cperl-continued-statement-offset: 4; indent-tabs-mode: nil -*-
2# Licensed to the Apache Software Foundation (ASF) under one or more
3# contributor license agreements.  See the NOTICE file distributed with
4# this work for additional information regarding copyright ownership.
5# The ASF licenses this file to You under the Apache License, Version 2.0
6# (the "License"); you may not use this file except in compliance with
7# the License.  You may obtain a copy of the License at
8#
9#     http://www.apache.org/licenses/LICENSE-2.0
10#
11# Unless required by applicable law or agreed to in writing, software
12# distributed under the License is distributed on an "AS IS" BASIS,
13# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14# See the License for the specific language governing permissions and
15# limitations under the License.
16#
17package ModPerl::RegistryLoader;
18
19use strict;
20use warnings;
21
22use ModPerl::RegistryCooker ();
23use Apache2::ServerUtil ();
24use Apache2::Log ();
25use APR::Pool ();
26use APR::Finfo ();
27use APR::Const -compile=>qw(FINFO_MIN);
28
29use Carp;
30use File::Spec ();
31
32use Apache2::Const -compile => qw(OK HTTP_OK OPT_EXECCGI);
33
34our @ISA = ();
35
36sub new {
37    my $class = shift;
38    my $self = bless {@_} => ref($class)||$class;
39    $self->{package} ||= 'ModPerl::Registry';
40    $self->{pool} = APR::Pool->new();
41    $self->load_package($self->{package});
42    return $self;
43}
44
45sub handler {
46    my ($self, $uri, $filename, $virthost) = @_;
47
48    # set the inheritance rules at run time
49    @ISA = $self->{package};
50
51    unless (defined $uri) {
52        $self->warn("uri is a required argument");
53        return;
54    }
55
56    if (defined $filename) {
57        unless (-e $filename) {
58            $self->warn("Cannot find: $filename");
59            return;
60        }
61    }
62    else {
63        # try to translate URI->filename
64        if (exists $self->{trans} and ref($self->{trans}) eq 'CODE') {
65            no strict 'refs';
66            $filename = $self->{trans}->($uri);
67            unless (-e $filename) {
68                $self->warn("Cannot find a translated from uri: $filename");
69                return;
70            }
71        }
72        else {
73            # try to guess
74            (my $guess = $uri) =~ s|^/||;
75
76            $self->warn("Trying to guess filename based on uri")
77                if $self->{debug};
78
79            $filename = File::Spec->catfile(Apache2::ServerUtil::server_root,
80                                            $guess);
81            unless (-e $filename) {
82                $self->warn("Cannot find guessed file: $filename",
83                            "provide \$filename or 'trans' sub");
84                return;
85            }
86        }
87    }
88
89    if ($self->{debug}) {
90        $self->warn("*** uri=$uri, filename=$filename");
91    }
92
93    my $rl = bless {
94        uri      => $uri,
95        filename => $filename,
96        package  => $self->{package},
97    } => ref($self) || $self;
98
99    $rl->{virthost} = $virthost if defined $virthost;
100
101    # can't call SUPER::handler here, because it usually calls new()
102    # and then the ModPerlRegistryLoader::new() will get called,
103    # instead of the super class' new, so we implement the super
104    # class' handler here. Hopefully all other subclasses use the same
105    # handler.
106    __PACKAGE__->SUPER::new($rl)->default_handler();
107
108}
109
110# XXX: s/my_// for qw(my_finfo my_slurp_filename);
111# when when finfo() and slurp_filename() are ported to 2.0 and
112# RegistryCooker is starting to use them
113
114sub get_server_name { return $_[0]->{virthost} if exists $_[0]->{virthost} }
115sub filename { shift->{filename} }
116sub status   { Apache2::Const::HTTP_OK }
117sub pool     { shift->{pool}||=APR::Pool->new() }
118sub finfo    { $_[0]->{finfo}||=APR::Finfo::stat($_[0]->{filename},
119                                                 APR::Const::FINFO_MIN,
120                                                 $_[0]->pool); }
121sub uri      { shift->{uri} }
122sub path_info {}
123sub allow_options { Apache2::Const::OPT_EXECCGI } #will be checked again at run-time
124sub log_error { shift; die @_ if $@; warn @_; }
125sub run { return Apache2::Const::OK } # don't run the script
126sub server { shift }
127sub is_virtual { exists shift->{virthost} }
128
129# the preloaded file needs to be precompiled into the package
130# specified by the 'package' attribute, not RegistryLoader
131sub namespace_root {
132    join '::', ModPerl::RegistryCooker::NAMESPACE_ROOT,
133        shift->{REQ}->{package};
134}
135
136# override Apache class methods called by Modperl::Registry*. normally
137# only available at request-time via blessed request_rec pointer
138sub slurp_filename {
139    my $r = shift;
140    my $tainted = @_ ? shift : 1;
141    my $filename = $r->filename;
142    open my $fh, $filename or die "can't open $filename: $!";
143    local $/;
144    my $code = <$fh>;
145    unless ($tainted) {
146        ($code) = $code =~ /(.*)/s; # untaint
147    }
148    close $fh;
149    return \$code;
150}
151
152sub load_package {
153    my ($self, $package) = @_;
154
155    croak "package to load wasn't specified" unless defined $package;
156
157    $package =~ s|::|/|g;
158    $package .= ".pm";
159    require $package;
160};
161
162sub warn {
163    my $self = shift;
164    Apache2::Log->warn(__PACKAGE__ . ": @_\n");
165}
166
1671;
168__END__
169