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/18 00:54:24 UTC
[lucy-commits] svn commit: r1232654 - in /incubator/lucy/trunk/clownfish: include/ perl/
perl/lib/Clownfish/ perl/lib/Clownfish/CFC/Binding/Perl/ src/
Author: marvin
Date: Tue Jan 17 23:54:24 2012
New Revision: 1232654
URL: http://svn.apache.org/viewvc?rev=1232654&view=rev
Log:
Restore C versions of CFC Perl sub bindings.
Reconnect Perl implementations of Clownfish::CFC::Binding::Perl::Subroutine,
::Constructor and ::Method.
Modified:
incubator/lucy/trunk/clownfish/include/CFC.h
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/Constructor.pm
incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC/Binding/Perl/Method.pm
incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC/Binding/Perl/Subroutine.pm
incubator/lucy/trunk/clownfish/perl/typemap
incubator/lucy/trunk/clownfish/src/CFCPerlConstructor.c
incubator/lucy/trunk/clownfish/src/CFCPerlMethod.c
incubator/lucy/trunk/clownfish/src/CFCPerlPod.c
Modified: incubator/lucy/trunk/clownfish/include/CFC.h
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/include/CFC.h?rev=1232654&r1=1232653&r2=1232654&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/include/CFC.h (original)
+++ incubator/lucy/trunk/clownfish/include/CFC.h Tue Jan 17 23:54:24 2012
@@ -39,5 +39,8 @@
#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/CFC.pm
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC.pm?rev=1232654&r1=1232653&r2=1232654&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC.pm (original)
+++ incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC.pm Tue Jan 17 23:54:24 2012
@@ -82,18 +82,6 @@ BEGIN { XSLoader::load( 'Clownfish::CFC'
}
{
- package Clownfish::CFC::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::CFC::Base;
}
@@ -647,17 +635,59 @@ BEGIN { XSLoader::load( 'Clownfish::CFC'
{
package Clownfish::CFC::Binding::Perl::Constructor;
- use Clownfish::CFC::Binding::Perl::Class;
+ BEGIN { push our @ISA, 'Clownfish::CFC::Binding::Perl::Subroutine' }
+ use Carp;
+ use Clownfish::CFC::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 )} );
+ }
}
{
package Clownfish::CFC::Binding::Perl::Method;
- use Clownfish::CFC::Binding::Perl::Method;
+ BEGIN { push our @ISA, 'Clownfish::CFC::Binding::Perl::Subroutine' }
+ use Clownfish::CFC::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 )} );
+ }
}
{
package Clownfish::CFC::Binding::Perl::Subroutine;
- use Clownfish::CFC::Binding::Perl::Subroutine;
+ BEGIN { push our @ISA, 'Clownfish::CFC::Base' }
+ use Carp;
+ use Clownfish::CFC::Util qw( verify_args );
+
+ sub xsub_def { confess "Abstract method" }
+}
+
+{
+ package Clownfish::CFC::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} );
+ }
}
1;
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=1232654&r1=1232653&r2=1232654&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC.xs (original)
+++ incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC.xs Tue Jan 17 23:54:24 2012
@@ -1752,6 +1752,107 @@ PPCODE:
CFCBindFile_write_h(file, dest, header, footer);
+MODULE = Clownfish PACKAGE = Clownfish::CFC::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::CFC::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::CFC::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::CFC::Binding::Perl::TypeMap
SV*
Modified: incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC/Binding/Perl/Constructor.pm
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC/Binding/Perl/Constructor.pm?rev=1232654&r1=1232653&r2=1232654&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC/Binding/Perl/Constructor.pm (original)
+++ incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC/Binding/Perl/Constructor.pm Tue Jan 17 23:54:24 2012
@@ -13,95 +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::Constructor;
-use base qw( Clownfish::CFC::Binding::Perl::Subroutine );
-use Carp;
-use Clownfish::CFC::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
-}
+use Clownfish::CFC;
1;
@@ -147,4 +60,3 @@ should be bound. The default function i
Generate the XSUB code.
=cut
-
Modified: incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC/Binding/Perl/Method.pm
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC/Binding/Perl/Method.pm?rev=1232654&r1=1232653&r2=1232654&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC/Binding/Perl/Method.pm (original)
+++ incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC/Binding/Perl/Method.pm Tue Jan 17 23:54:24 2012
@@ -13,238 +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::Method;
-use base qw( Clownfish::CFC::Binding::Perl::Subroutine );
-use Clownfish::CFC::Util qw( verify_args );
-use Clownfish::CFC::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);";
-}
+use Clownfish::CFC;
1;
@@ -284,4 +54,3 @@ will be set up to accept a single positi
Generate the XSUB code.
=cut
-
Modified: incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC/Binding/Perl/Subroutine.pm
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC/Binding/Perl/Subroutine.pm?rev=1232654&r1=1232653&r2=1232654&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC/Binding/Perl/Subroutine.pm (original)
+++ incubator/lucy/trunk/clownfish/perl/lib/Clownfish/CFC/Binding/Perl/Subroutine.pm Tue Jan 17 23:54:24 2012
@@ -13,178 +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::Subroutine;
-use Carp;
-use Scalar::Util qw( blessed );
-use Clownfish::CFC::Class;
-use Clownfish::CFC::Function;
-use Clownfish::CFC::Method;
-use Clownfish::CFC::Variable;
-use Clownfish::CFC::ParamList;
-use Clownfish::CFC::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::CFC::Type")
- unless blessed($type) && $type->isa('Clownfish::CFC::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" }
+use Clownfish::CFC;
1;
@@ -262,4 +92,3 @@ 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=1232654&r1=1232653&r2=1232654&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/perl/typemap (original)
+++ incubator/lucy/trunk/clownfish/perl/typemap Tue Jan 17 23:54:24 2012
@@ -32,6 +32,9 @@ 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
@@ -71,6 +74,31 @@ CLOWNFISH_BINDING_CORE_TYPE
croak(\"Not a ${(my $t = $type) =~ s/CFCBind(\w+).*/Clownfish::CFC::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::CFC::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::CFC::Binding::Perl::$1/;\$t}\");
+ }
+
+
+CLOWNFISH_BINDING_PERL_SUBROUTINE
+ if (!SvOK($arg)) {
+ $var = NULL;
+ }
+ else if (sv_derived_from($arg, \"Clownfish::CFC::Binding::Perl::Subroutine\")) {
+ IV objint = SvIV((SV*)SvRV($arg));
+ $var = INT2PTR($type, objint);
+ }
+ else {
+ croak(\"Not a Clownfish::CFC::Binding::Perl::Subroutine\");
+ }
+
OUTPUT
@@ -83,3 +111,9 @@ CLOWNFISH_BINDING_CORE
CLOWNFISH_BINDING_CORE_TYPE
sv_setref_pv($arg, \"${(my $t = $type) =~ s/CFCBind(\w+).*/Clownfish::CFC::Binding::Core::$1/;\$t}\", (void*)$var);
+CLOWNFISH_BINDING_PERL_COMMON
+ sv_setref_pv($arg, \"${(my $t = $type) =~ s/CFCPerl(\w+).*/Clownfish::CFC::Binding::Perl::$1/;\$t}\", (void*)$var);
+
+CLOWNFISH_BINDING_PERL_SUBROUTINE
+ sv_setref_pv($arg, \"Clownfish::CFC::Binding::Perl::Subroutine\", (void*)$var);
+
Modified: incubator/lucy/trunk/clownfish/src/CFCPerlConstructor.c
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/src/CFCPerlConstructor.c?rev=1232654&r1=1232653&r2=1232654&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/src/CFCPerlConstructor.c (original)
+++ incubator/lucy/trunk/clownfish/src/CFCPerlConstructor.c Tue Jan 17 23:54:24 2012
@@ -39,7 +39,7 @@ struct CFCPerlConstructor {
};
const static CFCMeta CFCPERLCONSTRUCTOR_META = {
- "Clownfish::Binding::Perl::Constructor",
+ "Clownfish::CFC::Binding::Perl::Constructor",
sizeof(CFCPerlConstructor),
(CFCBase_destroy_t)CFCPerlConstructor_destroy
};
Modified: incubator/lucy/trunk/clownfish/src/CFCPerlMethod.c
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/src/CFCPerlMethod.c?rev=1232654&r1=1232653&r2=1232654&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/src/CFCPerlMethod.c (original)
+++ incubator/lucy/trunk/clownfish/src/CFCPerlMethod.c Tue Jan 17 23:54:24 2012
@@ -50,7 +50,7 @@ static char*
S_xsub_def_positional_args(CFCPerlMethod *self);
const static CFCMeta CFCPERLMETHOD_META = {
- "Clownfish::Binding::Perl::Method",
+ "Clownfish::CFC::Binding::Perl::Method",
sizeof(CFCPerlMethod),
(CFCBase_destroy_t)CFCPerlMethod_destroy
};
Modified: incubator/lucy/trunk/clownfish/src/CFCPerlPod.c
URL: http://svn.apache.org/viewvc/incubator/lucy/trunk/clownfish/src/CFCPerlPod.c?rev=1232654&r1=1232653&r2=1232654&view=diff
==============================================================================
--- incubator/lucy/trunk/clownfish/src/CFCPerlPod.c (original)
+++ incubator/lucy/trunk/clownfish/src/CFCPerlPod.c Tue Jan 17 23:54:24 2012
@@ -51,7 +51,7 @@ struct CFCPerlPod {
};
const static CFCMeta CFCPERLPOD_META = {
- "Clownfish::Binding::Perl::Pod",
+ "Clownfish::CFC::Binding::Perl::Pod",
sizeof(CFCPerlPod),
(CFCBase_destroy_t)CFCPerlPod_destroy
};