eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'

if $running_under_some_shell;

use warnings;

use strict;

my( $H2XS_VERSION ) = ' $Revision: 1.23 $ ' =~ /\$Revision:\s+([^\s]+)/;

my $TEMPLATE_VERSION = '0.01';

my @ARGS = @ARGV;

my $compat_version = $];

use Getopt::Long;

use Config;

use Text::Wrap;

$Text::Wrap::huge = 'overflow';

$Text::Wrap::columns = 80;

use ExtUtils::Constant qw (WriteConstants WriteMakefileSnippet autoload);

use File::Compare;

use File::Path;

sub usage {

warn "@_\n" if @_;

die <<EOFUSAGE;

}

my ($opt_A,

$opt_B,

$opt_C,

$opt_F,

$opt_M,

$opt_O,

$opt_P,

$opt_X,

$opt_a,

$opt_c,

$opt_d,

$opt_e,

$opt_f,

$opt_g,

$opt_h,

$opt_k,

$opt_m,

$opt_n,

$opt_o,

$opt_p,

$opt_s,

$opt_v,

$opt_x,

$opt_b,

$opt_t,

$new_test,

$old_test,

$skip_exporter,

$skip_ppport,

$skip_autoloader,

$skip_strict,

$skip_warnings,

$use_xsloader

);

Getopt::Long::Configure('bundling');

Getopt::Long::Configure('pass_through');

my %options = (

'omit-autoload|A' => \$opt_A,

'beta-version|B' => \$opt_B,

'omit-changes|C' => \$opt_C,

'cpp-flags|F=s' => \$opt_F,

'func-mask|M=s' => \$opt_M,

'overwrite_ok|O' => \$opt_O,

'omit-pod|P' => \$opt_P,

'omit-XS|X' => \$opt_X,

'gen-accessors|a' => \$opt_a,

'compat-version|b=s' => \$opt_b,

'omit-constant|c' => \$opt_c,

'debugging|d' => \$opt_d,

'omit-enums|e:s' => \$opt_e,

'force|f' => \$opt_f,

'global|g' => \$opt_g,

'help|h|?' => \$opt_h,

'omit-const-func|k' => \$opt_k,

'gen-tied-var|m' => \$opt_m,

'name|n=s' => \$opt_n,

'opaque-re|o=s' => \$opt_o,

'remove-prefix|p=s' => \$opt_p,

'const-subs|s=s' => \$opt_s,

'default-type|t=s' => \$opt_t,

'version|v=s' => \$opt_v,

'autogen-xsubs|x' => \$opt_x,

'use-new-tests' => \$new_test,

'use-old-tests' => \$old_test,

'skip-exporter' => \$skip_exporter,

'skip-ppport' => \$skip_ppport,

'skip-autoloader' => \$skip_autoloader,

'skip-warnings' => \$skip_warnings,

'skip-strict' => \$skip_strict,

'use-xsloader' => \$use_xsloader,

);

GetOptions(%options) || usage;

usage if $opt_h;

if( $opt_b ){

usage "You cannot use -b and -m at the same time.\n" if ($opt_b && $opt_m);

$opt_b =~ /^\d+\.\d+\.\d+/ ||

usage "You must provide the backwards compatibility version in X.Y.Z form. "

. "(i.e. 5.5.0)\n";

my ($maj,$min,$sub) = split(/\./,$opt_b,3);

if ($maj < 5 || ($maj == 5 && $min < 6)) {

$compat_version =

$sub ? sprintf("%d.%03d%02d",$maj,$min,$sub) :

sprintf("%d.%03d", $maj,$min);

} else {

$compat_version =

$sub ? sprintf("%d.%03d%03d",$maj,$min,$sub) :

sprintf("%d.%03d", $maj,$min);

}

} else {

my ($maj,$min,$sub) = $compat_version =~ /(\d+)\.(\d\d\d)(\d*)/;

$sub ||= 0;

warn sprintf <<'EOF', $maj,$min,$sub;

}

if( $opt_B ){

$TEMPLATE_VERSION = '0.00_01';

}

if( $opt_v ){

$TEMPLATE_VERSION = $opt_v;

# check if it is numeric

my $temp_version = $TEMPLATE_VERSION;

my $beta_version = $temp_version =~ s/(\d)_(\d\d)/$1$2/;

my $notnum;

{

local $SIG{__WARN__} = sub { $notnum = 1 };

use warnings 'numeric';

$temp_version = 0+$temp_version;

}

if ($notnum) {

my $module = $opt_n || 'Your::Module';

warn <<"EOF";

}

else {

$opt_B = $beta_version;

}

}

$skip_autoloader = $opt_c = 1 if $opt_A;

$opt_c = $opt_f = 1 if $opt_X;

$opt_t ||= 'IV';

my %const_xsub;

%const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;

my $extralibs = '';

my @path_h;

