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
20use strict;
21require './parts/ppptools.pl';
22
23if (@ARGV) {
24  my $file = pop @ARGV;
25  open OUT, ">$file" or die "$file: $!\n";
26}
27else {
28  *OUT = \*STDOUT;
29}
30
31# Arguments passed to us in this variable are of the form
32# '--a=foo --b=bar', so split first on space, then the =, and then the hash is
33# of the form { a => foo, b => bar }
34my %script_args = map { split /=/ } split(/\s+/, $ENV{'DPPP_ARGUMENTS'});
35
36# Get list of functions/macros to test
37my @f = parse_embed(qw( parts/embed.fnc parts/apidoc.fnc parts/ppport.fnc ));
38
39# Read in what we've decided in previous calls should be #ifdef'd out for this
40# call.  The keys are the symbols to test; each value is a subhash, like so:
41#     'utf8_hop_forward' => {
42#                               'version' => '5.025007'
43#                           },
44# We don't care here about other subkeys
45my %todo = %{&parse_todo($script_args{'--todo-dir'})};
46
47# We convert these types into these other types
48my %tmap = (
49  void => 'int',
50);
51
52# These are for special marker argument names, as mentioned in embed.fnc
53my %amap = (
54  SP   => 'SP',
55  type => 'int',
56  cast => 'int',
57  block => '{1;}',
58  number => '1',
59);
60
61# Certain return types are instead considered void
62my %void = (
63  void     => 1,
64  Free_t   => 1,
65  Signal_t => 1,
66);
67
68# khw doesn't know why these exist.  These have an explicit (void) cast added.
69# Undef'ing this hash made no difference.  Maybe it's for older compilers?
70my %castvoid = (
71  map { ($_ => 1) } qw(
72    G_ARRAY
73    G_DISCARD
74    G_EVAL
75    G_NOARGS
76    G_SCALAR
77    G_VOID
78    HEf_SVKEY
79    MARK
80    Nullav
81    Nullch
82    Nullcv
83    Nullhv
84    Nullsv
85    SP
86    SVt_IV
87    SVt_NV
88    SVt_PV
89    SVt_PVAV
90    SVt_PVCV
91    SVt_PVHV
92    SVt_PVMG
93    SvUOK
94    XS_VERSION
95  ),
96);
97
98# Ignore the return value of these
99my %ignorerv = (
100  map { ($_ => 1) } qw(
101    newCONSTSUB
102  ),
103);
104
105my @simple_my_cxt_prereqs = ( 'typedef struct { int count; } my_cxt_t;', 'START_MY_CXT;' );
106my @my_cxt_prereqs = ( @simple_my_cxt_prereqs, 'MY_CXT_INIT;' );
107
108# The value of each key is a list of things that need to be declared in order
109# for the key to compile.
110my %stack = (
111  MULTICALL      => ['dMULTICALL;'],
112  ORIGMARK       => ['dORIGMARK;'],
113  POP_MULTICALL  => ['dMULTICALL;', 'U8 gimme;' ],
114  PUSH_MULTICALL => ['dMULTICALL;', 'U8 gimme;' ],
115  POPpbytex      => ['STRLEN n_a;'],
116  POPpx          => ['STRLEN n_a;'],
117  PUSHi          => ['dTARG;'],
118  PUSHn          => ['dTARG;'],
119  PUSHp          => ['dTARG;'],
120  PUSHu          => ['dTARG;'],
121  RESTORE_LC_NUMERIC => ['DECLARATION_FOR_LC_NUMERIC_MANIPULATION;'],
122  STORE_LC_NUMERIC_FORCE_TO_UNDERLYING => ['DECLARATION_FOR_LC_NUMERIC_MANIPULATION;'],
123  STORE_LC_NUMERIC_SET_TO_NEEDED => ['DECLARATION_FOR_LC_NUMERIC_MANIPULATION;'],
124  STORE_LC_NUMERIC_SET_TO_NEEDED_IN => ['DECLARATION_FOR_LC_NUMERIC_MANIPULATION;'],
125  TARG           => ['dTARG;'],
126  UNDERBAR       => ['dUNDERBAR;'],
127  XCPT_CATCH     => ['dXCPT;'],
128  XCPT_RETHROW   => ['dXCPT;'],
129  XCPT_TRY_END   => ['dXCPT;'],
130  XCPT_TRY_START => ['dXCPT;'],
131  XPUSHi         => ['dTARG;'],
132  XPUSHn         => ['dTARG;'],
133  XPUSHp         => ['dTARG;'],
134  XPUSHu         => ['dTARG;'],
135  XS_APIVERSION_BOOTCHECK => ['CV * cv;'],
136  XS_VERSION_BOOTCHECK => ['CV * cv;'],
137  MY_CXT_INIT  => [ @simple_my_cxt_prereqs ],
138  MY_CXT_CLONE => [ @simple_my_cxt_prereqs ],
139  dMY_CXT      => [ @simple_my_cxt_prereqs ],
140  MY_CXT       => [ @my_cxt_prereqs ],
141  _aMY_CXT     => [ @my_cxt_prereqs ],
142   aMY_CXT     => [ @my_cxt_prereqs ],
143   aMY_CXT_    => [ @my_cxt_prereqs ],
144   pMY_CXT     => [ @my_cxt_prereqs ],
145);
146
147# The entries in %ignore have two components, separated by this.
148my $sep = '~';
149
150# Things to not try to check.  (The component after $sep is empty.)
151my %ignore = map { ("$_$sep" => 1) } keys %{&known_but_hard_to_test_for()};
152
153print OUT <<HEAD;
154/*
155 * !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
156 * This file is built by $0.
157 * Any changes made here will be lost!
158 */
159
160#include "EXTERN.h"
161#include "perl.h"
162HEAD
163
164# These may not have gotten #included, and don't exist in all versions
165my $hdr;
166for $hdr (qw(time64 perliol malloc_ctl perl_inc_macro patchlevel)) {
167    my $dir;
168    for $dir (@INC) {
169        if (-e "$dir/CORE/$hdr.h") {
170            print OUT "#include \"$hdr.h\"\n";
171            last;
172        }
173    }
174}
175
176print OUT <<HEAD;
177
178#define NO_XSLOCKS
179#include "XSUB.h"
180
181#ifdef DPPP_APICHECK_NO_PPPORT_H
182
183/* This is just to avoid too many baseline failures with perls < 5.6.0 */
184
185#ifndef dTHX
186#  define dTHX extern int Perl___notused
187#endif
188
189#else
190
191$ENV{'DPPP_NEED'}    /* All the requisite NEED_foo #defines */
192
193#include "ppport.h"
194
195#endif
196
197static int    VARarg1;
198static char  *VARarg2;
199static double VARarg3;
200
201#if defined(PERL_BCDVERSION) && (PERL_BCDVERSION < 0x5009005)
202/* needed to make PL_parser apicheck work */
203typedef void yy_parser;
204#endif
205
206/* Handle both 5.x.y and 7.x.y and up */
207#ifndef PERL_VERSION_MAJOR
208#  define PERL_VERSION_MAJOR PERL_REVISION
209#endif
210#ifndef PERL_VERSION_MINOR
211#  define PERL_VERSION_MINOR PERL_VERSION
212#endif
213#ifndef PERL_VERSION_PATCH
214#  define PERL_VERSION_PATCH PERL_SUBVERSION
215#endif
216
217/* This causes some functions to compile that otherwise wouldn't, so we can
218 * get their info; and doesn't seem to harm anything */
219#define PERL_IMPLICIT_CONTEXT
220
221HEAD
222
223# Caller can restrict what functions tests are generated for
224if (@ARGV) {
225  my %want = map { ($_ => 0) } @ARGV;
226  @f = grep { exists $want{$_->{'name'}} } @f;
227  for (@f) { $want{$_->{'name'}}++ }
228  for (keys %want) {
229    die "nothing found for '$_'\n" unless $want{$_};
230  }
231}
232
233my $f;
234my %name_counts;
235
236# Loop through all the tests to add
237for $f (sort { dictionary_order($a->{'name'}, $b->{'name'}) } @f) {
238
239    my $short_form = $f->{'name'};
240
241    # Ignore duplicates; just the name isn't unique;  We also need the #if or
242    # #else condition
243    my $cond = $f->{'cond'};
244    $ignore{"$short_form$sep$cond"}++ and next;
245
246  # only public API members, except those in ppport.fnc are there because we
247  # want them to be tested even if non-public.  X,M functions are supposed to
248  # be considered to have just the macro form public (but not if restricted by
249  # 'E').
250      $f->{'flags'}{'A'}
251  or  $f->{'ppport_fnc'}
252  or ($f->{'flags'}{'X'} and $f->{'flags'}{'M'} and ! $f->{'flags'}{'E'} )
253  or next;
254
255  # Don't test unorthodox things that we aren't set up to do
256  $f->{'flags'}{'u'} and next;
257  $f->{'flags'}{'y'} and next;
258
259    my $nflag = $f->{'flags'}{'n'};
260    $nflag = 0 unless defined $nflag;
261    my $pflag = $f->{'flags'}{'p'};
262    $pflag = 0 unless defined $pflag;
263    my $Tflag = $f->{'flags'}{'T'};
264    $Tflag = 0 unless defined $Tflag;
265
266    die 'M flag without p makes no sense' if $f->{'flags'}{'M'} && ! $pflag;
267
268    my $long_form_required = $f->{'flags'}{'o'} || $f->{'flags'}{'f'};
269
270  my $stack = '';
271  my @arg;
272  my $aTHX = '';
273
274    my $i = 1;  # Argument number
275  my $ca;
276  my $varargs = 0;
277
278    # Loop through the function's args, building up the declarations
279    for $ca (@{$f->{'args'}}) {
280    my $a = $ca->[0];           # 1th is the name, 0th is its type
281    if ($a eq '...') {
282      $varargs = 1;
283      push @arg, qw(VARarg1 VARarg2 VARarg3);
284      last;
285    }
286
287        # Split this argument into its components.  The formal parameter name is
288        # discarded; we're just interested in the type and its modifiers
289    my($t, $p, $d) = $a =~ /^ (  (?: " [^"]* " )      # literal string type => $t
290                               | (?: \w+ (?: \s+ \w+ )* )    # name of type => $t
291                              )
292                              \s*
293                              ( \** )                 # optional pointer(s) => $p
294                              (?: \s* \b const \b \s* )? # opt. const
295                              ( (?: \[ [^\]]* \] )* )    # opt. dimension(s)=> $d
296                            $/x
297                     or die "$0 - cannot parse argument: [$a] in $short_form\n";
298
299        # Replace a special argument type by something that will compile.
300    if (exists $amap{$t}) {
301            if ($p or $d) {
302                die "$short_form had type '$t', which should have been the"
303                  . " whole type.  Instead '$p' or '$d' was non-empty";
304            }
305      push @arg, $amap{$t};
306      next;
307    }
308
309    # Certain types, like 'void', get remapped.
310    $t = $tmap{$t} || $t;
311
312    if ($t =~ / ^ " [^"]* " $/x) {  # Use the literal string, literally
313      push @arg, $t;
314    }
315    else {
316      my $v = 'arg' . $i++;     # Argument number
317      push @arg, $v;
318      my $no_const_n = $t;      # Get rid of any remaining 'const's
319      $no_const_n =~ s/\bconst\b//g unless $p;
320
321      # Declare this argument
322      $stack .= "  static $no_const_n $p$v$d;\n";
323    }
324  }
325
326  # Declare thread context for functions and macros that might need it.
327  # (Macros often fail to say they don't need it.)
328  unless ($Tflag) {
329    $stack = "  dTHX;\n$stack";     # Harmless to declare even if not needed
330    $aTHX = @arg ? 'aTHX_ ' : 'aTHX';
331  }
332
333    # If this function is on the list of things that need extra declarations,
334    # add them.
335  if ($stack{$short_form}) {
336    my $s = '';
337    for (@{$stack{$short_form}}) {
338      $s .= "  $_\n";
339    }
340    $stack = "$s$stack";
341  }
342
343  my $args = join ', ', @arg;
344  my $prefix = "";
345
346  my $rvt = $f->{'ret'};  # Type of return value
347
348  # Replace generic 'type'
349  $rvt = 'int' if defined $rvt && $rvt eq 'type';
350
351  # Failure to specify a return type in the apidoc line means void
352  $rvt = 'void' unless $rvt;
353
354  # Remove const, as otherwise could declare something that is impossible to
355  # set.
356  $rvt =~ s/\bconst\b//g;
357
358  my $ret;
359  if ($void{$rvt}) {    # Certain return types are instead considered void
360    $ret = $castvoid{$short_form} ? '(void) ' : '';
361  }
362  else {
363    $stack .= "  $rvt rval;\n";
364    $ret = $ignorerv{$short_form} ? '(void) ' : "rval = ";
365  }
366
367  my $THX_prefix = "";
368  my $THX_suffix = "";
369
370  # Add parens to functions that take an argument list, even if empty
371  unless ($nflag) {
372    $THX_suffix = "($aTHX$args)";
373    $args = "($args)";
374  }
375
376  # Single trailing underscore in name means is a comma operator
377  if ($short_form =~ /[^_]_$/) {
378    $THX_suffix .= ' 1';
379    $args .= ' 1';
380  }
381
382  # Single leading underscore in a few names means is a comma operator
383  if ($short_form =~ /^ _[ adp] (?: THX | MY_CXT ) /x) {
384    $THX_prefix = '1 ';
385    $prefix = '1 ';
386  }
387
388    my $tested_fcn = "";
389    $tested_fcn .= 'Perl_' if $pflag && $long_form_required;
390    $tested_fcn .= $short_form;
391
392  print OUT <<HEAD;
393/******************************************************************************
394*
395
396 *  $tested_fcn  $script_args{'--todo-dir'} for testing $script_args{'--todo'}
397*
398******************************************************************************/
399
400HEAD
401
402    my($rev, $ver,$sub);
403
404  # #ifdef out if marked as todo (not known in) this version
405    if (exists $todo{$tested_fcn}) {
406        ($rev, $ver,$sub) = parse_version($todo{$tested_fcn}{'version'});
407    print OUT <<EOT;
408#if       PERL_VERSION_MAJOR > $rev                         \\
409   || (   PERL_VERSION_MAJOR == $rev                        \\
410       && (   PERL_VERSION_MINOR > $ver                     \\
411           || (   PERL_VERSION_MINOR == $ver                \\
412               && PERL_VERSION_PATCH >= $sub))) /* TODO */
413EOT
414  }
415
416  my $final = $varargs
417              ? "$THX_prefix$tested_fcn$THX_suffix"
418              : "$prefix$short_form$args";
419
420    # If there is an '#if' associated with this, add that
421  $cond and print OUT "#if $cond\n";
422
423  # If only to be tested when ppport.h is enabled
424  $f->{'ppport_fnc'} and print OUT "#ifndef DPPP_APICHECK_NO_PPPORT_H\n";
425
426    my $test_name = "DPPP_test_";
427    $test_name .= $name_counts{$tested_fcn}++ . "_" if $cond;
428    $test_name .= $tested_fcn;
429  print OUT <<END;
430void $test_name (void)
431{
432  dXSARGS;
433$stack
434  {
435END
436
437  # If M is a flag here, it means the 'Perl_' form is not for general use, but
438  # the macro (tested above) is.
439  if ($f->{'flags'}{'M'}) {
440      print OUT <<END;
441
442    $ret$prefix$short_form$args;
443  }
444}
445END
446
447  }
448  else {
449    print OUT <<END;
450
451#ifdef $short_form
452    $ret$prefix$short_form$args;
453#endif
454  }
455
456  {
457#ifdef $short_form
458    $ret$final;
459#else
460    $ret$THX_prefix$tested_fcn$THX_suffix;
461#endif
462  }
463}
464END
465
466  }
467
468    $f->{'ppport_fnc'} and print OUT "#endif  /* for ppport_fnc */\n";
469    $cond and print OUT "#endif  /* for conditional compile */\n";
470    print OUT "#endif  /* disabled testing of $tested_fcn before $rev.$ver.$sub */\n"
471                                                    if exists $todo{$tested_fcn};
472  print OUT "\n";
473}
474
475@ARGV and close OUT;
476