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