view release on metacpan or  search on metacpan

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

    $node = $node->chain;
  }
 POST:
  while ($node = shift @C::DynaLib::Parse::post) {
    if ($node->isa('GCC::Node::record_type')) {
      declare_struct process_struct($node);
    }
  }
}

sub my_carp {
  # inspired by Exporter
  my $text = shift;
  local $Carp::CarpLevel = 0;
  if ((caller 2)[3] =~ /^\QC::DynaLib::__ANON__/) {
    $Carp::CarpLevel = 2;
    $text =~ s/(?: in pack)? at \(eval \d+\) line \d+.*\n//;
  }
  carp($text);
};

sub my_croak {
  my $text = shift;
  local $Carp::CarpLevel = 0;
  if ((caller 2)[3] =~ /^\QC::DynaLib::__ANON__/) {
    $Carp::CarpLevel = 2;
    $text =~ s/(?: in pack)? at \(eval \d+\) line \d+.*\n//;
  }
  croak($text);
};


package C::DynaLib::Callback;

use strict;
use Carp;
use vars qw($Config $GoodRet $GoodFirst $GoodArg $empty);
use subs qw(new Ptr DESTROY);

sub CONFIG_TEMPLATE () { C::DynaLib::PTR_TYPE ."pp". C::DynaLib::PTR_TYPE }
$empty = "";

if (C::DynaLib::PTR_TYPE eq 'q') {
  $GoodRet = '[iIq]?';
  $GoodFirst = '(?:[ilscILSCpqQ]?|P\d+)';
  $GoodArg = '(?:[ilscILSCfdpqQ]?|P\d+)';
} else {
  $GoodRet = '[iI]?';
  $GoodFirst = '(?:[ilscILSCp]?|P\d+)';
  $GoodArg = '(?:[ilscILSCfdp]?|P\d+)';
}

sub new {
  my $class = shift;
  my $self = [];
  my ($index, $coderef);
  my ($codeptr, $ret_type, $arg_type, @arg_type, $func);
  my $i;
  for ($index = 0; $index <= $#{$Config}; $index++) {
    ($codeptr, $ret_type, $arg_type, $func)
      = unpack(CONFIG_TEMPLATE, $Config->[$index]);
    last unless $codeptr;
  }
  if ($index > $#{$Config}) {
    carp "Limit of ", scalar(@$Config), " callbacks exceeded";
    return undef;
  }
  ($coderef, $ret_type, @arg_type) = @_;

  $ret_type =~ /^$GoodRet$/o
    or croak "Invalid callback return type: '$ret_type'";
  ! @arg_type || $arg_type[0] =~ /^$GoodFirst$/o
    or croak "Invalid callback first argument type: '$arg_type[0]'";
  for $i (@arg_type[1..$#arg_type]) {
    $i =~ /^$GoodArg$/o
      or croak "Invalid callback argument type: '$i'";
  }

  unshift @$self, $coderef;
  $codeptr = \$self->[0] + 0;
  $arg_type = join ('', @arg_type);

  unshift @$self, $codeptr, $ret_type, $arg_type, $func, $index;
  $Config->[$index] = pack (CONFIG_TEMPLATE, @$self);

  bless $self, $class;
}

sub Ptr {
  $_[0]->[3];
}

sub DESTROY {
  $Config->[$_[0]->[4]] = pack(CONFIG_TEMPLATE, 0, $empty, $empty,
			       $_[0]->[3]);
}

package C::DynaLib;
1;
__END__

=head1 NAME

C::DynaLib - Dynamic Perl interface to C compiled code.

=head1 SYNOPSIS

  use C::DynaLib;
  use sigtrap;	# recommended

  $lib = new C::DynaLib( $library [, $decl, [$dlopen_flags]] );

  $func = $lib->DeclareSub( $symbol_name
			    [, $return_type [, @arg_types] ] );
  $result = &$func(@args);
  # or
  $func = $lib->DeclareSub( { "name" => $symbol_name,
                              "decl" => 'stdcall',
			      [param => $value,] ... } );
  $func = $lib->DeclareSub( $symbol_name, $ret, $params...);
  # or