view release on metacpan or  search on metacpan

lib/ExtUtils/H2PM.pm  view on Meta::CPAN

key of C<_tail>.

=item * ifdef => STRING

If present, guard the structure with an C<#ifdef STRING> preprocessor macro.
If the given string is not defined, no functions will be generated.

=back

=cut

sub structure
{
   my ( $name, %params ) = @_;

   ( my $basename = $name ) =~ s/^struct //;

   my $packfunc   = $params{pack_func}   || "pack_$basename";
   my $unpackfunc = $params{unpack_func} || "unpack_$basename";

   my $with_tail       = $params{with_tail};
   my $no_length_check = $params{no_length_check};

   my $arg_style = $params{arg_style} || "list";

   my @membernames;
   my @argnames;
   my @memberhandlers;

   my $argindex = 0;
   my @members = @{ $params{members} };
   foreach ( pairs @members ) {
      my $memname = $_->key;
      my $handler = $_->value;

      push @membernames, $memname;
      push @memberhandlers, $handler;

      $handler->{set_names}->( $basename, $memname );

      my $wasindex = $argindex;
      $handler->{set_arg}( $argindex );

      push @argnames, $memname if $argindex > $wasindex;
   }

   push @fragments, "#ifdef $params{ifdef}" if $params{ifdef};
   push @fragments,
      "  {",
      "    $name $basename;", 
    qq[    printf("$basename=%lu,", (unsigned long)sizeof($basename));],
      ( map { "    " . $_->{gen_c}->() } @memberhandlers ),
    qq[    printf("\\n");],
      "  }";
   push @fragments, "#endif" if $params{ifdef};

   push @genblocks, [ $basename => sub {
      my ( $result ) = @_;
      return () unless defined $result;

      my @result = split m/,/, $result;

      my $curpos = 0;

      my $format = "";

      my $sizeof = shift @result;

      my ( @postargs, @preret );

      foreach my $def ( @result ) {
         my $handler = shift @memberhandlers;

         $format .= $handler->{gen_format}( $def, $curpos, \@postargs, \@preret ) . " ";
      }

      if( $curpos < $sizeof ) {
         $format .= "x" . ( $sizeof - $curpos );
      }

      my $eq = "==";
      if( $with_tail ) {
         $format .= "a*";
         $eq = ">=";
      }

      unshift( @perlcode, "use Carp;" ), $done_carp++ unless $done_carp;

      my ( @argcode, @retcode );
      if( $arg_style eq "list" ) {
         my $members = join( ", ", @argnames, ( $with_tail ? "[tail]" : () ) );

         @argcode = (
            qq{   \@_ $eq $argindex or croak "usage: $packfunc($members)";},
            qq{   my \@v = \@_;} );
         @retcode = (
            qq{   \@v;} );
      }
      elsif( $arg_style eq "hashref" ) {
         my $qmembers = join( ", ", map { "'$_'" } @membernames, ( $with_tail ? "_tail" : () ) );

         @argcode = (
            qq{   ref(\$_[0]) eq "HASH" or croak "usage: $packfunc(\\%args)";},
            qq(   my \@v = \@{\$_[0]}{$qmembers};) );
         @retcode = (
            # Seems we can't easily do this without a temporary
            qq(   my %ret; \@ret{$qmembers} = \@v;),
            qq{   \\%ret;} );
      }
      else {
         carp "Unrecognised arg_style $arg_style";
      }

      push_export $packfunc;
      push_export $unpackfunc;

      join( "\n",
         "",
         "sub $packfunc",
         "{",
         @argcode,

lib/ExtUtils/H2PM.pm  view on Meta::CPAN

if( my $mb = eval { require Module::Build and Module::Build->current } ) {
   $compile_args{include_dirs}         = $mb->include_dirs;
   $compile_args{extra_compiler_flags} = $mb->extra_compiler_flags;

   $link_args{extra_linker_flags} = $mb->extra_linker_flags;
}

sub gen_perl
{
   return "" unless @fragments;

   my $c_file = join "\n",
      "#include <stdio.h>",
      @preamble,
      "",
      "int main(void) {",
      @fragments,
      "  return 0;",
      "}\n";

   undef @preamble;
   undef @fragments;

   die "Cannot generate a C file yet - no module name\n" unless defined $modulename;

   my $tempname = "gen-$modulename";

   my $sourcename = "$tempname.c";
   {
      open( my $source_fh, "> $sourcename" ) or die "Cannot write $sourcename - $!";
      print $source_fh $c_file;
   }

   my $objname = eval { $cbuilder->compile( source => $sourcename, %compile_args ) };

   unlink $sourcename;

   if( !defined $objname ) {
      die "Failed to compile source\n";
   }

   my $exename = eval { $cbuilder->link_executable( objects => $objname, %link_args ) };

   unlink $objname;

   if( !defined $exename ) {
      die "Failed to link executable\n";
   }

   my $output;
   {
      open( my $runh, "./$exename |" ) or die "Cannot pipeopen $exename - $!";

      local $/;
      $output = <$runh>;
   }

   unlink $exename;

   my %results = map { m/^(\w+)=(.*)$/ } split m/\n/, $output;

   my $perl = "";

   my @bodylines;

   # Evaluate these first, so they have a chance to push_export()
   foreach my $genblock ( @genblocks ) {
      my ( $key, $code ) = @$genblock;

      push @bodylines, $code->( $results{$key} );
   }

   if( @exports ) {
      $perl .= "push \@EXPORT, " . join( ", ", map { "'$_'" } @exports ) . ";\n";
      undef @exports;
   }

   if( @exports_ok ) {
      $perl .= "push \@EXPORT_OK, " . join( ", ", map { "'$_'" } @exports_ok ) . ";\n";
      undef @exports_ok;
   }

   $perl .= join "", map { "$_\n" } @bodylines;

   undef @genblocks;

   my @thisperlcode = @perlcode;
   undef @perlcode;

   return join "\n", @thisperlcode, $perl;
}

=head2 gen_output

   $perl = gen_output;

Returns the generated perl code. This is used internally for testing purposes
but normally would not be necessary; see instead C<write_output>.

=cut

sub gen_output
{
   my $ret = $output . gen_perl . "\n1;\n";
   $output = "";

   return $ret;
}

=head2 write_output

   write_output $filename;

Write the generated perl code into the named file. This would normally be used
as the last function in the containing script, to generate the output file. In
the case of C<ExtUtils::MakeMaker> or C<Module::Build> invoking the script,
the path to the file to be generated should be given in C<$ARGV[0]>. Normally,
therefore, the script would end with

 write_output $ARGV[0];