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 2012/01/23 01:32:03 UTC
[lucy-commits] svn commit: r1234658 - in /incubator/lucy/trunk/clownfish:
perl/lib/Clownfish/ perl/lib/Clownfish/CFC/Binding/
perl/lib/Clownfish/CFC/Binding/Perl/ src/
Author: marvin
Date: Mon Jan 23 00:32:02 2012
New Revision: 1234658
URL: http://svn.apache.org/viewvc?rev=1234658&view=rev
Log:
Port the rest of CFCPerlClass to C.
Modified:
incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC.pm
incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC.xs
incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC/Binding/Perl.pm
incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC/Binding/Perl/Class.pm
incubator/lucy/trunk/clownfish/src/CFCPerlClass.c
incubator/lucy/trunk/clownfish/src/CFCPerlClass.h
incubator/lucy/trunk/clownfish/src/CFCPerlConstructor.c
incubator/lucy/trunk/clownfish/src/CFCPerlConstructor.h
incubator/lucy/trunk/clownfish/src/CFCPerlPod.c
Modified: incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC.pm
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC.pm?rev=1234658&r1=1234657&r2=1234658&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC.pm (original)
+++ incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC.pm Mon Jan 23 00:32:02 2012
@@ -630,7 +630,99 @@ BEGIN { XSLoader::load( 'Clownfish::CFC'
{
package Clownfish::CFC::Binding::Perl::Class;
- use Clownfish::CFC::Binding::Perl::Class;
+ BEGIN { push our @ISA, 'Clownfish::CFC::Base' }
+ use Carp;
+ use Clownfish::CFC::Util qw( verify_args );
+
+ our %new_PARAMS = (
+ parcel => undef,
+ class_name => undef,
+ bind_methods => undef,
+ bind_constructors => undef,
+ make_pod => undef,
+ xs_code => undef,
+ client => undef,
+ );
+
+ sub new {
+ my ( $either, %args ) = @_;
+ verify_args( \%new_PARAMS, %args ) or confess $@;
+ $args{parcel} = Clownfish::CFC::Parcel->acquire( $args{parcel} );
+
+ # Validate.
+ confess("Missing required param 'class_name'")
+ unless $args{class_name};
+
+ # Retrieve Clownfish::CFC::Class client, if it will be needed.
+ my $client;
+ if ( $args{bind_methods}
+ || $args{bind_constructors}
+ || $args{make_pod} )
+ {
+ $args{client} = Clownfish::CFC::Class->fetch_singleton(
+ parcel => $args{parcel},
+ class_name => $args{class_name},
+ );
+ confess("Can't fetch singleton for $args{class_name}")
+ unless $args{client};
+ }
+
+ # Create Pod spec if needed.
+ my $pod_spec;
+ if ( $args{make_pod} ) {
+ $pod_spec = Clownfish::CFC::Binding::Perl::Pod->new(
+ %{ $args{make_pod} } );
+ }
+
+ # Create object.
+ my $self = _new( @args{qw( parcel class_name client xs_code )},
+ $pod_spec );
+
+ my $meth_list = $args{bind_methods} || [];
+ for my $meth_namespec (@$meth_list) {
+ my ( $alias, $name )
+ = $meth_namespec =~ /^(.*?)\|(.*)$/
+ ? ( $1, $2 )
+ : ( lc($meth_namespec), $meth_namespec );
+ $self->bind_method( alias => $alias, method => $name );
+ }
+
+ my $cons_list = $args{bind_constructors} || [];
+ for my $cons_namespec (@$cons_list) {
+ my ( $alias, $initializer )
+ = $cons_namespec =~ /^(.*?)\|(.*)$/
+ ? ( $1, $2 )
+ : ( $cons_namespec, undef );
+ $self->bind_constructor(
+ alias => $alias,
+ initializer => $initializer,
+ );
+ }
+
+ return $self;
+ }
+
+ our %bind_method_PARAMS = (
+ alias => undef,
+ method => undef,
+ );
+
+ sub bind_method {
+ my ( $self, %args ) = @_;
+ verify_args( \%bind_method_PARAMS, %args ) or confess $@;
+ _bind_method( $self, @args{qw( alias method )} );
+ }
+
+ our %bind_constructor_PARAMS = (
+ alias => undef,
+ initializer => undef,
+ );
+
+ sub bind_constructor {
+ my ( $self, %args ) = @_;
+ verify_args( \%bind_constructor_PARAMS, %args ) or confess $@;
+ _bind_constructor( $self, @args{qw( alias initializer )} );
+ }
}
{
@@ -640,14 +732,15 @@ BEGIN { XSLoader::load( 'Clownfish::CFC'
use Clownfish::CFC::Util qw( verify_args );
our %new_PARAMS = (
- class => undef,
- alias => undef,
+ class => undef,
+ alias => undef,
+ initializer => undef,
);
sub new {
my ( $either, %args ) = @_;
confess $@ unless verify_args( \%new_PARAMS, %args );
- return _new( @args{qw( class alias )} );
+ return _new( @args{qw( class alias initializer )} );
}
}
Modified: incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC.xs
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC.xs?rev=1234658&r1=1234657&r2=1234658&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC.xs (original)
+++ incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC.xs Mon Jan 23 00:32:02 2012
@@ -1836,11 +1836,13 @@ OUTPUT: RETVAL
MODULE = Clownfish PACKAGE = Clownfish::CFC::Binding::Perl::Constructor
SV*
-_new(klass, alias)
+_new(klass, alias, init_sv)
CFCClass *klass;
const char *alias;
+ SV *init_sv;
CODE:
- CFCPerlConstructor *self = CFCPerlConstructor_new(klass, alias);
+ const char *init = SvOK(init_sv) ? SvPVutf8_nolen(init_sv) : NULL;
+ CFCPerlConstructor *self = CFCPerlConstructor_new(klass, alias, init);
RETVAL = S_cfcbase_to_perlref(self);
CFCBase_decref((CFCBase*)self);
OUTPUT: RETVAL
@@ -1852,7 +1854,6 @@ CODE:
RETVAL = S_sv_eat_c_string(CFCPerlConstructor_xsub_def(self));
OUTPUT: RETVAL
-
MODULE = Clownfish PACKAGE = Clownfish::CFC::Binding::Perl::Class
SV*
@@ -1873,12 +1874,6 @@ CODE:
OUTPUT: RETVAL
void
-_destroy(self)
- CFCPerlClass *self;
-PPCODE:
- CFCBase_decref((CFCBase*)self);
-
-void
register(unused, binding)
SV *unused;
CFCPerlClass *binding;
@@ -1908,6 +1903,52 @@ PPCODE:
CFCPerlClass_clear_registry();
void
+_bind_method(self, alias_sv, meth_sv)
+ CFCPerlClass *self;
+ SV *alias_sv;
+ SV *meth_sv;
+PPCODE:
+ const char *alias = SvOK(alias_sv) ? SvPVutf8_nolen(alias_sv) : NULL;
+ const char *meth = SvOK(meth_sv) ? SvPVutf8_nolen(meth_sv) : NULL;
+ CFCPerlClass_bind_method(self, alias, meth);
+
+void
+_bind_constructor(self, alias_sv, init_sv)
+ CFCPerlClass *self;
+ SV *alias_sv;
+ SV *init_sv;
+PPCODE:
+ const char *alias = SvOK(alias_sv) ? SvPVutf8_nolen(alias_sv) : NULL;
+ const char *init = SvOK(init_sv) ? SvPVutf8_nolen(init_sv) : NULL;
+ CFCPerlClass_bind_constructor(self, alias, init);
+
+SV*
+method_bindings(self)
+ CFCPerlClass *self;
+CODE:
+ CFCPerlMethod **bound = CFCPerlClass_method_bindings(self);
+ RETVAL = S_array_of_cfcbase_to_av((CFCBase**)bound);
+ FREEMEM(bound);
+OUTPUT: RETVAL
+
+SV*
+constructor_bindings(self)
+ CFCPerlClass *self;
+CODE:
+ CFCPerlConstructor **bound = CFCPerlClass_constructor_bindings(self);
+ RETVAL = S_array_of_cfcbase_to_av((CFCBase**)bound);
+ FREEMEM(bound);
+OUTPUT: RETVAL
+
+SV*
+create_pod(self)
+ CFCPerlClass *self;
+CODE:
+ char *pod = CFCPerlClass_create_pod(self);
+ RETVAL = S_sv_eat_c_string(pod);
+OUTPUT: RETVAL
+
+void
_set_or_get(self, ...)
CFCPerlClass *self;
ALIAS:
Modified: incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC/Binding/Perl.pm
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC/Binding/Perl.pm?rev=1234658&r1=1234657&r2=1234658&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC/Binding/Perl.pm (original)
+++ incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC/Binding/Perl.pm Mon Jan 23 00:32:02 2012
@@ -87,18 +87,12 @@ sub write_bindings {
my @xsubs;
# Build up a roster of all requested bindings.
- my %has_constructors;
- my %has_methods;
my %has_xs_code;
for my $class (@$registered) {
my $class_name = $class->get_class_name;
my $class_binding
= Clownfish::CFC::Binding::Perl::Class->singleton($class_name)
or next;
- $has_constructors{$class_name} = 1
- if $class_binding->get_bind_constructors;
- $has_methods{$class_name} = 1
- if $class_binding->get_bind_methods;
$has_xs_code{$class_name} = 1
if $class_binding->get_xs_code;
}
@@ -113,23 +107,23 @@ sub write_bindings {
# Constructors.
for my $class (@$ordered) {
my $class_name = $class->get_class_name;
- next unless delete $has_constructors{$class_name};
my $class_binding
= Clownfish::CFC::Binding::Perl::Class->singleton($class_name);
- my @bound = $class_binding->constructor_bindings;
- $generated_xs .= $_->xsub_def . "\n" for @bound;
- push @xsubs, @bound;
+ next unless $class_binding;
+ my $bound = $class_binding->constructor_bindings;
+ $generated_xs .= $_->xsub_def . "\n" for @$bound;
+ push @xsubs, @$bound;
}
# Methods.
for my $class (@$ordered) {
my $class_name = $class->get_class_name;
- next unless delete $has_methods{$class_name};
my $class_binding
= Clownfish::CFC::Binding::Perl::Class->singleton($class_name);
- my @bound = $class_binding->method_bindings;
- $generated_xs .= $_->xsub_def . "\n" for @bound;
- push @xsubs, @bound;
+ next unless $class_binding;
+ my $bound = $class_binding->method_bindings;
+ $generated_xs .= $_->xsub_def . "\n" for @$bound;
+ push @xsubs, @$bound;
}
# Hand-rolled XS.
@@ -141,16 +135,6 @@ sub write_bindings {
%has_xs_code = ();
# Verify that all binding specs were processed.
- my @leftover_ctor = keys %has_constructors;
- if (@leftover_ctor) {
- confess( "Constructor bindings spec'd for non-existant classes: "
- . "'@leftover_ctor'" );
- }
- my @leftover_bound = keys %has_methods;
- if (@leftover_bound) {
- confess( "Method bindings spec'd for non-existant classes: "
- . "'@leftover_bound'" );
- }
my @leftover_xs = keys %has_xs_code;
if (@leftover_xs) {
confess( "Hand-rolled XS spec'd for non-existant classes: "
Modified: incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC/Binding/Perl/Class.pm
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC/Binding/Perl/Class.pm?rev=1234658&r1=1234657&r2=1234658&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC/Binding/Perl/Class.pm (original)
+++ incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC/Binding/Perl/Class.pm Mon Jan 23 00:32:02 2012
@@ -13,235 +13,8 @@
# See the License for the specific language governing permissions and
# limitations under the License.
-use strict;
-use warnings;
-
package Clownfish::CFC::Binding::Perl::Class;
-use base qw( Clownfish::CFC::Base );
-use Clownfish::CFC::Util qw( verify_args );
-use Clownfish::CFC::Binding::Perl::Pod;
-use Carp;
-
-our %new_PARAMS = (
- parcel => undef,
- class_name => undef,
- bind_methods => undef,
- bind_constructors => undef,
- make_pod => undef,
- xs_code => undef,
- client => undef,
-);
-
-our %bind_methods;
-our %bind_constructors;
-
-sub new {
- my ( $either, %args ) = @_;
- verify_args( \%new_PARAMS, %args ) or confess $@;
- $args{parcel} = Clownfish::CFC::Parcel->acquire( $args{parcel} );
-
- # Validate.
- confess("Missing required param 'class_name'")
- unless $args{class_name};
-
- # Retrieve Clownfish::CFC::Class client, if it will be needed.
- my $client;
- if ( $args{bind_methods}
- || $args{bind_constructors}
- || $args{make_pod} )
- {
- $args{client} = Clownfish::CFC::Class->fetch_singleton(
- parcel => $args{parcel},
- class_name => $args{class_name},
- );
- confess("Can't fetch singleton for $args{class_name}")
- unless $args{client};
- }
-
- # Create Pod spec if needed.
- my $pod_spec;
- if ( $args{make_pod} ) {
- $pod_spec
- = Clownfish::CFC::Binding::Perl::Pod->new( %{ $args{make_pod} } );
- }
-
- # Create object.
- my $self = _new( @args{qw( parcel class_name client xs_code )}, $pod_spec );
- $bind_methods{$$self} = $args{bind_methods};
- $bind_constructors{$$self} = $args{bind_constructors};
-
- return $self;
-}
-
-sub DESTROY {
- return; # Leak intentionally for now.
- my $self = shift;
- delete $bind_methods{$$self};
- delete $bind_constructors{$$self};
- _destroy($self);
-}
-
-sub get_bind_methods { $bind_methods{ ${ +shift } } }
-sub get_bind_constructors { $bind_constructors{ ${ +shift } } }
-
-sub constructor_bindings {
- my $self = shift;
- my @bound = map {
- my $xsub = Clownfish::CFC::Binding::Perl::Constructor->new(
- class => $self->get_client,
- alias => $_,
- );
- } @{ $self->get_bind_constructors };
- return @bound;
-}
-
-sub method_bindings {
- my $self = shift;
- my $client = $self->get_client;
- my $meth_list = $self->get_bind_methods;
- my $class_name = $self->get_class_name;
- my @bound;
-
- # Assemble a list of methods to be bound for this class.
- my %meth_to_bind;
- for my $meth_namespec (@$meth_list) {
- my ( $alias, $name )
- = $meth_namespec =~ /^(.*?)\|(.*)$/
- ? ( $1, $2 )
- : ( lc($meth_namespec), $meth_namespec );
- $meth_to_bind{$name} = { alias => $alias };
- }
-
- # Iterate over all this class's methods, stopping to bind each one that
- # was spec'd.
- for my $method ( @{ $client->methods } ) {
- my $meth_name = $method->get_macro_sym;
- my $bind_args = delete $meth_to_bind{$meth_name};
- next unless $bind_args;
-
- # Safety checks against excess binding code or private methods.
- if ( !$method->novel ) {
- confess( "Binding spec'd for method '$meth_name' in class "
- . "$class_name, but it's overridden and "
- . "should be bound via the parent class" );
- }
- elsif ( $method->private ) {
- confess( "Binding spec'd for method '$meth_name' in class "
- . "$class_name, but it's private" );
- }
-
- # Create an XSub binding for each override. Each of these directly
- # calls the implementing function, rather than invokes the method on
- # the object using VTable method dispatch. Doing things this way
- # allows SUPER:: invocations from Perl-space to work properly.
- for my $descendant ( @{ $client->tree_to_ladder } ) { # includes self
- my $real_method = $descendant->fresh_method( lc($meth_name) );
- next unless $real_method;
-
- # Create the binding, add it to the array.
- my $method_binding = Clownfish::CFC::Binding::Perl::Method->new(
- method => $real_method,
- %$bind_args,
- );
- push @bound, $method_binding;
- }
- }
-
- # Verify that we processed all methods.
- my @leftover_meths = keys %meth_to_bind;
- confess("Leftover for $class_name: '@leftover_meths'")
- if @leftover_meths;
-
- return @bound;
-}
-
-sub create_pod {
- my $self = shift;
- my $pod_spec = $self->get_pod_spec or return;
- my $class_name = $self->get_class_name;
- my $class = $self->get_client or die "No client for $class_name";
- my $docucom = $class->get_docucomment;
- confess("No DocuComment for '$class_name'") unless $docucom;
- my $brief = $docucom->get_brief;
- my $description = $pod_spec->_perlify_doc_text( $pod_spec->get_description
- || $docucom->get_long );
-
- # Create SYNOPSIS.
- my $synopsis_pod = $pod_spec->get_synopsis;
- if ($synopsis_pod) {
- $synopsis_pod = qq|=head1 SYNOPSIS\n\n$synopsis_pod\n|;
- }
-
- # Create CONSTRUCTORS.
- my $constructor_pod = $pod_spec->constructors_pod($class);
-
- # Create METHODS, possibly including an ABSTRACT METHODS section.
- my $methods_pod = $pod_spec->methods_pod($class);
-
- # Build an INHERITANCE section describing class ancestry.
- my $child = $class;
- my @ancestors;
- while ( defined( my $parent = $child->get_parent ) ) {
- push @ancestors, $parent;
- $child = $parent;
- }
- my $inheritance_pod = "";
- if (@ancestors) {
- $inheritance_pod = "=head1 INHERITANCE\n\n";
- $inheritance_pod .= $class->get_class_name;
- for my $ancestor (@ancestors) {
- my $class_name = $ancestor->get_class_name;
- if ( __PACKAGE__->singleton($class_name) ) {
- $inheritance_pod .= " isa L<$class_name>";
- }
- else {
- $inheritance_pod .= " isa $class_name";
- }
- }
- $inheritance_pod .= ".\n";
- }
-
- # Put it all together.
- my $pod = <<END_POD;
-# Auto-generated file -- DO NOT EDIT!!!!!
-
-# Licensed to the Apache Software Foundation (ASF) under one or more
-# contributor license agreements. See the NOTICE file distributed with
-# this work for additional information regarding copyright ownership.
-# The ASF licenses this file to You 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.
-
-=head1 NAME
-
-$class_name - $brief
-
-$synopsis_pod
-
-=head1 DESCRIPTION
-
-$description
-
-$constructor_pod
-
-$methods_pod
-
-$inheritance_pod
-
-=cut
-
-END_POD
-
- return $pod;
-}
+use Clownfish::CFC;
1;
@@ -312,8 +85,7 @@ All registered bindings.
=head1 OBJECT METHODS
-=head2 get_class_name get_bind_methods get_bind_methods get_pod_spec
-get_xs_code get_client
+=head2 get_class_name get_pod_spec get_xs_code get_client
Accessors. C<get_client> retrieves the Clownfish::CFC::Class module to be
bound.
Modified: incubator/lucy/trunk/clownfish/src/CFCPerlClass.c
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/src/CFCPerlClass.c?rev=1234658&r1=1234657&r2=1234658&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/src/CFCPerlClass.c (original)
+++ incubator/lucy/trunk/clownfish/src/CFCPerlClass.c Mon Jan 23 00:32:02 2012
@@ -17,17 +17,21 @@
#include <string.h>
#include <ctype.h>
#include <stdlib.h>
+#include <stdio.h>
#define CFC_NEED_BASE_STRUCT_DEF
#include "CFCBase.h"
#include "CFCPerlClass.h"
#include "CFCUtil.h"
#include "CFCClass.h"
+#include "CFCMethod.h"
#include "CFCParcel.h"
#include "CFCParamList.h"
#include "CFCFunction.h"
#include "CFCDocuComment.h"
#include "CFCSymbol.h"
#include "CFCPerlPod.h"
+#include "CFCPerlMethod.h"
+#include "CFCPerlConstructor.h"
struct CFCPerlClass {
CFCBase base;
@@ -36,6 +40,12 @@ struct CFCPerlClass {
CFCClass *client;
char *xs_code;
CFCPerlPod *pod_spec;
+ char **meth_aliases;
+ char **meth_names;
+ size_t num_methods;
+ char **cons_aliases;
+ char **cons_inits;
+ size_t num_cons;
};
static CFCPerlClass **registry = NULL;
@@ -67,6 +77,12 @@ CFCPerlClass_init(CFCPerlClass *self, CF
self->class_name = CFCUtil_strdup(class_name);
self->pod_spec = (CFCPerlPod*)CFCBase_incref((CFCBase*)pod_spec);
self->xs_code = xs_code ? CFCUtil_strdup(xs_code) : NULL;
+ self->meth_aliases = NULL;
+ self->meth_names = NULL;
+ self->num_methods = 0;
+ self->cons_aliases = NULL;
+ self->cons_inits = NULL;
+ self->num_cons = 0;
return self;
}
@@ -77,6 +93,18 @@ CFCPerlClass_destroy(CFCPerlClass *self)
CFCBase_decref((CFCBase*)self->pod_spec);
FREEMEM(self->class_name);
FREEMEM(self->xs_code);
+ for (size_t i = 0; i < self->num_methods; i++) {
+ FREEMEM(self->meth_aliases);
+ FREEMEM(self->meth_names);
+ }
+ FREEMEM(self->meth_aliases);
+ FREEMEM(self->meth_names);
+ for (size_t i = 0; i < self->num_cons; i++) {
+ FREEMEM(self->cons_aliases);
+ FREEMEM(self->cons_inits);
+ }
+ FREEMEM(self->cons_aliases);
+ FREEMEM(self->cons_inits);
CFCBase_destroy((CFCBase*)self);
}
@@ -136,6 +164,229 @@ CFCPerlClass_clear_registry(void) {
registry = NULL;
}
+void
+CFCPerlClass_bind_method(CFCPerlClass *self, const char *alias,
+ const char *method) {
+ size_t size = (self->num_methods + 1) * sizeof(char*);
+ self->meth_aliases = (char**)REALLOCATE(self->meth_aliases, size);
+ self->meth_names = (char**)REALLOCATE(self->meth_names, size);
+ self->meth_aliases[self->num_methods] = (char*)CFCUtil_strdup(alias);
+ self->meth_names[self->num_methods] = (char*)CFCUtil_strdup(method);
+ self->num_methods++;
+}
+
+void
+CFCPerlClass_bind_constructor(CFCPerlClass *self, const char *alias,
+ const char *initializer) {
+ size_t size = (self->num_cons + 1) * sizeof(char*);
+ self->cons_aliases = (char**)REALLOCATE(self->cons_aliases, size);
+ self->cons_inits = (char**)REALLOCATE(self->cons_inits, size);
+ self->cons_aliases[self->num_cons] = (char*)CFCUtil_strdup(alias);
+ self->cons_inits[self->num_cons] = (char*)CFCUtil_strdup(initializer);
+ self->num_cons++;
+}
+
+CFCPerlMethod**
+CFCPerlClass_method_bindings(CFCPerlClass *self) {
+ CFCClass *client = self->client;
+ const char *class_name = self->class_name;
+ size_t num_bound = 0;
+ CFCPerlMethod **bound
+ = (CFCPerlMethod**)CALLOCATE(1, sizeof(CFCPerlMethod*));
+
+ // Iterate over the list of methods to be bound.
+ for (size_t i = 0; i < self->num_methods; i++) {
+ const char *meth_name = self->meth_names[i];
+ CFCMethod *method = CFCClass_method(client, meth_name);
+
+ // Safety checks against bad specs, excess binding code or private
+ // methods.
+ if (!method) {
+ CFCUtil_die("Can't find method '%s' for class '%s'", meth_name,
+ class_name);
+ }
+ else if (!CFCMethod_novel(method)) {
+ CFCUtil_die("Binding spec'd for method '%s' in class '%s', "
+ "but it's overridden and should be bound via the "
+ "parent class", meth_name, class_name);
+ }
+ else if (CFCSymbol_private((CFCSymbol*)method)) {
+ CFCUtil_die("Can't bind private method '%s' in class '%s', ",
+ meth_name, class_name);
+ }
+
+ /* Create an XSub binding for each override. Each of these directly
+ * calls the implementing function, rather than invokes the method on
+ * the object using VTable method dispatch. Doing things this way
+ * allows SUPER:: invocations from Perl-space to work properly.
+ */
+ CFCClass **descendants = CFCClass_tree_to_ladder(client);
+ for (size_t j = 0; descendants[j] != NULL; j++) {
+ CFCClass *descendant = descendants[j];
+ CFCMethod *real_method
+ = CFCClass_fresh_method(descendant, meth_name);
+ if (!real_method) { continue; }
+
+ // Create the binding, add it to the array.
+ CFCPerlMethod *meth_binding
+ = CFCPerlMethod_new(real_method, self->meth_aliases[i]);
+ size_t size = (num_bound + 2) * sizeof(CFCPerlMethod*);
+ bound = (CFCPerlMethod**)REALLOCATE(bound, size);
+ bound[num_bound] = meth_binding;
+ num_bound++;
+ bound[num_bound] = NULL;
+ }
+ }
+
+ return bound;
+}
+
+CFCPerlConstructor**
+CFCPerlClass_constructor_bindings(CFCPerlClass *self) {
+ CFCClass *client = self->client;
+ size_t num_bound = 0;
+ CFCPerlConstructor **bound
+ = (CFCPerlConstructor**)CALLOCATE(1, sizeof(CFCPerlConstructor*));
+
+ // Iterate over the list of constructors to be bound.
+ for (size_t i = 0; i < self->num_cons; i++) {
+ // Create the binding, add it to the array.
+ CFCPerlConstructor *cons_binding
+ = CFCPerlConstructor_new(client, self->cons_aliases[i],
+ self->cons_inits[i]);
+ size_t size = (num_bound + 2) * sizeof(CFCPerlConstructor*);
+ bound = (CFCPerlConstructor**)REALLOCATE(bound, size);
+ bound[num_bound] = cons_binding;
+ num_bound++;
+ bound[num_bound] = NULL;
+ }
+
+ return bound;
+}
+
+char*
+CFCPerlClass_create_pod(CFCPerlClass *self) {
+ CFCPerlPod *pod_spec = self->pod_spec;
+ const char *class_name = self->class_name;
+ CFCClass *client = self->client;
+ if (!pod_spec) {
+ return NULL;
+ }
+ if (!client) {
+ CFCUtil_die("No client for %s", class_name);
+ }
+ CFCDocuComment *docucom = CFCClass_get_docucomment(client);
+ if (!docucom) {
+ CFCUtil_die("No DocuComment for %s", class_name);
+ }
+
+ // Get the class's brief description.
+ const char *raw_brief = CFCDocuComment_get_brief(docucom);
+ char *brief = CFCPerlPod_perlify_doc_text(pod_spec, raw_brief);
+
+ // Get the class's long description.
+ const char *raw_description = CFCPerlPod_get_description(pod_spec);
+ if (!raw_description || !strlen(raw_description)) {
+ raw_description = CFCDocuComment_get_long(docucom);
+ }
+ char *description = CFCPerlPod_perlify_doc_text(pod_spec, raw_description);
+
+ // Create SYNOPSIS.
+ const char *raw_synopsis = CFCPerlPod_get_synopsis(pod_spec);
+ char *synopsis = CFCUtil_strdup("");
+ if (raw_synopsis && strlen(raw_synopsis)) {
+ synopsis = CFCUtil_cat(synopsis, "=head1 SYNOPSIS\n\n", raw_synopsis,
+ "\n", NULL);
+ }
+
+ // Create CONSTRUCTORS.
+ char *constructor_pod = CFCPerlPod_constructors_pod(pod_spec, client);
+
+ // Create METHODS, possibly including an ABSTRACT METHODS section.
+ char *methods_pod = CFCPerlPod_methods_pod(pod_spec, client);
+
+ // Build an INHERITANCE section describing class ancestry.
+ char *inheritance = CFCUtil_strdup("");
+ if (CFCClass_get_parent(client)) {
+ inheritance = CFCUtil_cat(inheritance, "=head1 INHERITANCE\n\n",
+ class_name, NULL);
+ CFCClass *ancestor = client;
+ while (NULL != (ancestor = CFCClass_get_parent(ancestor))) {
+ const char *ancestor_klass = CFCClass_get_class_name(ancestor);
+ if (CFCPerlClass_singleton(ancestor_klass)) {
+ inheritance = CFCUtil_cat(inheritance, " isa L<",
+ ancestor_klass, ">", NULL);
+ }
+ else {
+ inheritance = CFCUtil_cat(inheritance, " isa ",
+ ancestor_klass, NULL);
+ }
+ }
+ inheritance = CFCUtil_cat(inheritance, ".\n", NULL);
+ }
+
+ // Put it all together.
+ const char pattern[] =
+ "# Auto-generated file -- DO NOT EDIT!!!!!\n"
+ "\n"
+ "# Licensed to the Apache Software Foundation (ASF) under one or more\n"
+ "# contributor license agreements. See the NOTICE file distributed with\n"
+ "# this work for additional information regarding copyright ownership.\n"
+ "# The ASF licenses this file to You under the Apache License, Version 2.0\n"
+ "# (the \"License\"); you may not use this file except in compliance with\n"
+ "# the License. You may obtain a copy of the License at\n"
+ "#\n"
+ "# http://www.apache.org/licenses/LICENSE-2.0\n"
+ "#\n"
+ "# Unless required by applicable law or agreed to in writing, software\n"
+ "# distributed under the License is distributed on an \"AS IS\" BASIS,\n"
+ "# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.\n"
+ "# See the License for the specific language governing permissions and\n"
+ "# limitations under the License.\n"
+ "\n"
+ "=head1 NAME\n"
+ "\n"
+ "%s - %s\n"
+ "\n"
+ "%s\n"
+ "\n"
+ "=head1 DESCRIPTION\n"
+ "\n"
+ "%s\n"
+ "\n"
+ "%s\n"
+ "\n"
+ "%s\n"
+ "\n"
+ "%s\n"
+ "\n"
+ "=cut\n"
+ "\n";
+
+ size_t size = sizeof(pattern)
+ + strlen(class_name)
+ + strlen(brief)
+ + strlen(synopsis)
+ + strlen(description)
+ + strlen(constructor_pod)
+ + strlen(methods_pod)
+ + strlen(inheritance)
+ + 20;
+
+ char *pod = (char*)MALLOCATE(size);
+ sprintf(pod, pattern, class_name, brief, synopsis, description,
+ constructor_pod, methods_pod, inheritance);
+
+ FREEMEM(brief);
+ FREEMEM(synopsis);
+ FREEMEM(description);
+ FREEMEM(constructor_pod);
+ FREEMEM(methods_pod);
+ FREEMEM(inheritance);
+
+ return pod;
+}
+
CFCClass*
CFCPerlClass_get_client(CFCPerlClass *self) {
return self->client;
Modified: incubator/lucy/trunk/clownfish/src/CFCPerlClass.h
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/src/CFCPerlClass.h?rev=1234658&r1=1234657&r2=1234658&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/src/CFCPerlClass.h (original)
+++ incubator/lucy/trunk/clownfish/src/CFCPerlClass.h Mon Jan 23 00:32:02 2012
@@ -26,6 +26,8 @@ struct CFCParcel;
struct CFCClass;
struct CFCFunction;
struct CFCPerlPod;
+struct CFCPerlMethod;
+struct CFCPerlConstructor;
CFCPerlClass*
CFCPerlClass_new(struct CFCParcel *parcel, const char *class_name,
@@ -52,6 +54,23 @@ CFCPerlClass_registry();
void
CFCPerlClass_clear_registry(void);
+void
+CFCPerlClass_bind_method(CFCPerlClass *self, const char *alias,
+ const char *method);
+
+void
+CFCPerlClass_bind_constructor(CFCPerlClass *self, const char *alias,
+ const char *initializer);
+
+struct CFCPerlMethod**
+CFCPerlClass_method_bindings(CFCPerlClass *self);
+
+struct CFCPerlConstructor**
+CFCPerlClass_constructor_bindings(CFCPerlClass *self);
+
+char*
+CFCPerlClass_create_pod(CFCPerlClass *self);
+
struct CFCClass*
CFCPerlClass_get_client(CFCPerlClass *self);
Modified: incubator/lucy/trunk/clownfish/src/CFCPerlConstructor.c
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/src/CFCPerlConstructor.c?rev=1234658&r1=1234657&r2=1234658&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/src/CFCPerlConstructor.c (original)
+++ incubator/lucy/trunk/clownfish/src/CFCPerlConstructor.c Mon Jan 23 00:32:02 2012
@@ -45,32 +45,20 @@ const static CFCMeta CFCPERLCONSTRUCTOR_
};
CFCPerlConstructor*
-CFCPerlConstructor_new(CFCClass *klass, const char *alias) {
+CFCPerlConstructor_new(CFCClass *klass, const char *alias,
+ const char *initializer) {
CFCPerlConstructor *self
= (CFCPerlConstructor*)CFCBase_allocate(&CFCPERLCONSTRUCTOR_META);
- return CFCPerlConstructor_init(self, klass, alias);
+ return CFCPerlConstructor_init(self, klass, alias, initializer);
}
CFCPerlConstructor*
CFCPerlConstructor_init(CFCPerlConstructor *self, CFCClass *klass,
- const char *alias) {
- // Extract alias from the alias spec, which may include a pipe. If it
- // does, then the Perl-space alias is on the left, and the name of the
- // init function is on the right: alias|init_func
+ const char *alias, const char *initializer) {
CFCUTIL_NULL_CHECK(alias);
- char *real_alias = CFCUtil_strdup(alias);
- char *init_func_name;
- const char *alias_end = strchr(alias, '|');
- if (alias_end) {
- size_t alias_len = alias_end - alias;
- real_alias[alias_len] = '\0';
- init_func_name = CFCUtil_strdup(alias_end + 1);
- }
- else {
- init_func_name = CFCUtil_strdup("init");
- }
-
+ CFCUTIL_NULL_CHECK(klass);
const char *class_name = CFCClass_get_class_name(klass);
+ initializer = initializer ? initializer : "init";
// Find the implementing function.
self->init_func = NULL;
@@ -78,20 +66,18 @@ CFCPerlConstructor_init(CFCPerlConstruct
for (size_t i = 0; funcs[i] != NULL; i++) {
CFCFunction *func = funcs[i];
const char *func_name = CFCFunction_micro_sym(func);
- if (strcmp(init_func_name, func_name) == 0) {
+ if (strcmp(initializer, func_name) == 0) {
self->init_func = (CFCFunction*)CFCBase_incref((CFCBase*)func);
break;
}
}
if (!self->init_func) {
CFCUtil_die("Missing or invalid '%s' function for '%s'",
- init_func_name, class_name);
+ initializer, class_name);
}
CFCParamList *param_list = CFCFunction_get_param_list(self->init_func);
- CFCPerlSub_init((CFCPerlSub*)self, param_list, class_name, real_alias,
+ CFCPerlSub_init((CFCPerlSub*)self, param_list, class_name, alias,
true);
- FREEMEM(init_func_name);
- FREEMEM(real_alias);
return self;
}
Modified: incubator/lucy/trunk/clownfish/src/CFCPerlConstructor.h
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/src/CFCPerlConstructor.h?rev=1234658&r1=1234657&r2=1234658&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/src/CFCPerlConstructor.h (original)
+++ incubator/lucy/trunk/clownfish/src/CFCPerlConstructor.h Mon Jan 23 00:32:02 2012
@@ -25,11 +25,12 @@ typedef struct CFCPerlConstructor CFCPer
struct CFCClass;
CFCPerlConstructor*
-CFCPerlConstructor_new(struct CFCClass *klass, const char *alias);
+CFCPerlConstructor_new(struct CFCClass *klass, const char *alias,
+ const char *initializer);
CFCPerlConstructor*
CFCPerlConstructor_init(CFCPerlConstructor *self, struct CFCClass *klass,
- const char *alias);
+ const char *alias, const char *initializer);
void
CFCPerlConstructor_destroy(CFCPerlConstructor *self);
Modified: incubator/lucy/trunk/clownfish/src/CFCPerlPod.c
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/src/CFCPerlPod.c?rev=1234658&r1=1234657&r2=1234658&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/src/CFCPerlPod.c (original)
+++ incubator/lucy/trunk/clownfish/src/CFCPerlPod.c Mon Jan 23 00:32:02 2012
@@ -86,6 +86,13 @@ CFCPerlPod_destroy(CFCPerlPod *self) {
FREEMEM(self->methods[i].sample);
}
FREEMEM(self->methods);
+ for (size_t i = 0; i < self->num_constructors; i++) {
+ FREEMEM(self->constructors[i].alias);
+ FREEMEM(self->constructors[i].pod);
+ FREEMEM(self->constructors[i].func);
+ FREEMEM(self->constructors[i].sample);
+ }
+ FREEMEM(self->constructors);
CFCBase_destroy((CFCBase*)self);
}