[perl5.git] / cpan / Win32API-File / ExtUtils / Myconst2perl.pm

# This should eventually become part of MakeMaker as ExtUtils::Mkconst2perl.
# Documentation for this is very skimpy at this point.  Full documentation
# will be added to ExtUtils::Mkconst2perl when it is created.
package # Hide from PAUSE
         ExtUtils::Myconst2perl;

use strict;
use Config;

use vars qw( @ISA @EXPORT @EXPORT_OK $VERSION );
BEGIN {
    require Exporter;
    push @ISA, 'Exporter';
    @EXPORT= qw( &Myconst2perl );
    @EXPORT_OK= qw( &ParseAttribs );
    $VERSION= 1.00;
}

use Carp;
use File::Basename;
use ExtUtils::MakeMaker qw( neatvalue );

# Return the extension to use for a file of C++ source code:
sub _cc
{
    # Some day, $Config{_cc} might be defined for us:
    return $Config{_cc}   if  $Config{_cc};
    return ".cxx";	# Seems to be the most widely accepted extension.
}

=item ParseAttribs

Parses user-firendly options into coder-firendly specifics.

=cut

sub ParseAttribs
{
    # Usage:  ParseAttribs( "Package::Name", \%opts, {opt=>\$var} );
    my( $pkg, $hvAttr, $hvRequests )= @_;
    my( $outfile, @perlfiles, %perlfilecodes, @cfiles, %cfilecodes );
    my @importlist= @{$hvAttr->{IMPORT_LIST}};
    my $perlcode= $hvAttr->{PERL_PE_CODE} ||
	'last if /^\s*(bootstrap|XSLoader::load)\b/';
    my $ccode= $hvAttr->{C_PE_CODE} ||
	'last if m#/[/*]\s*CONSTS_DEFINED\b|^\s*MODULE\b#';
    my $ifdef= $hvAttr->{IFDEF} || 0;
    my $writeperl= !! $hvAttr->{WRITE_PERL};
    my $export= !! $hvAttr->{DO_EXPORT};
    my $importto= $hvAttr->{IMPORT_TO} || "_constants";
    my $cplusplus= $hvAttr->{CPLUSPLUS};
    $cplusplus= ""   if  ! defined $cplusplus;
    my $object= "";
    my $binary= "";
    my $final= "";
    my $norebuild= "";
    my $subroutine= "";
    my $base;
    my %params= (
	PERL_PE_CODE => \$perlcode,
	PERL_FILE_LIST => \@perlfiles,
	PERL_FILE_CODES => \%perlfilecodes,
	PERL_FILES => sub { map {($_,$perlfilecodes{$_})} @perlfiles },
	C_PE_CODE => \$ccode,
	C_FILE_LIST => \@cfiles,
	C_FILE_CODES => \%cfilecodes,
	C_FILES => sub { map {($_,$cfilecodes{$_})} @cfiles },
	DO_EXPORT => \$export,
	IMPORT_TO => \$importto,
	IMPORT_LIST => \@importlist,
	SUBROUTINE => \$subroutine,
	IFDEF => \$ifdef,
	WRITE_PERL => \$writeperl,
	CPLUSPLUS => \$cplusplus,
	BASEFILENAME => \$base,
	OUTFILE => \$outfile,
	OBJECT => \$object,
	BINARY => \$binary,
	FINAL_PERL => \$final,
	NO_REBUILD => \$norebuild,
    );
    {   my @err= grep {! defined $params{$_}} keys %$hvAttr;
	carp "ExtUtils::Myconst2perl::ParseAttribs:  ",
	  "Unsupported option(s) (@err).\n"
	  if  @err;
    }
    $norebuild= $hvAttr->{NO_REBUILD}   if  exists $hvAttr->{NO_REBUILD};
    my $module= ( split /::/, $pkg )[-1];
    $base= "c".$module;
    $base= $hvAttr->{BASEFILENAME}   if  exists $hvAttr->{BASEFILENAME};
    my $ext=  ! $cplusplus  ?  ($Config{_c}||".c")
      :  $cplusplus =~ /^[.]/  ?  $cplusplus  :  _cc();
    if(  $writeperl  ) {
	$outfile= $base . "_pc" . $ext;
	$object= $base . "_pc" . ($Config{_o}||$Config{obj_ext});
	$object= $hvAttr->{OBJECT}   if  $hvAttr->{OBJECT};
	$binary= $base . "_pc" . ($Config{_exe}||$Config{exe_ext});
	$binary= $hvAttr->{BINARY}   if  $hvAttr->{BINARY};
	$final= $base . ".pc";
	$final= $hvAttr->{FINAL_PERL}   if  $hvAttr->{FINAL_PERL};
	$subroutine= "main";
    } elsif(  $cplusplus  ) {
	$outfile= $base . $ext;
	$object= $base . ($Config{_o}||$Config{obj_ext});
	$object= $hvAttr->{OBJECT}   if  $hvAttr->{OBJECT};
	$subroutine= "const2perl_" . $pkg;
	$subroutine =~ s/\W/_/g;
    } else {
	$outfile= $base . ".h";
    }
    $outfile= $hvAttr->{OUTFILE}   if  $hvAttr->{OUTFILE};
    if(  $hvAttr->{PERL_FILES}  ) {
	carp "ExtUtils::Myconst2perl:  PERL_FILES option not allowed ",
	  "with PERL_FILE_LIST nor PERL_FILE_CODES.\n"
	  if  $hvAttr->{PERL_FILE_LIST}  ||  $hvAttr->{PERL_FILE_CODES};
	%perlfilecodes= @{$hvAttr->{PERL_FILES}};
	my $odd= 0;
	@perlfiles= grep {$odd= !$odd} @{$hvAttr->{PERL_FILES}};
    } else {
	if(  $hvAttr->{PERL_FILE_LIST}  ) {
	    @perlfiles= @{$hvAttr->{PERL_FILE_LIST}};
	} elsif(  $hvAttr->{PERL_FILE_CODES}  ) {
	    @perlfiles= keys %{$hvAttr->{PERL_FILE_CODES}};
	} else {
	    @perlfiles= ( "$module.pm" );
	}
	%perlfilecodes= %{$hvAttr->{PERL_FILE_CODES}}
	  if  $hvAttr->{PERL_FILE_CODES};
    }
    for my $file (  @perlfiles  ) {
	$perlfilecodes{$file}= $perlcode  if  ! $perlfilecodes{$file};
    }
    if(  ! $subroutine  ) {
	; # Don't process any C source code files.
    } elsif(  $hvAttr->{C_FILES}  ) {
	carp "ExtUtils::Myconst2perl:  C_FILES option not allowed ",
	  "with C_FILE_LIST nor C_FILE_CODES.\n"
	  if  $hvAttr->{C_FILE_LIST}  ||  $hvAttr->{C_FILE_CODES};
	%cfilecodes= @{$hvAttr->{C_FILES}};
	my $odd= 0;
	@cfiles= grep {$odd= !$odd} @{$hvAttr->{C_FILES}};
    } else {
	if(  $hvAttr->{C_FILE_LIST}  ) {
	    @cfiles= @{$hvAttr->{C_FILE_LIST}};
	} elsif(  $hvAttr->{C_FILE_CODES}  ) {
	    @cfiles= keys %{$hvAttr->{C_FILE_CODES}};
	} elsif(  $writeperl  ||  $cplusplus  ) {
	    @cfiles= ( "$module.xs" );
	}
	%cfilecodes= %{$hvAttr->{C_FILE_CODES}}   if  $hvAttr->{C_FILE_CODES};
    }
    for my $file (  @cfiles  ) {
	$cfilecodes{$file}= $ccode  if  ! $cfilecodes{$file};
    }
    for my $key (  keys %$hvRequests  ) {
	if(  ! $params{$key}  ) {
	    carp "ExtUtils::Myconst2perl::ParseAttribs:  ",
	      "Unsupported output ($key).\n";
	} elsif(  "SCALAR" eq ref( $params{$key} )  ) {
	    ${$hvRequests->{$key}}= ${$params{$key}};
	} elsif(  "ARRAY" eq ref( $params{$key} )  ) {
	    @{$hvRequests->{$key}}= @{$params{$key}};
	} elsif(  "HASH" eq ref( $params{$key} )  ) {
	    %{$hvRequests->{$key}}= %{$params{$key}};
	} elsif(  "CODE" eq ref( $params{$key} )  ) {
	    @{$hvRequests->{$key}}=  &{$params{$key}};
	} else {
	    die "Impossible value in \$params{$key}";
	}
    }
}

