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 / ppptools.pl
CommitLineData
adfe19db
MHM
1################################################################################
2#
3# ppptools.pl -- various utility functions
4#
5################################################################################
6#
7# $Revision: 11 $
8# $Author: mhx $
9# $Date: 2004/08/13 12:50:05 +0200 $
10#
11################################################################################
12#
13# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz.
14# Version 2.x, Copyright (C) 2001, Paul Marquess.
15# Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
16#
17# This program is free software; you can redistribute it and/or
18# modify it under the same terms as Perl itself.
19#
20################################################################################
21
22sub parse_todo
23{
24 my $dir = shift || 'parts/todo';
25 local *TODO;
26 my %todo;
27 my $todo;
28
29 for $todo (glob "$dir/*") {
30 open TODO, $todo or die "cannot open $todo: $!\n";
31 my $perl = <TODO>;
32 chomp $perl;
33 while (<TODO>) {
34 chomp;
35 s/#.*//;
36 s/^\s+//; s/\s+$//;
37 /^\s*$/ and next;
38 /^\w+$/ or die "invalid identifier: $_\n";
39 exists $todo{$_} and die "duplicate identifier: $_ ($todo{$_} <=> $perl)\n";
40 $todo{$_} = $perl;
41 }
42 close TODO;
43 }
44
45 return \%todo;
46}
47
48sub parse_partspec
49{
50 my $file = shift;
51 my $section = 'implementation';
52 my $vsec = join '|', qw( provides dontwarn implementation
53 xsubs xsinit xsmisc xshead xsboot tests );
54 my(%data, %options);
55 local *F;
56
57 open F, $file or die "$file: $!\n";
58 while (<F>) {
59 /^##/ and next;
60 if (/^=($vsec)(?:\s+(.*))?/) {
61 $section = $1;
62 if (defined $2) {
63 my $opt = $2;
64 $options{$section} = eval "{ $opt }";
65 $@ and die "Invalid options ($opt) in section $section of $file: $@\n";
66 }
67 next;
68 }
69 push @{$data{$section}}, $_;
70 }
71 close F;
72
73 for (keys %data) {
74 my @v = @{$data{$_}};
75 shift @v while @v && $v[0] =~ /^\s*$/;
76 pop @v while @v && $v[-1] =~ /^\s*$/;
77 $data{$_} = join '', @v;
78 }
79
80 unless (exists $data{provides}) {
81 $data{provides} = ($file =~ /(\w+)$/)[0];
82 }
83 $data{provides} = [$data{provides} =~ /(\S+)/g];
84
85 if (exists $data{dontwarn}) {
86 $data{dontwarn} = [$data{dontwarn} =~ /(\S+)/g];
87 }
88
89 my @prov;
90 my %proto;
91
92 if (exists $data{tests} && (!exists $data{implementation} || $data{implementation} !~ /\S/)) {
93 $data{implementation} = '';
94 }
95 else {
96 $data{implementation} =~ /\S/ or die "Empty implementation in $file\n";
97
98 my $p;
99
100 for $p (@{$data{provides}}) {
101 if ($p =~ m#^/.*/\w*$#) {
102 my @tmp = eval "\$data{implementation} =~ ${p}gm";
103 $@ and die "invalid regex $p in $file\n";
104 @tmp or warn "no matches for regex $p in $file\n";
105 push @prov, do { my %h; grep !$h{$_}++, @tmp };
106 }
107 elsif ($p eq '__UNDEFINED__') {
108 my @tmp = $data{implementation} =~ /^\s*__UNDEFINED__[^\r\n\S]+(\w+)/gm;
109 @tmp or warn "no __UNDEFINED__ macros in $file\n";
110 push @prov, @tmp;
111 }
112 else {
113 push @prov, $p;
114 }
115 }
116
117 for (@prov) {
118 if ($data{implementation} !~ /\b\Q$_\E\b/) {
119 warn "$file claims to provide $_, but doesn't seem to do so\n";
120 next;
121 }
122
123 # scan for prototypes
124 my($proto) = $data{implementation} =~ /
125 ( ^ (?:[\w*]|[^\S\r\n])+
126 [\r\n]*?
127 ^ \b$_\b \s*
128 \( [^{]* \)
129 )
130 \s* \{
131 /xm or next;
132
133 $proto =~ s/^\s+//;
134 $proto =~ s/\s+$//;
135 $proto =~ s/\s+/ /g;
136
137 exists $proto{$_} and warn "$file: duplicate prototype for $_\n";
138 $proto{$_} = $proto;
139 }
140 }
141
142 $data{provides} = \@prov;
143 $data{prototypes} = \%proto;
144 $data{OPTIONS} = \%options;
145
146 my %prov = map { ($_ => 1) } @prov;
147 my %dontwarn = exists $data{dontwarn} ? map { ($_ => 1) } @{$data{dontwarn}} : ();
148 my @maybeprov = do { my %h;
149 grep {
150 my($nop) = /^Perl_(.*)/;
151 not exists $prov{$_} ||
152 exists $dontwarn{$_} ||
153 (defined $nop && exists $prov{$nop} ) ||
154 (defined $nop && exists $dontwarn{$nop}) ||
155 $h{$_}++;
156 }
157 $data{implementation} =~ /^\s*#\s*define\s+(\w+)/g };
158
159 if (@maybeprov) {
160 warn "$file seems to provide these macros, but doesn't list them:\n "
161 . join("\n ", @maybeprov) . "\n";
162 }
163
164 return \%data;
165}
166
167sub compare_prototypes
168{
169 my($p1, $p2) = @_;
170 for ($p1, $p2) {
171 s/^\s+//;
172 s/\s+$//;
173 s/\s+/ /g;
174 s/(\w)\s(\W)/$1$2/g;
175 s/(\W)\s(\w)/$1$2/g;
176 }
177 return $p1 cmp $p2;
178}
179
180sub ppcond
181{
182 my $s = shift;
183 my @c;
184 my $p;
185
186 for $p (@$s) {
187 push @c, map "!($_)", @{$p->{pre}};
188 defined $p->{cur} and push @c, "($p->{cur})";
189 }
190
191 join " && ", @c;
192}
193
194sub trim_arg
195{
196 my $in = shift;
197
198 $in eq '...' and return ($in);
199
200 local $_ = $in;
201 my $id;
202
203 s/[*()]/ /g;
204 s/\[[^\]]*\]/ /g;
205 s/\b(?:auto|const|extern|inline|register|static|volatile|restrict)\b//g;
206 s/^\s*//; s/\s*$//;
207
208 if( /^\b(?:struct|union|enum)\s+\w+(?:\s+(\w+))?$/ ) {
209 defined $1 and $id = $1;
210 }
211 else {
212 if( s/\b(?:char|double|float|int|long|short|signed|unsigned|void)\b//g ) {
213 /^\s*(\w+)\s*$/ and $id = $1;
214 }
215 else {
216 /^\s*\w+\s+(\w+)\s*$/ and $id = $1;
217 }
218 }
219
220 $_ = $in;
221
222 defined $id and s/\b$id\b//;
223
224 # these don't matter at all
225 s/\b(?:auto|extern|inline|register|static|volatile|restrict)\b//g;
226
227 s/(?=<\*)\s+(?=\*)//g;
228 s/\s*(\*+)\s*/ $1 /g;
229 s/^\s*//; s/\s*$//;
230 s/\s+/ /g;
231
232 return ($_, $id);
233}
234
235sub parse_embed
236{
237 my @files = @_;
238 my @func;
239 my @pps;
240 my $file;
241 local *FILE;
242
243 for $file (@files) {
244 open FILE, $file or die "$file: $!\n";
245 my($line, $l);
246
247 while (defined($line = <FILE>)) {
248 while ($line =~ /\\$/ && defined($l = <FILE>)) {
249 $line =~ s/\\\s*//;
250 $line .= $l;
251 }
252 next if $line =~ /^\s*:/;
253 $line =~ s/^\s+|\s+$//gs;
254 my($dir, $args) = ($line =~ /^\s*#\s*(\w+)(?:\s*(.*?)\s*)?$/);
255 if (defined $dir and defined $args) {
256 for ($dir) {
257 /^ifdef$/ and do { push @pps, { pre => [], cur => "defined($args)" } ; last };
258 /^ifndef$/ and do { push @pps, { pre => [], cur => "!defined($args)" } ; last };
259 /^if$/ and do { push @pps, { pre => [], cur => $args } ; last };
260 /^elif$/ and do { push @{$pps[-1]{pre}}, $pps[-1]{cur}; $pps[-1]{cur} = $args; last };
261 /^else$/ and do { push @{$pps[-1]{pre}}, $pps[-1]{cur}; $pps[-1]{cur} = undef; last };
262 /^endif$/ and do { pop @pps ; last };
263 /^include$/ and last;
264 /^define$/ and last;
265 /^undef$/ and last;
266 warn "unhandled preprocessor directive: $dir\n";
267 }
268 }
269 else {
270 my @e = split /\s*\|\s*/, $line;
271 if( @e >= 3 ) {
272 my($flags, $ret, $name, @args) = @e;
273 for (@args) {
274 $_ = [trim_arg($_)];
275 }
276 ($ret) = trim_arg($ret);
277 push @func, {
278 name => $name,
279 flags => { map { $_, 1 } $flags =~ /./g },
280 ret => $ret,
281 args => \@args,
282 cond => ppcond(\@pps),
283 };
284 }
285 }
286 }
287
288 close FILE;
289 }
290
291 return @func;
292}
293
294sub make_prototype
295{
296 my $f = shift;
297 my @args = map { "@$_" } @{$f->{args}};
298 my $proto;
299 my $pTHX_ = exists $f->{flags}{n} ? "" : "pTHX_ ";
300 $proto = "$f->{ret} $f->{name}" . "($pTHX_" . join(', ', @args) . ')';
301 return $proto;
302}
303
304sub format_version
305{
306 my $ver = shift;
307
308 $ver =~ s/$/000000/;
309 my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
310
311 $v = int $v;
312 $s = int $s;
313
314 if ($r < 5 || ($r == 5 && $v < 6)) {
315 if ($s % 10) {
316 die "invalid version '$ver'\n";
317 }
318 $s /= 10;
319
320 $ver = sprintf "%d.%03d", $r, $v;
321 $s > 0 and $ver .= sprintf "_%02d", $s;
322
323 return $ver;
324 }
325
326 return sprintf "%d.%d.%d", $r, $v, $s;
327}
328
329sub parse_version
330{
331 my $ver = shift;
332
333 if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
334 return ($1, $2, $3);
335 }
336 elsif ($ver !~ /^\d+\.[\d_]+$/) {
337 die "cannot parse version '$ver'\n";
338 }
339
340 $ver =~ s/_//g;
341 $ver =~ s/$/000000/;
342
343 my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
344
345 $v = int $v;
346 $s = int $s;
347
348 if ($r < 5 || ($r == 5 && $v < 6)) {
349 if ($s % 10) {
350 die "cannot parse version '$ver'\n";
351 }
352 $s /= 10;
353 }
354
355 return ($r, $v, $s);
356}
357
3581;