ext/Devel/PPPort/PPPort_pm.PL

   1 ################################################################################
   2 #
   3 #  PPPort_pm.PL -- generate PPPort.pm
   4 #
   5 ################################################################################
   6 #
   7 #  $Revision: 44 $
   8 #  $Author: mhx $
   9 #  $Date: 2006/05/22 20:28:47 +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{$_}) {
  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: 44 $
 339 #  $Author: mhx $
 340 #  $Date: 2006/05/22 20:28:47 +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 require DynaLoader;
 499 use strict;
 500 use vars qw($VERSION @ISA $data);
 501
 502 $VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.08_03 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
 503
 504 @ISA = qw(DynaLoader);
 505
 506 bootstrap Devel::PPPort;
 507
 508 sub _init_data
 509 {
 510   $data = do { local $/; <DATA> };
 511   my $now = localtime;
 512   my $pkg = 'Devel::PPPort';
 513   $data =~ s/__PERL_VERSION__/$]/g;
 514   $data =~ s/__VERSION__/$VERSION/g;
 515   $data =~ s/__DATE__/$now/g;
 516   $data =~ s/__PKG__/$pkg/g;
 517   $data =~ s/^\|>//gm;
 518 }
 519
 520 sub WriteFile
 521 {
 522   my $file = shift || 'ppport.h';
 523   defined $data or _init_data();
 524   my $copy = $data;
 525   $copy =~ s/\bppport\.h\b/$file/g;
 526
 527   open F, ">$file" or return undef;
 528   print F $copy;
 529   close F;
 530
 531   return 1;
 532 }
 533
 534 1;
 535
 536 __DATA__
 537 #if 0
 538 <<'SKIP';
 539 #endif
 540 /*
 541 ----------------------------------------------------------------------
 542
 543     ppport.h -- Perl/Pollution/Portability Version __VERSION__
 544
 545     Automatically created by __PKG__ running under
 546     perl __PERL_VERSION__ on __DATE__.
 547
 548     Do NOT edit this file directly! -- Edit PPPort_pm.PL and the
 549     includes in parts/inc/ instead.
 550
 551     Use 'perldoc ppport.h' to view the documentation below.
 552
 553 ----------------------------------------------------------------------
 554
 555 SKIP
 556
 557 %include ppphdoc { indent => '|>' }
 558
 559 %include ppphbin
 560
 561 __DATA__
 562 */
 563
 564 #ifndef _P_P_PORTABILITY_H_
 565 #define _P_P_PORTABILITY_H_
 566
 567 #ifndef DPPP_NAMESPACE
 568 #  define DPPP_NAMESPACE DPPP_
 569 #endif
 570
 571 #define DPPP_CAT2(x,y) CAT2(x,y)
 572 #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name)
 573
 574 %include version
 575
 576 %include limits
 577
 578 %include uv
 579
 580 %include memory
 581
 582 %include misc
 583
 584 %include variables
 585
 586 %include threads
 587
 588 %include mPUSH
 589
 590 %include call
 591
 592 %include newRV
 593
 594 %include newCONSTSUB
 595
 596 %include MY_CXT
 597
 598 %include format
 599
 600 %include SvREFCNT
 601
 602 %include SvPV
 603
 604 %include Sv_set
 605
 606 %include sv_xpvf
 607
 608 %include warn
 609
 610 %include pvs
 611
 612 %include magic
 613
 614 %include cop
 615
 616 %include grok
 617
 618 %include snprintf
 619
 620 %include exception
 621
 622 #endif /* _P_P_PORTABILITY_H_ */
 623
 624 /* End of File ppport.h */