ext/Devel/PPPort/PPPort_pm.PL

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