This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
parts/apicheck.pl: LC_NUMERIC manip requires a decl
[perl5.git] / dist / Devel-PPPort / parts / apicheck.pl
CommitLineData
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
17use strict;
3d7c117d 18require './parts/ppptools.pl';
adfe19db
MHM
19
20if (@ARGV) {
0c96388f
MHM
21 my $file = pop @ARGV;
22 open OUT, ">$file" or die "$file: $!\n";
adfe19db
MHM
23}
24else {
25 *OUT = \*STDOUT;
26}
27
679ad62d 28my @f = parse_embed(qw( parts/embed.fnc parts/apidoc.fnc parts/ppport.fnc ));
adfe19db
MHM
29
30my %todo = %{&parse_todo};
31
32my %tmap = (
33 void => 'int',
34);
35
36my %amap = (
37 SP => 'SP',
38 type => 'int',
39 cast => 'int',
40);
41
42my %void = (
43 void => 1,
44 Free_t => 1,
45 Signal_t => 1,
46);
47
48my %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
76my %ignorerv = (
77 map { ($_ => 1) } qw(
78 newCONSTSUB
79 ),
80);
81
82my %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;'],
ec4a7abf
KW
99 RESTORE_LC_NUMERIC => ['DECLARATION_FOR_LC_NUMERIC_MANIPULATION;'],
100 STORE_LC_NUMERIC_FORCE_TO_UNDERLYING => ['DECLARATION_FOR_LC_NUMERIC_MANIPULATION;'],
101 STORE_LC_NUMERIC_SET_TO_NEEDED => ['DECLARATION_FOR_LC_NUMERIC_MANIPULATION;'],
102 STORE_LC_NUMERIC_SET_TO_NEEDED_IN => ['DECLARATION_FOR_LC_NUMERIC_MANIPULATION;'],
adfe19db
MHM
103);
104
adfe19db
MHM
105my %ignore = (
106 map { ($_ => 1) } qw(
107 svtype
108 items
109 ix
110 dXSI32
111 XS
112 CLASS
113 THIS
114 RETVAL
115 StructCopy
116 ),
117);
118
119print OUT <<HEAD;
120/*
121 * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
122 * This file is built by $0.
123 * Any changes made here will be lost!
124 */
125
126#include "EXTERN.h"
127#include "perl.h"
4a582685
NC
128
129#define NO_XSLOCKS
adfe19db
MHM
130#include "XSUB.h"
131
ba120f6f
MHM
132#ifdef DPPP_APICHECK_NO_PPPORT_H
133
134/* This is just to avoid too many baseline failures with perls < 5.6.0 */
135
136#ifndef dTHX
137# define dTHX extern int Perl___notused
138#endif
139
140#else
adfe19db 141
c01be2ce 142#define NEED_PL_parser
8d137abb 143#define NEED_PL_signals
744ef08f 144#define NEED_caller_cx
8d137abb
P
145#define NEED_croak_xs_usage
146#define NEED_die_sv
adfe19db
MHM
147#define NEED_eval_pv
148#define NEED_grok_bin
149#define NEED_grok_hex
150#define NEED_grok_number
151#define NEED_grok_numeric_radix
152#define NEED_grok_oct
679ad62d 153#define NEED_load_module
8d137abb
P
154#define NEED_mess
155#define NEED_mess_nocontext
156#define NEED_mess_sv
94e22bd6 157#define NEED_mg_findext
f2ab5a41 158#define NEED_my_snprintf
c01be2ce 159#define NEED_my_sprintf
aef0a14c
MHM
160#define NEED_my_strlcat
161#define NEED_my_strlcpy
8d137abb 162#define NEED_my_strnlen
adfe19db 163#define NEED_newCONSTSUB
c83e6f19 164#define NEED_newSVpvn_share
db42c902
MHM
165#define NEED_pv_display
166#define NEED_pv_escape
167#define NEED_pv_pretty
96ad942f
MHM
168#define NEED_sv_catpvf_mg
169#define NEED_sv_catpvf_mg_nocontext
170#define NEED_sv_setpvf_mg
171#define NEED_sv_setpvf_mg_nocontext
744ef08f 172#define NEED_sv_unmagicext
8d137abb 173#define NEED_utf8_to_uvchr_buf
679ad62d 174#define NEED_vload_module
8d137abb 175#define NEED_vmess
f2ab5a41 176#define NEED_warner
96ad942f 177
adfe19db
MHM
178#include "ppport.h"
179
180#endif
181
adfe19db
MHM
182static int VARarg1;
183static char *VARarg2;
184static double VARarg3;
185
744ef08f
CBW
186#if defined(PERL_BCDVERSION) && (PERL_BCDVERSION < 0x5009005)
187/* needed to make PL_parser apicheck work */
188typedef void yy_parser;
189#endif
190
adfe19db
MHM
191HEAD
192
0c96388f
MHM
193if (@ARGV) {
194 my %want = map { ($_ => 0) } @ARGV;
195 @f = grep { exists $want{$_->{name}} } @f;
196 for (@f) { $want{$_->{name}}++ }
197 for (keys %want) {
198 die "nothing found for '$_'\n" unless $want{$_};
199 }
200}
201
adfe19db
MHM
202my $f;
203for $f (@f) {
204 $ignore{$f->{name}} and next;
205 $f->{flags}{A} or next; # only public API members
206
fbd5db69
KW
207 $ignore{$f->{name}} = 1; # ignore duplicates
208
adfe19db
MHM
209 my $Perl_ = $f->{flags}{p} ? 'Perl_' : '';
210
211 my $stack = '';
212 my @arg;
213 my $aTHX = '';
214
215 my $i = 1;
216 my $ca;
217 my $varargs = 0;
218 for $ca (@{$f->{args}}) {
219 my $a = $ca->[0];
220 if ($a eq '...') {
221 $varargs = 1;
222 push @arg, qw(VARarg1 VARarg2 VARarg3);
223 last;
224 }
4a582685
NC
225 my($n, $p, $d) = $a =~ /^ (\w+(?:\s+\w+)*)\s* # type name => $n
226 (\**) # pointer => $p
d0cf06bd 227 (?:\s*\bconst\b\s*)? # const
4a582685
NC
228 ((?:\[[^\]]*\])*) # dimension => $d
229 $/x
230 or die "$0 - cannot parse argument: [$a]\n";
adfe19db
MHM
231 if (exists $amap{$n}) {
232 push @arg, $amap{$n};
233 next;
234 }
235 $n = $tmap{$n} || $n;
d0cf06bd 236 if ($n =~ /\bconst\s+char\b/ and $p eq '*' and !$f->{flags}{f}) {
0c96388f
MHM
237 push @arg, '"foo"';
238 }
239 else {
240 my $v = 'arg' . $i++;
241 push @arg, $v;
5334bcf6
KW
242 my $no_const_n = $n;
243 $no_const_n =~ s/\bconst\b// unless $p;
244 $stack .= " static $no_const_n $p$v$d;\n";
0c96388f 245 }
adfe19db
MHM
246 }
247
5624d54c
KW
248 unless ($f->{flags}{'T'}) {
249 $stack = " dTHX;\n$stack"; # Harmless to declare even if not needed
adfe19db
MHM
250 $aTHX = @arg ? 'aTHX_ ' : 'aTHX';
251 }
252
253 if ($stack{$f->{name}}) {
254 my $s = '';
255 for (@{$stack{$f->{name}}}) {
256 $s .= " $_\n";
257 }
258 $stack = "$s$stack";
259 }
260
261 my $args = join ', ', @arg;
262 my $rvt = $f->{ret} || 'void';
263 my $ret;
264 if ($void{$rvt}) {
265 $ret = $castvoid{$f->{name}} ? '(void) ' : '';
266 }
267 else {
ba120f6f
MHM
268 $stack .= " $rvt rval;\n";
269 $ret = $ignorerv{$f->{name}} ? '(void) ' : "rval = ";
adfe19db 270 }
5624d54c 271 my $aTHX_args = "";
adfe19db 272
5624d54c
KW
273 unless ($f->{flags}{'n'}) {
274 $aTHX_args = "($aTHX$args)";
adfe19db 275 $args = "($args)";
adfe19db
MHM
276 }
277
278 print OUT <<HEAD;
279/******************************************************************************
280*
281* $f->{name}
282*
283******************************************************************************/
284
285HEAD
286
287 if ($todo{$f->{name}}) {
288 my($ver,$sub) = $todo{$f->{name}} =~ /^5\.(\d{3})(\d{3})$/ or die;
289 for ($ver, $sub) {
290 s/^0+(\d)/$1/
291 }
292 if ($ver < 6 && $sub > 0) {
293 $sub =~ s/0$// or die;
294 }
295 print OUT "#if PERL_VERSION > $ver || (PERL_VERSION == $ver && PERL_SUBVERSION >= $sub) /* TODO */\n";
296 }
297
298 my $final = $varargs
299 ? "$Perl_$f->{name}$aTHX_args"
300 : "$f->{name}$args";
301
302 $f->{cond} and print OUT "#if $f->{cond}\n";
303
304 print OUT <<END;
ba120f6f 305void _DPPP_test_$f->{name} (void)
adfe19db
MHM
306{
307 dXSARGS;
308$stack
adfe19db 309 {
ba120f6f
MHM
310#ifdef $f->{name}
311 $ret$f->{name}$args;
adfe19db 312#endif
ba120f6f 313 }
adfe19db
MHM
314
315 {
316#ifdef $f->{name}
ba120f6f 317 $ret$final;
adfe19db 318#else
ba120f6f 319 $ret$Perl_$f->{name}$aTHX_args;
adfe19db
MHM
320#endif
321 }
322}
323END
324
325 $f->{cond} and print OUT "#endif\n";
326 $todo{$f->{name}} and print OUT "#endif\n";
327
328 print OUT "\n";
329}
330
331@ARGV and close OUT;