This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
parts/inc/inctools: Add fcn to return integer version
[perl5.git] / dist / Devel-PPPort / parts / apicheck.pl
1 #!/usr/bin/perl -w
2 ################################################################################
3 #
4 #  apicheck.pl -- generate apicheck.c: C source for automated API check
5 #
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 #
9 ################################################################################
10 #
11 #  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
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
20 use strict;
21 require './parts/ppptools.pl';
22
23 if (@ARGV) {
24   my $file = pop @ARGV;
25   open OUT, ">$file" or die "$file: $!\n";
26 }
27 else {
28   *OUT = \*STDOUT;
29 }
30
31 # Get list of functions/macros to test
32 my @f = parse_embed(qw( parts/embed.fnc parts/apidoc.fnc parts/ppport.fnc ));
33
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
40 my %todo = %{&parse_todo};
41
42 # We convert these types into these other types
43 my %tmap = (
44   void => 'int',
45 );
46
47 # These are for special marker argument names, as mentioned in embed.fnc
48 my %amap = (
49   SP   => 'SP',
50   type => 'int',
51   cast => 'int',
52   block => '{1;}',
53 );
54
55 # Certain return types are instead considered void
56 my %void = (
57   void     => 1,
58   Free_t   => 1,
59   Signal_t => 1,
60 );
61
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?
64 my %castvoid = (
65   map { ($_ => 1) } qw(
66     G_ARRAY
67     G_DISCARD
68     G_EVAL
69     G_NOARGS
70     G_SCALAR
71     G_VOID
72     HEf_SVKEY
73     MARK
74     Nullav
75     Nullch
76     Nullcv
77     Nullhv
78     Nullsv
79     SP
80     SVt_IV
81     SVt_NV
82     SVt_PV
83     SVt_PVAV
84     SVt_PVCV
85     SVt_PVHV
86     SVt_PVMG
87     SvUOK
88     XS_VERSION
89   ),
90 );
91
92 # Ignore the return value of these
93 my %ignorerv = (
94   map { ($_ => 1) } qw(
95     newCONSTSUB
96   ),
97 );
98
99 my @simple_my_cxt_prereqs = ( 'typedef struct { int count; } my_cxt_t;', 'START_MY_CXT;' );
100 my @my_cxt_prereqs = ( @simple_my_cxt_prereqs, 'MY_CXT_INIT;' );
101
102 # The value of each key is a list of things that need to be declared in order
103 # for the key to compile.
104 my %stack = (
105   MULTICALL      => ['dMULTICALL;'],
106   ORIGMARK       => ['dORIGMARK;'],
107   POP_MULTICALL  => ['dMULTICALL;', 'U8 gimme;' ],
108   PUSH_MULTICALL => ['dMULTICALL;', 'U8 gimme;' ],
109   POPpbytex      => ['STRLEN n_a;'],
110   POPpx          => ['STRLEN n_a;'],
111   PUSHi          => ['dTARG;'],
112   PUSHn          => ['dTARG;'],
113   PUSHp          => ['dTARG;'],
114   PUSHu          => ['dTARG;'],
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;'],
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;'],
128   XS_APIVERSION_BOOTCHECK => ['CV * cv;'],
129   XS_VERSION_BOOTCHECK => ['CV * cv;'],
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 ],
138 );
139
140 # Things to not try to check.  Either not applicable, or too hard to get to
141 # work here.
142 my %ignore = (
143   map { ($_ => 1) } qw(
144     CLASS
145     dXSI32
146     items
147     ix
148     RETVAL
149     StructCopy
150     svtype
151     THIS
152     XopDISABLE
153     XopENABLE
154     XopENTRY
155     XopENTRYCUSTOM
156     XopENTRY_set
157     XS
158     XS_EXTERNAL
159     XS_INTERNAL
160   ),
161 );
162
163 # XXX The NEED_foo lines should be autogenerated
164 print 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"
173
174 #define NO_XSLOCKS
175 #include "XSUB.h"
176
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
186
187 #define NEED_PL_parser
188 #define NEED_PL_signals
189 #define NEED_caller_cx
190 #define NEED_croak_xs_usage
191 #define NEED_die_sv
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
198 #define NEED_load_module
199 #define NEED_mess
200 #define NEED_mess_nocontext
201 #define NEED_mess_sv
202 #define NEED_mg_findext
203 #define NEED_my_snprintf
204 #define NEED_my_sprintf
205 #define NEED_my_strlcat
206 #define NEED_my_strlcpy
207 #define NEED_my_strnlen
208 #define NEED_newCONSTSUB
209 #define NEED_newSVpvn_share
210 #define NEED_pv_display
211 #define NEED_pv_escape
212 #define NEED_pv_pretty
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
217 #define NEED_sv_unmagicext
218 #define NEED_utf8_to_uvchr_buf
219 #define NEED_vload_module
220 #define NEED_vmess
221 #define NEED_warner
222
223 #include "ppport.h"
224
225 #endif
226
227 static int    VARarg1;
228 static char  *VARarg2;
229 static double VARarg3;
230
231 #if defined(PERL_BCDVERSION) && (PERL_BCDVERSION < 0x5009005)
232 /* needed to make PL_parser apicheck work */
233 typedef void yy_parser;
234 #endif
235
236 HEAD
237
238 # Caller can restrict what functions tests are generated for
239 if (@ARGV) {
240   my %want = map { ($_ => 0) } @ARGV;
241   @f = grep { exists $want{$_->{'name'}} } @f;
242   for (@f) { $want{$_->{'name'}}++ }
243   for (keys %want) {
244     die "nothing found for '$_'\n" unless $want{$_};
245   }
246 }
247
248 my $f;
249 for $f (@f) {   # Loop through all the tests to add
250   $ignore{$f->{'name'}} and next;
251   $f->{'flags'}{'A'} or next;  # only public API members
252
253   $ignore{$f->{'name'}} = 1; # ignore duplicates
254
255   my $Perl_ = $f->{'flags'}{'p'} ? 'Perl_' : '';
256
257   my $stack = '';
258   my @arg;
259   my $aTHX = '';
260
261   my $i = 1;
262   my $ca;
263   my $varargs = 0;
264
265   for $ca (@{$f->{'args'}}) {   # Loop through the function's args
266     my $a = $ca->[0];           # 1th is the name, 0th is its type
267     if ($a eq '...') {
268       $varargs = 1;
269       push @arg, qw(VARarg1 VARarg2 VARarg3);
270       last;
271     }
272
273     # Split this type into its components
274     my($n, $p, $d) = $a =~ /^ (  (?: " [^"]* " )      # literal string type => $n
275                                | (?: \w+ (?: \s+ \w+ )* )    # name of type => $n
276                               )
277                               \s*
278                               ( \** )                 # optional pointer(s) => $p
279                               (?: \s* \b const \b \s* )? # opt. const
280                               ( (?: \[ [^\]]* \] )* )    # opt. dimension(s)=> $d
281                             $/x
282                      or die "$0 - cannot parse argument: [$a] in $f->{'name'}\n";
283
284     # Replace a special argument name by something that will compile.
285     if (exists $amap{$n}) {
286       die "$f->{'name'} had type $n, which should have been the whole type"
287                                                                     if $p or $d;
288       push @arg, $amap{$n};
289       next;
290     }
291
292     # Certain types, like 'void', get remapped.
293     $n = $tmap{$n} || $n;
294
295     if ($n =~ / ^ " [^"]* " $/x) {  # Use the literal string, literally
296       push @arg, $n;
297     }
298     else {
299       my $v = 'arg' . $i++;     # Argument number
300       push @arg, $v;
301       my $no_const_n = $n;      # Get rid of any remaining 'const's
302       $no_const_n =~ s/\bconst\b// unless $p;
303
304       # Declare this argument
305       $stack .= "  static $no_const_n $p$v$d;\n";
306     }
307   }
308
309   # Declare thread context for functions and macros that might need it.
310   # (Macros often fail to say they don't need it.)
311   unless ($f->{'flags'}{'T'}) {
312     $stack = "  dTHX;\n$stack";     # Harmless to declare even if not needed
313     $aTHX = @arg ? 'aTHX_ ' : 'aTHX';
314   }
315
316   # If this function is on the list of things that need declarations, add
317   # them.
318   if ($stack{$f->{'name'}}) {
319     my $s = '';
320     for (@{$stack{$f->{'name'}}}) {
321       $s .= "  $_\n";
322     }
323     $stack = "$s$stack";
324   }
325
326   my $args = join ', ', @arg;
327   my $prefix = "";
328
329   # Failure to specify a return type in the apidoc line means void
330   my $rvt = $f->{'ret'} || 'void';
331
332   my $ret;
333   if ($void{$rvt}) {    # Certain return types are instead considered void
334     $ret = $castvoid{$f->{'name'}} ? '(void) ' : '';
335   }
336   else {
337     $stack .= "  $rvt rval;\n";
338     $ret = $ignorerv{$f->{'name'}} ? '(void) ' : "rval = ";
339   }
340
341   my $aTHX_args   = "";
342   my $aTHX_prefix = "";
343
344   # Add parens to functions that take an argument list, even if empty
345   unless ($f->{'flags'}{'n'}) {
346     $aTHX_args = "($aTHX$args)";
347     $args = "($args)";
348   }
349
350   # Single trailing underscore in name means is a comma operator
351   if ($f->{'name'} =~ /[^_]_$/) {
352     $aTHX_args .= ' 1';
353     $args .= ' 1';
354   }
355
356   print OUT <<HEAD;
357 /******************************************************************************
358 *
359 *  $f->{'name'}
360 *
361 ******************************************************************************/
362
363 HEAD
364
365   # #ifdef out if marked as todo (not known in) this version
366   if ($todo{$f->{'name'}}) {
367     my($ver,$sub) = $todo{$f->{'name'}} =~ /^5\.(\d{3})(\d{2,3})$/ or die;
368     for ($ver, $sub) {
369       s/^0+(\d)/$1/
370     }
371     if ($ver < 6 && $sub > 0) {
372       #$sub =~ s/0$// or die;
373     }
374     print OUT "#if PERL_VERSION > $ver || (PERL_VERSION == $ver && PERL_SUBVERSION >= $sub) /* TODO */\n";
375   }
376
377   my $final = $varargs
378               ? "$aTHX_prefix$Perl_$f->{'name'}$aTHX_args"
379               : "$prefix$f->{'name'}$args";
380
381   # If there is a '#if' associated with this, add that
382   $f->{'cond'} and print OUT "#if $f->{'cond'}\n";
383
384   print OUT <<END;
385 void _DPPP_test_$f->{'name'} (void)
386 {
387   dXSARGS;
388 $stack
389   {
390 #ifdef $f->{'name'}
391     $ret$prefix$f->{'name'}$args;
392 #endif
393   }
394
395   {
396 #ifdef $f->{'name'}
397     $ret$final;
398 #else
399     $ret$aTHX_prefix$Perl_$f->{'name'}$aTHX_args;
400 #endif
401   }
402 }
403 END
404
405   $f->{'cond'} and print OUT "#endif\n";
406   $todo{$f->{'name'}} and print OUT "#endif\n";
407
408   print OUT "\n";
409 }
410
411 @ARGV and close OUT;