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 # The value of each key is a list of things that need to be declared in order
 100 # for the key to compile.
 101 my %stack = (
 102   MULTICALL      => ['dMULTICALL;'],
 103   ORIGMARK       => ['dORIGMARK;'],
 104   POP_MULTICALL  => ['dMULTICALL;', 'U8 gimme;' ],
 105   PUSH_MULTICALL => ['dMULTICALL;', 'U8 gimme;' ],
 106   POPpbytex      => ['STRLEN n_a;'],
 107   POPpx          => ['STRLEN n_a;'],
 108   PUSHi          => ['dTARG;'],
 109   PUSHn          => ['dTARG;'],
 110   PUSHp          => ['dTARG;'],
 111   PUSHu          => ['dTARG;'],
 112   RESTORE_LC_NUMERIC => ['DECLARATION_FOR_LC_NUMERIC_MANIPULATION;'],
 113   STORE_LC_NUMERIC_FORCE_TO_UNDERLYING => ['DECLARATION_FOR_LC_NUMERIC_MANIPULATION;'],
 114   STORE_LC_NUMERIC_SET_TO_NEEDED => ['DECLARATION_FOR_LC_NUMERIC_MANIPULATION;'],
 115   STORE_LC_NUMERIC_SET_TO_NEEDED_IN => ['DECLARATION_FOR_LC_NUMERIC_MANIPULATION;'],
 116   UNDERBAR       => ['dUNDERBAR;'],
 117   XCPT_CATCH     => ['dXCPT;'],
 118   XCPT_RETHROW   => ['dXCPT;'],
 119   XCPT_TRY_END   => ['dXCPT;'],
 120   XCPT_TRY_START => ['dXCPT;'],
 121   XPUSHi         => ['dTARG;'],
 122   XPUSHn         => ['dTARG;'],
 123   XPUSHp         => ['dTARG;'],
 124   XPUSHu         => ['dTARG;'],
 125   XS_APIVERSION_BOOTCHECK => ['CV * cv;'],
 126   XS_VERSION_BOOTCHECK => ['CV * cv;'],
 127 );
 128
 129 # Things to not try to check.  Either not applicable, or too hard to get to
 130 # work here.
 131 my %ignore = (
 132   map { ($_ => 1) } qw(
 133     CLASS
 134     dXSI32
 135     items
 136     ix
 137     RETVAL
 138     StructCopy
 139     svtype
 140     THIS
 141     XopDISABLE
 142     XopENABLE
 143     XopENTRY
 144     XopENTRYCUSTOM
 145     XopENTRY_set
 146     XS
 147     XS_EXTERNAL
 148     XS_INTERNAL
 149   ),
 150 );
 151
 152 # XXX The NEED_foo lines should be autogenerated
 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
 163 #define NO_XSLOCKS
 164 #include "XSUB.h"
 165
 166 #ifdef DPPP_APICHECK_NO_PPPORT_H
 167
 168 /* This is just to avoid too many baseline failures with perls < 5.6.0 */
 169
 170 #ifndef dTHX
 171 #  define dTHX extern int Perl___notused
 172 #endif
 173
 174 #else
 175
 176 #define NEED_PL_parser
 177 #define NEED_PL_signals
 178 #define NEED_caller_cx
 179 #define NEED_croak_xs_usage
 180 #define NEED_die_sv
 181 #define NEED_eval_pv
 182 #define NEED_grok_bin
 183 #define NEED_grok_hex
 184 #define NEED_grok_number
 185 #define NEED_grok_numeric_radix
 186 #define NEED_grok_oct
 187 #define NEED_load_module
 188 #define NEED_mess
 189 #define NEED_mess_nocontext
 190 #define NEED_mess_sv
 191 #define NEED_mg_findext
 192 #define NEED_my_snprintf
 193 #define NEED_my_sprintf
 194 #define NEED_my_strlcat
 195 #define NEED_my_strlcpy
 196 #define NEED_my_strnlen
 197 #define NEED_newCONSTSUB
 198 #define NEED_newSVpvn_share
 199 #define NEED_pv_display
 200 #define NEED_pv_escape
 201 #define NEED_pv_pretty
 202 #define NEED_sv_catpvf_mg
 203 #define NEED_sv_catpvf_mg_nocontext
 204 #define NEED_sv_setpvf_mg
 205 #define NEED_sv_setpvf_mg_nocontext
 206 #define NEED_sv_unmagicext
 207 #define NEED_utf8_to_uvchr_buf
 208 #define NEED_vload_module
 209 #define NEED_vmess
 210 #define NEED_warner
 211
 212 #include "ppport.h"
 213
 214 #endif
 215
 216 static int    VARarg1;
 217 static char  *VARarg2;
 218 static double VARarg3;
 219
 220 #if defined(PERL_BCDVERSION) && (PERL_BCDVERSION < 0x5009005)
 221 /* needed to make PL_parser apicheck work */
 222 typedef void yy_parser;
 223 #endif
 224
 225 HEAD
 226
 227 # Caller can restrict what functions tests are generated for
 228 if (@ARGV) {
 229   my %want = map { ($_ => 0) } @ARGV;
 230   @f = grep { exists $want{$_->{'name'}} } @f;
 231   for (@f) { $want{$_->{'name'}}++ }
 232   for (keys %want) {
 233     die "nothing found for '$_'\n" unless $want{$_};
 234   }
 235 }
 236
 237 my $f;
 238 for $f (@f) {   # Loop through all the tests to add
 239   $ignore{$f->{'name'}} and next;
 240   $f->{'flags'}{'A'} or next;  # only public API members
 241
 242   $ignore{$f->{'name'}} = 1; # ignore duplicates
 243
 244   my $Perl_ = $f->{'flags'}{'p'} ? 'Perl_' : '';
 245
 246   my $stack = '';
 247   my @arg;
 248   my $aTHX = '';
 249
 250   my $i = 1;
 251   my $ca;
 252   my $varargs = 0;
 253
 254   for $ca (@{$f->{'args'}}) {   # Loop through the function's args
 255     my $a = $ca->[0];           # 1th is the name, 0th is its type
 256     if ($a eq '...') {
 257       $varargs = 1;
 258       push @arg, qw(VARarg1 VARarg2 VARarg3);
 259       last;
 260     }
 261
 262     # Split this type into its components
 263     my($n, $p, $d) = $a =~ /^ ( \w+ (?: \s+ \w+ )* )     # type name  => $n
 264                               \s*
 265                               ( \** )                 # optional pointer(s) => $p
 266                               (?: \s* \b const \b \s* )? # opt. const
 267                               ( (?: \[ [^\]]* \] )* )    # opt. dimension(s)=> $d
 268                             $/x
 269                      or die "$0 - cannot parse argument: [$a] in $f->{'name'}\n";
 270
 271     # Replace a special argument name by something that will compile.
 272     if (exists $amap{$n}) {
 273       die "$f->{'name'} had type $n, which should have been the whole type"
 274                                                                     if $p or $d;
 275       push @arg, $amap{$n};
 276       next;
 277     }
 278
 279     # Certain types, like 'void', get remapped.
 280     $n = $tmap{$n} || $n;
 281
 282     # Use a literal of our choosing for non-format functions
 283     if ($n =~ /\bconst\s+char\b/ and $p eq '*' and !$f->{'flags'}{'f'}) {
 284       push @arg, '"foo"';
 285     }
 286     else {
 287       my $v = 'arg' . $i++;     # Argument number
 288       push @arg, $v;
 289       my $no_const_n = $n;      # Get rid of any remaining 'const's
 290       $no_const_n =~ s/\bconst\b// unless $p;
 291
 292       # Declare this argument
 293       $stack .= "  static $no_const_n $p$v$d;\n";
 294     }
 295   }
 296
 297   # Declare thread context for functions and macros that might need it.
 298   # (Macros often fail to say they don't need it.)
 299   unless ($f->{'flags'}{'T'}) {
 300     $stack = "  dTHX;\n$stack";     # Harmless to declare even if not needed
 301     $aTHX = @arg ? 'aTHX_ ' : 'aTHX';
 302   }
 303
 304   # If this function is on the list of things that need declarations, add
 305   # them.
 306   if ($stack{$f->{'name'}}) {
 307     my $s = '';
 308     for (@{$stack{$f->{'name'}}}) {
 309       $s .= "  $_\n";
 310     }
 311     $stack = "$s$stack";
 312   }
 313
 314   my $args = join ', ', @arg;
 315
 316   # Failure to specify a return type in the apidoc line means void
 317   my $rvt = $f->{'ret'} || 'void';
 318
 319   my $ret;
 320   if ($void{$rvt}) {    # Certain return types are instead considered void
 321     $ret = $castvoid{$f->{'name'}} ? '(void) ' : '';
 322   }
 323   else {
 324     $stack .= "  $rvt rval;\n";
 325     $ret = $ignorerv{$f->{'name'}} ? '(void) ' : "rval = ";
 326   }
 327
 328   my $aTHX_args = "";
 329
 330   # Add parens to functions that take an argument list, even if empty
 331   unless ($f->{'flags'}{'n'}) {
 332     $aTHX_args = "($aTHX$args)";
 333     $args = "($args)";
 334   }
 335
 336   print OUT <<HEAD;
 337 /******************************************************************************
 338 *
 339 *  $f->{'name'}
 340 *
 341 ******************************************************************************/
 342
 343 HEAD
 344
 345   # #ifdef out if marked as todo (not known in) this version
 346   if ($todo{$f->{'name'}}) {
 347     my($ver,$sub) = $todo{$f->{'name'}} =~ /^5\.(\d{3})(\d{2,3})$/ or die;
 348     for ($ver, $sub) {
 349       s/^0+(\d)/$1/
 350     }
 351     if ($ver < 6 && $sub > 0) {
 352       #$sub =~ s/0$// or die;
 353     }
 354     print OUT "#if PERL_VERSION > $ver || (PERL_VERSION == $ver && PERL_SUBVERSION >= $sub) /* TODO */\n";
 355   }
 356
 357   my $final = $varargs
 358               ? "$Perl_$f->{'name'}$aTHX_args"
 359               : "$f->{'name'}$args";
 360
 361   # If there is a '#if' associated with this, add that
 362   $f->{'cond'} and print OUT "#if $f->{'cond'}\n";
 363
 364   print OUT <<END;
 365 void _DPPP_test_$f->{'name'} (void)
 366 {
 367   dXSARGS;
 368 $stack
 369   {
 370 #ifdef $f->{'name'}
 371     $ret$f->{'name'}$args;
 372 #endif
 373   }
 374
 375   {
 376 #ifdef $f->{'name'}
 377     $ret$final;
 378 #else
 379     $ret$Perl_$f->{'name'}$aTHX_args;
 380 #endif
 381   }
 382 }
 383 END
 384
 385   $f->{'cond'} and print OUT "#endif\n";
 386   $todo{$f->{'name'}} and print OUT "#endif\n";
 387
 388   print OUT "\n";
 389 }
 390
 391 @ARGV and close OUT;