Mailing List Archive

Author: creamyg
Date: 2008-08-23 21:16:37 -0700 (Sat, 23 Aug 2008)
New Revision: 3753

Added:
trunk/boilerplater/lib/Boilerplater/Session.pm
trunk/boilerplater/t/500-session.t
Removed:
trunk/boilerplater/lib/Boilerplater/Hierarchy.pm
trunk/boilerplater/t/500-hierarchy.t
Modified:
trunk/boilerplater/MANIFEST
trunk/boilerplater/lib/Boilerplater/Binding/Perl.pm
trunk/boilerplater/lib/Boilerplater/Method.pm
trunk/c_src/KinoSearch/Test/TestQueryParserLogic.bp
trunk/c_src/KinoSearch/Test/TestQueryParserSyntax.bp
trunk/c_src/KinoSearch/Util/Carp.bp
trunk/perl/buildlib/Lucy/Build.pm
Log:
Replace Boilerplater::Hierarchy with Boilerplater::Session, which is similar
but supports multiple hierarchies. This means that not all objects have to
descend from Obj. We prove the point by breaking the inheritance of static
classes like KinoSearch::Util::Carp.


Modified: trunk/boilerplater/MANIFEST
===================================================================
--- trunk/boilerplater/MANIFEST 2008-08-24 01:31:31 UTC (rev 3752)
+++ trunk/boilerplater/MANIFEST 2008-08-24 04:16:37 UTC (rev 3753)
@@ -12,13 +12,13 @@
lib/Boilerplater/DocuComment.pm
lib/Boilerplater/File.pm
lib/Boilerplater/Function.pm
-lib/Boilerplater/Hierarchy.pm
lib/Boilerplater/Method.pm
lib/Boilerplater/Method/Final.pm
lib/Boilerplater/Method/Overridden.pm
lib/Boilerplater/ParamList.pm
lib/Boilerplater/Parcel.pm
lib/Boilerplater/Parser.pm
+lib/Boilerplater/Session.pm
lib/Boilerplater/Type.pm
lib/Boilerplater/Util.pm
lib/Boilerplater/Variable.pm
@@ -35,5 +35,5 @@
t/400-class.t
t/401-final_class.t
t/402-parcel.t
-t/500-hierarchy.t
+t/500-session.t
t/600-parser.t

Modified: trunk/boilerplater/lib/Boilerplater/Binding/Perl.pm
===================================================================
--- trunk/boilerplater/lib/Boilerplater/Binding/Perl.pm 2008-08-24 01:31:31 UTC (rev 3752)
+++ trunk/boilerplater/lib/Boilerplater/Binding/Perl.pm 2008-08-24 04:16:37 UTC (rev 3753)
@@ -3,7 +3,7 @@

package Boilerplater::Binding::Perl;

-use Boilerplater::Hierarchy;
+use Boilerplater::Session;
use Carp;
use File::Spec::Functions qw( catfile );
use Fcntl;
@@ -19,10 +19,10 @@
use Boilerplater::Binding::Perl::XSub::Constructor;

our %new_params = (
- hierarchy => undef,
- xs_path => undef,
- pm_path => undef,
- xs_code => undef,
+ session => undef,
+ xs_path => undef,
+ pm_path => undef,
+ xs_code => undef,
);

sub new {
@@ -39,7 +39,7 @@
@_,
},
ref($either) || $either;
- confess("hierarchy is mandatory") unless $self->{hierarchy};
+ confess("session is mandatory") unless $self->{session};
return $self;
}

@@ -75,7 +75,7 @@

