perl-modperl-cvs mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From s...@apache.org
Subject cvs commit: modperl-2.0/ModPerl-Registry/lib/ModPerl RegistryLoader.pm
Date Tue, 13 Nov 2001 04:33:06 GMT
stas        01/11/12 20:33:06

  Modified:    ModPerl-Registry/t/conf extra.conf.in
  Added:       ModPerl-Registry/t/conf modperl_extra_startup.pl
               ModPerl-Registry/lib/ModPerl RegistryLoader.pm
  Log:
  - implement RegistryLoader and test it in the startup file
  
  Revision  Changes    Path
  1.3       +3 -0      modperl-2.0/ModPerl-Registry/t/conf/extra.conf.in
  
  Index: extra.conf.in
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/ModPerl-Registry/t/conf/extra.conf.in,v
  retrieving revision 1.2
  retrieving revision 1.3
  diff -u -r1.2 -r1.3
  --- extra.conf.in	2001/10/19 06:46:25	1.2
  +++ extra.conf.in	2001/11/13 04:33:06	1.3
  @@ -3,6 +3,9 @@
   # make sure that we test under Taint mode
   PerlSwitches -T
   
  +# run on startup
  +PerlRequire @ServerRoot@/conf/modperl_extra_startup.pl
  +
   PerlSwitches -Mlib=@ServerRoot@/../lib
   PerlSwitches -Mlib=@ServerRoot@/../../Apache-Test/lib
   PerlSwitches -Mlib=@ServerRoot@/../../lib
  
  
  
  1.1                  modperl-2.0/ModPerl-Registry/t/conf/modperl_extra_startup.pl
  
  Index: modperl_extra_startup.pl
  ===================================================================
  # 
  
  use strict;
  use warnings;
  
  # test the scripts pre-loading by explicitly specifying uri => filename
  use ModPerl::RegistryLoader ();
  my $rl = ModPerl::RegistryLoader->new(package => "ModPerl::Registry");
  my $base_dir = Apache::server_root_relative("cgi-bin");
  my $base_uri = "/cgi-bin";
  for my $file (qw(basic.pl env.pl)) {
      my $file_path  = "$base_dir/$file";
      my $info_path  = "$base_uri/$file";
      $rl->handler($info_path, $file_path);
  }
  
  {
      # test the scripts pre-loading by using trans sub
      use ModPerl::RegistryLoader ();
      use DirHandle ();
      use strict;
  
      my $dir = Apache::server_root_relative("cgi-bin");
  
      sub trans {
          my $uri = shift; 
          $uri =~ s|^/registry_bb/|cgi-bin/|;
          return Apache::server_root_relative($uri);
      }
  
      my $rl = ModPerl::RegistryLoader->new(package => "ModPerl::RegistryBB",
                                            trans   => \&trans);
      my $dh = DirHandle->new($dir) or die $!;
  
      for my $file ($dh->read) {
          next unless $file =~ /\.pl$/;
          $rl->handler("/registry_bb/$file");
      }
  }
  
  1;
  
  
  
  1.1                  modperl-2.0/ModPerl-Registry/lib/ModPerl/RegistryLoader.pm
  
  Index: RegistryLoader.pm
  ===================================================================
  package ModPerl::RegistryLoader;
  
  use Apache::Const -compile => qw(OPT_EXECCGI);
  use Carp;
  
  our @ISA = ();
  
  sub new {
      my $class = shift;
      my $self = bless {@_} => ref($class)||$class;
      $self->load_package($self->{package});
      return $self;
  }
  
  sub handler {
      my($self, $uri, $filename) = @_;
  
      # set the inheritance rules at run time
      @ISA = $self->{package};
  
      unless (defined $uri) {
          $self->warn("uri is a required argument");
          return;
      }
  
      if (defined $filename) {
          unless (-e $filename) {
              $self->warn("Cannot find: $filename");
              return;
          }
      }
      else {
          # try to translate URI->filename
          if (my $func = $self->{trans}) {
              no strict 'refs';
              $filename = $func->($uri);
              unless (-e $filename) {
                  $self->warn("Cannot find a translated from uri: $filename");
                  return;
              }
          } else {
              # try to guess
              (my $guess = $uri) =~ s|^/||;
              $filename = Apache::server_root_relative($guess);
              $self->warn("Trying to guess filename based on uri");
              unless (-e $filename) {
                  $self->warn("Cannot find guessed file: $filename",
                              "provide \$filename or 'trans' sub");
                  return;
              }
          }
      }
  
      if ($self->{debug}) {
          $self->warn("*** uri=$uri, filename=$filename");
      }
  
      my $r = bless {
  		   uri      => $uri,
  		   filename => $filename,
  		  } => ref($self) || $self;
  
      $r->SUPER::handler;
  
  }
  
  sub filename { shift->{filename} }
  sub finfo    { shift->{filename} }
  sub uri      { shift->{uri} }
  sub path_info {}
  sub allow_options { Apache::OPT_EXECCGI } #will be checked again at run-time
  sub log_error { shift; die @_ if $@; warn @_; }
  *log_reason = \&log_error;
  sub run {} # don't run the script
  sub server { shift }
  
  # override Apache class methods called by Modperl::Registry*. normally
  # only available at request-time via blessed request_rec pointer
  sub slurp_filename {
      my $r = shift;
      my $filename = $r->filename;
      open my $fh, $filename;
      local $/;
      my $code = <$fh>;
      return \$code;
  }
  
  sub load_package {
      my($self, $package) = @_;
  
      croak "package to load wasn't specified" unless defined $package;
  
      $package =~ s|::|/|g;
      $package .= ".pm";
      require $package;
  };
  
  sub warn {
      my $self = shift;
      Apache::warn(__PACKAGE__ . ": @_\n");
  }
  
  1;
  __END__
  
  
  

Mime
View raw message