while (my $arg = shift) {

if ($arg =~ /^-l/i) {

$extralibs .= "$arg ";

next;

}

last if $extralibs;

push(@path_h, $arg);

}

usage "Must supply header file or module name\n"

unless (@path_h or $opt_n);

my $fmask;

my $tmask;

$fmask = qr{$opt_M} if defined $opt_M;

$tmask = qr{$opt_o} if defined $opt_o;

my $tmask_all = $tmask && $opt_o eq '.';

if ($opt_x) {

eval {require C::Scan; 1}

or die <<EOD;

unless ($tmask_all) {

$C::Scan::VERSION >= 0.70

or die <<EOD;

}

if (($opt_m || $opt_a) && $C::Scan::VERSION < 0.73) {

die <<EOD;

}

}

elsif ($opt_o or $opt_F) {

warn <<EOD if $opt_o;

warn <<EOD if $opt_F and $opt_X ;

}

my @path_h_ini = @path_h;

my ($name, %fullpath, %prefix, %seen_define, %prefixless, %const_names);

my $module = $opt_n;

if( @path_h ){

use File::Spec;

my @paths;

my $pre_sub_tri_graphs = 1;

if ($^O eq 'VMS') { # Consider overrides of default location

# XXXX This is not equivalent to what the older version did:

# it was looking at $hadsys header-file per header-file...

my($hadsys) = grep s!^sys/!!i , @path_h;

@paths = qw( Sys$Library VAXC$Include );

push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]');

push @paths, qw( DECC$Library_Include DECC$System_Include );

}

else {

@paths = (File::Spec->curdir(), $Config{usrinc},

(split ' ', $Config{locincpth}), '/usr/include');

}

foreach my $path_h (@path_h) {

$name ||= $path_h;

$module ||= do {

$name =~ s/\.h$//;

if ( $name !~ /::/ ) {

$name =~ s#^.*/##;

$name = "\u$name";

}

$name;

};

if( $path_h =~ s#::#/#g && $opt_n ){

warn "Nesting of headerfile ignored with -n\n";

}

$path_h .= ".h" unless $path_h =~ /\.h$/;

my $fullpath = $path_h;

$path_h =~ s/,.*$// if $opt_x;

$fullpath{$path_h} = $fullpath;

# Minor trickery: we can't chdir() before we processed the headers

# (so know the name of the extension), but the header may be in the

# extension directory...

my $tmp_path_h = $path_h;

my $rel_path_h = $path_h;

my @dirs = @paths;

if (not -f $path_h) {

my $found;

for my $dir (@paths) {

$found++, last

if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h));

}

if ($found) {

$rel_path_h = $path_h;

$fullpath{$path_h} = $fullpath;

} else {

(my $epath = $module) =~ s,::,/,g;

$epath = File::Spec->catdir('ext', $epath) if -d 'ext';

$rel_path_h = File::Spec->catfile($epath, $tmp_path_h);

$path_h = $tmp_path_h; # Used during -x

push @dirs, $epath;

}

}

if (!$opt_c) {

die "Can't find $tmp_path_h in @dirs\n"

if ( ! $opt_f && ! -f "$rel_path_h" );

# Scan the header file (we should deal with nested header files)

# Record the names of simple #define constants into const_names

# Function prototypes are processed below.

open(CH, "<$rel_path_h") || die "Can't open $rel_path_h: $!\n";

defines:

while (<CH>) {

if ($pre_sub_tri_graphs) {

# Preprocess all tri-graphs

# including things stuck in quoted string constants.

s/\?\?=/#/g; # | ??=| #|

s/\?\?\!/|/g; # | ??!| ||

s/\?\?'/^/g; # | ??'| ^|

s/\?\?\(/[/g; # | ??(| [|

s/\?\?\)/]/g; # | ??)| ]|

s/\?\?\-/~/g; # | ??-| ~|

s/\?\?\//\\/g; # | ??/| \|

s/\?\?</{/g; # | ??<| {|

s/\?\?>/}/g; # | ??>| }|

}

if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^"\s])(.*)/) {

my $def = $1;

my $rest = $2;

$rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments

$rest =~ s/^\s+//;

$rest =~ s/\s+$//;

# Cannot do: (-1) and ((LHANDLE)3) are OK:

#print("Skip non-wordy $def => $rest\n"),

# next defines if $rest =~ /[^\w\$]/;

if ($rest =~ /"/) {

print("Skip stringy $def => $rest\n") if $opt_d;

next defines;

}

print "Matched $_ ($def)\n" if $opt_d;

$seen_define{$def} = $rest;

$_ = $def;

next if /^_.*_h_*$/i; # special case, but for what?

if (defined $opt_p) {

if (!/^$opt_p(\d)/) {

++$prefix{$_} if s/^$opt_p//;

}

else {

warn "can't remove $opt_p prefix from '$_'!\n";

}

}

$prefixless{$def} = $_;

if (!$fmask or /$fmask/) {

print "... Passes mask of -M.\n" if $opt_d and $fmask;

$const_names{$_}++;

}

}

}

