view release on metacpan or  search on metacpan

lib/C/DynaLib.pm  view on Meta::CPAN

  # We eval $obj->isa and $obj->can for 5.003 compatibility.
  local ($@);
  my $self = shift;

  # Calling as a method is equivalent to supplying the "libref" named arg.
  my $is_method;
  $is_method = ref($self) && eval { $self->isa("C::DynaLib") };
  $@ and $is_method = (ref($self) eq 'C::DynaLib');
  my $first = ($is_method ? shift : $self);

  my ($libref, $name, $ptr, @arg_type);
  my ($convention, $ret_type) = ($is_method ? $self->LibDecl : $DefConv, '');

  if (ref($first) eq 'HASH') {

    # Using named parameters.
    ! @_ && (($ptr = $first->{'ptr'}) || defined ($name = $first->{'name'}))
      or croak 'Usage: $lib->DeclareSub('.
        '{ "name" => $func_name [, "return" => $ret_type] [,'.
        '  "args" => \@arg_types] [, "decl" => $decl] })';

    $libref = $first->{'libref'};
    $convention = $first->{'decl'} || $convention;
    $ret_type = $first->{'return'} || $ret_type;
    @arg_type = @{ $first->{'args'} || [] };

  } else {

    # Using positional parameters.
    ($is_method ? $name : $ptr) = $first
      or croak 'Usage: $lib->DeclareSub( $func_name [, $return_type [, \@arg_types]] )';
    $ret_type = shift || $ret_type;
    @arg_type = @_;
  }

  unless ($ptr) {
    # No pointer, so we're looking up the function in a library...
    $libref ||= $is_method && $self->LibRef()
      or croak 'C::DynaLib::DeclareSub: non-method form requires a "ptr" or "libref"';
    $ptr = eval { DynaLoader::dl_find_symbol($libref, $name) };
    if ($@ || ! $ptr) {
      return undef;
    }
  }

  $ret_type =~ /^$GoodRet$/o
    or croak "Invalid return type: '$ret_type'";

  my $glue_sub_name = $convention . '_call_packed';
  my $glue_sub = ($is_method && eval { $self->can($glue_sub_name) })
    || (defined(&{"$glue_sub_name"}) && \&{"$glue_sub_name"});

  if (! $glue_sub) {
    carp "Unsupported calling convention: decl => '$convention'"
      if $^W;
    return undef;
  }

  my @pre_args = ($ptr, $ret_type, $libref);
  my $pkg = caller();

  # This 'inner' closure must be an eval-string in order to compile the
  # function call in our caller's package.
  my $proc = eval q/ sub {
    package /.$pkg.q/;
    &$glue_sub(@pre_args, map { pack($_, shift) } @arg_type);
  }/;

  return sub {
    if ($^W) {
      if ($#_ < $#arg_type) {
	carp 'Missing arguments supplied as undef';
      } elsif ($#_ > $#arg_type) {
	carp 'Extra arguments ignored';
      }
    }
    local $SIG{'__WARN__'} = \&my_carp;
    local $SIG{'__DIE__'} = \&my_croak;
    &$proc;
  };
}

sub Parse {
  my $self = shift;
  my $is_method = ref($self) && eval { $self->isa("C::DynaLib") };
  $@ and $is_method = (ref($self) eq 'C::DynaLib');
  my $first = ($is_method ? shift : $self);
  my ($code,$cc,$inc,$filter);
  if (ref($first) eq 'HASH') {
    $code = $first->{code} or die "code missing\n";
    $cc = $first->{cc} || "gcc";
    $inc = $first->{inc};
    $filter = $first->{filter};
    $cc = "$cc -I$inc" if $inc;
  } else {
    $code = $first;
    $cc = shift;
    $filter = shift;
  }
  require C::DynaLib::Parse;
  C::DynaLib::Parse->import (qw(declare_func declare_struct
			       pack_types process_struct process_func));
  my $node = C::DynaLib::Parse::GCC_prepare($code, $cc);
  while ($node) {
    if ($node->isa('GCC::Node::function_decl')
	and ($filter ? $node->name->identifier =~ /$filter/
	     : $node->name->identifier !~ /^_/))
    {
      declare_func process_func($node);
    }
    if ($node->isa('GCC::Node::record_type')
	and ($filter ? $node->name->identifier =~ /$filter/
	     : $node->name->identifier !~ /^_/))
    {
      declare_struct process_struct($node);
    }
  } continue {
    $node = $node->chain;
  }
 POST: