dist/Devel-PPPort/PPPort_pm.PL

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