ext/Devel/PPPort/PPPort_pm.PL

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