view release on metacpan or  search on metacpan

ECD.pm  view on Meta::CPAN

#_______________________________________
sub parser {
    if (defined $Embedix::ECD::__parser) {
        return  $Embedix::ECD::__parser;
    } else {
        # construct a new parser
        my $g = \$Embedix::ECD::__grammar;
        my $p = Parse::RecDescent->new($$g);
        return $Embedix::ECD::__parser = $p;
    }
}

# constructor, basic
#_______________________________________
sub new {
    my $class = shift; (@_ & 1) && die "Odd number of parameters.\n";
    my %opt   = @_;
    my %child;
    tie %child, "Tie::IxHash";
    my $self  = { 
        name   => $opt{name} || die("name attribute is mandatory\n"),
        parent => undef,
        child  => \%child,

        # FIXME : these are the attributes that have occurred in nodes
        # so far.  I need to find out if certain attributes are not
        # allowed in certain node types.
        attribute => { 
            # scalar values
            type                => undef,
            value               => undef,
            default_value       => undef,
            range               => undef,
            help                => undef,
            prompt              => undef,
            license             => undef,
            srpm                => undef,
            specpatch           => undef,

            static_size         => undef,   # XXX < not a good indicator of
            min_dynamic_size    => undef,   # XXX < true memory consumption
            storage_size        => undef,   # XXX platform dependent
            startup_time        => undef,   # XXX platform dependent

            # These options have been observed to contain aggregate values.
            build_vars          => undef,
            conflicts           => undef,
            provides            => undef,
            requires            => undef,
            keeplist            => undef,
            choicelist          => undef,
            trideps             => undef,

            # a syntax of its own
            requiresexpr        => undef,
            'if'                => undef,
        },
    };
    delete($opt{name});
    @{$self->{attribute}}{keys %opt} = values %opt;
    return bless($self => $class);
}

# constructor, object
#_______________________________________
sub newFromCons {
    my $proto = shift;
    my $cons  = shift;
    my $self  = undef;
    my $i;

    # self
    $self = $proto if (ref($proto));

    # root node
    $self = Embedix::ECD->new(name => 'ecd') unless ($self);

    # add kids recursively
    while ($i = shift(@$cons)) {
        if (ref($i->[0])) {
            # node
            my $node_class =  "Embedix::ECD::" . $i->[0][0];
            my $child = $node_class->new(name => $i->[0][1]);
            $self->addChild($child);
            $child->newFromCons($i->[1]);
        } else {
            # attribute
            if ($i->[0] eq "Comment") {
                # comment
                # throw them away for now
            } else {
                # attribute
                $self->setAttribute(lc $i->[0], $i->[1]);
            }
        }
    }
    return $self;
}

# constructor, object
#_______________________________________
sub newFromString {
    my $class = shift;
    my $s     = shift;
    my $p     = Embedix::ECD->parser();
    my $cons  = $p->ecd_arrayref($s);
    my $self  = $class->newFromCons($cons);
    return $self;
}

# constructor, object
#_______________________________________
sub newFromFile {
    my $class    = shift;
    my $filename = shift;
    open(ECD, $filename) || die "$!";
    my $s    = join('', <ECD>);
    my $self = $class->newFromString($s);
    close(ECD);
    return $self;
}