#!/usr/bin/perl -w
################################################################################
#
# apicheck.pl -- generate C source for automated API check
#
################################################################################
#
# $Revision: 37 $
# $Author: mhx $
# $Date: 2010/03/07 13:15:43 +0100 $
#
################################################################################
#
# Version 3.x, Copyright (C) 2004-2010, Marcus Holland-Moritz.
# Version 2.x, Copyright (C) 2001, Paul Marquess.
# Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
#
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
################################################################################
use strict;
require 'parts/ppptools.pl';
if (@ARGV) {
my $file = pop @ARGV;
open OUT, ">$file" or die "$file: $!\n";
}
else {
*OUT = \*STDOUT;
}
my @f = parse_embed(qw( parts/embed.fnc parts/apidoc.fnc parts/ppport.fnc ));
my %todo = %{&parse_todo};
my %tmap = (
void => 'int',
);
my %amap = (
SP => 'SP',
type => 'int',
cast => 'int',
);
my %void = (
void => 1,
Free_t => 1,
Signal_t => 1,
);
my %castvoid = (
map { ($_ => 1) } qw(
Nullav
Nullcv
Nullhv
Nullch
Nullsv
HEf_SVKEY
SP
MARK
SVt_PV
SVt_IV
SVt_NV
SVt_PVMG
SVt_PVAV
SVt_PVHV
SVt_PVCV
SvUOK
G_SCALAR
G_ARRAY
G_VOID
G_DISCARD
G_EVAL
G_NOARGS
XS_VERSION
),
);
my %ignorerv = (
map { ($_ => 1) } qw(
newCONSTSUB
),
);
my %stack = (
ORIGMARK => ['dORIGMARK;'],
POPpx => ['STRLEN n_a;'],
POPpbytex => ['STRLEN n_a;'],
PUSHp => ['dTARG;'],
PUSHn => ['dTARG;'],
PUSHi => ['dTARG;'],
PUSHu => ['dTARG;'],
XPUSHp => ['dTARG;'],
XPUSHn => ['dTARG;'],
XPUSHi => ['dTARG;'],
XPUSHu => ['dTARG;'],
UNDERBAR => ['dUNDERBAR;'],
XCPT_TRY_START => ['dXCPT;'],
XCPT_TRY_END => ['dXCPT;'],
XCPT_CATCH => ['dXCPT;'],
XCPT_RETHROW => ['dXCPT;'],
);
my %ignore = (
map { ($_ => 1) } qw(
svtype
items
ix
dXSI32
XS
CLASS
THIS
RETVAL
StructCopy
),
);
print OUT <<HEAD;
/*
* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
* This file is built by $0.
* Any changes made here will be lost!
*/
#include "EXTERN.h"
#include "perl.h"
#define NO_XSLOCKS
#include "XSUB.h"
#ifdef DPPP_APICHECK_NO_PPPORT_H
/* This is just to avoid too many baseline failures with perls < 5.6.0 */
#ifndef dTHX
# define dTHX extern int Perl___notused
#endif
#else
#define NEED_PL_signals
#define NEED_PL_parser
#define NEED_eval_pv
#define NEED_grok_bin
#define NEED_grok_hex
#define NEED_grok_number
#define NEED_grok_numeric_radix
#define NEED_grok_oct
#define NEED_load_module
#define NEED_my_snprintf
#define NEED_my_sprintf
#define NEED_my_strlcat
#define NEED_my_strlcpy
#define NEED_newCONSTSUB
#define NEED_newRV_noinc
#define NEED_newSV_type
#define NEED_newSVpvn_share
#define NEED_pv_display
#define NEED_pv_escape
#define NEED_pv_pretty
#define NEED_sv_2pv_flags
#define NEED_sv_2pvbyte
#define NEED_sv_catpvf_mg
#define NEED_sv_catpvf_mg_nocontext
#define NEED_sv_pvn_force_flags
#define NEED_sv_setpvf_mg
#define NEED_sv_setpvf_mg_nocontext
#define NEED_vload_module
#define NEED_vnewSVpvf
#define NEED_warner
#define NEED_newSVpvn_flags
#include "ppport.h"
#endif
static int VARarg1;
static char *VARarg2;
static double VARarg3;
HEAD
if (@ARGV) {
my %want = map { ($_ => 0) } @ARGV;
@f = grep { exists $want{$_->{name}} } @f;
for (@f) { $want{$_->{name}}++ }
for (keys %want) {
die "nothing found for '$_'\n" unless $want{$_};
}
}
my $f;
for $f (@f) {
$ignore{$f->{name}} and next;
$f->{flags}{A} or next; # only public API members
$ignore{$f->{name}} = 1; # ignore duplicates
my $Perl_ = $f->{flags}{p} ? 'Perl_' : '';
my $stack = '';
my @arg;
my $aTHX = '';
my $i = 1;
my $ca;
my $varargs = 0;
for $ca (@{$f->{args}}) {
my $a = $ca->[0];
if ($a eq '...') {
$varargs = 1;
push @arg, qw(VARarg1 VARarg2 VARarg3);
last;
}
my($n, $p, $d) = $a =~ /^ (\w+(?:\s+\w+)*)\s* # type name => $n
(\**) # pointer => $p
(?:\s*const\s*)? # const
((?:\[[^\]]*\])*) # dimension => $d
$/x
or die "$0 - cannot parse argument: [$a]\n";
if (exists $amap{$n}) {
push @arg, $amap{$n};
next;
}
$n = $tmap{$n} || $n;
if ($n eq 'const char' and $p eq '*' and !$f->{flags}{f}) {
push @arg, '"foo"';
}
else {
my $v = 'arg' . $i++;
push @arg, $v;
$stack .= " static $n $p$v$d;\n";
}
}
unless ($f->{flags}{n} || $f->{flags}{'m'}) {
$stack = " dTHX;\n$stack";
$aTHX = @arg ? 'aTHX_ ' : 'aTHX';
}
if ($stack{$f->{name}}) {
my $s = '';
for (@{$stack{$f->{name}}}) {
$s .= " $_\n";
}
$stack = "$s$stack";
}
my $args = join ', ', @arg;
my $rvt = $f->{ret} || 'void';
my $ret;
if ($void{$rvt}) {
$ret = $castvoid{$f->{name}} ? '(void) ' : '';
}
else {
$stack .= " $rvt rval;\n";
$ret = $ignorerv{$f->{name}} ? '(void) ' : "rval = ";
}
my $aTHX_args = "$aTHX$args";
if (!$f->{flags}{'m'} or $f->{flags}{'b'} or @arg > 0) {
$args = "($args)";
$aTHX_args = "($aTHX_args)";
}
print OUT <<HEAD;
/******************************************************************************
*
* $f->{name}
*
******************************************************************************/
HEAD
if ($todo{$f->{name}}) {
my($ver,$sub) = $todo{$f->{name}} =~ /^5\.(\d{3})(\d{3})$/ or die;
for ($ver, $sub) {
s/^0+(\d)/$1/
}
if ($ver < 6 && $sub > 0) {
$sub =~ s/0$// or die;
}
print OUT "#if PERL_VERSION > $ver || (PERL_VERSION == $ver && PERL_SUBVERSION >= $sub) /* TODO */\n";
}
my $final = $varargs
? "$Perl_$f->{name}$aTHX_args"
: "$f->{name}$args";
$f->{cond} and print OUT "#if $f->{cond}\n";
print OUT <<END;
void _DPPP_test_$f->{name} (void)
{
dXSARGS;
$stack
{
#ifdef $f->{name}
$ret$f->{name}$args;
#endif
}
{
#ifdef $f->{name}
$ret$final;
#else
$ret$Perl_$f->{name}$aTHX_args;
#endif
}
}
END
$f->{cond} and print OUT "#endif\n";
$todo{$f->{name}} and print OUT "#endif\n";
print OUT "\n";
}
@ARGV and close OUT;