This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
parts/apicheck.pl: Special case things like _aTHX
[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
e27fc489
KW
140# Things to not try to check. Either not applicable, or too hard to get to
141# work here.
adfe19db
MHM
142my %ignore = (
143 map { ($_ => 1) } qw(
c54ae73f
KW
144 CLASS
145 dXSI32
adfe19db
MHM
146 items
147 ix
adfe19db
MHM
148 RETVAL
149 StructCopy
c54ae73f
KW
150 svtype
151 THIS
d02cf1d1
KW
152 XopDISABLE
153 XopENABLE
154 XopENTRY
155 XopENTRYCUSTOM
156 XopENTRY_set
c54ae73f 157 XS
d02cf1d1
KW
158 XS_EXTERNAL
159 XS_INTERNAL
adfe19db
MHM
160 ),
161);
162
e27fc489 163# XXX The NEED_foo lines should be autogenerated
adfe19db
MHM
164print OUT <<HEAD;
165/*
166 * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
167 * This file is built by $0.
168 * Any changes made here will be lost!
169 */
170
171#include "EXTERN.h"
172#include "perl.h"
4a582685
NC
173
174#define NO_XSLOCKS
adfe19db
MHM
175#include "XSUB.h"
176
ba120f6f
MHM
177#ifdef DPPP_APICHECK_NO_PPPORT_H
178
179/* This is just to avoid too many baseline failures with perls < 5.6.0 */
180
181#ifndef dTHX
182# define dTHX extern int Perl___notused
183#endif
184
185#else
adfe19db 186
c01be2ce 187#define NEED_PL_parser
8d137abb 188#define NEED_PL_signals
744ef08f 189#define NEED_caller_cx
8d137abb
P
190#define NEED_croak_xs_usage
191#define NEED_die_sv
adfe19db
MHM
192#define NEED_eval_pv
193#define NEED_grok_bin
194#define NEED_grok_hex
195#define NEED_grok_number
196#define NEED_grok_numeric_radix
197#define NEED_grok_oct
679ad62d 198#define NEED_load_module
8d137abb
P
199#define NEED_mess
200#define NEED_mess_nocontext
201#define NEED_mess_sv
94e22bd6 202#define NEED_mg_findext
f2ab5a41 203#define NEED_my_snprintf
c01be2ce 204#define NEED_my_sprintf
aef0a14c
MHM
205#define NEED_my_strlcat
206#define NEED_my_strlcpy
8d137abb 207#define NEED_my_strnlen
adfe19db 208#define NEED_newCONSTSUB
c83e6f19 209#define NEED_newSVpvn_share
db42c902
MHM
210#define NEED_pv_display
211#define NEED_pv_escape
212#define NEED_pv_pretty
96ad942f
MHM
213#define NEED_sv_catpvf_mg
214#define NEED_sv_catpvf_mg_nocontext
215#define NEED_sv_setpvf_mg
216#define NEED_sv_setpvf_mg_nocontext
744ef08f 217#define NEED_sv_unmagicext
8d137abb 218#define NEED_utf8_to_uvchr_buf
679ad62d 219#define NEED_vload_module
8d137abb 220#define NEED_vmess
f2ab5a41 221#define NEED_warner
96ad942f 222
adfe19db
MHM
223#include "ppport.h"
224
225#endif
226
adfe19db
MHM
227static int VARarg1;
228static char *VARarg2;
229static double VARarg3;
230
744ef08f
CBW
231#if defined(PERL_BCDVERSION) && (PERL_BCDVERSION < 0x5009005)
232/* needed to make PL_parser apicheck work */
233typedef void yy_parser;
234#endif
235
adfe19db
MHM
236HEAD
237
e27fc489 238# Caller can restrict what functions tests are generated for
0c96388f
MHM
239if (@ARGV) {
240 my %want = map { ($_ => 0) } @ARGV;
54b3baf4
KW
241 @f = grep { exists $want{$_->{'name'}} } @f;
242 for (@f) { $want{$_->{'name'}}++ }
0c96388f
MHM
243 for (keys %want) {
244 die "nothing found for '$_'\n" unless $want{$_};
245 }
246}
247
adfe19db 248my $f;
e27fc489 249for $f (@f) { # Loop through all the tests to add
54b3baf4
KW
250 $ignore{$f->{'name'}} and next;
251 $f->{'flags'}{'A'} or next; # only public API members
adfe19db 252
54b3baf4 253 $ignore{$f->{'name'}} = 1; # ignore duplicates
fbd5db69 254
54b3baf4 255 my $Perl_ = $f->{'flags'}{'p'} ? 'Perl_' : '';
adfe19db
MHM
256
257 my $stack = '';
258 my @arg;
259 my $aTHX = '';
260
261 my $i = 1;
262 my $ca;
263 my $varargs = 0;
e27fc489 264
54b3baf4 265 for $ca (@{$f->{'args'}}) { # Loop through the function's args
e27fc489 266 my $a = $ca->[0]; # 1th is the name, 0th is its type
adfe19db
MHM
267 if ($a eq '...') {
268 $varargs = 1;
269 push @arg, qw(VARarg1 VARarg2 VARarg3);
270 last;
271 }
e27fc489
KW
272
273 # Split this type into its components
6085326e
KW
274 my($n, $p, $d) = $a =~ /^ ( \w+ (?: \s+ \w+ )* ) # type name => $n
275 \s*
276 ( \** ) # optional pointer(s) => $p
277 (?: \s* \b const \b \s* )? # opt. const
278 ( (?: \[ [^\]]* \] )* ) # opt. dimension(s)=> $d
4a582685 279 $/x
bf10f3cf 280 or die "$0 - cannot parse argument: [$a] in $f->{'name'}\n";
e27fc489
KW
281
282 # Replace a special argument name by something that will compile.
adfe19db 283 if (exists $amap{$n}) {
bf10f3cf
KW
284 die "$f->{'name'} had type $n, which should have been the whole type"
285 if $p or $d;
adfe19db
MHM
286 push @arg, $amap{$n};
287 next;
288 }
e27fc489
KW
289
290 # Certain types, like 'void', get remapped.
adfe19db 291 $n = $tmap{$n} || $n;
e27fc489
KW
292
293 # Use a literal of our choosing for non-format functions
54b3baf4 294 if ($n =~ /\bconst\s+char\b/ and $p eq '*' and !$f->{'flags'}{'f'}) {
0c96388f
MHM
295 push @arg, '"foo"';
296 }
297 else {
e27fc489 298 my $v = 'arg' . $i++; # Argument number
0c96388f 299 push @arg, $v;
e27fc489 300 my $no_const_n = $n; # Get rid of any remaining 'const's
5334bcf6 301 $no_const_n =~ s/\bconst\b// unless $p;
e27fc489
KW
302
303 # Declare this argument
5334bcf6 304 $stack .= " static $no_const_n $p$v$d;\n";
0c96388f 305 }
adfe19db
MHM
306 }
307
e27fc489
KW
308 # Declare thread context for functions and macros that might need it.
309 # (Macros often fail to say they don't need it.)
54b3baf4 310 unless ($f->{'flags'}{'T'}) {
5624d54c 311 $stack = " dTHX;\n$stack"; # Harmless to declare even if not needed
adfe19db
MHM
312 $aTHX = @arg ? 'aTHX_ ' : 'aTHX';
313 }
314
e27fc489
KW
315 # If this function is on the list of things that need declarations, add
316 # them.
54b3baf4 317 if ($stack{$f->{'name'}}) {
adfe19db 318 my $s = '';
54b3baf4 319 for (@{$stack{$f->{'name'}}}) {
adfe19db
MHM
320 $s .= " $_\n";
321 }
322 $stack = "$s$stack";
323 }
324
325 my $args = join ', ', @arg;
73f5bd35 326 my $prefix = "";
e27fc489
KW
327
328 # Failure to specify a return type in the apidoc line means void
54b3baf4 329 my $rvt = $f->{'ret'} || 'void';
e27fc489 330
adfe19db 331 my $ret;
e27fc489 332 if ($void{$rvt}) { # Certain return types are instead considered void
54b3baf4 333 $ret = $castvoid{$f->{'name'}} ? '(void) ' : '';
adfe19db
MHM
334 }
335 else {
ba120f6f 336 $stack .= " $rvt rval;\n";
54b3baf4 337 $ret = $ignorerv{$f->{'name'}} ? '(void) ' : "rval = ";
adfe19db 338 }
e27fc489 339
73f5bd35
KW
340 my $aTHX_args = "";
341 my $aTHX_prefix = "";
adfe19db 342
e27fc489 343 # Add parens to functions that take an argument list, even if empty
54b3baf4 344 unless ($f->{'flags'}{'n'}) {
5624d54c 345 $aTHX_args = "($aTHX$args)";
adfe19db 346 $args = "($args)";
adfe19db
MHM
347 }
348
2b007d03
KW
349 # Single trailing underscore in name means is a comma operator
350 if ($f->{'name'} =~ /[^_]_$/) {
351 $aTHX_args .= ' 1';
352 $args .= ' 1';
353 }
354
adfe19db
MHM
355 print OUT <<HEAD;
356/******************************************************************************
357*
54b3baf4 358* $f->{'name'}
adfe19db
MHM
359*
360******************************************************************************/
361
362HEAD
363
e27fc489 364 # #ifdef out if marked as todo (not known in) this version
54b3baf4
KW
365 if ($todo{$f->{'name'}}) {
366 my($ver,$sub) = $todo{$f->{'name'}} =~ /^5\.(\d{3})(\d{2,3})$/ or die;
adfe19db
MHM
367 for ($ver, $sub) {
368 s/^0+(\d)/$1/
369 }
370 if ($ver < 6 && $sub > 0) {
54b3baf4 371 #$sub =~ s/0$// or die;
adfe19db
MHM
372 }
373 print OUT "#if PERL_VERSION > $ver || (PERL_VERSION == $ver && PERL_SUBVERSION >= $sub) /* TODO */\n";
374 }
375
376 my $final = $varargs
73f5bd35
KW
377 ? "$aTHX_prefix$Perl_$f->{'name'}$aTHX_args"
378 : "$prefix$f->{'name'}$args";
adfe19db 379
e27fc489 380 # If there is a '#if' associated with this, add that
54b3baf4 381 $f->{'cond'} and print OUT "#if $f->{'cond'}\n";
adfe19db
MHM
382
383 print OUT <<END;
54b3baf4 384void _DPPP_test_$f->{'name'} (void)
adfe19db
MHM
385{
386 dXSARGS;
387$stack
adfe19db 388 {
54b3baf4 389#ifdef $f->{'name'}
73f5bd35 390 $ret$prefix$f->{'name'}$args;
adfe19db 391#endif
ba120f6f 392 }
adfe19db
MHM
393
394 {
54b3baf4 395#ifdef $f->{'name'}
ba120f6f 396 $ret$final;
adfe19db 397#else
73f5bd35 398 $ret$aTHX_prefix$Perl_$f->{'name'}$aTHX_args;
adfe19db
MHM
399#endif
400 }
401}
402END
403
54b3baf4
KW
404 $f->{'cond'} and print OUT "#endif\n";
405 $todo{$f->{'name'}} and print OUT "#endif\n";
adfe19db
MHM
406
407 print OUT "\n";
408}
409
410@ARGV and close OUT;