ext/Win32API-File/ExtUtils/Myconst2perl.pm

   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;
   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#/[/*]\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
 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;