File Coverage

blib/lib/FFI/C/ArrayDef.pm
Criterion Covered Total %
statement 85 88 96.5
branch 26 36 72.2
condition 13 24 54.1
subroutine 17 17 100.0
pod 2 2 100.0
total 143 167 85.6


line stmt bran cond sub pod time code
1             package FFI::C::ArrayDef;
2              
3 4     4   1309 use strict;
  4         9  
  4         175  
4 4     4   21 use warnings;
  4         19  
  4         97  
5 4     4   65 use 5.008001;
  4         32  
6 4     4   500 use Ref::Util qw( is_blessed_ref is_ref is_plain_arrayref );
  4         1613  
  4         277  
7 4     4   1640 use FFI::C::Array;
  4         8  
  4         106  
8 4     4   492 use Sub::Install ();
  4         1834  
  4         61  
9 4     4   470 use Sub::Util ();
  4         314  
  4         79  
10 4     4   20 use Scalar::Util qw( refaddr );
  4         8  
  4         189  
11 4     4   38 use base qw( FFI::C::Def );
  4         25  
  4         2289  
12              
13             our @CARP_NOT = qw( FFI::C );
14              
15             # ABSTRACT: Array data definition for FFI
16             our $VERSION = '0.15'; # VERSION
17              
18              
19             sub new
20             {
21 11     11 1 1274 my $self = shift->SUPER::new(@_);
22              
23 11         20 my %args = %{ delete $self->{args} };
  11         56  
24              
25 11         27 my $member;
26 11         23 my $count = 0;
27              
28 11 50       17 my @members = @{ delete $args{members} || [] };
  11         52  
29 11 100       51 if(@members == 1)
    50          
30             {
31 4         11 ($member) = @members;
32             }
33             elsif(@members == 2)
34             {
35 7         18 ($member, $count) = @members;
36             }
37             else
38             {
39 0         0 Carp::croak("The members argument should be a struct/union type and an optional element count");
40             }
41              
42 11 100       45 if(my $def = $self->ffi->def('FFI::C::Def', $member))
43             {
44 4         40 $member = $def;
45             }
46              
47 11 100       262 Carp::croak("Canot nest an array def inside of itself") if refaddr($member) == refaddr($self);
48              
49 10 50 33     96 Carp::croak("Illegal member")
      33        
50             unless defined $member && is_blessed_ref($member) && $member->isa("FFI::C::Def");
51              
52 10 50 33     82 Carp::croak("The element count must be a positive integer")
53             if defined $count && $count !~ /^[1-9]*[0-9]$/;
54              
55 10         33 $self->{size} = $member->size * $count;
56 10         36 $self->{align} = $member->align;
57 10         26 $self->{members}->{member} = $member;
58 10         29 $self->{members}->{count} = $count;
59              
60 10         35 Carp::carp("Unknown argument: $_") for sort keys %args;
61              
62 10 100       31 if($self->class)
63             {
64             # not handled by the superclass:
65             # 3. Any nested cdefs must have Perl classes.
66              
67             {
68 5         9 my $member = $self->{members}->{member};
  5         18  
69 5         14 my $accessor = $self->class . '::get';
70             Carp::croak("Missing Perl class for $accessor")
71 5 50 33     24 if $member->{nest} && !$member->{nest}->{class};
72             }
73              
74 5         28 $self->_generate_class(qw( get ));
75              
76             {
77 5         22 my $member_class = $self->{members}->{member}->class;
78 5         54 my $member_size = $self->{members}->{member}->size;
79             my $code = sub {
80 61     28   10374 my($self, $index) = @_;
        28      
        61      
        33      
        27      
81 61 100       440 Carp::croak("Negative array index") if $index < 0;
82 57 100 100     753 Carp::croak("OOB array index") if $self->{count} && $index >= $self->{count};
83 53         100 my $ptr = $self->{ptr} + $member_size * $index;
84 53         146 $member_class->new($ptr,$self);
85 5         82 };
86 5         18 Sub::Util::set_subname(join('::', $self->class), $code);
87 5         39 Sub::Install::install_sub({
88             code => $code,
89             into => $self->class,
90             as => 'get',
91             });
92             }
93              
94             {
95 4     4   51 no strict 'refs';
  4         9  
  4         1498  
  5         212  
  5         215  
96 5         46 push @{ join '::', $self->class, 'ISA' }, 'FFI::C::Array';
  5         17  
97             }
98              
99             }
100              
101 10         65 $self;
102             }
103              
104              
105             sub create
106             {
107 7     7 1 323 my $self = shift;
108              
109 7 50       22 return $self->class->new(@_) if $self->class;
110              
111 7         24 local $self->{size} = $self->{size};
112 7         16 my $count = $self->{members}->{count};
113 7 100       20 if(@_ == 1)
114             {
115 3 50       25 if(! is_ref $_[0])
    50          
116             {
117 0         0 $count = shift;
118             }
119             elsif(is_plain_arrayref $_[0])
120             {
121 3         6 $count = scalar @{$_[0]};
  3         9  
122             }
123 3 50       11 if($count)
124             {
125 3         13 $self->{size} = $self->{members}->{member}->size * $count;
126             }
127             }
128              
129 7 50 66     42 if( (@_ == 2 && ! is_ref $_[0]) || ($self->size) )
      66        
130             {
131 7         26 my $array = $self->SUPER::create(@_);
132 7         95 $array->{count} = $count;
133 7 100 66     58 FFI::C::Util::perl_to_c($array, $_[0]) if @_ == 1 && is_plain_arrayref $_[0];
134 7         28 return $array;
135             }
136              
137 0           Carp::croak("Cannot create array without knowing the number of elements");
138             }
139              
140             1;
141              
142             __END__