view release on metacpan or  search on metacpan

t/01test.t  view on Meta::CPAN

  ($buffer, $fmt, @args);
  $buffer =~ s/\0.*//;
  return $buffer;
}

my $fmt = "%x %10sfoo %d %10.7g %f %d %d %d";
my @args = (253, "bar", -789, 2.32578, 3.14, 5, 6, 7);

my $expected = sprintf($fmt, @args);
my $got = my_sprintf($fmt, @args);

ok($got eq $expected, "expected: $expected"); #4

my $ptr_len = length(pack("p", $tmp = "foo"));

# Try passing a pointer to DeclareSub.
my $fopen_ptr = DynaLoader::dl_find_symbol($libc->LibRef(), "fopen")
  or die DynaLoader::dl_error();
my $fopen = DeclareSub ({ "ptr" => $fopen_ptr,
                          "return" => PTR_TYPE,
                          "args" => ["p", "p"] });

open TEST, ">tmp.tmp"
  or die "Can't write file tmp.tmp: $!\n";
print TEST "a string";
close TEST;

# Can't do &$fopen("tmp.tmp", "r") in perls before 5.00402.
my $fp = &$fopen($tmp1 = "tmp.tmp", $tmp2 = "r");
if (! $fp) {
  ok(0, q(Can't do &$fopen("tmp.tmp", "r") in perls before 5.00402.)); #5
} else {
  # Hope "I" will work for type size_t!
  my $fread = $libc->DeclareSub("fread", "i",
                                "P", "I", "I", PTR_TYPE);
  my $buffer = "\0" x 4;
  my $result = &$fread($buffer, 1, length($buffer), $fp);
  ok($result == 4); #5
  ok($buffer eq "a st"); #6
}
unlink "tmp.tmp";

if (@$C::DynaLib::Callback::Config) {
  sub compare_lengths {
    length(unpack("p", $_[0])) <=> length(unpack("p", $_[1]));
  }
  my @list = qw(A bunch of elements with unique lengths);
  my $array = pack("p*", @list);

  my $callback = new C::DynaLib::Callback("compare_lengths", "i",
                                          "P$ptr_len", "P$ptr_len");

  my $qsort = $libc->DeclareSub("qsort", "",
			     "P", "I", "I", PTR_TYPE);
  &$qsort($array, scalar(@list), length($array) / @list, $callback->Ptr());

  my @expected = sort { length($a) <=> length($b) } @list;
  my @got = unpack("p*", $array);
  ok("[@got]" eq "[@expected]"); #7

  # Hey!  We've got callbacks.  We've got a way to call them.
  # Who needs libraries?
  undef $callback;
  $callback = new C::DynaLib::Callback
    (sub {
       $_[0] + 10*$_[1] + 100*$_[2];
     }, "i", "i", "p", "i");
  my $sub = DeclareSub($callback->Ptr(), "i", "i", "p", "i");

  my $got = &$sub(1, $tmp = 7, 3.14);
  my $expected = 371;
  ok($got == $expected); #8

  undef $callback;
  $callback = new C::DynaLib::Callback(sub { shift }, "I", "i");
  $sub = DeclareSub($callback->Ptr(), "I", "i");
  $got = &$sub(-1);

  # Can't do this generally because it's broken in too many Perl versions:
  if (0) { # TODO: needed for an earlier version
    $expected = unpack("I", pack("i", -1));
  } else {
    $expected = 0;
    for ($i = 1; $i > 0; $i <<= 1) {
      $expected += $i;
    }
    $expected -= $i;
  }
  ok($got == $expected, "Callback Ii $got == $expected"); #9

  my $int_size = length(pack("i",0));
  undef $callback;
  $callback = new C::DynaLib::Callback
    (sub {
       $global = shift;
       $global .= pack("i", shift);
       return unpack(PTR_TYPE, pack("P", $global));
     }, PTR_TYPE, "P".(2 * $int_size), "i");

  $sub = DeclareSub($callback->Ptr(), "P".(3 * $int_size), PTR_TYPE, "i");
  $array = pack("ii", 1729, 31415);
  $pointer = unpack(PTR_TYPE, pack("P", $array));
  $struct = &$sub($pointer, 253);
  @got = unpack("iii", $struct);
  ok("[@got]" eq "[1729 31415 253]"); #10

} else {
  print ("# Skipping callback tests on this platform\n");
}

my $buf = "willo";
C::DynaLib::Poke(unpack(PTR_TYPE, pack("p", $buf)), "he");
ok($buf eq "hello"); #11