[p5sagit/p5-mst-13.2.git] / ext / Devel / PPPort / PPPort_pm.PL

################################################################################
#
#  PPPort_pm.PL -- generate PPPort.pm
#
################################################################################
#
#  $Revision: 41 $
#  $Author: mhx $
#  $Date: 2006/01/14 18:07:56 +0100 $
#
################################################################################
#
#  Version 3.x, Copyright (C) 2004-2006, Marcus Holland-Moritz.
#  Version 2.x, Copyright (C) 2001, Paul Marquess.
#  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
#
#  This program is free software; you can redistribute it and/or
#  modify it under the same terms as Perl itself.
#
################################################################################

use strict;
$^W = 1;
require "parts/ppptools.pl";

my $INCLUDE = 'parts/inc';
my $DPPP = 'DPPP_';

my %embed = map { ( $_->{name} => $_ ) }
            parse_embed(qw(parts/embed.fnc parts/apidoc.fnc));

my(%provides, %prototypes, %explicit);

my $data = do { local $/; <DATA> };
$data =~ s{^\%(include)\s+(\w+)((?:[^\S\r\n]+.*?)?)\s*$}
          {eval "$1('$2', $3)" or die $@}gem;

$data = expand($data);

my @api = sort { lc $a cmp lc $b } keys %provides;

$data =~ s{^(.*)__PROVIDED_API__(\s*?)^}
          {join '', map "$1$_\n", @api}gem;

{
  my $len = 0;
  for (keys %explicit) {
    length > $len and $len = length;
  }
  my $format = sprintf '%%-%ds  %%-%ds  %%s', $len+2, $len+5;
  $len = 3*$len + 23;

$data =~ s!^(.*)__EXPLICIT_API__(\s*?)^!
           sprintf("$1$format\n", 'Function / Variable', 'Static Request', 'Global Request') .
           $1 . '-'x$len . "\n" .
           join('', map { sprintf "$1$format\n", $explicit{$_} eq 'var' ? $_ : "$_()", "NEED_$_", "NEED_${_}_GLOBAL" }
                    sort keys %explicit)
          !gem;
}

my %raw_base = %{&parse_todo('parts/base')};
my %raw_todo = %{&parse_todo('parts/todo')};

my %todo;
for (keys %raw_todo) {
  push @{$todo{$raw_todo{$_}}}, $_;
}

# check consistency
for (@api) {
  if (exists $raw_todo{$_}) {
    if ($raw_base{$_} eq $raw_todo{$_}) {
      warn "$INCLUDE/$provides{$_} provides $_, which is still marked "
           . "todo for " . format_version($raw_todo{$_}) . "\n";
    }
    else {
      check(2, "$_ was ported back to " . format_version($raw_todo{$_}) .
               " (baseline revision: " . format_version($raw_base{$_}) . ").");
    }
  }
}

my @perl_api;
for (keys %provides) {
  next if exists $embed{$_};
  push @perl_api, $_;
  check(2, "No API definition for provided element $_ found.");
}

push @perl_api, keys %embed;

for (@perl_api) {
  if (exists $provides{$_} && !exists $raw_base{$_}) {
    check(2, "Mmmh, $_ doesn't seem to need backporting.");
  }
  my $line = "$_|" . (exists $provides{$_} && exists $raw_base{$_} ? $raw_base{$_} : '') . '|';
  $line .= ($raw_todo{$_} || '') . '|';
  $line .= 'p' if exists $provides{$_};
  if (exists $embed{$_}) {
    my $e = $embed{$_};
    if (exists $e->{flags}{p}) {
      my $args = $e->{args};
      $line .= 'v' if @$args && $args->[-1][0] eq '...';
    }
    $line .= 'n' if exists $e->{flags}{n};
  }
  $_ = $line;
}

$data =~ s/^([\t ]*)__PERL_API__(\s*?)$/
           join "\n", map "$1$_", sort @perl_api
          /gem;

my @todo;
for (reverse sort keys %todo) {
  my $ver = format_version($_);
  my $todo = "=item perl $ver\n\n";
  for (sort @{$todo{$_}}) {
    $todo .= "  $_\n";
  }
  push @todo, $todo;
}

$data =~ s{^__UNSUPPORTED_API__(\s*?)^}
          {join "\n", @todo}gem;

$data =~ s{__MIN_PERL__}{5.003}g;
$data =~ s{__MAX_PERL__}{5.9.3}g;

open FH, ">PPPort.pm" or die "PPPort.pm: $!\n";
print FH $data;
close FH;

