#24685: Add support for __cdecl function call

Extracted from the email by Matthew Haycraft:

----8<-----------

Greetings Cosimo,
I recently tried to use Win32::API to call a __cdecl function from a
dll. That's when I realized that this modules only supports __stdcall
functions. A quick search and I found:
http://cpanratings.perl.org/dist/Win32-API which pointed me to:
http://www.xs4all.nl/~itsme/projects/perl/

Which has a modified version of 0.41 that allows an additional parameter
to the new method to specify __stdcall or __cdecl calling method. This
appears to be the difference between my perl script crashing and
successfully calling __cdecl functions from a third party dll.

Is is possible that you could incorporate functionality like this?

The author of the branch above also mentioned a possibility of adding a
feature to catch calling a method by the wrong calling protocol. Any
interest in adding such a feature?

TIA for a reponce,

Matthew Haycraft

diff -durw Win32-API-0.41/API.pm Win32-API-0.41-wj/API.pm
--- Win32-API-0.41/API.pm 2003-03-10 17:15:44.000000000 +0100
+++ Win32-API-0.41-wj/API.pm 2004-03-24 14:29:44.755429500 +0100
@@ -52,7 +52,7 @@
# PUBLIC METHODS
#
sub new {
- my($class, $dll, $proc, $in, $out) = @_;
+ my($class, $dll, $proc, $in, $out, $callconvention) = @_;
my $hdll;
my $self = {};

@@ -74,7 +74,7 @@

#### determine if we have a prototype or not
if( (not defined $in) and (not defined $out) ) {
- ($proc, $self->{in}, $self->{intypes}, $self->{out}) = parse_prototype( $proc );
+ ($proc, $self->{in}, $self->{intypes}, $self->{out}, $self->{cdecl}) = parse_prototype( $proc );
return undef unless $proc;
$self->{proto} = 1;
} else {
@@ -90,6 +90,7 @@
}
}
$self->{out} = type_to_num($out);
+ $self->{cdecl} = calltype_to_num($callconvention);
}

#### first try to import the function of given name...
@@ -125,8 +126,8 @@
}

sub Import {
- my($class, $dll, $proc, $in, $out) = @_;
- $Imported{"$dll:$proc"} = Win32::API->new($dll, $proc, $in, $out) or return 0;
+ my($class, $dll, $proc, $in, $out, $callconvention) = @_;
+ $Imported{"$dll:$proc"} = Win32::API->new($dll, $proc, $in, $out, $callconvention) or return 0;
my $P = (caller)[0];
eval qq(
sub ${P}::$Imported{"$dll:$proc"}->{procname} { \$Win32::API::Imported{"$dll:$proc"}->Call(\@_); }
@@ -152,6 +153,20 @@
}
}

+sub calltype_to_num {
+ my $type = shift;
+
+ if (!$type || $type eq "__stdcall") {
+ return 0;
+ }
+ elsif ($type eq "_cdecl") {
+ return 1;
+ }
+ else {
+ warn "unknown calling convention: '$type'";
+ return 0;
+ }
+}
sub type_to_num {
my $type = shift;
my $out = shift;
@@ -209,10 +224,11 @@

my @in_params = ();
my @in_types = ();
- if($proto =~ /^\s*(\S+)\s+(\S+)\s*\(([^\)]*)\)/) {
+ if($proto =~ /^\s*(\S+)(?:\s+(\w+))?\s+(\S+)\s*\(([^\)]*)\)/) {
my $ret = $1;
- my $proc = $2;
- my $params = $3;
+ my $callconvention= $2;
+ my $proc = $3;
+ my $params = $4;

$params =~ s/^\s+//;
$params =~ s/\s+$//;
@@ -261,17 +277,17 @@
$ret,
Win32::API::Type->packing( $ret ),
type_to_num('P');
- return ( $proc, \@in_params, \@in_types, type_to_num('P') );
+ return ( $proc, \@in_params, \@in_types, type_to_num('P'), calltype_to_num($callconvention) );
} else {
DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n",
$ret,
Win32::API::Type->packing( $ret ),
type_to_num( Win32::API::Type->packing( $ret ) );
- return ( $proc, \@in_params, \@in_types, type_to_num(Win32::API::Type->packing($ret)) );
+ return ( $proc, \@in_params, \@in_types, type_to_num(Win32::API::Type->packing($ret)), calltype_to_num($callconvention) );
}
} else {
warn "Win32::API::parse_prototype: WARNING unknown output parameter type '$ret'";
- return ( $proc, \@in_params, \@in_types, type_to_num('I') );
+ return ( $proc, \@in_params, \@in_types, type_to_num('I'), calltype_to_num($callconvention) );
}

} else {
@@ -441,6 +457,10 @@
=item 4.
The type of the value returned by the function.

+=item 5.
+And optionally you can specify the calling convention, this defaults to
+'__stdcall', alternatively you can specify '_cdecl'.
+
=back

To better explain their meaning, let's suppose that we
diff -durw Win32-API-0.41/API.xs Win32-API-0.41-wj/API.xs
--- Win32-API-0.41/API.xs 2003-03-07 12:19:16.000000000 +0100
+++ Win32-API-0.41-wj/API.xs 2004-03-24 13:00:05.899898400 +0100
@@ -235,6 +235,7 @@
SV** obj_out;
SV** obj_intypes;
SV** in_type;
+ SV** call_type;
AV* inlist;
AV* intypes;

@@ -244,6 +245,8 @@
SV** code;

int nin, tin, tout, i;
+ BOOL c_call;
+ int words_pushed;
BOOL has_proto = FALSE;

obj = (HV*) SvRV(api);
@@ -266,6 +269,9 @@
nin = av_len(inlist);
tout = SvIV(*obj_out);

+ call_type = hv_fetch(obj, "cdecl", 5, FALSE);
+ c_call = call_type ? SvTRUE(*call_type) : FALSE;
+
if(items-1 != nin+1) {
croak("Wrong number of parameters: expected %d, got %d.\n", nin+1, items-1);
}
@@ -466,6 +472,7 @@
}
}

