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.
4 package # Hide from PAUSE
5 ExtUtils::Myconst2perl;
10 use vars qw( @ISA @EXPORT @EXPORT_OK $VERSION );
13 push @ISA, 'Exporter';
14 @EXPORT= qw( &Myconst2perl );
15 @EXPORT_OK= qw( &ParseAttribs );
21 use ExtUtils::MakeMaker qw( neatvalue );
23 # Return the extension to use for a file of C++ source code:
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.
33 Parses user-firendly options into coder-firendly specifics.
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;
60 PERL_PE_CODE => \$perlcode,
61 PERL_FILE_LIST => \@perlfiles,
62 PERL_FILE_CODES => \%perlfilecodes,
63 PERL_FILES => sub { map {($_,$perlfilecodes{$_})} @perlfiles },
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,
73 WRITE_PERL => \$writeperl,
74 CPLUSPLUS => \$cplusplus,
75 BASEFILENAME => \$base,
79 FINAL_PERL => \$final,
80 NO_REBUILD => \$norebuild,
82 { my @err= grep {! defined $params{$_}} keys %$hvAttr;
83 carp "ExtUtils::Myconst2perl::ParseAttribs: ",
84 "Unsupported option(s) (@err).\n"
87 $norebuild= $hvAttr->{NO_REBUILD} if exists $hvAttr->{NO_REBUILD};
88 my $module= ( split /::/, $pkg )[-1];
90 $base= $hvAttr->{BASEFILENAME} if exists $hvAttr->{BASEFILENAME};
91 my $ext= ! $cplusplus ? ($Config{_c}||".c")
92 : $cplusplus =~ /^[.]/ ? $cplusplus : _cc();
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};
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;
109 $outfile= $base . ".h";
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}};
118 @perlfiles= grep {$odd= !$odd} @{$hvAttr->{PERL_FILES}};
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}};
125 @perlfiles= ( "$module.pm" );
127 %perlfilecodes= %{$hvAttr->{PERL_FILE_CODES}}
128 if $hvAttr->{PERL_FILE_CODES};
130 for my $file ( @perlfiles ) {
131 $perlfilecodes{$file}= $perlcode if ! $perlfilecodes{$file};
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}};
141 @cfiles= grep {$odd= !$odd} @{$hvAttr->{C_FILES}};
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" );
150 %cfilecodes= %{$hvAttr->{C_FILE_CODES}} if $hvAttr->{C_FILE_CODES};
152 for my $file ( @cfiles ) {
153 $cfilecodes{$file}= $ccode if ! $cfilecodes{$file};
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}};
168 die "Impossible value in \$params{$key}";
175 Generates a file used to implement C constants as "constant subroutines" in
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.
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,
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,
204 my $module= ( split /::/, $pkg )[-1];
206 warn "Writing $outfile...\n";
207 open( STDOUT, ">$outfile" ) or die "Can't create $outfile: $!\n";
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";
220 ] or die "$file eval: $@\n";
225 "/* $outfile - Generated by ExtUtils::Myconst2perl::Myconst2perl */\n";
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";
231 # Here are more reasons why the WRITE_PERL option is discouraged.
232 if( $Config{useperlio} ) {
233 print "#define PERLIO_IS_STDIO 1\n";
235 print "#define WIN32IO_IS_STDIO 1\n"; # May cause a warning
236 print "#define NO_XSLOCKS 1\n"; # What a hack!
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];
253 ] or die "$file eval: $@\n";
256 #print qq[\n#undef main\n];
257 print qq[\n#define CONST2WRITE_PERL\n];
258 print qq[\n#include "const2perl.h"\n\n];
260 print "int\nmain( int argc, char *argv[], char *envp[] )\n";
262 print "void\n$routine( void )\n";
268 @ExtUtils::Myconst2perl::importlist= @importlist;
269 my $var= '@ExtUtils::Myconst2perl::importlist';
270 my $port= $export ? "export" : "import";
271 my $arg2= $export ? "q[$importto]," : "";
274 . " { package $importto;\n"
275 . " warn qq[\u${port}ing to $importto: $var\\n];\n"
276 . " \$pkg->$port( $arg2 $var );\n"
278 . " { no strict 'refs';\n"
279 . " $var= sort keys %{'_constants::'}; }\n"
280 . " warn 0 + $var, qq[ symbols ${port}ed.\\n];\n"
284 my @syms= @ExtUtils::Myconst2perl::importlist;
288 print qq[ START_CONSTS( "$pkg" ) /* No ";" */\n];
290 my( $head, $tail )= ( "/*", "\n" );
292 $head= ' printf( "#';
293 $tail= '\\n" );' . "\n";
294 print $head, " Generated by $outfile.", $tail;
296 print $head, " Package $pkg with options:", $tail;
297 $head= " *" if ! $writeperl;
299 foreach $key ( sort keys %spec ) {
300 my $val= neatvalue($spec{$key});
301 $val =~ s/\\/\\\\/g if $writeperl;
302 print $head, " $key => ", $val, $tail;
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;
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;
319 print $head, " $key => ", $code, $tail;
325 if( ! ref($ifdef) && $ifdef =~ /[^\s\w]/ ) {
327 $sub= 'sub { local($_)= @_; ' . $sub . ' }'
328 unless $sub =~ /^\s*sub\b/;
330 die "$@: $sub\n" if $@;
331 if( "CODE" ne ref($ifdef) ) {
332 die "IFDEF didn't create subroutine reference: eval $sub\n";
335 foreach $const ( @syms ) {
336 $if= "CODE" eq ref($ifdef) ? $ifdef->($const) : $ifdef;
339 } elsif( "1" eq $if ) {
340 $if= "#ifdef $const\n";
341 } elsif( $if !~ /^#/ ) {
347 . qq[ const2perl( $const );\n];
350 . qq[ noconst( $const );\n]
356 qq[ printf( "1;\\n" );\n],