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