This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
parts/apicheck.pl: Don't test macros with weird params
[perl5.git] / dist / Devel-PPPort / parts / apicheck.pl
CommitLineData
adfe19db
MHM
1#!/usr/bin/perl -w
2################################################################################
3#
e27fc489 4# apicheck.pl -- generate apicheck.c: C source for automated API check
adfe19db 5#
54b3baf4
KW
6# WARNING: This script will be run on very old perls. You need to not use
7# modern constructs. See HACKERS file for examples.
8#
adfe19db
MHM
9################################################################################
10#
b2049988 11# Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
adfe19db
MHM
12# Version 2.x, Copyright (C) 2001, Paul Marquess.
13# Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
14#
15# This program is free software; you can redistribute it and/or
16# modify it under the same terms as Perl itself.
17#
18################################################################################
19
20use strict;
3d7c117d 21require './parts/ppptools.pl';
adfe19db
MHM
22
23if (@ARGV) {
0c96388f
MHM
24 my $file = pop @ARGV;
25 open OUT, ">$file" or die "$file: $!\n";
adfe19db
MHM
26}
27else {
28 *OUT = \*STDOUT;
29}
30
e27fc489 31# Get list of functions/macros to test
679ad62d 32my @f = parse_embed(qw( parts/embed.fnc parts/apidoc.fnc parts/ppport.fnc ));
adfe19db 33
e27fc489
KW
34# Read in what we've decided in previous calls should be #ifdef'd out for this
35# call. The keys are the symbols to test; each value is a subhash, like so:
36# 'utf8_hop_forward' => {
37# 'version' => '5.025007'
38# },
39# We don't care here about other subkeys
adfe19db
MHM
40my %todo = %{&parse_todo};
41
e27fc489 42# We convert these types into these other types
adfe19db
MHM
43my %tmap = (
44 void => 'int',
45);
46
e27fc489 47# These are for special marker argument names, as mentioned in embed.fnc
adfe19db
MHM
48my %amap = (
49 SP => 'SP',
50 type => 'int',
51 cast => 'int',
15765034 52 block => '{1;}',
adfe19db
MHM
53);
54
e27fc489 55# Certain return types are instead considered void
adfe19db
MHM
56my %void = (
57 void => 1,
58 Free_t => 1,
59 Signal_t => 1,
60);
61
e27fc489
KW
62# khw doesn't know why these exist. These have an explicit (void) cast added.
63# Undef'ing this hash made no difference. Maybe it's for older compilers?
adfe19db
MHM
64my %castvoid = (
65 map { ($_ => 1) } qw(
c54ae73f
KW
66 G_ARRAY
67 G_DISCARD
68 G_EVAL
69 G_NOARGS
70 G_SCALAR
71 G_VOID
72 HEf_SVKEY
73 MARK
adfe19db 74 Nullav
c54ae73f 75 Nullch
adfe19db
MHM
76 Nullcv
77 Nullhv
adfe19db 78 Nullsv
adfe19db 79 SP
adfe19db
MHM
80 SVt_IV
81 SVt_NV
c54ae73f 82 SVt_PV
adfe19db 83 SVt_PVAV
adfe19db 84 SVt_PVCV
c54ae73f
KW
85 SVt_PVHV
86 SVt_PVMG
adfe19db 87 SvUOK
adfe19db
MHM
88 XS_VERSION
89 ),
90);
91
e27fc489 92# Ignore the return value of these
adfe19db
MHM
93my %ignorerv = (
94 map { ($_ => 1) } qw(
95 newCONSTSUB
96 ),
97);
98
b485c9d9
KW
99my @simple_my_cxt_prereqs = ( 'typedef struct { int count; } my_cxt_t;', 'START_MY_CXT;' );
100my @my_cxt_prereqs = ( @simple_my_cxt_prereqs, 'MY_CXT_INIT;' );
101
e27fc489
KW
102# The value of each key is a list of things that need to be declared in order
103# for the key to compile.
adfe19db 104my %stack = (
cfc3b033 105 MULTICALL => ['dMULTICALL;'],
4a582685 106 ORIGMARK => ['dORIGMARK;'],
cfc3b033
KW
107 POP_MULTICALL => ['dMULTICALL;', 'U8 gimme;' ],
108 PUSH_MULTICALL => ['dMULTICALL;', 'U8 gimme;' ],
4a582685 109 POPpbytex => ['STRLEN n_a;'],
c54ae73f 110 POPpx => ['STRLEN n_a;'],
4a582685 111 PUSHi => ['dTARG;'],
c54ae73f
KW
112 PUSHn => ['dTARG;'],
113 PUSHp => ['dTARG;'],
4a582685 114 PUSHu => ['dTARG;'],
ec4a7abf
KW
115 RESTORE_LC_NUMERIC => ['DECLARATION_FOR_LC_NUMERIC_MANIPULATION;'],
116 STORE_LC_NUMERIC_FORCE_TO_UNDERLYING => ['DECLARATION_FOR_LC_NUMERIC_MANIPULATION;'],
117 STORE_LC_NUMERIC_SET_TO_NEEDED => ['DECLARATION_FOR_LC_NUMERIC_MANIPULATION;'],
118 STORE_LC_NUMERIC_SET_TO_NEEDED_IN => ['DECLARATION_FOR_LC_NUMERIC_MANIPULATION;'],
c54ae73f
KW
119 UNDERBAR => ['dUNDERBAR;'],
120 XCPT_CATCH => ['dXCPT;'],
121 XCPT_RETHROW => ['dXCPT;'],
122 XCPT_TRY_END => ['dXCPT;'],
123 XCPT_TRY_START => ['dXCPT;'],
124 XPUSHi => ['dTARG;'],
125 XPUSHn => ['dTARG;'],
126 XPUSHp => ['dTARG;'],
127 XPUSHu => ['dTARG;'],
eae22b18
KW
128 XS_APIVERSION_BOOTCHECK => ['CV * cv;'],
129 XS_VERSION_BOOTCHECK => ['CV * cv;'],
b485c9d9
KW
130 MY_CXT_INIT => [ @simple_my_cxt_prereqs ],
131 MY_CXT_CLONE => [ @simple_my_cxt_prereqs ],
132 dMY_CXT => [ @simple_my_cxt_prereqs ],
133 MY_CXT => [ @my_cxt_prereqs ],
134 _aMY_CXT => [ @my_cxt_prereqs ],
135 aMY_CXT => [ @my_cxt_prereqs ],
136 aMY_CXT_ => [ @my_cxt_prereqs ],
137 pMY_CXT => [ @my_cxt_prereqs ],
adfe19db
MHM
138);
139
7d0cbfba
KW
140# The entries in %ignore have two components, separated by this.
141my $sep = '~';
6b99da3d 142
7d0cbfba
KW
143# Things to not try to check. (The component after $sep is empty.)
144my %ignore = map { ("$_$sep" => 1) } keys %{&known_but_hard_to_test_for()};
adfe19db 145
e27fc489 146# XXX The NEED_foo lines should be autogenerated
adfe19db
MHM
147print OUT <<HEAD;
148/*
149 * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
150 * This file is built by $0.
151 * Any changes made here will be lost!
152 */
153
154#include "EXTERN.h"
155#include "perl.h"
4a582685
NC
156
157#define NO_XSLOCKS
adfe19db
MHM
158#include "XSUB.h"
159
ba120f6f
MHM
160#ifdef DPPP_APICHECK_NO_PPPORT_H
161
162/* This is just to avoid too many baseline failures with perls < 5.6.0 */
163
164#ifndef dTHX
165# define dTHX extern int Perl___notused
166#endif
167
168#else
adfe19db 169
c01be2ce 170#define NEED_PL_parser
8d137abb 171#define NEED_PL_signals
744ef08f 172#define NEED_caller_cx
8d137abb
P
173#define NEED_croak_xs_usage
174#define NEED_die_sv
adfe19db
MHM
175#define NEED_eval_pv
176#define NEED_grok_bin
177#define NEED_grok_hex
178#define NEED_grok_number
179#define NEED_grok_numeric_radix
180#define NEED_grok_oct
679ad62d 181#define NEED_load_module
8d137abb
P
182#define NEED_mess
183#define NEED_mess_nocontext
184#define NEED_mess_sv
94e22bd6 185#define NEED_mg_findext
f2ab5a41 186#define NEED_my_snprintf
c01be2ce 187#define NEED_my_sprintf
aef0a14c
MHM
188#define NEED_my_strlcat
189#define NEED_my_strlcpy
8d137abb 190#define NEED_my_strnlen
adfe19db 191#define NEED_newCONSTSUB
c83e6f19 192#define NEED_newSVpvn_share
db42c902
MHM
193#define NEED_pv_display
194#define NEED_pv_escape
195#define NEED_pv_pretty
96ad942f
MHM
196#define NEED_sv_catpvf_mg
197#define NEED_sv_catpvf_mg_nocontext
198#define NEED_sv_setpvf_mg
199#define NEED_sv_setpvf_mg_nocontext
744ef08f 200#define NEED_sv_unmagicext
8d137abb 201#define NEED_utf8_to_uvchr_buf
679ad62d 202#define NEED_vload_module
8d137abb 203#define NEED_vmess
f2ab5a41 204#define NEED_warner
96ad942f 205
adfe19db
MHM
206#include "ppport.h"
207
208#endif
209
adfe19db
MHM
210static int VARarg1;
211static char *VARarg2;
212static double VARarg3;
213
744ef08f
CBW
214#if defined(PERL_BCDVERSION) && (PERL_BCDVERSION < 0x5009005)
215/* needed to make PL_parser apicheck work */
216typedef void yy_parser;
217#endif
218
adfe19db
MHM
219HEAD
220
e27fc489 221# Caller can restrict what functions tests are generated for
0c96388f
MHM
222if (@ARGV) {
223 my %want = map { ($_ => 0) } @ARGV;
54b3baf4
KW
224 @f = grep { exists $want{$_->{'name'}} } @f;
225 for (@f) { $want{$_->{'name'}}++ }
0c96388f
MHM
226 for (keys %want) {
227 die "nothing found for '$_'\n" unless $want{$_};
228 }
229}
230
adfe19db 231my $f;
e27fc489 232for $f (@f) { # Loop through all the tests to add
7d0cbfba
KW
233
234 # Just the name isn't unique; We also need the #if or #else condition
235 my $unique = "$f->{'name'}$sep$f->{'cond'}";
236 $ignore{$unique} and next;
237
dfaee99f
KW
238 # only public API members, except those in ppport.fnc are there because we
239 # want them to be tested even if non-public.
240 $f->{'flags'}{'A'} or $f->{'ppport_fnc'} or next;
adfe19db 241
59974c5d
KW
242 # Don't test unorthodox things that we aren't set up to do
243 $f->{'flags'}{'u'} and next;
244
7d0cbfba 245 $ignore{$unique} = 1; # ignore duplicates
fbd5db69 246
54b3baf4 247 my $Perl_ = $f->{'flags'}{'p'} ? 'Perl_' : '';
adfe19db
MHM
248
249 my $stack = '';
250 my @arg;
251 my $aTHX = '';
252
253 my $i = 1;
254 my $ca;
255 my $varargs = 0;
e27fc489 256
54b3baf4 257 for $ca (@{$f->{'args'}}) { # Loop through the function's args
e27fc489 258 my $a = $ca->[0]; # 1th is the name, 0th is its type
adfe19db
MHM
259 if ($a eq '...') {
260 $varargs = 1;
261 push @arg, qw(VARarg1 VARarg2 VARarg3);
262 last;
263 }
e27fc489
KW
264
265 # Split this type into its components
d8db9e48
KW
266 my($n, $p, $d) = $a =~ /^ ( (?: " [^"]* " ) # literal string type => $n
267 | (?: \w+ (?: \s+ \w+ )* ) # name of type => $n
268 )
6085326e
KW
269 \s*
270 ( \** ) # optional pointer(s) => $p
271 (?: \s* \b const \b \s* )? # opt. const
272 ( (?: \[ [^\]]* \] )* ) # opt. dimension(s)=> $d
4a582685 273 $/x
bf10f3cf 274 or die "$0 - cannot parse argument: [$a] in $f->{'name'}\n";
e27fc489
KW
275
276 # Replace a special argument name by something that will compile.
adfe19db 277 if (exists $amap{$n}) {
bf10f3cf
KW
278 die "$f->{'name'} had type $n, which should have been the whole type"
279 if $p or $d;
adfe19db
MHM
280 push @arg, $amap{$n};
281 next;
282 }
e27fc489
KW
283
284 # Certain types, like 'void', get remapped.
adfe19db 285 $n = $tmap{$n} || $n;
e27fc489 286
d8db9e48
KW
287 if ($n =~ / ^ " [^"]* " $/x) { # Use the literal string, literally
288 push @arg, $n;
0c96388f
MHM
289 }
290 else {
e27fc489 291 my $v = 'arg' . $i++; # Argument number
0c96388f 292 push @arg, $v;
e27fc489 293 my $no_const_n = $n; # Get rid of any remaining 'const's
5334bcf6 294 $no_const_n =~ s/\bconst\b// unless $p;
e27fc489
KW
295
296 # Declare this argument
5334bcf6 297 $stack .= " static $no_const_n $p$v$d;\n";
0c96388f 298 }
adfe19db
MHM
299 }
300
e27fc489
KW
301 # Declare thread context for functions and macros that might need it.
302 # (Macros often fail to say they don't need it.)
54b3baf4 303 unless ($f->{'flags'}{'T'}) {
5624d54c 304 $stack = " dTHX;\n$stack"; # Harmless to declare even if not needed
adfe19db
MHM
305 $aTHX = @arg ? 'aTHX_ ' : 'aTHX';
306 }
307
e27fc489
KW
308 # If this function is on the list of things that need declarations, add
309 # them.
54b3baf4 310 if ($stack{$f->{'name'}}) {
adfe19db 311 my $s = '';
54b3baf4 312 for (@{$stack{$f->{'name'}}}) {
adfe19db
MHM
313 $s .= " $_\n";
314 }
315 $stack = "$s$stack";
316 }
317
318 my $args = join ', ', @arg;
73f5bd35 319 my $prefix = "";
e27fc489
KW
320
321 # Failure to specify a return type in the apidoc line means void
54b3baf4 322 my $rvt = $f->{'ret'} || 'void';
e27fc489 323
adfe19db 324 my $ret;
e27fc489 325 if ($void{$rvt}) { # Certain return types are instead considered void
54b3baf4 326 $ret = $castvoid{$f->{'name'}} ? '(void) ' : '';
adfe19db
MHM
327 }
328 else {
ba120f6f 329 $stack .= " $rvt rval;\n";
54b3baf4 330 $ret = $ignorerv{$f->{'name'}} ? '(void) ' : "rval = ";
adfe19db 331 }
e27fc489 332
73f5bd35
KW
333 my $aTHX_args = "";
334 my $aTHX_prefix = "";
adfe19db 335
e27fc489 336 # Add parens to functions that take an argument list, even if empty
54b3baf4 337 unless ($f->{'flags'}{'n'}) {
5624d54c 338 $aTHX_args = "($aTHX$args)";
adfe19db 339 $args = "($args)";
adfe19db
MHM
340 }
341
2b007d03
KW
342 # Single trailing underscore in name means is a comma operator
343 if ($f->{'name'} =~ /[^_]_$/) {
344 $aTHX_args .= ' 1';
345 $args .= ' 1';
346 }
347
adfe19db
MHM
348 print OUT <<HEAD;
349/******************************************************************************
350*
54b3baf4 351* $f->{'name'}
adfe19db
MHM
352*
353******************************************************************************/
354
355HEAD
356
e27fc489 357 # #ifdef out if marked as todo (not known in) this version
c07cf326
KW
358 if (exists $todo{$f->{'name'}}) {
359 my($five, $ver,$sub) = parse_version($todo{$f->{'name'}}{'version'});
adfe19db
MHM
360 print OUT "#if PERL_VERSION > $ver || (PERL_VERSION == $ver && PERL_SUBVERSION >= $sub) /* TODO */\n";
361 }
362
363 my $final = $varargs
73f5bd35
KW
364 ? "$aTHX_prefix$Perl_$f->{'name'}$aTHX_args"
365 : "$prefix$f->{'name'}$args";
adfe19db 366
e27fc489 367 # If there is a '#if' associated with this, add that
54b3baf4 368 $f->{'cond'} and print OUT "#if $f->{'cond'}\n";
adfe19db
MHM
369
370 print OUT <<END;
54b3baf4 371void _DPPP_test_$f->{'name'} (void)
adfe19db
MHM
372{
373 dXSARGS;
374$stack
adfe19db 375 {
54b3baf4 376#ifdef $f->{'name'}
73f5bd35 377 $ret$prefix$f->{'name'}$args;
adfe19db 378#endif
ba120f6f 379 }
adfe19db
MHM
380
381 {
54b3baf4 382#ifdef $f->{'name'}
ba120f6f 383 $ret$final;
adfe19db 384#else
73f5bd35 385 $ret$aTHX_prefix$Perl_$f->{'name'}$aTHX_args;
adfe19db
MHM
386#endif
387 }
388}
389END
390
54b3baf4 391 $f->{'cond'} and print OUT "#endif\n";
c07cf326 392 exists $todo{$f->{'name'}} and print OUT "#endif\n";
adfe19db
MHM
393
394 print OUT "\n";
395}
396
397@ARGV and close OUT;