Many changes
[perl-ctypes:perl-ctypes.git] / lib / Ctypes / Type / Simple.pm
1 package Ctypes::Type::Simple;
2 use strict;
3 use warnings;
4 use Carp;
5 use Ctypes;
6 use Ctypes::Type qw|&_types &allow_overflow_all|;
7 our @ISA = qw|Ctypes::Type|;
8 use fields qw|alignment name _typecode size
9               allow_overflow val _as_param_|;
10 use overload '${}' => \&_scalar_overload,
11              '0+'  => \&_scalar_overload,
12              '""'  => \&_scalar_overload,
13              '&{}' => \&_code_overload,
14              fallback => 'TRUE';
15        # TODO Multiplication will have to be overridden
16        # to implement Python's Array contruction with "type * x"???
17 my $Debug = 0;
18
19 =head1 NAME
20
21 Ctypes::Type::Simple - The atomic C data types
22
23 =head1 INSTANTIATION
24
25 =over
26
27 =item c_X<lt>typeX<gt>(x)
28
29 =back
30
31 The basic Ctypes::Type objects are almost always created with the
32 correspondingly named functions exported by default from Ctypes.
33 All basic types are objects of type Ctypes::Type::Simple. You could
34 call the class constructor directly if you liked, passing a typecode
35 as the first argument followed by any initialisers, but the named
36 functions put in the appropriate typecode for you and are normally
37 more convenient.
38
39 A Ctypes::Type object represents a variable of a certain C type. If
40 uninitialised, the value defaults to zero. You can use uninitialised
41 instances to find out information about the various types (see list of
42 accessor methods below).
43
44 After creation, you can manipulate the value stored in a Type object
45 in any of the following ways:
46
47 =over
48
49 =item $obj->val = 100;
50
51 =item $obj->val(100);
52
53 =item $obj->(100);
54
55 =back
56
57 The actual data which will be passed to C is held in
58 L<packed|perlfunc/"pack"> string form in an internal attribute called
59 C<{_data}>. Note the underscore! The methods above do all the necessary
60 validation of values assigned to the object for you, as well as packing
61 the data into a format C understands. You cannot set C<{_data}> directly
62 (although you can examine it through its accessor should you ever feel
63 like looking at some unintelligible gibberish).
64
65 In addition to the methods provided by Ctypes::Type, Ctypes::Type::Simple
66 objects provide the following extra method.
67
68 =over
69
70 =item allow_overflow
71
72 B<Mutator> setting and/or returning a flag (1 or 0) indicating whether
73 this particular object is allowed to overflow. Defaults to 1, allowing
74 overflowing, as in C, but you'll get a warning about it. Note that even
75 if C<allow_overflow> is set to 1 for a particular object, overflows
76 will be prevented if C<allow_overflow_all> is set to 0. See the
77 L<allow_overflow_all|Ctypes::Type/allow_overflow_all> class method in
78 L<Ctypes::Type>.
79
80 =back
81
82 =cut
83
84
85 sub _num_overload { return shift->{_value}; }
86
87 sub _add_overload {
88   my( $x, $y, $swap ) = @_;
89   my $ret;
90   if( defined($swap) ) {
91     if( !$swap ) { $ret = $x->{_value} + $y; }
92     else { $ret = $y->{_value} + $x; }
93   } else {           # += etc.
94     $x->{_value} = $x->{_value} + $y;
95     $ret = $x;
96   }
97   return $ret;
98 }
99
100 sub _subtract_overload {
101   my( $x, $y, $swap ) = @_;
102   my $ret;
103   if( defined($swap) ) {
104     if( !$swap ) { $ret = $x->{_value} - $y; }
105     else { $ret = $x - $y->{_value}; }
106   } else {           # -= etc.
107     $x->{_value} = $x->{_value} - $y;
108     $ret = $x;
109   }
110   return $ret;
111 }
112
113 sub _scalar_overload {
114   my $self = shift;
115   return \$self->{_value};
116 }
117
118 sub _code_overload {
119   my $self = shift;
120   return sub { $self = @_ }
121 }
122
123 sub new {
124   my $class = ref($_[0]) || $_[0]; shift;
125   my $typecode = shift;
126   my $arg = shift;
127   print "In Type::Simple constructor, typecode [ $typecode ]", $arg ? "arg [ $arg ]" : '', "\n" if $Debug == 1;
128   croak("Ctypes::Type::Simple error: Need typecode!") if not defined $typecode;
129   my $self = $class->SUPER::_new;
130   my $attrs = { 
131     _typecode        => $typecode,
132     _name            => Ctypes::Type::_types()->{$typecode},
133     _allow_overflow  => 1,
134               };
135   for(keys(%{$attrs})) { $self->{$_} = $attrs->{$_}; };
136   bless $self => $class;
137   $self->{_size} = Ctypes::sizeof($typecode);
138   $arg = 0 unless defined $arg;
139   $self->{_rawvalue} = tie $self->{_value}, 'Ctypes::Type::Simple::value', $self;
140   $self->{_value} = $arg;
141   return undef if not defined $self->{_rawvalue}{VALUE};
142   return $self;
143 }
144
145 sub allow_overflow {
146     my $self = shift;
147     my $arg = shift;
148     if( @_  or ( defined $arg and $arg != 1 and $arg != 0 ) ) {
149       croak("Usage: allow_overflow(1 or 0)");
150     }
151     $self->{_allow_overflow} = $arg if defined $arg;
152     $self->{_allow_overflow};
153 }
154
155 sub data { 
156   my $self = shift;
157   print "In ", $self->{_name}, "'s _DATA_, from ", join(", ",(caller(0))[0..3]), "\n" if $Debug == 1;
158   if( defined $self->owner
159       or $self->_datasafe == 0 ) {
160     print "    Can't trust data, updating...\n" if $Debug == 1;
161     $self->_update_;
162   }
163   if( defined $self->{_data}
164       and $self->{_datasafe} == 1 ) {
165     print "    asparam already defined\n" if $Debug == 1;
166     print "    returning ", unpack('b*',$self->{_data}), "\n" if $Debug == 1;
167     return \$self->{_data};
168   }
169   $self->{_data} =
170     pack( $self->{_typecode}, $self->{_rawvalue}{VALUE} );
171   print "    returning ", unpack('b*',$self->{_data}), "\n" if $Debug == 1;
172   $self->{_datasafe} = 0;  # used by FETCH
173   return \$self->{_data};
174 }
175
176 sub _as_param_ { &data(@_) }
177
178 sub _update_ {
179   my( $self, $arg ) = @_;
180   print "In ", $self->{_name}, "'s _UPDATE_...\n" if $Debug == 1;
181   print "    I am pwnd by ", $self->{_owner}->{_name}, "\n" if $self->{_owner} and $Debug == 1;
182   if( not defined $arg ) {
183     if( $self->{_owner} ) {
184       print "    Have owner, getting updated data...\n" if $Debug == 1; 
185       my $owners_data = ${$self->{_owner}->data};
186       print "    Here's where I think I am in my pwner's data:\n" if $Debug == 1;
187       print " " x ($self->{_index} * 8), "v\n" if $Debug == 1;
188       print "12345678" x length($owners_data), "\n" if $Debug == 1;
189       print unpack('b*', $owners_data), "\n" if $Debug == 1;
190       print "    My index is ", $self->{_index}, "\n" if $Debug == 1;
191       $self->{_data} = substr( ${$self->{_owner}->data},
192                                $self->{_index},
193                                $self->{_size} );
194     }
195   } else {
196     $self->{_data} = $arg if $arg;
197     if( $self->owner ) {
198       $self->owner->_update_($self->{_data},$self->{_index});
199     }
200   }
201   $self->{_rawvalue}{VALUE} = unpack($self->{_typecode},$self->{_data});
202   $self->{_datasafe} = 1;
203   return 1; 
204 }
205
206 package Ctypes::Type::Simple::value;
207 use strict;
208 use warnings;
209 use Carp;
210
211 sub TIESCALAR {
212   my $class = shift;
213   my $object = shift;
214   my $self = { object  => $object,
215                VALUE   => undef,
216              };
217   return bless $self => $class;
218 }
219
220 sub STORE {
221   croak("STORE must take a value") if scalar @_ != 2;
222   my $self = shift;
223   my $arg = shift;
224   print "In ", $self->{object}{_name}, "'s STORE with arg [ $arg ],\n" if $Debug == 1;
225   print "    called from ", (caller(1))[0..3], "\n" if $Debug == 1;
226   croak("Simple Types can only be assigned a single value") if @_;
227   # Deal with being assigned other Type objects and the like...
228   if(my $ref = ref($arg)) {
229     if($ref =~ /^Ctypes::Type::/) {
230       $arg = $arg->{_data};
231     } else {
232       if($arg->can("_as_param_")) {
233         $arg = $arg->_as_param_;
234       } elsif($arg->{_data}) {
235         $arg = $arg->{_data};
236       } else {
237   # ??? Would you ever want to store an object/reference as the value
238   # of a type? What would get pack()ed in the end?
239         croak("Ctypes Types can only be made from native types or " . 
240               "Ctypes compatible objects");
241       }
242     }
243   }
244
245   # Object's Value set to undef: {_val} becomes undef, {_data} filled
246   # with null (i.e. numeric zero) , update owners, return early.
247   if( not defined $arg ) {
248     print "    Assigned undef! All goes null!\n" if $Debug == 1;
249     $self->{VALUE} = $arg;
250     $self->{object}{_data} = "\0" x $self->{object}{_size}; # must stay right length!
251     if( $self->{object}{_owner} ) {
252       $self->{object}{_owner}->_update_($self->{object}{_data}, $self->{object}{_index});
253     }
254     return $self->{VALUE};
255   }
256
257   my $typecode = $self->{object}{_typecode};
258   # return 1 on success, 0 on fail, -1 if (numeric but) out of range
259   my $is_valid = Ctypes::_valid_for_type($arg,$typecode);
260   print "    _valid_for_type returned $is_valid\n" if $Debug == 1;
261   if( $is_valid < 1 ) {
262     no strict 'refs';
263     if( ($is_valid == -1)
264         and ( $self->{object}->allow_overflow == 0
265         or Ctypes::Type::allow_overflow_all() == 0 ) ) {
266       carp( "Value out of range for " . $self->{object}{_name} . ": $arg");
267       return undef;
268     } else {
269       my $temp = Ctypes::_cast($arg,$typecode);
270       print "    _cast returned: ", $temp, "\n" if $Debug == 1;
271       if( $temp && Ctypes::_valid_for_type($temp,$typecode) ) {
272         $arg = $temp;
273       } else {
274         carp("Unreconcilable argument for type " . $self->{object}{_name} .
275               ": $arg");
276         return undef;
277       }
278     }
279   }
280   $self->{VALUE} = $arg;
281   $self->{object}{_data} =
282     pack( $self->{object}{_typecode}, $arg );
283   if( $self->{object}{_owner} ) {
284     print "    Have owner, updating...\n" if $Debug == 1;
285     $self->{object}{_owner}->_update_($self->{object}{_data}, $self->{object}{_index});
286   }
287   print "  Returning ok...\n" if $Debug == 1;
288   return $self->{VALUE};
289 }
290
291 sub FETCH {
292   my $self = shift;
293   print "In ", $self->{object}{_name}, "'s FETCH, from ", (caller(1))[0..3], "\n" if $Debug == 1;
294   if ( defined $self->{object}{_owner}
295        or $self->{object}{_datasafe} == 0 ) {
296     print "    Can't trust data, updating...\n" if $Debug == 1;
297     $self->{object}->_update_;
298   }
299   croak("Error updating value!") if $self->{object}{_datasafe} != 1;
300   print "    ", $self->{object}->name, "'s Fetch returning ", $self->{VALUE}, "\n" if $Debug == 1;
301   return $self->{VALUE};
302 }
303
304 1;
305 __END__