+ words_pushed = 0;
/* #### PUSH THE PARAMETER ON THE (ASSEMBLER) STACK #### */
for(i = nin; i >= 0; i--) {
switch(params[i].t) {
@@ -479,6 +486,7 @@
mov eax, dword ptr pParam
push eax
}
+ words_pushed++;
break;
case T_POINTERPOINTER:
ppParam = params[i].b;
@@ -489,6 +497,7 @@
mov eax, dword ptr ppParam
push eax
}
+ words_pushed++;
break;
case T_NUMBER:
case T_CHAR:
@@ -500,6 +509,7 @@
mov eax, lParam
push eax
}
+ words_pushed++;
break;
case T_FLOAT:
fParam = params[i].f;
@@ -510,6 +520,7 @@
mov eax, fParam
push eax
}
+ words_pushed++;
break;
case T_DOUBLE:
dParam = params[i].d;
@@ -522,6 +533,8 @@
mov eax, dword ptr [dParam]
push eax
}
+ words_pushed++;
+ words_pushed++;
break;
case T_CODE:
lParam = params[i].l;
@@ -532,6 +545,7 @@
mov eax, lParam
push eax
}
+ words_pushed++;
break;
}
}
@@ -606,6 +620,14 @@
ApiFunctionVoid();
break;
}
+ if (c_call) {
+ // cleanup stack for _cdecl type functions.
+ _asm {
+ mov eax, dword ptr words_pushed
+ shl eax, 2
+ add esp, eax
+ }
+ }
/* #### THIRD PASS: postfix pointers/structures #### */
for(i = 0; i <= nin; i++) {
if(params[i].t == T_POINTER && has_proto) {
diff -durw Win32-API-0.41/API_test_dll/API_test.cpp Win32-API-0.41-wj/API_test_dll/API_test.cpp
--- Win32-API-0.41/API_test_dll/API_test.cpp 2002-10-24 13:36:44.000000000 +0200
+++ Win32-API-0.41-wj/API_test_dll/API_test.cpp 2004-03-24 15:08:55.692929500 +0100
@@ -130,3 +130,17 @@
printf("do_callback: returning %ld\n", r);
return r;
}
\ No newline at end of file
+
+API_TEST_API int __stdcall int_to_str(int a, char *buf, int buflen)
+{
+ return _snprintf(buf, buflen, "%d", a);
+}
+
+API_TEST_API int _cdecl c_call_sum_int(int a, int b) {
+ return a + b;
+}
+
+API_TEST_API int _cdecl c_call_sum_int_dbl(int a, double b) {
+ return a + b;
+}
+
diff -durw Win32-API-0.41/API_test_dll/API_test.def Win32-API-0.41-wj/API_test_dll/API_test.def
--- Win32-API-0.41/API_test_dll/API_test.def 2002-10-24 11:40:35.000000000 +0200
+++ Win32-API-0.41-wj/API_test_dll/API_test.def 2004-03-24 15:09:43.052304500 +0100
@@ -11,3 +11,6 @@
dump_struct
mangle_simple_struct
do_callback
+ int_to_str
+ c_call_sum_int
+ c_call_sum_int_dbl
diff -durw Win32-API-0.41/API_test_dll/API_test.h Win32-API-0.41-wj/API_test_dll/API_test.h
--- Win32-API-0.41/API_test_dll/API_test.h 2002-10-24 13:36:32.000000000 +0200
+++ Win32-API-0.41-wj/API_test_dll/API_test.h 2004-03-24 15:09:44.927304500 +0100
@@ -33,3 +33,8 @@
API_TEST_API void __stdcall dump_struct(simple_struct *x);
API_TEST_API int __stdcall mangle_simple_struct(simple_struct *x);

+API_TEST_API int __stdcall int_to_str(int a, char *buf, int buflen);
+
+API_TEST_API int c_call_sum_int(int a, int b);
+API_TEST_API int c_call_sum_int_dbl(int a, double b);
+
diff -durw Win32-API-0.41/Callback/Callback.xs Win32-API-0.41-wj/Callback/Callback.xs
--- Win32-API-0.41/Callback/Callback.xs 2003-03-07 12:10:38.000000000 +0100
+++ Win32-API-0.41-wj/Callback/Callback.xs 2004-03-24 14:09:04.567929500 +0100
@@ -481,7 +481,9 @@
done = TRUE;
}

