ext/Devel/PPPort/PPPort_pm.PL

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