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