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