1 ################################################################################
3 # ppptools.pl -- various utility functions
5 ################################################################################
9 # $Date: 2007/08/19 01:18:23 +0200 $
11 ################################################################################
13 # Version 3.x, Copyright (C) 2004-2007, 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 eval { require File::Spec };
25 return $@ ? join('/', @_) : File::Spec->catfile(@_);
33 opendir DIR, $dir or die "cannot open directory $dir: $!\n";
34 my @files = grep { !-d && !/^\./ } readdir DIR; # no dirs or hidden files
37 return map { cat_file($dir, $_) } @files;
42 my $dir = shift || 'parts/todo';
47 for $todo (all_files_in_dir($dir)) {
48 open TODO, $todo or die "cannot open $todo: $!\n";
56 /^\w+$/ or die "invalid identifier: $_\n";
57 exists $todo{$_} and die "duplicate identifier: $_ ($todo{$_} <=> $perl)\n";
69 my($r, $v, $s) = parse_version($ver);
70 $r == 5 or die "only Perl revision 5 is supported\n";
71 my $bcdver = sprintf "0x%d%03d%03d", $r, $v, $s;
72 return "(PERL_BCDVERSION $op $bcdver)";
78 my $section = 'implementation';
79 my $vsec = join '|', qw( provides dontwarn implementation
80 xsubs xsinit xsmisc xshead xsboot tests );
84 open F, $file or die "$file: $!\n";
86 /[ \t]+$/ and warn "$file:$.: warning: trailing whitespace\n";
87 if ($section eq 'implementation') {
88 m!//! && !m!(?:=~|s/).*//! && !m!(?:ht|f)tp://!
89 and warn "$file:$.: warning: potential C++ comment\n";
92 if (/^=($vsec)(?:\s+(.*))?/) {
96 $options{$section} = eval "{ $opt }";
97 $@ and die "$file:$.: invalid options ($opt) in section $section: $@\n";
101 push @{$data{$section}}, $_;
106 my @v = @{$data{$_}};
107 shift @v while @v && $v[0] =~ /^\s*$/;
108 pop @v while @v && $v[-1] =~ /^\s*$/;
109 $data{$_} = join '', @v;
112 unless (exists $data{provides}) {
113 $data{provides} = ($file =~ /(\w+)$/)[0];
115 $data{provides} = [$data{provides} =~ /(\S+)/g];
117 if (exists $data{dontwarn}) {
118 $data{dontwarn} = [$data{dontwarn} =~ /(\S+)/g];
124 if (exists $data{tests} && (!exists $data{implementation} || $data{implementation} !~ /\S/)) {
125 $data{implementation} = '';
128 $data{implementation} =~ /\S/ or die "Empty implementation in $file\n";
132 for $p (@{$data{provides}}) {
133 if ($p =~ m#^/.*/\w*$#) {
134 my @tmp = eval "\$data{implementation} =~ ${p}gm";
135 $@ and die "invalid regex $p in $file\n";
136 @tmp or warn "no matches for regex $p in $file\n";
137 push @prov, do { my %h; grep !$h{$_}++, @tmp };
139 elsif ($p eq '__UNDEFINED__') {
140 my @tmp = $data{implementation} =~ /^\s*__UNDEFINED__[^\r\n\S]+(\w+)/gm;
141 @tmp or warn "no __UNDEFINED__ macros in $file\n";
150 if ($data{implementation} !~ /\b\Q$_\E\b/) {
151 warn "$file claims to provide $_, but doesn't seem to do so\n";
155 # scan for prototypes
156 my($proto) = $data{implementation} =~ /
157 ( ^ (?:[\w*]|[^\S\r\n])+
169 exists $proto{$_} and warn "$file: duplicate prototype for $_\n";
174 for $section (qw( implementation xsubs xsinit xsmisc xshead xsboot )) {
175 if (exists $data{$section}) {
176 $data{$section} =~ s/\{\s*version\s*(<|>|==|!=|>=|<=)\s*([\d._]+)\s*\}/expand_version($1, $2)/gei;
180 $data{provides} = \@prov;
181 $data{prototypes} = \%proto;
182 $data{OPTIONS} = \%options;
184 my %prov = map { ($_ => 1) } @prov;
185 my %dontwarn = exists $data{dontwarn} ? map { ($_ => 1) } @{$data{dontwarn}} : ();
186 my @maybeprov = do { my %h;
188 my($nop) = /^Perl_(.*)/;
189 not exists $prov{$_} ||
190 exists $dontwarn{$_} ||
191 (defined $nop && exists $prov{$nop} ) ||
192 (defined $nop && exists $dontwarn{$nop}) ||
195 $data{implementation} =~ /^\s*#\s*define\s+(\w+)/gm };
198 warn "$file seems to provide these macros, but doesn't list them:\n "
199 . join("\n ", @maybeprov) . "\n";
205 sub compare_prototypes
225 push @c, map "!($_)", @{$p->{pre}};
226 defined $p->{cur} and push @c, "($p->{cur})";
235 my $remove = join '|', qw( NN NULLOK );
237 $in eq '...' and return ($in);
244 s/\b(?:auto|const|extern|inline|register|static|volatile|restrict)\b//g;
248 if( /^\b(?:struct|union|enum)\s+\w+(?:\s+(\w+))?$/ ) {
249 defined $1 and $id = $1;
252 if( s/\b(?:char|double|float|int|long|short|signed|unsigned|void)\b//g ) {
253 /^\s*(\w+)\s*$/ and $id = $1;
256 /^\s*\w+\s+(\w+)\s*$/ and $id = $1;
262 defined $id and s/\b$id\b//;
264 # these don't matter at all
265 s/\b(?:auto|extern|inline|register|static|volatile|restrict)\b//g;
268 s/(?=<\*)\s+(?=\*)//g;
269 s/\s*(\*+)\s*/ $1 /g;
285 open FILE, $file or die "$file: $!\n";
288 while (defined($line = <FILE>)) {
289 while ($line =~ /\\$/ && defined($l = <FILE>)) {
293 next if $line =~ /^\s*:/;
294 $line =~ s/^\s+|\s+$//gs;
295 my($dir, $args) = ($line =~ /^\s*#\s*(\w+)(?:\s*(.*?)\s*)?$/);
296 if (defined $dir and defined $args) {
298 /^ifdef$/ and do { push @pps, { pre => [], cur => "defined($args)" } ; last };
299 /^ifndef$/ and do { push @pps, { pre => [], cur => "!defined($args)" } ; last };
300 /^if$/ and do { push @pps, { pre => [], cur => $args } ; last };
301 /^elif$/ and do { push @{$pps[-1]{pre}}, $pps[-1]{cur}; $pps[-1]{cur} = $args; last };
302 /^else$/ and do { push @{$pps[-1]{pre}}, $pps[-1]{cur}; $pps[-1]{cur} = undef; last };
303 /^endif$/ and do { pop @pps ; last };
304 /^include$/ and last;
307 warn "unhandled preprocessor directive: $dir\n";
311 my @e = split /\s*\|\s*/, $line;
313 my($flags, $ret, $name, @args) = @e;
317 ($ret) = trim_arg($ret);
320 flags => { map { $_, 1 } $flags =~ /./g },
323 cond => ppcond(\@pps),
338 my @args = map { "@$_" } @{$f->{args}};
340 my $pTHX_ = exists $f->{flags}{n} ? "" : "pTHX_ ";
341 $proto = "$f->{ret} $f->{name}" . "($pTHX_" . join(', ', @args) . ')';
350 my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
355 if ($r < 5 || ($r == 5 && $v < 6)) {
357 die "invalid version '$ver'\n";
361 $ver = sprintf "%d.%03d", $r, $v;
362 $s > 0 and $ver .= sprintf "_%02d", $s;
367 return sprintf "%d.%d.%d", $r, $v, $s;
374 if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
377 elsif ($ver !~ /^\d+\.[\d_]+$/) {
378 die "cannot parse version '$ver'\n";
384 my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
389 if ($r < 5 || ($r == 5 && $v < 6)) {
391 die "cannot parse version '$ver'\n";