2_0_13/lib/ModPerl/StructureMap.pm

# please insert nothing before this line: -*- mode: cperl; cperl-indent-level: 4; cperl-continued-statement-offset: 4; indent-tabs-mode: nil -*-
# Licensed to the Apache Software Foundation (ASF) under one or more
# contributor license agreements.  See the NOTICE file distributed with
# this work for additional information regarding copyright ownership.
# The ASF licenses this file to You under the Apache License, Version 2.0
# (the "License"); you may not use this file except in compliance with
# the License.  You may obtain a copy of the License at
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
#
package ModPerl::StructureMap;

use strict;
use warnings FATAL => 'all';
use ModPerl::MapUtil qw(structure_table);

our @ISA = qw(ModPerl::MapBase);

sub new {
    my $class = shift;
    bless {}, $class;
}

sub generate {
    my $self = shift;
    my $map = $self->get;

    for my $entry (@{ structure_table() }) {
        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 (@{ structure_table() }) {
        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 (@{ structure_table() }) {
        $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?)</?([^>]+)>:) {
            my $args;
            $disabled = $1;
            ($class, $args) = split /\s+/, $2, 2;

            %cur = ();
            if ($args and $args =~ /E=/) {
                %cur = $self->parse_keywords($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) {
            # < denotes a read-only accessor
            if ($1) {
                if ($1 eq '<') {
                    $map->{$class}->{$_} = 'ro';
                }
                elsif ($1 eq '&') {
                    $map->{$class}->{$_} = 'rw_char_undef';
                }
                elsif ($1 eq '$') {
                    $map->{$class}->{$_} = 'r+w_startup';
                }
                elsif ($1 eq '%') {
                    $map->{$class}->{$_} = 'r+w_startup_dup';
                }
            }
            else {
                $map->{$class}->{$_} = undef;
                push @{ $self->{disabled}->{ $1 || '!' } }, "$class.$_";
            }

        }
        else {
            $map->{$class}->{$_} = 'rw';
        }
    }

    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__