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