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