Struct indirection working
[perl-ctypes:perl-ctypes.git] / lib / Ctypes / Type / Struct.pm
1 package Ctypes::Type::Struct;
2 use strict;
3 use warnings;
4 use Ctypes;
5 use Ctypes::Type::Field;
6 use Carp;
7 use Data::Dumper;
8 use overload 
9   '${}'    => \&_scalar_overload,
10   fallback => 'TRUE';
11
12 our @ISA = qw|Ctypes::Type|;
13 my $Debug = 0;
14
15 sub _hash_overload {
16   return shift->_get_inner;
17 }
18
19 sub _scalar_overload {
20   return \shift->contents;
21 }
22
23 ############################################
24 # TYPE::STRUCT : PUBLIC FUNCTIONS & VALUES #
25 ############################################
26
27 sub new {
28   my $class = ref($_[0]) || $_[0];  shift;
29   print "In Struct::new constructor...\n" if $Debug == 1;
30   print "args:\n" if $Debug == 1;
31   # Try to determine if ::new was called by a class that inherits
32   # from Struct, and get the name of that class
33   # XXX Later, the [non-]existence of $progeny is used to make an
34   # educated guess at whether Struct was instantiated directly, or
35   # via a subclass.
36   # Q: What are some of the ways the following logic fails?
37   my $progeny = undef;
38   my $caller = (caller(1))[3];
39   print "    caller is ", $caller, "\n" if $caller and $Debug == 1;
40   if( defined $caller and $caller =~ m/::/ ) {  # need check for eval()s
41     $caller =~ s/::(.*)$//;
42     if( $caller->isa('Ctypes::Type::Struct') ) {
43       $progeny = $caller;
44     }
45   }
46
47   # What kind of input?
48   my( $in_vals, $in_fields ) = [];
49   if( ref($_[0]) eq 'HASH' ) {
50     my $hashref = shift;
51     # We only know about fields=> and values=>
52     for my $key (keys(%{$hashref})) {
53     croak(($progeny ? $progeny : 'Struct'), " error: unknown arg $key") 
54       unless $key eq 'fields' or $key eq 'values';
55     }
56     $in_vals   = $hashref->{values} if exists $hashref->{values};
57     $in_fields = $hashref->{fields} if exists $hashref->{fields};
58     print "    in_vals:\n", Dumper( $in_vals ) if $Debug == 1;
59     if( !$in_vals and @_ ) {  # So can specify fields in hashref
60       $in_vals = [ @_ ];      # and still list values lazily afterwards,
61     }                         # without having to name them all :)
62   } else {
63     print"    Vals are an Arrayref!\n" if $Debug == 1;
64     $in_vals = [ @_ ];
65   }
66
67   if( !$progeny ) {   # (probably) called as "new Struct( foo )"
68     print "    Check for multiply defined fields...\n" if $Debug == 1;
69     my %seenfields;
70     for( 0..$#{$in_fields} ) {
71       print "      Looking at ", Dumper($in_fields->[$_]) if $Debug == 1;
72       if( exists $seenfields{$in_fields->[$_][0]} ) {
73         croak( "Struct error: ",
74            "field '", $in_fields->[$_][0], "' defined more than once");
75         return undef;
76       }
77       $seenfields{$in_fields->[$_][0]} = 1;
78     }
79   }
80
81   # Get fields, populate with named/unnamed args
82   my $self = { _fields     => undef,      # hashref, field data by name
83                _fields_ord => undef,      # arrayref, order of fields
84                _typecode_  => 'p'    };
85
86   # format of _fields_ info: <name> <type> <default> <bitwidth>
87   for( my $i=0; defined(local $_ = $in_fields->[$i]); $i++ ) {
88     if( defined $_->[3] and $_->[1]->type ne 'i' ) {
89       croak("Bit fields must be type c_int (you specified a bit width)");
90     }
91     print "    Assigning field ", $_->[0], "\n" if $Debug == 1;
92     $self->{_fields}{ $_->[0] } =
93       [ $_->[0], $_->[1], $_->[2] ];
94     $self->{_fields}{$_->[0]}->[3] = $_->[3] if defined $_->[3];
95     $self->{_fields_ord}->[$i] = $self->{_fields}{ $_->[0] };
96   }
97
98   if( ref($in_vals) eq 'HASH' ) { # Named arguments
99     print "    Checking for unknown named attrs...\n" if $Debug == 1;
100     for(keys(%$in_vals) ) {
101       if( not exists $self->{_fields}{$_} ) {
102         my $tc = Ctypes::_check_type_needed( $in_vals->{$_} );
103         if( !ref($in_vals->{$_}) ) {
104           $in_vals->{$_} = Ctypes::Type::Simple->new( $tc, $in_vals->{$_} );
105         }
106         $self->{_fields}{$_}
107           = [ $_, Ctypes::Type::Simple->new($tc,0), undef ];
108       }
109       $self->{_fields_ord}->[ $#{$self->{_fields_ords}} + 1 ]
110         = $self->{_fields}{$_};
111     }
112   } else {  # positional arguments
113     if( $#$in_vals > $#{$self->{_fields_ord}} ) {
114       print $#$in_vals, " in_vals and ", scalar @{$self->{_fields_ord}},
115             " fields\n" if $Debug == 1;
116       print Dumper($in_vals) if $Debug == 1;
117       print Dumper($self->{_fields_ord}) if $Debug == 1;
118       croak( ($progeny ? $progeny : 'Struct'), " error: ",
119         "Too many positional arguments for fields!");
120     }
121   }
122
123   bless $self => $class;
124   my $base = $class->SUPER::_new;
125
126   for(keys %$base) { $self->{$_} = $base->{$_} }
127     print "    in_vals:\n", Dumper( $in_vals ) if $Debug == 1;
128
129   # Set name. This could be hella long, but it's how we figure out if two
130   # Structs in an array were of the same type, for example (until we work
131   # out multiple inheritance of fields).
132   $self->{_name} = '';
133   print "    Making name...\n" if $Debug == 1;
134   for( @{$self->{_fields_ord}} ) {
135     if( !ref($_->[1]) ) {
136       my $tc = Ctypes::_check_type_needed($_->[1]);
137       $_->[1] = Ctypes::Type::Simple->new($tc, $_->[1]);
138     }
139     $self->{_name} .= $_->[1]->name . '_';
140     $self->{_name} =~ s/c_//;
141   }
142   $self->{_name} .= '_Struct';
143
144   $self->{_allow_new_fields} = 1;
145   $self->{_size} = 0;
146   $self->{_contents} = new Ctypes::Type::Struct::Fields($self);
147   print "    Creating fields...\n" if $Debug == 1;
148   for( @{$self->{_fields_ord}} ) {
149     $self->{_contents}->add_field($_);
150     $self->{_size} += $_->[1]->size;
151   }
152   print "    Assigning values...\n" if $Debug == 1;
153     print "    in_vals:\n", Dumper( $in_vals ) if $Debug == 1;
154   if( ref($in_vals) eq 'HASH' ) {
155     for( @{$self->{_fields_ord}} ) {
156       $in_vals->{ $_[0] }
157         ? $self->{_contents}->set_value( $_->[0], $in_vals->{ $_->[0] } )
158         : $self->{_contents}->set_value( $_->[0], $_->[1] );
159     }
160   } else {
161     for( 0..$#{$self->{_fields_ord}} ) {
162       if( defined $in_vals->[$_] ) {
163         print "INTVALZIZ ", $in_vals->[$_], "\n" if $Debug == 1;
164         print "going into field ", $self->{_fields_ord}->[$_][0], "\n" if $Debug == 1;
165         $self->{_contents}->set_value(
166           $self->{_fields_ord}->[$_][0], $in_vals->[$_] );
167       } else {
168         $self->{_contents}->set_value(
169           $self->{_fields_ord}->[$_][0], $self->{_fields_ord}->[$_][1] );
170       }
171     }
172   }
173   $self->{_allow_new_fields} = 0;
174
175 #  for (@$fields) { # arrayref of ctypes, or just arrayref of paramtypes
176     # XXX convert fields to ctypes
177 #    my $fsize = $_->{size};
178 #    $size += $fsize;
179     # TODO: align!!
180   print "    Struct constructor returning\n" if $Debug == 1;
181   return $self;
182 }
183
184 sub _as_param_ { return $_[0]->_data(@_) }
185
186 sub _data { 
187   my $self = shift;
188   print "In ", $self->{_name}, "'s _DATA(), from ", join(", ",(caller(1))[0..3]), "\n" if $Debug == 1;
189     my @data;
190     my @ordkeys;
191     for( 0..$#{$self->{_fields_ord}} ) {
192       $ordkeys[$_] = $self->{_fields_ord}[$_][0];
193      print "    ordkeys[$_]: ", $ordkeys[$_], "\n" if $Debug == 1;
194     }
195 if( defined $self->{_data}
196       and $self->{_datasafe} == 1 ) {
197     print "    _data already defined and safe\n" if $Debug == 1;
198     print "    returning ", unpack('b*',$self->{_data}), "\n" if $Debug == 1;
199     for(@ordkeys) {
200       print "    Calling Datasafe on ", $_, "\n" if $Debug == 1;
201       if( defined $self->contents->raw->{$_}->contents ) {
202         $self->contents->raw->{$_}->contents->_datasafe = 0;
203         print "    He now knows his data's ", $self->contents->raw->{$_}->contents->_datasafe, "00% safe\n" if $Debug == 1;
204       }
205     }
206     return \$self->{_data};
207   }
208 # TODO This is where a check for an endianness property would come in.
209   if( $self->{_endianness} ne 'b' ) {
210     for(my $i=0;defined(local $_ = $ordkeys[$i]);$i++) {
211       $data[$i] = ${$self->{contents}->{$ordkeys[$i]}->_data};
212     }
213     $self->{_data} = join('',@data);
214     print "  ", $self->{_name}, "'s _data returning ok...\n" if $Debug == 1;
215     $self->_datasafe = 0;
216     for(@ordkeys) {
217       print "    Calling Datasafe on ", $self->{_contents}->{$_}, "\n"; # if $Debug == 1;
218       $self->{_contents}->{$_}->_datasafe = 0
219     }
220     return \$self->{_data};
221   } else {
222   # <insert code for other / swapped endianness here>
223   }
224 }
225
226 sub _update_ {
227   my($self, $arg, $index) = @_;
228   print "In ", $self->{_name}, "'s _UPDATE_, from ", join(", ",(caller(0))[0..3]), "\n" if $Debug == 1;
229   print "  self is: ", $self, "\n" if $Debug == 1;
230   print "  current data looks like:\n", unpack('b*',$self->{_data}), "\n" if $Debug == 1;
231   print "  arg is: $arg" if $arg and $Debug == 1;
232   print $arg ? (",  which is\n", unpack('b*',$arg), "\n  to you and me\n") : ('') if $Debug == 1;
233   print "  and index is: $index\n" if defined $index and $Debug == 1;
234   if( not defined $arg ) {
235     print "    Arg wasn't defined!\n" if $Debug == 1;
236     if( $self->{_owner} ) {
237     print "      Getting data from owner...\n" if $Debug == 1;
238     $self->{_data} = substr( ${$self->{_owner}->_data},
239                              $self->{_index},
240                              $self->{_size} );
241     }
242   } else {
243     if( defined $index ) {
244       my $pad = $index + length($arg) - length($self->{_data});
245       if( $pad > 0 ) {
246         $self->{_data} .= "\0" x $pad;
247       }
248       print "    Setting chunk of self->data\n" if $Debug == 1;
249       substr( $self->{_data},
250               $index,
251               length($arg)
252             ) = $arg;
253     } else {
254       $self->{_data} = $arg; # if data given with no index, replaces all
255     }
256   }
257
258   # Have to send all data upstream even if only 1 member updated
259   # ... or do we? Send our _index, plus #bytes updated member starts at?
260   # Could C::B::C help with this???
261   if( defined $arg and $self->{_owner} ) {
262   print "    Need to update my owner...\n" if $Debug == 1;
263   my $success = undef;
264   print "  Sending data back upstream:\n" if $arg and $Debug == 1;
265   print "    Index is ", $self->{_index}, "\n" if $arg and $Debug == 1;
266     $success =
267       $self->{_owner}->_update_(
268         $self->{_data},
269         $self->{_index}
270       );
271     if(!$success) {
272       croak($self->{_name},
273             ": Error updating member in owner object ",
274               $self->{_owner}->{_name});
275     }
276   }
277   $self->{_datasafe} = 1;
278   if( defined $arg or $self->{_owner} ) { # otherwise nothing's changed
279     for(keys %{$self->{_fields}}) {
280       print ref($self->{_contents}->{_rawfields}->{$_}->{CONTENTS}), "\n" if $Debug == 1;
281       $self->{_contents}->{_rawfields}->{$_}->{CONTENTS}->_datasafe = 0
282         if defined $self->{_contents}->{_rawfields}->{$_}->{CONTENTS};
283     }
284   }
285   print "  data NOW looks like:\n", unpack('b*',$self->{_data}), "\n" if $Debug == 1;
286   print "    ", $self->{_name}, "'s _Update_ returning ok\n" if $Debug == 1;
287   return 1;
288 }
289
290 #
291 # Accessor generation
292 #
293 my %access = ( 
294   typecode        => ['_typecode_'],
295   type              => ['_typecode_'],
296   allow_overflow    =>
297     [ '_allow_overflow',
298       sub {if( $_[0] == 1 or $_[0] == 0){return 1;}else{return 0;} },
299       1 ], # <--- makes this settable
300   alignment         => ['_alignment'],
301   name              => ['_name'],
302   size              => ['_size'],
303   fields            => ['_fields'],
304   field_list        => ['_fields_ord'],
305   contents          => ['_contents'],
306              );
307 for my $func (keys(%access)) {
308   no strict 'refs';
309   my $key = $access{$func}[0];
310   *$func = sub {
311     my $self = shift;
312     my $arg = shift;
313 #    print "In $func accessor\n" if $Debug == 1;
314     croak("The $key method only takes one argument") if @_;
315     if($access{$func}[1] and defined($arg)){
316       eval{ $access{$func}[1]->($arg); };
317       if( $@ ) {
318         croak("Invalid argument for $key method: $@");
319       }
320     }
321     if($access{$func}[2] and defined($arg)) {
322       $self->{$key} = $arg;
323     }
324 #    print "    $func returning $key...\n" if $Debug == 1;
325     return $self->{$key};
326   }
327 }
328
329 sub AUTOLOAD {
330   our $AUTOLOAD;
331   if ( $AUTOLOAD =~ /.*::(.*)/ ) {
332     return if $1 eq 'DESTROY';
333     my $wantfield = $1;
334     print "Trying to AUTOLOAD for $wantfield in STRUCT\n" if $Debug == 1;
335     my $self = $_[0];
336     my $found = 0;
337     if( exists $self->fields->{$wantfield} ) {
338       $found = 1;
339     }
340     my $name = $wantfield;
341     $found ? print "    Found it!\n" : print "    Didnt find it\n" if $Debug == 1;
342     if( $found == 1 ) {
343       my $func = sub {
344         my $caller = shift;
345         my $arg = shift;
346         print "In $name accessor\n" if $Debug == 1;
347         croak("Usage: $name( arg )") if @_;
348         if( not defined $arg ) {
349           if(ref($caller)) {
350             print "    Returning value...\n" if $Debug == 1;
351             my $ret = $caller->{_contents}->{_rawfields}->{$name};
352             if( ref($ret) eq 'Ctypes::Type::Simple' ) {
353               return ${$ret};
354             } else {
355               return $ret;
356             }
357           } else {  # class method
358             if( defined ${"${caller}::_fields_info{$name}"} ) {
359               return  ${"${caller}::_fields_info{$name}"};
360             } else {
361               my $field;
362               print "    Looking for field '$name'\n" if $Debug == 1;
363               for( $self->field_list ) {
364                 $field = $_ if $_[0] = $name;
365               }
366               my $info = {
367                      name => $name,
368                      type => $field->[1]->_typecode_,
369                      size => $field->[1]->size,
370                      ofs  => 0,                       # XXX
371                    };
372                ${"${caller}::_fields_info{$name}"} = $info;
373               return $info;
374             }
375           }
376         } else {
377         }
378       };
379       no strict 'refs';
380       *{"Ctypes::Type::Struct::$wantfield"} = $func;
381       goto &{"Ctypes::Type::Struct::$wantfield"};
382     }
383   }
384 }
385
386 package Ctypes::Type::Struct::Fields;
387 use warnings;
388 use strict;
389 use Ctypes;
390 use Carp;
391 use Data::Dumper;
392
393 sub new {
394   my $class = ref($_[0]) || $_[0];  shift;
395   my $owner = shift;
396   return bless {
397                  _owner     => $owner,
398                  _fields    => {},
399                  _rawfields => {},
400                } => $class;
401 }
402
403 sub owner { return $_[0]->{_owner} }
404
405 sub add_field {
406   my $self = shift;
407   my $field = shift;
408   print "IN ADD FIELD\n" if $Debug == 1;
409   print "    offset will be ", $self->owner->size, "\n" if $Debug == 1;
410   $self->{_rawfields}->{$_->[0]} = 
411     tie $self->{_fields}->{$_->[0]},
412       'Ctypes::Type::Field',
413       $_->[0],
414       $_->[1],
415       $self->owner->size,
416       $self->owner;
417 }
418
419 sub set_value {
420   my( $self, $key, $val ) = @_;
421   $self->{_fields}->{$key} = $val;
422   return 1;
423 }
424
425 sub raw { return $_[0]->{_rawfields} }
426
427 sub AUTOLOAD {
428   our $AUTOLOAD;
429   if ( $AUTOLOAD =~ /.*::(.*)/ ) {
430     return if $1 eq 'DESTROY';
431     my $wantfield = $1;
432     print "Trying to AUTOLOAD for $wantfield in FieldSS\n" if $Debug == 1;
433     my $self = $_[0];
434     my $found = 0;
435     if( exists $self->owner->fields->{$wantfield} ) {
436       $found = 1;
437     }
438     my $name = $wantfield;
439     $found ? print "    Found it!\n" : print "    Didnt find it\n" if $Debug == 1;
440     if( $found == 1 ) {
441       my $owner = $self->owner;
442       my $func = sub {
443         my $caller = shift;
444         my $arg = shift;
445         print "In $name accessor\n" if $Debug == 1;
446         croak("Usage: $name( arg )") if @_;
447         if( not defined $arg ) {
448           if(ref($caller)) {
449             print "    Returning value...\n" if $Debug == 1;
450             print Dumper( $self->{_fields}->{$name} ) if $Debug == 1;
451             my $ret = $self->{_fields}->{$name};
452             if( ref($ret) eq 'Ctypes::Type::Simple' ) {
453               return ${$ret};
454             } else {
455               return $ret;
456             }
457           } else {  # class method
458             if( defined ${"${owner}::_fields_info{$name}"} ) {
459               return  ${"${owner}::_fields_info{$name}"};
460             } else {
461               my $field;
462               print "    Looking for field '$name'\n" if $Debug == 1;
463               for( $owner->field_list ) {
464                 $field = $_ if $_[0] = $name;
465               }
466               my $info = {
467                      name => $name,
468                      type => $field->[1]->_typecode_,
469                      size => $field->[1]->size,
470                      ofs  => 0,                       # XXX
471                    };
472                ${"${owner}::_fields_info{$name}"} = $info;
473               return $info;
474             }
475           }
476         } else {
477         }
478       };
479       no strict 'refs';
480       *{"Ctypes::Type::Struct::Fields::$wantfield"} = $func;
481       goto &{"Ctypes::Type::Struct::Fields::$wantfield"};
482     }
483   }
484 }
485
486 1;