home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / StructureMap.pm < prev    next >
Encoding:
Perl POD Document  |  2004-07-09  |  3.7 KB  |  160 lines
  1. # Copyright 2001-2004 The Apache Software Foundation
  2. #
  3. # Licensed under the Apache License, Version 2.0 (the "License");
  4. # you may not use this file except in compliance with the License.
  5. # You may obtain a copy of the License at
  6. #
  7. #     http://www.apache.org/licenses/LICENSE-2.0
  8. #
  9. # Unless required by applicable law or agreed to in writing, software
  10. # distributed under the License is distributed on an "AS IS" BASIS,
  11. # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  12. # See the License for the specific language governing permissions and
  13. # limitations under the License.
  14. #
  15. package ModPerl::StructureMap;
  16.  
  17. use strict;
  18. use warnings FATAL => 'all';
  19. use ModPerl::MapUtil qw(structure_table);
  20.  
  21. our @ISA = qw(ModPerl::MapBase);
  22.  
  23. sub new {
  24.     my $class = shift;
  25.     bless {}, $class;
  26. }
  27.  
  28. sub generate {
  29.     my $self = shift;
  30.     my $map = $self->get;
  31.  
  32.     for my $entry (@{ structure_table() }) {
  33.         my $type = $entry->{type};
  34.         my $elts = $entry->{elts};
  35.  
  36.         next unless @$elts;
  37.         next if $type =~ $self->{IGNORE_RE};
  38.         next unless grep {
  39.             not exists $map->{$type}->{ $_->{name} }
  40.         } @$elts;
  41.  
  42.         print "<$type>\n";
  43.         for my $e (@$elts) {
  44.             print "   $e->{name}\n";
  45.         }
  46.         print "</$type>\n\n";
  47.     }
  48. }
  49.  
  50. sub disabled { shift->{disabled} }
  51.  
  52. sub check {
  53.     my $self = shift;
  54.     my $map = $self->get;
  55.  
  56.     my @missing;
  57.  
  58.     for my $entry (@{ structure_table() }) {
  59.         my $type = $entry->{type};
  60.  
  61.         for my $name (map $_->{name}, @{ $entry->{elts} }) {
  62.             next if exists $map->{$type}->{$name};
  63.             next if $type =~ $self->{IGNORE_RE};
  64.             push @missing, "$type.$name";
  65.         }
  66.     }
  67.  
  68.     return @missing ? \@missing : undef;
  69. }
  70.  
  71. sub check_exists {
  72.     my $self = shift;
  73.  
  74.     my %structures;
  75.     for my $entry (@{ structure_table() }) {
  76.         $structures{ $entry->{type} } = { map {
  77.             $_->{name}, 1
  78.         } @{ $entry->{elts} } };
  79.     }
  80.  
  81.     my @missing;
  82.  
  83.     while (my($type, $elts) = each %{ $self->{map} }) {
  84.         for my $name (keys %$elts) {
  85.             next if exists $structures{$type}->{$name};
  86.             push @missing, "$type.$name";
  87.         }
  88.     }
  89.  
  90.     return @missing ? \@missing : undef;
  91. }
  92.  
  93. sub parse {
  94.     my($self, $fh, $map) = @_;
  95.  
  96.     my($disabled, $class);
  97.     my %cur;
  98.  
  99.     while ($fh->readline) {
  100.         if (m:^(\W?)</?([^>]+)>:) {
  101.             my $args;
  102.             $disabled = $1;
  103.             ($class, $args) = split /\s+/, $2, 2;
  104.  
  105.             %cur = ();
  106.             if ($args and $args =~ /E=/) {
  107.                 %cur = $self->parse_keywords($args);
  108.             }
  109.  
  110.             $self->{MODULES}->{$class} = $cur{MODULE} if $cur{MODULE};
  111.  
  112.             next;
  113.         }
  114.         elsif (s/^(\w+):\s*//) {
  115.             push @{ $self->{$1} }, split /\s+/;
  116.             next;
  117.         }
  118.  
  119.         if (s/^(\W)\s*// or $disabled) {
  120.             # < denotes a read-only accessor
  121.             if ($1) {
  122.                 if ($1 eq '<') {
  123.                     $map->{$class}->{$_} = 'ro';
  124.                 }
  125.                 elsif ($1 eq '&') {
  126.                     $map->{$class}->{$_} = 'rw_char_undef';
  127.                 }
  128.                 elsif ($1 eq '$') {
  129.                     $map->{$class}->{$_} = 'r+w_startup';
  130.                 }
  131.             }
  132.             else {
  133.                 $map->{$class}->{$_} = undef;
  134.                 push @{ $self->{disabled}->{ $1 || '!' } }, "$class.$_";
  135.             }
  136.  
  137.         }
  138.         else {
  139.             $map->{$class}->{$_} = 'rw';
  140.         }
  141.     }
  142.  
  143.     if (my $ignore = $self->{IGNORE}) {
  144.         $ignore = join '|', @$ignore;
  145.         $self->{IGNORE_RE} = qr{^($ignore)};
  146.     }
  147.     else {
  148.         $self->{IGNORE_RE} = qr{^$};
  149.     }
  150. }
  151.  
  152. sub get {
  153.     my $self = shift;
  154.  
  155.     $self->{map} ||= $self->parse_map_files;
  156. }
  157.  
  158. 1;
  159. __END__
  160.