Commit | Line | Data |
---|---|---|
adfe19db MHM |
1 | #!/usr/bin/perl -w |
2 | ################################################################################ | |
3 | # | |
4 | # apicheck.pl -- generate C source for automated API check | |
5 | # | |
6 | ################################################################################ | |
7 | # | |
b2049988 | 8 | # Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz. |
adfe19db MHM |
9 | # Version 2.x, Copyright (C) 2001, Paul Marquess. |
10 | # Version 1.x, Copyright (C) 1999, Kenneth Albanowski. | |
11 | # | |
12 | # This program is free software; you can redistribute it and/or | |
13 | # modify it under the same terms as Perl itself. | |
14 | # | |
15 | ################################################################################ | |
16 | ||
17 | use strict; | |
3d7c117d | 18 | require './parts/ppptools.pl'; |
adfe19db MHM |
19 | |
20 | if (@ARGV) { | |
0c96388f MHM |
21 | my $file = pop @ARGV; |
22 | open OUT, ">$file" or die "$file: $!\n"; | |
adfe19db MHM |
23 | } |
24 | else { | |
25 | *OUT = \*STDOUT; | |
26 | } | |
27 | ||
679ad62d | 28 | my @f = parse_embed(qw( parts/embed.fnc parts/apidoc.fnc parts/ppport.fnc )); |
adfe19db MHM |
29 | |
30 | my %todo = %{&parse_todo}; | |
31 | ||
32 | my %tmap = ( | |
33 | void => 'int', | |
34 | ); | |
35 | ||
36 | my %amap = ( | |
37 | SP => 'SP', | |
38 | type => 'int', | |
39 | cast => 'int', | |
40 | ); | |
41 | ||
42 | my %void = ( | |
43 | void => 1, | |
44 | Free_t => 1, | |
45 | Signal_t => 1, | |
46 | ); | |
47 | ||
48 | my %castvoid = ( | |
49 | map { ($_ => 1) } qw( | |
50 | Nullav | |
51 | Nullcv | |
52 | Nullhv | |
53 | Nullch | |
54 | Nullsv | |
55 | HEf_SVKEY | |
56 | SP | |
57 | MARK | |
58 | SVt_PV | |
59 | SVt_IV | |
60 | SVt_NV | |
61 | SVt_PVMG | |
62 | SVt_PVAV | |
63 | SVt_PVHV | |
64 | SVt_PVCV | |
65 | SvUOK | |
66 | G_SCALAR | |
67 | G_ARRAY | |
68 | G_VOID | |
69 | G_DISCARD | |
70 | G_EVAL | |
71 | G_NOARGS | |
72 | XS_VERSION | |
73 | ), | |
74 | ); | |
75 | ||
76 | my %ignorerv = ( | |
77 | map { ($_ => 1) } qw( | |
78 | newCONSTSUB | |
79 | ), | |
80 | ); | |
81 | ||
82 | my %stack = ( | |
4a582685 NC |
83 | ORIGMARK => ['dORIGMARK;'], |
84 | POPpx => ['STRLEN n_a;'], | |
85 | POPpbytex => ['STRLEN n_a;'], | |
86 | PUSHp => ['dTARG;'], | |
87 | PUSHn => ['dTARG;'], | |
88 | PUSHi => ['dTARG;'], | |
89 | PUSHu => ['dTARG;'], | |
90 | XPUSHp => ['dTARG;'], | |
91 | XPUSHn => ['dTARG;'], | |
92 | XPUSHi => ['dTARG;'], | |
93 | XPUSHu => ['dTARG;'], | |
94 | UNDERBAR => ['dUNDERBAR;'], | |
95 | XCPT_TRY_START => ['dXCPT;'], | |
96 | XCPT_TRY_END => ['dXCPT;'], | |
97 | XCPT_CATCH => ['dXCPT;'], | |
98 | XCPT_RETHROW => ['dXCPT;'], | |
adfe19db MHM |
99 | ); |
100 | ||
adfe19db MHM |
101 | my %ignore = ( |
102 | map { ($_ => 1) } qw( | |
103 | svtype | |
104 | items | |
105 | ix | |
106 | dXSI32 | |
107 | XS | |
108 | CLASS | |
109 | THIS | |
110 | RETVAL | |
111 | StructCopy | |
112 | ), | |
113 | ); | |
114 | ||
115 | print OUT <<HEAD; | |
116 | /* | |
117 | * !!!!!!! DO NOT EDIT THIS FILE !!!!!!! | |
118 | * This file is built by $0. | |
119 | * Any changes made here will be lost! | |
120 | */ | |
121 | ||
122 | #include "EXTERN.h" | |
123 | #include "perl.h" | |
4a582685 NC |
124 | |
125 | #define NO_XSLOCKS | |
adfe19db MHM |
126 | #include "XSUB.h" |
127 | ||
ba120f6f MHM |
128 | #ifdef DPPP_APICHECK_NO_PPPORT_H |
129 | ||
130 | /* This is just to avoid too many baseline failures with perls < 5.6.0 */ | |
131 | ||
132 | #ifndef dTHX | |
133 | # define dTHX extern int Perl___notused | |
134 | #endif | |
135 | ||
136 | #else | |
adfe19db | 137 | |
679ad62d | 138 | #define NEED_PL_signals |
c01be2ce | 139 | #define NEED_PL_parser |
744ef08f | 140 | #define NEED_caller_cx |
adfe19db MHM |
141 | #define NEED_eval_pv |
142 | #define NEED_grok_bin | |
143 | #define NEED_grok_hex | |
144 | #define NEED_grok_number | |
145 | #define NEED_grok_numeric_radix | |
146 | #define NEED_grok_oct | |
94e22bd6 | 147 | #define NEED_gv_fetchpvn_flags |
679ad62d | 148 | #define NEED_load_module |
94e22bd6 | 149 | #define NEED_mg_findext |
f2ab5a41 | 150 | #define NEED_my_snprintf |
c01be2ce | 151 | #define NEED_my_sprintf |
aef0a14c MHM |
152 | #define NEED_my_strlcat |
153 | #define NEED_my_strlcpy | |
adfe19db MHM |
154 | #define NEED_newCONSTSUB |
155 | #define NEED_newRV_noinc | |
8565c31a | 156 | #define NEED_newSV_type |
94e22bd6 | 157 | #define NEED_newSVpvn_flags |
c83e6f19 | 158 | #define NEED_newSVpvn_share |
db42c902 MHM |
159 | #define NEED_pv_display |
160 | #define NEED_pv_escape | |
161 | #define NEED_pv_pretty | |
679ad62d | 162 | #define NEED_sv_2pv_flags |
adfe19db | 163 | #define NEED_sv_2pvbyte |
96ad942f MHM |
164 | #define NEED_sv_catpvf_mg |
165 | #define NEED_sv_catpvf_mg_nocontext | |
c83e6f19 | 166 | #define NEED_sv_pvn_force_flags |
96ad942f MHM |
167 | #define NEED_sv_setpvf_mg |
168 | #define NEED_sv_setpvf_mg_nocontext | |
744ef08f | 169 | #define NEED_sv_unmagicext |
94e22bd6 | 170 | #define NEED_SvRX |
679ad62d | 171 | #define NEED_vload_module |
96ad942f | 172 | #define NEED_vnewSVpvf |
f2ab5a41 | 173 | #define NEED_warner |
96ad942f | 174 | |
adfe19db MHM |
175 | #include "ppport.h" |
176 | ||
177 | #endif | |
178 | ||
adfe19db MHM |
179 | static int VARarg1; |
180 | static char *VARarg2; | |
181 | static double VARarg3; | |
182 | ||
744ef08f CBW |
183 | #if defined(PERL_BCDVERSION) && (PERL_BCDVERSION < 0x5009005) |
184 | /* needed to make PL_parser apicheck work */ | |
185 | typedef void yy_parser; | |
186 | #endif | |
187 | ||
adfe19db MHM |
188 | HEAD |
189 | ||
0c96388f MHM |
190 | if (@ARGV) { |
191 | my %want = map { ($_ => 0) } @ARGV; | |
192 | @f = grep { exists $want{$_->{name}} } @f; | |
193 | for (@f) { $want{$_->{name}}++ } | |
194 | for (keys %want) { | |
195 | die "nothing found for '$_'\n" unless $want{$_}; | |
196 | } | |
197 | } | |
198 | ||
adfe19db MHM |
199 | my $f; |
200 | for $f (@f) { | |
201 | $ignore{$f->{name}} and next; | |
202 | $f->{flags}{A} or next; # only public API members | |
203 | ||
204 | $ignore{$f->{name}} = 1; # ignore duplicates | |
205 | ||
206 | my $Perl_ = $f->{flags}{p} ? 'Perl_' : ''; | |
207 | ||
208 | my $stack = ''; | |
209 | my @arg; | |
210 | my $aTHX = ''; | |
211 | ||
212 | my $i = 1; | |
213 | my $ca; | |
214 | my $varargs = 0; | |
215 | for $ca (@{$f->{args}}) { | |
216 | my $a = $ca->[0]; | |
217 | if ($a eq '...') { | |
218 | $varargs = 1; | |
219 | push @arg, qw(VARarg1 VARarg2 VARarg3); | |
220 | last; | |
221 | } | |
4a582685 NC |
222 | my($n, $p, $d) = $a =~ /^ (\w+(?:\s+\w+)*)\s* # type name => $n |
223 | (\**) # pointer => $p | |
f2ab5a41 | 224 | (?:\s*const\s*)? # const |
4a582685 NC |
225 | ((?:\[[^\]]*\])*) # dimension => $d |
226 | $/x | |
227 | or die "$0 - cannot parse argument: [$a]\n"; | |
adfe19db MHM |
228 | if (exists $amap{$n}) { |
229 | push @arg, $amap{$n}; | |
230 | next; | |
231 | } | |
232 | $n = $tmap{$n} || $n; | |
0c96388f MHM |
233 | if ($n eq 'const char' and $p eq '*' and !$f->{flags}{f}) { |
234 | push @arg, '"foo"'; | |
235 | } | |
236 | else { | |
237 | my $v = 'arg' . $i++; | |
238 | push @arg, $v; | |
239 | $stack .= " static $n $p$v$d;\n"; | |
240 | } | |
adfe19db MHM |
241 | } |
242 | ||
243 | unless ($f->{flags}{n} || $f->{flags}{'m'}) { | |
244 | $stack = " dTHX;\n$stack"; | |
245 | $aTHX = @arg ? 'aTHX_ ' : 'aTHX'; | |
246 | } | |
247 | ||
248 | if ($stack{$f->{name}}) { | |
249 | my $s = ''; | |
250 | for (@{$stack{$f->{name}}}) { | |
251 | $s .= " $_\n"; | |
252 | } | |
253 | $stack = "$s$stack"; | |
254 | } | |
255 | ||
256 | my $args = join ', ', @arg; | |
257 | my $rvt = $f->{ret} || 'void'; | |
258 | my $ret; | |
259 | if ($void{$rvt}) { | |
260 | $ret = $castvoid{$f->{name}} ? '(void) ' : ''; | |
261 | } | |
262 | else { | |
ba120f6f MHM |
263 | $stack .= " $rvt rval;\n"; |
264 | $ret = $ignorerv{$f->{name}} ? '(void) ' : "rval = "; | |
adfe19db MHM |
265 | } |
266 | my $aTHX_args = "$aTHX$args"; | |
267 | ||
49ef49fe | 268 | if (!$f->{flags}{'m'} or $f->{flags}{'b'} or @arg > 0) { |
adfe19db MHM |
269 | $args = "($args)"; |
270 | $aTHX_args = "($aTHX_args)"; | |
271 | } | |
272 | ||
273 | print OUT <<HEAD; | |
274 | /****************************************************************************** | |
275 | * | |
276 | * $f->{name} | |
277 | * | |
278 | ******************************************************************************/ | |
279 | ||
280 | HEAD | |
281 | ||
282 | if ($todo{$f->{name}}) { | |
283 | my($ver,$sub) = $todo{$f->{name}} =~ /^5\.(\d{3})(\d{3})$/ or die; | |
284 | for ($ver, $sub) { | |
285 | s/^0+(\d)/$1/ | |
286 | } | |
287 | if ($ver < 6 && $sub > 0) { | |
288 | $sub =~ s/0$// or die; | |
289 | } | |
290 | print OUT "#if PERL_VERSION > $ver || (PERL_VERSION == $ver && PERL_SUBVERSION >= $sub) /* TODO */\n"; | |
291 | } | |
292 | ||
293 | my $final = $varargs | |
294 | ? "$Perl_$f->{name}$aTHX_args" | |
295 | : "$f->{name}$args"; | |
296 | ||
297 | $f->{cond} and print OUT "#if $f->{cond}\n"; | |
298 | ||
299 | print OUT <<END; | |
ba120f6f | 300 | void _DPPP_test_$f->{name} (void) |
adfe19db MHM |
301 | { |
302 | dXSARGS; | |
303 | $stack | |
adfe19db | 304 | { |
ba120f6f MHM |
305 | #ifdef $f->{name} |
306 | $ret$f->{name}$args; | |
adfe19db | 307 | #endif |
ba120f6f | 308 | } |
adfe19db MHM |
309 | |
310 | { | |
311 | #ifdef $f->{name} | |
ba120f6f | 312 | $ret$final; |
adfe19db | 313 | #else |
ba120f6f | 314 | $ret$Perl_$f->{name}$aTHX_args; |
adfe19db MHM |
315 | #endif |
316 | } | |
317 | } | |
318 | END | |
319 | ||
320 | $f->{cond} and print OUT "#endif\n"; | |
321 | $todo{$f->{name}} and print OUT "#endif\n"; | |
322 | ||
323 | print OUT "\n"; | |
324 | } | |
325 | ||
326 | @ARGV and close OUT; |