1################################################################################ 2# 3# ppptools.pl -- various utility functions 4# 5# WARNING: This will be called by old perls. You can't use modern constructs 6# in it. 7# 8################################################################################ 9# 10# Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz. 11# Version 2.x, Copyright (C) 2001, Paul Marquess. 12# Version 1.x, Copyright (C) 1999, Kenneth Albanowski. 13# 14# This program is free software; you can redistribute it and/or 15# modify it under the same terms as Perl itself. 16# 17################################################################################ 18 19require './parts/inc/inctools'; 20 21sub cat_file 22{ 23 eval { require File::Spec }; 24 return $@ ? join('/', @_) : File::Spec->catfile(@_); 25} 26 27sub all_files_in_dir 28{ 29 my $dir = shift; 30 local *DIR; 31 32 opendir DIR, $dir or die "cannot open directory $dir: $!\n"; 33 my @files = grep { !-d && !/^\./ } readdir DIR; # no dirs or hidden files 34 closedir DIR; 35 36 return map { cat_file($dir, $_) } sort @files; 37} 38 39sub parse_todo 40{ 41 # Creates a hash with the keys being all symbols found in all the files in 42 # the input directory (default 'parts/todo'), and the values being each a 43 # subhash like so: 44 # 'utf8_hop_forward' => { 45 # 'code' => 'U', 46 # 'version' => '5.025007' 47 # }, 48 # 49 # The input line that generated that was this: 50 # 51 # utf8_hop_forward # U 52 53 my $dir = shift || 'parts/todo'; 54 local *TODO; 55 my %todo; 56 my $todo; 57 58 for $todo (all_files_in_dir($dir)) { 59 open TODO, $todo or die "cannot open $todo: $!\n"; 60 my $version = <TODO>; 61 chomp $version; 62 while (<TODO>) { 63 chomp; 64 s/#(?: (\w)\b)?.*//; # 'code' is optional 65 my $code = $1; 66 s/^\s+//; s/\s+$//; 67 /^\s*$/ and next; 68 /^\w+$/ or die "parse_todo: invalid identifier in $todo: $_\n"; 69 exists $todo{$_} and die "parse_todo: duplicate identifier in $todo: $_ ($todo{$_} <=> $version)\n"; 70 $todo{$_}{'version'} = $version; 71 $todo{$_}{'code'} = $code if $code; 72 } 73 close TODO; 74 } 75 76 return \%todo; 77} 78 79sub expand_version 80{ 81 my($op, $ver) = @_; 82 my($r, $v, $s) = parse_version($ver); 83 $r =~ / ^ [57] $ /x or die "only Perl revisions [57] are supported\n"; 84 my $bcdver = sprintf "0x%d%03d%03d", $r, $v, $s; 85 return "(PERL_BCDVERSION $op $bcdver)"; 86} 87 88sub parse_partspec 89{ 90 my $file = shift; 91 my $section = 'implementation'; 92 93 my $vsec = join '|', qw( provides dontwarn implementation 94 xsubs xsinit xsmisc xshead xsboot tests ); 95 my(%data, %options); 96 local *F; 97 98 open F, $file or die "$file: $!\n"; 99 while (<F>) { 100 /[ \t]+$/ and warn "$file:$.: warning: trailing whitespace\n"; 101 if ($section eq 'implementation') { 102 m!//! && !m!(?:=~|s/).*//! && !m!(?:ht|f)tp(?:s)://! 103 and warn "$file:$.: warning: potential C++ comment\n"; 104 } 105 106 /^##/ and next; 107 108 if (/^=($vsec)(?:\s+(.*))?/) { 109 $section = $1; 110 if (defined $2) { 111 my $opt = $2; 112 $options{$section} = eval "{ $opt }"; 113 $@ and die "$file:$.: invalid options ($opt) in section $section: $@\n"; 114 } 115 next; 116 } 117 push @{$data{$section}}, $_; 118 } 119 close F; 120 121 for (keys %data) { 122 my @v = @{$data{$_}}; 123 shift @v while @v && $v[0] =~ /^\s*$/; 124 pop @v while @v && $v[-1] =~ /^\s*$/; 125 $data{$_} = join '', @v; 126 } 127 128 if (! exists $data{provides}) { 129 if ($file =~ /inctools$/) { # This file is special, it doesn't 'provide' 130 # any API, but has subs to use internally 131 $data{provides} = ""; 132 } 133 else { 134 $data{provides} = ($file =~ /(\w+)\.?$/)[0]; 135 } 136 } 137 $data{provides} = [$data{provides} =~ /(\S+)/g]; 138 139 if (exists $data{dontwarn}) { 140 $data{dontwarn} = [$data{dontwarn} =~ /(\S+)/g]; 141 } 142 143 my @prov; 144 my %proto; 145 146 if (exists $data{tests} && (!exists $data{implementation} || $data{implementation} !~ /\S/)) { 147 $data{implementation} = ''; 148 } 149 else { 150 $data{implementation} =~ /\S/ or die "Empty implementation in $file\n"; 151 152 my $p; 153 154 for $p (@{$data{provides}}) { 155 if ($p =~ m#^/.*/\w*$#) { 156 my @tmp = eval "\$data{implementation} =~ ${p}gm"; 157 $@ and die "invalid regex $p in $file\n"; 158 @tmp or warn "no matches for regex $p in $file\n"; 159 push @prov, do { my %h; grep !$h{$_}++, @tmp }; 160 } 161 elsif ($p eq '__UNDEFINED__') { 162 my @tmp = $data{implementation} =~ /^\s*__UNDEFINED__[^\r\n\S]+(\w+)/gm; 163 @tmp or warn "no __UNDEFINED__ macros in $file\n"; 164 push @prov, @tmp; 165 } 166 else { 167 push @prov, $p; 168 } 169 } 170 171 for (@prov) { 172 if ($data{implementation} !~ /\b\Q$_\E\b/) { 173 warn "$file claims to provide $_, but doesn't seem to do so\n"; 174 next; 175 } 176 177 # scan for prototypes 178 my($proto) = $data{implementation} =~ / 179 ( ^ (?:[\w*]|[^\S\r\n])+ 180 [\r\n]*? 181 ^ \b$_\b \s* 182 \( [^{]* \) 183 ) 184 \s* \{ 185 /xm or next; 186 187 $proto =~ s/^\s+//; 188 $proto =~ s/\s+$//; 189 $proto =~ s/\s+/ /g; 190 191 exists $proto{$_} and warn "$file: duplicate prototype for $_\n"; 192 $proto{$_} = $proto; 193 } 194 } 195 196 for $section (qw( implementation xsubs xsinit xsmisc xshead xsboot )) { 197 if (exists $data{$section}) { 198 $data{$section} =~ s/\{\s*version\s*(<|>|==|!=|>=|<=)\s*([\d._]+)\s*\}/expand_version($1, $2)/gei; 199 } 200 } 201 202 $data{provides} = \@prov; 203 $data{prototypes} = \%proto; 204 $data{OPTIONS} = \%options; 205 206 my %prov = map { ($_ => 1) } @prov; 207 my %dontwarn = exists $data{dontwarn} ? map { ($_ => 1) } @{$data{dontwarn}} : (); 208 my @maybeprov = do { my %h; 209 grep { 210 my($nop) = /^Perl_(.*)/; 211 not exists $prov{$_} || 212 exists $dontwarn{$_} || 213 /^D_PPP_/ || 214 (defined $nop && exists $prov{$nop} ) || 215 (defined $nop && exists $dontwarn{$nop}) || 216 $h{$_}++; 217 } 218 $data{implementation} =~ /^\s*#\s*define\s+(\w+)/gm }; 219 220 if (@maybeprov) { 221 warn "$file seems to provide these macros, but doesn't list them:\n " 222 . join("\n ", @maybeprov) . "\n"; 223 } 224 225 return \%data; 226} 227 228sub compare_prototypes 229{ 230 my($p1, $p2) = @_; 231 for ($p1, $p2) { 232 s/^\s+//; 233 s/\s+$//; 234 s/\s+/ /g; 235 s/(\w)\s(\W)/$1$2/g; 236 s/(\W)\s(\w)/$1$2/g; 237 } 238 return $p1 cmp $p2; 239} 240 241sub ppcond 242{ 243 my $s = shift; 244 my @c; 245 my $p; 246 247 for $p (@$s) { 248 push @c, map "!($_)", @{$p->{pre}}; 249 defined $p->{cur} and push @c, "($p->{cur})"; 250 } 251 252 join " && ", @c; 253} 254 255sub trim_arg # Splits the argument into type and name, returning the 256 # pair: (type, name) 257{ 258 my $in = shift; 259 my $remove = join '|', qw( NN NULLOK VOL ); 260 261 $in eq '...' and return ($in); 262 263 local $_ = $in; 264 my $name; # Work on the name 265 266 s/[*()]/ /g; # Get rid of this punctuation 267 s/ \[ [^\]]* \] / /xg; # Get rid of dimensions 268 s/\b(?:auto|const|extern|inline|register|static|volatile|restrict)\b//g; 269 s/\b(?:$remove)\b//; 270 s/^\s+//; s/\s+$//; # No leading, trailing space 271 272 if( /^\b (?:struct|union|enum) \s+ \w+ (?: \s+ ( \w+ ) )? $/x ) { 273 defined $1 and $name = $1; # Extract the name for one of these declarations 274 } 275 else { 276 if( s/\b(?:char|double|float|int|long|short|signed|unsigned|void)\b//g ) { 277 /^ \s* (\w+) \s* $/x and $name = $1; # Similarly for these 278 } 279 elsif (/^ \s* " [^"]+ " \s+ (\w+) \s* $/x) { # A literal string (is special) 280 $name = $1; 281 } 282 else { 283 /^ \s* \w+ \s+ (\w+) \s* $/x and $name = $1; # Everything else. 284 } 285 } 286 287 $_ = $in; # Now work on the type. 288 289 # Get rid of the name if we found one 290 defined $name and s/\b$name\b//; 291 292 # these don't matter at all; note that const does matter 293 s/\b(?:auto|extern|inline|register|static|volatile|restrict)\b//g; 294 s/\b(?:$remove)\b//; 295 296 while (s/ \* \s+ \* /**/xg) {} # No spaces within pointer sequences 297 s/ \s* ( \*+ ) \s* / $1 /xg; # Normalize pointer sequences to be surrounded 298 # by a single space 299 s/^\s+//; s/\s+$//; # No leading, trailing spacd 300 s/\s+/ /g; # Collapse multiple space into one 301 302 return ($_, $name) if defined $name; 303 return $_; 304} 305 306sub parse_embed 307{ 308 my @files = @_; 309 my @func; 310 my @pps; 311 my $file; 312 local *FILE; 313 314 for $file (@files) { 315 open FILE, $file or die "$file: $!\n"; 316 my($line, $l); 317 318 while (defined($line = <FILE>)) { 319 while ($line =~ /\\$/ && defined($l = <FILE>)) { 320 $line =~ s/\\\s*//; 321 $line .= $l; 322 } 323 next if $line =~ /^\s*:/; 324 $line =~ s/^\s+|\s+$//gs; 325 my($dir, $args) = ($line =~ /^\s*#\s*(\w+)(?:\s*(.*?)\s*)?$/); 326 if (defined $dir and defined $args) { 327 for ($dir) { 328 /^ifdef$/ and do { push @pps, { pre => [], cur => "defined($args)" } ; last }; 329 /^ifndef$/ and do { push @pps, { pre => [], cur => "!defined($args)" } ; last }; 330 /^if$/ and do { push @pps, { pre => [], cur => $args } ; last }; 331 /^elif$/ and do { push @{$pps[-1]{pre}}, $pps[-1]{cur}; $pps[-1]{cur} = $args; last }; 332 /^else$/ and do { push @{$pps[-1]{pre}}, $pps[-1]{cur}; $pps[-1]{cur} = undef; last }; 333 /^endif$/ and do { pop @pps ; last }; 334 /^include$/ and last; 335 /^define$/ and last; 336 /^undef$/ and last; 337 warn "unhandled preprocessor directive: $dir\n"; 338 } 339 } 340 else { 341 my @e = split /\s*\|\s*/, $line; 342 if( @e >= 3 ) { 343 my($flags, $ret, $name, @args) = @e; 344 345 # Skip non-name entries, like 346 # PL_parser-E<gt>linestr 347 # which documents a struct entry rather than a function. We retain 348 # all other entries, so that our caller has full information, and 349 # may skip things like non-public functions. 350 next if $flags =~ /N/; 351 352 # M implies m for the purposes of this module. 353 $flags .= 'm' if $flags =~ /M/; 354 355 # An entry marked 'b' is in mathoms, so is effectively deprecated, 356 # as it can be removed at anytime. But if it also has a macro to 357 # implement it, that macro stays when mathoms is removed, so the 358 # non-'Perl_' form isn't deprecated. embed.fnc is supposed to have 359 # already set this up, but make sure. 360 if ($flags =~ /b/ && $flags !~ /m/ && $flags !~ /D/) { 361 warn "Expecting D flag for '$name', since it is b without [Mm]"; 362 $flags .= 'D'; 363 } 364 365 if ($name =~ /^[^\W\d]\w*$/) { 366 my $cond = ppcond(\@pps); 367 if ($cond =~ /defined\(PERL_IN_[A-Z0-9_]+_[CH]/ && $flags =~ /A/) 368 { 369 warn "$name marked as API, but restricted scope: $cond\n"; 370 } 371 #warn "$name: $cond" if length $cond && $flags =~ /A/; 372 for (@args) { 373 $_ = [trim_arg($_)]; 374 } 375 ($ret) = trim_arg($ret); 376 push @func, { 377 name => $name, 378 flags => { map { $_, 1 } $flags =~ /./g }, 379 ret => $ret, 380 args => \@args, 381 cond => $cond, 382 }; 383 $func[-1]{'ppport_fnc'} = 1 if $file =~ /ppport\.fnc/; 384 } 385 elsif ($flags !~ /y/) { 386 warn "mysterious name [$name] in $file, line $.\n"; 387 } 388 } 389 } 390 } 391 392 close FILE; 393 } 394 395 # Here's what two elements of the array look like: 396 # { 397 # 'args' => [ 398 # [ 399 # 'const nl_item', 400 # 'item' 401 # ] 402 # ], 403 # 'cond' => '(defined(HAS_NL_LANGINFO) && defined(PERL_LANGINFO_H))', 404 # 'flags' => { 405 # 'A' => 1, 406 # 'T' => 1, 407 # 'd' => 1, 408 # 'o' => 1 409 # }, 410 # 'name' => 'Perl_langinfo', 411 # 'ret' => 'const char *' 412 # }, 413 # { 414 # 'args' => [ 415 # [ 416 # 'const int', 417 # 'item' 418 # ] 419 # ], 420 # 'cond' => '!(defined(HAS_NL_LANGINFO) && defined(PERL_LANGINFO_H))', 421 # 'flags' => { 422 # 'A' => 1, 423 # 'T' => 1, 424 # 'd' => 1, 425 # 'o' => 1 426 # }, 427 # 'name' => 'Perl_langinfo', 428 # 'ret' => 'const char *' 429 # }, 430 431 return @func; 432} 433 434sub known_but_hard_to_test_for 435{ 436 # This returns a list of functions/symbols that are in Perl, but the tests 437 # for their existence don't work, usually as a result of them being XS, 438 # and using XS to test. Effectively, any XS code that compiles and works 439 # is exercising most of these XS-related ones. 440 # 441 # The values for the keys are each the version that ppport.h makes them 442 # work on, and were gleaned by manually looking at the code parts/inc/*. 443 # For functions, scanprov will automatically figure out the version 444 # they were introduced in. 445 446 my %return; 447 448 449 450 451 452for (qw(CLASS CPERLscope dMY_CXT_SV dXSI32 END_EXTERN_C EXTERN_C items 453 ix PERL_USE_GCC_BRACE_GROUPS PL_hexdigit pTHX_ PTRV 454 RETVAL START_EXTERN_C STMT_END STMT_START StructCopy 455 STR_WITH_LEN svtype THIS XS XSPROTO)) 456 { 457 # __MIN_PERL__ is this at the time of this commit. This is the 458 # earliest these have been tested to at the time of the commit, but 459 # likely go back further. 460 $return{$_} = '5.003_07'; 461 } 462 for (qw(_pMY_CXT pMY_CXT_)) { 463 $return{$_} = '5.9.0'; 464 } 465 for (qw(PERLIO_FUNCS_DECL)) { 466 $return{$_} = '5.9.3'; 467 } 468 for (qw(XopDISABLE XopENABLE XopENTRY XopENTRYCUSTOM XopENTRY_set)) { 469 $return{$_} = '5.13.7'; 470 } 471 for (qw(XS_EXTERNAL XS_INTERNAL)) { 472 $return{$_} = '5.15.2'; 473 } 474 475 return \%return; 476} 477 478sub normalize_prototype # So that they can be compared more easily 479{ 480 my $proto = shift; 481 $proto =~ s/\s* \* \s* / * /xg; 482 return $proto; 483} 484 485sub make_prototype 486{ 487 my $f = shift; 488 my @args = map { "@$_" } @{$f->{args}}; 489 my $proto; 490 my $pTHX_ = exists $f->{flags}{T} ? "" : "pTHX_ "; 491 $proto = "$f->{ret} $f->{name}" . "($pTHX_" . join(', ', @args) . ')'; 492 return normalize_prototype($proto); 493} 4941; 495