cpan/Devel-PPPort/parts/apicheck.pl

   1 #!/usr/bin/perl -w
   2 ################################################################################
   3 #
   4 #  apicheck.pl -- generate C source for automated API check
   5 #
   6 ################################################################################
   7 #
   8 #  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
   9 #  Version 2.x, Copyright (C) 2001, Paul Marquess.
  10 #  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
  11 #
  12 #  This program is free software; you can redistribute it and/or
  13 #  modify it under the same terms as Perl itself.
  14 #
  15 ################################################################################
  16
  17 use strict;
  18 require './parts/ppptools.pl';
  19
  20 if (@ARGV) {
  21   my $file = pop @ARGV;
  22   open OUT, ">$file" or die "$file: $!\n";
  23 }
  24 else {
  25   *OUT = \*STDOUT;
  26 }
  27
  28 my @f = parse_embed(qw( parts/embed.fnc parts/apidoc.fnc parts/ppport.fnc ));
  29
  30 my %todo = %{&parse_todo};
  31
  32 my %tmap = (
  33   void => 'int',
  34 );
  35
  36 my %amap = (
  37   SP   => 'SP',
  38   type => 'int',
  39   cast => 'int',
  40 );
  41
  42 my %void = (
  43   void     => 1,
  44   Free_t   => 1,
  45   Signal_t => 1,
  46 );
  47
  48 my %castvoid = (
  49   map { ($_ => 1) } qw(
  50     Nullav
  51     Nullcv
  52     Nullhv
  53     Nullch
  54     Nullsv
  55     HEf_SVKEY
  56     SP
  57     MARK
  58     SVt_PV
  59     SVt_IV
  60     SVt_NV
  61     SVt_PVMG
  62     SVt_PVAV
  63     SVt_PVHV
  64     SVt_PVCV
  65     SvUOK
  66     G_SCALAR
  67     G_ARRAY
  68     G_VOID
  69     G_DISCARD
  70     G_EVAL
  71     G_NOARGS
  72     XS_VERSION
  73   ),
  74 );
  75
  76 my %ignorerv = (
  77   map { ($_ => 1) } qw(
  78     newCONSTSUB
  79   ),
  80 );
  81
  82 my %stack = (
  83   ORIGMARK       => ['dORIGMARK;'],
  84   POPpx          => ['STRLEN n_a;'],
  85   POPpbytex      => ['STRLEN n_a;'],
  86   PUSHp          => ['dTARG;'],
  87   PUSHn          => ['dTARG;'],
  88   PUSHi          => ['dTARG;'],
  89   PUSHu          => ['dTARG;'],
  90   XPUSHp         => ['dTARG;'],
  91   XPUSHn         => ['dTARG;'],
  92   XPUSHi         => ['dTARG;'],
  93   XPUSHu         => ['dTARG;'],
  94   UNDERBAR       => ['dUNDERBAR;'],
  95   XCPT_TRY_START => ['dXCPT;'],
  96   XCPT_TRY_END   => ['dXCPT;'],
  97   XCPT_CATCH     => ['dXCPT;'],
  98   XCPT_RETHROW   => ['dXCPT;'],
  99 );
 100
 101 my %ignore = (
 102   map { ($_ => 1) } qw(
 103     svtype
 104     items
 105     ix
 106     dXSI32
 107     XS
 108     CLASS
 109     THIS
 110     RETVAL
 111     StructCopy
 112   ),
 113 );
 114
 115 print OUT <<HEAD;
 116 /*
 117  * !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 118  * This file is built by $0.
 119  * Any changes made here will be lost!
 120  */
 121
 122 #include "EXTERN.h"
 123 #include "perl.h"
 124
 125 #define NO_XSLOCKS
 126 #include "XSUB.h"
 127
 128 #ifdef DPPP_APICHECK_NO_PPPORT_H
 129
 130 /* This is just to avoid too many baseline failures with perls < 5.6.0 */
 131
 132 #ifndef dTHX
 133 #  define dTHX extern int Perl___notused
 134 #endif
 135
 136 #else
 137
 138 #define NEED_PL_signals
 139 #define NEED_PL_parser
 140 #define NEED_caller_cx
 141 #define NEED_eval_pv
 142 #define NEED_grok_bin
 143 #define NEED_grok_hex
 144 #define NEED_grok_number
 145 #define NEED_grok_numeric_radix
 146 #define NEED_grok_oct
 147 #define NEED_gv_fetchpvn_flags
 148 #define NEED_load_module
 149 #define NEED_mg_findext
 150 #define NEED_my_snprintf
 151 #define NEED_my_sprintf
 152 #define NEED_my_strlcat
 153 #define NEED_my_strlcpy
 154 #define NEED_newCONSTSUB
 155 #define NEED_newRV_noinc
 156 #define NEED_newSV_type
 157 #define NEED_newSVpvn_flags
 158 #define NEED_newSVpvn_share
 159 #define NEED_pv_display
 160 #define NEED_pv_escape
 161 #define NEED_pv_pretty
 162 #define NEED_sv_2pv_flags
 163 #define NEED_sv_2pvbyte
 164 #define NEED_sv_catpvf_mg
 165 #define NEED_sv_catpvf_mg_nocontext
 166 #define NEED_sv_pvn_force_flags
 167 #define NEED_sv_setpvf_mg
 168 #define NEED_sv_setpvf_mg_nocontext
 169 #define NEED_sv_unmagicext
 170 #define NEED_SvRX
 171 #define NEED_vload_module
 172 #define NEED_vnewSVpvf
 173 #define NEED_warner
 174
 175 #include "ppport.h"
 176
 177 #endif
 178
 179 static int    VARarg1;
 180 static char  *VARarg2;
 181 static double VARarg3;
 182
 183 #if defined(PERL_BCDVERSION) && (PERL_BCDVERSION < 0x5009005)
 184 /* needed to make PL_parser apicheck work */
 185 typedef void yy_parser;
 186 #endif
 187
 188 HEAD
 189
 190 if (@ARGV) {
 191   my %want = map { ($_ => 0) } @ARGV;
 192   @f = grep { exists $want{$_->{name}} } @f;
 193   for (@f) { $want{$_->{name}}++ }
 194   for (keys %want) {
 195     die "nothing found for '$_'\n" unless $want{$_};
 196   }
 197 }
 198
 199 my $f;
 200 for $f (@f) {
 201   $ignore{$f->{name}} and next;
 202   $f->{flags}{A} or next;  # only public API members
 203
 204   $ignore{$f->{name}} = 1; # ignore duplicates
 205
 206   my $Perl_ = $f->{flags}{p} ? 'Perl_' : '';
 207
 208   my $stack = '';
 209   my @arg;
 210   my $aTHX = '';
 211
 212   my $i = 1;
 213   my $ca;
 214   my $varargs = 0;
 215   for $ca (@{$f->{args}}) {
 216     my $a = $ca->[0];
 217     if ($a eq '...') {
 218       $varargs = 1;
 219       push @arg, qw(VARarg1 VARarg2 VARarg3);
 220       last;
 221     }
 222     my($n, $p, $d) = $a =~ /^ (\w+(?:\s+\w+)*)\s*  # type name  => $n
 223                               (\**)                # pointer    => $p
 224                               (?:\s*const\s*)?     # const
 225                               ((?:\[[^\]]*\])*)    # dimension  => $d
 226                             $/x
 227                      or die "$0 - cannot parse argument: [$a]\n";
 228     if (exists $amap{$n}) {
 229       push @arg, $amap{$n};
 230       next;
 231     }
 232     $n = $tmap{$n} || $n;
 233     if ($n eq 'const char' and $p eq '*' and !$f->{flags}{f}) {
 234       push @arg, '"foo"';
 235     }
 236     else {
 237       my $v = 'arg' . $i++;
 238       push @arg, $v;
 239       $stack .= "  static $n $p$v$d;\n";
 240     }
 241   }
 242
 243   unless ($f->{flags}{n} || $f->{flags}{'m'}) {
 244     $stack = "  dTHX;\n$stack";
 245     $aTHX = @arg ? 'aTHX_ ' : 'aTHX';
 246   }
 247
 248   if ($stack{$f->{name}}) {
 249     my $s = '';
 250     for (@{$stack{$f->{name}}}) {
 251       $s .= "  $_\n";
 252     }
 253     $stack = "$s$stack";
 254   }
 255
 256   my $args = join ', ', @arg;
 257   my $rvt = $f->{ret} || 'void';
 258   my $ret;
 259   if ($void{$rvt}) {
 260     $ret = $castvoid{$f->{name}} ? '(void) ' : '';
 261   }
 262   else {
 263     $stack .= "  $rvt rval;\n";
 264     $ret = $ignorerv{$f->{name}} ? '(void) ' : "rval = ";
 265   }
 266   my $aTHX_args = "$aTHX$args";
 267
 268   if (!$f->{flags}{'m'} or $f->{flags}{'b'} or @arg > 0) {
 269     $args = "($args)";
 270     $aTHX_args = "($aTHX_args)";
 271   }
 272
 273   print OUT <<HEAD;
 274 /******************************************************************************
 275 *
 276 *  $f->{name}
 277 *
 278 ******************************************************************************/
 279
 280 HEAD
 281
 282   if ($todo{$f->{name}}) {
 283     my($ver,$sub) = $todo{$f->{name}} =~ /^5\.(\d{3})(\d{3})$/ or die;
 284     for ($ver, $sub) {
 285       s/^0+(\d)/$1/
 286     }
 287     if ($ver < 6 && $sub > 0) {
 288       $sub =~ s/0$// or die;
 289     }
 290     print OUT "#if PERL_VERSION > $ver || (PERL_VERSION == $ver && PERL_SUBVERSION >= $sub) /* TODO */\n";
 291   }
 292
 293   my $final = $varargs
 294               ? "$Perl_$f->{name}$aTHX_args"
 295               : "$f->{name}$args";
 296
 297   $f->{cond} and print OUT "#if $f->{cond}\n";
 298
 299   print OUT <<END;
 300 void _DPPP_test_$f->{name} (void)
 301 {
 302   dXSARGS;
 303 $stack
 304   {
 305 #ifdef $f->{name}
 306     $ret$f->{name}$args;
 307 #endif
 308   }
 309
 310   {
 311 #ifdef $f->{name}
 312     $ret$final;
 313 #else
 314     $ret$Perl_$f->{name}$aTHX_args;
 315 #endif
 316   }
 317 }
 318 END
 319
 320   $f->{cond} and print OUT "#endif\n";
 321   $todo{$f->{name}} and print OUT "#endif\n";
 322
 323   print OUT "\n";
 324 }
 325
 326 @ARGV and close OUT;