xref: /openbsd-src/gnu/usr.bin/perl/cpan/Win32API-File/inc/ExtUtils/Myconst2perl.pm (revision b8851fcc53cbe24fd20b090f26dd149e353f6174) 
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.
4package # Hide from PAUSE
5         ExtUtils::Myconst2perl;
6
7use strict;
8use Config;
9
10use vars qw( @ISA @EXPORT @EXPORT_OK $VERSION );
11BEGIN {
12    require Exporter;
13    push @ISA, 'Exporter';
14    @EXPORT= qw( &Myconst2perl );
15    @EXPORT_OK= qw( &ParseAttribs );
16    $VERSION= 1.00;
17}
18
19use Carp;
20use File::Basename;
21use ExtUtils::MakeMaker qw( neatvalue );
22
23# Return the extension to use for a file of C++ source code:
24sub _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
33Parses user-firendly options into coder-firendly specifics.
34
35=cut
36
37sub 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#/[/*]\s*CONSTS_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
175Generates a file used to implement C constants as "constant subroutines" in
176a Perl module.
177
178Extracts a list of constants from a module's export list by C<eval>ing the
179first part of the Module's F<*.pm> file and then requesting some groups of
180symbols be exported/imported into a dummy package.  Then writes C or C++
181code that can convert each C constant into a Perl "constant subroutine"
182whose name is the constant's name and whose value is the constant's value.
183
184=cut
185
186sub 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
3621;
363