Many changes
[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_ord}} + 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]->typecode;
140   }
141   $self->{_name} .= '_Struct';
142
143   $self->{_allow_new_fields} = 1;
144   $self->{_size} = 0;
145   $self->{_contents} = new Ctypes::Type::Struct::Fields($self);
146   print "    Creating fields...\n" if $Debug == 1;
147   for( @{$self->{_fields_ord}} ) {
148     $self->{_contents}->add_field($_);
149     $self->{_size} += $_->[1]->size;
150   }
151   print "    Assigning values...\n" if $Debug == 1;
152     print "    in_vals:\n", Dumper( $in_vals ) if $Debug == 1;
153   if( ref($in_vals) eq 'HASH' ) {
154     for( @{$self->{_fields_ord}} ) {
155       $in_vals->{ $_[0] }
156         ? $self->{_contents}->set_value( $_->[0], $in_vals->{ $_->[0] } )
157         : $self->{_contents}->set_value( $_->[0], $_->[1] );
158     }
159   } else {
160     for( 0..$#{$self->{_fields_ord}} ) {
161       if( defined $in_vals->[$_] ) {
162         print "INTVALZIZ ", $in_vals->[$_], "\n" if $Debug == 1;
163         print "going into field ", $self->{_fields_ord}->[$_][0], "\n" if $Debug == 1;
164         $self->{_contents}->set_value(
165           $self->{_fields_ord}->[$_][0], $in_vals->[$_] );
166       } else {
167         $self->{_contents}->set_value(
168           $self->{_fields_ord}->[$_][0], $self->{_fields_ord}->[$_][1] );
169       }
170     }
171   }
172   $self->{_allow_new_fields} = 0;
173   $self->{_endianness} = 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     my $rawcontents = $self->{_contents}->{_rawfields};
211     for(my $i=0;defined(local $_ = $ordkeys[$i]);$i++) {
212       $data[$i] = $rawcontents->{$ordkeys[$i]}->{CONTENTS}->{_data};
213     }
214     $self->{_data} = join('',@data);
215     print "  ", $self->{_name}, "'s _data returning ok...\n" if $Debug == 1;
216     $self->_datasafe(0);
217     return \$self->{_data};
218   } else {
219   # <insert code for other / swapped endianness here>
220   }
221 }
222
223 sub _update_ {
224   my($self, $arg, $index) = @_;
225   print "In ", $self->{_name}, "'s _UPDATE_, from ", join(", ",(caller(0))[0..3]), "\n" if $Debug == 1;
226   print "  self is: ", $self, "\n" if $Debug == 1;
227   print "  current data looks like:\n", unpack('b*',$self->{_data}), "\n" if $Debug == 1;
228   print "  arg is: $arg" if $arg and $Debug == 1;
229   print $arg ? (",  which is\n", unpack('b*',$arg), "\n  to you and me\n") : ('') if $Debug == 1;
230   print "  and index is: $index\n" if defined $index and $Debug == 1;
231   if( not defined $arg ) {
232     print "    Arg wasn't defined!\n" if $Debug == 1;
233     if( $self->{_owner} ) {
234     print "      Getting data from owner...\n" if $Debug == 1;
235     $self->{_data} = substr( ${$self->{_owner}->data},
236                              $self->{_index},
237                              $self->{_size} );
238     }
239   } else {
240     if( defined $index ) {
241       my $pad = $index + length($arg) - length($self->{_data});
242       if( $pad > 0 ) {
243         $self->{_data} .= "\0" x $pad;
244       }
245       print "    Setting chunk of self->data\n" if $Debug == 1;
246       substr( $self->{_data},
247               $index,
248               length($arg)
249             ) = $arg;
250     } else {
251       $self->{_data} = $arg; # if data given with no index, replaces all
252     }
253   }
254
255   # Have to send all data upstream even if only 1 member updated
256   # ... or do we? Send our _index, plus #bytes updated member starts at?
257   # Could C::B::C help with this???
258   if( defined $arg and $self->{_owner} ) {
259   print "    Need to update my owner...\n" if $Debug == 1;
260   my $success = undef;
261   print "  Sending data back upstream:\n" if $arg and $Debug == 1;
262   print "    Index is ", $self->{_index}, "\n" if $arg and $Debug == 1;
263     $success =
264       $self->{_owner}->_update_(
265         $self->{_data},
266         $self->{_index}
267       );
268     if(!$success) {
269       croak($self->{_name},
270             ": Error updating member in owner object ",
271               $self->{_owner}->{_name});
272     }
273   }
274   $self->{_datasafe} = 1;
275   if( defined $arg or $self->{_owner} ) { # otherwise nothing's changed
276     $self->_set_owned_unsafe;
277   }
278   print "  data NOW looks like:\n", unpack('b*',$self->{_data}), "\n" if $Debug == 1;
279   print "    ", $self->{_name}, "'s _Update_ returning ok\n" if $Debug == 1;
280   return 1;
281 }
282
283 #
284 # Accessor generation
285 #
286 my %access = ( 
287   typecode        => ['_typecode_'],
288   type              => ['_typecode_'],
289   allow_overflow    =>
290     [ '_allow_overflow',
291       sub {if( $_[0] == 1 or $_[0] == 0){return 1;}else{return 0;} },
292       1 ], # <--- makes this settable
293   alignment         => ['_alignment'],
294   name              => ['_name'],
295   size              => ['_size'],
296   fields            => ['_fields'],
297   field_list        => ['_fields_ord'],
298   contents          => ['_contents'],
299              );
300 for my $func (keys(%access)) {
301   no strict 'refs';
302   my $key = $access{$func}[0];
303   *$func = sub {
304     my $self = shift;
305     my $arg = shift;
306 #    print "In $func accessor\n" if $Debug == 1;
307     croak("The $key method only takes one argument") if @_;
308     if($access{$func}[1] and defined($arg)){
309       eval{ $access{$func}[1]->($arg); };
310       if( $@ ) {
311         croak("Invalid argument for $key method: $@");
312       }
313     }
314     if($access{$func}[2] and defined($arg)) {
315       $self->{$key} = $arg;
316     }
317 #    print "    $func returning $key...\n" if $Debug == 1;
318     return $self->{$key};
319   }
320 }
321
322 sub _datasafe {
323   my( $self, $arg ) = @_;
324   if( defined $arg and $arg != 1 and $arg != 0 ) {
325     croak("Usage: ->_datasafe(1 or 0)")
326   }
327   if( defined $arg and $arg == 0 ) {
328     $self->_set_owned_unsafe;
329   }
330   $self->{_datasafe} = $arg if defined $arg;
331   return $self->{_datasafe};
332 }
333
334 sub _set_owned_unsafe {
335   my $self = shift;
336   for( keys %{$self->contents->raw} ) {
337     if(defined $self->{_contents}->{_rawfields}->{$_}->{CONTENTS}) {
338       print "    Setting owned obj ", $self->{_contents}->{_rawfields}->{$_}->{CONTENTS}->name, "'s datasafe = 0\n" if $Debug == 1;
339       $self->{_contents}->{_rawfields}->{$_}->{CONTENTS}->_datasafe(0);
340     }
341   }
342   return 1;
343 }
344
345 sub AUTOLOAD {
346   our $AUTOLOAD;
347   if ( $AUTOLOAD =~ /.*::(.*)/ ) {
348     return if $1 eq 'DESTROY';
349     my $wantfield = $1;
350     print "Trying to AUTOLOAD for $wantfield in STRUCT\n" if $Debug == 1;
351     my $self = $_[0];
352     my $found = 0;
353     if( exists $self->fields->{$wantfield} ) {
354       $found = 1;
355     }
356     my $name = $wantfield;
357     $found ? print "    Found it!\n" : print "    Didnt find it\n" if $Debug == 1;
358     if( $found == 1 ) {
359       my $func = sub {
360         my $caller = shift;
361         my $arg = shift;
362         print "In $name accessor\n" if $Debug == 1;
363         croak("Usage: $name( arg )") if @_;
364         if( not defined $arg ) {
365           if(ref($caller)) {
366             print "    Returning value...\n" if $Debug == 1;
367             my $ret = $caller->{_contents}->{_rawfields}->{$name};
368             if( ref($ret) eq 'Ctypes::Type::Simple' ) {
369               return ${$ret};
370             } else {
371               return $ret;
372             }
373           } else {  # class method
374             if( defined ${"${caller}::_fields_info{$name}"} ) {
375               return  ${"${caller}::_fields_info{$name}"};
376             } else {
377               my $field;
378               print "    Looking for field '$name'\n" if $Debug == 1;
379               for( $self->field_list ) {
380                 $field = $_ if $_[0] = $name;
381               }
382               my $info = {
383                      name => $name,
384                      type => $field->[1]->_typecode_,
385                      size => $field->[1]->size,
386                      ofs  => 0,                       # XXX
387                    };
388                ${"${caller}::_fields_info{$name}"} = $info;
389               return $info;
390             }
391           }
392         } else {
393         }
394       };
395       no strict 'refs';
396       *{"Ctypes::Type::Struct::$wantfield"} = $func;
397       goto &{"Ctypes::Type::Struct::$wantfield"};
398     }
399   }
400 }
401
402 package Ctypes::Type::Struct::Fields;
403 use warnings;
404 use strict;
405 use Ctypes;
406 use Carp;
407 use Data::Dumper;
408
409 sub new {
410   my $class = ref($_[0]) || $_[0];  shift;
411   my $owner = shift;
412   return bless {
413                  _owner     => $owner,
414                  _fields    => {},
415                  _rawfields => {},
416                } => $class;
417 }
418
419 sub owner { return $_[0]->{_owner} }
420
421 sub add_field {
422   my $self = shift;
423   my $field = shift;
424   print "IN ADD FIELD\n" if $Debug == 1;
425   print "    offset will be ", $self->owner->size, "\n" if $Debug == 1;
426   $self->{_rawfields}->{$_->[0]} = 
427     tie $self->{_fields}->{$_->[0]},
428       'Ctypes::Type::Field',
429       $_->[0],
430       $_->[1],
431       $self->owner->size,
432       $self->owner;
433 }
434
435 sub set_value {
436   my( $self, $key, $val ) = @_;
437   $self->{_fields}->{$key} = $val;
438   return 1;
439 }
440
441 sub raw { return $_[0]->{_rawfields} }
442
443 sub AUTOLOAD {
444   our $AUTOLOAD;
445   if ( $AUTOLOAD =~ /.*::(.*)/ ) {
446     return if $1 eq 'DESTROY';
447     my $wantfield = $1;
448     print "Trying to AUTOLOAD for $wantfield in FieldSS\n" if $Debug == 1;
449     my $self = $_[0];
450     my $found = 0;
451     if( exists $self->owner->fields->{$wantfield} ) {
452       $found = 1;
453     }
454     my $name = $wantfield;
455     $found ? print "    Found it!\n" : print "    Didnt find it\n" if $Debug == 1;
456     if( $found == 1 ) {
457       my $owner = $self->owner;
458       my $func = sub {
459         my $caller = shift;
460         my $arg = shift;
461         print "In $name accessor\n" if $Debug == 1;
462         croak("Usage: $name( arg )") if @_;
463         if( not defined $arg ) {
464           if(ref($caller)) {
465             print "    Returning value...\n" if $Debug == 1;
466             my $ret = $self->{_rawfields}->{$name}->contents;
467             if( ref($ret) eq 'Ctypes::Type::Simple' ) {
468               return ${$ret};
469             } elsif( ref($ret) eq 'Ctypes::Type::Array') {
470               return ${$ret};
471             } else {
472               return $ret;
473             }
474           } else {  # class method
475             if( defined ${"${owner}::_fields_info{$name}"} ) {
476               return  ${"${owner}::_fields_info{$name}"};
477             } else {
478               my $field;
479               print "    Looking for field '$name'\n" if $Debug == 1;
480               for( $owner->field_list ) {
481                 $field = $_ if $_[0] = $name;
482               }
483               my $info = {
484                      name => $name,
485                      type => $field->[1]->_typecode_,
486                      size => $field->[1]->size,
487                      ofs  => 0,                       # XXX
488                    };
489                ${"${owner}::_fields_info{$name}"} = $info;
490               return $info;
491             }
492           }
493         } else {
494         }
495       };
496       no strict 'refs';
497       *{"Ctypes::Type::Struct::Fields::$wantfield"} = $func;
498       goto &{"Ctypes::Type::Struct::Fields::$wantfield"};
499     }
500   }
501 }
502
503 1;