lucy-commits mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From mar...@apache.org
Subject svn commit: r807450 - in /lucene/lucy/trunk/boilerplater: lib/Boilerplater/Class.pm lib/Boilerplater/Parser.pm t/400-class.t
Date Tue, 25 Aug 2009 01:54:16 GMT
Author: marvin
Date: Tue Aug 25 01:54:16 2009
New Revision: 807450

URL: http://svn.apache.org/viewvc?rev=807450&view=rev
Log:
Commit LUCY-23, adding Boilerplater::Class.

Added:
    lucene/lucy/trunk/boilerplater/lib/Boilerplater/Class.pm   (with props)
    lucene/lucy/trunk/boilerplater/t/400-class.t   (with props)
Modified:
    lucene/lucy/trunk/boilerplater/lib/Boilerplater/Parser.pm

Added: lucene/lucy/trunk/boilerplater/lib/Boilerplater/Class.pm
URL: http://svn.apache.org/viewvc/lucene/lucy/trunk/boilerplater/lib/Boilerplater/Class.pm?rev=807450&view=auto
==============================================================================
--- lucene/lucy/trunk/boilerplater/lib/Boilerplater/Class.pm (added)
+++ lucene/lucy/trunk/boilerplater/lib/Boilerplater/Class.pm Tue Aug 25 01:54:16 2009
@@ -0,0 +1,541 @@
+use strict;
+use warnings;
+
+package Boilerplater::Class;
+use base qw( Boilerplater::Symbol );
+use Carp;
+use Config;
+use Boilerplater::Function;
+use Boilerplater::Method;
+use Boilerplater::Util qw(
+    verify_args
+    a_isa_b
+);
+use File::Spec::Functions qw( catfile );
+use Scalar::Util qw( reftype );
+
+our %create_PARAMS = (
+    source_class      => undef,
+    class_name        => undef,
+    cnick             => undef,
+    parent_class_name => undef,
+    methods           => undef,
+    functions         => undef,
+    member_vars       => undef,
+    inert_vars        => undef,
+    docucomment       => undef,
+    inert             => undef,
+    final             => undef,
+    parcel            => undef,
+    attributes        => undef,
+    exposure          => 'parcel',
+);
+
+our %registry;
+
+# Testing only.
+sub _zap { delete $registry{ +shift } }
+
+our %fetch_singleton_PARAMS = (
+    parcel     => undef,
+    class_name => undef,
+);
+
+sub fetch_singleton {
+    my ( undef, %args ) = @_;
+    verify_args( \%fetch_singleton_PARAMS, %args ) or confess $@;
+
+    # Start with the class identifier.
+    my $class_name = $args{class_name};
+    confess("Missing required param 'class_name'") unless defined $class_name;
+    $class_name =~ /(\w+)$/ or confess("Invalid class name: '$class_name'");
+    my $key = $1;
+
+    # Maybe prepend parcel prefix.
+    my $parcel = $args{parcel};
+    if ( defined $parcel ) {
+        if ( !a_isa_b( $parcel, "Boilerplater::Parcel" ) ) {
+            $parcel = Boilerplater::Parcel->singleton( name => $parcel );
+        }
+        $key = $parcel->get_prefix . $key;
+    }
+
+    return $registry{$key};
+}
+
+sub new { confess("The constructor for Boilerplater::Class is create()") }
+
+sub create {
+    my ( $class_class, %args ) = @_;
+    verify_args( \%create_PARAMS, %args ) or confess $@;
+    $args{class_cnick} = $args{cnick};
+    my $self = $class_class->SUPER::new(
+        %create_PARAMS,
+        micro_sym   => 'class',
+        struct_sym  => undef,
+        methods     => [],
+        overridden  => {},
+        functions   => [],
+        member_vars => [],
+        children    => [],
+        parent      => undef,
+        attributes  => {},
+        autocode    => '',
+        tree_grown  => 0,
+        %args,
+    );
+    $self->{cnick} ||= $self->{class_cnick};
+
+    # Make it possible to look up methods and functions by name.
+    $self->{meth_by_name}{ $_->micro_sym } = $_ for $self->methods;
+    $self->{func_by_name}{ $_->micro_sym } = $_ for $self->functions;
+
+    # Derive struct name.
+    confess("Missing required param 'class_name'") unless $self->{class_name};
+    $self->{class_name} =~ /(\w+)$/;
+    $self->{struct_sym} = $1;
+
+    # Verify that members of supplied arrays meet "is a" requirements.
+    for ( @{ $self->{functions} } ) {
+        confess("Not a Boilerplater::Function")
+            unless a_isa_b( $_, 'Boilerplater::Function' );
+    }
+    for ( @{ $self->{methods} } ) {
+        confess("Not a Boilerplater::Method")
+            unless a_isa_b( $_, 'Boilerplater::Method' );
+    }
+    for ( @{ $self->{member_vars} }, @{ $self->{inert_vars} } ) {
+        confess("Not a Boilerplater::Variable")
+            unless a_isa_b( $_, 'Boilerplater::Variable' );
+    }
+
+    # Assume that Foo::Bar should be found in Foo/Bar.h.
+    $self->{source_class} = $self->{class_name}
+        unless defined $self->{source_class};
+
+    # Validate attributes.
+    confess("Param 'attributes' not a hashref")
+        unless reftype( $self->{attributes} ) eq 'HASH';
+
+    # Store in registry.
+    my $key      = $self->get_prefix . $self->{struct_sym};
+    my $existing = $registry{$key};
+    if ($existing) {
+        confess(  "New class $self->{class_name} conflicts with previously "
+                . "compiled class $existing->{class_name}" );
+    }
+    $registry{$key} = $self;
+
+    # Validate inert param.
+    confess("Inert classes can't have methods")
+        if ( $self->{inert} and @{ $self->{methods} } );
+
+    return $self;
+}
+
+sub file_path {
+    my ( $self, $base_dir, $ext ) = @_;
+    my @components = split( '::', $self->{source_class} );
+    unshift @components, $base_dir
+        if defined $base_dir;
+    $components[-1] .= $ext;
+    return catfile(@components);
+}
+
+sub include_h {
+    my $self = shift;
+    my @components = split( '::', $self->{source_class} );
+    $components[-1] .= '.h';
+    return join( '/', @components );
+}
+
+sub has_attribute { exists $_[0]->{attributes}{ $_[1] } }
+
+sub get_cnick             { shift->{cnick} }
+sub get_struct_sym        { shift->{struct_sym} }
+sub get_parent_class_name { shift->{parent_class_name} }
+sub get_source_class      { shift->{source_class} }
+sub get_docucomment       { shift->{docucomment} }
+sub get_parent            { shift->{parent} }
+sub get_autocode          { shift->{autocode} }
+sub inert                 { shift->{inert} }
+sub final                 { shift->{final} }
+
+sub set_parent { $_[0]->{parent} = $_[1] }
+
+sub vtable_var  { uc( shift->{struct_sym} ) }
+sub vtable_type { shift->vtable_var . '_VT' }
+
+sub append_autocode { $_[0]->{autocode} .= $_[1] }
+
+sub functions   { @{ shift->{functions} } }
+sub methods     { @{ shift->{methods} } }
+sub member_vars { @{ shift->{member_vars} } }
+sub inert_vars  { @{ shift->{inert_vars} } }
+sub children    { @{ shift->{children} } }
+
+sub novel_methods {
+    my $self = shift;
+    return
+        grep { $_->get_class_cnick eq $self->{cnick} } @{ $self->{methods} };
+}
+
+sub novel_member_vars {
+    my $self = shift;
+    return
+        grep { $_->get_class_cnick eq $self->{cnick} }
+        @{ $self->{member_vars} };
+}
+
+sub function {
+    my ( $self, $micro_sym ) = @_;
+    return $self->{func_by_name}{ lc($micro_sym) };
+}
+
+sub method {
+    my ( $self, $micro_sym ) = @_;
+    return $self->{meth_by_name}{ lc($micro_sym) };
+}
+
+sub novel_method {
+    my ( $self, $micro_sym ) = @_;
+    my $method = $self->{meth_by_name}{ lc($micro_sym) };
+    if ( defined $method
+        and $method->get_class_cnick eq $self->get_class_cnick )
+    {
+        return $method;
+    }
+    else {
+        return;
+    }
+}
+
+sub add_child {
+    my ( $self, $child ) = @_;
+    confess("Can't call add_child after grow_tree") if $self->{tree_grown};
+    push @{ $self->{children} }, $child;
+}
+
+sub add_method {
+    my ( $self, $method ) = @_;
+    confess("Not a Method") unless a_isa_b( $method, "Boilerplater::Method" );
+    confess("Can't call add_method after grow_tree") if $self->{tree_grown};
+    confess("Can't add_method to an inert class")    if $self->{inert};
+    push @{ $self->{methods} }, $method;
+    $self->{meth_by_name}{ $method->micro_sym } = $method;
+}
+
+sub grow_tree {
+    my $self = shift;
+    confess("Can't call grow_tree more than once") if $self->{tree_grown};
+    $self->_establish_ancestry;
+    $self->_bequeath_member_vars;
+    $self->_generate_automethods;
+    $self->_bequeath_methods;
+    $self->{tree_grown} = 1;
+}
+
+# Let the children know who their parent class is.
+sub _establish_ancestry {
+    my $self = shift;
+    for my $child ( @{ $self->{children} } ) {
+        # This is a circular reference and thus a memory leak, but we don't
+        # care, because we have to have everything in memory at once anyway.
+        $child->{parent} = $self;
+        $child->_establish_ancestry;
+    }
+}
+
+# Pass down member vars to from parent to children.
+sub _bequeath_member_vars {
+    my $self = shift;
+    for my $child ( @{ $self->{children} } ) {
+        unshift @{ $child->{member_vars} }, @{ $self->{member_vars} };
+        $child->_bequeath_member_vars;
+    }
+}
+
+# Create auto-generated methods.  This must be called after member vars are
+# passed down but before methods are passed down.
+sub _generate_automethods {
+    my $self = shift;
+    for my $child ( @{ $self->{children} } ) {
+        $child->_generate_automethods;
+    }
+}
+
+sub _bequeath_methods {
+    my $self = shift;
+
+    for my $child ( @{ $self->{children} } ) {
+        # Pass down methods, with some being overridden.
+        my @common_methods;    # methods which child inherits or overrides
+        for my $method ( @{ $self->{methods} } ) {
+            if ( exists $child->{meth_by_name}{ $method->micro_sym } ) {
+                my $child_method
+                    = $child->{meth_by_name}{ $method->micro_sym };
+                $child_method->override($method);
+                push @common_methods, $child_method;
+            }
+            else {
+                $child->{meth_by_name}{ $method->micro_sym } = $method;
+                push @common_methods, $method;
+            }
+        }
+
+        # Create array of methods, preserving exact order so vtables match up.
+        my @new_method_set;
+        my %seen;
+        for my $meth ( @common_methods, @{ $child->{methods} } ) {
+            next if $seen{ $meth->micro_sym };
+            $seen{ $meth->micro_sym } = 1;
+            if ( $child->final ) {
+                $meth = $meth->finalize if $child->final;
+                $child->{meth_by_name}{ $meth->micro_sym } = $meth;
+            }
+            push @new_method_set, $meth;
+        }
+        $child->{methods} = \@new_method_set;
+
+        # Pass it all down to the next generation.
+        $child->_bequeath_methods;
+        $child->{tree_grown} = 1;
+    }
+}
+
+sub tree_to_ladder {
+    my $self   = shift;
+    my @ladder = ($self);
+    for my $child ( @{ $self->{children} } ) {
+        push @ladder, $child->tree_to_ladder;
+    }
+    return @ladder;
+}
+
+1;
+
+__END__
+
+__POD__
+
+=head1 NAME
+
+Boilerplater::Class - An object representing a single class definition.
+
+=head1 CONSTRUCTORS
+
+Boilerplater::Class objects are stored as quasi-singletons, one for each
+unique parcel/class_name combination.
+
+=head2 fetch_singleton 
+
+    my $class = Boilerplater::Class->fetch_singleton(
+        parcel     => 'Boil',
+        class_name => 'Foo::Bar',
+    );
+
+Retrieve a Class, if one has already been created.
+
+=head2 create
+
+    my $class = Boilerplater::Class->create(
+        parcel            => 'Boil',        # default: special
+        class_name        => 'Foo::FooJr',  # required
+        cnick             => 'FooJr',       # default: derived from class_name
+        exposure          => 'public',      # default: 'parcel'
+        source_class      => 'Foo',         # default: same as class_name
+        parent_class_name => 'Obj',         # default: undef
+        inert             => undef,         # default: undef
+        methods           => \@methods,     # default: []
+        functions         => \@funcs,       # default: []
+        member_vars       => \@members,     # default: []
+        inert_vars        => \@inert_vars,  # default: []
+        docucomment       => $documcom,     # default: undef,
+        attributes        => \%attributes,  # default: {}
+    );
+
+Create and register a quasi-singleton.  May only be called once for each
+unique parcel/class_name combination.
+
+=over
+
+=item * B<parcel>, B<class_name>, B<cnick>, B<exposure> - see
+L<Boilerplater::Symbol>.
+
+=item * B<source_class> - The name of the class that owns the file in which
+this class was declared.  Should be "Foo" if "Foo::FooJr" is defined in
+C<Foo.bp>.
+
+=item * B<parent_class_name> - The name of this class's parent class.  Needed
+in order to establish the class hierarchy.
+
+=item * B<inert> - Should be true if the class is inert, i.e. cannot be
+instantiated.
+
+=item * B<methods> - An array where each element is a Boilerplater::Method.
+
+=item * B<functions> - An array where each element is a Boilerplater::Method.
+
+=item * B<member_vars> - An array where each element is a
+Boilerplater::Variable and should be a member variable in each instantiated
+object.
+
+=item * B<inert_vars> - An array where each element is a
+Boilerplater::Variable and should be a shared (class) variable.
+
+=item * B<docucomment> - A Boilerplater::DocuComment describing this Class.
+
+=item * B<attributes> - An arbitrary hash of attributes.
+
+=back
+
+=head1 METHODS
+
+=head2 get_cnick get_struct_sym get_parent_class_name get_source_class
+get_docucomment get_parent get_autocode inert final
+
+Accessors.
+
+=head2 set_parent
+
+    $class->set_parent($ancestor);
+
+Set the parent class.
+
+=head2 add_child
+
+    $class->add_child($child_class);
+
+Add a child class. 
+
+=head2 add_method
+
+    $class->add_method($method);
+
+Add a Method to the class.  Valid only before grow_tree() is called.
+
+=head2 function 
+
+    my $do_stuff_function = $class->function("do_stuff");
+
+Return the inert Function object for the supplied C<micro_sym>, if any.
+
+=head2 method
+
+    my $do_stuff_method = $class->method("Do_Stuff");
+
+Return the Method object for the supplied C<micro_sym> / C<macro_sym>, if any.
+
+=head2 novel_method
+
+    my $do_stuff_method = $class->novel_method("Do_Stuff");
+
+Return a Method object if the Method corresponding to the supplied string is
+novel.
+
+=head2 children 
+
+    my @child_classes = $class->children;
+
+Return all child classes as a list.
+
+=head2 functions
+
+    my @functions = $class->functions;
+
+Return all (inert) functions as a list.
+
+=head2 methods
+
+    my @methods = $class->methods;
+
+Return all methods as a list.
+
+=head2 inert_vars
+
+    my @inert_vars = $class->inert_vars;
+
+Return all inert (shared, class) variables as a list.
+
+=head2 member_vars
+
+    my @members = $class->member_vars;
+
+Return all member variables as a list.
+
+=head2 novel_methods
+
+    my @novel_methods = $class->novel_methods;
+
+Return all novel methods as a list.
+
+=head2 novel_member_vars
+
+    my @new_members = $class->novel_member_vars;
+
+Return all novel member variables as a list.
+
+=head2 grow_tree
+
+    $class->grow_tree;
+
+Bequeath all inherited methods and members to children.
+
+=head2 tree_to_ladder
+
+    my @ordered = $class->tree_to_ladder;
+
+Return this class and all its child classes as an array, where all children
+appear after their parent nodes.
+
+=head2 file_path
+
+    # /path/to/Foo/Bar.c, if source class is Foo::Bar.
+    my $path = $class->file_path( '/path/to', '.c' );
+
+Provide an OS-specific path for a file relating to this class could be found,
+by joining together the components of the C<source_class> name.
+
+=head2 include_h
+
+    my $relative_path = $class->include_h;
+
+Return a relative path to a C header file, appropriately formatted for a
+pound-include directive.
+
+=head2 append_autocode
+
+    $class->append_autocode($code);
+
+Append auxiliary C code.
+
+=head2 vtable_var
+
+The name of the global VTable object for this class.
+
+=head2 vtable_type
+
+The C type specifier for this class's vtable.  Each vtable needs to have its
+own type because each has a variable number of methods at the end of the
+struct, and it's not possible to initialize a static struct with a flexible
+array at the end under C89.
+
+=head1 COPYRIGHT AND LICENSE
+
+    /**
+     * Copyright 2009 The Apache Software Foundation
+     *
+     * Licensed 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.
+     */
+
+=cut

