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