ext/Devel/PPPort/PPPort_pm.PL

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