cpan/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.11.5}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 =head1 DESCRIPTION
 388
 389 Perl's API has changed over time, gaining new features, new functions,
 390 increasing its flexibility, and reducing the impact on the C namespace
 391 environment (reduced pollution). The header file written by this module,
 392 typically F<ppport.h>, attempts to bring some of the newer Perl API
 393 features to older versions of Perl, so that you can worry less about
 394 keeping track of old releases, but users can still reap the benefit.
 395
 396 C<Devel::PPPort> contains a single function, called C<WriteFile>. Its
 397 only purpose is to write the F<ppport.h> C header file. This file
 398 contains a series of macros and, if explicitly requested, functions that
 399 allow XS modules to be built using older versions of Perl. Currently,
 400 Perl versions from __MIN_PERL__ to __MAX_PERL__ are supported.
 401
 402 This module is used by C<h2xs> to write the file F<ppport.h>.
 403
 404 =head2 Why use ppport.h?
 405
 406 You should use F<ppport.h> in modern code so that your code will work
 407 with the widest range of Perl interpreters possible, without significant
 408 additional work.
 409
 410 You should attempt older code to fully use F<ppport.h>, because the
 411 reduced pollution of newer Perl versions is an important thing. It's so
 412 important that the old polluting ways of original Perl modules will not be
 413 supported very far into the future, and your module will almost certainly
 414 break! By adapting to it now, you'll gain compatibility and a sense of
 415 having done the electronic ecology some good.
 416
 417 =head2 How to use ppport.h
 418
 419 Don't direct the users of your module to download C<Devel::PPPort>.
 420 They are most probably no XS writers. Also, don't make F<ppport.h>
 421 optional. Rather, just take the most recent copy of F<ppport.h> that
 422 you can find (e.g. by generating it with the latest C<Devel::PPPort>
 423 release from CPAN), copy it into your project, adjust your project to
 424 use it, and distribute the header along with your module.
 425
 426 =head2 Running ppport.h
 427
 428 But F<ppport.h> is more than just a C header. It's also a Perl script
 429 that can check your source code. It will suggest hints and portability
 430 notes, and can even make suggestions on how to change your code. You
 431 can run it like any other Perl program:
 432
 433     perl ppport.h [options] [files]
 434
 435 It also has embedded documentation, so you can use
 436
 437     perldoc ppport.h
 438
 439 to find out more about how to use it.
 440
 441 =head1 FUNCTIONS
 442
 443 =head2 WriteFile
 444
 445 C<WriteFile> takes one optional argument. When called with one
 446 argument, it expects to be passed a filename. When called with
 447 no arguments, it defaults to the filename F<ppport.h>.
 448
 449 The function returns a true value if the file was written successfully.
 450 Otherwise it returns a false value.
 451
 452 =head1 COMPATIBILITY
 453
 454 F<ppport.h> supports Perl versions from __MIN_PERL__ to __MAX_PERL__
 455 in threaded and non-threaded configurations.
 456
 457 =head2 Provided Perl compatibility API
 458
 459 The header file written by this module, typically F<ppport.h>, provides
 460 access to the following elements of the Perl API that is not available
 461 in older Perl releases:
 462
 463     __PROVIDED_API__
 464
 465 =head2 Perl API not supported by ppport.h
 466
 467 There is still a big part of the API not supported by F<ppport.h>.
 468 Either because it doesn't make sense to back-port that part of the API,
 469 or simply because it hasn't been implemented yet. Patches welcome!
 470
 471 Here's a list of the currently unsupported API, and also the version of
 472 Perl below which it is unsupported:
 473
 474 =over 4
 475
 476 __UNSUPPORTED_API__
 477
 478 =back
 479
 480 =head1 BUGS
 481
 482 If you find any bugs, C<Devel::PPPort> doesn't seem to build on your
 483 system or any of its tests fail, please use the CPAN Request Tracker
 484 at L<http://rt.cpan.org/> to create a ticket for the module.
 485
 486 =head1 AUTHORS
 487
 488 =over 2
 489
 490 =item *
 491
 492 Version 1.x of Devel::PPPort was written by Kenneth Albanowski.
 493
 494 =item *
 495
 496 Version 2.x was ported to the Perl core by Paul Marquess.
 497
 498 =item *
 499
 500 Version 3.x was ported back to CPAN by Marcus Holland-Moritz.
 501
 502 =back
 503
 504 =head1 COPYRIGHT
 505
 506 Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
 507
 508 Version 2.x, Copyright (C) 2001, Paul Marquess.
 509
 510 Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
 511
 512 This program is free software; you can redistribute it and/or
 513 modify it under the same terms as Perl itself.
 514
 515 =head1 SEE ALSO
 516
 517 See L<h2xs>, L<ppport.h>.
 518
 519 =cut
 520
 521 package Devel::PPPort;
 522
 523 use strict;
 524 use vars qw($VERSION $data);
 525
 526 $VERSION = '3.21';
 527
 528 sub _init_data
 529 {
 530   $data = do { local $/; <DATA> };
 531   my $pkg = 'Devel::PPPort';
 532   $data =~ s/__PERL_VERSION__/$]/g;
 533   $data =~ s/__VERSION__/$VERSION/g;
 534   $data =~ s/__PKG__/$pkg/g;
 535   $data =~ s/^\|>//gm;
 536 }
 537
 538 sub WriteFile
 539 {
 540   my $file = shift || 'ppport.h';
 541   defined $data or _init_data();
 542   my $copy = $data;
 543   $copy =~ s/\bppport\.h\b/$file/g;
 544
 545   open F, ">$file" or return undef;
 546   print F $copy;
 547   close F;
 548
 549   return 1;
 550 }
 551
 552 1;
 553
 554 __DATA__
 555 #if 0
 556 <<'SKIP';
 557 #endif
 558 /*
 559 ----------------------------------------------------------------------
 560
 561     ppport.h -- Perl/Pollution/Portability Version __VERSION__
 562
 563     Automatically created by __PKG__ running under perl __PERL_VERSION__.
 564
 565     Do NOT edit this file directly! -- Edit PPPort_pm.PL and the
 566     includes in parts/inc/ instead.
 567
 568     Use 'perldoc ppport.h' to view the documentation below.
 569
 570 ----------------------------------------------------------------------
 571
 572 SKIP
 573
 574 %include ppphdoc { indent => '|>' }
 575
 576 %include ppphbin
 577
 578 __DATA__
 579 */
 580
 581 #ifndef _P_P_PORTABILITY_H_
 582 #define _P_P_PORTABILITY_H_
 583
 584 #ifndef DPPP_NAMESPACE
 585 #  define DPPP_NAMESPACE DPPP_
 586 #endif
 587
 588 #define DPPP_CAT2(x,y) CAT2(x,y)
 589 #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name)
 590
 591 %include version
 592
 593 %include threads
 594
 595 %include limits
 596
 597 %include uv
 598
 599 %include memory
 600
 601 %include misc
 602
 603 %include variables
 604
 605 %include mPUSH
 606
 607 %include call
 608
 609 %include newRV
 610
 611 %include newCONSTSUB
 612
 613 %include MY_CXT
 614
 615 %include format
 616
 617 %include SvREFCNT
 618
 619 %include newSV_type
 620
 621 %include newSVpv
 622
 623 %include SvPV
 624
 625 %include Sv_set
 626
 627 %include sv_xpvf
 628
 629 %include shared_pv
 630
 631 %include HvNAME
 632
 633 %include gv
 634
 635 %include warn
 636
 637 %include pvs
 638
 639 %include magic
 640
 641 %include cop
 642
 643 %include grok
 644
 645 %include snprintf
 646
 647 %include sprintf
 648
 649 %include exception
 650
 651 %include strlfuncs
 652
 653 %include pv_tools
 654
 655 #endif /* _P_P_PORTABILITY_H_ */
 656
 657 /* End of File ppport.h */