dist/Devel-PPPort/PPPort_pm.PL

   1 ################################################################################
   2 #
   3 #  PPPort_pm.PL -- generate PPPort.pm
   4 #
   5 # Set the environment variable DPPP_CHECK_LEVEL to more than zero for some
   6 # extra checking. 1 or 2 currently
   7
   8 ################################################################################
   9 #
  10 #  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
  11 #               Copyright (C) 2018, The perl5 porters
  12 #  Version 2.x, Copyright (C) 2001, Paul Marquess.
  13 #  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
  14 #
  15 #  This program is free software; you can redistribute it and/or
  16 #  modify it under the same terms as Perl itself.
  17 #
  18 ################################################################################
  19
  20 use strict;
  21 BEGIN { $^W = 1; }
  22 require "./parts/ppptools.pl";
  23
  24 my $INCLUDE = 'parts/inc';
  25 my $DPPP = 'DPPP_';
  26
  27 my %embed = map { ( $_->{name} => $_ ) }
  28             parse_embed(qw(parts/embed.fnc parts/apidoc.fnc parts/ppport.fnc));
  29
  30 my(%provides, %prototypes, %explicit);
  31
  32 my $data = do { local $/; <DATA> };
  33
  34 # Call include(file, params) for every line that begins with %include
  35 $data =~ s{^\%(include)\s+(\w+)((?:[^\S\r\n]+.*?)?)\s*$}
  36           {eval "$1('$2', $3)" or die $@}gem;
  37
  38 $data = expand($data);
  39
  40 my @api = sort { lc $a cmp lc $b or $a cmp $b } keys %provides;
  41
  42 $data =~ s{^(.*)__PROVIDED_API__(\s*?)^}
  43           {join '', map "$1$_\n", @api}gem;
  44
  45 {
  46   my $len = 0;
  47   for (keys %explicit) {
  48     length > $len and $len = length;
  49   }
  50   my $format = sprintf '%%-%ds  %%-%ds  %%s', $len+2, $len+5;
  51   $len = 3*$len + 23;
  52
  53 $data =~ s!^(.*)__EXPLICIT_API__(\s*?)^!
  54            sprintf("$1$format\n", 'Function / Variable', 'Static Request', 'Global Request') .
  55            $1 . '-'x$len . "\n" .
  56            join('', map { sprintf "$1$format\n", $explicit{$_} eq 'var' ? $_ : "$_()", "NEED_$_", "NEED_${_}_GLOBAL" }
  57                     sort keys %explicit)
  58           !gem;
  59 }
  60
  61 my %raw_base = %{&parse_todo('parts/base')};
  62 my %raw_todo = %{&parse_todo('parts/todo')};
  63
  64 my %todo;
  65 for (keys %raw_todo) {
  66   push @{$todo{$raw_todo{$_}}}, $_;
  67 }
  68
  69 # check consistency
  70 for (@api) {
  71   if (exists $raw_todo{$_} and exists $raw_base{$_}) {
  72     if ($raw_base{$_} eq $raw_todo{$_}) {
  73       warn "$INCLUDE/$provides{$_} provides $_, which is still marked "
  74            . "todo for " . format_version($raw_todo{$_}) . "\n";
  75     }
  76     else {
  77       check(2, "$_ was ported back to " . format_version($raw_todo{$_}) .
  78                " (baseline revision: " . format_version($raw_base{$_}) . ").");
  79     }
  80   }
  81 }
  82
  83 my @perl_api;
  84 for (keys %provides) {
  85   next if /^Perl_(.*)/ && exists $embed{$1};
  86   next if exists $embed{$_};
  87   push @perl_api, $_;
  88   check(2, "No API definition for provided element $_ found.");
  89 }
  90
  91 push @perl_api, keys %embed;
  92
  93 for (@perl_api) {
  94   if (exists $provides{$_} && !exists $raw_base{$_}) {
  95     check(2, "Mmmh, $_ doesn't seem to need backporting.");
  96   }
  97   my $line = "$_|" . (exists $provides{$_} && exists $raw_base{$_} ? $raw_base{$_} : '') . '|';
  98   $line .= ($raw_todo{$_} || '') . '|';
  99   $line .= 'p' if exists $provides{$_};
 100   if (exists $embed{$_}) {
 101     my $e = $embed{$_};
 102     if (exists $e->{flags}{p}) {    # Has 'Perl_' prefix
 103       my $args = $e->{args};
 104       $line .= 'v' if @$args && $args->[-1][0] eq '...';
 105     }
 106     $line .= 'n' if exists $e->{flags}{T};  # No thread context parameter
 107   }
 108   $_ = $line;
 109 }
 110
 111 $data =~ s/^([\t ]*)__PERL_API__(\s*?)$/
 112            join "\n", map "$1$_", sort @perl_api
 113           /gem;
 114
 115 my $undocumented = "(undocumented)";
 116
 117 my @todo;
 118 for (reverse sort keys %todo) {
 119   my $ver = format_version($_);
 120   my $todo = "=item perl $ver\n\n";
 121   for (sort @{$todo{$_}}) {
 122     $todo .= "  $_";
 123     $todo .= "  (DEPRECATED)" if  $embed{$_}->{flags}{D};
 124     $todo .= "  (marked experimental)" if $embed{$_}->{flags}{x};
 125     $todo .= "  $undocumented" unless $embed{$_}->{flags}{d};
 126     $todo .= "\n";
 127   }
 128   push @todo, $todo;
 129 }
 130
 131 $data =~ s{^__UNSUPPORTED_API__(\s*?)^}
 132           {join "\n", @todo}gem;
 133
 134 $data =~ s{__MIN_PERL__}{5.003}g;
 135 $data =~ s{__MAX_PERL__}{5.30}g;
 136
 137 open FH, ">PPPort.pm" or die "PPPort.pm: $!\n";
 138 print FH $data;
 139 close FH;
 140
 141 exit 0;
 142
 143 sub include
 144 {
 145   my($file, $opt) = @_;
 146
 147   print "including $file\n";
 148
 149   my $data = parse_partspec("$INCLUDE/$file");
 150
 151   for (@{$data->{provides}}) {
 152     if (exists $provides{$_}) {
 153       if ($provides{$_} ne $file) {
 154         warn "$file: $_ already provided by $provides{$_}\n";
 155       }
 156     }
 157     else {
 158       $provides{$_} = $file;
 159     }
 160   }
 161
 162   for (keys %{$data->{prototypes}}) {
 163     $prototypes{$_} = $data->{prototypes}{$_};
 164     $prototypes{$_} = normalize_prototype($data->{prototypes}{$_});
 165     $data->{implementation} =~ s/^$_(?=\s*\()/$DPPP(my_$_)/mg;
 166   }
 167
 168   my $out = $data->{implementation};
 169
 170   if (exists $opt->{indent}) {
 171     $out =~ s/^/$opt->{indent}/gm;
 172   }
 173
 174   return $out;
 175 }
 176
 177 sub expand
 178 {
 179   my $code = shift;
 180   $code =~ s{^(\s*#\s*(?:el)?if\s+)(.*)$}{$1.expand_pp_expressions($2)}gem;
 181   $code =~ s{^\s*
 182               __UNDEFINED__
 183               \s+
 184               (
 185                 ( \w+ )
 186                 (?: \( [^)]* \) )?
 187               )
 188               [^\r\n\S]*
 189               (
 190                 (?:[^\r\n\\]|\\[^\r\n])*
 191                 (?:
 192                   \\
 193                   (?:\r\n|[\r\n])
 194                   (?:[^\r\n\\]|\\[^\r\n])*
 195                 )*
 196               )
 197             \s*$}
 198             {expand_undefined($2, $1, $3)}gemx;
 199   $code =~ s{^([^\S\r\n]*)__NEED_VAR__\s+(.*?)\s+(\w+)(?:\s*=\s*([^;]+?))?\s*;\s*$}
 200             {expand_need_var($1, $3, $2, $4)}gem;
 201   $code =~ s{^([^\S\r\n]*)__NEED_DUMMY_VAR__\s+(.*?)\s+(\w+)(?:\s*=\s*([^;]+?))?\s*;\s*$}
 202             {expand_need_dummy_var($1, $3, $2, $4)}gem;
 203   return $code;
 204 }
 205
 206 sub expand_need_var
 207 {
 208   my($indent, $var, $type, $init) = @_;
 209
 210   $explicit{$var} = 'var';
 211
 212   my $myvar = "$DPPP(my_$var)";
 213   $init = defined $init ? " = $init" : "";
 214
 215   my $code = <<ENDCODE;
 216 #if defined(NEED_$var)
 217 static $type $myvar$init;
 218 #elif defined(NEED_${var}_GLOBAL)
 219 $type $myvar$init;
 220 #else
 221 extern $type $myvar;
 222 #endif
 223 #define $var $myvar
 224 ENDCODE
 225
 226   $code =~ s/^/$indent/mg;
 227
 228   return $code;
 229 }
 230
 231 sub expand_need_dummy_var
 232 {
 233   my($indent, $var, $type, $init) = @_;
 234
 235   $explicit{$var} = 'var';
 236
 237   my $myvar = "$DPPP(dummy_$var)";
 238   $init = defined $init ? " = $init" : "";
 239
 240   my $code = <<ENDCODE;
 241 #if defined(NEED_$var)
 242 static $type $myvar$init;
 243 #elif defined(NEED_${var}_GLOBAL)
 244 $type $myvar$init;
 245 #else
 246 extern $type $myvar;
 247 #endif
 248 ENDCODE
 249
 250   $code =~ s/^/$indent/mg;
 251
 252   return $code;
 253 }
 254
 255 sub expand_undefined
 256 {
 257   my($macro, $withargs, $def) = @_;
 258   my $rv = "#ifndef $macro\n#  define ";
 259
 260   if (defined $def && $def =~ /\S/) {
 261     $rv .= sprintf "%-30s %s", $withargs, $def;
 262   }
 263   else {
 264     $rv .= $withargs;
 265   }
 266
 267   $rv .= "\n#endif\n";
 268
 269   return $rv;
 270 }
 271
 272 sub expand_pp_expressions
 273 {
 274   my $pp = shift;
 275   $pp =~ s/\{([^\}]+)\}/expand_pp_expr($1)/ge;
 276   return $pp;
 277 }
 278
 279 sub expand_pp_expr
 280 {
 281   my $expr = shift;
 282
 283   if ($expr =~ /^\s*need\s+(\w+)\s*$/i) {
 284     my $func = $1;
 285     my $e = $embed{$func} or die "unknown API function '$func' in NEED\n";
 286     my $proto = make_prototype($e);
 287     if (exists $prototypes{$func}) {
 288       if (compare_prototypes($proto, $prototypes{$func})) {
 289         check(1, "differing prototypes for $func:\n  API: $proto\n  PPP: $prototypes{$func}");
 290         $proto = $prototypes{$func};
 291       }
 292     }
 293     else {
 294       warn "found no prototype for $func\n";;
 295     }
 296
 297     $explicit{$func} = 'func';
 298
 299     $proto =~ s/\b$func(?=\s*\()/$DPPP(my_$func)/;
 300     my $embed = make_embed($e);
 301
 302     return "defined(NEED_$func)\n"
 303          . "static $proto;\n"
 304          . "static\n"
 305          . "#else\n"
 306          . "extern $proto;\n"
 307          . "#endif\n"
 308          . "\n"
 309          . "#if defined(NEED_$func) || defined(NEED_${func}_GLOBAL)\n"
 310          . "\n"
 311          . "$embed\n";
 312   }
 313
 314   die "cannot expand preprocessor expression '$expr'\n";
 315 }
 316
 317 sub make_embed
 318 {
 319   my $f = shift;
 320   my $n = $f->{name};
 321   my $a = do { my $x = 'a'; join ',', map { $x++ } 1 .. @{$f->{args}} };
 322   my $lastarg = ${$f->{args}}[-1];
 323
 324   if ($f->{flags}{T}) {
 325     if ($f->{flags}{p}) {
 326       return "#define $n $DPPP(my_$n)\n" .
 327              "#define Perl_$n $DPPP(my_$n)";
 328     }
 329     else {
 330       return "#define $n $DPPP(my_$n)";
 331     }
 332   }
 333   else {
 334     my $undef = <<UNDEF;
 335 #ifdef $n
 336 #  undef $n
 337 #endif
 338 UNDEF
 339     if ($f->{flags}{p}) {
 340       if ($f->{flags}{f}) {
 341         return "#define Perl_$n $DPPP(my_$n)";
 342       }
 343       elsif (@$lastarg && $lastarg->[0] =~ /\.\.\./) {
 344         return $undef . "#define $n $DPPP(my_$n)\n" .
 345                         "#define Perl_$n $DPPP(my_$n)";
 346       }
 347       else {
 348         return $undef . "#define $n($a) $DPPP(my_$n)(aTHX_ $a)\n" .
 349                         "#define Perl_$n $DPPP(my_$n)";
 350       }
 351     }
 352     else {
 353       return $undef . "#define $n($a) $DPPP(my_$n)(aTHX_ $a)";
 354     }
 355   }
 356 }
 357
 358 sub check
 359 {
 360   my $level = shift;
 361
 362   if (exists $ENV{DPPP_CHECK_LEVEL} and $ENV{DPPP_CHECK_LEVEL} >= $level) {
 363     print STDERR @_, "\n";
 364   }
 365 }
 366
 367 __DATA__
 368 ################################################################################
 369 #
 370 #  !!!!! Do NOT edit this file directly! -- Edit PPPort_pm.PL instead. !!!!!
 371 #
 372 #  This file was automatically generated from the definition files in the
 373 #  parts/inc/ subdirectory by PPPort_pm.PL. To learn more about how all this
 374 #  works, please read the F<HACKERS> file that came with this distribution.
 375 #
 376 ################################################################################
 377 #
 378 #  Perl/Pollution/Portability
 379 #
 380 ################################################################################
 381 #
 382 #  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
 383 #               Copyright (C) 2018, The perl5 porters
 384 #  Version 2.x, Copyright (C) 2001, Paul Marquess.
 385 #  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
 386 #
 387 #  This program is free software; you can redistribute it and/or
 388 #  modify it under the same terms as Perl itself.
 389 #
 390 ################################################################################
 391
 392 =head1 NAME
 393
 394 Devel::PPPort - Perl/Pollution/Portability
 395
 396 =head1 SYNOPSIS
 397
 398   Devel::PPPort::WriteFile();   # defaults to ./ppport.h
 399   Devel::PPPort::WriteFile('someheader.h');
 400
 401   # Same as above but retrieve contents rather than write file
 402   my $contents = Devel::PPPort::GetFileContents();
 403   my $contents = Devel::PPPort::GetFileContents('someheader.h');
 404
 405 =head1 Start using Devel::PPPort for XS projects
 406
 407   $ cpan Devel::PPPort
 408   $ perl -MDevel::PPPort -e'Devel::PPPort::WriteFile'
 409   $ perl ppport.h --compat-version=5.6.1 --patch=diff.patch *.xs
 410   $ patch -p0 < diff.patch
 411   $ echo ppport.h >>MANIFEST
 412
 413 =head1 DESCRIPTION
 414
 415 Perl's API has changed over time, gaining new features, new functions,
 416 increasing its flexibility, and reducing the impact on the C namespace
 417 environment (reduced pollution). The header file written by this module,
 418 typically F<ppport.h>, attempts to bring some of the newer Perl API
 419 features to older versions of Perl, so that you can worry less about
 420 keeping track of old releases, but users can still reap the benefit.
 421
 422 C<Devel::PPPort> contains two functions, C<WriteFile> and C<GetFileContents>.
 423 C<WriteFile>'s only purpose is to write the F<ppport.h> C header file.
 424 This file contains a series of macros and, if explicitly requested, functions
 425 that allow XS modules to be built using older versions of Perl. Currently,
 426 Perl versions from __MIN_PERL__ to __MAX_PERL__ are supported.
 427
 428 C<GetFileContents> can be used to retrieve the file contents rather than
 429 writing it out.
 430
 431 This module is used by C<h2xs> to write the file F<ppport.h>.
 432
 433 =head2 Why use ppport.h?
 434
 435 You should use F<ppport.h> in modern code so that your code will work
 436 with the widest range of Perl interpreters possible, without significant
 437 additional work.
 438
 439 You should attempt to get older code to fully use F<ppport.h>, because the
 440 reduced pollution of newer Perl versions is an important thing. It's so
 441 important that the old polluting ways of original Perl modules will not be
 442 supported very far into the future, and your module will almost certainly
 443 break! By adapting to it now, you'll gain compatibility and a sense of
 444 having done the electronic ecology some good.
 445
 446 =head2 How to use ppport.h
 447
 448 Don't direct the users of your module to download C<Devel::PPPort>.
 449 They are most probably not XS writers. Also, don't make F<ppport.h>
 450 optional. Rather, just take the most recent copy of F<ppport.h> that
 451 you can find (e.g. by generating it with the latest C<Devel::PPPort>
 452 release from CPAN), copy it into your project, adjust your project to
 453 use it, and distribute the header along with your module.
 454
 455 =head2 Running ppport.h
 456
 457 But F<ppport.h> is more than just a C header. It's also a Perl script
 458 that can check your source code. It will suggest hints and portability
 459 notes, and can even make suggestions on how to change your code. You
 460 can run it like any other Perl program:
 461
 462     perl ppport.h [options] [files]
 463
 464 It also has embedded documentation, so you can use
 465
 466     perldoc ppport.h
 467
 468 to find out more about how to use it.
 469
 470 =head1 FUNCTIONS
 471
 472 =head2 WriteFile
 473
 474 C<WriteFile> takes one optional argument. When called with one
 475 argument, it expects to be passed a filename. When called with
 476 no arguments, it defaults to the filename F<ppport.h>.
 477
 478 The function returns a true value if the file was written successfully.
 479 Otherwise it returns a false value.
 480
 481 =head2 GetFileContents
 482
 483 C<GetFileContents> behaves like C<WriteFile> above, but returns the contents
 484 of the would-be file rather than writing it out.
 485
 486 =head1 COMPATIBILITY
 487
 488 F<ppport.h> supports Perl versions from __MIN_PERL__ to __MAX_PERL__
 489 in threaded and non-threaded configurations.
 490
 491 =head2 Provided Perl compatibility API
 492
 493 The header file written by this module, typically F<ppport.h>, provides
 494 access to the following elements of the Perl API that are not otherwise
 495 available in Perl releases older than when the elements were first introduced.
 496 (Many of these are not supported all the way back to __MIN_PERL__;
 497 see L</Perl API not supported by ppport.h back to __MIN_PERL__> for details.)
 498
 499     __PROVIDED_API__
 500
 501 =head2 Perl API not supported by ppport.h back to __MIN_PERL__
 502
 503 There is still a big part of the API not fully supported by F<ppport.h>.
 504 This can be because it doesn't make sense to back-port that part of the API,
 505 or simply because it hasn't been implemented yet. Patches welcome!  Some
 506 elements are ported backward for some releases, but not all the way to
 507 __MIN_PERL__.
 508
 509 Below is a list of the API that isn't currently supported back to
 510 __MIN_PERL__, sorted by the version of Perl below which it is unsupported.
 511 Only things you should be using are included in the list, so not listed are
 512 deprecated and experimental functions.
 513
 514 Some of the entries are marked as "undocumented".  This means that they
 515 aren't necessarily considered stable, and could be changed or removed in some
 516 future release without warning.  It is therefore a bad idea to use them
 517 without further checking.  It could be that these are considered to be for
 518 perl core use only; or it could be, though, that C<Devel::PPPort> doesn't know
 519 where to find their documentation, or that it's just an oversight that they
 520 haven't been documented.  If you want to use one, and potentially have it
 521 backported, first send mail to L<mailto:perl5-porters@perl.org>.
 522
 523 =over 4
 524
 525 __UNSUPPORTED_API__
 526
 527 =back
 528
 529 =head1 BUGS
 530
 531 If you find any bugs, C<Devel::PPPort> doesn't seem to build on your
 532 system, or any of its tests fail, please send a bug report to
 533 L<perlbug@perl.org|mailto:perlbug@perl.org>.
 534
 535 =head1 AUTHORS
 536
 537 =over 2
 538
 539 =item *
 540
 541 Version 1.x of Devel::PPPort was written by Kenneth Albanowski.
 542
 543 =item *
 544
 545 Version 2.x was ported to the Perl core by Paul Marquess.
 546
 547 =item *
 548
 549 Version 3.x was ported back to CPAN by Marcus Holland-Moritz.
 550
 551 =item *
 552
 553 Versions >= 3.22 are maintained by perl5 porters
 554
 555 =back
 556
 557 =head1 COPYRIGHT
 558
 559 Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
 560
 561              Copyright (C) 2018, The perl5 porters
 562
 563 Version 2.x, Copyright (C) 2001, Paul Marquess.
 564
 565 Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
 566
 567 This program is free software; you can redistribute it and/or
 568 modify it under the same terms as Perl itself.
 569
 570 =head1 SEE ALSO
 571
 572 See L<h2xs>, L<ppport.h>.
 573
 574 =cut
 575
 576 package Devel::PPPort;
 577
 578 use strict;
 579 use vars qw($VERSION $data);
 580
 581 $VERSION = '3.55';
 582
 583 sub _init_data
 584 {
 585   $data = do { local $/; <DATA> };
 586   my $pkg = 'Devel::PPPort';
 587   $data =~ s/__PERL_VERSION__/$]/g;
 588   $data =~ s/__VERSION__/$VERSION/g;
 589   $data =~ s/__PKG__/$pkg/g;
 590   $data =~ s/^\|>//gm;
 591 }
 592
 593 sub GetFileContents {
 594   my $file = shift || 'ppport.h';
 595   defined $data or _init_data();
 596   my $copy = $data;
 597   $copy =~ s/\bppport\.h\b/$file/g;
 598
 599   return $copy;
 600 }
 601
 602 sub WriteFile
 603 {
 604   my $file = shift || 'ppport.h';
 605   my $data = GetFileContents($file);
 606   open F, ">$file" or return undef;
 607   print F $data;
 608   close F;
 609
 610   return 1;
 611 }
 612
 613 1;
 614
 615 __DATA__
 616 #if 0
 617 <<'SKIP';
 618 #endif
 619 /*
 620 ----------------------------------------------------------------------
 621
 622     ppport.h -- Perl/Pollution/Portability Version __VERSION__
 623
 624     Automatically created by __PKG__ running under perl __PERL_VERSION__.
 625
 626     Do NOT edit this file directly! -- Edit PPPort_pm.PL and the
 627     includes in parts/inc/ instead.
 628
 629     Use 'perldoc ppport.h' to view the documentation below.
 630
 631 ----------------------------------------------------------------------
 632
 633 SKIP
 634
 635 %include ppphdoc { indent => '|>' }
 636
 637 %include ppphbin
 638
 639 __DATA__
 640 */
 641
 642 #ifndef _P_P_PORTABILITY_H_
 643 #define _P_P_PORTABILITY_H_
 644
 645 #ifndef DPPP_NAMESPACE
 646 #  define DPPP_NAMESPACE DPPP_
 647 #endif
 648
 649 #define DPPP_CAT2(x,y) CAT2(x,y)
 650 #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name)
 651
 652 %include version
 653
 654 %include threads
 655
 656 %include limits
 657
 658 %include variables
 659
 660 %include newCONSTSUB
 661
 662 %include magic_defs
 663
 664 %include misc
 665
 666 %include sv_xpvf
 667
 668 %include SvPV
 669
 670 %include warn
 671
 672 %include format
 673
 674 %include uv
 675
 676 %include memory
 677
 678 %include mess
 679
 680 %include mPUSH
 681
 682 %include call
 683
 684 %include newRV
 685
 686 %include MY_CXT
 687
 688 %include SvREFCNT
 689
 690 %include newSV_type
 691
 692 %include newSVpv
 693
 694 %include Sv_set
 695
 696 %include shared_pv
 697
 698 %include HvNAME
 699
 700 %include gv
 701
 702 %include pvs
 703
 704 %include magic
 705
 706 %include cop
 707
 708 %include grok
 709
 710 %include snprintf
 711
 712 %include sprintf
 713
 714 %include exception
 715
 716 %include strlfuncs
 717
 718 %include utf8
 719
 720 %include pv_tools
 721
 722 #endif /* _P_P_PORTABILITY_H_ */
 723
 724 /* End of File ppport.h */