File Coverage

blib/lib/FFI/Platypus/Legacy/Raw/MemPtr.pm

Criterion	Covered	Total	%
statement	40	43	93.0
branch	7	10	70.0
condition			n/a
subroutine	11	12	91.6
pod	4	5	80.0
total	62	70	88.5

package FFI::Platypus::Legacy::Raw::MemPtr;

use strict;
use warnings;
use Carp qw( croak );
use FFI::Platypus::Legacy::Raw::Platypus;
use FFI::Platypus::Memory qw( malloc free memcpy );
use FFI::Platypus::Buffer qw( scalar_to_buffer buffer_to_scalar );

# ABSTRACT: FFI::Platypus::Legacy::Raw memory pointer type
our $VERSION = '0.06'; # VERSION

our @ISA = qw( FFI::Platypus::Legacy::Raw::Ptr );


sub new
{
  my($class, $size) = @_;
  my $ptr = malloc $size;
  die "malloc failed" unless defined $ptr;
  bless \$ptr, $class;
}

sub DESTROY
{
  my($self) = @_;
  free $$self;
}


sub new_from_buf
{
  my($class, undef, $size) = @_;
  my $dst = malloc $size;
  my($src, undef) = scalar_to_buffer $_[1];
  memcpy $dst, $src, $size;
  bless \$dst, $class;
}


_ffi_package
  ->attach(
    ['ffi__platypus__legacy__raw__memptr__new_from_ptr' =>
     '_new_from_ptr']
    => ['opaque'] => 'opaque'
  )
;

sub new_from_ptr
{
  my($class, $src) = @_;
  if(ref $src)
  {
    if(eval { $src->isa('FFI::Platypus::Legacy::Raw::Ptr') })
    {
      $src = $$src;
    }
  }
  my $dst = _new_from_ptr($src);
  bless \$dst, $class;
}


_ffi_package->attach_cast('_opaque_to_string', 'opaque' => 'string');

## NOTE: prototype for a method is kind of dumb but we are including it for
## full compatability with FFI::Raw
sub to_perl_str ($;$)
{
  my($self, $size) = @_;
  if(@_ == 1)
  {
    return _opaque_to_string($$self);
  }
  elsif(@_ == 2)
  {
    return buffer_to_scalar($$self, $size);
  }
  else
  {
    croak "Wrong number of arguments";
  }
}


sub tostr {
  my $self = shift;
  return $self->to_perl_str(@_)
}

1;

__END__