ext/Devel/PPPort/PPPort_pm.PL

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