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