cvs commit: modperl-2.0/lib/ModPerl StructureMap.pm

[dougm]

dougm       01/03/04 19:45:47

  Added:       lib/ModPerl StructureMap.pm
  Log:
  module for mapping data structures
  
  Revision  Changes    Path
  1.1                  modperl-2.0/lib/ModPerl/StructureMap.pm
  
  Index: StructureMap.pm
  ===================================================================
  package ModPerl::StructureMap;
  
  use strict;
  use warnings FATAL => 'all';
  use Apache::StructureTable ();
  use ModPerl::MapUtil ();
  
  our @ISA = qw(ModPerl::MapBase);
  
  sub new {
      my $class = shift;
      bless {}, $class;
  }
  
  sub generate {
      my $self = shift;
      my $map = $self->get;
  
      for my $entry (@$Apache::StructureTable) {
          my $type = $entry->{type};
          my $elts = $entry->{elts};
  
          next unless @$elts;
          next if $type =~ $self->{IGNORE_RE};
          next unless grep {
              not exists $map->{$type}->{ $_->{name} }
          } @$elts;
  
          print "<$type>\n";
          for my $e (@$elts) {
              print "   $e->{name}\n";
          }
          print "</$type>\n\n";
      }
  }
  
  sub disabled { shift->{disabled} }
  
  sub check {
      my $self = shift;
      my $map = $self->get;
  
      my @missing;
  
      for my $entry (@$Apache::StructureTable) {
          my $type = $entry->{type};
  
          for my $name (map $_->{name}, @{ $entry->{elts} }) {
              next if exists $map->{$type}->{$name};
              next if $type =~ $self->{IGNORE_RE};
              push @missing, "$type.$name";
          }
      }
  
      return @missing ? \@missing : undef;
  }
  
  sub check_exists {
      my $self = shift;
  
      my %structures;
      for my $entry (@$Apache::StructureTable) {
          $structures{ $entry->{type} } = { map {
              $_->{name}, 1
          } @{ $entry->{elts} } };
      }
  
      my @missing;
  
      while (my($type, $elts) = each %{ $self->{map} }) {
          for my $name (keys %$elts) {
              next if exists $structures{$type}->{$name};
              push @missing, "$type.$name";
          }
      }
  
      return @missing ? \@missing : undef;
  }
  
  sub parse {
      my($self, $fh, $map) = @_;
  
      my($disabled, $class);
      my %cur;
  
      while ($fh->readline) {
          if (m:^(\W?)</?([^>]+)>:) {
              $disabled = $1;
              my $args = $2;
  
              %cur = ();
              if ($args =~ /E=/) {
                  %cur = $self->parse_keywords($args);
              }
  
              $class = $cur{STRUCT} || $args;
              $self->{MODULES}->{$class} = $cur{MODULE} if $cur{MODULE};
  
              next;
          }
          elsif (s/^(\w+):\s*//) {
              push @{ $self->{$1} }, split /\s+/;
              next;
          }
  
          if (s/^(\W)\s*// or $disabled) {
              $map->{$class}->{$_} = undef;
              push @{ $self->{disabled}->{ $1 || '!' } }, "$class.$_";
          }
          else {
              $map->{$class}->{$_} = 1;
          }
      }
  
      if (my $ignore = $self->{IGNORE}) {
          $ignore = join '|', @$ignore;
          $self->{IGNORE_RE} = qr{^($ignore)};
      }
      else {
          $self->{IGNORE_RE} = qr{^$};
      }
  }
  
  sub get {
      my $self = shift;
  
      $self->{map} ||= $self->parse_map_files;
  }
  
  1;
  __END__