Handle numeric casting of utf8 chars
[perl-ctypes:shlomifs-perl-ctypes.git] / lib / Ctypes / Type.pm
1 package Ctypes::Type;
2 # always loaded and all c types are exported.
3
4 use strict;
5 use warnings;
6 use Carp;
7 use Ctypes;
8 require Exporter;
9 our @ISA = ("Exporter");
10 use constant USE_PERLTYPES => 1; # so far use only perl pack-style types, 
11                                  # not the full python ctypes types
12
13 our @EXPORT_OK = qw|&_types|;
14
15 our $_perltypes = 
16
17   v =>  "c_void",
18   c =>  "c_byte",
19   C =>  "c_char",
20   s =>  "c_short",
21   S =>  "c_ushort",
22   i =>  "c_int",
23   I =>  "c_uint",
24   l =>  "c_long",
25   L =>  "c_ulong",
26   f =>  "c_float",
27   d =>  "c_double",
28   D =>  "c_longdouble",
29   p =>  "c_void_p",
30 };
31
32 our $_pytypes = 
33
34   s =>  "c_char_p",
35   c =>  "c_char",
36   b =>  "c_byte",
37   B =>  "c_ubyte",
38   C =>  "c_uchar",
39   h =>  "c_short",
40   H =>  "c_ushort",
41   i =>  "c_int",
42   I =>  "c_uint",
43   l =>  "c_long",
44   L =>  "c_ulong",
45   f =>  "c_float",
46   d =>  "c_double",
47   g =>  "c_longdouble",
48   q =>  "c_longlong",
49   Q =>  "c_ulonglong",
50   P =>  "c_void_p",
51   u =>  "c_wchar_p",
52   U =>  "c_char_p",
53   Z =>  "c_wchar_p",
54   X =>  "c_bstr",
55   v =>  "c_bool",
56   O =>  "c_void_p",
57 };
58 our $_types = USE_PERLTYPES ? $_perltypes : $_pytypes;
59 sub _types () { return $_types; }
60 our $allow_overflow_all = 0;
61
62 # http://docs.python.org/library/ctypes.html
63 # #ctypes-fundamental-data-types-2:
64 # Fundamental data types, when returned as foreign function call
65 # results, or, for example, by retrieving structure field members
66 # or array items, are transparently converted to native Python types.
67 # In other words, if a foreign function has a restype of c_char_p,
68 # you will always receive a Python string, not a c_char_p instance.
69
70 # Subclasses of fundamental data types do not inherit this behavior.
71 # So, if a foreign functions restype is a subclass of c_void_p, you
72 # will receive an instance of this subclass from the function call.
73 # Of course, you can get the value of the pointer by accessing the
74 # value attribute.
75
76 package Ctypes::Type::Simple::value;
77 use strict;
78 use warnings;
79 use Carp;
80
81 my $owner;
82
83 sub protect ($) {
84   ref shift or return undef;
85   my($cpack, $cfile, $cline, $csub) = caller(0);
86   if( $cpack ne __PACKAGE__ 
87       or $cfile ne __FILE__ ) {
88     return undef;
89   }
90   return 1;
91 }
92  
93 sub TIESCALAR {
94   my $class = shift;
95   $owner = shift;
96   return bless \my $self => $class;
97 }
98
99 sub STORE {
100   my $self = shift;
101   protect $self
102     or carp("Unauthorised access of val attribute") && return undef;
103   my $arg = shift;
104   # Deal with being assigned other Type objects and the like...
105   if(my $ref = ref($arg)) {
106     if($ref =~ /^Ctypes::Type::/) {
107       $arg = $arg->{_as_param_};
108     } else {
109       if($arg->can("_as_param_")) {
110         $arg = $arg->_as_param_;
111       } elsif($arg->{_as_param_}) {
112         $arg = $arg->{_as_param_};
113       } else {
114   # ??? Would you ever want to store an object/reference as the value
115   # of a type? What would get pack()ed in the end?
116         croak("Can only store native types or Ctypes compatible objects");
117       }
118     }
119   }
120   my $typecode = $owner->{_typecode_};
121   croak("Simple Types can only be assigned a single value") if @_;
122   # return 1 on success, 0 on fail, -1 if (numeric but) out of range
123   my $is_valid = Ctypes::_valid_for_type($arg,$typecode);
124   if( $is_valid < 1 ) {
125     no strict 'refs';
126     if( ($is_valid == -1)
127         and not ( $owner->allow_overflow
128         || $owner->allow_overflow_class
129         || $Ctypes::Type::allow_overflow_all ) ) {
130       croak( "Value out of range for " . $owner->{name} . ": $arg");
131     } else {
132       my $temp = Ctypes::_cast($arg,$typecode);
133       if( $temp && Ctypes::_valid_for_type($temp,$typecode) ) {
134         if( $is_valid == -1 ) {
135           carp("Argument $arg overflows for type " . $owner->{name}
136                 . ". Value now " . $temp );
137         }
138         $arg = $temp;
139       } else {
140         croak("Unreconcilable argument for type '$typecode': $arg");
141       }
142     }
143   }
144   $owner->{_as_param_} = pack( $typecode, $arg );
145   $$self = $arg;
146   return $$self;
147 }
148
149 sub FETCH {
150   my $self = shift;
151   return $$self;
152 }
153
154
155 package Ctypes::Type::Simple;
156 use strict;
157 use warnings;
158 use Ctypes;
159 use Carp;
160 our @ISA = qw|Ctypes::Type|;
161 use fields qw|alignment name _typecode_ size
162               allow_overflow val _as_param_|;
163 use overload '0+'  => \&_num_overload,
164              '+'   => \&_add_overload,
165              '-'   => \&_subtract_overload,
166              '&{}' => \&_code_overload,
167              '%{}' => \&_hash_overload,
168              fallback => 'TRUE';
169              # TODO Multiplication will have to be overridden
170              # to implement Python's Array contruction with "type * x"???
171
172 {
173   my $allow_overflow_class = 1;
174   sub allow_overflow_class {
175 # ??? This could be improved; could still be called as a class method
176 # with an object instead of a 1 or 0 and user would not be notified
177     my $self = shift if ref($_[0]);
178     my $arg = shift;
179     if( @_ or ( defined($arg) and $arg != 1 and $arg != 0 ) ) {
180       croak("Usage: allow_overflow_class(x) (1 or 0)");
181     }
182     $allow_overflow_class = $arg if $arg;
183     return $allow_overflow_class;
184   }
185 }
186
187 sub _num_overload { return shift->{val}; }
188
189 sub _add_overload {
190   my( $x, $y, $swap ) = @_;
191   my $ret;
192   if( defined($swap) ) {
193     if( !$swap ) { $ret = $x->{val} + $y; }
194     else { $ret = $y->{val} + $x; }
195   } else {           # += etc.
196     $x->val($x->{val} + $y);
197     $ret = $x;
198   }
199   return $ret;
200 }
201
202 sub _subtract_overload {
203   my( $x, $y, $swap ) = @_;
204   my $ret;
205   if( defined($swap) ) {
206     if( !$swap ) { $ret = $x->{val} - $y; }
207     else { $ret = $x - $y->{val}; }
208   } else {           # -= etc.
209     $x->val($x->{val} - $y);
210     $ret = $x;
211   }
212   return $ret;
213 }
214
215 sub _hash_overload {
216   my($cpack, $cfile) = caller(0);
217   if( $cpack !~ /^Ctypes/
218       or $cfile !~ /Ctypes\// ) {
219     carp("Unauthorized direct Type attribute access!");
220     return {};
221   }
222   return shift;
223 }
224
225 sub _code_overload { 
226   my $self = shift;
227   return sub { val($self, @_) };
228 }
229
230 sub new {
231   my $class = shift;
232   my $typecode = shift;
233   my $arg = shift;
234   my $self = { _as_param_      => '',
235                _typecode_      => $typecode,
236                val             => 0,
237                address         => undef,
238                name            => $_types->{$typecode},
239                size            => 0,
240                alignment       => 0,
241                allow_overflow  => 0,
242              };
243   bless $self => $class;
244   $self->{size} = Ctypes::sizeof($self->{_typecode_});
245   $arg = 0 unless $arg;
246   tie $self->{val}, "Ctypes::Type::Simple::value", $self;
247   $self->{val} = $arg;
248 # XXX Unimplemented! Must come after setting val;
249 #  $self->{address} = Ctypes::addressof($self);
250   return $self;
251 }
252
253 # val can't go in the loop below simply because
254 # it's an lvalue. To make them all lvalue would
255 # require more tie'ing for validity checks.
256 sub val : lvalue {
257   my $self = shift;
258   my $arg = shift;
259   $self->{val} = $arg if $arg;
260   $self->{val};
261 }
262
263 #
264 # Accessor generation
265 #
266 my %access = ( 
267   _data             => ['_as_param_',undef],
268   typecode          => ['_typecode_',\&Ctypes::sizeof],
269   allow_overflow =>
270     [ 'allow_overflow',
271       sub {if( $_[0] != 1 and $_[0] != 0){return 0;}else{return 1;} } ],
272   alignment         => ['alignment',undef],
273   name              => ['name',undef],
274 # Users ~could~ modify size, but only of they delight in the meaningless.
275   size              => ['size',undef],
276              );
277 for my $func (keys(%access)) {
278   no strict 'refs';
279   my $key = $access{$func}[0];
280   *$func = sub {
281     my $self = shift;
282     my $arg = shift;
283     croak("The $key method only takes one argument") if @_;
284     if($access{$func}[1] and defined($arg)){
285       eval{ $access{$func}[1]->($arg); };
286       if( $@ ) {
287         croak("Invalid argument for $key method: $@");
288       }
289     }
290     $self->{$key} = $arg if $arg;
291     $self->{$key};
292   }
293 }
294
295
296 package Ctypes::Type;
297
298 =head1 METHODS
299
300 =over
301
302 =item new Ctypes::Type (type-code, c_type-name) 
303
304 Create a simple Ctypes::Type instance. This is almost always 
305 called by the global c_X<lt>typeX<gt> functions.
306
307 A Ctypes::Type object holds information about simple and aggregate types, 
308 i.e. unions and structs, but also about actual external values, e.g. 
309 function arguments and return values.
310
311 Each type is defined as function returning a c_type object.
312
313 Each c_type object holds the type-code char, the c name, the size, 
314 the alignment and the address if used.
315
316 =cut
317
318 #
319 # Create global c_<type> functions...
320 #
321 my %_defined;
322 for my $k (keys %$_types) {
323   my $name = $_types->{$k};
324   my $func;
325   unless ($_defined{$name}) {
326     no strict 'refs';
327     $func = sub { Ctypes::Type::Simple->new($k, @_); };
328     *{"Ctypes::$name"} = $func;
329     $_defined{$name} = 1;
330   }
331 }
332 our @_allnames = keys %_defined;
333
334 package Ctypes::Type::Array;
335 use strict;
336 use warnings;
337 use Ctypes;  # which uses Ctypes::Type?
338
339 sub new {
340   my $class = shift;
341   return undef unless $_[0]; # TODO: Uninitialised Arrays? Why??
342   my $in = Ctypes::_make_arrayref(@_);
343 }
344
345 package Ctypes::Type::Field;
346 use Ctypes::Type;
347 our @ISA = qw(Ctypes::Type);
348
349 package Ctypes::Type::Union;
350 use Ctypes::Type;
351 our @ISA = qw(Ctypes::Type);
352
353 sub new {
354   my ($class, $fields) = @_;
355   my $size = 0;
356   for (@$fields) {
357     # XXX convert fields to ctypes
358     my $fsize = $_->{size}; 
359     $size = $fsize if $fsize > $size;
360     # TODO: align!!
361   }
362   return bless { fields => $fields, size => $size, address => 0 }, $class;
363 }
364
365 package Ctypes::Type::Struct;
366 use Ctypes::Type;
367 our @ISA = qw(Ctypes::Type);
368
369 sub new {
370   my ($class, $fields) = @_;
371   my $size = 0;
372   for (@$fields) { # arrayref of ctypes, or just arrayref of paramtypes
373     # XXX convert fields to ctypes
374     my $fsize = $_->{size};
375     $size += $fsize;
376     # TODO: align!!
377   }
378   return bless { fields => $fields, size => $size, address => 0 }, $class;
379 }
380
381 =back
382 =cut
383 1;