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