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


line stmt bran cond sub pod time code
1             package FFI::Platypus::Legacy::Raw::MemPtr;
2              
3 7     7   51 use strict;
  7         16  
  7         259  
4 7     7   39 use warnings;
  7         13  
  7         224  
5 7     7   43 use Carp qw( croak );
  7         15  
  7         338  
6 7     7   42 use FFI::Platypus::Legacy::Raw::Platypus;
  7         14  
  7         358  
7 7     7   48 use FFI::Platypus::Memory qw( malloc free memcpy );
  7         14  
  7         348  
8 7     7   4079 use FFI::Platypus::Buffer qw( scalar_to_buffer buffer_to_scalar );
  7         4523  
  7         3639  
9              
10             # ABSTRACT: FFI::Platypus::Legacy::Raw memory pointer type
11             our $VERSION = '0.04'; # VERSION
12              
13             our @ISA = qw( FFI::Platypus::Legacy::Raw::Ptr );
14              
15              
16             sub new
17             {
18 3     3 1 3518 my($class, $size) = @_;
19 3         17 my $ptr = malloc $size;
20 3 50       12 die "malloc failed" unless defined $ptr;
21 3         13 bless \$ptr, $class;
22             }
23              
24             sub DESTROY
25             {
26 9     9   2383 my($self) = @_;
27 9         56 free $$self;
28             }
29              
30              
31             sub new_from_buf
32             {
33 4     4 1 10011 my($class, undef, $size) = @_;
34 4         85 my $dst = malloc $size;
35 4         59 my($src, undef) = scalar_to_buffer $_[1];
36 4         67 memcpy $dst, $src, $size;
37 4         18 bless \$dst, $class;
38             }
39              
40              
41             _ffi_package
42             ->attach(
43             ['ffi__platypus__legacy__raw__memptr__new_from_ptr' =>
44             '_new_from_ptr']
45             => ['opaque'] => 'opaque'
46             )
47             ;
48              
49             sub new_from_ptr
50             {
51 2     2 1 17 my($class, $src) = @_;
52 2 100       9 if(ref $src)
53             {
54 1 50       3 if(eval { $src->isa('FFI::Platypus::Legacy::Raw::Ptr') })
  1         8  
55             {
56 1         32 $src = $$src;
57             }
58             }
59 2         15 my $dst = _new_from_ptr($src);
60 2         8 bless \$dst, $class;
61             }
62              
63              
64             _ffi_package->attach_cast('_opaque_to_string', 'opaque' => 'string');
65              
66             ## NOTE: prototype for a method is kind of dumb but we are including it for
67             ## full compatability with FFI::Raw
68             sub to_perl_str ($;$)
69             {
70 4     4 1 1350 my($self, $size) = @_;
71 4 100       19 if(@_ == 1)
    50          
72             {
73 1         17 return _opaque_to_string($$self);
74             }
75             elsif(@_ == 2)
76             {
77 3         13 return buffer_to_scalar($$self, $size);
78             }
79             else
80             {
81 0           croak "Wrong number of arguments";
82             }
83             }
84              
85              
86             sub tostr {
87 0     0 0   my $self = shift;
88 0           return $self->to_perl_str(@_)
89             }
90              
91             1;
92              
93             __END__