our
%new_PARAMS
= (
method
=>
undef
,
alias
=>
undef
,
);
sub
new {
my
(
$either
,
%args
) =
@_
;
confess $@
unless
verify_args( \
%new_PARAMS
,
%args
);
my
$method
=
delete
$args
{method};
$args
{retval_type} ||=
$method
->get_return_type;
$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;
}
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;
}
}
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
=
""
;
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
.=
"if ($var_name) (void)KINO_INCREF($var_name);\n "
;
}
if
(
$method
->void ) {
$body
.=
qq|$full_func_sym($name_list);|
;
}
else
{
my
$return_type
=
$method
->get_return_type;
my
$retval_assignment
= to_perl(
$return_type
,
'ST(0)'
,
'retval'
);
my
$decrement
=
""
;
if
(
$return_type
->is_object and
$return_type
->incremented ) {
$decrement
=
"KINO_DECREF(retval);\n"
;
}
$body
.=
qq|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;
my
$min_required
=
$num_args
;
while
(
defined
$arg_inits
->[
$min_required
- 1 ] ) {
$min_required
--;
}
my
@xs_arg_names
;
for
(
my
$i
= 0;
$i
<
$min_required
;
$i
++ ) {
push
@xs_arg_names
,
$arg_vars
->[
$i
]->micro_sym;
}
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(%s)", GvNAME(CvGV(cv)),|
.
qq| "$xs_name_list"); }|
;
}
else
{
$num_args_check
=
qq|if (items != $num_args) { |
.
qq| CFISH_THROW(CFISH_ERR, "Usage: %s(%s)", GvNAME(CvGV(cv)), |
.
qq|"$xs_name_list"); }|
;
}
my
$var_declarations
=
$self
->var_declarations;
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
$statement
;
if
(
$i
== 0 ) {
$statement
= _self_assign_statement(
$var_type
,
$method
->micro_sym );
}
else
{
$statement
= from_perl(
$var_type
,
$var_name
,
"ST($i)"
);
}
if
(
defined
$val
) {
$statement
=
qq| if ( items >= $i && XSBind_sv_defined(ST($i)) ) {
$statement
}
else {
$var_name = $val;
}|
;
}
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);
CHY_UNUSED_VAR(ax);
SP -= items;
$num_args_check;
{
/* Extract vars from Perl stack. */
$var_declarations
$var_assignments
/* Execute */
$body
}
PUTBACK;
}
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
$num_args
=
$param_list
->num_vars;
my
$arg_vars
=
$param_list
->get_variables;
my
$body
=
$self
->_xsub_body;
my
$name_list
=
$arg_vars
->[0]->micro_sym .
", ..."
;
my
$num_args_check
=
qq|if (items < 1) { |
.
qq|CFISH_THROW(CFISH_ERR, "Usage: %s(%s)", GvNAME(CvGV(cv)), |
.
qq|"$name_list"); }|
;
my
$var_declarations
=
$self
->var_declarations;
my
$self_var
=
$arg_vars
->[0];
my
$self_type
=
$self_var
->get_type;
my
$params_hash_name
=
$self
->perl_name .
"_PARAMS"
;
my
$self_assignment
= _self_assign_statement(
$self_type
,
$self
->{method}->micro_sym );
my
@var_assignments
;
my
$allot_params
=
qq|XSBind_allot_params( &(ST(0)), 1, items, "$params_hash_name", |
;
for
(
my
$i
= 1;
$i
<=
$#$arg_vars
;
$i
++ ) {
my
$var
=
$arg_vars
->[
$i
];
my
$val
=
$arg_inits
->[
$i
];
my
$name
=
$var
->micro_sym;
my
$sv_name
=
$name
.
"_sv"
;
my
$type
=
$var
->get_type;
my
$len
=
length
$name
;
$allot_params
.=
qq| &$sv_name, "$name", $len,\n|
;
my
$statement
= from_perl(
$type
,
$name
,
$sv_name
);
if
(
defined
$val
) {
my
$assignment
=
qq|if ( $sv_name && XSBind_sv_defined($sv_name) ) {
$statement;
}
else {
$name = $val;
}|
;
push
@var_assignments
,
$assignment
;
}
else
{
my
$assignment
=
qq#if ( !$sv_name || !XSBind_sv_defined($sv_name) ) { #
.
qq#CFISH_THROW(CFISH_ERR, "Missing required param '$name'"); }\n#
.
qq# $statement;#
;
push
@var_assignments
,
$assignment
;
}
}
$allot_params
.=
" NULL);\n"
;
my
$var_assignments
=
join
(
"\n "
,
$self_assignment
,
$allot_params
,
@var_assignments
, );
return
<<END_STUFF;
XS($c_name);
XS($c_name)
{
dXSARGS;
CHY_UNUSED_VAR(cv);
CHY_UNUSED_VAR(ax);
$num_args_check;
SP -= items;
{
/* Extract vars from Perl stack. */
$var_declarations
$var_assignments
/* Execute */
$body
}
PUTBACK;
}
END_STUFF
}
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);
my
$binding_func
=
$method_name
eq
'deserialize'
?
'XSBind_maybe_sv_to_cfish_obj'
:
'XSBind_sv_to_cfish_obj'
;
return
"self = ($type_c)$binding_func(ST(0), $vtable, NULL);"
;
}
1;