Skip to content

Commit

Permalink
handle String args/retvals using typemap and wrapper
Browse files Browse the repository at this point in the history
  • Loading branch information
@mohawk2
mohawk2 committed Feb 13, 2023
1 parent b03715f commit fa3b1fa
Show file tree
Hide file tree
Showing 3 changed files with 54 additions and 19 deletions.
20 changes: 8 additions & 12 deletions genpp.pl
View file
Original file line number Diff line number Diff line change
Expand Up @@ -7,7 +7,7 @@

my $T = [qw(A B S U L F D)];
our %type_overrides = (
String => ['char *', 'char *'], # PP, C
String => ['StringWrapper*', 'StringWrapper*'], # PP, C
bool => ['byte', 'unsigned char'],
);
$type_overrides{$_->[0]} = $type_overrides{$_->[1]} for (# aliases
Expand All @@ -21,6 +21,7 @@
);
our %extra_cons_args = (
LineSegmentDetector => [[qw(int lsd_type)]],
String => [['const char*', 'str']],
);
our $IF_ERROR_RETURN = "if (CW_err.error) return *(pdl_error *)&CW_err";

Expand All @@ -38,12 +39,12 @@ package PP::OpenCV;
sub new {
my ($class, $pcount, $type, $name, $default, $f) = @_;
my %flags = map +($_=>1), @{$f||[]};
my $self = bless {type=>$type, name=>$name, is_io=>$flags{'/IO'}, is_output=>$flags{'/O'}, pcount => $pcount}, $class;
my $self = bless {type=>$type, name=>$name, is_io=>$flags{'/IO'}, is_output=>$flags{'/O'}, pcount => $pcount, pdltype => ''}, $class;
$self->{is_vector} = (my $nonvector_type = $type) =~ s/vector_//g;
$self->{type_pp} = $type_overrides{$nonvector_type} ? $type_overrides{$nonvector_type}[0] : $nonvector_type;
$self->{type_c} = $type_overrides{$nonvector_type} ? $type_overrides{$nonvector_type}[1] : $nonvector_type;
$self->{default} = $default if defined $default and length $default;
@$self{qw(is_other naive_otherpar use_comp)} = (1,1,1), return $self if $self->{type_c} eq 'char *';
@$self{qw(is_other naive_otherpar use_comp)} = (1,1,1), return $self if $self->{type_c} eq 'StringWrapper*';
if ($self->{is_vector}) {
$self->{fixeddims} = 1 if my $spec = $DIMTYPES{$nonvector_type};
$self->{use_comp} = 1 if $spec and $self->{is_output};
Expand All @@ -59,7 +60,6 @@ sub new {
@$self{qw(was_ptr type)} = (1, $type) if $type =~ s/\s*\*+$//;
%$self = (%$self,
type_c => "${type}Wrapper *",
pdltype => '',
fixeddims => 0,
destroy => "cw_${type}_DESTROY",
);
Expand All @@ -82,7 +82,6 @@ sub c_input {
}
sub par {
my ($self) = @_;
return $self->_par if $self->{is_other};
join ' ', grep length, $self->{pdltype},
($self->{is_output} ? '[o]' : $self->{is_io} ? '[io]' : ()),
$self->_par;
Expand Down Expand Up @@ -154,7 +153,7 @@ sub default_pl {
my $d = $self->{default} // '';
$d =~ s/[A-Z][A-Z0-9_]+/$&()/g if length $d and $d !~ /\(/;
if ($self->{is_output}) {
$d = 'PDL->null' if !length $d or $d eq 'Mat()' or ($d eq '0' && $self->{was_ptr});
$d = 'PDL->null' if !$self->{naive_otherpar} and (!length $d or $d eq 'Mat()' or ($d eq '0' && $self->{was_ptr}));
} elsif ($default_overrides{$d}) {
$d = $default_overrides{$d}[0];
}
Expand Down Expand Up @@ -201,7 +200,6 @@ sub genpp {
unshift @params, [$class,'self'] if $ismethod;
push @params, [$ret,'res','',['/O']] if $ret ne 'void';
my @allpars = map PP::OpenCV->new($pcount++, @$_), @params;
die "Error in $func: OtherPars '$_->{name}' is output: ".do {require Data::Dumper; Data::Dumper::Dumper($_)} for grep $_->{is_other} && $_->{type_pp} =~ /^[A-Z]/ && $_->{is_output}, @allpars;
my (@inputs, @outputs); push @{$_->{is_output} ? \@outputs : \@inputs}, $_ for @allpars;
if (!grep $_->{is_vector} || ($_->{type_pp} =~ /^[A-Z]/ && !$_->{is_other}), @allpars) {
$doxy->{brief}[0] .= make_example($func, $ismethod, \@inputs, \@outputs);
Expand All @@ -213,15 +211,13 @@ sub genpp {
my @cw_params = (($ret ne 'void' ? '&RETVAL' : ()), map $_->{name}, @allpars);
my $xs = <<EOF;
MODULE = ${main::PDLMOD} PACKAGE = ${main::PDLOBJ} PREFIX=@{[join '_', grep length,'cw',$class]}_
\n@{[$ret_type eq 'char *'?'void':$ret_type]} $cfunc(@{[join ', ', map $_->xs_par, @allpars]})
\n$ret_type $cfunc(@{[join ', ', map $_->xs_par, @allpars]})
PROTOTYPE: DISABLE
@{[$ret_type eq 'char *'?'PP':'']}CODE:
@{[$ret_type eq 'char *'?'char *RETVAL;':'']}
CODE:
cw_error CW_err = $cfunc(@{[join ', ', @cw_params]});
PDL->barf_if_error(*(pdl_error *)&CW_err);
@{[$ret_type eq 'char *'?'XPUSHs(sv_2mortal(newSVpv(RETVAL, 0)));free(RETVAL);':'']}
EOF
$xs .= " OUTPUT:\n RETVAL\n" if $ret_type ne 'void' and $ret_type ne 'char *';
$xs .= " OUTPUT:\n RETVAL\n" if $ret_type ne 'void';
pp_addxs($xs);
return;
}
Expand Down
36 changes: 29 additions & 7 deletions genwrap.pl
View file
Original file line number Diff line number Diff line change
Expand Up @@ -7,7 +7,7 @@

require ''. catfile $Bin, 'genpp.pl';
our (%type_overrides, %extra_cons_args);
my %GLOBALTYPES = do { no warnings 'once'; (%PP::OpenCV::DIMTYPES, Mat=>[]) };
my %GLOBALTYPES = do { no warnings 'once'; (%PP::OpenCV::DIMTYPES, Mat=>[], String=>[]) };
my @PDLTYPES_SUPPORTED = grep $_->real && $_->ppsym !~/[KPQN]/ && howbig($_) <= 8, PDL::Types::types;
my %VECTORTYPES = (%PP::OpenCV::DIMTYPES, map +($_=>[]), qw(int float));
my %overrides = (
Expand All @@ -19,7 +19,7 @@
my $CATCH = q[catch (const std::exception& e) {
CW_err = {CW_EUSERERROR,strdup(e.what()),1};
}];
my $wrap_re = qr/^(?:[A-Z]|vector_)/;
my $wrap_re = qr/^(?:(?!String)[A-Z]|vector_)/;
my %constructor_override = (
Tracker => <<EOF,
#if CV_VERSION_MINOR >= 5 && CV_VERSION_MAJOR >= 4
Expand All @@ -45,6 +45,16 @@
} $CATCH
return CW_err;
}
EOF
String => <<EOF,
cw_error cw_String_new(StringWrapper **cw_retval, char *klass, const char* str) {
cw_error CW_err = {CW_ENONE, NULL, 0};
try {
*cw_retval = new StringWrapper;
(*cw_retval)->held = str ? cv::String(str) : cv::String();
} $CATCH
return CW_err;
}
EOF
);
my @funclist = do ''. catfile curdir, 'funclist.pl'; die if $@;
Expand Down Expand Up @@ -87,6 +97,13 @@
} $CATCH
return CW_err;
}
cw_error cw_String_c_str(const char **ptr, StringWrapper *self) {
cw_error CW_err = {CW_ENONE, NULL, 0};
try {
*ptr = self->held.c_str();
} $CATCH
return CW_err;
}
EOF
my $CFOOTER = "}\n";
my $HHEADER = <<'EOF';
Expand Down Expand Up @@ -121,6 +138,7 @@
cw_error cw_Mat_pdlDims(MatWrapper *wrapper, int *t, ptrdiff_t *l, ptrdiff_t *c, ptrdiff_t *r);
cw_error cw_Mat_newWithDims(MatWrapper **cw_retval, const ptrdiff_t planes, const ptrdiff_t cols, const ptrdiff_t rows, const int type, void * data);
cw_error cw_Mat_copyDataTo(MatWrapper *self, void *data, ptrdiff_t bytes);
cw_error cw_String_c_str(const char **ptr, StringWrapper *self);
EOF
my $HFOOTER = <<'EOF';
#ifdef __cplusplus
Expand Down Expand Up @@ -157,10 +175,14 @@ sub gen_code {
my $opt = $overrides{$class}{$name} || {};
my (@input_args, @cvargs, $methodvar);
my ($func_ret, $cpp_ret, $after_ret) = ($ret, '', '');
if ($ret =~ $wrap_re) {
if ($ret eq 'StringWrapper*') {
$func_ret = "StringWrapper *";
$cpp_ret = "cv::String cpp_retval = ";
$after_ret = " CW_err = cw_String_new(cw_retval, NULL, cpp_retval.c_str()); if (CW_err.error) return CW_err;\n";
} elsif ($ret =~ $wrap_re) {
$func_ret = "${ret}Wrapper *";
$cpp_ret = "cv::$ret cpp_retval = ";
$after_ret = " cw_${ret}_new(cw_retval, NULL); (*cw_retval)->held = cpp_retval;\n";
$after_ret = " CW_err = cw_${ret}_new(cw_retval, NULL); if (CW_err.error) return CW_err; (*cw_retval)->held = cpp_retval;\n";
} elsif ($ret ne 'void') {
$cpp_ret = "*cw_retval = ";
}
Expand All @@ -176,20 +198,20 @@ sub gen_code {
$s = $type_overrides{$s}[1] if $type_overrides{$s};
my $ctype = $s . ($s =~ $wrap_re ? "Wrapper *" : '');
push @input_args, "$ctype $v";
push @cvargs, $s =~ $wrap_re ? ($was_ptr ? '&' : '')."$v->held" : $v;
push @cvargs, $s eq 'StringWrapper*' ? "$v->held" : $s =~ $wrap_re ? ($was_ptr ? '&' : '')."$v->held" : $v;
}
my $fname = join '_', grep length, 'cw', $class, $name;
my $str = "cw_error $fname(" . join(", ", @input_args) . ")";
my $hstr = $str.";\n";
$str .= " {\n";
$str .= " cw_error CW_err = {CW_ENONE, NULL, 0};\n try {\n";
$str .= " // pre:\n$$opt{pre}\n" if $$opt{pre};
$str .= " $cpp_ret".($ret eq 'char *' ? "strdup(" : "");
$str .= " $cpp_ret";
$str .= $ismethod == 0 ? join('::', grep length, "cv", $class, $name)."(" :
"$methodvar->held".($ptr_only?'->':'.')."$name" .
($ismethod == 1 ? "(" : ";\n");
$opt->{argfix}->(\@cvargs) if $opt->{argfix};
$str .= join(', ', @cvargs).")".($ret eq 'char *' ? ".c_str())" : "").";\n";
$str .= join(', ', @cvargs).");\n";
$str .= $after_ret;
$str .= " // post:\n$$opt{post}\n" if $$opt{post};
$str .= " } $CATCH\n return CW_err;\n";
Expand Down
17 changes: 17 additions & 0 deletions typemap
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,6 +4,7 @@ PDL__OpenCV__LineSegmentDetector T_PTROBJ_SPECIAL
PDL__OpenCV__Tracker T_PTROBJ_SPECIAL
PDL__OpenCV__VideoCapture T_PTROBJ_SPECIAL
PDL__OpenCV__VideoWriter T_PTROBJ_SPECIAL
StringWrapper* T_OPENCV_STRING

INPUT
T_PTROBJ_SPECIAL
Expand All @@ -14,7 +15,23 @@ T_PTROBJ_SPECIAL
else
croak(\"$var is not of type ${(my $ntt=$type)=~s/__/::/g;\$ntt}\")

T_OPENCV_STRING
{
cw_error CW_err = cw_String_new(&$var, NULL, SvOK($arg) ? SvPV_nolen($arg) : NULL);
PDL_CORE_(barf_if_error)(*(pdl_error *)&CW_err);
}

OUTPUT
T_PTROBJ_SPECIAL
sv_setref_pv($arg, \"${(my $ntt=$type)=~s/__/::/g;\$ntt}\",
(void*)$var);

T_OPENCV_STRING
{
const char *cptr;
cw_error CW_err = cw_String_c_str(&cptr, $var);
if (CW_err.error) cw_String_DESTROY($var);
PDL_CORE_(barf_if_error)(*(pdl_error *)&CW_err);
sv_setpv((SV*)$arg, cptr);
cw_String_DESTROY($var);
}

0 comments on commit fa3b1fa

Please sign in to comment.