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($five, $ver,$sub) = parse_version($todo{$f->{'name'}});
 368     print OUT "#if PERL_VERSION > $ver || (PERL_VERSION == $ver && PERL_SUBVERSION >= $sub) /* TODO */\n";
 369   }
 370
 371   my $final = $varargs
 372               ? "$aTHX_prefix$Perl_$f->{'name'}$aTHX_args"
 373               : "$prefix$f->{'name'}$args";
 374
 375   # If there is a '#if' associated with this, add that
 376   $f->{'cond'} and print OUT "#if $f->{'cond'}\n";
 377
 378   print OUT <<END;
 379 void _DPPP_test_$f->{'name'} (void)
 380 {
 381   dXSARGS;
 382 $stack
 383   {
 384 #ifdef $f->{'name'}
 385     $ret$prefix$f->{'name'}$args;
 386 #endif
 387   }
 388
 389   {
 390 #ifdef $f->{'name'}
 391     $ret$final;
 392 #else
 393     $ret$aTHX_prefix$Perl_$f->{'name'}$aTHX_args;
 394 #endif
 395   }
 396 }
 397 END
 398
 399   $f->{'cond'} and print OUT "#endif\n";
 400   $todo{$f->{'name'}} and print OUT "#endif\n";
 401
 402   print OUT "\n";
 403 }
 404
 405 @ARGV and close OUT;