ext/Devel/PPPort/PPPort_pm.PL

   1 ################################################################################
   2 #
   3 #  PPPort_pm.PL -- generate PPPort.pm
   4 #
   5 ################################################################################
   6 #
   7 #  $Revision: 47 $
   8 #  $Author: mhx $
   9 #  $Date: 2006/07/08 11:44:19 +0200 $
  10 #
  11 ################################################################################
  12 #
  13 #  Version 3.x, Copyright (C) 2004-2006, 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));
  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.4}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
 288   if ($f->{flags}{n}) {
 289     if ($f->{flags}{p}) {
 290       return "#define $n $DPPP(my_$n)\n" .
 291              "#define Perl_$n $DPPP(my_$n)";
 292     }
 293     else {
 294       return "#define $n $DPPP(my_$n)";
 295     }
 296   }
 297   else {
 298     my $undef = <<UNDEF;
 299 #ifdef $n
 300 #  undef $n
 301 #endif
 302 UNDEF
 303     if ($f->{flags}{p}) {
 304       if ($f->{flags}{f}) {
 305         return "#define Perl_$n $DPPP(my_$n)";
 306       }
 307       else {
 308         return $undef . "#define $n($a) $DPPP(my_$n)(aTHX_ $a)\n" .
 309                         "#define Perl_$n $DPPP(my_$n)";
 310       }
 311     }
 312     else {
 313       return $undef . "#define $n($a) $DPPP(my_$n)(aTHX_ $a)";
 314     }
 315   }
 316 }
 317
 318 sub check
 319 {
 320   my $level = shift;
 321
 322   if (exists $ENV{DPPP_CHECK_LEVEL} and $ENV{DPPP_CHECK_LEVEL} >= $level) {
 323     print STDERR @_, "\n";
 324   }
 325 }
 326
 327 __DATA__
 328 ################################################################################
 329 #
 330 #  !!!!! Do NOT edit this file directly! -- Edit PPPort_pm.PL instead. !!!!!
 331 #
 332 ################################################################################
 333 #
 334 #  Perl/Pollution/Portability
 335 #
 336 ################################################################################
 337 #
 338 #  $Revision: 47 $
 339 #  $Author: mhx $
 340 #  $Date: 2006/07/08 11:44:19 +0200 $
 341 #
 342 ################################################################################
 343 #
 344 #  Version 3.x, Copyright (C) 2004-2006, Marcus Holland-Moritz.
 345 #  Version 2.x, Copyright (C) 2001, Paul Marquess.
 346 #  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
 347 #
 348 #  This program is free software; you can redistribute it and/or
 349 #  modify it under the same terms as Perl itself.
 350 #
 351 ################################################################################
 352
 353 =head1 NAME
 354
 355 Devel::PPPort - Perl/Pollution/Portability
 356
 357 =head1 SYNOPSIS
 358
 359     Devel::PPPort::WriteFile();   # defaults to ./ppport.h
 360     Devel::PPPort::WriteFile('someheader.h');
 361
 362 =head1 DESCRIPTION
 363
 364 Perl's API has changed over time, gaining new features, new functions,
 365 increasing its flexibility, and reducing the impact on the C namespace
 366 environment (reduced pollution). The header file written by this module,
 367 typically F<ppport.h>, attempts to bring some of the newer Perl API
 368 features to older versions of Perl, so that you can worry less about
 369 keeping track of old releases, but users can still reap the benefit.
 370
 371 C<Devel::PPPort> contains a single function, called C<WriteFile>. Its
 372 only purpose is to write the F<ppport.h> C header file. This file
 373 contains a series of macros and, if explicitly requested, functions that
 374 allow XS modules to be built using older versions of Perl. Currently,
 375 Perl versions from __MIN_PERL__ to __MAX_PERL__ are supported.
 376
 377 This module is used by C<h2xs> to write the file F<ppport.h>.
 378
 379 =head2 Why use ppport.h?
 380
 381 You should use F<ppport.h> in modern code so that your code will work
 382 with the widest range of Perl interpreters possible, without significant
 383 additional work.
 384
 385 You should attempt older code to fully use F<ppport.h>, because the
 386 reduced pollution of newer Perl versions is an important thing. It's so
 387 important that the old polluting ways of original Perl modules will not be
 388 supported very far into the future, and your module will almost certainly
 389 break! By adapting to it now, you'll gain compatibility and a sense of
 390 having done the electronic ecology some good.
 391
 392 =head2 How to use ppport.h
 393
 394 Don't direct the users of your module to download C<Devel::PPPort>.
 395 They are most probably no XS writers. Also, don't make F<ppport.h>
 396 optional. Rather, just take the most recent copy of F<ppport.h> that
 397 you can find (e.g. by generating it with the latest C<Devel::PPPort>
 398 release from CPAN), copy it into your project, adjust your project to
 399 use it, and distribute the header along with your module.
 400
 401 =head2 Running ppport.h
 402
 403 But F<ppport.h> is more than just a C header. It's also a Perl script
 404 that can check your source code. It will suggest hints and portability
 405 notes, and can even make suggestions on how to change your code. You
 406 can run it like any other Perl program:
 407
 408     perl ppport.h [options] [files]
 409
 410 It also has embedded documentation, so you can use
 411
 412     perldoc ppport.h
 413
 414 to find out more about how to use it.
 415
 416 =head1 FUNCTIONS
 417
 418 =head2 WriteFile
 419
 420 C<WriteFile> takes one optional argument. When called with one
 421 argument, it expects to be passed a filename. When called with
 422 no arguments, it defaults to the filename F<ppport.h>.
 423
 424 The function returns a true value if the file was written successfully.
 425 Otherwise it returns a false value.
 426
 427 =head1 COMPATIBILITY
 428
 429 F<ppport.h> supports Perl versions from __MIN_PERL__ to __MAX_PERL__
 430 in threaded and non-threaded configurations.
 431
 432 =head2 Provided Perl compatibility API
 433
 434 The header file written by this module, typically F<ppport.h>, provides
 435 access to the following elements of the Perl API that is not available
 436 in older Perl releases:
 437
 438     __PROVIDED_API__
 439
 440 =head2 Perl API not supported by ppport.h
 441
 442 There is still a big part of the API not supported by F<ppport.h>.
 443 Either because it doesn't make sense to back-port that part of the API,
 444 or simply because it hasn't been implemented yet. Patches welcome!
 445
 446 Here's a list of the currently unsupported API, and also the version of
 447 Perl below which it is unsupported:
 448
 449 =over 4
 450
 451 __UNSUPPORTED_API__
 452
 453 =back
 454
 455 =head1 BUGS
 456
 457 If you find any bugs, C<Devel::PPPort> doesn't seem to build on your
 458 system or any of its tests fail, please use the CPAN Request Tracker
 459 at L<http://rt.cpan.org/> to create a ticket for the module.
 460
 461 =head1 AUTHORS
 462
 463 =over 2
 464
 465 =item *
 466
 467 Version 1.x of Devel::PPPort was written by Kenneth Albanowski.
 468
 469 =item *
 470
 471 Version 2.x was ported to the Perl core by Paul Marquess.
 472
 473 =item *
 474
 475 Version 3.x was ported back to CPAN by Marcus Holland-Moritz.
 476
 477 =back
 478
 479 =head1 COPYRIGHT
 480
 481 Version 3.x, Copyright (C) 2004-2006, Marcus Holland-Moritz.
 482
 483 Version 2.x, Copyright (C) 2001, Paul Marquess.
 484
 485 Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
 486
 487 This program is free software; you can redistribute it and/or
 488 modify it under the same terms as Perl itself.
 489
 490 =head1 SEE ALSO
 491
 492 See L<h2xs>, L<ppport.h>.
 493
 494 =cut
 495
 496 package Devel::PPPort;
 497
 498 use strict;
 499 use vars qw($VERSION $data);
 500
 501 $VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.09_01 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
 502
 503 sub _init_data
 504 {
 505   $data = do { local $/; <DATA> };
 506   my $now = localtime;
 507   my $pkg = 'Devel::PPPort';
 508   $data =~ s/__PERL_VERSION__/$]/g;
 509   $data =~ s/__VERSION__/$VERSION/g;
 510   $data =~ s/__DATE__/$now/g;
 511   $data =~ s/__PKG__/$pkg/g;
 512   $data =~ s/^\|>//gm;
 513 }
 514
 515 sub WriteFile
 516 {
 517   my $file = shift || 'ppport.h';
 518   defined $data or _init_data();
 519   my $copy = $data;
 520   $copy =~ s/\bppport\.h\b/$file/g;
 521
 522   open F, ">$file" or return undef;
 523   print F $copy;
 524   close F;
 525
 526   return 1;
 527 }
 528
 529 1;
 530
 531 __DATA__
 532 #if 0
 533 <<'SKIP';
 534 #endif
 535 /*
 536 ----------------------------------------------------------------------
 537
 538     ppport.h -- Perl/Pollution/Portability Version __VERSION__
 539
 540     Automatically created by __PKG__ running under
 541     perl __PERL_VERSION__ on __DATE__.
 542
 543     Do NOT edit this file directly! -- Edit PPPort_pm.PL and the
 544     includes in parts/inc/ instead.
 545
 546     Use 'perldoc ppport.h' to view the documentation below.
 547
 548 ----------------------------------------------------------------------
 549
 550 SKIP
 551
 552 %include ppphdoc { indent => '|>' }
 553
 554 %include ppphbin
 555
 556 __DATA__
 557 */
 558
 559 #ifndef _P_P_PORTABILITY_H_
 560 #define _P_P_PORTABILITY_H_
 561
 562 #ifndef DPPP_NAMESPACE
 563 #  define DPPP_NAMESPACE DPPP_
 564 #endif
 565
 566 #define DPPP_CAT2(x,y) CAT2(x,y)
 567 #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name)
 568
 569 %include version
 570
 571 %include limits
 572
 573 %include uv
 574
 575 %include memory
 576
 577 %include misc
 578
 579 %include variables
 580
 581 %include threads
 582
 583 %include mPUSH
 584
 585 %include call
 586
 587 %include newRV
 588
 589 %include newCONSTSUB
 590
 591 %include MY_CXT
 592
 593 %include format
 594
 595 %include SvREFCNT
 596
 597 %include SvPV
 598
 599 %include Sv_set
 600
 601 %include sv_xpvf
 602
 603 %include warn
 604
 605 %include pvs
 606
 607 %include magic
 608
 609 %include cop
 610
 611 %include grok
 612
 613 %include snprintf
 614
 615 %include exception
 616
 617 #endif /* _P_P_PORTABILITY_H_ */
 618
 619 /* End of File ppport.h */