More docs
[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   '@{}'    => \&_array_overload,
9   '%{}'    => \&_hash_overload,
10   '&{}'    => \&_code_overload,
11   fallback => 'TRUE';
12
13 my $Debug = 0;
14
15 sub _array_overload {
16   return \@{$_[0]->{_rawcontents}->{VALUE}};
17 }
18
19 sub _hash_overload {
20   if( caller =~ /^Ctypes::Type/ ) {
21     return $_[0];
22   }
23   my( $self, $key ) = ( shift, shift );
24   my $class = ref($self);
25   bless $self => 'overload::dummy';
26   my $ret = $self->{_rawcontents};
27   bless $self => $class;
28   return $ret;
29 }
30
31 sub _string_overload {
32   return $_[0]->info;
33 }
34 sub _code_overload {
35   my $self = shift;
36   return sub { $self->{_rawcontents}->{VALUE} };
37 }
38
39 sub new {
40   my $class = ref($_[0]) || $_[0];  shift;
41   my( $key, $val, $offset, $obj ) = ( shift, shift, shift, shift );
42   my $self  = {
43                 _obj         => $obj,
44                 _index       => $offset,
45                 _key         => $key,
46                 _contents    => $val,
47                 _rawcontents => undef,
48               };
49   $self->{_rawcontents} = tie $self->{_contents},
50                           'Ctypes::Type::Field::contents',
51                           $self;
52   $self->{_contents} = $val;
53   return bless $self => $class;
54 }
55
56 #
57 # Accessor generation - DIFFERENT to most!
58 #
59 my %access = (
60   typecode          => ['_typecode'],
61   name              => ['_name'],
62   size              => ['_size'],
63   'index'           => ['_index'],
64   owner             => ['_owner'],
65              );
66 for my $func (keys(%access)) {
67   no strict 'refs';
68   my $key = $access{$func}[0];
69   *$func = sub {
70     my $self = shift;
71     my $arg = shift;
72     print "In $func accessor\n" if $Debug;
73     croak("The $key method only takes one argument") if @_;
74     if($access{$func}[1] and defined($arg)){
75       eval{ $access{$func}[1]->($arg); };
76       if( $@ ) {
77         croak("Invalid argument for $key method: $@");
78       }
79     }
80     if($access{$func}[2] and defined($arg)) {
81       $self->{_rawcontents}->{VALUE}->{$key} = $arg;
82     }
83     print "    $func returning $key...\n" if $Debug;
84     return $self->{_rawcontents}->{VALUE}->$func;
85   }
86 }
87
88 sub contents {
89   return $_[0]->{_contents};
90 }
91
92 sub key {
93   return $_[0]->{_key};
94 }
95
96 sub info {
97   my $self = shift;
98   return "<Field type=" . $self->name . ", ofs=" .
99     $self->index . ", size=" . $self->size . ">";
100 }
101
102 sub STORE {
103   $_[0]->{_contents} = $_[1];
104 }
105
106 sub FETCH {
107   return $_[0]->{_contents};
108 }
109
110 sub AUTOLOAD {
111   our $AUTOLOAD;
112   if ( $AUTOLOAD =~ /.*::(.*)/ ) {
113     return if $1 eq 'DESTROY';
114     my $func = $1;
115     print "Trying to AUTOLOAD for $func in FIELD\n" if $Debug;
116     my $self = shift;
117     print "args: ", @_, "\n" if @_ and $Debug;
118     return $self->{_rawcontents}->{VALUE}->$func(@_);
119   }
120 }
121
122 package Ctypes::Type::Field::contents;
123 use strict;
124 use warnings;
125 use Scalar::Util qw|blessed|;
126 use Data::Dumper;
127 use Carp;
128
129 sub TIESCALAR {
130   my $class = shift;
131   my $object = shift;
132   my $self = { _obj  => $object,
133                VALUE => undef,
134              };
135   return bless $self => $class;
136 }
137
138 sub STORE {
139   croak("Field's STORE must take an argument") if scalar @_ < 2;
140   my( $self, $val ) = ( shift, shift );
141   print "In ", $self->{_obj}{_obj}{_name}, "'s Field::STORE with arg '$val',\n" if $Debug;
142   print "    called from ", (caller(1))[0..3], "\n" if $Debug;
143   croak("Fields can only be assigned single values") if @_;
144   my $need_manual_update = 0;
145   if(!ref($val)) {
146     print "    \$val had no ref\n" if $Debug;
147     if( not defined $val ) {
148       print "    \$val not defined\n" if $Debug;
149       if( not defined $self->{VALUE} ) {
150         croak( "Fields must be initialised with a Ctypes object" );
151       } else {
152         print "    setting {VALUE} to undef\n" if $Debug;
153         ${$self->{VALUE}} = undef;
154       }
155     }
156     if( not defined $self->{VALUE} ) {
157       print "    Initialising {VALUE} with plain scalar...\n" if $Debug;
158       my $tc = Ctypes::_check_type_needed( $val );
159       $val = new Ctypes::Type::Simple( $tc, $val );
160       $self->{VALUE} = $val;
161       $need_manual_update = 1;
162     } else {
163       if( $self->{VALUE}->isa('Ctypes::Type::Simple') ) {
164         print "    Setting simple type to \$val\n" if $Debug;
165         ${$self->{VALUE}} = $val;
166       } else {
167         croak( "Tried to squash ", $self->{VALUE},
168                " object with value $val" );
169       }
170     }
171   } else {  # $val is a ref
172     print "    \$val is a ref\n" if $Debug;
173     if( blessed($val) ) {
174       if ( $val->isa('Ctypes::Type') ) {
175         $val = $val->copy;
176         print "    \$val copied successfully\n" if $val and $Debug;
177         $self->{VALUE}->_set_owner(undef) if defined $self->{VALUE};
178         $self->{VALUE}->_set_index(undef) if defined $self->{VALUE};
179         $self->{VALUE} = $val;
180         $need_manual_update = 1;
181       } else {
182         croak( "Structs can only hold Ctypes objects" );
183       }
184     } else {  # hashref or arrayref
185       if( defined $self->{VALUE} ) { # last-ditch attempt...
186         my $newval = $self->{VALUE}->new($val);
187         if( defined $newval ) {
188           $self->{VALUE}->_set_owner(undef) if defined $self->{VALUE};
189           $self->{VALUE}->_set_index(undef) if defined $self->{VALUE};
190           $self->{VALUE} = $newval;
191           $need_manual_update = 1;
192         } else {                     # didn't work
193           croak( "Couldn't make new ", $self->{VALUE}->name,
194                  " object from input ", $val );
195         }
196       } else {
197         # Not sure when this would crop up...
198         croak( "Don't know what to do with input ", $val );
199       }
200     }
201   }
202   if( $need_manual_update == 1 ) {
203     $self->{VALUE}->_set_owner(undef);
204     my $datum = ${$self->{VALUE}->data};
205     $self->{_obj}{_obj}->_update_( $datum,
206                                    $self->{_obj}{_index} );
207     $self->{VALUE}->_set_owner( $self->{_obj}{_obj} );
208     print "    Setting index ", $self->{_obj}{_index}, " for $val\n" if $Debug;
209     $self->{VALUE}->_set_index( $self->{_obj}{_index} );
210     print "      Got index ", $self->{VALUE}->index, "\n" if $Debug;
211   }
212   return $self->{VALUE};
213 }
214
215 sub FETCH {
216   my $self = shift;
217   print "In ", $self->{_obj}{_obj}->name, "'s ", $self->{_obj}{_key}, " field FETCH,\n\tcalled from ", (caller(1))[0..3], "\n" if $Debug;
218   if( defined $self->{VALUE}
219       and $self->{VALUE}->isa('Ctypes::Type::Simple') ) {
220     return ${$self->{VALUE}};
221   }
222   return $self->{VALUE};
223 }
224
225 1;