You are viewing a plain text version of this content. The canonical link for it is here.
Posted to commits@lucy.apache.org by ma...@apache.org on 2009/08/25 03:54:16 UTC
svn commit: r807450 - in /lucene/lucy/trunk/boilerplater:
lib/Boilerplater/Class.pm lib/Boilerplater/Parser.pm t/400-class.t
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