=item Myconst2perl

Generates a file used to implement C constants as "constant subroutines" in
a Perl module.

Extracts a list of constants from a module's export list by C<eval>ing the
first part of the Module's F<*.pm> file and then requesting some groups of
symbols be exported/imported into a dummy package.  Then writes C or C++
code that can convert each C constant into a Perl "constant subroutine"
whose name is the constant's name and whose value is the constant's value.

=cut

sub Myconst2perl
{
    my( $pkg, %spec )= @_;
    my( $outfile, $writeperl, $ifdef, $export, $importto, @importlist,
        @perlfile, %perlcode, @cfile, %ccode, $routine );
    ParseAttribs( $pkg, \%spec, {
	DO_EXPORT => \$export,
	IMPORT_TO => \$importto,
	IMPORT_LIST => \@importlist,
	IFDEF => \$ifdef,
	WRITE_PERL => \$writeperl,
	OUTFILE => \$outfile,
	PERL_FILE_LIST => \@perlfile,
	PERL_FILE_CODES => \%perlcode,
	C_FILE_LIST => \@cfile,
	C_FILE_CODES => \%ccode,
	SUBROUTINE => \$routine,
    } );
    my $module= ( split /::/, $pkg )[-1];

    warn "Writing $outfile...\n";
    open( STDOUT, ">$outfile" )  or  die "Can't create $outfile: $!\n";

    my $code= "";
    my $file;
    foreach $file (  @perlfile  ) {
	warn "Reading Perl file, $file:  $perlcode{$file}\n";
	open( MODULE, "<$file" )  or  die "Can't read Perl file, $file: $!\n";
	eval qq[
	    while(  <MODULE>  ) {
		$perlcode{$file};
		\$code .= \$_;
	    }
	    1;
	]  or  die "$file eval: $@\n";
	close( MODULE );
    }

    print
      "/* $outfile - Generated by ExtUtils::Myconst2perl::Myconst2perl */\n";
    if(  $routine  ) {
	print "/* See start of $routine() for generation parameters used */\n";
	#print "#define main _main_proto"
	#  " /* Ignore Perl's main() prototype */\n\n";
	if(  $writeperl  ) {
	    # Here are more reasons why the WRITE_PERL option is discouraged.
	    if(  $Config{useperlio}  ) {
		print "#define PERLIO_IS_STDIO 1\n";
	    }
	    print "#define WIN32IO_IS_STDIO 1\n";	# May cause a warning
	    print "#define NO_XSLOCKS 1\n";	# What a hack!
	}
	foreach $file (  @cfile  ) {
	    warn "Reading C file, $file:  $ccode{$file}\n";
	    open( XS, "<$file" )  or  die "Can't read C file, $file: $!\n";
	    my $code= $ccode{$file};
	    $code =~ s#\\#\\\\#g;
	    $code =~ s#([^\s -~])#"\\x".sprintf "%02X",unpack "C",$1#ge;
	    $code =~ s#[*]/#*\\/#g;
	    print qq[\n/* Include $file:  $code */\n];
	    print qq[\n#line 1 "$file"\n];
	    eval qq[
		while(  <XS>  ) {
		    $ccode{$file};
		    print;
		}
		1;
	    ]  or  die "$file eval: $@\n";
	    close( XS );
	}
	#print qq[\n#undef main\n];
	print qq[\n#define CONST2WRITE_PERL\n];
	print qq[\n#include "const2perl.h"\n\n];
	if(  $writeperl  ) {
	    print "int\nmain( int argc, char *argv[], char *envp[] )\n";
	} else {
	    print "void\n$routine( void )\n";
	}
    }
    print "{\n";

    {
	@ExtUtils::Myconst2perl::importlist= @importlist;
	my $var= '@ExtUtils::Myconst2perl::importlist';
	my $port= $export ? "export" : "import";
	my $arg2= $export ? "q[$importto]," : "";
	local( $^W )= 0;
	eval $code . "{\n"
	  . "    {    package $importto;\n"
	  . "        warn qq[\u${port}ing to $importto: $var\\n];\n"
	  . "        \$pkg->$port( $arg2 $var );\n"
	  . "    }\n"
	  . "    {   no strict 'refs';\n"
	  . "        $var=  sort keys %{'_constants::'};   }\n"
	  . "    warn 0 + $var, qq[ symbols ${port}ed.\\n];\n"
	  . "}\n1;\n"
	  or  die "eval: $@\n";
    }
    my @syms= @ExtUtils::Myconst2perl::importlist;

    my $if;
    my $const;
    print qq[    START_CONSTS( "$pkg" )	/* No ";" */\n];
    {
	my( $head, $tail )= ( "/*", "\n" );
	if(  $writeperl  ) {
	    $head= '    printf( "#';
	    $tail= '\\n" );' . "\n";
	    print $head, " Generated by $outfile.", $tail;
	}
	print $head, " Package $pkg with options:", $tail;
	$head= " *"   if  ! $writeperl;
	my $key;
	foreach $key (  sort keys %spec  ) {
	    my $val= neatvalue($spec{$key});
	    $val =~ s/\\/\\\\/g   if  $writeperl;
	    print $head, "    $key => ", $val, $tail;
	}
	print $head, " Perl files eval'd:", $tail;
	foreach $key (  @perlfile  ) {
	    my $code= $perlcode{$key};
	    $code =~ s#\\#\\\\#g;
	    $code =~ s#([^ -~])#"\\".sprintf "%03o",unpack "C",$1#ge;
	    $code =~ s#"#\\"#g   if  $writeperl;
	    print $head, "    $key => ", $code, $tail;
	}
	if(  $writeperl  ) {
	    print $head, " C files included:", $tail;
	    foreach $key (  @cfile  ) {
		my $code= $ccode{$key};
		$code =~ s#\\#\\\\#g;
		$code =~ s#([^ -~])#"\\".sprintf "%03o",unpack "C",$1#ge;
		$code =~ s#"#\\"#g;
		print $head, "    $key => ", $code, $tail;
	    }
	} else {
	    print " */\n";
	}
    }
    if(  ! ref($ifdef)  &&  $ifdef =~ /[^\s\w]/  ) {
	my $sub= $ifdef;
	$sub= 'sub { local($_)= @_; ' . $sub . ' }'
	  unless  $sub =~ /^\s*sub\b/;
	$ifdef= eval $sub;
	die "$@:  $sub\n"   if  $@;
	if(  "CODE" ne ref($ifdef)  ) {
	    die "IFDEF didn't create subroutine reference:  eval $sub\n";
	}
    }
    foreach $const (  @syms  ) {
	$if=  "CODE" eq ref($ifdef)  ?  $ifdef->($const)  :  $ifdef;
	if(  ! $if  ) {
	    $if= "";
	} elsif(  "1" eq $if  ) {
	    $if= "#ifdef $const\n";
	} elsif(  $if !~ /^#/  ) {
	    $if= "#ifdef $if\n";
	} else {
	    $if= "$if\n";
	}
	print $if
	  . qq[    const2perl( $const );\n];
	if(  $if  ) {
	    print "#else\n"
	      . qq[    noconst( $const );\n]
	      . "#endif\n";
	}
    }
    if(  $writeperl  ) {
	print
	  qq[    printf( "1;\\n" );\n],
	  qq[    return( 0 );\n];
    }
    print "}\n";
}

1;
Commit	Line	Data
00701878 SH	1	# This should eventually become part of MakeMaker as ExtUtils::Mkconst2perl.
	2	# Documentation for this is very skimpy at this point. Full documentation
	3	# will be added to ExtUtils::Mkconst2perl when it is created.
3826db83 SH	4	package # Hide from PAUSE
3826db83 SH	5	ExtUtils::Myconst2perl;
00701878 SH	6
	7	use strict;
	8	use Config;
	9
	10	use vars qw( @ISA @EXPORT @EXPORT_OK $VERSION );
	11	BEGIN {
	12	require Exporter;
	13	push @ISA, 'Exporter';
	14	@EXPORT= qw( &Myconst2perl );
	15	@EXPORT_OK= qw( &ParseAttribs );
	16	$VERSION= 1.00;
	17	}
	18
	19	use Carp;
	20	use File::Basename;
	21	use ExtUtils::MakeMaker qw( neatvalue );
	22
	23	# Return the extension to use for a file of C++ source code:
	24	sub _cc
	25	{
	26	# Some day, $Config{_cc} might be defined for us:
	27	return $Config{_cc} if $Config{_cc};
	28	return ".cxx"; # Seems to be the most widely accepted extension.
	29	}
	30
	31	=item ParseAttribs
	32
	33	Parses user-firendly options into coder-firendly specifics.
	34
	35	=cut
	36
	37	sub ParseAttribs
	38	{
	39	# Usage: ParseAttribs( "Package::Name", \%opts, {opt=>\$var} );
	40	my( $pkg, $hvAttr, $hvRequests )= @_;
	41	my( $outfile, @perlfiles, %perlfilecodes, @cfiles, %cfilecodes );
	42	my @importlist= @{$hvAttr->{IMPORT_LIST}};
	43	my $perlcode= $hvAttr->{PERL_PE_CODE} \|\|
	44	'last if /^\s*(bootstrap\|XSLoader::load)\b/';
	45	my $ccode= $hvAttr->{C_PE_CODE} \|\|
	46	'last if m#/[/]\sCONSTS_DEFINED\b\|^\s*MODULE\b#';
	47	my $ifdef= $hvAttr->{IFDEF} \|\| 0;
	48	my $writeperl= !! $hvAttr->{WRITE_PERL};
	49	my $export= !! $hvAttr->{DO_EXPORT};
	50	my $importto= $hvAttr->{IMPORT_TO} \|\| "_constants";
	51	my $cplusplus= $hvAttr->{CPLUSPLUS};
	52	$cplusplus= "" if ! defined $cplusplus;
	53	my $object= "";
	54	my $binary= "";
	55	my $final= "";
	56	my $norebuild= "";
	57	my $subroutine= "";
	58	my $base;
	59	my %params= (
	60	PERL_PE_CODE => \$perlcode,
	61	PERL_FILE_LIST => \@perlfiles,
	62	PERL_FILE_CODES => \%perlfilecodes,
	63	PERL_FILES => sub { map {($_,$perlfilecodes{$_})} @perlfiles },
	64	C_PE_CODE => \$ccode,
	65	C_FILE_LIST => \@cfiles,
	66	C_FILE_CODES => \%cfilecodes,
	67	C_FILES => sub { map {($_,$cfilecodes{$_})} @cfiles },
	68	DO_EXPORT => \$export,
	69	IMPORT_TO => \$importto,
70	IMPORT_LIST => \@importlist,
71	SUBROUTINE => \$subroutine,
72	IFDEF => \$ifdef,
73	WRITE_PERL => \$writeperl,
74	CPLUSPLUS => \$cplusplus,
75	BASEFILENAME => \$base,
76	OUTFILE => \$outfile,
77	OBJECT => \$object,
78	BINARY => \$binary,
79	FINAL_PERL => \$final,
80	NO_REBUILD => \$norebuild,
81	);
82	{ my @err= grep {! defined $params{$_}} keys %$hvAttr;
83	carp "ExtUtils::Myconst2perl::ParseAttribs: ",
84	"Unsupported option(s) (@err).\n"
85	if @err;
86	}
87	$norebuild= $hvAttr->{NO_REBUILD} if exists $hvAttr->{NO_REBUILD};
88	my $module= ( split /::/, $pkg )[-1];
89	$base= "c".$module;
90	$base= $hvAttr->{BASEFILENAME} if exists $hvAttr->{BASEFILENAME};
91	my $ext= ! $cplusplus ? ($Config{_c}\|\|".c")
92	: $cplusplus =~ /^[.]/ ? $cplusplus : _cc();
93	if( $writeperl ) {
94	$outfile= $base . "_pc" . $ext;
95	$object= $base . "_pc" . ($Config{_o}\|\|$Config{obj_ext});
96	$object= $hvAttr->{OBJECT} if $hvAttr->{OBJECT};
97	$binary= $base . "_pc" . ($Config{_exe}\|\|$Config{exe_ext});
98	$binary= $hvAttr->{BINARY} if $hvAttr->{BINARY};
99	$final= $base . ".pc";
100	$final= $hvAttr->{FINAL_PERL} if $hvAttr->{FINAL_PERL};
101	$subroutine= "main";
102	} elsif( $cplusplus ) {
103	$outfile= $base . $ext;
104	$object= $base . ($Config{_o}\|\|$Config{obj_ext});
105	$object= $hvAttr->{OBJECT} if $hvAttr->{OBJECT};
106	$subroutine= "const2perl_" . $pkg;
107	$subroutine =~ s/\W/_/g;
108	} else {
109	$outfile= $base . ".h";
110	}
111	$outfile= $hvAttr->{OUTFILE} if $hvAttr->{OUTFILE};
112	if( $hvAttr->{PERL_FILES} ) {
113	carp "ExtUtils::Myconst2perl: PERL_FILES option not allowed ",
114	"with PERL_FILE_LIST nor PERL_FILE_CODES.\n"
115	if $hvAttr->{PERL_FILE_LIST} \|\| $hvAttr->{PERL_FILE_CODES};
116	%perlfilecodes= @{$hvAttr->{PERL_FILES}};
117	my $odd= 0;
118	@perlfiles= grep {$odd= !$odd} @{$hvAttr->{PERL_FILES}};
119	} else {
120	if( $hvAttr->{PERL_FILE_LIST} ) {
121	@perlfiles= @{$hvAttr->{PERL_FILE_LIST}};
122	} elsif( $hvAttr->{PERL_FILE_CODES} ) {
123	@perlfiles= keys %{$hvAttr->{PERL_FILE_CODES}};
124	} else {
125	@perlfiles= ( "$module.pm" );
126	}
127	%perlfilecodes= %{$hvAttr->{PERL_FILE_CODES}}
128	if $hvAttr->{PERL_FILE_CODES};
129	}
130	for my $file ( @perlfiles ) {
131	$perlfilecodes{$file}= $perlcode if ! $perlfilecodes{$file};
132	}
133	if( ! $subroutine ) {
134	; # Don't process any C source code files.
135	} elsif( $hvAttr->{C_FILES} ) {
136	carp "ExtUtils::Myconst2perl: C_FILES option not allowed ",
137	"with C_FILE_LIST nor C_FILE_CODES.\n"
138	if $hvAttr->{C_FILE_LIST} \|\| $hvAttr->{C_FILE_CODES};
139	%cfilecodes= @{$hvAttr->{C_FILES}};
140	my $odd= 0;
141	@cfiles= grep {$odd= !$odd} @{$hvAttr->{C_FILES}};
142	} else {
143	if( $hvAttr->{C_FILE_LIST} ) {
144	@cfiles= @{$hvAttr->{C_FILE_LIST}};
145	} elsif( $hvAttr->{C_FILE_CODES} ) {
146	@cfiles= keys %{$hvAttr->{C_FILE_CODES}};
147	} elsif( $writeperl \|\| $cplusplus ) {
148	@cfiles= ( "$module.xs" );
149	}
150	%cfilecodes= %{$hvAttr->{C_FILE_CODES}} if $hvAttr->{C_FILE_CODES};
151	}
152	for my $file ( @cfiles ) {
153	$cfilecodes{$file}= $ccode if ! $cfilecodes{$file};
154	}
155	for my $key ( keys %$hvRequests ) {
156	if( ! $params{$key} ) {
157	carp "ExtUtils::Myconst2perl::ParseAttribs: ",
158	"Unsupported output ($key).\n";
159	} elsif( "SCALAR" eq ref( $params{$key} ) ) {
160	${$hvRequests->{$key}}= ${$params{$key}};
161	} elsif( "ARRAY" eq ref( $params{$key} ) ) {
162	@{$hvRequests->{$key}}= @{$params{$key}};
163	} elsif( "HASH" eq ref( $params{$key} ) ) {
164	%{$hvRequests->{$key}}= %{$params{$key}};
165	} elsif( "CODE" eq ref( $params{$key} ) ) {
166	@{$hvRequests->{$key}}= &{$params{$key}};
167	} else {
168	die "Impossible value in \$params{$key}";
169	}
170	}
171	}
172
173	=item Myconst2perl
174
175	Generates a file used to implement C constants as "constant subroutines" in
176	a Perl module.
177
178	Extracts a list of constants from a module's export list by C<eval>ing the
179	first part of the Module's F<*.pm> file and then requesting some groups of
180	symbols be exported/imported into a dummy package. Then writes C or C++
181	code that can convert each C constant into a Perl "constant subroutine"
182	whose name is the constant's name and whose value is the constant's value.
183
184	=cut
185
186	sub Myconst2perl
187	{
188	my( $pkg, %spec )= @_;
189	my( $outfile, $writeperl, $ifdef, $export, $importto, @importlist,
190	@perlfile, %perlcode, @cfile, %ccode, $routine );
191	ParseAttribs( $pkg, \%spec, {
192	DO_EXPORT => \$export,
193	IMPORT_TO => \$importto,
194	IMPORT_LIST => \@importlist,
195	IFDEF => \$ifdef,
196	WRITE_PERL => \$writeperl,
197	OUTFILE => \$outfile,
198	PERL_FILE_LIST => \@perlfile,
199	PERL_FILE_CODES => \%perlcode,
200	C_FILE_LIST => \@cfile,
201	C_FILE_CODES => \%ccode,
202	SUBROUTINE => \$routine,
203	} );
204	my $module= ( split /::/, $pkg )[-1];
205
206	warn "Writing $outfile...\n";
207	open( STDOUT, ">$outfile" ) or die "Can't create $outfile: $!\n";
208
209	my $code= "";
210	my $file;
211	foreach $file ( @perlfile ) {
212	warn "Reading Perl file, $file: $perlcode{$file}\n";
213	open( MODULE, "<$file" ) or die "Can't read Perl file, $file: $!\n";
214	eval qq[
215	while( <MODULE> ) {
216	$perlcode{$file};
217	\$code .= \$_;
218	}
219	1;
220	] or die "$file eval: $@\n";
221	close( MODULE );
222	}
223
224	print
225	"/* $outfile - Generated by ExtUtils::Myconst2perl::Myconst2perl */\n";
226	if( $routine ) {
227	print "/* See start of $routine() for generation parameters used */\n";
228	#print "#define main _main_proto"
229	# " /* Ignore Perl's main() prototype */\n\n";
230	if( $writeperl ) {
231	# Here are more reasons why the WRITE_PERL option is discouraged.
232	if( $Config{useperlio} ) {
233	print "#define PERLIO_IS_STDIO 1\n";
234	}
235	print "#define WIN32IO_IS_STDIO 1\n"; # May cause a warning
236	print "#define NO_XSLOCKS 1\n"; # What a hack!
237	}
238	foreach $file ( @cfile ) {
239	warn "Reading C file, $file: $ccode{$file}\n";
240	open( XS, "<$file" ) or die "Can't read C file, $file: $!\n";
241	my $code= $ccode{$file};
242	$code =~ s#\\#\\\\#g;
243	$code =~ s#([^\s -~])#"\\x".sprintf "%02X",unpack "C",$1#ge;
244	$code =~ s#[]/#\\/#g;
245	print qq[\n/* Include $file: $code */\n];
246	print qq[\n#line 1 "$file"\n];
247	eval qq[
248	while( <XS> ) {
249	$ccode{$file};
250	print;
251	}
252	1;
253	] or die "$file eval: $@\n";
254	close( XS );
255	}
256	#print qq[\n#undef main\n];
257	print qq[\n#define CONST2WRITE_PERL\n];
258	print qq[\n#include "const2perl.h"\n\n];
259	if( $writeperl ) {
260	print "int\nmain( int argc, char argv[], char envp[] )\n";
261	} else {
262	print "void\n$routine( void )\n";
263	}
264	}
265	print "{\n";
266
267	{
268	@ExtUtils::Myconst2perl::importlist= @importlist;
269	my $var= '@ExtUtils::Myconst2perl::importlist';
270	my $port= $export ? "export" : "import";
271	my $arg2= $export ? "q[$importto]," : "";
272	local( $^W )= 0;
273	eval $code . "{\n"
274	. " { package $importto;\n"
275	. " warn qq[\u${port}ing to $importto: $var\\n];\n"
276	. " \$pkg->$port( $arg2 $var );\n"
277	. " }\n"
278	. " { no strict 'refs';\n"
279	. " $var= sort keys %{'_constants::'}; }\n"
280	. " warn 0 + $var, qq[ symbols ${port}ed.\\n];\n"
281	. "}\n1;\n"
282	or die "eval: $@\n";
283	}
284	my @syms= @ExtUtils::Myconst2perl::importlist;
285
286	my $if;
287	my $const;
288	print qq[ START_CONSTS( "$pkg" ) /* No ";" */\n];
289	{
290	my( $head, $tail )= ( "/*", "\n" );
291	if( $writeperl ) {
292	$head= ' printf( "#';
293	$tail= '\\n" );' . "\n";
294	print $head, " Generated by $outfile.", $tail;
295	}
296	print $head, " Package $pkg with options:", $tail;
297	$head= " *" if ! $writeperl;
298	my $key;
299	foreach $key ( sort keys %spec ) {
300	my $val= neatvalue($spec{$key});
301	$val =~ s/\\/\\\\/g if $writeperl;
302	print $head, " $key => ", $val, $tail;
303	}
304	print $head, " Perl files eval'd:", $tail;
305	foreach $key ( @perlfile ) {
306	my $code= $perlcode{$key};
307	$code =~ s#\\#\\\\#g;
308	$code =~ s#([^ -~])#"\\".sprintf "%03o",unpack "C",$1#ge;
309	$code =~ s#"#\\"#g if $writeperl;
310	print $head, " $key => ", $code, $tail;
311	}
312	if( $writeperl ) {
313	print $head, " C files included:", $tail;
314	foreach $key ( @cfile ) {
315	my $code= $ccode{$key};
316	$code =~ s#\\#\\\\#g;
317	$code =~ s#([^ -~])#"\\".sprintf "%03o",unpack "C",$1#ge;
318	$code =~ s#"#\\"#g;
319	print $head, " $key => ", $code, $tail;
320	}
321	} else {
322	print " */\n";
323	}
324	}
325	if( ! ref($ifdef) && $ifdef =~ /[^\s\w]/ ) {
326	my $sub= $ifdef;
327	$sub= 'sub { local($_)= @_; ' . $sub . ' }'
328	unless $sub =~ /^\s*sub\b/;
329	$ifdef= eval $sub;
330	die "$@: $sub\n" if $@;
331	if( "CODE" ne ref($ifdef) ) {
332	die "IFDEF didn't create subroutine reference: eval $sub\n";
333	}
334	}
335	foreach $const ( @syms ) {
336	$if= "CODE" eq ref($ifdef) ? $ifdef->($const) : $ifdef;
337	if( ! $if ) {
338	$if= "";
339	} elsif( "1" eq $if ) {
340	$if= "#ifdef $const\n";
341	} elsif( $if !~ /^#/ ) {
342	$if= "#ifdef $if\n";
343	} else {
344	$if= "$if\n";
345	}
346	print $if
347	. qq[ const2perl( $const );\n];
348	if( $if ) {
349	print "#else\n"
350	. qq[ noconst( $const );\n]
351	. "#endif\n";
352	}
353	}
354	if( $writeperl ) {
355	print
356	qq[ printf( "1;\\n" );\n],
357	qq[ return( 0 );\n];
358	}
359	print "}\n";
360	}
361
362	1;