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