File Coverage

blib/lib/FFI/C/Struct.pm
Criterion Covered Total %
statement 84 90 93.3
branch 41 46 89.1
condition 8 12 66.6
subroutine 14 17 82.3
pod 0 1 0.0
total 147 166 88.5


line stmt bran cond sub pod time code
1             package FFI::C::Struct;
2              
3 9     9   120 use strict;
  9         17  
  9         254  
4 9     9   44 use warnings;
  9         20  
  9         205  
5 9     9   887 use FFI::C::Util;
  9         16  
  9         310  
6 9     9   2852 use FFI::C::FFI ();
  9         23  
  9         254  
7 9     9   56 use Ref::Util qw( is_ref is_plain_arrayref );
  9         17  
  9         4066  
8              
9             # ABSTRACT: Structured data instance for FFI
10             our $VERSION = '0.14'; # VERSION
11              
12              
13             sub AUTOLOAD
14             {
15 223     223   4830 our $AUTOLOAD;
16 223         328 my $self = shift;
17 223         357 my $name = $AUTOLOAD;
18 223         1073 $name=~ s/^.*:://;
19 223 100       635 if(my $member = $self->{def}->{members}->{$name})
20             {
21 217         396 my $ptr = $self->{ptr} + $member->{offset};
22              
23 217 100       457 if($member->{nest})
24             {
25 9   33     65 my $m = $member->{nest}->create($ptr,$self->{owner} || $self);
26 9 100       55 FFI::C::Util::perl_to_c($m, $_[0]) if @_;
27 9         27 return $m;
28             }
29              
30 208         535 my $ffi = $self->{def}->ffi;
31              
32 208 100       447 if(defined $member->{count})
33             {
34 56 100       107 if(defined $_[0])
35             {
36 42 100       91 if(! is_ref $_[0])
    50          
37             {
38 40         51 my $index = shift;
39 40 100       224 Carp::croak("$name Negative index on array member") if $index < 0;
40 38 100       198 Carp::croak("$name OOB index on array member") if $index >= $member->{count};
41 36         66 $ptr += $index * $member->{unitsize};
42             }
43             elsif(is_plain_arrayref $_[0])
44             {
45 2         6 my $array = shift;
46 2 50       55 Carp::croak("$name OOB index on array member") if @$array > $member->{count};
47 2         5 my $asize = @$array * $member->{unitsize};
48 2         8 $ffi->function( FFI::C::FFI::memcpy_addr() => [ 'opaque', $member->{spec} . "[@{[ scalar @$array ]}]", 'size_t' ] => 'opaque' )
  2         17  
49             ->call($ptr, $array, $asize);
50 2         288 my @a;
51 2         14 tie @a, 'FFI::C::Struct::MemberArrayTie', $self, $name, $member->{count};
52 2         14 return \@a;
53             }
54             else
55             {
56 0         0 Carp::croak("$name tried to set element to non-scalar");
57             }
58             }
59             else
60             {
61 14         19 my @a;
62 14         57 tie @a, 'FFI::C::Struct::MemberArrayTie', $self, $name, $member->{count};
63 14         76 return \@a;
64             }
65             }
66              
67 188 100       415 if(@_)
68             {
69 60 50       154 Carp::croak("$name tried to set member to non-scalar") if is_ref $_[0];
70              
71 60         109 my $src = \$_[0];
72              
73             # For fixed strings, pad short strings with NULLs
74 9 100 66 9   74 $src = \($_[0] . ("\0" x ($member->{size} - do { use bytes; length $_[0] }))) if $member->{rec} && $member->{size} > do { use bytes; length $_[0] };
  9     9   16  
  9         95  
  9         431  
  9         35  
  9         36  
  60         204  
  2         9  
  2         9  
75              
76 60 100       140 if(my $enum = $member->{enum})
77             {
78 4 100       11 if(exists $enum->str_lookup->{$$src})
    50          
79             {
80 2         4 $src = \($enum->str_lookup->{$$src});
81             }
82             elsif(exists $enum->int_lookup->{$$src})
83             {
84             # nothing
85             }
86             else
87             {
88 0         0 Carp::croak("$name tried to set member to invalid enum value");
89             }
90             }
91              
92             $ffi->function( FFI::C::FFI::memcpy_addr() => [ 'opaque', $member->{spec} . "*", 'size_t' ] => 'opaque' )
93 60   66     276 ->call($ptr, $src, $member->{unitsize} || $member->{size});
94             }
95              
96 188         9810 my $value = $ffi->cast( 'opaque' => $member->{spec} . "*", $ptr );
97 188 100       18061 $value = $$value unless $member->{rec};
98 188 100       422 $value =~ s/\0.*$// if $member->{trim_string};
99              
100 188 100       384 if(my $enum = $member->{enum})
101             {
102 10 100       23 if($enum->rev eq 'str')
103             {
104 5 50       10 if(exists $enum->int_lookup->{$value})
105             {
106 5         9 $value = $enum->int_lookup->{$value};
107             }
108             }
109             }
110              
111 188         674 return $value;
112             }
113             else
114             {
115 6         609 Carp::croak("No such member: $name");
116             }
117             }
118              
119             sub can
120             {
121 147     147 0 42407 my($self, $name) = @_;
122             $self->{def}->{members}->{$name}
123 0     0   0 ? sub { shift->$name(@_) }
124 147 100       936 : $self->SUPER::can($name);
125             }
126              
127             sub DESTROY
128             {
129 106     106   12245 my($self) = @_;
130 106 100 100     567 if($self->{ptr} && !$self->{owner})
131             {
132 19         164 FFI::C::FFI::free(delete $self->{ptr});
133             }
134             }
135              
136             package FFI::C::Struct::MemberArrayTie;
137              
138             sub TIEARRAY
139             {
140 31     31   95 my($class, $struct, $name, $count) = @_;
141 31         122 bless [ $struct, $name, $count ], $class;
142             }
143              
144             sub FETCH
145             {
146 48     48   150 my($self, $index) = @_;
147 48         85 my($struct, $name) = @$self;
148 48         159 $struct->$name($index);
149             }
150              
151             sub STORE
152             {
153 6     6   19 my($self, $index, $value) = @_;
154 6         14 my($struct, $name) = @$self;
155 6         21 $struct->$name($index, $value);
156             }
157              
158             sub FETCHSIZE
159             {
160 12     12   2210 my($self) = @_;
161 12         73 $self->[2];
162             }
163              
164             sub STORESIZE
165             {
166 0     0     my($self) = @_;
167 0           $self->[2];
168             }
169              
170             sub CLEAR
171             {
172 0     0     Carp::croak("Cannot clear");
173             }
174              
175             1;
176              
177             __END__