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