Commit | Line | Data |
adfe19db |
1 | #!/usr/bin/perl -w |
2 | ################################################################################ |
3 | # |
4 | # apicheck.pl -- generate C source for automated API check |
5 | # |
6 | ################################################################################ |
7 | # |
9132e1a3 |
8 | # $Revision: 11 $ |
adfe19db |
9 | # $Author: mhx $ |
9132e1a3 |
10 | # $Date: 2005/01/31 08:10:51 +0100 $ |
adfe19db |
11 | # |
12 | ################################################################################ |
13 | # |
9132e1a3 |
14 | # Version 3.x, Copyright (C) 2004-2005, Marcus Holland-Moritz. |
adfe19db |
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 | ); |
101 | |
102 | my %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 | |
116 | my %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 | |
130 | print 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 |
96ad942f |
153 | #define NEED_sv_catpvf_mg |
154 | #define NEED_sv_catpvf_mg_nocontext |
155 | #define NEED_sv_setpvf_mg |
156 | #define NEED_sv_setpvf_mg_nocontext |
157 | #define NEED_vnewSVpvf |
158 | |
adfe19db |
159 | |
160 | #include "ppport.h" |
161 | |
162 | #endif |
163 | |
164 | static int some_global_var; |
165 | |
166 | static int VARarg1; |
167 | static char *VARarg2; |
168 | static double VARarg3; |
169 | |
170 | HEAD |
171 | |
172 | my $f; |
173 | for $f (@f) { |
174 | $ignore{$f->{name}} and next; |
175 | $f->{flags}{A} or next; # only public API members |
176 | |
177 | $ignore{$f->{name}} = 1; # ignore duplicates |
178 | |
179 | my $Perl_ = $f->{flags}{p} ? 'Perl_' : ''; |
180 | |
181 | my $stack = ''; |
182 | my @arg; |
183 | my $aTHX = ''; |
184 | |
185 | my $i = 1; |
186 | my $ca; |
187 | my $varargs = 0; |
188 | for $ca (@{$f->{args}}) { |
189 | my $a = $ca->[0]; |
190 | if ($a eq '...') { |
191 | $varargs = 1; |
192 | push @arg, qw(VARarg1 VARarg2 VARarg3); |
193 | last; |
194 | } |
195 | my($n, $p, $d) = $a =~ /^(\w+(?:\s+\w+)*)\s*(\**)((?:\[[^\]]*\])*)$/ or die; |
196 | if (exists $amap{$n}) { |
197 | push @arg, $amap{$n}; |
198 | next; |
199 | } |
200 | $n = $tmap{$n} || $n; |
201 | my $v = 'arg' . $i++; |
202 | push @arg, $v; |
203 | $stack .= " static $n $p$v$d;\n"; |
204 | } |
205 | |
206 | unless ($f->{flags}{n} || $f->{flags}{'m'}) { |
207 | $stack = " dTHX;\n$stack"; |
208 | $aTHX = @arg ? 'aTHX_ ' : 'aTHX'; |
209 | } |
210 | |
211 | if ($stack{$f->{name}}) { |
212 | my $s = ''; |
213 | for (@{$stack{$f->{name}}}) { |
214 | $s .= " $_\n"; |
215 | } |
216 | $stack = "$s$stack"; |
217 | } |
218 | |
219 | my $args = join ', ', @arg; |
220 | my $rvt = $f->{ret} || 'void'; |
221 | my $ret; |
222 | if ($void{$rvt}) { |
223 | $ret = $castvoid{$f->{name}} ? '(void) ' : ''; |
224 | } |
225 | else { |
226 | $ret = $ignorerv{$f->{name}} ? '(void) ' : "return "; |
227 | } |
228 | my $aTHX_args = "$aTHX$args"; |
229 | |
230 | my $post = ''; |
231 | if ($postcode{$f->{name}}) { |
232 | $post = $postcode{$f->{name}}; |
233 | $post =~ s/^/ /g; |
234 | $post = "\n$post"; |
235 | } |
236 | |
237 | unless ($f->{flags}{'m'} and @arg == 0) { |
238 | $args = "($args)"; |
239 | $aTHX_args = "($aTHX_args)"; |
240 | } |
241 | |
242 | print OUT <<HEAD; |
243 | /****************************************************************************** |
244 | * |
245 | * $f->{name} |
246 | * |
247 | ******************************************************************************/ |
248 | |
249 | HEAD |
250 | |
251 | if ($todo{$f->{name}}) { |
252 | my($ver,$sub) = $todo{$f->{name}} =~ /^5\.(\d{3})(\d{3})$/ or die; |
253 | for ($ver, $sub) { |
254 | s/^0+(\d)/$1/ |
255 | } |
256 | if ($ver < 6 && $sub > 0) { |
257 | $sub =~ s/0$// or die; |
258 | } |
259 | print OUT "#if PERL_VERSION > $ver || (PERL_VERSION == $ver && PERL_SUBVERSION >= $sub) /* TODO */\n"; |
260 | } |
261 | |
262 | my $final = $varargs |
263 | ? "$Perl_$f->{name}$aTHX_args" |
264 | : "$f->{name}$args"; |
265 | |
266 | $f->{cond} and print OUT "#if $f->{cond}\n"; |
267 | |
268 | print OUT <<END; |
269 | $rvt _DPPP_test_$f->{name} (void) |
270 | { |
271 | dXSARGS; |
272 | $stack |
273 | #ifdef $f->{name} |
274 | if (some_global_var) |
275 | { |
276 | $ret$f->{name}$args;$post |
277 | } |
278 | #endif |
279 | |
280 | some_global_var = items && ax; |
281 | |
282 | { |
283 | #ifdef $f->{name} |
284 | $ret$final;$post |
285 | #else |
286 | $ret$Perl_$f->{name}$aTHX_args;$post |
287 | #endif |
288 | } |
289 | } |
290 | END |
291 | |
292 | $f->{cond} and print OUT "#endif\n"; |
293 | $todo{$f->{name}} and print OUT "#endif\n"; |
294 | |
295 | print OUT "\n"; |
296 | } |
297 | |
298 | @ARGV and close OUT; |
299 | |