if (defined $opt_e and !$opt_e) {

close(CH);

}

else {

# Work from miniperl too - on "normal" systems

my $SEEK_SET = eval 'use Fcntl qw/SEEK_SET/; SEEK_SET' or 0;

seek CH, 0, $SEEK_SET;

my $src = do { local $/; <CH> };

close CH;

no warnings 'uninitialized';

# Remove C and C++ comments

$src =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#$2#gs;

while ($src =~ /\benum\s*([\w_]*)\s*\{\s([^}]+)\}/gsc) {

my ($enum_name, $enum_body) = ($1, $2);

# skip enums matching $opt_e

next if $opt_e && $enum_name =~ /$opt_e/;

my $val = 0;

for my $item (split /,/, $enum_body) {

my ($key, $declared_val) = $item =~ /(\w+)\s*(?:=\s*(.*))?/;

$val = defined($declared_val) && length($declared_val) ? $declared_val : 1 + $val;

$seen_define{$key} = $val;

$const_names{$key}++;

}

} # while (...)

} # if (!defined $opt_e or $opt_e)

}

}

}

my $cwd = File::Spec->rel2abs( File::Spec->curdir );

my $constscfname = 'const-c.inc';

my $constsxsfname = 'const-xs.inc';

my $fallbackdirname = 'fallback';

my $ext = chdir 'ext' ? 'ext/' : '';

my @modparts = split(/::/,$module);

my $modpname = join('-', @modparts);

my $modfname = pop @modparts;

my $modpmdir = join '/', 'lib', @modparts;

my $modpmname = join '/', $modpmdir, $modfname.'.pm';

if ($opt_O) {

warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname;

}

else {

die "Won't overwrite existing $ext$modpname\n" if -e $modpname;

}

-d "$modpname" || mkpath([$modpname], 0, 0775);

chdir($modpname) || die "Can't chdir $ext$modpname: $!\n";

my %types_seen;

my %std_types;

my $fdecls = [];

my $fdecls_parsed = [];

my $typedef_rex;

my %typedefs_pre;

my %known_fnames;

my %structs;

my @fnames;

my @fnames_no_prefix;

my %vdecl_hash;

my @vdecls;

if( ! $opt_X ){ # use XS, unless it was disabled

unless ($skip_ppport) {

require Devel::PPPort;

warn "Writing $ext$modpname/ppport.h\n";

Devel::PPPort::WriteFile('ppport.h')

|| die "Can't create $ext$modpname/ppport.h: $!\n";

}

open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";

if ($opt_x) {

warn "Scanning typemaps...\n";

get_typemap();

my @td;

my @good_td;

my $addflags = $opt_F || '';

foreach my $filename (@path_h) {

my $c;

my $filter;

if ($fullpath{$filename} =~ /,/) {

$filename = $`;

$filter = $';

}

warn "Scanning $filename for functions...\n";

my @styles = $Config{gccversion} ? qw(C++ C9X GNU) : qw(C++ C9X);

$c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,

'add_cppflags' => $addflags, 'c_styles' => \@styles;

$c->set('includeDirs' => ["$Config::Config{archlib}/CORE", $cwd]);

$c->get('keywords')->{'__restrict'} = 1;

push @$fdecls_parsed, @{ $c->get('parsed_fdecls') };

push(@$fdecls, @{$c->get('fdecls')});

push @td, @{$c->get('typedefs_maybe')};

if ($opt_a) {

my $structs = $c->get('typedef_structs');

@structs{keys %$structs} = values %$structs;

}

if ($opt_m) {

%vdecl_hash = %{ $c->get('vdecl_hash') };

@vdecls = sort keys %vdecl_hash;

for (local $_ = 0; $_ < @vdecls; ++$_) {

my $var = $vdecls[$_];

my($type, $post) = @{ $vdecl_hash{$var} };

if (defined $post) {

warn "Can't handle variable '$type $var $post', skipping.\n";

splice @vdecls, $_, 1;

redo;

}

$type = normalize_type($type);

$vdecl_hash{$var} = $type;

}

}

unless ($tmask_all) {

warn "Scanning $filename for typedefs...\n";

my $td = $c->get('typedef_hash');

# eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d;

my @f_good_td = grep $td->{$_}[1] eq '', keys %$td;

push @good_td, @f_good_td;

@typedefs_pre{@f_good_td} = map $_->[0], @$td{@f_good_td};

}

}

{ local $" = '|';

$typedef_rex = qr(\b(?<!struct )(?:@good_td)\b) if @good_td;

}

%known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT

if ($fmask) {

my @good;

for my $i (0..$#$fdecls_parsed) {

next unless $fdecls_parsed->[$i][1] =~ /$fmask/; # [1] is NAME

push @good, $i;

print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n"