- if(cursor >= (unsigned char *) PerformCallback) {
+ // this test only works if the compiler does not reorder the functions in the output.
+ if((unsigned char *) CallbackTemplate < (unsigned char *) PerformCallback
+ && cursor >= (unsigned char *) PerformCallback) {
checkpoint_DONE = distance;
done = TRUE;
}
@@ -636,7 +638,7 @@
} else
if(*(cursor+0) == 0xC7
&& *(cursor+1) == 0x45
- && *(cursor+2) == 0xEC
+ && (*(cursor+2) == 0xFC || *(cursor+2) == 0xEC)
&& *((int*)(cursor+3)) == 0xC0DE0003
) {
#ifdef WIN32_API_DEBUG
@@ -686,7 +688,7 @@
} else
if(*(cursor+0) == 0xC7
&& *(cursor+1) == 0x45
- && *(cursor+2) == 0xEC
+ && (*(cursor+2) == 0xFC || *(cursor+2) == 0xEC)
&& *((int*)(cursor+3)) == 0xC0DE0003
) {
#ifdef WIN32_API_DEBUG
@@ -737,7 +739,7 @@
} else
if(*(cursor+0) == 0xC7
&& *(cursor+1) == 0x45
- && *(cursor+2) == 0xEC
+ && (*(cursor+2) == 0xFC || *(cursor+2) == 0xEC)
&& *((int*)(cursor+3)) == 0xC0DE0003
) {
#ifdef WIN32_API_DEBUG
diff -durw Win32-API-0.41/t/00_API.t Win32-API-0.41-wj/t/00_API.t
--- Win32-API-0.41/t/00_API.t 2003-03-10 17:36:58.000000000 +0100
+++ Win32-API-0.41-wj/t/00_API.t 2004-03-24 15:11:48.411679500 +0100
@@ -16,7 +16,7 @@

######################### We start with some black magic to print on failure.

-BEGIN { $| = 1; print "1..11\n"; }
+BEGIN { $| = 1; print "1..16\n"; }
END {print "not ok 1\n" unless $loaded;}
use Win32::API;
$loaded = 1;
@@ -113,3 +113,36 @@
my $char = "a";
print "" . ($function->Call($string, $char) eq "aph" ? "" : "not ") . "ok $t\n";
$t++;
+
+#### 12: sum integers and double via _cdecl function
+$function = new Win32::API($test_dll, 'int _cdecl c_call_sum_int(int a, int b)');
+defined($function) or die "not ok $t\t$^E\n";
+print "" . ($function->Call(2, 3) == 5 ? "" : "not ") . "ok $t\n";
+$t++;
+
+#### 13: sum integers and double via _cdecl function
+$function = new Win32::API($test_dll, 'int _cdecl c_call_sum_int_dbl(int a, double b)');
+defined($function) or die "not ok $t\t$^E\n";
+print "" . ($function->Call(2, 3) == 5 ? "" : "not ") . "ok $t\n";
+$t++;
+
+#### 14: sum integers and double via _cdecl function, no prototype
+$function = new Win32::API($test_dll, 'c_call_sum_int', 'II', 'I', '_cdecl');
+defined($function) or die "not ok $t\t$^E\n";
+print "" . ($function->Call(2, 3) == 5 ? "" : "not ") . "ok $t\n";
+$t++;
+
+#### 15: sum 2 integers, no prototype
+$function = new Win32::API($test_dll, 'sum_integers', 'II', 'I');
+defined($function) or die "not ok $t\t$^E\n";
+print "" . ($function->Call(2, 3) == 5 ? "" : "not ") . "ok $t\n";
+$t++;
+
+#### 16: convert integer to string
+$function = new Win32::API($test_dll, 'int_to_str', 'IPI', 'I');
+defined($function) or die "not ok $t\t$^E\n";
+my $buf= " " x 16;
+print "" . ( ($function->Call(12345, $buf, length($buf)) == 5 && $buf =~ /^12345\x00 +$/ ) ? "" : "not ") . "ok $t\n";
+$t++;
+
+

Great! Thank you for merging this feature in!

On Wed, Feb 20, 2008 at 4:04 PM, Cosimo Streppone via RT <
bug-Win32-API[...]rt.cpan.org> wrote:

>
> <URL: http://rt.cpan.org/Ticket/Display.html?id=24685 >
>
> Added support for cdecl function calls in Win32::API v0.48.
> Soon at your local CPAN mirror.
>
>