File Coverage

blib/lib/Embedix/ECD.pm

Criterion	Covered	Total	%
statement	192	206	93.2
branch	37	50	74.0
condition	4	11	36.3
subroutine	37	39	94.8
pod	21	23	91.3
total	291	329	88.4

package Embedix::ECD;

use strict;
use vars qw($AUTOLOAD $VERSION);

$VERSION = '0.09';

# different classes of nodes
use Embedix::ECD::Autovar;
use Embedix::ECD::Component;
use Embedix::ECD::Group;
use Embedix::ECD::Option;

# misc info
use Embedix::ECD::Util qw(
    indent
    unindent_and_aggregate
    %default
    @attribute_order
);

# damian conway is the man
use Parse::RecDescent;

# for debugging
use Data::Dumper;

# for preserving insertion order
use Tie::IxHash;

# for when the grammar is giving me trouble
# $::RD_HINT = 1;

# the grammar
$Embedix::ECD::__grammar = q(

    {
        *Parse::RecDescent::unindent_and_aggregate =
        \&Embedix::ECD::Util::unindent_and_aggregate;
    }

    ecd_arrayref:
        statement(s?)
        {
            # return syntax tree as nested arrayrefs
            $return = $item[1];
        }

    statement:
        comment
        | node
        | attribute
        |

    comment_line:
        /^#(.*)\n/
        {
            $return = $1;
        }

    comment:
        comment_line(s)
        {
            $return = [ 'Comment', $item[1] ];
        }

    rawtext:
        #m{[^<]+}
        #m{(?:[^<]|<(?!(?:/[a-zA-Z_]+|[a-zA-Z_]+/?)>))+}
        m{(?:[^<]|<(?!(/)?[a-zA-Z_]+(?(1)|/?)>))+}
        {
            $return = $item[1];
        }

    attribute:
        # one line w/o tags
        m{(\w+)[ \t]*=(.*)\n}
        {
            my $attr  = $1;
            my $value = $2;
            $value    =~ s/^\s*//;
            $value    =~ s/\s*$//;
            $return   = [ $attr, $value ];
        }
        | tag_open rawtext(s?) tag_close
        {
            if ($item[1] ne $item[3]) {
                die "$thisline: was expecting $item[1], " .
                    "but found $item[3] instead\n";
            }
            my $value = ref($item[2]) && $item[2][0] || '';
            $value    = unindent_and_aggregate($value);
            $return   = [ $item[1], $value ];
        }

    tag_open:
        m{<([a-zA-Z_]+)>}
        {
            $return = $1;
        }

    tag_close:
        m{}
        {
            $return = $1;
        }

    node:
        node_start node_item(s?) node_end
        {
            if ($item[1][0] ne $item[3]) {
                die "$thisline: was expecting $item[1][0], " .
                    "but found $item[3] instead\n";
            }
            $return = [ $item[1], $item[2] ];
        }

    node_item:
        statement
        | attribute

    node_start:
        m{<(\w+)\s+(.*?)>}
        {
            #print STDERR "node $1 $2\n";
            my $nodetype = ucfirst lc $1;
            my $name     = $2;
            $return      = [ $nodetype, $name ];
        }

    node_end:
        m{}
        {
            $return = ucfirst lc $1;
        }
);

$Embedix::ECD::__parser = undef;

# the parser as a singleton
#_______________________________________
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('', );
    my $self = $class->newFromString($s);
    close(ECD);
    return $self;
}

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

# constructor, arrayref
#_______________________________________
sub consFromFile {
    my $class    = shift;
    my $filename = shift;
    open(ECD, $filename) || die "$!";
    my $s    = join('', );
    my $cons = $class->consFromString($s);
    close(ECD);
    return $cons;
}

# destructor
#_______________________________________
sub DESTROY {

}

# accessor for name
#_______________________________________
sub name {
    my $self = shift;
    if (@_) {
        $self->{name} = +shift;
    } else {
        return $self->{name};
    }
}

# general attribute getter
#_______________________________________
sub getAttribute {
    my $self = shift;
    my $attr = shift;
    return $self->{attribute}{$attr};
}

# general attribute setter
#_______________________________________
sub setAttribute {
    my $self = shift;
    my $attr = shift;
    my $val  = shift;
    $self->{attribute}{$attr} = $val;
}

# maybe do some glob + closure magic for attribute getters and setters
#_______________________________________
sub make_accessor_method {
    my $package = caller;
    my $method;
    foreach $method (@_) {
        no strict 'refs';
        *{$package . "::$method"} = sub {
            my $self = shift;
            if (@_) {
                $self->{attribute}{$method} = +shift;
            } else {
                return $self->{attribute}{$method};
            }
        }
    }
}

# *_size attributes can be mathematical expressions.
#_______________________________________
sub make_evaluating_getter_method {
    my $package = caller;
    my $method;
    foreach $method (@_) {
        no strict 'refs';
        *{$package . "::eval_$method"} = sub {
            my $self = shift;
            my @x = split (
                /(?<=\d)\s+(?=\d)/,
                $self->{attribute}{$method}
            );
            push @x, 0 if (@x == 1);
            return map { eval } @x;
        }
    }
}

