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