Many changes
[perl-ctypes:perl-ctypes.git] / lib / Ctypes / Type / Array.pm
1 package Ctypes::Type::Array;
2 use strict;
3 use warnings;
4 use Carp;
5 use Ctypes;
6 use Scalar::Util qw|looks_like_number|;
7 use overload '@{}'    => \&_array_overload,
8              '${}'    => \&_scalar_overload,
9              fallback => 'TRUE';
10
11 our @ISA = qw|Ctypes::Type|;
12 my $Debug = 0;
13
14 =head1 NAME
15
16 Ctypes::Type::Array - Taking (some of) the misery out of C arrays!
17
18 =head1 SYNOPSIS
19
20   use Ctypes;
21
22   my $array = Array( 1, 3, 5, 7, 9 );
23
24   my $bytes_size = $array->size;         # sizeof(int) * $#array;
25
26   $array->[2] = 4;                       # That's ok.
27   my $longnum = INT_MAX() + 1;
28   $array->[2] = $longnum;                # Error!
29
30 =cut
31
32 ##########################################
33 # TYPE::ARRAY : PRIVATE FUNCTIONS & VALUES #
34 ##########################################
35
36 sub _arg_to_type {
37   my( $arg, $type ) = @_;
38   croak("_arg_to_type error: need typecode!") if not defined $type;
39   $type = $type->{_typecode} if ref($type); # take typecode or obj
40   my $out = undef;
41   if( !ref($arg) ) {     # Perl native type
42     # new() will handle casting and blow up if inappropriate
43     $out =  Ctypes::Type::Simple->new( $type, $arg );
44   } 
45   # Second simplest case: input is a Type object
46   if( ref($arg) eq 'Ctypes::Type::Simple' ) {
47     if( $arg->{_typecode} eq $type ) {
48       $out = $arg;
49     } else {
50       $out = Ctypes::Type::Simple->new( $type, $arg->{val} );
51     }
52   }
53   if( ref($arg) and ref($arg) ne 'Ctypes::Type::Simple') {
54   # This is the long shot: some other kind of object.
55   # In theory it Should work. TODO: a good test for this!
56     my $datum = $arg->{_data} ?
57       $arg->{_data} :
58       $arg->can("_as_param_") ? $arg->_as_param_ : undef;
59     carp("Object typecode differs but, you asked for it...")
60       if $arg->{_typecode} ne $type;
61     $out = Ctypes::Type::Simple->new($type,unpack($type,$datum))
62         if defined($datum);
63   }
64   return $out;
65 }
66
67 # Scenario A: We've been told what type to make the array
68 #   Cast all inputs to that type.
69 sub _get_members_typed {
70   my $deftype = shift;
71   my $in = shift;
72   my $members = [];
73   my $newval;
74   # A.a) Required type is a Ctypes Type
75   if( ref($deftype) eq 'Ctypes::Type::Simple' ) {
76     for(my $i = 0; defined(local $_ = $$in[$i]); $i++) {
77     $newval = _arg_to_type( $_, $deftype );
78     if( defined $newval ) {
79       $members->[$i] = $newval;
80       } else {
81    carp("Array input at $i could not be coaersed to type ",
82        $deftype->{name});
83        return undef;
84       }
85     }
86   } else {
87   # A.b) Required type is a user-defined object (which we've already
88   #      checked is 'Ctypes compatible'
89   # Since it's a non-type object, we can't do casting (we only know
90   # how data comes out [_typecode, _as_param_], not goes in.
91   # Just check they're all the same type, err if not
92     for(my $i = 0; $i <= $#$in; $i++) {
93       if( ref($$in[$i]) ne $deftype ) {
94         carp("Input at $i is not of user-defined type $deftype");
95         return undef;
96       }
97     }
98   }
99   return $members;
100 }
101
102 # Scenario B: Type not defined. Here come the best guesses!
103 # First get values of inputs, plus some info...
104 sub _get_members_untyped {
105   my $in = shift;
106   my $members = [];
107
108   my( $found_type, $invalid, $found_string) = undef;
109
110   for(my $i=0;defined(local $_ = $$in[$i]);$i++) {
111     if( defined $found_type ) {
112       if( ref ne $found_type ) {
113         carp("Arrays must be all of the same type: "
114              . " new type found at position $i");
115         return undef;
116       } else {
117         next;
118       }
119     }
120     if( ref ) {
121       if( $i > 0 ) {
122         carp("Arrays must be all of the same type: "
123            . " new type found at position $i");
124         return undef;
125       }
126       if( ref ne 'Ctypes::Type::Simple' ) {
127       $invalid = Ctypes::_check_invalid_types( [ $_ ] );
128         if( not $invalid ) {
129           $found_type = ref;
130         } else {
131           carp("Arrays can only store Ctypes compatible objects:"
132                . " type " . ref() . " is not valid");
133           return undef;
134         }
135       }
136       $found_type = ref;
137     }
138     if( not looks_like_number($_) ) { $found_string = 1 };
139   }
140
141   if( $found_type ) {
142     return $in;
143   }
144
145 # Now, check for non-numerics...
146   my $lcd = Ctypes::_check_type_needed(@$in);   # 'lowest common denomenator'
147   # Now create type objects for all members...
148   for(my $i = 0; defined( local $_ = $$in[$i]); $i++ ) {
149     $members->[$i] =
150       Ctypes::Type::Simple->new($lcd, $$in[$i]);
151   }
152   return $members;
153 }
154
155 sub _array_overload {
156   return shift->{members};
157 }
158
159 sub _scalar_overload {
160   return \shift;
161 }
162
163 ###########################################
164 # TYPE::ARRAY : PUBLIC FUNCTIONS & VALUES #
165 ###########################################
166
167 sub new {
168   my $class = ref($_[0]) || $_[0]; shift;
169   return undef unless defined($_[0]); # TODO: Uninitialised Arrays? Why??
170   # Specified array type in 1st pos, members in arrayref in 2nd
171   my( $deftype, $in );
172   # Note that since $deftype is a Ctypes::Type object, its presence must
173   # be ascertained with defined rather than a simple if( $deftype ) (since
174   # it will in many cases be the default 0 and return such in simple checks.
175   if( defined($_[0]) and ref($_[1]) eq 'ARRAY' ) {
176     $deftype = shift;
177     croak("Array type must be specified as Ctypes Type or similar object")
178       unless ref($deftype);
179     Ctypes::_check_invalid_types( [ $deftype ] );
180     $in = shift;
181   } else {  # no specification of array type, guess reasonable defaults
182     $in = Ctypes::_make_arrayref(@_);
183   }
184
185   my $inputs_typed = defined $deftype ?
186     _get_members_typed($deftype, $in) :
187     _get_members_untyped( $in );
188
189   if( not defined @{$inputs_typed} ) {
190     croak("Could not create Array from arguments supplied: see warnings");
191   }
192
193   $deftype = $inputs_typed->[0] if not defined $deftype;
194   my $name = $deftype->name;
195   $name =~ s/^c_//;
196
197   my $self = $class->SUPER::_new;
198   my $attrs = {
199     _name         => lc($name) . '_Array',
200     _typecode     => 'p',
201     _can_resize   => 0,
202     _endianness   => '',
203     _length       => $#$in + 1,
204     _member_type  => $deftype->typecode,
205     _member_size  => $deftype->size,
206                };
207   for(keys(%{$attrs})) { $self->{$_} = $attrs->{$_}; };
208   bless $self => $class;
209   $self->{_name} =~ s/::/_/g;
210   $self->{_size} = $deftype->size * ($#$in + 1);
211   $self->{_rawmembers} =
212     tie @{$self->{members}}, 'Ctypes::Type::Array::members', $self;
213   @{$self->{members}} =  @{$inputs_typed};
214   return $self;
215 }
216
217 #
218 # Accessor generation
219 #
220 my %access = (
221   'length'          => ['_length'],
222   can_resize        =>
223     [ '_can_resize',
224       sub {if( $_[0] != 1 and $_[0] != 0){return 0;}else{return 1;} },
225       1 ], # <--- this makes 'flexible' settable
226   alignment         => ['_alignment'],
227   member_type       => ['_member_type'],
228   member_size       => ['_member_size'],
229   endianness        => ['_endianness'],
230              );
231 for my $func (keys(%access)) {
232   no strict 'refs';
233   my $key = $access{$func}[0];
234   *$func = sub {
235     my $self = shift;
236     my $arg = shift;
237     croak("The $key method only takes one argument") if @_;
238     if($access{$func}[1] and defined($arg)){
239       eval{ $access{$func}[1]->($arg); };
240       if( $@ ) {
241         croak("Invalid argument for $key method: $@");
242       }
243     }
244     if($access{$func}[2] and defined($arg)) {
245       $self->{$key} = $arg if $arg;
246     }
247     return $self->{$key};
248   }
249 }
250
251 sub data { 
252   my $self = shift;
253   print "In ", $self->{_name}, "'s _DATA(), from ", join(", ",(caller(1))[0..3]), "\n" if $Debug == 1;
254 if( defined $self->{_data}
255       and $self->_datasafe == 1 ) {
256     print "    _data already defined and safe\n" if $Debug == 1;
257     print "    returning ", unpack('b*',$self->{_data}), "\n" if $Debug == 1;
258     return \$self->{_data};
259   }
260 # TODO This is where a check for an endianness property would come in.
261   if( $self->{_endianness} ne 'b' ) {
262     my @data;
263     for(my $i=0;defined(local $_ = $self->{_rawmembers}{VALUES}[$i]);$i++) {
264       $data[$i] = # $_->{_data} ?
265   #      $_->{_data} :
266         ${$_->_as_param_};
267     }
268     $self->{_data} = join('',@data);
269     print "  ", $self->{_name}, "'s _data returning ok...\n" if $Debug == 1;
270     $self->_datasafe(0);
271     return \$self->{_data};
272   } else {
273   # <insert code for other / swapped endianness here>
274   }
275 }
276
277 sub _as_param_ { return $_[0]->data(@_) }
278
279 sub _update_ {
280   my($self, $arg, $index) = @_;
281   print "In ", $self->{_name}, "'s _UPDATE_, from ", join(", ",(caller(0))[0..3]), "\n" if $Debug == 1;
282   print "  self is: ", $self, "\n" if $Debug == 1;
283   print "  current data looks like:\n", unpack('b*',$self->{_data}), "\n" if $Debug == 1;
284   print "  arg is: $arg\n" if $arg and $Debug == 1;
285   print "  which is\n", unpack('b*',$arg), "\n  to you and me\n" if $arg and $Debug == 1;
286   print "  and index is: $index\n" if $index and $Debug == 1;
287   if( not defined $arg ) {
288     if( $self->{_owner} ) {
289     $self->{_data} = substr( ${$self->{_owner}->data},
290                              $self->{_index},
291                              $self->{_size} );
292     }
293   } else {
294     if( $index ) {
295       my $pad = $index + length($arg) - length($self->{_data});
296       if( $pad > 0 ) {
297         $self->{_data} .= "\0" x $pad;
298       }
299       print "  Putting arg where I think it should go...\n" if $Debug == 1;
300       substr( $self->{_data},
301               $index,
302               length($arg)
303             ) = $arg;
304       print "  In ", $self->name, ", data NOW looks like:\n", unpack('b*',$self->{_data}), "\n" if $Debug == 1;
305     } else {
306       $self->{_data} = $arg; # if data given with no index, replaces all
307   print "  In ", $self->name, ", data NOW looks like:\n", unpack('b*',$self->{_data}), "\n" if $Debug == 1;
308     }
309   }
310
311   # Have to send all data upstream even if only 1 member updated
312   # ... or do we? Send our _index, plus #bytes updated member starts at?
313   # Could C::B::C help with this???
314   if( defined $arg and $self->{_owner} ) {
315   my $success = undef;
316   print "  Sending data back upstream:\n" if $arg and $Debug == 1;
317   print "    Index is ", $self->{_index}, "\n" if $arg and $Debug == 1;
318     $success =
319       $self->{_owner}->_update_(
320         $self->{_data},
321         $self->{_index}
322       );
323     if(!$success) {
324       croak($self->{_name},
325             ": Error updating member in owner object ",
326               $self->{_owner}->{_name});
327     }
328   }
329   $self->_datasafe(1);
330   print "BLARG: ", $self->{_rawmembers}, "\n" if $Debug == 1;
331   for(@{$self->{_rawmembers}->{VALUES}}) {
332     print "    Telling $_ it's not safe\n" if $Debug == 1;
333     $_->_datasafe(0);
334   }
335   print "  In ", $self->name, ", data NOW looks like:\n", unpack('b*',$self->{_data}), "\n" if $Debug == 1;
336   print "    ", $self->{_name}, "'s _Update_ returning ok\n" if $Debug == 1;
337   return 1;
338 }
339
340 sub _datasafe {
341   my( $self, $arg ) = @_;
342   if( defined $arg and $arg != 1 and $arg != 0 ) {
343     croak("Usage: ->_datasafe(1 or 0)")
344   }
345   if( defined $arg and $arg == 0 ) {
346     for(@{$self->{_rawmembers}{VALUES}}) { $_->_datasafe(0) }
347   }
348   $self->{_datasafe} = $arg if defined $arg;
349   return $self->{_datasafe};
350 }
351
352 package Ctypes::Type::Array::members;
353 use strict;
354 use warnings;
355 use Carp;
356 use Ctypes::Type::Array;
357 use Tie::Array;
358
359 # our @ISA = ('Tie::StdArray');
360
361 sub TIEARRAY {
362   my $class = shift;
363   my $object = shift;
364   my $self = { object   => $object,
365                VALUES     => [],
366              };
367   return bless $self => $class;
368 }
369
370 sub STORE {
371   my( $self, $index, $arg ) = @_;
372   print "In ", $self->{object}{_name}, "'s STORE, from ", join(", ",(caller(1))[0..3]), "\n" if $Debug == 1;
373
374   if( $index > ($self->{object}{_length} - 1)
375       and $self->{object}{_can_resize} = 0 ) {
376     croak("Max index ", $#$self,"; not allowed to resize!");
377     return undef;
378   }
379
380   my $val;
381   if( !ref($arg) ) {
382     $val = Ctypes::Type::Array::_arg_to_type($arg,$self->{object}{_member_type});
383     if( not defined $val ) {
384       carp("Could not create " . $self->{object}{_name}
385            . " type from argument '$arg'");
386       return undef;
387     }
388     $val->{_needsfree} = 1;
389   } else {
390   # Deal with being assigned other Type objects and the like...
391     $val = $arg;
392   }
393
394   if( ref($val) eq 'ARRAY' ) {
395     $val = new Ctypes::Type::Array( $val );
396   }
397
398   if( $val->typecode =~ /p/ ) {  # might add other pointer types...
399     if ( ref($self->{VALUES}[0])   # might be first obj added
400          and ref($val) ne ref($self->{VALUES}[0]) ) {
401     carp( "Cannot put " . ref($val) . " type object into "
402           . $self->{object}{_name} );
403     return undef;
404     }
405   } elsif( $val->typecode ne $self->{object}{_member_type} ) {
406     carp( "Cannot put " . ref($val) . " type object into "
407           . $self->{object}{_name} );
408     return undef;
409   }
410
411   if( $self->{VALUES}[$index] ) {
412     $self->{VALUES}[$index]->{_owner} = undef;
413 #    if( $self->{VALUES}[$index]{_needsfree} == 1 )  # If this were C (or
414 # if it were someday being translated to C), I think this might be where
415 # one would make use of the disappearing object's _needsfree attribute.
416   }
417   my $datum = ${$val->data}; # BEFORE setting owner, that's important!
418   print "    Arg is ", $val, " / ", ref($val), " / ", ref($val) ? $val->name : '', " / ", ${$val}, "\n" if $Debug == 1;
419   print "    ", __PACKAGE__ . ":" . __LINE__, ": In data form, that's\n",unpack('b*',$datum),"\n" if $Debug == 1;
420   $self->{VALUES}[$index]->{_owner} = $self->{object};
421   $self->{VALUES}[$index]->{_index}
422     = $index * $self->{object}->{_member_size};
423   print "    Setting {VALUES}[$index] to $val\n" if $Debug == 1;
424   $self->{VALUES}[$index] = $val;
425   $self->{VALUES}[$index]->{_owner} = $self->{object};
426   $self->{VALUES}[$index]->{_index} = $index * $self->{object}->{_member_size};
427
428 # XXX Found this while working on Struct, think it's suspect. Sadly,
429 # tests still pass without it. Doesn't say much for the regime :(
430 #  if( $self->{object}{_owner} ) {
431 #    $self->{object}{_owner}->_update_($arg, $self->{_owner}{_index});
432 #  }
433   $self->{object}->_update_($datum, $index * $self->{object}{_member_size});
434   
435   return $self->{VALUES}[$index]; # success
436 }
437
438 sub FETCH {
439   my($self, $index) = @_;
440   print "In ", $self->{object}{_name}, "'s FETCH, looking for [ $index ], called from ", join(", ",(caller(1))[0..3]), "\n" if $Debug == 1;
441   if( defined $self->{object}{_owner}
442       or $self->{object}{_datasafe} == 0 ) {
443     print "    Can't trust data, updating...\n" if $Debug == 1;
444     $self->{object}->_update_; # Don't need to update member we're FETCHing;
445                                # it will pull from us, because we _owner it
446   }
447   croak("Error updating values!") if $self->{object}{_datasafe} != 1;
448   if( ref($self->{VALUES}[$index]) eq 'Ctypes::Type::Simple' ) {
449   print "    ", $self->{object}{_name}, "'s FETCH[ $index ] returning ", $self->{VALUES}[$index], "\n" if $Debug == 1;
450   carp "    ", $self->{object}{_name}, "\n" if $Debug == 1;
451   carp "    ", $self->{VALUES}[$index], "\n" if $Debug == 1;
452     return ${$self->{VALUES}[$index]};
453   } else {
454     print "    ", $self->{object}{_name}, "'s FETCH[ $index ] returning ", $self->{VALUES}[$index], "\n" if $Debug == 1;
455     print "\n" if $Debug == 1;
456     return $self->{VALUES}[$index];
457   }
458 }
459
460 sub CLEAR { $_[0]->{VALUES} = [] }
461 sub EXTEND { }
462 sub FETCHSIZE { scalar @{$_[0]->{VALUES}} }
463
464 1;