exit 0;

sub include
{
  my($file, $opt) = @_;

  print "including $file\n";

  my $data = parse_partspec("$INCLUDE/$file");

  for (@{$data->{provides}}) {
    if (exists $provides{$_}) {
      if ($provides{$_} ne $file) {
        warn "$file: $_ already provided by $provides{$_}\n";
      }
    }
    else {
      $provides{$_} = $file;
    }
  }

  for (keys %{$data->{prototypes}}) {
    $prototypes{$_} = $data->{prototypes}{$_};
    $data->{implementation} =~ s/^$_(?=\s*\()/$DPPP(my_$_)/mg;
  }

  my $out = $data->{implementation};

  if (exists $opt->{indent}) {
    $out =~ s/^/$opt->{indent}/gm;
  }

  return $out;
}

sub expand
{
  my $code = shift;
  $code =~ s{^(\s*#\s*(?:el)?if\s+)(.*)$}{$1.expand_pp_expressions($2)}gem;
  $code =~ s{^\s*
              __UNDEFINED__
              \s+
              (
                ( \w+ )
                (?: \( [^)]* \) )?
              )
              [^\r\n\S]*
              (
                (?:[^\r\n\\]|\\[^\r\n])*
                (?:
                  \\
                  (?:\r\n|[\r\n])
                  (?:[^\r\n\\]|\\[^\r\n])*
                )*
              )
            \s*$}
            {expand_undefined($2, $1, $3)}gemx;
  $code =~ s{^([^\S\r\n]*)__NEED_VAR__\s+(.*?)\s+(\w+)(?:\s*=\s*([^;]+?)\s*;\s*)?$}
            {expand_need_var($1, $3, $2, $4)}gem;
  return $code;
}

sub expand_need_var
{
  my($indent, $var, $type, $init) = @_;

  $explicit{$var} = 'var';

  my $myvar = "$DPPP(my_$var)";

  my $code = <<ENDCODE;
#if defined(NEED_$var)
static $type $myvar = $init;
#elif defined(NEED_${var}_GLOBAL)
$type $myvar = $init;
#else
extern $type $myvar;
#endif
#define $var $myvar
ENDCODE

  $code =~ s/^/$indent/mg;

  return $code;
}

sub expand_undefined
{
  my($macro, $withargs, $def) = @_;
  my $rv = "#ifndef $macro\n#  define ";

  if (defined $def && $def =~ /\S/) {
    $rv .= sprintf "%-30s %s", $withargs, $def;
  }
  else {
    $rv .= $withargs;
  }

  $rv .= "\n#endif\n";

  return $rv;
}

sub expand_pp_expressions
{
  my $pp = shift;
  $pp =~ s/\{([^\}]+)\}/expand_pp_expr($1)/ge;
  return $pp;
}

sub expand_pp_expr
{
  my $expr = shift;

  if ($expr =~ /^\s*need\s+(\w+)\s*$/i) {
    my $func = $1;
    my $e = $embed{$func} or die "unknown API function '$func' in NEED\n";
    my $proto = make_prototype($e);
    if (exists $prototypes{$func}) {
      if (compare_prototypes($proto, $prototypes{$func})) {
        check(1, "differing prototypes for $func:\n  API: $proto\n  PPP: $prototypes{$func}");
        $proto = $prototypes{$func};
      }
    }
    else {
      warn "found no prototype for $func\n";;
    }

    $explicit{$func} = 'func';

    $proto =~ s/\b$func(?=\s*\()/$DPPP(my_$func)/;
    my $embed = make_embed($e);

    return "defined(NEED_$func)\n"
         . "static $proto;\n"
         . "static\n"
         . "#else\n"
         . "extern $proto;\n"
         . "#endif\n"
         . "\n"
         . "$embed\n"
         . "\n"
         . "#if defined(NEED_$func) || defined(NEED_${func}_GLOBAL)";
  }

  die "cannot expand preprocessor expression '$expr'\n";
}

sub make_embed
{
  my $f = shift;
  my $n = $f->{name};
  my $a = do { my $x = 'a'; join ',', map { $x++ } 1 .. @{$f->{args}} };

  if ($f->{flags}{n}) {
    if ($f->{flags}{p}) {
      return "#define $n $DPPP(my_$n)\n" .
             "#define Perl_$n $DPPP(my_$n)";
    }
    else {
      return "#define $n $DPPP(my_$n)";
    }
  }
  else {
    my $undef = <<UNDEF;
#ifdef $n
#  undef $n
#endif
UNDEF
    if ($f->{flags}{p}) {
      if ($f->{flags}{f}) {
        return "#define Perl_$n $DPPP(my_$n)";
      }
      else {
        return $undef . "#define $n($a) $DPPP(my_$n)(aTHX_ $a)\n" .
                        "#define Perl_$n $DPPP(my_$n)";
      }
    }
    else {
      return $undef . "#define $n($a) $DPPP(my_$n)(aTHX_ $a)";
    }
  }
}

sub check
{
  my $level = shift;

  if (exists $ENV{DPPP_CHECK_LEVEL} and $ENV{DPPP_CHECK_LEVEL} >= $level) {
    print STDERR @_, "\n";
  }
}

__DATA__
################################################################################
#
#  !!!!! Do NOT edit this file directly! -- Edit PPPort_pm.PL instead. !!!!!
#
################################################################################
#
#  Perl/Pollution/Portability
#
################################################################################
#
#  $Revision: 41 $
#  $Author: mhx $
#  $Date: 2006/01/14 18:07:56 +0100 $
#
################################################################################
#
#  Version 3.x, Copyright (C) 2004-2006, Marcus Holland-Moritz.
#  Version 2.x, Copyright (C) 2001, Paul Marquess.
#  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
#
#  This program is free software; you can redistribute it and/or
#  modify it under the same terms as Perl itself.
#
################################################################################

=head1 NAME

Devel::PPPort - Perl/Pollution/Portability

=head1 SYNOPSIS

    Devel::PPPort::WriteFile();   # defaults to ./ppport.h
    Devel::PPPort::WriteFile('someheader.h');

=head1 DESCRIPTION

Perl's API has changed over time, gaining new features, new functions,
increasing its flexibility, and reducing the impact on the C namespace
environment (reduced pollution). The header file written by this module,
typically F<ppport.h>, attempts to bring some of the newer Perl API
features to older versions of Perl, so that you can worry less about
keeping track of old releases, but users can still reap the benefit.

C<Devel::PPPort> contains a single function, called C<WriteFile>. Its
only purpose is to write the F<ppport.h> C header file. This file
contains a series of macros and, if explicitly requested, functions that
allow XS modules to be built using older versions of Perl. Currently,
Perl versions from __MIN_PERL__ to __MAX_PERL__ are supported.

This module is used by C<h2xs> to write the file F<ppport.h>.

=head2 Why use ppport.h?

You should use F<ppport.h> in modern code so that your code will work
with the widest range of Perl interpreters possible, without significant
additional work.

You should attempt older code to fully use F<ppport.h>, because the
reduced pollution of newer Perl versions is an important thing. It's so
important that the old polluting ways of original Perl modules will not be
supported very far into the future, and your module will almost certainly
break! By adapting to it now, you'll gain compatibility and a sense of
having done the electronic ecology some good.

=head2 How to use ppport.h

Don't direct the users of your module to download C<Devel::PPPort>.
They are most probably no XS writers. Also, don't make F<ppport.h>
optional. Rather, just take the most recent copy of F<ppport.h> that
you can find (e.g. by generating it with the latest C<Devel::PPPort>
release from CPAN), copy it into your project, adjust your project to
use it, and distribute the header along with your module.

=head2 Running ppport.h

But F<ppport.h> is more than just a C header. It's also a Perl script
that can check your source code. It will suggest hints and portability
notes, and can even make suggestions on how to change your code. You
can run it like any other Perl program:

    perl ppport.h [options] [files]

It also has embedded documentation, so you can use

    perldoc ppport.h

to find out more about how to use it.

=head1 FUNCTIONS

=head2 WriteFile

C<WriteFile> takes one optional argument. When called with one
argument, it expects to be passed a filename. When called with
no arguments, it defaults to the filename F<ppport.h>.

The function returns a true value if the file was written successfully.
Otherwise it returns a false value.

=head1 COMPATIBILITY

F<ppport.h> supports Perl versions from __MIN_PERL__ to __MAX_PERL__
in threaded and non-threaded configurations.

=head2 Provided Perl compatibility API

The header file written by this module, typically F<ppport.h>, provides
access to the following elements of the Perl API that is not available
in older Perl releases:

    __PROVIDED_API__

=head2 Perl API not supported by ppport.h

There is still a big part of the API not supported by F<ppport.h>.
Either because it doesn't make sense to back-port that part of the API,
or simply because it hasn't been implemented yet. Patches welcome!

Here's a list of the currently unsupported API, and also the version of
Perl below which it is unsupported:

=over 4

__UNSUPPORTED_API__

=back

=head1 BUGS

If you find any bugs, C<Devel::PPPort> doesn't seem to build on your
system or any of its tests fail, please use the CPAN Request Tracker
at L<http://rt.cpan.org/> to create a ticket for the module.

=head1 AUTHORS

=over 2

=item *

Version 1.x of Devel::PPPort was written by Kenneth Albanowski.

=item *

Version 2.x was ported to the Perl core by Paul Marquess.

=item *

Version 3.x was ported back to CPAN by Marcus Holland-Moritz.

=back

=head1 COPYRIGHT

Version 3.x, Copyright (C) 2004-2006, Marcus Holland-Moritz.

Version 2.x, Copyright (C) 2001, Paul Marquess.

Version 1.x, Copyright (C) 1999, Kenneth Albanowski.

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=head1 SEE ALSO

See L<h2xs>, L<ppport.h>.

=cut

package Devel::PPPort;

require DynaLoader;
use strict;
use vars qw($VERSION @ISA $data);

$VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.07 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };

@ISA = qw(DynaLoader);

bootstrap Devel::PPPort;

sub _init_data
{
  $data = do { local $/; <DATA> };
  my $now = localtime;
  my $pkg = 'Devel::PPPort';
  $data =~ s/__PERL_VERSION__/$]/g;
  $data =~ s/__VERSION__/$VERSION/g;
  $data =~ s/__DATE__/$now/g;
  $data =~ s/__PKG__/$pkg/g;
  $data =~ s/^\|>//gm;
}

