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/t/response/TestDirective perlloadmodule2.pm
Date Thu, 05 Dec 2002 03:31:10 GMT
stas        2002/12/04 19:31:09

  Modified:    t/conf   extra.last.conf.in
  Added:       t/directive perlloadmodule2.t
               t/response/TestDirective perlloadmodule2.pm
  Log:
  a new test that tests the merging of custom directives, using inheritance
  from parents, plus new values
  
  Revision  Changes    Path
  1.3       +12 -0     modperl-2.0/t/conf/extra.last.conf.in
  
  Index: extra.last.conf.in
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/t/conf/extra.last.conf.in,v
  retrieving revision 1.2
  retrieving revision 1.3
  diff -u -r1.2 -r1.3
  --- extra.last.conf.in	3 Dec 2002 15:38:22 -0000	1.2
  +++ extra.last.conf.in	5 Dec 2002 03:31:09 -0000	1.3
  @@ -11,6 +11,18 @@
   </Location>
   
   ### --------------------------------- ###
  +PerlLoadModule TestDirective::perlloadmodule2
  +
  +MyMergeTest one two
  +<Location /TestDirective::perlloadmodule2>
  +    MyMergeTest three four
  +</Location>
  +<Location /TestDirective::perlloadmodule2/subdir>
  +   MyMergeTest five
  +   MyMergeTest six
  +</Location>
  +
  +### --------------------------------- ###
   <Perl >
   push @Alias, ['/perl_sections', '@DocumentRoot@'],
   $Location{'/perl_sections'} = {
  
  
  
  1.1                  modperl-2.0/t/directive/perlloadmodule2.t
  
  Index: perlloadmodule2.t
  ===================================================================
  use strict;
  use warnings FATAL => 'all';
  
  use Apache::Test;
  use Apache::TestUtil;
  use Apache::TestRequest;
  
  my $url = "/TestDirective::perlloadmodule2";
  
  plan tests => 3;
  
  {
      my $location = "$url?srv";
      my $expected = "srv: one two";
      my $received = GET_BODY $location;
      ok t_cmp($expected, $received, "access server settings");
  }
  
  {
      my $location = "$url?";
      my $expected = "dir: one two three four";
      my $received = GET_BODY $location;
      ok t_cmp($expected, $received, "server/dir merge");
  }
  
  {
      my $location = "$url/subdir";
      my $expected = "dir: one two three four five six";
      my $received = GET_BODY $location;
      ok t_cmp($expected, $received, "server/dir/subdir merge");
  }
  
  
  
  1.1                  modperl-2.0/t/response/TestDirective/perlloadmodule2.pm
  
  Index: perlloadmodule2.pm
  ===================================================================
  package TestDirective::perlloadmodule2;
  
  # in this test the merge is inherits all the values from the ancestors
  # and adds new values if such were set
  
  use strict;
  use warnings FATAL => 'all';
  
  use Apache::Const -compile => qw(OK OR_ALL ITERATE);
  
  use Apache::CmdParms ();
  use Apache::Module ();
  
  our @APACHE_MODULE_COMMANDS = (
      {
       name         => 'MyMergeTest',
       func         => __PACKAGE__ . '::MyMergeTest',
       req_override => Apache::OR_ALL,
       args_how     => Apache::ITERATE,
       errmsg       => 'Values that get merged',
      },
  );
  
  sub merge {
      my($base, $add) = @_;
      #use Data::Dumper;
      #warn Dumper $base, $add;
  
      my %new = ();
  
      push @{ $new{$_} }, @{ $base->{$_} } for keys %$base;
  
      # XXX: why this approach doesn't work?
      # @new{keys %$base} = (values %$base);
  
      push @{ $new{$_} }, @{ $add->{$_}||[] } for keys %$add;
  
      #warn Dumper \%new;
      return bless \%new, ref($base);
  }
  
  sub DIR_MERGE {
      my $class = ref $_[0];
      warn "$class->DIR_MERGE\n";
      merge(@_);
  }
  
  sub SERVER_MERGE {
      my $class = ref $_[0];
      warn "$class->SERVER_MERGE\n";
      merge(@_);
  }
  
  
  
  # this variable is of type ITERATE, so it'll get called as many times
  # as arguments, a single argument at a time. This function is called
  # only during the server startup and when the directive appears in the
  # .htaccess files
  sub MyMergeTest {
      my($self, $parms, $arg) = @_;
      warn "MyMergeTest: @{[$parms->path||'']}\n\t$arg\n";
      push @{ $self->{MyMergeTest} }, $arg;
  
      # store the top level srv values in the server struct as well, so
      # during the request you can query what was the top level (srv)
      # setting, before it was merged with the current container's
      # setting if any
      unless ($parms->path) {
          my $srv_cfg = $self->get_config($parms->server);
          push @{ $srv_cfg->{MyMergeTest} }, $arg;
      }
  }
  
  sub get_config {
      my($self, $s) = (shift, shift);
      Apache::Module->get_config($self, $s, @_);
  }
  
  sub handler : method {
      my($self, $r) = @_;
  
      $r->content_type('text/plain');
  
      my $s = $r->server;
  
      if ($r->args eq 'srv') {
          my $srv_cfg = $self->get_config($s);
          $r->print("srv: @{ $srv_cfg->{MyMergeTest}||[] }");
      }
      else {
          my $dir_cfg = $self->get_config($s, $r->per_dir_config);
          $r->print("dir: @{ $dir_cfg->{MyMergeTest}||[] }");
      }
  
      return Apache::OK;
  }
  
  1;
  __END__
  
  
  

Mime
View raw message