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 / RegistryLoader.pm < prev    next >
Encoding:
Perl POD Document  |  2003-08-29  |  3.9 KB  |  143 lines
  1. package ModPerl::RegistryLoader;
  2.  
  3. use strict;
  4. use warnings;
  5.  
  6. use ModPerl::RegistryCooker ();
  7. use APR::Pool ();
  8.  
  9. use Apache::Const -compile => qw(OK HTTP_OK OPT_EXECCGI);
  10. use Carp;
  11.  
  12. our @ISA = ();
  13.  
  14. sub new {
  15.     my $class = shift;
  16.     my $self = bless {@_} => ref($class)||$class;
  17.     $self->{package} ||= 'ModPerl::Registry';
  18.     $self->{pool} = APR::Pool->new();
  19.     $self->load_package($self->{package});
  20.     return $self;
  21. }
  22.  
  23. sub handler {
  24.     my($self, $uri, $filename, $virthost) = @_;
  25.  
  26.     # set the inheritance rules at run time
  27.     @ISA = $self->{package};
  28.  
  29.     unless (defined $uri) {
  30.         $self->warn("uri is a required argument");
  31.         return;
  32.     }
  33.  
  34.     if (defined $filename) {
  35.         unless (-e $filename) {
  36.             $self->warn("Cannot find: $filename");
  37.             return;
  38.         }
  39.     }
  40.     else {
  41.         # try to translate URI->filename
  42.         if (exists $self->{trans} and ref($self->{trans}) eq 'CODE') {
  43.             no strict 'refs';
  44.             $filename = $self->{trans}->($uri);
  45.             unless (-e $filename) {
  46.                 $self->warn("Cannot find a translated from uri: $filename");
  47.                 return;
  48.             }
  49.         }
  50.         else {
  51.             # try to guess
  52.             (my $guess = $uri) =~ s|^/||;
  53.  
  54.             $self->warn("Trying to guess filename based on uri")
  55.                 if $self->{debug};
  56.  
  57.             $filename = Apache::server_root_relative($self->{pool}, $guess);
  58.             unless (-e $filename) {
  59.                 $self->warn("Cannot find guessed file: $filename",
  60.                             "provide \$filename or 'trans' sub");
  61.                 return;
  62.             }
  63.         }
  64.     }
  65.  
  66.     if ($self->{debug}) {
  67.         $self->warn("*** uri=$uri, filename=$filename");
  68.     }
  69.  
  70.     my $rl = bless {
  71.         uri      => $uri,
  72.         filename => $filename,
  73.         package  => $self->{package},
  74.     } => ref($self) || $self;
  75.  
  76.     $rl->{virthost} = $virthost if defined $virthost;
  77.  
  78.     # can't call SUPER::handler here, because it usually calls new()
  79.     # and then the ModPerlRegistryLoader::new() will get called,
  80.     # instead of the super class' new, so we implement the super
  81.     # class' handler here. Hopefully all other subclasses use the same
  82.     # handler.
  83.     __PACKAGE__->SUPER::new($rl)->default_handler();
  84.  
  85. }
  86.  
  87. # XXX: s/my_// for qw(my_finfo my_slurp_filename);
  88. # when when finfo() and slurp_filename() are ported to 2.0 and
  89. # RegistryCooker is starting to use them
  90.  
  91. sub get_server_name { return $_[0]->{virthost} if exists $_[0]->{virthost} }
  92. sub filename { shift->{filename} }
  93. sub status { Apache::HTTP_OK }
  94. sub my_finfo    { shift->{filename} }
  95. sub uri      { shift->{uri} }
  96. sub path_info {}
  97. sub allow_options { Apache::OPT_EXECCGI } #will be checked again at run-time
  98. sub log_error { shift; die @_ if $@; warn @_; }
  99. sub run { return Apache::OK } # don't run the script
  100. sub server { shift }
  101. sub is_virtual { exists shift->{virthost} }
  102.  
  103. # the preloaded file needs to be precompiled into the package
  104. # specified by the 'package' attribute, not RegistryLoader
  105. sub namespace_root {
  106.     join '::', ModPerl::RegistryCooker::NAMESPACE_ROOT,
  107.         shift->{REQ}->{package};
  108. }
  109.  
  110. # override Apache class methods called by Modperl::Registry*. normally
  111. # only available at request-time via blessed request_rec pointer
  112. sub slurp_filename {
  113.     my $r = shift;
  114.     my $tainted = @_ ? shift : 1;
  115.     my $filename = $r->filename;
  116.     open my $fh, $filename or die "can't open $filename: $!";
  117.     local $/;
  118.     my $code = <$fh>;
  119.     unless ($tainted) {
  120.         ($code) = $code =~ /(.*)/s; # untaint
  121.     }
  122.     close $fh;
  123.     return \$code;
  124. }
  125.  
  126. sub load_package {
  127.     my($self, $package) = @_;
  128.  
  129.     croak "package to load wasn't specified" unless defined $package;
  130.  
  131.     $package =~ s|::|/|g;
  132.     $package .= ".pm";
  133.     require $package;
  134. };
  135.  
  136. sub warn {
  137.     my $self = shift;
  138.     Apache->warn(__PACKAGE__ . ": @_\n");
  139. }
  140.  
  141. 1;
  142. __END__
  143.