This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Devel::PPPort 3.00.
[perl5.git] / ext / Devel / PPPort / parts / apicheck.pl
CommitLineData
adfe19db
MHM
1#!/usr/bin/perl -w
2################################################################################
3#
4# apicheck.pl -- generate C source for automated API check
5#
6################################################################################
7#
8# $Revision: 9 $
9# $Author: mhx $
10# $Date: 2004/08/13 12:49:50 +0200 $
11#
12################################################################################
13#
14# Version 3.x, Copyright (C) 2004, 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
23use strict;
24require 'parts/ppptools.pl';
25
26if (@ARGV) {
27 open OUT, ">$ARGV[0]" or die "$ARGV[0]: $!\n";
28}
29else {
30 *OUT = \*STDOUT;
31}
32
33my @f = parse_embed(qw( parts/embed.fnc parts/apidoc.fnc ));
34
35my %todo = %{&parse_todo};
36
37my %tmap = (
38 void => 'int',
39);
40
41my %amap = (
42 SP => 'SP',
43 type => 'int',
44 cast => 'int',
45);
46
47my %void = (
48 void => 1,
49 Free_t => 1,
50 Signal_t => 1,
51);
52
53my %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
81my %ignorerv = (
82 map { ($_ => 1) } qw(
83 newCONSTSUB
84 ),
85);
86
87my %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);
101
102my %postcode = (
103 dSP => "some_global_var = !sp;",
104 dMARK => "some_global_var = !mark;",
105 dORIGMARK => "some_global_var = !origmark;",
106 dAX => "some_global_var = !ax;",
107 dITEMS => "some_global_var = !items;",
108 dXSARGS => "some_global_var = ax && items;",
109 NEWSV => "some_global_var = !arg1;",
110 New => "some_global_var = !arg1;",
111 Newc => "some_global_var = !arg1;",
112 Newz => "some_global_var = !arg1;",
113 dUNDERBAR => "(void) UNDERBAR;",
114);
115
116my %ignore = (
117 map { ($_ => 1) } qw(
118 svtype
119 items
120 ix
121 dXSI32
122 XS
123 CLASS
124 THIS
125 RETVAL
126 StructCopy
127 ),
128);
129
130print OUT <<HEAD;
131/*
132 * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
133 * This file is built by $0.
134 * Any changes made here will be lost!
135 */
136
137#include "EXTERN.h"
138#include "perl.h"
139#include "XSUB.h"
140
141#ifndef DPPP_APICHECK_NO_PPPORT_H
142
143#define NEED_eval_pv
144#define NEED_grok_bin
145#define NEED_grok_hex
146#define NEED_grok_number
147#define NEED_grok_numeric_radix
148#define NEED_grok_oct
149#define NEED_newCONSTSUB
150#define NEED_newRV_noinc
151#define NEED_sv_2pv_nolen
152#define NEED_sv_2pvbyte
153
154#include "ppport.h"
155
156#endif
157
158static int some_global_var;
159
160static int VARarg1;
161static char *VARarg2;
162static double VARarg3;
163
164HEAD
165
166my $f;
167for $f (@f) {
168 $ignore{$f->{name}} and next;
169 $f->{flags}{A} or next; # only public API members
170
171 $ignore{$f->{name}} = 1; # ignore duplicates
172
173 my $Perl_ = $f->{flags}{p} ? 'Perl_' : '';
174
175 my $stack = '';
176 my @arg;
177 my $aTHX = '';
178
179 my $i = 1;
180 my $ca;
181 my $varargs = 0;
182 for $ca (@{$f->{args}}) {
183 my $a = $ca->[0];
184 if ($a eq '...') {
185 $varargs = 1;
186 push @arg, qw(VARarg1 VARarg2 VARarg3);
187 last;
188 }
189 my($n, $p, $d) = $a =~ /^(\w+(?:\s+\w+)*)\s*(\**)((?:\[[^\]]*\])*)$/ or die;
190 if (exists $amap{$n}) {
191 push @arg, $amap{$n};
192 next;
193 }
194 $n = $tmap{$n} || $n;
195 my $v = 'arg' . $i++;
196 push @arg, $v;
197 $stack .= " static $n $p$v$d;\n";
198 }
199
200 unless ($f->{flags}{n} || $f->{flags}{'m'}) {
201 $stack = " dTHX;\n$stack";
202 $aTHX = @arg ? 'aTHX_ ' : 'aTHX';
203 }
204
205 if ($stack{$f->{name}}) {
206 my $s = '';
207 for (@{$stack{$f->{name}}}) {
208 $s .= " $_\n";
209 }
210 $stack = "$s$stack";
211 }
212
213 my $args = join ', ', @arg;
214 my $rvt = $f->{ret} || 'void';
215 my $ret;
216 if ($void{$rvt}) {
217 $ret = $castvoid{$f->{name}} ? '(void) ' : '';
218 }
219 else {
220 $ret = $ignorerv{$f->{name}} ? '(void) ' : "return ";
221 }
222 my $aTHX_args = "$aTHX$args";
223
224 my $post = '';
225 if ($postcode{$f->{name}}) {
226 $post = $postcode{$f->{name}};
227 $post =~ s/^/ /g;
228 $post = "\n$post";
229 }
230
231 unless ($f->{flags}{'m'} and @arg == 0) {
232 $args = "($args)";
233 $aTHX_args = "($aTHX_args)";
234 }
235
236 print OUT <<HEAD;
237/******************************************************************************
238*
239* $f->{name}
240*
241******************************************************************************/
242
243HEAD
244
245 if ($todo{$f->{name}}) {
246 my($ver,$sub) = $todo{$f->{name}} =~ /^5\.(\d{3})(\d{3})$/ or die;
247 for ($ver, $sub) {
248 s/^0+(\d)/$1/
249 }
250 if ($ver < 6 && $sub > 0) {
251 $sub =~ s/0$// or die;
252 }
253 print OUT "#if PERL_VERSION > $ver || (PERL_VERSION == $ver && PERL_SUBVERSION >= $sub) /* TODO */\n";
254 }
255
256 my $final = $varargs
257 ? "$Perl_$f->{name}$aTHX_args"
258 : "$f->{name}$args";
259
260 $f->{cond} and print OUT "#if $f->{cond}\n";
261
262 print OUT <<END;
263$rvt _DPPP_test_$f->{name} (void)
264{
265 dXSARGS;
266$stack
267#ifdef $f->{name}
268 if (some_global_var)
269 {
270 $ret$f->{name}$args;$post
271 }
272#endif
273
274 some_global_var = items && ax;
275
276 {
277#ifdef $f->{name}
278 $ret$final;$post
279#else
280 $ret$Perl_$f->{name}$aTHX_args;$post
281#endif
282 }
283}
284END
285
286 $f->{cond} and print OUT "#endif\n";
287 $todo{$f->{name}} and print OUT "#endif\n";
288
289 print OUT "\n";
290}
291
292@ARGV and close OUT;
293