ext/Devel/PPPort/PPPort_pm.PL

   1 ################################################################################
   2 #
   3 #  PPPort_pm.PL -- generate PPPort.pm
   4 #
   5 ################################################################################
   6 #
   7 #  $Revision: 64 $
   8 #  $Author: mhx $
   9 #  $Date: 2009/01/18 14:10:49 +0100 $
  10 #
  11 ################################################################################
  12 #
  13 #  Version 3.x, Copyright (C) 2004-2009, Marcus Holland-Moritz.
  14 #  Version 2.x, Copyright (C) 2001, Paul Marquess.
  15 #  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
  16 #
  17 #  This program is free software; you can redistribute it and/or
  18 #  modify it under the same terms as Perl itself.
  19 #
  20 ################################################################################
  21
  22 use strict;
  23 $^W = 1;
  24 require "parts/ppptools.pl";
  25
  26 my $INCLUDE = 'parts/inc';
  27 my $DPPP = 'DPPP_';
  28
  29 my %embed = map { ( $_->{name} => $_ ) }
  30             parse_embed(qw(parts/embed.fnc parts/apidoc.fnc parts/ppport.fnc));
  31
  32 my(%provides, %prototypes, %explicit);
  33
  34 my $data = do { local $/; <DATA> };
  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 } 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}) {
 103       my $args = $e->{args};
 104       $line .= 'v' if @$args && $args->[-1][0] eq '...';
 105     }
 106     $line .= 'n' if exists $e->{flags}{n};
 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.10.0}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     $data->{implementation} =~ s/^$_(?=\s*\()/$DPPP(my_$_)/mg;
 159   }
 160
 161   my $out = $data->{implementation};
 162
 163   if (exists $opt->{indent}) {
 164     $out =~ s/^/$opt->{indent}/gm;
 165   }
 166
 167   return $out;
 168 }
 169
 170 sub expand
 171 {
 172   my $code = shift;
 173   $code =~ s{^(\s*#\s*(?:el)?if\s+)(.*)$}{$1.expand_pp_expressions($2)}gem;
 174   $code =~ s{^\s*
 175               __UNDEFINED__
 176               \s+
 177               (
 178                 ( \w+ )
 179                 (?: \( [^)]* \) )?
 180               )
 181               [^\r\n\S]*
 182               (
 183                 (?:[^\r\n\\]|\\[^\r\n])*
 184                 (?:
 185                   \\
 186                   (?:\r\n|[\r\n])
 187                   (?:[^\r\n\\]|\\[^\r\n])*
 188                 )*
 189               )
 190             \s*$}
 191             {expand_undefined($2, $1, $3)}gemx;
 192   $code =~ s{^([^\S\r\n]*)__NEED_VAR__\s+(.*?)\s+(\w+)(?:\s*=\s*([^;]+?))?\s*;\s*$}
 193             {expand_need_var($1, $3, $2, $4)}gem;
 194   $code =~ s{^([^\S\r\n]*)__NEED_DUMMY_VAR__\s+(.*?)\s+(\w+)(?:\s*=\s*([^;]+?))?\s*;\s*$}
 195             {expand_need_dummy_var($1, $3, $2, $4)}gem;
 196   return $code;
 197 }
 198
 199 sub expand_need_var
 200 {
 201   my($indent, $var, $type, $init) = @_;
 202
 203   $explicit{$var} = 'var';
 204
 205   my $myvar = "$DPPP(my_$var)";
 206   $init = defined $init ? " = $init" : "";
 207
 208   my $code = <<ENDCODE;
 209 #if defined(NEED_$var)
 210 static $type $myvar$init;
 211 #elif defined(NEED_${var}_GLOBAL)
 212 $type $myvar$init;
 213 #else
 214 extern $type $myvar;
 215 #endif
 216 #define $var $myvar
 217 ENDCODE
 218
 219   $code =~ s/^/$indent/mg;
 220
 221   return $code;
 222 }
 223
 224 sub expand_need_dummy_var
 225 {
 226   my($indent, $var, $type, $init) = @_;
 227
 228   $explicit{$var} = 'var';
 229
 230   my $myvar = "$DPPP(dummy_$var)";
 231   $init = defined $init ? " = $init" : "";
 232
 233   my $code = <<ENDCODE;
 234 #if defined(NEED_$var)
 235 static $type $myvar$init;
 236 #elif defined(NEED_${var}_GLOBAL)
 237 $type $myvar$init;
 238 #else
 239 extern $type $myvar;
 240 #endif
 241 ENDCODE
 242
 243   $code =~ s/^/$indent/mg;
 244
 245   return $code;
 246 }
 247
 248 sub expand_undefined
 249 {
 250   my($macro, $withargs, $def) = @_;
 251   my $rv = "#ifndef $macro\n#  define ";
 252
 253   if (defined $def && $def =~ /\S/) {
 254     $rv .= sprintf "%-30s %s", $withargs, $def;
 255   }
 256   else {
 257     $rv .= $withargs;
 258   }
 259
 260   $rv .= "\n#endif\n";
 261
 262   return $rv;
 263 }
 264
 265 sub expand_pp_expressions
 266 {
 267   my $pp = shift;
 268   $pp =~ s/\{([^\}]+)\}/expand_pp_expr($1)/ge;
 269   return $pp;
 270 }
 271
 272 sub expand_pp_expr
 273 {
 274   my $expr = shift;
 275
 276   if ($expr =~ /^\s*need\s+(\w+)\s*$/i) {
 277     my $func = $1;
 278     my $e = $embed{$func} or die "unknown API function '$func' in NEED\n";
 279     my $proto = make_prototype($e);
 280     if (exists $prototypes{$func}) {
 281       if (compare_prototypes($proto, $prototypes{$func})) {
 282         check(1, "differing prototypes for $func:\n  API: $proto\n  PPP: $prototypes{$func}");
 283         $proto = $prototypes{$func};
 284       }
 285     }
 286     else {
 287       warn "found no prototype for $func\n";;
 288     }
 289
 290     $explicit{$func} = 'func';
 291
 292     $proto =~ s/\b$func(?=\s*\()/$DPPP(my_$func)/;
 293     my $embed = make_embed($e);
 294
 295     return "defined(NEED_$func)\n"
 296          . "static $proto;\n"
 297          . "static\n"
 298          . "#else\n"
 299          . "extern $proto;\n"
 300          . "#endif\n"
 301          . "\n"
 302          . "$embed\n"
 303          . "\n"
 304          . "#if defined(NEED_$func) || defined(NEED_${func}_GLOBAL)";
 305   }
 306
 307   die "cannot expand preprocessor expression '$expr'\n";
 308 }
 309
 310 sub make_embed
 311 {
 312   my $f = shift;
 313   my $n = $f->{name};
 314   my $a = do { my $x = 'a'; join ',', map { $x++ } 1 .. @{$f->{args}} };
 315   my $lastarg = ${$f->{args}}[-1];
 316
 317   if ($f->{flags}{n}) {
 318     if ($f->{flags}{p}) {
 319       return "#define $n $DPPP(my_$n)\n" .
 320              "#define Perl_$n $DPPP(my_$n)";
 321     }
 322     else {
 323       return "#define $n $DPPP(my_$n)";
 324     }
 325   }
 326   else {
 327     my $undef = <<UNDEF;
 328 #ifdef $n
 329 #  undef $n
 330 #endif
 331 UNDEF
 332     if ($f->{flags}{p}) {
 333       if ($f->{flags}{f}) {
 334         return "#define Perl_$n $DPPP(my_$n)";
 335       }
 336       elsif (@$lastarg && $lastarg->[0] =~ /\.\.\./) {
 337         return $undef . "#define $n $DPPP(my_$n)\n" .
 338                         "#define Perl_$n $DPPP(my_$n)";
 339       }
 340       else {
 341         return $undef . "#define $n($a) $DPPP(my_$n)(aTHX_ $a)\n" .
 342                         "#define Perl_$n $DPPP(my_$n)";
 343       }
 344     }
 345     else {
 346       return $undef . "#define $n($a) $DPPP(my_$n)(aTHX_ $a)";
 347     }
 348   }
 349 }
 350
 351 sub check
 352 {
 353   my $level = shift;
 354
 355   if (exists $ENV{DPPP_CHECK_LEVEL} and $ENV{DPPP_CHECK_LEVEL} >= $level) {
 356     print STDERR @_, "\n";
 357   }
 358 }
 359
 360 __DATA__
 361 ################################################################################
 362 #
 363 #  !!!!! Do NOT edit this file directly! -- Edit PPPort_pm.PL instead. !!!!!
 364 #
 365 #  This file was automatically generated from the definition files in the
 366 #  parts/inc/ subdirectory by PPPort_pm.PL. To learn more about how all this
 367 #  works, please read the F<HACKERS> file that came with this distribution.
 368 #
 369 ################################################################################
 370 #
 371 #  Perl/Pollution/Portability
 372 #
 373 ################################################################################
 374 #
 375 #  $Revision: 64 $
 376 #  $Author: mhx $
 377 #  $Date: 2009/01/18 14:10:49 +0100 $
 378 #
 379 ################################################################################
 380 #
 381 #  Version 3.x, Copyright (C) 2004-2009, Marcus Holland-Moritz.
 382 #  Version 2.x, Copyright (C) 2001, Paul Marquess.
 383 #  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
 384 #
 385 #  This program is free software; you can redistribute it and/or
 386 #  modify it under the same terms as Perl itself.
 387 #
 388 ################################################################################
 389
 390 =head1 NAME
 391
 392 Devel::PPPort - Perl/Pollution/Portability
 393
 394 =head1 SYNOPSIS
 395
 396     Devel::PPPort::WriteFile();   # defaults to ./ppport.h
 397     Devel::PPPort::WriteFile('someheader.h');
 398
 399 =head1 DESCRIPTION
 400
 401 Perl's API has changed over time, gaining new features, new functions,
 402 increasing its flexibility, and reducing the impact on the C namespace
 403 environment (reduced pollution). The header file written by this module,
 404 typically F<ppport.h>, attempts to bring some of the newer Perl API
 405 features to older versions of Perl, so that you can worry less about
 406 keeping track of old releases, but users can still reap the benefit.
 407
 408 C<Devel::PPPort> contains a single function, called C<WriteFile>. Its
 409 only purpose is to write the F<ppport.h> C header file. This file
 410 contains a series of macros and, if explicitly requested, functions that
 411 allow XS modules to be built using older versions of Perl. Currently,
 412 Perl versions from __MIN_PERL__ to __MAX_PERL__ are supported.
 413
 414 This module is used by C<h2xs> to write the file F<ppport.h>.
 415
 416 =head2 Why use ppport.h?
 417
 418 You should use F<ppport.h> in modern code so that your code will work
 419 with the widest range of Perl interpreters possible, without significant
 420 additional work.
 421
 422 You should attempt older code to fully use F<ppport.h>, because the
 423 reduced pollution of newer Perl versions is an important thing. It's so
 424 important that the old polluting ways of original Perl modules will not be
 425 supported very far into the future, and your module will almost certainly
 426 break! By adapting to it now, you'll gain compatibility and a sense of
 427 having done the electronic ecology some good.
 428
 429 =head2 How to use ppport.h
 430
 431 Don't direct the users of your module to download C<Devel::PPPort>.
 432 They are most probably no XS writers. Also, don't make F<ppport.h>
 433 optional. Rather, just take the most recent copy of F<ppport.h> that
 434 you can find (e.g. by generating it with the latest C<Devel::PPPort>
 435 release from CPAN), copy it into your project, adjust your project to
 436 use it, and distribute the header along with your module.
 437
 438 =head2 Running ppport.h
 439
 440 But F<ppport.h> is more than just a C header. It's also a Perl script
 441 that can check your source code. It will suggest hints and portability
 442 notes, and can even make suggestions on how to change your code. You
 443 can run it like any other Perl program:
 444
 445     perl ppport.h [options] [files]
 446
 447 It also has embedded documentation, so you can use
 448
 449     perldoc ppport.h
 450
 451 to find out more about how to use it.
 452
 453 =head1 FUNCTIONS
 454
 455 =head2 WriteFile
 456
 457 C<WriteFile> takes one optional argument. When called with one
 458 argument, it expects to be passed a filename. When called with
 459 no arguments, it defaults to the filename F<ppport.h>.
 460
 461 The function returns a true value if the file was written successfully.
 462 Otherwise it returns a false value.
 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 use the CPAN Request Tracker
 496 at L<http://rt.cpan.org/> to create a ticket for the module.
 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 =back
 515
 516 =head1 COPYRIGHT
 517
 518 Version 3.x, Copyright (C) 2004-2009, Marcus Holland-Moritz.
 519
 520 Version 2.x, Copyright (C) 2001, Paul Marquess.
 521
 522 Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
 523
 524 This program is free software; you can redistribute it and/or
 525 modify it under the same terms as Perl itself.
 526
 527 =head1 SEE ALSO
 528
 529 See L<h2xs>, L<ppport.h>.
 530
 531 =cut
 532
 533 package Devel::PPPort;
 534
 535 use strict;
 536 use vars qw($VERSION $data);
 537
 538 $VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.16 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
 539
 540 sub _init_data
 541 {
 542   $data = do { local $/; <DATA> };
 543   my $pkg = 'Devel::PPPort';
 544   $data =~ s/__PERL_VERSION__/$]/g;
 545   $data =~ s/__VERSION__/$VERSION/g;
 546   $data =~ s/__PKG__/$pkg/g;
 547   $data =~ s/^\|>//gm;
 548 }
 549
 550 sub WriteFile
 551 {
 552   my $file = shift || 'ppport.h';
 553   defined $data or _init_data();
 554   my $copy = $data;
 555   $copy =~ s/\bppport\.h\b/$file/g;
 556
 557   open F, ">$file" or return undef;
 558   print F $copy;
 559   close F;
 560
 561   return 1;
 562 }
 563
 564 1;
 565
 566 __DATA__
 567 #if 0
 568 <<'SKIP';
 569 #endif
 570 /*
 571 ----------------------------------------------------------------------
 572
 573     ppport.h -- Perl/Pollution/Portability Version __VERSION__
 574
 575     Automatically created by __PKG__ running under perl __PERL_VERSION__.
 576
 577     Do NOT edit this file directly! -- Edit PPPort_pm.PL and the
 578     includes in parts/inc/ instead.
 579
 580     Use 'perldoc ppport.h' to view the documentation below.
 581
 582 ----------------------------------------------------------------------
 583
 584 SKIP
 585
 586 %include ppphdoc { indent => '|>' }
 587
 588 %include ppphbin
 589
 590 __DATA__
 591 */
 592
 593 #ifndef _P_P_PORTABILITY_H_
 594 #define _P_P_PORTABILITY_H_
 595
 596 #ifndef DPPP_NAMESPACE
 597 #  define DPPP_NAMESPACE DPPP_
 598 #endif
 599
 600 #define DPPP_CAT2(x,y) CAT2(x,y)
 601 #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name)
 602
 603 %include version
 604
 605 %include threads
 606
 607 %include limits
 608
 609 %include uv
 610
 611 %include memory
 612
 613 %include misc
 614
 615 %include variables
 616
 617 %include mPUSH
 618
 619 %include call
 620
 621 %include newRV
 622
 623 %include newCONSTSUB
 624
 625 %include MY_CXT
 626
 627 %include format
 628
 629 %include SvREFCNT
 630
 631 %include newSVpv
 632
 633 %include SvPV
 634
 635 %include Sv_set
 636
 637 %include sv_xpvf
 638
 639 %include shared_pv
 640
 641 %include warn
 642
 643 %include pvs
 644
 645 %include magic
 646
 647 %include cop
 648
 649 %include grok
 650
 651 %include snprintf
 652
 653 %include sprintf
 654
 655 %include exception
 656
 657 %include strlfuncs
 658
 659 %include pv_tools
 660
 661 #endif /* _P_P_PORTABILITY_H_ */
 662
 663 /* End of File ppport.h */