sub write_bindings {
my $self = shift;
- my @ordered = $self->{hierarchy}->ordered_classes;
+ my @ordered = $self->{session}->ordered_classes;
my @xsubs;
my $xs = "";

@@ -313,7 +313,7 @@
for (qw( lib_dir )) {
confess "$_ is required" unless $args{$_};
}
- my @ordered = $self->{hierarchy}->ordered_classes;
+ my @ordered = $self->{session}->ordered_classes;
my $make_pod = $self->{make_pod};
my @files_written;

@@ -377,13 +377,13 @@
my $num_vars = $param_list->num_vars;

# Only allow "public" subs to be exposed as part of the public API.
- confess("$class_name->$sub_name is not public") unless $func->public;
+ confess("$class_name->$sub_name is not public") unless $func->public;

# Get documentation, which may be inherited.
my $docucom = $func->get_docu_comment;
- if (!$docucom) {
+ if ( !$docucom ) {
my $micro_name = $func->get_micro_name;
- my $parent = $class;
+ my $parent = $class;
while ( $parent = $parent->get_parent ) {
my $parent_func = $parent->method($micro_name);
last unless $parent_func;
@@ -446,8 +446,8 @@
my $constructor_pod = "";
if ( defined $pod_args->{constructor} ) {
$constructor_pod = "=head1 CONSTRUCTOR\n\n";
- my $init_func = $class->function('init');
- my $ctor_name = $pod_args->{constructor}{name} || 'new';
+ my $init_func = $class->function('init');
+ my $ctor_name = $pod_args->{constructor}{name} || 'new';
my $code_sample = $pod_args->{constructor}{sample};
$constructor_pod .= _perlify_doc_text(
$self->_gen_subroutine_pod(
@@ -528,13 +528,13 @@
}

sub _write_boot_h {
- my $self = shift;
- my $hierarchy = $self->{hierarchy};
- my $header = $hierarchy->get_header;
- my $footer = $hierarchy->get_footer;
- my $prefix = $hierarchy->get_prefix;
- my $PREFIX = $hierarchy->get_PREFIX;
- my $filepath = catfile( $hierarchy->get_dest_dir, $prefix . "boot.h" );
+ my $self = shift;
+ my $session = $self->{session};
+ my $header = $session->get_header;
+ my $footer = $session->get_footer;
+ my $prefix = $session->get_prefix;
+ my $PREFIX = $session->get_PREFIX;
+ my $filepath = catfile( $session->get_dest_dir, $prefix . "boot.h" );
unlink $filepath;
sysopen( my $fh, $filepath, O_CREAT | O_EXCL | O_WRONLY )
or confess("Can't open '$filepath': $!");
@@ -555,16 +555,16 @@

sub _write_boot_c {
my $self = shift;
- my $hierarchy = $self->{hierarchy};
- my $header = $hierarchy->get_header;
- my $footer = $hierarchy->get_footer;
- my @ordered = $hierarchy->ordered_classes;
+ my $session = $self->{session};
+ my $header = $session->get_header;
+ my $footer = $session->get_footer;
+ my @ordered = $session->ordered_classes;
my $num_classes = scalar @ordered;
my $pound_includes = "";
my $registrations = "";
my $isa_pushes = "";
- my $prefix = $hierarchy->get_prefix;
- my $PREFIX = $hierarchy->get_PREFIX;
+ my $prefix = $session->get_prefix;
+ my $PREFIX = $session->get_PREFIX;

for my $class (@ordered) {
my $include_h = $class->include_h;
@@ -584,7 +584,7 @@
$isa_pushes .= qq| isa = get_av("$class_name\::ISA", 1);\n|;
$isa_pushes .= qq| av_push(isa, newSVpv("$parent_class", 0));\n|;
}
- my $filepath = catfile( $hierarchy->get_dest_dir, $prefix . "boot.c" );
+ my $filepath = catfile( $session->get_dest_dir, $prefix . "boot.c" );
unlink $filepath;
sysopen( my $fh, $filepath, O_CREAT | O_EXCL | O_WRONLY )
or confess("Can't open '$filepath': $!");

Deleted: trunk/boilerplater/lib/Boilerplater/Hierarchy.pm
===================================================================
--- trunk/boilerplater/lib/Boilerplater/Hierarchy.pm 2008-08-24 01:31:31 UTC (rev 3752)
+++ trunk/boilerplater/lib/Boilerplater/Hierarchy.pm 2008-08-24 04:16:37 UTC (rev 3753)
@@ -1,360 +0,0 @@
-use strict;
-use warnings;
-
-package Boilerplater::Hierarchy;
-use base qw( Boilerplater::Base );
-use Carp;
-use File::Find qw( find );
-use File::Spec::Functions qw( catfile splitpath );
-use File::Path qw( mkpath );
-use Fcntl;
-
-use Boilerplater::Util qw( slurp_file current verify_args saved_error );
-use Boilerplater::Class;
-use Boilerplater::Class::Final;
-use Boilerplater::Parser;
-
-our %new_args = (
- base_dir => undef,
- dest_dir => undef,
- header => undef,
- footer => undef,
-);
-
-sub new {
- my $either = shift;
- confess saved_error() unless verify_args( \%new_args, @_ );
- my $self = $either->SUPER::new(
- tree => {}, # the hierarchy, with Obj at its base
- parser => Boilerplater::Parser->new,
- files => {},
- %new_args,
- @_,
- );
-
- # Validate.
- for (qw( base_dir dest_dir header footer )) {
- confess("$_ is mandatory") unless defined $self->{$_};
- }
-
- # Don't default the parcel -- set it during build().
- $self->set_parcel("_INVALID") unless defined $self->get_parcel;
-
- return $self;
-}
-
-# Accessors.
-sub get_base_dir { shift->{base_dir} }
-sub get_dest_dir { shift->{dest_dir} }
-sub get_header { shift->{header} }
-sub get_footer { shift->{footer} }
-
-# Return the flattened hierarchy.
-sub ordered_classes { shift->{tree}->tree_to_ladder }
-
-# Slurp all .bp files.
-# Arrange the class objects into a tree with Obj at the root.
-sub build {
- my $self = shift;
- my ( $base_dir, $dest_dir ) = @{$self}{qw( base_dir dest_dir )};
-
- # Collect filenames.
- my @all_source_paths;
- find(
- { wanted => sub {
- if ( $File::Find::name =~ /\.bp$/ ) {
- push @all_source_paths, $File::Find::name
- unless /#/; # skip emacs .#filename.h lock files
- }
- },
- no_chdir => 1,
- follow => 1, # follow symlinks if possible (noop on Windows)
- },
- $self->{base_dir},
- );
-
- # Process any file that has at least one class declaration.
- my %classes;
- for my $source_path (@all_source_paths) {
- # Derive the name of the class that owns the module file.
- my $source_class = $source_path;
- $source_class =~ s/\.bp$//;
- $source_class =~ s/^\Q$base_dir\E\W*//
- or die "'$source_path' doesn't start with '$base_dir'";
- $source_class =~ s/\W/::/g;
-
- # Slurp, parse, add parsed file to pool.
- my $content = slurp_file($source_path);
- $content = $self->{parser}->strip_plain_comments($content);
- my $file = $self->{parser}
- ->file( $content, 0, source_class => $source_class, );
- confess("parse error for $source_path") unless defined $file;
- $self->{files}{$source_class} = $file,
- $classes{ $_->get_class_name } = $_
- for $file->get_classes;
- }
-
- # Wrangle the classes into a hierarchy and figure out inheritance.
- while ( my ( $nickname, $class ) = each %classes ) {
- my $parent_name = $class->get_parent_class_name;
- next unless $parent_name; # skip if class is top node.
- if ( not exists $classes{$parent_name} ) {
- confess( "parent class '$parent_name' not defined "
- . "for class '"
- . $class->get_class_name
- . "'" );
- }
- $classes{$parent_name}->add_child($class);
- }
-
- # Make Obj the root.
- my ($obj_class) = grep {m/\bObj$/} keys %classes;
- $self->{tree} = $classes{$obj_class};
- $self->{tree}->bequeath;
- $self->set_parcel( $self->{tree}->get_parcel );
-}
-
-sub write_all_modified {
- my ( $self, $modified ) = @_;
-
- # Seed the recursive write.
- $modified = $self->_propagate_modified( $self->{tree}, $modified );
-
- my %written;
- while ( my ( $source_class, $file ) = each %{ $self->{files} } ) {
- next unless $file->get_modified;
- next if $written{$source_class};
- $written{$source_class} = 1;
- $file->write_h(
- dest_dir => $self->{dest_dir},
- header => $self->{header},
- footer => $self->{footer},
- );
- }
-
- return $modified;
-}
-
-# Recursive helper function.
-sub _propagate_modified {
- my ( $self, $class, $modified ) = @_;
- my $file = $self->{files}{ $class->get_source_class };
- my $source_path = $file->bp_path( $self->{base_dir} );
- my $h_path = $file->h_path( $self->{dest_dir} );
-
- if ( !current( $source_path, $h_path ) ) {
- $modified = 1;
- }
-
- if ($modified) {
- $file->set_modified($modified);
- }
-
- # Proceed to the next generation.
- my $somebody_is_modified = $modified;
- for my $kid ( $class->get_children ) {
- if ( $class->is_final ) {
- confess( "Attempt to inherit from final class "
- . $class->get_class_name . " by "
- . $kid->get_class_name );
- }
- if ( $self->_propagate_modified( $kid, $modified ) ) {
- $somebody_is_modified = 1;
- }
- }
-
- return $somebody_is_modified;
-}
-
-sub write_boil_h {
- my $self = shift;
- my @ordered = $self->{tree}->tree_to_ladder;
- my $typedefs = "";
- my $prefix = $self->get_prefix;
-
- for my $class (@ordered) {
- next if $class->static;
- my $struct = $class->get_struct_name;
- $typedefs .= "typedef struct $prefix$struct $prefix$struct;\n";
- }
- my $filepath = catfile( $self->{dest_dir}, $prefix . "boil.h" );
- unlink $filepath;
- sysopen( my $fh, $filepath, O_CREAT | O_EXCL | O_WRONLY )
- or confess("Can't open '$filepath': $!");
- print $fh <<END_STUFF;
-$self->{header}
-#ifndef BOIL_H
-#define BOIL_H 1
-
-#include <stddef.h>
-#include "charmony.h"
-
-typedef union boil_ref_t {
- chy_u32_t count;
- void *native;
-} boil_ref_t;
-
-$typedefs
-
-/* Generic method pointer.
- */
-typedef void
-(*${prefix}method_t)(struct ${prefix}Obj *self);
-
-#endif /* BOIL_H */
-
-$self->{footer}
-
-END_STUFF
-}
-
-# Write.
-sub write_boil_c {
- my $self = shift;
- my @ordered = $self->ordered_classes;
- my $num_classes = scalar @ordered;
- my $pound_includes = "";
- my $offsets = "";
- my $vtable_defs = "";
- my $registrations = "";
- my $isa_pushes = "";
- my $callback_funcs = "";
- my $callbacks = "";
- my $prefix = $self->get_prefix;
- my $PREFIX = $self->get_PREFIX;
-
- my @class_name_defs;
- for my $class (@ordered) {
- next if $class->static;
- push @class_name_defs, $class->name_var_definition;
- }
- my $class_names = join( "\n", @class_name_defs );
-
- for my $class (@ordered) {
- my $include_h = $class->include_h;
- $pound_includes .= qq|#include "$include_h"\n|;
- next if $class->static;
- my $class_cnick = $class->get_cnick;
- my $vt_type = $PREFIX . $class->vtable_type;
- my $meth_num = 0;
- my @class_callbacks;
- my %novel
- = map { ( $_->get_micro_name => $_ ) } $class->novel_methods;
-
- for my $method ( $class->get_methods ) {
- my $offset = "(offsetof($vt_type, methods)"
- . " + $meth_num * sizeof(${prefix}method_t))";
- my $var_name = $method->offset_var_name($class_cnick);
- $offsets .= "size_t $var_name = $offset;\n";
-
- # Define callbacks for methods that are OK to override natively.
- if ( $method->abstract ) {
- my $func_name = $method->get_full_func_name;
- my $callback_name = $func_name . "_CALLBACK";
- my $callback_obj = $method->callback_obj(
- func_name => $func_name,
- offset => $offset
- );
- if ( $novel{ $method->get_micro_name } ) {
- $callback_funcs .= $method->abstract_callback_def . "\n";
- $callbacks
- .= "kino_Callback $callback_name = $callback_obj;\n";
- }
- push @class_callbacks, "&$callback_name";
- }
- elsif ( $method->public ) {
- my $func_name = $method->get_full_func_name . "_OVERRIDE";
- my $callback_name = $method->get_full_func_name . "_CALLBACK";
- my $callback_obj = $method->callback_obj(
- func_name => $func_name,
- offset => $offset
- );
- if ( $novel{ $method->get_micro_name } ) {
- $callback_funcs .= $method->override_callback_def . "\n";
- $callbacks
- .= "kino_Callback $callback_name = $callback_obj;\n";
- }
- push @class_callbacks, "&$callback_name";
- }
- $meth_num++;
- }
- $vtable_defs .= $class->vtable_definition . "\n";
-
- my $callbacks_var = $PREFIX . $class->vtable_var . "_CALLBACKS";
- $callbacks .= "${prefix}Callback *$callbacks_var" . "[] = {\n ";
- $callbacks .= join( ",\n ", @class_callbacks, "NULL" );
- $callbacks .= "\n};\n";
- }
- my $filepath = catfile( $self->{dest_dir}, $prefix . "boil.c" );
- unlink $filepath;
- sysopen( my $fh, $filepath, O_CREAT | O_EXCL | O_WRONLY )
- or confess("Can't open '$filepath': $!");
- print $fh <<END_STUFF;
-$self->{header}
-
-#include "${prefix}boil.h"
-$pound_includes
-#include "KinoSearch/Util/Native.h"
-$offsets
-$callback_funcs
-$callbacks
-$class_names
-$vtable_defs
-
-$self->{footer}
-
-END_STUFF
-}
-
-1;
-
-__END__
-
-__POD__
-
-=head1 NAME
-
-Boilerplater::Hierarchy - A class hierarchy.
-
-=head1 METHODS
-
-=head2 new
-
- my $hierarchy = Boilerplater::Hierarchy->new(
- base_dir => undef, # required
- dest_dir => undef, # required
- header => undef, # required
- footer => undef, # required
- );
-
-=over
-
-=item *
-
-B<base_dir> - The directory we begin reading files from.
-
-=item *
-
-B<dest_dir> - The directory we write C header output files to.
-
-=item *
-
-B<header> - Text which will be prepended to each generated C file --
-typically, an "autogenerated file" warning.
-
-=item *
-
-B<footer> - Text to be appended to the end of each generated C file --
-typically copyright information.
-
-=back
-
-=head1 COPYRIGHT
-
-Copyright 2006-2008 Marvin Humphrey
-
-=head1 LICENSE, DISCLAIMER, BUGS, etc.
-
-See L<KinoSearch> version 0.20.
-
-=cut

Modified: trunk/boilerplater/lib/Boilerplater/Method.pm
===================================================================
--- trunk/boilerplater/lib/Boilerplater/Method.pm 2008-08-24 01:31:31 UTC (rev 3752)
+++ trunk/boilerplater/lib/Boilerplater/Method.pm 2008-08-24 04:16:37 UTC (rev 3753)
@@ -60,7 +60,7 @@
object.

All methods start out as plain old Method objects, because we don't know about
-inheritance until we build the Hierarchy after all files have been parsed.
+inheritance until we build the hierarchy after all files have been parsed.
override() is a way of going back and relabeling a method as overridden when
new information has become available: in this case, that a parent class has
defined a method with the same name.

Copied: trunk/boilerplater/lib/Boilerplater/Session.pm (from rev 3747, trunk/boilerplater/lib/Boilerplater/Hierarchy.pm)
===================================================================
--- trunk/boilerplater/lib/Boilerplater/Session.pm (rev 0)
+++ trunk/boilerplater/lib/Boilerplater/Session.pm 2008-08-24 04:16:37 UTC (rev 3753)
@@ -0,0 +1,377 @@
+use strict;
+use warnings;
+
+package Boilerplater::Session;
+use base qw( Boilerplater::Base );
+use Carp;
+use File::Find qw( find );
+use File::Spec::Functions qw( catfile splitpath );
+use File::Path qw( mkpath );
+use Fcntl;
+
+use Boilerplater::Util qw( slurp_file current verify_args saved_error );
+use Boilerplater::Class;
+use Boilerplater::Class::Final;
+use Boilerplater::Parser;
+
+our %new_args = (
+ base_dir => undef,
+ dest_dir => undef,
+ header => undef,
+ footer => undef,
+);
+
+sub new {
+ my $either = shift;
+ confess saved_error() unless verify_args( \%new_args, @_ );
+ my $self = $either->SUPER::new(
+ parser => Boilerplater::Parser->new,
+ trees => {},
+ files => {},
+ %new_args,
+ @_,
+ );
+
+ # Validate.
+ for (qw( base_dir dest_dir header footer )) {
+ confess("$_ is mandatory") unless defined $self->{$_};
+ }
+
+ # Don't default the parcel -- set it during build().
+ $self->set_parcel("_INVALID") unless defined $self->get_parcel;
+
+ return $self;
+}
+
+# Accessors.
+sub get_base_dir { shift->{base_dir} }
+sub get_dest_dir { shift->{dest_dir} }
+sub get_header { shift->{header} }
+sub get_footer { shift->{footer} }
+
+# Return flattened hierarchies.
+sub ordered_classes {
+ my $self = shift;
+ my @all;
+ for my $tree ( values %{ $self->{trees} } ) {
+ push @all, $tree->tree_to_ladder;
+ }
+ return @all;
+}
+
+# Slurp all .bp files.
+# Arrange the class objects into inheritance trees.
+sub build {
+ my $self = shift;
+ my ( $base_dir, $dest_dir ) = @{$self}{qw( base_dir dest_dir )};
+
+ # Collect filenames.
+ my @all_source_paths;
+ find(
+ { wanted => sub {
+ if ( $File::Find::name =~ /\.bp$/ ) {
+ push @all_source_paths, $File::Find::name
+ unless /#/; # skip emacs .#filename.h lock files
+ }
+ },
+ no_chdir => 1,
+ follow => 1, # follow symlinks if possible (noop on Windows)
+ },
+ $self->{base_dir},
+ );
+
+ # Process any file that has at least one class declaration.
+ my %classes;
+ for my $source_path (@all_source_paths) {
+ # Derive the name of the class that owns the module file.
+ my $source_class = $source_path;
+ $source_class =~ s/\.bp$//;
+ $source_class =~ s/^\Q$base_dir\E\W*//
+ or die "'$source_path' doesn't start with '$base_dir'";
+ $source_class =~ s/\W/::/g;
+
+ # Slurp, parse, add parsed file to pool.
+ my $content = slurp_file($source_path);
+ $content = $self->{parser}->strip_plain_comments($content);
+ my $file = $self->{parser}
+ ->file( $content, 0, source_class => $source_class, );
+ confess("parse error for $source_path") unless defined $file;
+ $self->{files}{$source_class} = $file;
+ for my $class ( $file->get_classes ) {
+ my $class_name = $class->get_class_name;
+ confess "$class_name already defined"
+ if exists $classes{$class_name};
+ $classes{$class_name} = $class;
+ }
+ }
+
+ # Wrangle the classes into hierarchies and figure out inheritance.
+ while ( my ( $class_name, $class ) = each %classes ) {
+ my $parent_name = $class->get_parent_class_name;
+ if ( defined $parent_name ) {
+ if ( not exists $classes{$parent_name} ) {
+ confess( "parent class '$parent_name' not defined "
+ . "for class '$class_name'" );
+ }
+ $classes{$parent_name}->add_child($class);
+ }
+ else {
+ $self->{trees}{$class_name} = $class;
+ }
+ }
+
+ for my $tree ( values %{ $self->{trees} } ) {
+ my $parcel = $tree->get_parcel;
+ $self->set_parcel($parcel) if $self->get_parcel eq '_INVALID';
+ confess("Can only support one parcel right now")
+ unless $self->get_parcel eq $parcel;
+ $tree->bequeath;
+ }
+}
+
+sub write_all_modified {
+ my ( $self, $modified ) = @_;
+
+ # Seed the recursive write.
+ for my $tree ( values %{ $self->{trees} } ) {
+ $modified = $self->_propagate_modified( $tree, $modified );
+ }
+
+ my %written;
+ while ( my ( $source_class, $file ) = each %{ $self->{files} } ) {
+ next unless $file->get_modified;
+ next if $written{$source_class};
+ $written{$source_class} = 1;
+ $file->write_h(
+ dest_dir => $self->{dest_dir},
+ header => $self->{header},
+ footer => $self->{footer},
+ );
+ }
+
+ return $modified;
+}
+
+# Recursive helper function.
+sub _propagate_modified {
+ my ( $self, $class, $modified ) = @_;
+ my $file = $self->{files}{ $class->get_source_class };
+ my $source_path = $file->bp_path( $self->{base_dir} );
+ my $h_path = $file->h_path( $self->{dest_dir} );
+
+ if ( !current( $source_path, $h_path ) ) {
+ $modified = 1;
+ }
+
+ if ($modified) {
+ $file->set_modified($modified);
+ }
+
+ # Proceed to the next generation.
+ my $somebody_is_modified = $modified;
+ for my $kid ( $class->get_children ) {
+ if ( $class->is_final ) {
+ confess( "Attempt to inherit from final class "
+ . $class->get_class_name . " by "
+ . $kid->get_class_name );
+ }
+ if ( $self->_propagate_modified( $kid, $modified ) ) {
+ $somebody_is_modified = 1;
+ }
+ }
+
+ return $somebody_is_modified;
+}
+
+sub write_boil_h {
+ my $self = shift;
+ my @ordered = $self->ordered_classes;
+ my $typedefs = "";
+ my $prefix = $self->get_prefix;
+
+ for my $class (@ordered) {
+ next if $class->static;
+ my $struct = $class->get_struct_name;
+ $typedefs .= "typedef struct $prefix$struct $prefix$struct;\n";
+ }
+ my $filepath = catfile( $self->{dest_dir}, $prefix . "boil.h" );
+ unlink $filepath;
+ sysopen( my $fh, $filepath, O_CREAT | O_EXCL | O_WRONLY )
+ or confess("Can't open '$filepath': $!");
+ print $fh <<END_STUFF;
+$self->{header}
+#ifndef BOIL_H
+#define BOIL_H 1
+
+#include <stddef.h>
+#include "charmony.h"
+
+typedef union boil_ref_t {
+ chy_u32_t count;
+ void *native;
+} boil_ref_t;
+
+$typedefs
+
+/* Generic method pointer.
+ */
+typedef void
+(*${prefix}method_t)(struct ${prefix}Obj *self);
+
+#endif /* BOIL_H */
+
+$self->{footer}
+
+END_STUFF
+}
+
+# Write.
+sub write_boil_c {
+ my $self = shift;
+ my @ordered = $self->ordered_classes;
+ my $num_classes = scalar @ordered;
+ my $pound_includes = "";
+ my $offsets = "";
+ my $vtable_defs = "";
+ my $registrations = "";
+ my $isa_pushes = "";
+ my $callback_funcs = "";
+ my $callbacks = "";
+ my $prefix = $self->get_prefix;
+ my $PREFIX = $self->get_PREFIX;
+
+ my @class_name_defs;
+ for my $class (@ordered) {
+ next if $class->static;
+ push @class_name_defs, $class->name_var_definition;
+ }
+ my $class_names = join( "\n", @class_name_defs );
+
+ for my $class (@ordered) {
+ my $include_h = $class->include_h;
+ $pound_includes .= qq|#include "$include_h"\n|;
+ next if $class->static;
+ my $class_cnick = $class->get_cnick;
+ my $vt_type = $PREFIX . $class->vtable_type;
+ my $meth_num = 0;
+ my @class_callbacks;
+ my %novel
+ = map { ( $_->get_micro_name => $_ ) } $class->novel_methods;
+
+ for my $method ( $class->get_methods ) {
+ my $offset = "(offsetof($vt_type, methods)"
+ . " + $meth_num * sizeof(${prefix}method_t))";
+ my $var_name = $method->offset_var_name($class_cnick);
+ $offsets .= "size_t $var_name = $offset;\n";
+
+ # Define callbacks for methods that are OK to override natively.
+ if ( $method->abstract ) {
+ my $func_name = $method->get_full_func_name;
+ my $callback_name = $func_name . "_CALLBACK";
+ my $callback_obj = $method->callback_obj(
+ func_name => $func_name,
+ offset => $offset
+ );
+ if ( $novel{ $method->get_micro_name } ) {
+ $callback_funcs .= $method->abstract_callback_def . "\n";
+ $callbacks
+ .= "kino_Callback $callback_name = $callback_obj;\n";
+ }
+ push @class_callbacks, "&$callback_name";
+ }
+ elsif ( $method->public ) {
+ my $func_name = $method->get_full_func_name . "_OVERRIDE";
+ my $callback_name = $method->get_full_func_name . "_CALLBACK";
+ my $callback_obj = $method->callback_obj(
+ func_name => $func_name,
+ offset => $offset
+ );
+ if ( $novel{ $method->get_micro_name } ) {
+ $callback_funcs .= $method->override_callback_def . "\n";
+ $callbacks
+ .= "kino_Callback $callback_name = $callback_obj;\n";
+ }
+ push @class_callbacks, "&$callback_name";
+ }
+ $meth_num++;
+ }
+ $vtable_defs .= $class->vtable_definition . "\n";
+
+ my $callbacks_var = $PREFIX . $class->vtable_var . "_CALLBACKS";
+ $callbacks .= "${prefix}Callback *$callbacks_var" . "[] = {\n ";
+ $callbacks .= join( ",\n ", @class_callbacks, "NULL" );
+ $callbacks .= "\n};\n";
+ }
+ my $filepath = catfile( $self->{dest_dir}, $prefix . "boil.c" );
+ unlink $filepath;
+ sysopen( my $fh, $filepath, O_CREAT | O_EXCL | O_WRONLY )
+ or confess("Can't open '$filepath': $!");
+ print $fh <<END_STUFF;
+$self->{header}
+
+#include "${prefix}boil.h"
+$pound_includes
+#include "KinoSearch/Util/Native.h"
+$offsets
+$callback_funcs
+$callbacks
+$class_names
+$vtable_defs
+
+$self->{footer}
+
+END_STUFF
+}
+
+1;
+
+__END__
+
+__POD__
+
+=head1 NAME
+
+Boilerplater::Session - A compilation session.
+
+=head1 METHODS
+
+=head2 new
+
+ my $session = Boilerplater::Session->new(
+ base_dir => undef, # required
+ dest_dir => undef, # required
+ header => undef, # required
+ footer => undef, # required
+ );
+
+=over
+
+=item *
+
+B<base_dir> - The directory we begin reading files from.
+
+=item *
+
+B<dest_dir> - The directory we write C header output files to.
+
+=item *
+
+B<header> - Text which will be prepended to each generated C file --
+typically, an "autogenerated file" warning.
+
+=item *
+
+B<footer> - Text to be appended to the end of each generated C file --
+typically copyright information.
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2006-2008 Marvin Humphrey
+
+=head1 LICENSE, DISCLAIMER, BUGS, etc.
+
+See L<KinoSearch> version 0.20.
+
+=cut

Deleted: trunk/boilerplater/t/500-hierarchy.t
===================================================================
--- trunk/boilerplater/t/500-hierarchy.t 2008-08-24 01:31:31 UTC (rev 3752)
+++ trunk/boilerplater/t/500-hierarchy.t 2008-08-24 04:16:37 UTC (rev 3753)
@@ -1,19 +0,0 @@
-use strict;
-use warnings;
-
-use Test::More tests => 3;
-
-BEGIN { use_ok('Boilerplater::Hierarchy') }
-
-my %args = (
- base_dir => 't/bp',
- dest_dir => 't/r',
- header => "HEAD_START\n",
- footer => "THIS_LOOKS_LIKE_THE_END\n",
-);
-
-my $hierarchy = Boilerplater::Hierarchy->new(%args);
-isa_ok( $hierarchy, "Boilerplater::Hierarchy" );
-
-eval { my $death = Boilerplater::Hierarchy->new( %args, extra_arg => undef ) };
-like( $@, qr/extra_arg/, "Extra arg kills constructor" );

Copied: trunk/boilerplater/t/500-session.t (from rev 3747, trunk/boilerplater/t/500-hierarchy.t)
===================================================================
--- trunk/boilerplater/t/500-session.t (rev 0)
+++ trunk/boilerplater/t/500-session.t 2008-08-24 04:16:37 UTC (rev 3753)
@@ -0,0 +1,19 @@
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+
+BEGIN { use_ok('Boilerplater::Session') }
+
+my %args = (
+ base_dir => 't/bp',
+ dest_dir => 't/r',
+ header => "HEAD_START\n",
+ footer => "THIS_LOOKS_LIKE_THE_END\n",
+);
+
+my $session = Boilerplater::Session->new(%args);
+isa_ok( $session, "Boilerplater::Session" );
+
+eval { my $death = Boilerplater::Session->new( %args, extra_arg => undef ) };
+like( $@, qr/extra_arg/, "Extra arg kills constructor" );

Modified: trunk/c_src/KinoSearch/Test/TestQueryParserLogic.bp
===================================================================
--- trunk/c_src/KinoSearch/Test/TestQueryParserLogic.bp 2008-08-24 01:31:31 UTC (rev 3752)
+++ trunk/c_src/KinoSearch/Test/TestQueryParserLogic.bp 2008-08-24 04:16:37 UTC (rev 3753)
@@ -3,9 +3,7 @@
/** Tests for logical structure of Query objects output by QueryParser.
*/

-static class KinoSearch::Test::TestQueryParserLogic cnick TestQPLogic
- extends KinoSearch::Obj {
-
+static class KinoSearch::Test::TestQueryParserLogic cnick TestQPLogic {
static incremented VArray*
logical_tests(const CharBuf *boolop);


Modified: trunk/c_src/KinoSearch/Test/TestQueryParserSyntax.bp
===================================================================
--- trunk/c_src/KinoSearch/Test/TestQueryParserSyntax.bp 2008-08-24 01:31:31 UTC (rev 3752)
+++ trunk/c_src/KinoSearch/Test/TestQueryParserSyntax.bp 2008-08-24 04:16:37 UTC (rev 3753)
@@ -3,9 +3,7 @@
/** Tests for logical structure of Query objects output by QueryParser.
*/

-static class KinoSearch::Test::TestQueryParserSyntax cnick TestQPSyntax
- extends KinoSearch::Obj {
-
+static class KinoSearch::Test::TestQueryParserSyntax cnick TestQPSyntax {
static incremented VArray*
leaf_tests();


Modified: trunk/c_src/KinoSearch/Util/Carp.bp
===================================================================
--- trunk/c_src/KinoSearch/Util/Carp.bp 2008-08-24 01:31:31 UTC (rev 3752)
+++ trunk/c_src/KinoSearch/Util/Carp.bp 2008-08-24 04:16:37 UTC (rev 3753)
@@ -4,7 +4,7 @@
* Error handling.
*/

-static class KinoSearch::Util::Carp extends KinoSearch::Obj {
+static class KinoSearch::Util::Carp {

/* Print an error message to stderr with some C contextual information.
* Usually invoked via the WARN(pattern, ...) macro.

Modified: trunk/perl/buildlib/Lucy/Build.pm
===================================================================
--- trunk/perl/buildlib/Lucy/Build.pm 2008-08-24 01:31:31 UTC (rev 3752)
+++ trunk/perl/buildlib/Lucy/Build.pm 2008-08-24 04:16:37 UTC (rev 3753)
@@ -31,7 +31,7 @@
use Parse::RecDescent;|;
my $bad_dep = $@;
eval q|
- use Boilerplater::Hierarchy;
+ use Boilerplater::Session;
use Boilerplater::Binding::Perl;
|;
die $@ if $@ && !$bad_dep;
@@ -332,19 +332,19 @@
}
}

- my $hierarchy = Boilerplater::Hierarchy->new(
+ my $session = Boilerplater::Session->new(
base_dir => $C_SOURCE_DIR,
dest_dir => $H_SOURCE_DIR,
header => $self->autogen_header,
footer => $self->copyfoot,
);
- $hierarchy->build;
+ $session->build;

# Write out all autogenerated files.
- my $modified = $hierarchy->write_all_modified;
+ my $modified = $session->write_all_modified;
if ($modified) {
- $hierarchy->write_boil_h;
- $hierarchy->write_boil_c;
+ $session->write_boil_h;
+ $session->write_boil_c;
}

# Rewrite XS if either any .bp files or relevant .pm files were modified.
@@ -353,10 +353,10 @@

if ($modified) {
my $binding = Boilerplater::Binding::Perl->new(
- hierarchy => $hierarchy,
- pm_path => $AUTOBIND_PM_PATH,
- xs_path => $XS_FILEPATH,
- xs_code => $xs_code,
+ session => $session,
+ pm_path => $AUTOBIND_PM_PATH,
+ xs_path => $XS_FILEPATH,
+ xs_code => $xs_code,
);
while ( my ( $class_name, $lists ) = each %auto_xs ) {
$binding->add_class( class_name => $class_name, %$lists );


_______________________________________________
kinosearch-commits mailing list
kinosearch-commits@rectangular.com
http://www.rectangular.com/mailman/listinfo/kinosearch-commits