Propchange: lucene/lucy/trunk/boilerplater/lib/Boilerplater/Class.pm
------------------------------------------------------------------------------
    svn:eol-style = native

Modified: lucene/lucy/trunk/boilerplater/lib/Boilerplater/Parser.pm
URL: http://svn.apache.org/viewvc/lucene/lucy/trunk/boilerplater/lib/Boilerplater/Parser.pm?rev=807450&r1=807449&r2=807450&view=diff
==============================================================================
--- lucene/lucy/trunk/boilerplater/lib/Boilerplater/Parser.pm (original)
+++ lucene/lucy/trunk/boilerplater/lib/Boilerplater/Parser.pm Tue Aug 25 01:54:16 2009
@@ -18,6 +18,7 @@
 use Boilerplater::DocuComment;
 use Boilerplater::Function;
 use Boilerplater::Method;
+use Boilerplater::Class;
 use Carp;
 
 our $grammar = <<'END_GRAMMAR';
@@ -30,6 +31,35 @@
         $parcel;
     }
 
+class_declaration:
+    docucomment(?)
+    exposure_specifier(?) class_modifier(s?) 'class' class_name 
+        cnick(?)
+        class_extension(?)
+        class_attribute(s?)
+    '{'
+        declaration_statement[
+            class  => $item{class_name}, 
+            cnick  => $item{'cnick(?)'}[0],
+            parent => $item{'class_extension(?)'}[0],
+        ](s?)
+    '}'
+    { Boilerplater::Parser->new_class( \%item, \%arg ) }
+
+class_modifier:
+      'inert'
+    | 'abstract'
+    | 'final'
+    { $item[1] }
+
+class_extension:
+    'extends' class_name
+    { $item[2] }
+
+class_attribute:
+    ':' /[a-z]+(?!\w)/
+    { $item[2] }
+
 class_name:
     class_name_component ( "::" class_name_component )(s?)
     { join('::', $item[1], @{ $item[2] } ) }
