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 / PerlSection.pm < prev    next >
Encoding:
Perl POD Document  |  2003-05-25  |  4.0 KB  |  177 lines
  1. package Apache::PerlSection;
  2.  
  3. use strict;
  4. use warnings FATAL => 'all';
  5.  
  6. our $VERSION = '0.01';
  7.  
  8. use Apache::CmdParms ();
  9. use Apache::Directive ();
  10. use APR::Table ();
  11. use Apache::Server ();
  12. use Apache::ServerUtil ();
  13. use Apache::Const -compile => qw(OK);
  14.  
  15. use constant SPECIAL_NAME => 'PerlConfig';
  16.  
  17. sub new {
  18.     my($package, @args) = @_;
  19.     return bless { @args }, ref($package) || $package;
  20. }
  21.  
  22. sub server     { return shift->{'parms'}->server() }
  23. sub directives { return shift->{'directives'} ||= [] }
  24. sub package    { return shift->{'args'}->{'package'} }
  25.  
  26. sub handler : method {
  27.     my($self, $parms, $args) = @_;
  28.  
  29.     unless (ref $self) {
  30.         $self = $self->new('parms' => $parms, 'args' => $args);
  31.     }
  32.  
  33.     my $special = $self->SPECIAL_NAME;
  34.  
  35.     for my $entry ($self->symdump()) {
  36.         if ($entry->[0] !~ /$special/) {
  37.             $self->dump(@$entry);
  38.         }
  39.     }
  40.  
  41.     {
  42.         no strict 'refs';
  43.         my $package = $self->package;
  44.  
  45.         $self->dump_special(${"${package}::$special"},
  46.           @{"${package}::$special"} );
  47.     }
  48.  
  49.     $self->post_config();
  50.  
  51.     Apache::OK;
  52. }
  53.  
  54. sub symdump {
  55.     my($self) = @_;
  56.  
  57.     my $pack = $self->package;
  58.  
  59.     unless ($self->{symbols}) {
  60.         $self->{symbols} = [];
  61.  
  62.         no strict;
  63.  
  64.         #XXX: Shamelessly borrowed from Devel::Symdump;
  65.         while (my ($key, $val) = each(%{ *{"$pack\::"} })) {
  66.             local (*ENTRY) = $val;
  67.             if (defined $val && defined *ENTRY{SCALAR}) {
  68.                 push @{$self->{symbols}}, [$key, $ENTRY];
  69.             }
  70.             if (defined $val && defined *ENTRY{ARRAY}) {
  71.                 push @{$self->{symbols}}, [$key, \@ENTRY];
  72.             }
  73.             if (defined $val && defined *ENTRY{HASH} && $key !~ /::/) {
  74.                 push @{$self->{symbols}}, [$key, \%ENTRY];
  75.             }
  76.         }
  77.     }
  78.  
  79.     return @{$self->{symbols}};
  80. }
  81.  
  82. sub dump_special {
  83.     my($self, @data) = @_;
  84.     $self->add_config(@data);
  85. }
  86.  
  87. sub dump {
  88.     my($self, $name, $entry) = @_;
  89.     my $type = ref $entry;
  90.  
  91.     if ($type eq 'ARRAY') {
  92.         $self->dump_array($name, $entry);
  93.     }
  94.     elsif ($type eq 'HASH') {
  95.         $self->dump_hash($name, $entry);
  96.     }
  97.     else {
  98.         $self->dump_entry($name, $entry);
  99.     }
  100. }
  101.  
  102. sub dump_hash {
  103.     my($self, $name, $hash) = @_;
  104.  
  105.     for my $entry (sort keys %{ $hash || {} }) {
  106.         my $item = $hash->{$entry};
  107.         my $type = ref($item);
  108.  
  109.         if ($type eq 'HASH') {
  110.             $self->dump_section($name, $entry, $item);
  111.         }
  112.         elsif ($type eq 'ARRAY') {
  113.             for my $e (@$item) {
  114.                 $self->dump_section($name, $entry, $e);
  115.             }
  116.         }
  117.     }
  118. }
  119.  
  120. sub dump_section {
  121.     my($self, $name, $loc, $hash) = @_;
  122.  
  123.     $self->add_config("<$name $loc>\n");
  124.  
  125.     for my $entry (sort keys %{ $hash || {} }) {
  126.         $self->dump_entry($entry, $hash->{$entry});
  127.     }
  128.  
  129.     $self->add_config("</$name>\n");
  130. }
  131.  
  132. sub dump_array {
  133.     my($self, $name, $entries) = @_;
  134.  
  135.     for my $entry (@$entries) {
  136.         $self->dump_entry($name, $entry);
  137.     }
  138. }
  139.  
  140. sub dump_entry {
  141.     my($self, $name, $entry) = @_;
  142.     my $type = ref $entry;
  143.  
  144.     if ($type eq 'SCALAR') {
  145.         $self->add_config("$name $$entry\n");
  146.     }
  147.     elsif ($type eq 'ARRAY') {
  148.         $self->add_config("$name @$entry\n");
  149.     }
  150.     elsif ($type eq 'HASH') {
  151.         $self->dump_hash($name, $entry);
  152.     }
  153.     elsif ($type) {
  154.         #XXX: Could do $type->can('httpd_config') here on objects ???
  155.         die "Unknown type '$type' for directive $name";
  156.     }
  157.     elsif (defined $entry) {
  158.         $self->add_config("$name $entry\n");
  159.     }
  160. }
  161.  
  162. sub add_config {
  163.     my($self, $config) = @_;
  164.     return unless defined $config;
  165.     chomp($config);
  166.     push @{ $self->directives }, $config;
  167. }
  168.  
  169. sub post_config {
  170.     my($self) = @_;
  171.     my $errmsg = $self->server->add_config($self->directives);
  172.     die $errmsg if $errmsg;
  173. }
  174.  
  175. 1;
  176. __END__
  177.