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 # 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 }
  34 my %script_args = map { split /=/ } split(/\s+/, $ENV{'DPPP_ARGUMENTS'});
  35
  36 # Get list of functions/macros to test
  37 my @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
  45 my %todo = %{&parse_todo($script_args{'--todo-dir'})};
  46
  47 # We convert these types into these other types
  48 my %tmap = (
  49   void => 'int',
  50 );
  51
  52 # These are for special marker argument names, as mentioned in embed.fnc
  53 my %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
  62 my %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?
  70 my %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
  99 my %ignorerv = (
 100   map { ($_ => 1) } qw(
 101     newCONSTSUB
 102   ),
 103 );
 104
 105 my @simple_my_cxt_prereqs = ( 'typedef struct { int count; } my_cxt_t;', 'START_MY_CXT;' );
 106 my @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.
 110 my %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.
 148 my $sep = '~';
 149
 150 # Things to not try to check.  (The component after $sep is empty.)
 151 my %ignore = map { ("$_$sep" => 1) } keys %{&known_but_hard_to_test_for()};
 152
 153 print 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"
 162 HEAD
 163
 164 # These may not have gotten #included, and don't exist in all versions
 165 my $hdr;
 166 for $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
 176 print 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
 197 static int    VARarg1;
 198 static char  *VARarg2;
 199 static double VARarg3;
 200
 201 #if defined(PERL_BCDVERSION) && (PERL_BCDVERSION < 0x5009005)
 202 /* needed to make PL_parser apicheck work */
 203 typedef 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
 221 HEAD
 222
 223 # Caller can restrict what functions tests are generated for
 224 if (@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
 233 my $f;
 234 for $f (@f) {   # Loop through all the tests to add
 235
 236   # Just the name isn't unique;  We also need the #if or #else condition
 237   my $unique = "$f->{'name'}$sep$f->{'cond'}";
 238   $ignore{$unique} and next;
 239
 240   # only public API members, except those in ppport.fnc are there because we
 241   # want them to be tested even if non-public.  X,M functions are supposed to
 242   # be considered to have just the macro form public.
 243       $f->{'flags'}{'A'}
 244   or  $f->{'ppport_fnc'}
 245   or ($f->{'flags'}{'X'} and $f->{'flags'}{'M'})
 246   or next;
 247
 248   # Don't test unorthodox things that we aren't set up to do
 249   $f->{'flags'}{'u'} and next;
 250   $f->{'flags'}{'y'} and next;
 251
 252   $ignore{$unique} = 1; # ignore duplicates
 253
 254   my $Perl_ = $f->{'flags'}{'p'} ? 'Perl_' : '';
 255
 256   my $stack = '';
 257   my @arg;
 258   my $aTHX = '';
 259
 260   my $i = 1;
 261   my $ca;
 262   my $varargs = 0;
 263
 264   for $ca (@{$f->{'args'}}) {   # Loop through the function's args
 265     my $a = $ca->[0];           # 1th is the name, 0th is its type
 266     if ($a eq '...') {
 267       $varargs = 1;
 268       push @arg, qw(VARarg1 VARarg2 VARarg3);
 269       last;
 270     }
 271
 272     # Split this type into its components
 273     my($n, $p, $d) = $a =~ /^ (  (?: " [^"]* " )      # literal string type => $n
 274                                | (?: \w+ (?: \s+ \w+ )* )    # name of type => $n
 275                               )
 276                               \s*
 277                               ( \** )                 # optional pointer(s) => $p
 278                               (?: \s* \b const \b \s* )? # opt. const
 279                               ( (?: \[ [^\]]* \] )* )    # opt. dimension(s)=> $d
 280                             $/x
 281                      or die "$0 - cannot parse argument: [$a] in $f->{'name'}\n";
 282
 283     # Replace a special argument name by something that will compile.
 284     if (exists $amap{$n}) {
 285       die "$f->{'name'} had type $n, which should have been the whole type"
 286                                                                     if $p or $d;
 287       push @arg, $amap{$n};
 288       next;
 289     }
 290
 291     # Certain types, like 'void', get remapped.
 292     $n = $tmap{$n} || $n;
 293
 294     if ($n =~ / ^ " [^"]* " $/x) {  # Use the literal string, literally
 295       push @arg, $n;
 296     }
 297     else {
 298       my $v = 'arg' . $i++;     # Argument number
 299       push @arg, $v;
 300       my $no_const_n = $n;      # Get rid of any remaining 'const's
 301       $no_const_n =~ s/\bconst\b// unless $p;
 302
 303       # Declare this argument
 304       $stack .= "  static $no_const_n $p$v$d;\n";
 305     }
 306   }
 307
 308   # Declare thread context for functions and macros that might need it.
 309   # (Macros often fail to say they don't need it.)
 310   unless ($f->{'flags'}{'T'}) {
 311     $stack = "  dTHX;\n$stack";     # Harmless to declare even if not needed
 312     $aTHX = @arg ? 'aTHX_ ' : 'aTHX';
 313   }
 314
 315   # If this function is on the list of things that need declarations, add
 316   # them.
 317   if ($stack{$f->{'name'}}) {
 318     my $s = '';
 319     for (@{$stack{$f->{'name'}}}) {
 320       $s .= "  $_\n";
 321     }
 322     $stack = "$s$stack";
 323   }
 324
 325   my $args = join ', ', @arg;
 326   my $prefix = "";
 327
 328   my $rvt = $f->{'ret'};
 329
 330   # Replace generic 'type'
 331   $rvt = 'int' if defined $rvt && $rvt eq 'type';
 332
 333   # Failure to specify a return type in the apidoc line means void
 334   $rvt = 'void' unless $rvt;;
 335
 336   my $ret;
 337   if ($void{$rvt}) {    # Certain return types are instead considered void
 338     $ret = $castvoid{$f->{'name'}} ? '(void) ' : '';
 339   }
 340   else {
 341     $stack .= "  $rvt rval;\n";
 342     $ret = $ignorerv{$f->{'name'}} ? '(void) ' : "rval = ";
 343   }
 344
 345   my $THX_prefix = "";
 346   my $THX_suffix = "";
 347
 348   # Add parens to functions that take an argument list, even if empty
 349   unless ($f->{'flags'}{'n'}) {
 350     $THX_suffix = "($aTHX$args)";
 351     $args = "($args)";
 352   }
 353
 354   # Single trailing underscore in name means is a comma operator
 355   if ($f->{'name'} =~ /[^_]_$/) {
 356     $THX_suffix .= ' 1';
 357     $args .= ' 1';
 358   }
 359
 360   # Single leading underscore in a few names means is a comma operator
 361   if ($f->{'name'} =~ /^ _[ adp] (?: THX | MY_CXT ) /x) {
 362     $THX_prefix = '1 ';
 363     $prefix = '1 ';
 364   }
 365
 366
 367   print OUT <<HEAD;
 368 /******************************************************************************
 369 *
 370
 371 *  $f->{'name'}  $script_args{'--todo-dir'}  $script_args{'--todo'}
 372 *
 373 ******************************************************************************/
 374
 375 HEAD
 376
 377   # #ifdef out if marked as todo (not known in) this version
 378   if (exists $todo{$f->{'name'}}) {
 379     my($rev, $ver,$sub) = parse_version($todo{$f->{'name'}}{'version'});
 380     print OUT <<EOT;
 381 #if       PERL_VERSION_MAJOR > $rev                         \\
 382    || (   PERL_VERSION_MAJOR == $rev                        \\
 383        && (   PERL_VERSION_MINOR > $ver                     \\
 384            || (   PERL_VERSION_MINOR == $ver                \\
 385                && PERL_VERSION_PATCH >= $sub))) /* TODO */
 386 EOT
 387   }
 388
 389   my $final = $varargs
 390               ? "$THX_prefix$Perl_$f->{'name'}$THX_suffix"
 391               : "$prefix$f->{'name'}$args";
 392
 393   # If there is a '#if' associated with this, add that
 394   $f->{'cond'} and print OUT "#if $f->{'cond'}\n";
 395
 396   # If only to be tested when ppport.h is enabled
 397   $f->{'ppport_fnc'} and print OUT "#ifndef DPPP_APICHECK_NO_PPPORT_H\n";
 398
 399   print OUT <<END;
 400 void DPPP_test_$f->{'name'} (void)
 401 {
 402   dXSARGS;
 403 $stack
 404   {
 405 END
 406
 407   # If M is a flag here, it means the 'Perl_' form is not for general use, but
 408   # the macro (tested above) is.
 409   if ($f->{'flags'}{'M'}) {
 410       print OUT <<END;
 411
 412     $ret$prefix$f->{'name'}$args;
 413   }
 414 }
 415 END
 416
 417   }
 418   else {
 419     print OUT <<END;
 420
 421 #ifdef $f->{'name'}
 422     $ret$prefix$f->{'name'}$args;
 423 #endif
 424   }
 425
 426   {
 427 #ifdef $f->{'name'}
 428     $ret$final;
 429 #else
 430     $ret$THX_prefix$Perl_$f->{'name'}$THX_suffix;
 431 #endif
 432   }
 433 }
 434 END
 435
 436   }
 437
 438   $f->{'ppport_fnc'} and print OUT "#endif\n";
 439   $f->{'cond'} and print OUT "#endif\n";
 440   exists $todo{$f->{'name'}} and print OUT "#endif\n";
 441
 442   print OUT "\n";
 443 }
 444
 445 @ARGV and close OUT;