# in the future, subclasses will be more specific.
Embedix::ECD::make_accessor_method(qw(
    type
    value
    default_value
    range
    help
    prompt
    license
    srpm
    specpatch

    static_size
    min_dynamic_size
    storage_size
    startup_time

    build_vars
    conflicts
    provides
    requires
    keeplist
    choicelist
    trideps

    requiresexpr
    if
));

Embedix::ECD::make_evaluating_getter_method(qw(
    static_size
    min_dynamic_size
    storage_size
    startup_time
));

# get child node objects
#_______________________________________
sub getChild {
    my $self = shift;
    my $name = shift;

    if (defined $self->{child}{$name}) {
        return  $self->{child}{$name};
    } else {
        return undef;
    }
}

# an alias for getChild()
#_______________________________________
*Embedix::ECD::n = \&getChild;  # node

# set child node objects
#_______________________________________
sub addChild {
    my $self = shift;
    my $obj  = shift;
    die "$obj is not an instance of Embedix::ECD.\n"
        unless (ref($obj) && $obj->isa('Embedix::ECD'));
    my $name = $obj->{name};
    $obj->{parent} = $self;
    $self->{child}{$name} = $obj;
    return $obj;
}

# delete a child from a node
#_______________________________________
sub delChild {
    my $self = shift;
    my $obj  = shift;
    my $name;
    if (ref($obj)) {
        $name = $obj->name;
    } else {
        $name = $obj;
    }
    if (defined $self->{child}{$name}) {
        return delete($self->{child}{$name});
    } else {
        carp("Child $name does not exist");
        return undef;
    }
}

# return list of children of node
#_______________________________________
sub getChildren {
    my $self = shift;
    return values %{$self->{child}};
}

# true if node has children
#_______________________________________
sub hasChildren {
    my $self = shift;
    return scalar values %{$self->{child}};
}

# get child node objects automagically
#_______________________________________
sub AUTOLOAD {
    my $self = shift;
    my $name = $AUTOLOAD;

    $name =~ s/.*://;

    if (defined $self->{child}{$name}) {
        return  $self->{child}{$name};
    } else {
        # my (undef, $f, $l) = caller();
        # die "$f\[$l\] => ", ref($self), "::$name() is not a valid method.\n";
        return undef;
    }
}

# merge another Embedix::ECD object together with $self
#_______________________________________
sub mergeWith {
    my $self = shift;
    my $ecd  = shift;

    # restrict
    unless (   ($self->name eq $ecd->name)
           &&  (ref($self)  eq  ref($ecd)) )
    {
        die "ecd needs to have the same name and class to be merged\n";
    }

    # copy attributes
    foreach (keys %{$ecd->{attribute}}) {
        $self->{attribute}{$_} = $ecd->{attribute}{$_}
            if defined ($ecd->{attribute}{$_});
    }

    # merge children
    my $sibling;
    foreach $sibling ($ecd->getChildren) {
        my $name  = $sibling->name;
        my $child = $self->getChild($name);

        unless ($child) {
            $self->addChild($sibling);
        } else {
            my $evil_twin = $sibling;
            $child->mergeWith($evil_twin);  # bad poetry?
        }
    }
}

# get depth in tree
#_______________________________________
sub getDepth {
    my $self = shift;
    my $parent = $self->{parent};
    unless (ref($parent)) {
        return 0;
    } else {
        return ($parent->getDepth() + 1);
    }
}

# return the class of the node as a string
#_______________________________________
sub getNodeClass {
    my $self = shift;
    my $type = ref($self);
    return substr($type, rindex($type, ':') + 1);
}

# calculate spaces
#_______________________________________
sub getFormatOptions {
    my $self = shift; (@_ & 1) && die "Odd number of parameters.\n";
    my %opt  = @_;

    $opt{indent} = 0 unless(defined($opt{indent}));
    $opt{sw}     = $opt{shiftwidth} || $default{shiftwidth};
    $opt{space}  = " " x $opt{indent} . indent($self->getDepth, $opt{sw});
    $opt{space2} = $opt{space} . " " x $opt{sw};
    $opt{order}  = \@attribute_order;

    return \%opt;
}

# render the attributes of a node
# It's rare for me to nest this much.
#_______________________________________
sub attributeToString {
    my $self = shift;
    my $opt  = shift;
    my ($sw, $space, $space2) = map { $opt->{$_} } qw(sw space space2);
    my $a;
    return join '', map {
        $a = $self->getAttribute($_);
        if (defined($a)) {
            if (ref($a)) {
                if (scalar(@$a)) {
                    # an aggregate attribute
                    $space2 . "<" . uc($_) . ">\n" .
                    join('', map { $space2 . " " x $sw . "$_\n" } @$a) .
                    $space2 . "\n";
                } else {
                    # an empty aggregate attribute
                    "";
                }
            } else {
                # a scalar attribute
                $space2 . uc($_) . "=" . "$a\n";
            }
        }
    } @{$opt->{order}};
}

# render $self in ECD format
# Embedix::ECD itself doesn't have a textual representation
# but its subclasses should.
#_______________________________________
sub toString {
    my $self = shift;
    return join('', map { $_->toString(@_) } $self->getChildren());
}

1;

__END__