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