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