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