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 2011/12/21 02:24:01 UTC
[lucy-commits] svn commit: r1221555 - in /incubator/lucy/trunk/clownfish: include/ perl/
perl/lib/ perl/lib/Clownfish/Binding/Perl/ src/
Author: marvin
Date: Wed Dec 21 01:24:00 2011
New Revision: 1221555
URL: http://svn.apache.org/viewvc?rev=1221555&view=rev
Log:
Revert porting of CFC Perl subroutine bindings.
Undo porting of CFCPerlSub, CFCPerlConstructor and CFCPerlMethod to C,
restoring the .pm files to the state the were in around May 2, 2011, then
applying a few fixes: r1149407, r1152065, r1152302, r1154343, r1212651 (all of
which I wrote). In the end, the files generated for Lucy are identical,
modulo some inconsequential whitespace -- "diff -urw old new" produces no
output.
Removed:
incubator/lucy/trunk/clownfish/src/CFCPerlConstructor.c
incubator/lucy/trunk/clownfish/src/CFCPerlConstructor.h
incubator/lucy/trunk/clownfish/src/CFCPerlMethod.c
incubator/lucy/trunk/clownfish/src/CFCPerlMethod.h
incubator/lucy/trunk/clownfish/src/CFCPerlSub.c
incubator/lucy/trunk/clownfish/src/CFCPerlSub.h
Modified:
incubator/lucy/trunk/clownfish/include/CFC.h
incubator/lucy/trunk/clownfish/perl/lib/Clownfish.pm
incubator/lucy/trunk/clownfish/perl/lib/Clownfish.xs
incubator/lucy/trunk/clownfish/perl/lib/Clownfish/Binding/Perl/Constructor.pm
incubator/lucy/trunk/clownfish/perl/lib/Clownfish/Binding/Perl/Method.pm
incubator/lucy/trunk/clownfish/perl/lib/Clownfish/Binding/Perl/Subroutine.pm
incubator/lucy/trunk/clownfish/perl/typemap
Modified: incubator/lucy/trunk/clownfish/include/CFC.h
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/include/CFC.h?rev=1221555&r1=1221554&r2=1221555&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/include/CFC.h (original)
+++ incubator/lucy/trunk/clownfish/include/CFC.h Wed Dec 21 01:24:00 2011
@@ -39,8 +39,5 @@
#include "CFCBindFunction.h"
#include "CFCBindMethod.h"
-#include "CFCPerlSub.h"
-#include "CFCPerlMethod.h"
-#include "CFCPerlConstructor.h"
#include "CFCPerlTypeMap.h"
Modified: incubator/lucy/trunk/clownfish/perl/lib/Clownfish.pm
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/perl/lib/Clownfish.pm?rev=1221555&r1=1221554&r2=1221555&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/perl/lib/Clownfish.pm (original)
+++ incubator/lucy/trunk/clownfish/perl/lib/Clownfish.pm Wed Dec 21 01:24:00 2011
@@ -82,6 +82,18 @@ BEGIN { XSLoader::load( 'Clownfish', '0.
}
{
+ package Clownfish::Binding::Perl::TypeMap;
+ use base qw( Exporter );
+
+ BEGIN { our @EXPORT_OK = qw( from_perl to_perl ) }
+
+ sub write_xs_typemap {
+ my ( undef, %args ) = @_;
+ _write_xs_typemap( $args{hierarchy} );
+ }
+}
+
+{
package Clownfish::Base;
}
@@ -630,38 +642,12 @@ BEGIN { XSLoader::load( 'Clownfish', '0.
{
package Clownfish::Binding::Perl::Constructor;
- BEGIN { push our @ISA, 'Clownfish::Binding::Perl::Subroutine' }
- use Carp;
- use Clownfish::Util qw( verify_args );
-
- our %new_PARAMS = (
- class => undef,
- alias => undef,
- );
-
- sub new {
- my ( $either, %args ) = @_;
- confess $@ unless verify_args( \%new_PARAMS, %args );
- return _new( @args{qw( class alias )} );
- }
+ use Clownfish::Binding::Perl::Class;
}
{
package Clownfish::Binding::Perl::Method;
- BEGIN { push our @ISA, 'Clownfish::Binding::Perl::Subroutine' }
- use Clownfish::Util qw( verify_args );
- use Carp;
-
- our %new_PARAMS = (
- method => undef,
- alias => undef,
- );
-
- sub new {
- my ( $either, %args ) = @_;
- confess $@ unless verify_args( \%new_PARAMS, %args );
- return _new( @args{qw( method alias )} );
- }
+ use Clownfish::Binding::Perl::Method;
}
{
@@ -705,23 +691,7 @@ BEGIN { XSLoader::load( 'Clownfish', '0.
{
package Clownfish::Binding::Perl::Subroutine;
- BEGIN { push our @ISA, 'Clownfish::Base' }
- use Carp;
- use Clownfish::Util qw( verify_args );
-
- sub xsub_def { confess "Abstract method" }
-}
-
-{
- package Clownfish::Binding::Perl::TypeMap;
- use base qw( Exporter );
-
- our @EXPORT_OK = qw( from_perl to_perl );
-
- sub write_xs_typemap {
- my ( undef, %args ) = @_;
- _write_xs_typemap( $args{hierarchy} );
- }
+ use Clownfish::Binding::Perl::Subroutine;
}
1;
Modified: incubator/lucy/trunk/clownfish/perl/lib/Clownfish.xs
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/perl/lib/Clownfish.xs?rev=1221555&r1=1221554&r2=1221555&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/perl/lib/Clownfish.xs (original)
+++ incubator/lucy/trunk/clownfish/perl/lib/Clownfish.xs Wed Dec 21 01:24:00 2011
@@ -1751,105 +1751,6 @@ _write_h(file, dest, header, footer)
PPCODE:
CFCBindFile_write_h(file, dest, header, footer);
-MODULE = Clownfish PACKAGE = Clownfish::Binding::Perl::Subroutine
-
-void
-_set_or_get(self, ...)
- CFCPerlSub *self;
-ALIAS:
- get_class_name = 2
- use_labeled_params = 4
- perl_name = 6
- get_param_list = 8
- c_name = 10
- c_name_list = 12
-PPCODE:
-{
- START_SET_OR_GET_SWITCH
- case 2: {
- const char *value = CFCPerlSub_get_class_name(self);
- retval = newSVpvn(value, strlen(value));
- }
- break;
- case 4:
- retval = newSViv(CFCPerlSub_use_labeled_params(self));
- break;
- case 6: {
- const char *value = CFCPerlSub_perl_name(self);
- retval = newSVpvn(value, strlen(value));
- }
- break;
- case 8: {
- CFCParamList *value = CFCPerlSub_get_param_list(self);
- retval = S_cfcbase_to_perlref(value);
- }
- break;
- case 10: {
- const char *value = CFCPerlSub_c_name(self);
- retval = newSVpvn(value, strlen(value));
- }
- break;
- case 12: {
- const char *value = CFCPerlSub_c_name_list(self);
- retval = newSVpvn(value, strlen(value));
- }
- break;
- END_SET_OR_GET_SWITCH
-}
-
-SV*
-params_hash_def(self)
- CFCPerlSub *self;
-CODE:
- RETVAL = S_sv_eat_c_string(CFCPerlSub_params_hash_def(self));
-OUTPUT: RETVAL
-
-SV*
-build_allot_params(self)
- CFCPerlSub *self;
-CODE:
- RETVAL = S_sv_eat_c_string(CFCPerlSub_build_allot_params(self));
-OUTPUT: RETVAL
-
-MODULE = Clownfish PACKAGE = Clownfish::Binding::Perl::Method
-
-SV*
-_new(method, alias)
- CFCMethod *method;
- const char *alias;
-CODE:
- CFCPerlMethod *self = CFCPerlMethod_new(method, alias);
- RETVAL = S_cfcbase_to_perlref(self);
- CFCBase_decref((CFCBase*)self);
-OUTPUT: RETVAL
-
-SV*
-xsub_def(self)
- CFCPerlMethod *self;
-CODE:
- RETVAL = S_sv_eat_c_string(CFCPerlMethod_xsub_def(self));
-OUTPUT: RETVAL
-
-
-MODULE = Clownfish PACKAGE = Clownfish::Binding::Perl::Constructor
-
-SV*
-_new(klass, alias)
- CFCClass *klass;
- const char *alias;
-CODE:
- CFCPerlConstructor *self = CFCPerlConstructor_new(klass, alias);
- RETVAL = S_cfcbase_to_perlref(self);
- CFCBase_decref((CFCBase*)self);
-OUTPUT: RETVAL
-
-SV*
-xsub_def(self)
- CFCPerlConstructor *self;
-CODE:
- RETVAL = S_sv_eat_c_string(CFCPerlConstructor_xsub_def(self));
-OUTPUT: RETVAL
-
MODULE = Clownfish PACKAGE = Clownfish::Binding::Perl::TypeMap
Modified: incubator/lucy/trunk/clownfish/perl/lib/Clownfish/Binding/Perl/Constructor.pm
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/perl/lib/Clownfish/Binding/Perl/Constructor.pm?rev=1221555&r1=1221554&r2=1221555&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/perl/lib/Clownfish/Binding/Perl/Constructor.pm (original)
+++ incubator/lucy/trunk/clownfish/perl/lib/Clownfish/Binding/Perl/Constructor.pm Wed Dec 21 01:24:00 2011
@@ -13,8 +13,95 @@
# See the License for the specific language governing permissions and
# limitations under the License.
+use strict;
+use warnings;
+
package Clownfish::Binding::Perl::Constructor;
-use Clownfish;
+use base qw( Clownfish::Binding::Perl::Subroutine );
+use Carp;
+use Clownfish::ParamList;
+
+sub new {
+ my ( $either, %args ) = @_;
+ my $class = delete $args{class};
+ my $alias = delete $args{alias};
+ my $init_func_name = $alias =~ s/^(\w+)\|(\w+)$/$1/ ? $2 : 'init';
+ my $class_name = $class->get_class_name;
+
+ # Find the implementing function.
+ my $func;
+ for my $function ( @{ $class->functions } ) {
+ next unless $function->micro_sym eq $init_func_name;
+ $func = $function;
+ last;
+ }
+ confess("Missing or invalid init() function for $class_name")
+ unless $func;
+
+ my $self = $either->SUPER::new(
+ param_list => $func->get_param_list,
+ class_name => $class_name,
+ use_labeled_params => 1,
+ alias => $alias,
+ %args
+ );
+ $self->{init_func} = $func;
+ return $self;
+}
+
+sub xsub_def {
+ my $self = shift;
+ my $c_name = $self->c_name;
+ my $param_list = $self->{param_list};
+ my $name_list = $param_list->name_list;
+ my $arg_inits = $param_list->get_initial_values;
+ my $arg_vars = $param_list->get_variables;
+ my $func_sym = $self->{init_func}->full_func_sym;
+ my $allot_params = $self->build_allot_params;
+
+ # Compensate for swallowed refcounts.
+ my $refcount_mods = "";
+ for ( my $i = 1; $i <= $#$arg_vars; $i++ ) {
+ my $var = $arg_vars->[$i];
+ my $type = $var->get_type;
+ if ( $type->is_object and $type->decremented ) {
+ my $name = $var->micro_sym;
+ $refcount_mods .= "\n CFISH_INCREF($name);";
+ }
+ }
+
+ # Last, so that earlier exceptions while fetching params don't trigger bad
+ # DESTROY.
+ my $self_var = $arg_vars->[0];
+ my $self_type = $self_var->get_type->to_c;
+ my $self_assign
+ = qq|$self_type self = ($self_type)XSBind_new_blank_obj(ST(0));|;
+
+ return <<END_STUFF;
+XS($c_name);
+XS($c_name) {
+ dXSARGS;
+ CHY_UNUSED_VAR(cv);
+ if (items < 1) { CFISH_THROW(CFISH_ERR, "Usage: %s(class_name, ...)", GvNAME(CvGV(cv))); }
+ SP -= items;
+
+ $allot_params
+ $self_assign$refcount_mods
+
+ $self_type retval = $func_sym($name_list);
+ if (retval) {
+ ST(0) = (SV*)Cfish_Obj_To_Host((cfish_Obj*)retval);
+ Cfish_Obj_Dec_RefCount((cfish_Obj*)retval);
+ }
+ else {
+ ST(0) = newSV(0);
+ }
+ sv_2mortal(ST(0));
+ XSRETURN(1);
+}
+
+END_STUFF
+}
1;
@@ -60,3 +147,4 @@ should be bound. The default function i
Generate the XSUB code.
=cut
+
Modified: incubator/lucy/trunk/clownfish/perl/lib/Clownfish/Binding/Perl/Method.pm
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/perl/lib/Clownfish/Binding/Perl/Method.pm?rev=1221555&r1=1221554&r2=1221555&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/perl/lib/Clownfish/Binding/Perl/Method.pm (original)
+++ incubator/lucy/trunk/clownfish/perl/lib/Clownfish/Binding/Perl/Method.pm Wed Dec 21 01:24:00 2011
@@ -13,8 +13,238 @@
# See the License for the specific language governing permissions and
# limitations under the License.
+use strict;
+use warnings;
+
package Clownfish::Binding::Perl::Method;
-use Clownfish;
+use base qw( Clownfish::Binding::Perl::Subroutine );
+use Clownfish::Util qw( verify_args );
+use Clownfish::Binding::Perl::TypeMap qw( from_perl to_perl );
+use Carp;
+
+our %new_PARAMS = (
+ method => undef,
+ alias => undef,
+);
+
+sub new {
+ my ( $either, %args ) = @_;
+ confess $@ unless verify_args( \%new_PARAMS, %args );
+
+ # Derive arguments to SUPER constructor from supplied Method.
+ my $method = delete $args{method};
+ $args{param_list} ||= $method->get_param_list;
+ $args{alias} ||= $method->micro_sym;
+ $args{class_name} ||= $method->get_class_name;
+ if ( !defined $args{use_labeled_params} ) {
+ $args{use_labeled_params}
+ = $method->get_param_list->num_vars > 2
+ ? 1
+ : 0;
+ }
+
+ # The Clownfish destructor needs to be spelled DESTROY for Perl.
+ if ( $args{alias} =~ /^destroy$/i ) {
+ $args{alias} = 'DESTROY';
+ }
+
+ my $self = $either->SUPER::new(%args);
+ $self->{method} = $method;
+
+ return $self;
+}
+
+sub xsub_def {
+ my $self = shift;
+ if ( $self->{use_labeled_params} ) {
+ return $self->_xsub_def_labeled_params;
+ }
+ else {
+ return $self->_xsub_def_positional_args;
+ }
+}
+
+# Build XSUB function body.
+sub _xsub_body {
+ my $self = shift;
+ my $method = $self->{method};
+ my $full_func_sym = $method->full_func_sym;
+ my $param_list = $method->get_param_list;
+ my $arg_vars = $param_list->get_variables;
+ my $name_list = $param_list->name_list;
+ my $body = "";
+
+ # Compensate for functions which eat refcounts.
+ for my $arg_var (@$arg_vars) {
+ my $arg_type = $arg_var->get_type;
+ next unless $arg_type->is_object;
+ next unless $arg_type->decremented;
+ my $var_name = $arg_var->micro_sym;
+ $body .= "CFISH_INCREF($var_name);\n ";
+ }
+
+ if ( $method->void ) {
+ # Invoke method in void context.
+ $body .= qq|$full_func_sym($name_list);\n| . qq| XSRETURN(0);|;
+ }
+ else {
+ # Return a value for method invoked in a scalar context.
+ my $return_type = $method->get_return_type;
+ my $type_str = $return_type->to_c;
+ my $retval_assignment
+ = "ST(0) = " . to_perl( $return_type, 'retval' ) . ';';
+ my $decrement = "";
+ if ( $return_type->is_object and $return_type->incremented ) {
+ $decrement = "\n CFISH_DECREF(retval);";
+ }
+ $body .= qq|$type_str retval = $full_func_sym($name_list);
+ $retval_assignment$decrement
+ sv_2mortal( ST(0) );
+ XSRETURN(1);|
+ }
+
+ return $body;
+}
+
+sub _xsub_def_positional_args {
+ my $self = shift;
+ my $method = $self->{method};
+ my $param_list = $method->get_param_list;
+ my $arg_vars = $param_list->get_variables;
+ my $arg_inits = $param_list->get_initial_values;
+ my $num_args = $param_list->num_vars;
+ my $c_name = $self->c_name;
+ my $body = $self->_xsub_body;
+
+ # Determine how many args are truly required and build an error check.
+ my $min_required = 0;
+ for ( my $i = 0; $i < $num_args; $i++ ) {
+ if ( !defined( $arg_inits->[$i] ) ) {
+ $min_required = $i + 1;
+ }
+ }
+ my @xs_arg_names;
+ for ( my $i = 0; $i < $num_args; $i++ ) {
+ my $var_name = $arg_vars->[$i]->micro_sym;
+ if ( $i < $min_required ) {
+ push @xs_arg_names, $var_name;
+ }
+ else {
+ push @xs_arg_names, "[$var_name]";
+ }
+ }
+ my $xs_name_list = join( ', ', @xs_arg_names );
+ my $num_args_check;
+ if ( $min_required < $num_args ) {
+ $num_args_check
+ = qq|if (items < $min_required) { |
+ . qq|CFISH_THROW(CFISH_ERR, "Usage: %s($xs_name_list)", |
+ . qq|GvNAME(CvGV(cv))); } |;
+ }
+ else {
+ $num_args_check = qq|if (items != $num_args) { |
+ . qq|CFISH_THROW(CFISH_ERR, "Usage: %s($xs_name_list)", |
+ . qq|GvNAME(CvGV(cv))); } |;
+ }
+
+ # Var assignments.
+ my @var_assignments;
+ for ( my $i = 0; $i < @$arg_vars; $i++ ) {
+ my $var = $arg_vars->[$i];
+ my $val = $arg_inits->[$i];
+ my $var_name = $var->micro_sym;
+ my $var_type = $var->get_type;
+ my $type_c = $var_type->to_c;
+ my $statement;
+ if ( $i == 0 ) { # $self
+ $statement
+ = _self_assign_statement( $var_type, $method->micro_sym );
+ }
+ else {
+ if ( defined $val ) {
+ $statement
+ = "$type_c $var_name = "
+ . "( items >= $i && XSBind_sv_defined(ST($i)) ) ? "
+ . from_perl( $var_type, "ST($i)" )
+ . " : $val;";
+ }
+ else {
+ $statement = "$type_c $var_name = "
+ . from_perl( $var_type, "ST($i)" ) . ';';
+ }
+ }
+ push @var_assignments, $statement;
+ }
+ my $var_assignments = join "\n ", @var_assignments;
+
+ return <<END_STUFF;
+XS($c_name);
+XS($c_name) {
+ dXSARGS;
+ CHY_UNUSED_VAR(cv);
+ SP -= items;
+ $num_args_check;
+
+ /* Extract vars from Perl stack. */
+ $var_assignments
+
+ /* Execute */
+ $body
+}
+END_STUFF
+}
+
+sub _xsub_def_labeled_params {
+ my $self = shift;
+ my $c_name = $self->c_name;
+ my $param_list = $self->{param_list};
+ my $arg_inits = $param_list->get_initial_values;
+ my $arg_vars = $param_list->get_variables;
+ my $self_var = $arg_vars->[0];
+ my $self_assign = _self_assign_statement( $self_var->get_type,
+ $self->{method}->micro_sym );
+ my $allot_params = $self->build_allot_params;
+ my $body = $self->_xsub_body;
+
+ # Prepare error message for incorrect args.
+ my $name_list = $self_var->micro_sym . ", ...";
+ my $num_args_check
+ = qq|if (items < 1) { |
+ . qq|CFISH_THROW(CFISH_ERR, "Usage: %s(self, ...)\", GvNAME(CvGV(cv))); }|;
+
+ return <<END_STUFF;
+XS($c_name);
+XS($c_name) {
+ dXSARGS;
+ CHY_UNUSED_VAR(cv);
+ $num_args_check
+ SP -= items;
+
+ /* Extract vars from Perl stack. */
+ $allot_params
+ $self_assign
+
+ /* Execute */
+ $body
+}
+END_STUFF
+}
+
+# Create an assignment statement for extracting $self from the Perl stack.
+sub _self_assign_statement {
+ my ( $type, $method_name ) = @_;
+ my $type_c = $type->to_c;
+ $type_c =~ /(\w+)\*$/ or die "Not an object type: $type_c";
+ my $vtable = uc($1);
+
+ # Make an exception for deserialize -- allow self to be NULL if called as
+ # a class method.
+ my $binding_func
+ = $method_name eq 'deserialize'
+ ? 'XSBind_maybe_sv_to_cfish_obj'
+ : 'XSBind_sv_to_cfish_obj';
+ return "$type_c self = ($type_c)$binding_func(ST(0), $vtable, NULL);";
+}
1;
@@ -54,3 +284,4 @@ will be set up to accept a single positi
Generate the XSUB code.
=cut
+
Modified: incubator/lucy/trunk/clownfish/perl/lib/Clownfish/Binding/Perl/Subroutine.pm
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/perl/lib/Clownfish/Binding/Perl/Subroutine.pm?rev=1221555&r1=1221554&r2=1221555&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/perl/lib/Clownfish/Binding/Perl/Subroutine.pm (original)
+++ incubator/lucy/trunk/clownfish/perl/lib/Clownfish/Binding/Perl/Subroutine.pm Wed Dec 21 01:24:00 2011
@@ -13,8 +13,178 @@
# See the License for the specific language governing permissions and
# limitations under the License.
+use strict;
+use warnings;
+
package Clownfish::Binding::Perl::Subroutine;
-use Clownfish;
+use Carp;
+use Scalar::Util qw( blessed );
+use Clownfish::Class;
+use Clownfish::Function;
+use Clownfish::Method;
+use Clownfish::Variable;
+use Clownfish::ParamList;
+use Clownfish::Util qw( verify_args );
+
+our %new_PARAMS = (
+ param_list => undef,
+ alias => undef,
+ class_name => undef,
+ use_labeled_params => undef,
+);
+
+sub new {
+ my $either = shift;
+ verify_args( \%new_PARAMS, @_ ) or confess $@;
+ my $self = bless { %new_PARAMS, @_, }, ref($either) || $either;
+ for (qw( param_list class_name alias )) {
+ confess("$_ is required") unless defined $self->{$_};
+ }
+ return $self;
+}
+
+sub get_class_name { shift->{class_name} }
+sub use_labeled_params { shift->{use_labeled_params} }
+
+sub perl_name {
+ my $self = shift;
+ return "$self->{class_name}::$self->{alias}";
+}
+
+sub c_name {
+ my $self = shift;
+ my $c_name = "XS_" . $self->perl_name;
+ $c_name =~ s/:+/_/g;
+ return $c_name;
+}
+
+sub c_name_list {
+ my $self = shift;
+ return $self->{param_list}->name_list;
+}
+
+my %params_hash_vals_map = (
+ NULL => 'undef',
+ true => 1,
+ false => 0,
+);
+
+sub params_hash_def {
+ my $self = shift;
+ return unless $self->{use_labeled_params};
+
+ my $params_hash_name = $self->perl_name . "_PARAMS";
+ my $arg_vars = $self->{param_list}->get_variables;
+ my $vals = $self->{param_list}->get_initial_values;
+ my @pairs;
+ for ( my $i = 1; $i < @$arg_vars; $i++ ) {
+ my $var = $arg_vars->[$i];
+ my $val = $vals->[$i];
+ if ( !defined $val ) {
+ $val = 'undef';
+ }
+ elsif ( exists $params_hash_vals_map{$val} ) {
+ $val = $params_hash_vals_map{$val};
+ }
+ push @pairs, $var->micro_sym . " => $val,";
+ }
+
+ if (@pairs) {
+ my $list = join( "\n ", @pairs );
+ return qq|\%$params_hash_name = (\n $list\n);\n|;
+ }
+ else {
+ return qq|\%$params_hash_name = ();\n|;
+ }
+}
+
+my %prim_type_to_allot_macro = (
+ double => 'ALLOT_F64',
+ float => 'ALLOT_F32',
+ int => 'ALLOT_INT',
+ short => 'ALLOT_SHORT',
+ long => 'ALLOT_LONG',
+ size_t => 'ALLOT_SIZE_T',
+ uint64_t => 'ALLOT_U64',
+ uint32_t => 'ALLOT_U32',
+ uint16_t => 'ALLOT_U16',
+ uint8_t => 'ALLOT_U8',
+ int64_t => 'ALLOT_I64',
+ int32_t => 'ALLOT_I32',
+ int16_t => 'ALLOT_I16',
+ int8_t => 'ALLOT_I8',
+ chy_bool_t => 'ALLOT_BOOL',
+);
+
+sub _allot_params_arg {
+ my ( $type, $label, $required ) = @_;
+ confess("Not a Clownfish::Type")
+ unless blessed($type) && $type->isa('Clownfish::Type');
+ my $len = length($label);
+ my $req_string = $required ? 'true' : 'false';
+
+ if ( $type->is_object ) {
+ my $struct_sym = $type->get_specifier;
+ my $vtable = uc($struct_sym);
+ if ( $struct_sym =~ /^[a-z_]*(Obj|CharBuf)$/ ) {
+ # Share buffers rather than copy between Perl scalars and
+ # Clownfish string types.
+ return qq|ALLOT_OBJ(\&$label, "$label", $len, $req_string, |
+ . qq|$vtable, alloca(cfish_ZCB_size()))|;
+ }
+ else {
+ return qq|ALLOT_OBJ(\&$label, "$label", $len, $req_string, |
+ . qq|$vtable, NULL)|;
+ }
+ }
+ elsif ( $type->is_primitive ) {
+ if ( my $allot = $prim_type_to_allot_macro{ $type->to_c } ) {
+ return qq|$allot(\&$label, "$label", $len, $req_string)|;
+ }
+ }
+
+ confess( "Missing typemap for " . $type->to_c );
+}
+
+sub build_allot_params {
+ my $self = shift;
+ my $param_list = $self->{param_list};
+ my $arg_inits = $param_list->get_initial_values;
+ my $arg_vars = $param_list->get_variables;
+ my $params_hash = $self->perl_name . "_PARAMS";
+ my $allot_params = "";
+
+ # Declare variables and assign default values.
+ for ( my $i = 1; $i <= $#$arg_vars; $i++ ) {
+ my $arg_var = $arg_vars->[$i];
+ my $val = $arg_inits->[$i];
+ if ( !defined($val) ) {
+ $val = $arg_var->get_type->is_object ? 'NULL' : '0';
+ }
+ $allot_params .= $arg_var->local_c . " = $val;\n ";
+ }
+
+ # Iterate over args in param list.
+ $allot_params .= qq|chy_bool_t args_ok = XSBind_allot_params(\n|
+ . qq| &(ST(0)), 1, items, "$params_hash",\n|;
+ for ( my $i = 1; $i <= $#$arg_vars; $i++ ) {
+ my $var = $arg_vars->[$i];
+ my $val = $arg_inits->[$i];
+ my $required = defined $val ? 0 : 1;
+ my $name = $var->micro_sym;
+ my $type = $var->get_type;
+ $allot_params .= " "
+ . _allot_params_arg( $type, $name, $required ) . ",\n";
+ }
+ $allot_params .= qq| NULL);
+ if (!args_ok) {
+ CFISH_RETHROW(CFISH_INCREF(cfish_Err_get_error()));
+ }|;
+
+ return $allot_params;
+}
+
+sub xsub_def { confess "Abstract method" }
1;
@@ -92,3 +262,4 @@ names of labeled params. The hash's nam
perl_name() plus "_PARAMS".
=cut
+
Modified: incubator/lucy/trunk/clownfish/perl/typemap
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/perl/typemap?rev=1221555&r1=1221554&r2=1221555&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/perl/typemap (original)
+++ incubator/lucy/trunk/clownfish/perl/typemap Wed Dec 21 01:24:00 2011
@@ -32,9 +32,6 @@ CFCType* CLOWNFISH_TYPE
CFCVariable* CLOWNFISH_TYPE
CFCBindCore* CLOWNFISH_BINDING_CORE
CFCBindClass* CLOWNFISH_BINDING_CORE_TYPE
-CFCPerlSub* CLOWNFISH_BINDING_PERL_SUBROUTINE
-CFCPerlConstructor* CLOWNFISH_BINDING_PERL_COMMON
-CFCPerlMethod* CLOWNFISH_BINDING_PERL_COMMON
INPUT
@@ -74,31 +71,6 @@ CLOWNFISH_BINDING_CORE_TYPE
croak(\"Not a ${(my $t = $type) =~ s/CFCBind(\w+).*/Clownfish::Binding::Core::$1/;\$t}\");
}
-CLOWNFISH_BINDING_PERL_COMMON
- if (!SvOK($arg)) {
- $var = NULL;
- }
- else if (sv_derived_from($arg, \"${(my $t = $type) =~ s/CFCPerl(\w+).*/Clownfish::Binding::Perl::$1/;\$t}\")) {
- IV objint = SvIV((SV*)SvRV($arg));
- $var = INT2PTR($type, objint);
- }
- else {
- croak(\"Not a ${(my $t = $type) =~ s/CFCPerl(\w+).*/Clownfish::Binding::Perl::$1/;\$t}\");
- }
-
-
-CLOWNFISH_BINDING_PERL_SUBROUTINE
- if (!SvOK($arg)) {
- $var = NULL;
- }
- else if (sv_derived_from($arg, \"Clownfish::Binding::Perl::Subroutine\")) {
- IV objint = SvIV((SV*)SvRV($arg));
- $var = INT2PTR($type, objint);
- }
- else {
- croak(\"Not a Clownfish::Binding::Perl::Subroutine\");
- }
-
OUTPUT
@@ -111,9 +83,3 @@ CLOWNFISH_BINDING_CORE
CLOWNFISH_BINDING_CORE_TYPE
sv_setref_pv($arg, \"${(my $t = $type) =~ s/CFCBind(\w+).*/Clownfish::Binding::Core::$1/;\$t}\", (void*)$var);
-CLOWNFISH_BINDING_PERL_COMMON
- sv_setref_pv($arg, \"${(my $t = $type) =~ s/CFCPerl(\w+).*/Clownfish::Binding::Perl::$1/;\$t}\", (void*)$var);
-
-CLOWNFISH_BINDING_PERL_SUBROUTINE
- sv_setref_pv($arg, \"Clownfish::Binding::Perl::Subroutine\", (void*)$var);
-