Struct indirection working
[perl-ctypes:perl-ctypes.git] / lib / Ctypes / Type / Field.pm
1 package Ctypes::Type::Field;
2 use Ctypes;
3 use Ctypes::Type::Struct;
4 use Carp;
5 use Data::Dumper;
6 use overload
7   '""'     => \&_string_overload,
8   '&{}'    => \&_code_overload,
9   fallback => 'TRUE';
10
11 our $Debug = 0;
12
13 sub _string_overload {
14   my $self = shift;
15   return "<Field type=" . $self->typename . ", ofs=" .
16     $self->offset . ", size=" . $self->size . ">";
17 }
18 sub _code_overload {
19   my $self = shift;
20   return sub { STORE( $self, @_ ) };
21 }
22
23 sub _code_overload {
24   print "Did we get to code overload?\n" if $Debug == 1;
25   print "args: ", Dumper( @_ ) if $Debug == 1;
26   return &STORE;
27 }
28
29 sub TIESCALAR {
30   my $class = ref($_[0]) || $_[0];  shift;
31   my $name  = shift;
32   my $type = shift;
33   my $offset = shift;
34   my $owner  = shift;
35   my $self  = {
36                 CONTENTS  => undef,
37                 _owner    => $owner,
38                 _name     => $name,
39                 _typecode => $type->type,
40                 _typename => $type->name,
41                 _size     => $type->size,
42                 _offset   => $offset,
43               };
44   print "In Field's TIESCALAR\n" if $Debug == 1;
45   print "    got offset $offset\n" if $Debug == 1;
46   return bless $self => $class;
47 }
48
49 #
50 # Accessor generation
51 #
52 my %access = ( 
53   typecode          => ['_typecode'],
54   type              => ['_typecode'],
55   typename          => ['_typename'],
56   alignment         => ['_alignment'],
57   name              => ['_name'],
58   size              => ['_size'],
59   contents          => ['CONTENTS',undef,1],
60   offset            => ['_offset'],
61   owner             => ['_owner',undef,1],
62              );
63 for my $func (keys(%access)) {
64   no strict 'refs';
65   my $key = $access{$func}[0];
66   *$func = sub {
67     my $self = shift;
68     my $arg = shift;
69 #    print "In $func accessor\n" if $Debug == 1;
70     croak("The $key method only takes one argument") if @_;
71     if($access{$func}[1] and defined($arg)){
72       eval{ $access{$func}[1]->($arg); };
73       if( $@ ) {
74         croak("Invalid argument for $key method: $@");
75       }
76     }
77     if($access{$func}[2] and defined($arg)) {
78       $self->{$key} = $arg;
79     }
80 #    print "    $func returning $key...\n" if $Debug == 1;
81     return $self->{$key};
82   }
83 }
84
85 sub STORE {
86   $DB::single = 1;
87   my( $self, $val ) = @_;
88   print "In ", $saelf->{_owner}{_name}, "'s ", $self->{_name}, " field STORE, called from ", join(", ",(caller(1))[0..3]), "\n" if $Debug == 1;
89   print "    arg is ", $val, "\n" if $Debug == 1;
90   print "    self is ", $self->name, "\n" if $Debug == 1;
91   # Check if key exists ### Done in object
92   print $self->{CONTENTS}, "\n" if $Debug == 1;
93   if( !ref($val) ) {
94     print "    val was not a reference\n" if $Debug == 1;
95     if( not defined $self->contents ) {
96       $val = new Ctypes::Type::Simple( $self->typecode, $val );
97       if( not defined $val ) {
98         carp("Could not create " . $self->typecode
99              . " type from argument '$val'");
100         return undef;
101       }
102       $val->{_needsfree} = 1;
103     } else {
104       print "    Setting field ", $self->{_name}, " to $val\n" if $Debug == 1;
105       ${$self->{CONTENTS}} = $val;
106     }
107   } else {
108     if( $val->name ne $self->{_typename} ) {
109       carp( "Cannot put " . $val->name . " type object into "
110             . $self->{_typename} . " type field" );
111       return undef;
112     }
113     if( $self->{CONTENTS} ) {
114       $self->{CONTENTS}->{_owner} = undef;
115     }
116     print "    Setting field ", $self->{_name}, " to $val\n" if $Debug == 1;
117     $self->{CONTENTS} = $val;
118   }
119
120   if( not defined $self->contents ) { $self->contents($val) }
121   my $datum = ${$self->contents->_data};
122   $self->contents->owner = $self->owner;
123   print "    Self->offset is ", $self->offset, "\n" if $Debug == 1;
124   $self->contents->_index($self->offset);
125   print "CONTENTS' INDEX IS NOW ", $self->contents->_index, "\n" if $Debug == 1;
126   print "contents is now ", $self->contents, "\n" if $Debug == 1;
127   $self->owner->_update_($datum, $self->offset);
128   print "    Setting Owner to ", $self->{_owner}{_name}, "\n" if $Debug == 1;
129   
130   return $self->{CONTENTS}; # success
131 }
132
133 sub FETCH : lvalue {
134   $DB::single = 1;
135   my $self = shift;
136   print "In ", $self->owner->name, "'s ", $self->name, " field FETCH,\n\tcalled from ", (caller(1))[0..3], "\n" if $Debug == 1;
137   if( defined $self->{_owner}{_owner}
138       or $self->{_owner}{_datasafe} == 0 ) {
139     print "    Can't trust data, updating...\n" if $Debug == 1;
140     $self->{_owner}->_update_;
141   }
142   croak("Error updating values!") if $self->{_owner}{_datasafe} != 1;
143
144 #  if( ref($self->{CONTENTS}) eq 'Ctypes::Type::Simple' ) {
145 #  print "    ", $self->{_owner}{_name}, "'s ", $self->{_name}, " field FETCH returning ", ${$self->{CONTENTS}} "\n" if $Debug == 1;
146 #    return ${$self->{HASH}{$key}};
147 #  } else {
148   print "    ", $self->{_owner}{_name}, "'s ", $self->{_name}, " field FETCH returning ", $self->{CONTENTS}, "\n" if $Debug == 1;
149     return $self->{CONTENTS};
150 #  }
151 }       
152
153 sub AUTOLOAD {
154   our $AUTOLOAD;
155   if ( $AUTOLOAD =~ /.*::(.*)/ ) {
156     return if $1 eq 'DESTROY';
157     my $wantfield = $1;
158     print "Trying to AUTOLOAD for $wantfield in FIELD\n"; # if $Debug == 1;
159     my $self = shift;
160     return $self->contents->$wantfield;
161   }
162 }
163
164 1;