More docs
[perl-ctypes:shlomifs-perl-ctypes.git] / lib / Ctypes / Type / Union.pm
1 package Ctypes::Type::Union;
2 use strict;
3 use warnings;
4 use Ctypes;
5 use base qw|Ctypes::Type::Struct|;
6
7 use Carp;
8 use Data::Dumper;
9
10 my $Debug = 0;
11
12 ###########################################
13 # TYPE::UNION : PUBLIC FUNCTIONS & VALUES #
14 ###########################################
15
16 sub new {
17   my $class = ref($_[0]) || $_[0];  shift;
18   print "In Union::new constructor...\n" if $Debug;
19   my $self = $class->SUPER::new(@_);
20   print "    Hash returned\n" if $Debug;
21
22   print "    Getting biggest size\n" if $Debug;
23   my $thissize = 0;
24   my $biggest = 0;
25   for( keys %{$self->fields} ) {
26     print "  Looking at field $_\n" if $Debug;
27     $thissize = $self->fields->{$_}->size;
28     print "  it's $thissize bytes long\n" if $Debug;
29     $biggest = $thissize if $thissize > $biggest;
30   }
31   $self->_set_size($biggest);
32   print "  Biggest field was size $biggest\n" if $Debug;
33
34   my $newname = $self->name;
35   $newname =~ s/Struct$/Union/;
36   $newname = 'Union' if $newname eq 'Union_Union';
37   $self->_set_name($newname);
38
39   # ??? Will this be ok or need to explicitly undef all?
40   for( keys %{$self->fields} ) {
41     if( defined $self->fields->{$_} ) {
42     $self->fields->{$_}->_datasafe(0);
43     $self->fields->{$_}->_set_owner($self);
44     }
45   }
46
47   # WHICH MEMber is currently valid.
48   $self->{_whichmem} = undef;
49
50   for( @{$self->fields} ) {
51     $_->_set_index(0);
52     print "$_ index: ", $_->index, "\n" if $Debug;
53   }
54
55   print "    Union constructor returning\n" if $Debug;
56   return $self;
57 }
58
59 sub is_set {
60   return $_[0]->{_whichmem};
61 }
62
63 sub _set_whichmem {
64   $_[0]->{_whichmem} = $_[1] if defined $_[1]; return $_[0]->{_whichmem};
65 }
66
67 sub _as_param_ { return $_[0]->data(@_) }
68
69 sub data {
70   my $self = shift;
71   print "In ", $self->{_name}, "'s _DATA(), from ", join(", ",(caller(1))[0..3]), "\n" if $Debug;
72   my @data;
73   if( defined $self->{_data}
74       and $self->{_datasafe} == 1 ) {
75     print "    _data already defined and safe\n" if $Debug;
76     print "    returning ", unpack('b*',$self->{_data}), "\n" if $Debug;
77     return \$self->{_data};
78   }
79 # TODO This is where a check for an endianness property would come in.
80 #  if( $self->{_endianness} ne 'b' ) {
81     for(@{$self->{_fields}->{_rawarray}}) {
82       push @data, $_->{_data};
83     }
84     $self->{_data} = join('',@data);
85     print "    returning ", unpack('b*',$self->{_data}), "\n" if $Debug;
86     print "  ", $self->{_name}, "'s _data returning ok...\n" if $Debug;
87     $self->_datasafe(0);
88     return \$self->{_data};
89 #  } else {
90   # <insert code for other / swapped endianness here>
91 #  }
92 }
93
94
95 sub _update_ {
96   my($self, $arg) = @_;
97   print "In ", $self->name, "'s _UPDATE_, from ", join(", ",(caller(0))[0..3]), "\n" if $Debug;
98   print "  self is: ", $self, "\n" if $Debug;
99   print "  current data looks like:\n", unpack('b*',$self->{_data}), "\n" if $Debug;
100   print "  arg is: $arg" if $arg and $Debug;
101   print $arg ? (",  which is\n", unpack('b*',$arg), "\n  to you and me\n") : ('') if $Debug;
102   if( defined $arg ) {
103     my $pad = length($self->{_data}) - length($arg);
104     if( $pad > 0 ) {
105       print "    Current data was $pad bytes longer than arg.\n    Padding arg...\n" if $Debug;
106       $arg .= "\0" x $pad;
107     } elsif ( $pad < 0 ) {
108       print "    Arg was longer; updating size...\n" if $Debug;
109       $self->{_size} = length($arg);
110     }
111     print "    Setting self->data\n" if $Debug;
112     $self->{_data} = $arg; # if data given with no index, replaces all
113   } else {
114     print "    Arg wasn't defined!\n" if $Debug;
115     if( $self->{_owner} ) {
116       print "      Getting data from owner...\n" if $Debug;
117       $self->{_data} = substr( ${$self->owner->data},
118                                $self->index,
119                                $self->size );
120     }
121   }
122
123   # Have to send all data upstream even if only 1 member updated
124   # ... or do we? Send our _index, plus #bytes updated member starts at?
125   # Could C::B::C help with this???
126   if( defined $arg and $self->{_owner} ) {
127     my $success = undef;
128     print "    Must send data back upstream, at index ", $self->{_index}, "\n" if $arg and $Debug;
129     $success =
130       $self->{_owner}->_update_(
131         $self->{_data},
132         $self->{_index}
133       );
134     if(!$success) {
135       croak($self->{_name},
136             ": Error updating member in owner object ",
137               $self->{_owner}->{_name});
138     }
139   }
140   $self->{_datasafe} = 1;
141   if( defined $arg or $self->{_owner} ) { # otherwise nothing's changed
142     $self->_set_owned_unsafe;
143   } else {
144     carp( $self->{_name}, "'s _update_ changed nothing!" );
145   }
146   print "  Data NOW looks like:\n    ", unpack('b*',$self->{_data}), "\n" if $Debug;
147   print "    ", $self->{_name}, "'s _Update_ returning ok\n" if $Debug;
148   return 1;
149 }
150
151 #
152 #  package Ctypes::Type::Union::Fields;
153 #  use warnings;
154 #  use strict;
155 #  use Ctypes;
156 #  use Carp;
157 #  use Data::Dumper;
158 #
159 #  sub new {
160 #    my $class = ref($_[0]) || $_[0];  shift;
161 #    my $owner = shift;
162 #    return bless {
163 #                   _owner     => $owner,
164 #                   _fields    => {},
165 #                   _rawfields => {},
166 #                 } => $class;
167 #  }
168 #
169 #  sub owner { return $_[0]->{_owner} }
170 #
171 #  sub add_field {
172 #    my $self = shift;
173 #    my $field = shift;
174 #    print "IN ADD FIELD\n" if $Debug;
175 #    print "    offset will be ", $self->owner->size, "\n" if $Debug;
176 #    $self->{_rawfields}->{$_->[0]} =
177 #      tie $self->{_fields}->{$_->[0]},
178 #        'Ctypes::Type::Field',
179 #        $_->[0],
180 #        $_->[1],
181 #        $self->owner->size,
182 #        $self->owner;
183 #  }
184 #
185 #  sub set_value {
186 #    my( $self, $key, $val ) = @_;
187 #    $self->{_fields}->{$key} = $val;
188 #    return 1;
189 #  }
190 #
191 #  sub raw { return $_[0]->{_rawfields} }
192 #
193 #  sub AUTOLOAD {
194 #    our $AUTOLOAD;
195 #    if ( $AUTOLOAD =~ /.*::(.*)/ ) {
196 #      return if $1 eq 'DESTROY';
197 #      my $wantfield = $1;
198 #      print "Trying to AUTOLOAD for $wantfield in FieldSS\n" if $Debug;
199 #      my $self = $_[0];
200 #      my $found = 0;
201 #      if( exists $self->owner->fields->{$wantfield} ) {
202 #        $found = 1;
203 #      }
204 #      my $name = $wantfield;
205 #      $found ? print "    Found it!\n" : print "    Didnt find it\n" if $Debug;
206 #      if( $found == 1 ) {
207 #        my $owner = $self->owner;
208 #        my $func = sub {
209 #          my $caller = shift;
210 #          my $arg = shift;
211 #          print "In $name accessor\n" if $Debug;
212 #          croak("Usage: $name( arg )") if @_;
213 #          if( not defined $arg ) {
214 #            if(ref($caller)) {
215 #              print "    Returning value...\n" if $Debug;
216 #              print Dumper( $self->{_fields}->{$name} ) if $Debug;
217 #              my $ret = $self->{_fields}->{$name};
218 #              if( ref($ret) eq 'Ctypes::Type::Simple' ) {
219 #                return ${$ret};
220 #              } elsif( ref($ret) eq 'Ctypes::Type::Array') {
221 #                return ${$ret};
222 #              } else {
223 #                return $ret;
224 #              }
225 #            } else {  # class method
226 #              if( defined ${"${owner}::_fields_info{$name}"} ) {
227 #                return  ${"${owner}::_fields_info{$name}"};
228 #              } else {
229 #                my $field;
230 #                print "    Looking for field '$name'\n" if $Debug;
231 #                for( $owner->field_list ) {
232 #                  $field = $_ if $_[0] = $name;
233 #                }
234 #                my $info = {
235 #                       name => $name,
236 #                       type => $field->[1]->_typecode_,
237 #                       size => $field->[1]->size,
238 #                       ofs  => 0,                       # XXX
239 #                     };
240 #                 ${"${owner}::_fields_info{$name}"} = $info;
241 #                return $info;
242 #              }
243 #            }
244 #          } else {
245 #          }
246 #        };
247 #        no strict 'refs';
248 #        *{"Ctypes::Type::Union::Fields::$wantfield"} = $func;
249 #        goto &{"Ctypes::Type::Union::Fields::$wantfield"};
250 #      }
251 #    }
252 #  }
253
254 1;