view release on metacpan or  search on metacpan

lib/XS/TCC.pm  view on Meta::CPAN

  if (defined $code and defined $args{code}) {
    Carp::croak("Can't specify code both as a named and as a positional parameter");
  }
  $code //= $args{code};
  Carp::croak("Need code to compile") if not defined $code;

  my $package = $args{package} // (caller())[0];

  # Set up the typemap object if any (defaulting to core typemaps)
  my $typemap;
  my $typemap_arg = $args{typemap};
  if (not defined($typemap_arg)) {
    $typemap = _get_core_typemap();
  }
  elsif (ref($typemap_arg)) {
    $typemap = _get_core_typemap()->clone(shallow => 1);
    $typemap->merge(typemap => $typemap_arg);
  }
  else {
    $typemap = _get_core_typemap()->clone(shallow => 1);
    $typemap->add_string(string => $typemap_arg);
  }

  # Function signature parsing
  my $parse_result = XS::TCC::Parser::extract_function_metadata($code);
  return
    if not $parse_result
    or not @{$parse_result->{function_names}};

  # eval the typemaps for the function sig
  my @code = ($CodeHeader, $code);
  foreach my $cfun_name (@{$parse_result->{function_names}}) {
    my $fun_info = $parse_result->{functions}{$cfun_name};
    my $xs_fun = _gen_single_function_xs_wrapper($package, $cfun_name, $fun_info, $typemap, \@code);
    $fun_info->{xs_function_name} = $xs_fun;
  }

  my $final_code = join "\n", @code;

  warn _add_line_nums($final_code) if $args{warn_code};

  my $compiler = _get_compiler();

  # Code to catch compile errors
  my $errmsg;
  my $err_hook = sub { $errmsg = $_[0] };

  $compiler->set_error_callback($err_hook);

  # Add user-specified files
  my @add_files;
  @add_files = ref($args{add_files}) ? @{$args{add_files}} : $args{add_files}
    if defined $args{add_files};
  $compiler->add_file($_) for @add_files;

  # Do the compilation
  $compiler->set_options(($args{ccopts} // $CCOPTS));
  # compile_string() returns 0 if succeeded, -1 otherwise.
  my $fatal = $compiler->compile_string($final_code);
  $compiler->relocate();

  if (defined $errmsg) {
    $errmsg = _build_compile_error_msg($errmsg, 1);
    if ($fatal) {
      Carp::croak($errmsg);
    } else {
      Carp::carp($errmsg);
    }
  }

  # install the XSUBs
  foreach my $cfun_name (@{$parse_result->{function_names}}) {
    my $fun_info = $parse_result->{functions}{$cfun_name};
    my $sym = $compiler->get_symbol($fun_info->{xs_function_name});
    my $perl_name = $package . "::" . $cfun_name;
    my $sub = $sym->as_xsub();
    no strict 'refs';
    *{"$perl_name"} = $sub;
  }

}


sub _build_compile_error_msg {
  my ($msg, $caller_level) = @_;
  $caller_level++;
  # TODO write code to emit file/line info
  return $msg;
}

sub _gen_single_function_xs_wrapper {
  my ($package, $cfun_name, $fun_info, $typemap, $code_ary) = @_;

  my $arg_names = $fun_info->{arg_names};
  my $nparams = scalar(@$arg_names);
  my $arg_names_str = join ", ", map {s/\W/_/; $_} @$arg_names;

  # Return type and output typemap preparation
  my $ret_type = $fun_info->{return_type};
  my $is_void_function = $ret_type eq 'void';
  my $retval_decl = $is_void_function ? '' : "$ret_type RETVAL;";

  my $out_typemap;
  my $outputmap;
  my $dxstarg = "";
  if (not $is_void_function) {
    $out_typemap = $typemap->get_typemap(ctype => $ret_type);
    $outputmap = $out_typemap
                 ? $typemap->get_outputmap(xstype => $out_typemap->xstype)
                 : undef;
    Carp::croak("No output typemap found for return type '$ret_type'")
      if not $outputmap;
    # TODO implement TARG optimization below
    #$dxstarg = $outputmap->targetable ? " dXSTARG;" : "";
  }

  # Emit function header and declarations
  (my $xs_pkg_name = $package) =~ s/:+/_/g;
  my $xs_fun_name = "XS_${xs_pkg_name}_$cfun_name";
  push @$code_ary, <<FUN_HEADER;