1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
|
# nqp::buildnativecall($target, $libname, $symbol, $convention, $arguments, $returns)
#
# Build a call descriptor into $target (which must be NativeCall REPRd or have
# a box target that is), for the function $symbol from $libname with the
# $convention calling convention.
#
# $arguments is a list of hashes, one hash per argument to the function. The
# hash can contain the following keys:
# - type: A string describing the type of the argument. One of:
# - void
# - char
# - short
# - int
# - long
# - longlong
# - float
# - double
# - asciistr
# - utf8str
# - utf16str
# - cstruct
# - cpointer
# - carray
# - callback
# - free_str: Should the cstring created for the call be freed afterwards?
# - callback_args: A list of hashes describing the arguments to a callback
# - typeobj: The type object of the Perl 6 type we want to pass
# $returns is a hash of the same kind used in $arguments
#
# nqp::nativecall($returns, $call, $arguments)
#
# Actually calls the foreign function. $returns is the type object for the
# return type (or null, for void functions), $call is the descriptor build
# with nqp::buildnativecall, and $arguments the arguments passed.
plan(3);
my $arg_hash;
my $return_hash;
BEGIN {
nqp::initnativecall();
}
class Call is repr('NativeCall') { }
class CPointer is repr('CPointer') { }
my $printf := Call.new;
$arg_hash := nqp::hash();
$arg_hash<type> := 'utf8str';
$arg_hash<free_str> := 1;
$return_hash := nqp::hash();
$return_hash<type> := 'void';
try {
nqp::buildnativecall($printf, '', 'printf', '', [$arg_hash], $return_hash);
CATCH {
nqp::buildnativecall($printf, 'msvcrt.dll', 'printf', '', [$arg_hash], $return_hash);
}
}
nqp::nativecall(nqp::null(), $printf, ["ok - printf\n"]);
my $strdup := nqp::create(Call);
$arg_hash := nqp::hash();
$arg_hash<type> := 'utf8str';
$arg_hash<free_str> := 1;
$return_hash := nqp::hash();
$return_hash<type> := 'cpointer';
try {
nqp::buildnativecall($strdup, '', 'strdup', '', [$arg_hash], $return_hash);
CATCH {
nqp::buildnativecall($strdup, 'msvcrt.dll', '_strdup', '', [$arg_hash], $return_hash);
}
}
my $dupped := nqp::nativecall(CPointer, $strdup, ["ok - passing cpointer\n"]);
say("ok - function returning cpointer"); # want un-numbered
my $ptrprint := nqp::create(Call);
$arg_hash := nqp::hash();
$arg_hash<type> := 'cpointer';
$return_hash := nqp::hash();
$return_hash<type> := 'void';
try {
nqp::buildnativecall($printf, '', 'printf', '', [$arg_hash], $return_hash);
CATCH {
nqp::buildnativecall($printf, 'msvcrt.dll', 'printf', '', [$arg_hash], $return_hash);
}
}
nqp::nativecall(nqp::null(), $printf, [$dupped]);
# vim: ft=perl6
|
