2 ################################################################################
4 # apicheck.pl -- generate apicheck.c: C source for automated API check
6 # WARNING: This script will be run on very old perls. You need to not use
7 # modern constructs. See HACKERS file for examples.
9 ################################################################################
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.
15 # This program is free software; you can redistribute it and/or
16 # modify it under the same terms as Perl itself.
18 ################################################################################
21 require './parts/ppptools.pl';
25 open OUT, ">$file" or die "$file: $!\n";
31 # Get list of functions/macros to test
32 my @f = parse_embed(qw( parts/embed.fnc parts/apidoc.fnc parts/ppport.fnc ));
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'
39 # We don't care here about other subkeys
40 my %todo = %{&parse_todo};
42 # We convert these types into these other types
47 # These are for special marker argument names, as mentioned in embed.fnc
55 # Certain return types are instead considered void
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?
92 # Ignore the return value of these
99 # The value of each key is a list of things that need to be declared in order
100 # for the key to compile.
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;'],
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;'],
129 # Things to not try to check. Either not applicable, or too hard to get to
132 map { ($_ => 1) } qw(
152 # XXX The NEED_foo lines should be autogenerated
155 * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
156 * This file is built by $0.
157 * Any changes made here will be lost!
166 #ifdef DPPP_APICHECK_NO_PPPORT_H
168 /* This is just to avoid too many baseline failures with perls < 5.6.0 */
171 # define dTHX extern int Perl___notused
176 #define NEED_PL_parser
177 #define NEED_PL_signals
178 #define NEED_caller_cx
179 #define NEED_croak_xs_usage
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
189 #define NEED_mess_nocontext
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
217 static char *VARarg2;
218 static double VARarg3;
220 #if defined(PERL_BCDVERSION) && (PERL_BCDVERSION < 0x5009005)
221 /* needed to make PL_parser apicheck work */
222 typedef void yy_parser;
227 # Caller can restrict what functions tests are generated for
229 my %want = map { ($_ => 0) } @ARGV;
230 @f = grep { exists $want{$_->{'name'}} } @f;
231 for (@f) { $want{$_->{'name'}}++ }
233 die "nothing found for '$_'\n" unless $want{$_};
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
242 $ignore{$f->{'name'}} = 1; # ignore duplicates
244 my $Perl_ = $f->{'flags'}{'p'} ? 'Perl_' : '';
254 for $ca (@{$f->{'args'}}) { # Loop through the function's args
255 my $a = $ca->[0]; # 1th is the name, 0th is its type
258 push @arg, qw(VARarg1 VARarg2 VARarg3);
262 # Split this type into its components
263 my($n, $p, $d) = $a =~ /^ ( \w+ (?: \s+ \w+ )* ) # type name => $n
265 ( \** ) # optional pointer(s) => $p
266 (?: \s* \b const \b \s* )? # opt. const
267 ( (?: \[ [^\]]* \] )* ) # opt. dimension(s)=> $d
269 or die "$0 - cannot parse argument: [$a]\n";
271 # Replace a special argument name by something that will compile.
272 if (exists $amap{$n}) {
273 push @arg, $amap{$n};
277 # Certain types, like 'void', get remapped.
278 $n = $tmap{$n} || $n;
280 # Use a literal of our choosing for non-format functions
281 if ($n =~ /\bconst\s+char\b/ and $p eq '*' and !$f->{'flags'}{'f'}) {
285 my $v = 'arg' . $i++; # Argument number
287 my $no_const_n = $n; # Get rid of any remaining 'const's
288 $no_const_n =~ s/\bconst\b// unless $p;
290 # Declare this argument
291 $stack .= " static $no_const_n $p$v$d;\n";
295 # Declare thread context for functions and macros that might need it.
296 # (Macros often fail to say they don't need it.)
297 unless ($f->{'flags'}{'T'}) {
298 $stack = " dTHX;\n$stack"; # Harmless to declare even if not needed
299 $aTHX = @arg ? 'aTHX_ ' : 'aTHX';
302 # If this function is on the list of things that need declarations, add
304 if ($stack{$f->{'name'}}) {
306 for (@{$stack{$f->{'name'}}}) {
312 my $args = join ', ', @arg;
314 # Failure to specify a return type in the apidoc line means void
315 my $rvt = $f->{'ret'} || 'void';
318 if ($void{$rvt}) { # Certain return types are instead considered void
319 $ret = $castvoid{$f->{'name'}} ? '(void) ' : '';
322 $stack .= " $rvt rval;\n";
323 $ret = $ignorerv{$f->{'name'}} ? '(void) ' : "rval = ";
328 # Add parens to functions that take an argument list, even if empty
329 unless ($f->{'flags'}{'n'}) {
330 $aTHX_args = "($aTHX$args)";
335 /******************************************************************************
339 ******************************************************************************/
343 # #ifdef out if marked as todo (not known in) this version
344 if ($todo{$f->{'name'}}) {
345 my($ver,$sub) = $todo{$f->{'name'}} =~ /^5\.(\d{3})(\d{2,3})$/ or die;
349 if ($ver < 6 && $sub > 0) {
350 #$sub =~ s/0$// or die;
352 print OUT "#if PERL_VERSION > $ver || (PERL_VERSION == $ver && PERL_SUBVERSION >= $sub) /* TODO */\n";
356 ? "$Perl_$f->{'name'}$aTHX_args"
357 : "$f->{'name'}$args";
359 # If there is a '#if' associated with this, add that
360 $f->{'cond'} and print OUT "#if $f->{'cond'}\n";
363 void _DPPP_test_$f->{'name'} (void)
369 $ret$f->{'name'}$args;
377 $ret$Perl_$f->{'name'}$aTHX_args;
383 $f->{'cond'} and print OUT "#endif\n";
384 $todo{$f->{'name'}} and print OUT "#endif\n";