@@ -42,6 +72,11 @@
     /([A-Z][A-Za-z0-9]+)(?!\w)/
     { $1 }
 
+declaration_statement:
+      var_declaration_statement[%arg]
+    | subroutine_declaration_statement[%arg]
+    | <error>
+
 var_declaration_statement:
     exposure_specifier(?) variable_modifier(s?) type declarator ';'
     {
@@ -368,6 +403,48 @@
     );
 }
 
+sub new_class {
+    my ( undef, $item, $arg ) = @_;
+    my ( @member_vars, @inert_vars, @functions, @methods );
+    my $source_class = $arg->{source_class} || $item->{class_name};
+    my %class_modifiers
+        = map { ( $_ => 1 ) } @{ $item->{'class_modifier(s?)'} };
+    my %class_attributes
+        = map { ( $_ => 1 ) } @{ $item->{'class_attribute(s?)'} };
+
+    for my $declaration ( @{ $item->{'declaration_statement(s?)'} } ) {
+        my $declared  = $declaration->{declared};
+        my $exposure  = $declaration->{exposure};
+        my $modifiers = $declaration->{modifiers};
+        my $inert     = ( scalar grep {/inert/} @$modifiers ) ? 1 : 0;
+        my $subs      = $inert ? \@functions : \@methods;
+        my $vars      = $inert ? \@inert_vars : \@member_vars;
+
+        if ( $declared->isa('Boilerplater::Variable') ) {
+            push @$vars, $declared;
+        }
+        else {
+            push @$subs, $declared;
+        }
+    }
+
+    return Boilerplater::Class->create(
+        parcel            => $parcel,
+        class_name        => $item->{class_name},
+        cnick             => $item->{'cnick(?)'}[0],
+        parent_class_name => $item->{'class_extension(?)'}[0],
+        member_vars       => \@member_vars,
+        functions         => \@functions,
+        methods           => \@methods,
+        inert_vars        => \@inert_vars,
+        docucomment       => $item->{'docucomment(?)'}[0],
+        source_class      => $source_class,
+        inert             => $class_modifiers{inert},
+        final             => $class_modifiers{final},
+        attributes        => \%class_attributes,
+    );
+}
+
 sub new_parcel {
     my ( undef, $item ) = @_;
     Boilerplater::Parcel->singleton(

Added: lucene/lucy/trunk/boilerplater/t/400-class.t
URL: http://svn.apache.org/viewvc/lucene/lucy/trunk/boilerplater/t/400-class.t?rev=807450&view=auto
==============================================================================
--- lucene/lucy/trunk/boilerplater/t/400-class.t (added)
+++ lucene/lucy/trunk/boilerplater/t/400-class.t Tue Aug 25 01:54:16 2009
@@ -0,0 +1,207 @@
+use strict;
+use warnings;
+
+use Test::More tests => 49;
+use Boilerplater::Class;
+use Boilerplater::Parser;
+
+my $parser = Boilerplater::Parser->new;
+
+my $thing = Boilerplater::Variable->new(
+    parcel     => 'Boil',
+    class_name => 'Foo',
+    type       => $parser->type('Thing*'),
+    micro_sym  => 'thing',
+);
+my $widget = Boilerplater::Variable->new(
+    class_name => 'Widget',
+    type       => $parser->type('Widget*'),
+    micro_sym  => 'widget',
+);
+my $tread_water = Boilerplater::Function->new(
+    parcel      => 'Boil',
+    class_name  => 'Foo',
+    return_type => $parser->type('void'),
+    micro_sym   => 'tread_water',
+    param_list  => $parser->param_list('()'),
+);
+my %foo_create_args = (
+    parcel      => 'Boil',
+    class_name  => 'Foo',
+    member_vars => [$thing],
+    inert_vars  => [$widget],
+    functions   => [$tread_water],
+);
+
+my $foo = Boilerplater::Class->create(%foo_create_args);
+eval { Boilerplater::Class->create(%foo_create_args) };
+like( $@, qr/conflict/i,
+    "Can't call create for the same class more than once" );
+my $should_be_foo = Boilerplater::Class->fetch_singleton(
+    parcel     => 'Boil',
+    class_name => 'Foo',
+);
+is( $foo, $should_be_foo, "fetch_singleton" );
+
+my $foo_jr = Boilerplater::Class->create(
+    parcel            => 'Boil',
+    class_name        => 'Foo::FooJr',
+    parent_class_name => 'Foo',
+    attributes        => { dumpable => 1 },
+);
+
+ok( $foo_jr->has_attribute('dumpable'), 'has_attribute' );
+is( $foo_jr->get_struct_sym, 'FooJr', "struct_sym" );
+
+my $final_foo = Boilerplater::Class->create(
+    parcel            => 'Boil',
+    class_name        => 'Foo::FooJr::FinalFoo',
+    parent_class_name => 'Foo::FooJr',
+    source_class      => 'Foo::FooJr',
+    final             => 1,
+    attributes        => { dumpable => 1 },
+);
+ok( $final_foo->final, "final" );
+is( $final_foo->file_path( '/path/to', '.c', ),
+    '/path/to/Foo/FooJr.c', "file_path" );
+is( $final_foo->include_h, 'Foo/FooJr.h', "inlude_h uses source_class" );
+is( $final_foo->get_parent_class_name, 'Foo::FooJr',
+    "get_parent_class_name" );
+
+my $do_stuff
+    = $parser->subroutine_declaration_statement( 'void Do_Stuff(Foo *self);',
+    0, class => 'Foo' )->{declared}
+    or die "parsing failure";
+$foo->add_method($do_stuff);
+
+my $inert_do_stuff
+    = $parser->subroutine_declaration_statement(
+    'void Do_Stuff(InertFoo *self);',
+    0, class => 'InertFoo' )->{declared}
+    or die "parsing failure";
+my %inert_args = (
+    parcel     => 'Boil',
+    class_name => 'InertFoo',
+    inert      => 1,
+);
+eval {
+    Boilerplater::Class->create( %inert_args, methods => [$inert_do_stuff] );
+};
+like(
+    $@,
+    qr/inert class/i,
+    "Error out on conflict between inert attribute and object method"
+);
+
+$foo->add_child($foo_jr);
+$foo_jr->add_child($final_foo);
+$foo->grow_tree;
+eval { $foo->grow_tree };
+like( $@, qr/grow_tree/, "call grow_tree only once." );
+eval { $foo_jr->add_method($do_stuff) };
+like( $@, qr/grow_tree/, "Forbid add_method after grow_tree." );
+
+is( $foo_jr->get_parent,            $foo,      "grow_tree, one level" );
+is( $final_foo->get_parent,         $foo_jr,   "grow_tree, two levels" );
+is( $foo->novel_method("Do_Stuff"), $do_stuff, 'novel_method' );
+is( $foo_jr->method("Do_Stuff"),    $do_stuff, "inherited method" );
+ok( !$foo_jr->novel_method("Do_Stuff"),    'inherited method not novel' );
+ok( $final_foo->method("Do_Stuff")->final, "Finalize inherited method" );
+ok( !$foo_jr->method("Do_Stuff")->final, "Don't finalize method in parent" );
+is_deeply( [ $foo->inert_vars ],        [$widget],      "inert vars" );
+is_deeply( [ $foo->functions ],         [$tread_water], "inert funcs" );
+is_deeply( [ $foo->methods ],           [$do_stuff],    "methods" );
+is_deeply( [ $foo->novel_methods ],     [$do_stuff],    "novel_methods" );
+is_deeply( [ $foo->novel_member_vars ], [$thing],       "novel_member_vars" );
+is_deeply( [ $foo_jr->member_vars ], [$thing], "inherit member vars" );
+is_deeply( [ $foo_jr->functions ],   [],       "don't inherit inert funcs" );
+is_deeply( [ $foo_jr->novel_member_vars ], [], "novel_member_vars" );
+is_deeply( [ $foo_jr->inert_vars ],        [], "don't inherit inert vars" );
+is_deeply( [ $final_foo->novel_methods ],  [], "novel_methods" );
+
+is_deeply(
+    [ $foo->tree_to_ladder ],
+    [ $foo, $foo_jr, $final_foo ],
+    'tree_to_ladder'
+);
+
+ok( $parser->class_modifier($_), "class_modifier: $_" )
+    for (qw( abstract inert ));
+
+ok( $parser->class_extension($_), "class_extension: $_" )
+    for ( 'extends Foo', 'extends Foo::FooJr::FooIII' );
+
+my $class_content
+    = 'public class Foo::FooJr cnick FooJr extends Foo { private int num; }';
+my $class = $parser->class_declaration($class_content);
+isa_ok( $class, "Boilerplater::Class", "class_declaration FooJr" );
+ok( ( scalar grep { $_->micro_sym eq 'num' } $class->member_vars ),
+    "parsed private member var" );
+
+$class_content = q|
+    /** 
+     * Bow wow.
+     *
+     * Wow wow wow.
+     */
+    public class Animal::Dog extends Animal : lovable : drooly {
+        public inert Dog* init(Dog *self, CharBuf *name, CharBuf *fave_food);
+        inert u32_t count();
+        inert u64_t num_dogs;
+
+        private CharBuf *name;
+        private bool_t   likes_to_go_fetch;
+        private void     Chase_Tail(Dog *self);
+
+        ChewToy *squishy;
+
+        void               Destroy(Dog *self);
+        public CharBuf*    Bark(Dog *self);
+        public void        Eat(Dog *self);
+        public void        Bite(Dog *self, Enemy *enemy);
+        public Thing      *Fetch(Dog *self, Thing *thing);
+        public final void  Bury(Dog *self, Bone *bone);
+        public Owner      *mom;
+
+        i32_t[1]  flexible_array_at_end_of_struct;
+    }
+|;
+
+$class = $parser->class_declaration($class_content);
+isa_ok( $class, "Boilerplater::Class", "class_declaration Dog" );
+ok( ( scalar grep { $_->micro_sym eq 'num_dogs' } $class->inert_vars ),
+    "parsed inert var" );
+ok( ( scalar grep { $_->micro_sym eq 'mom' } $class->member_vars ),
+    "parsed public member var" );
+ok( ( scalar grep { $_->micro_sym eq 'squishy' } $class->member_vars ),
+    "parsed parcel member var" );
+ok( ( scalar grep { $_->micro_sym eq 'init' } $class->functions ),
+    "parsed function" );
+ok( ( scalar grep { $_->micro_sym eq 'chase_tail' } $class->methods ),
+    "parsed private method" );
+ok( ( scalar grep { $_->micro_sym eq 'destroy' } $class->methods ),
+    "parsed parcel method" );
+ok( ( scalar grep { $_->micro_sym eq 'bury' } $class->methods ),
+    "parsed public method" );
+is( ( scalar grep { $_->public } $class->methods ),
+    5, "pass acl to Method constructor" );
+ok( $class->has_attribute('lovable'), "parsed class attribute" );
+ok( $class->has_attribute('drooly'),  "parsed second class attribute" );
+
+$class_content = qq|
+    parcel inert class Rigor::Mortis cnick Mort { 
+        parcel inert void lie_still(); 
+    }|;
+$class = $parser->class_declaration($class_content);
+isa_ok( $class, "Boilerplater::Class", "inert class_declaration" );
+ok( $class->inert, "inert modifier parsed and passed to constructor" );
+
+$class_content = qq|
+    final class Ultimo { 
+        /** Throws an error. 
+         */
+        void Say_Never(Ultimo *self); 
+    }|;
+$class = $parser->class_declaration($class_content);
+ok( $class->final, "final class_declaration" );
+

Propchange: lucene/lucy/trunk/boilerplater/t/400-class.t
------------------------------------------------------------------------------
    svn:eol-style = native



Mime
View raw message