File Coverage

blib/lib/FFI/Platypus/Record.pm
Criterion Covered Total %
statement 115 117 98.2
branch 35 44 79.5
condition 11 18 61.1
subroutine 14 15 93.3
pod 2 2 100.0
total 177 196 90.3


line stmt bran cond sub pod time code
1             package FFI::Platypus::Record;
2              
3 9     9   264201 use strict;
  9         30  
  9         270  
4 9     9   47 use warnings;
  9         18  
  9         228  
5 9     9   164 use 5.008004;
  9         36  
6 9     9   101 use Carp qw( croak );
  9         20  
  9         457  
7 9     9   763 use FFI::Platypus;
  9         138  
  9         282  
8 9     9   52 use Exporter qw( import );
  9         123  
  9         387  
9 9     9   64 use constant 1.32 ();
  9         207  
  9         6689  
10              
11             our @EXPORT = qw( record_layout record_layout_1 );
12              
13             # ABSTRACT: FFI support for structured records data
14             our $VERSION = '2.08'; # VERSION
15              
16              
17             sub record_layout_1
18             {
19 5 100 66 5 1 27670 if(@_ % 2 == 0)
    100 33        
    50          
20             {
21 3         20 my $ffi = FFI::Platypus->new( api => 2);
22 3         18 unshift @_, $ffi;
23 3         48 goto &record_layout;
24             }
25             elsif(defined $_[0] && ref($_[0]) eq 'ARRAY')
26             {
27 1         3 my @args = @{ shift @_ };
  1         3  
28 1         3 unshift @args, api => 2;
29 1         3 unshift @_, \@args;
30 1         5 goto &record_layout;
31             }
32 1         9 elsif(defined $_[0] && eval { $_[0]->isa('FFI::Platypus') })
33             {
34 1         6 goto &record_layout;
35             }
36             else
37             {
38 0         0 croak "odd number of arguments, but first argument is not either an array reference or Platypus instance";
39             }
40             }
41              
42              
43             sub record_layout
44             {
45 24     24 1 94935 my $ffi;
46              
47 24 50       96 if(defined $_[0])
48             {
49 24 100       96 if(ref($_[0]) eq 'ARRAY')
    100          
50             {
51 2         4 my @args = @{ shift() };
  2         8  
52 2         10 $ffi = FFI::Platypus->new(@args);
53             }
54 22         242 elsif(eval { $_[0]->isa('FFI::Platypus') })
55             {
56 7         19 $ffi = shift;
57             }
58             }
59              
60 24   66     154 $ffi ||= FFI::Platypus->new;
61              
62 24         94 my $offset = 0;
63 24         72 my $record_align = 0;
64              
65 24 50       98 croak "uneven number of arguments!" if scalar(@_) % 2;
66              
67 24         115 my($caller, $filename, $line) = caller;
68              
69 24 50 33     428 if($caller->can("_ffi_record_size")
70             || $caller->can("ffi_record_size"))
71             {
72 0         0 croak "record already defined for the class $caller";
73             }
74              
75 24         89 my @destroy;
76             my @ffi_types;
77 24         0 my $has_string;
78              
79 24         75 while(@_)
80             {
81 92         172 my $spec = shift;
82 92         172 my $name = shift;
83 92         428 my $type = $ffi->{tp}->parse( $spec, { member => 1 } );
84              
85 92 50 66     558 croak "illegal name $name"
86             unless $name =~ /^[A-Za-z_][A-Za-z_0-9]*$/
87             || $name eq ':';
88 92 100       733 croak "accessor/method $name already exists"
89             if $caller->can($name);
90              
91 91         376 my $size = $type->sizeof;
92 91         270 my $align = $type->alignof;
93 91 100       343 $record_align = $align if $align > $record_align;
94 91         745 my $meta = $type->meta;
95              
96 91         338 $offset++ while $offset % $align;
97              
98             {
99 91         154 my $count;
  91         179  
100             my $ffi_type;
101              
102 91 100       248 if($meta->{type} eq 'record') # this means fixed string atm
103             {
104 9         27 $ffi_type = 'sint8';
105 9         27 $count = $size;
106             }
107             else
108             {
109 82         194 $ffi_type = $meta->{ffi_type};
110 82         145 $count = $meta->{element_count};
111 82 100       185 $count = 1 unless defined $count;
112              
113 82 100       192 $has_string = 1 if $meta->{type} eq 'string';
114             }
115 91         450 push @ffi_types, $ffi_type for 1..$count;
116             }
117              
118 91 100       241 if($name ne ':')
119             {
120              
121 66 100 100     208 if($meta->{type} eq 'string'
122             && $meta->{access} eq 'rw')
123             {
124 8         422 push @destroy, eval '# line '. __LINE__ . ' "' . __FILE__ . qq("\n) .qq{
125             sub {
126             shift->$name(undef);
127             };
128             };
129 8 50       33 die $@ if $@;
130             }
131              
132 66         189 my $full_name = join '::', $caller, $name;
133 66         725 my $error_str = _accessor
134             $full_name,
135             "$filename:$line",
136             $type,
137             $offset;
138 66 50       222 croak("$error_str ($spec $name)") if $error_str;
139             };
140              
141 91         380 $offset += $size;
142             }
143              
144 23         78 my $size = $offset;
145              
146 9     9   74 no strict 'refs';
  9         19  
  9         3448  
147 23         1326 constant->import("${caller}::_ffi_record_size", $size);
148 23         714 constant->import("${caller}::_ffi_record_align", $record_align);
149 23         72 *{join '::', $caller, '_ffi_record_ro'} = \&_ffi_record_ro;
  23         130  
150 23         101 *{join '::', $caller, 'new'} = sub {
151 21     21   14944 my $class = shift;
152 21 100       69 my $args = ref($_[0]) ? [%{$_[0]}] : \@_;
  1         4  
153 21 50       72 croak "uneven number of arguments to record constructor"
154             if @$args % 2;
155 21         90 my $record = "\0" x $class->_ffi_record_size;
156 21         48 my $self = bless \$record, $class;
157              
158 21         59 while(@$args)
159             {
160 23         38 my $key = shift @$args;
161 23         40 my $value = shift @$args;
162 23         142 $self->$key($value);
163             }
164              
165 21         156 $self;
166 23         146 };
167              
168             {
169 23         50 require FFI::Platypus::Record::Meta;
  23         4363  
170 23         184 my $ffi_meta = FFI::Platypus::Record::Meta->new(
171             \@ffi_types,
172             !$has_string,
173             );
174 23     7   129 *{join '::', $caller, '_ffi_meta'} = sub { $ffi_meta };
  23         144  
  7         417  
175             }
176              
177 23     0   94 my $destroy_sub = sub {};
178              
179 23 100       78 if(@destroy)
180             {
181             $destroy_sub = sub {
182 5 50   5   22030 return if _ffi_record_ro($_[0]);
183 5         24 $_->($_[0]) for @destroy;
184 4         25 };
185             }
186 23         52 do {
187 9     9   79 no strict 'refs';
  9         31  
  9         1120  
188 23         40 *{"${caller}::DESTROY"} = $destroy_sub;
  23         113  
189             };
190 23         148 ();
191             }
192              
193             1;
194              
195             __END__