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   65 use strict;
  9         18  
  9         258  
4 9     9   52 use warnings;
  9         18  
  9         201  
5 9     9   839 use FFI::C::Util;
  9         18  
  9         334  
6 9     9   2862 use FFI::C::FFI ();
  9         23  
  9         252  
7 9     9   55 use Ref::Util qw( is_ref is_plain_arrayref );
  9         19  
  9         4171  
8              
9             # ABSTRACT: Structured data instance for FFI
10             our $VERSION = '0.15'; # VERSION
11              
12              
13             sub AUTOLOAD
14             {
15 223     223   4506 our $AUTOLOAD;
16 223         334 my $self = shift;
17 223         338 my $name = $AUTOLOAD;
18 223         1046 $name=~ s/^.*:://;
19 223 100       658 if(my $member = $self->{def}->{members}->{$name})
20             {
21 217         401 my $ptr = $self->{ptr} + $member->{offset};
22              
23 217 100       445 if($member->{nest})
24             {
25 9   33     58 my $m = $member->{nest}->create($ptr,$self->{owner} || $self);
26 9 100       33 FFI::C::Util::perl_to_c($m, $_[0]) if @_;
27 9         25 return $m;
28             }
29              
30 208         545 my $ffi = $self->{def}->ffi;
31              
32 208 100       447 if(defined $member->{count})
33             {
34 56 100       111 if(defined $_[0])
35             {
36 42 100       92 if(! is_ref $_[0])
    50          
37             {
38 40         58 my $index = shift;
39 40 100       225 Carp::croak("$name Negative index on array member") if $index < 0;
40 38 100       194 Carp::croak("$name OOB index on array member") if $index >= $member->{count};
41 36         68 $ptr += $index * $member->{unitsize};
42             }
43             elsif(is_plain_arrayref $_[0])
44             {
45 2         6 my $array = shift;
46 2 50       45 Carp::croak("$name OOB index on array member") if @$array > $member->{count};
47 2         5 my $asize = @$array * $member->{unitsize};
48 2         9 $ffi->function( FFI::C::FFI::memcpy_addr() => [ 'opaque', $member->{spec} . "[@{[ scalar @$array ]}]", 'size_t' ] => 'opaque' )
  2         19  
49             ->call($ptr, $array, $asize);
50 2         284 my @a;
51 2         10 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         23 my @a;
62 14         48 tie @a, 'FFI::C::Struct::MemberArrayTie', $self, $name, $member->{count};
63 14         74 return \@a;
64             }
65             }
66              
67 188 100       381 if(@_)
68             {
69 60 50       143 Carp::croak("$name tried to set member to non-scalar") if is_ref $_[0];
70              
71 60         99 my $src = \$_[0];
72              
73             # For fixed strings, pad short strings with NULLs
74 9 100 66 9   80 $src = \($_[0] . ("\0" x ($member->{size} - do { use bytes; length $_[0] }))) if $member->{rec} && $member->{size} > do { use bytes; length $_[0] };
  9     9   17  
  9         74  
  9         425  
  9         38  
  9         44  
  60         147  
  2         10  
  2         9  
75              
76 60 100       175 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     265 ->call($ptr, $src, $member->{unitsize} || $member->{size});
94             }
95              
96 188         9905 my $value = $ffi->cast( 'opaque' => $member->{spec} . "*", $ptr );
97 188 100       18158 $value = $$value unless $member->{rec};
98 188 100       429 $value =~ s/\0.*$// if $member->{trim_string};
99              
100 188 100       391 if(my $enum = $member->{enum})
101             {
102 10 100       25 if($enum->rev eq 'str')
103             {
104 5 50       10 if(exists $enum->int_lookup->{$value})
105             {
106 5         10 $value = $enum->int_lookup->{$value};
107             }
108             }
109             }
110              
111 188         650 return $value;
112             }
113             else
114             {
115 6         525 Carp::croak("No such member: $name");
116             }
117             }
118              
119             sub can
120             {
121 147     147 0 42623 my($self, $name) = @_;
122             $self->{def}->{members}->{$name}
123 0     0   0 ? sub { shift->$name(@_) }
124 147 100       969 : $self->SUPER::can($name);
125             }
126              
127             sub DESTROY
128             {
129 106     106   9956 my($self) = @_;
130 106 100 100     556 if($self->{ptr} && !$self->{owner})
131             {
132 19         153 FFI::C::FFI::free(delete $self->{ptr});
133             }
134             }
135              
136             package FFI::C::Struct::MemberArrayTie;
137              
138             sub TIEARRAY
139             {
140 31     31   76 my($class, $struct, $name, $count) = @_;
141 31         149 bless [ $struct, $name, $count ], $class;
142             }
143              
144             sub FETCH
145             {
146 48     48   145 my($self, $index) = @_;
147 48         86 my($struct, $name) = @$self;
148 48         146 $struct->$name($index);
149             }
150              
151             sub STORE
152             {
153 6     6   13 my($self, $index, $value) = @_;
154 6         12 my($struct, $name) = @$self;
155 6         20 $struct->$name($index, $value);
156             }
157              
158             sub FETCHSIZE
159             {
160 12     12   2117 my($self) = @_;
161 12         57 $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__