sub WriteFile
{
  my $file = shift || 'ppport.h';
  defined $data or _init_data();
  my $copy = $data;
  $copy =~ s/\bppport\.h\b/$file/g;

  open F, ">$file" or return undef;
  print F $copy;
  close F;

  return 1;
}

1;

__DATA__
#if 0
<<'SKIP';
#endif
/*
----------------------------------------------------------------------

    ppport.h -- Perl/Pollution/Portability Version __VERSION__

    Automatically created by __PKG__ running under
    perl __PERL_VERSION__ on __DATE__.

    Do NOT edit this file directly! -- Edit PPPort_pm.PL and the
    includes in parts/inc/ instead.

    Use 'perldoc ppport.h' to view the documentation below.

----------------------------------------------------------------------

SKIP

%include ppphdoc { indent => '|>' }

%include ppphbin

__DATA__
*/

#ifndef _P_P_PORTABILITY_H_
#define _P_P_PORTABILITY_H_

#ifndef DPPP_NAMESPACE
#  define DPPP_NAMESPACE DPPP_
#endif

#define DPPP_CAT2(x,y) CAT2(x,y)
#define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name)

%include version

%include limits

%include uv

%include memory

%include misc

%include variables

%include threads

%include mPUSH

%include call

%include newRV

%include newCONSTSUB

