1 ################################################################################
3 # ppptools.pl -- various utility functions
5 ################################################################################
9 # $Date: 2006/01/14 18:07:58 +0100 $
11 ################################################################################
13 # Version 3.x, Copyright (C) 2004-2006, Marcus Holland-Moritz.
14 # Version 2.x, Copyright (C) 2001, Paul Marquess.
15 # Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
17 # This program is free software; you can redistribute it and/or
18 # modify it under the same terms as Perl itself.
20 ################################################################################
24 my $dir = shift || 'parts/todo';
29 for $todo (glob "$dir/*") {
30 open TODO, $todo or die "cannot open $todo: $!\n";
38 /^\w+$/ or die "invalid identifier: $_\n";
39 exists $todo{$_} and die "duplicate identifier: $_ ($todo{$_} <=> $perl)\n";
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";
62 my $section = 'implementation';
63 my $vsec = join '|', qw( provides dontwarn implementation
64 xsubs xsinit xsmisc xshead xsboot tests );
68 open F, $file or die "$file: $!\n";
71 if (/^=($vsec)(?:\s+(.*))?/) {
75 $options{$section} = eval "{ $opt }";
76 $@ and die "Invalid options ($opt) in section $section of $file: $@\n";
80 push @{$data{$section}}, $_;
86 shift @v while @v && $v[0] =~ /^\s*$/;
87 pop @v while @v && $v[-1] =~ /^\s*$/;
88 $data{$_} = join '', @v;
91 unless (exists $data{provides}) {
92 $data{provides} = ($file =~ /(\w+)$/)[0];
94 $data{provides} = [$data{provides} =~ /(\S+)/g];
96 if (exists $data{dontwarn}) {
97 $data{dontwarn} = [$data{dontwarn} =~ /(\S+)/g];
103 if (exists $data{tests} && (!exists $data{implementation} || $data{implementation} !~ /\S/)) {
104 $data{implementation} = '';
107 $data{implementation} =~ /\S/ or die "Empty implementation in $file\n";
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 };
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";
129 if ($data{implementation} !~ /\b\Q$_\E\b/) {
130 warn "$file claims to provide $_, but doesn't seem to do so\n";
134 # scan for prototypes
135 my($proto) = $data{implementation} =~ /
136 ( ^ (?:[\w*]|[^\S\r\n])+
148 exists $proto{$_} and warn "$file: duplicate prototype for $_\n";
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;
159 $data{provides} = \@prov;
160 $data{prototypes} = \%proto;
161 $data{OPTIONS} = \%options;
163 my %prov = map { ($_ => 1) } @prov;
164 my %dontwarn = exists $data{dontwarn} ? map { ($_ => 1) } @{$data{dontwarn}} : ();
165 my @maybeprov = do { my %h;
167 my($nop) = /^Perl_(.*)/;
168 not exists $prov{$_} ||
169 exists $dontwarn{$_} ||
170 (defined $nop && exists $prov{$nop} ) ||
171 (defined $nop && exists $dontwarn{$nop}) ||
174 $data{implementation} =~ /^\s*#\s*define\s+(\w+)/g };
177 warn "$file seems to provide these macros, but doesn't list them:\n "
178 . join("\n ", @maybeprov) . "\n";
184 sub compare_prototypes
204 push @c, map "!($_)", @{$p->{pre}};
205 defined $p->{cur} and push @c, "($p->{cur})";
214 my $remove = join '|', qw( NN NULLOK );
216 $in eq '...' and return ($in);
223 s/\b(?:auto|const|extern|inline|register|static|volatile|restrict)\b//g;
227 if( /^\b(?:struct|union|enum)\s+\w+(?:\s+(\w+))?$/ ) {
228 defined $1 and $id = $1;
231 if( s/\b(?:char|double|float|int|long|short|signed|unsigned|void)\b//g ) {
232 /^\s*(\w+)\s*$/ and $id = $1;
235 /^\s*\w+\s+(\w+)\s*$/ and $id = $1;
241 defined $id and s/\b$id\b//;
243 # these don't matter at all
244 s/\b(?:auto|extern|inline|register|static|volatile|restrict)\b//g;
247 s/(?=<\*)\s+(?=\*)//g;
248 s/\s*(\*+)\s*/ $1 /g;
264 open FILE, $file or die "$file: $!\n";
267 while (defined($line = <FILE>)) {
268 while ($line =~ /\\$/ && defined($l = <FILE>)) {
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) {
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;
286 warn "unhandled preprocessor directive: $dir\n";
290 my @e = split /\s*\|\s*/, $line;
292 my($flags, $ret, $name, @args) = @e;
296 ($ret) = trim_arg($ret);
299 flags => { map { $_, 1 } $flags =~ /./g },
302 cond => ppcond(\@pps),
317 my @args = map { "@$_" } @{$f->{args}};
319 my $pTHX_ = exists $f->{flags}{n} ? "" : "pTHX_ ";
320 $proto = "$f->{ret} $f->{name}" . "($pTHX_" . join(', ', @args) . ')';
329 my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
334 if ($r < 5 || ($r == 5 && $v < 6)) {
336 die "invalid version '$ver'\n";
340 $ver = sprintf "%d.%03d", $r, $v;
341 $s > 0 and $ver .= sprintf "_%02d", $s;
346 return sprintf "%d.%d.%d", $r, $v, $s;
353 if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
356 elsif ($ver !~ /^\d+\.[\d_]+$/) {
357 die "cannot parse version '$ver'\n";
363 my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
368 if ($r < 5 || ($r == 5 && $v < 6)) {
370 die "cannot parse version '$ver'\n";