%include MY_CXT

%include format

%include SvPV

%include Sv_set

%include sv_xpvf

%include magic

%include cop

%include grok

%include exception

#endif /* _P_P_PORTABILITY_H_ */

/* End of File ppport.h */
Commit	Line	Data
adfe19db	1	################################################################################
	2	#
	3	# PPPort_pm.PL -- generate PPPort.pm
	4	#
	5	################################################################################
	6	#
0d0f8426	7	# $Revision: 41 $
adfe19db	8	# $Author: mhx $
0d0f8426	9	# $Date: 2006/01/14 18:07:56 +0100 $
adfe19db	10	#
	11	################################################################################
	12	#
0d0f8426	13	# Version 3.x, Copyright (C) 2004-2006, Marcus Holland-Moritz.
adfe19db	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	}
4a582685	50	my $format = sprintf '%%-%ds %%-%ds %%s', $len+2, $len+5;
adfe19db	51	$len = 3*$len + 23;
adfe19db	52
0d0f8426	53	$data =~ s!^(.)__EXPLICIT_API__(\s?)^!
0d0f8426	54	sprintf("$1$format\n", 'Function / Variable', 'Static Request', 'Global Request') .
adfe19db	55	$1 . '-'x$len . "\n" .
0d0f8426	56	join('', map { sprintf "$1$format\n", $explicit{$_} eq 'var' ? $_ : "$_()", "NEED_$_", "NEED_${_}_GLOBAL" }
adfe19db	57	sort keys %explicit)
0d0f8426	58	!gem;
adfe19db	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{$_}) {
96ad942f	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	}
adfe19db	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;
4a582685	128	$data =~ s{__MAX_PERL__}{5.9.3}g;
adfe19db	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}{$_};
96ad942f	157	$data->{implementation} =~ s/^$_(?=\s*\()/$DPPP(my_$_)/mg;
adfe19db	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;
0d0f8426	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
adfe19db	217	return $code;
	218	}
	219
	220	sub expand_undefined
	221	{
	222	my($macro, $withargs, $def) = @_;
	223	my $rv = "#ifndef $macro\n# define ";
	224
4a582685	225	if (defined $def && $def =~ /\S/) {
adfe19db	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
0d0f8426	248	if ($expr =~ /^\sneed\s+(\w+)\s$/i) {
adfe19db	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
0d0f8426	262	$explicit{$func} = 'func';
adfe19db	263
96ad942f	264	$proto =~ s/\b$func(?=\s*\()/$DPPP(my_$func)/;
adfe19db	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"
96ad942f	276	. "#if defined(NEED_$func) \|\| defined(NEED_${func}_GLOBAL)";
adfe19db	277	}
adfe19db	278
adfe19db	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}) {
96ad942f	290	return "#define $n $DPPP(my_$n)\n" .
96ad942f	291	"#define Perl_$n $DPPP(my_$n)";
adfe19db	292	}
adfe19db	293	else {
96ad942f	294	return "#define $n $DPPP(my_$n)";
adfe19db	295	}
	296	}
	297	else {
	298	my $undef = <<UNDEF;
	299	#ifdef $n
	300	# undef $n
	301	#endif
	302	UNDEF
	303	if ($f->{flags}{p}) {
96ad942f	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	}
adfe19db	311	}
adfe19db	312	else {
96ad942f	313	return $undef . "#define $n($a) $DPPP(my_$n)(aTHX_ $a)";
adfe19db	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	#
0d0f8426	338	# $Revision: 41 $
adfe19db	339	# $Author: mhx $
0d0f8426	340	# $Date: 2006/01/14 18:07:56 +0100 $
adfe19db	341	#
	342	################################################################################
	343	#
0d0f8426	344	# Version 3.x, Copyright (C) 2004-2006, Marcus Holland-Moritz.
adfe19db	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
4a582685	377	This module is used by C<h2xs> to write the file F<ppport.h>.
adfe19db	378
adfe19db	379	=head2 Why use ppport.h?
4a582685	380
adfe19db	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
4a582685	399	use it, and distribute the header along with your module.
adfe19db	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
9132e1a3	408	perl ppport.h [options] [files]
adfe19db	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
0d0f8426	481	Version 3.x, Copyright (C) 2004-2006, Marcus Holland-Moritz.
adfe19db	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
0d0f8426	502	$VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.07 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
adfe19db	503
	504	@ISA = qw(DynaLoader);
	505
	506	bootstrap Devel::PPPort;
	507
4a582685	508	sub _init_data
adfe19db	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;
4a582685	517	$data =~ s/^\\|>//gm;
adfe19db	518	}
	519
	520	sub WriteFile
	521	{
	522	my $file = shift \|\| 'ppport.h';
4a582685	523	defined $data or _init_data();
adfe19db	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
4a582685	543	ppport.h -- Perl/Pollution/Portability Version __VERSION__
4a582685	544
adfe19db	545	Automatically created by __PKG__ running under
adfe19db	546	perl __PERL_VERSION__ on __DATE__.
4a582685	547
adfe19db	548	Do NOT edit this file directly! -- Edit PPPort_pm.PL and the
adfe19db	549	includes in parts/inc/ instead.
4a582685	550
adfe19db	551	Use 'perldoc ppport.h' to view the documentation below.
	552
	553	----------------------------------------------------------------------
	554
	555	SKIP
	556
4a582685	557	%include ppphdoc { indent => '\|>' }
adfe19db	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
0d0f8426	580	%include memory
0d0f8426	581
adfe19db	582	%include misc
adfe19db	583
0d0f8426	584	%include variables
0d0f8426	585
adfe19db	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 SvPV
	601
0d0f8426	602	%include Sv_set
0d0f8426	603
96ad942f	604	%include sv_xpvf
96ad942f	605
adfe19db	606	%include magic
	607
	608	%include cop
	609
	610	%include grok
	611
9132e1a3	612	%include exception
9132e1a3	613
adfe19db	614	#endif /* _P_P_PORTABILITY_H_ */
	615
	616	/* End of File ppport.h */