Many changes
[perl-ctypes:shlomifs-perl-ctypes.git] / lib / Ctypes / Type / Pointer.pm
1 package Ctypes::Type::Pointer;
2 use strict;
3 use warnings;
4 use Carp;
5 use Ctypes;
6 use overload
7   '+'      => \&_add_overload,
8   '-'      => \&_substract_overload,
9   '${}'    => \&_scalar_overload,
10   '@{}'    => \&_array_overload,
11   fallback => 'TRUE';
12
13 our @ISA = qw|Ctypes::Type|;
14 my $Debug = 0;
15
16 =head1 NAME
17
18 Ctypes::Type::Pointer - What's that over there?
19
20 =head1 SYNOPSIS
21
22   (see t/Pointer.t for now)
23
24 =cut
25
26 ############################################
27 # TYPE::POINTER : PRIVATE FUNCTIONS & DATA #
28 ############################################
29
30 sub _add_overload {
31   my( $x, $y, $swap ) = @_;
32   my $ret;
33   if( defined($swap) ) {
34     if( !$swap ) { $ret = $x->{_offset} + $y; }
35     else { $ret = $y->{_offset} + $x; }
36   } else {           # += etc.
37     $x->{_offset} = $x->{_offset} + $y;
38     $ret = $x;
39   }
40   return $ret;
41 }
42
43 sub _array_overload {
44   print ". . .._wearemany_.. . .\n" if $Debug == 1;
45   return shift->{_bytes};
46 }
47
48 sub _scalar_overload {
49   print "We are One ^_^\n" if $Debug == 1;
50   return \shift->{_contents}; 
51 }
52
53 sub _subtract_overload {
54   my( $x, $y, $swap ) = @_;
55   my $ret;
56   if( defined($swap) ) {
57     if( !$swap ) { $ret = $x->{_offset} - $y; }
58     else { $ret = $x - $y->{_offset}; }
59   } else {           # -= etc.
60     $x->{_offset} -= $y;
61     $ret = $x;
62   }
63   return $ret;
64 }
65
66 ############################################
67 # TYPE::POINTER : PUBLIC FUNCTIONS & DATA  #
68 ############################################
69
70 sub new {
71   my $class = ref($_[0]) || $_[0]; shift;
72   my( $type, $contents );
73 #  return undef unless defined($contents);  # No null pointers plz :)
74
75   if( scalar @_ == 1 ) {
76     $type = $contents = shift;
77   } elsif( scalar @_ > 1 ) {
78     $type = shift;
79     $contents = shift;
80   }
81
82   carp("Useage: Pointer( [type, ] \$object )") if @_;
83
84   return undef unless Ctypes::is_ctypes_compat($contents);
85
86   $type = $type->typecode if ref($type);
87   if( not Ctypes::sizeof($type) ) {
88     carp("Invalid Array type specified (first position argument)");
89     return undef;
90   }
91   my $self = $class->SUPER::_new;
92   my $attrs = {
93      _name        => $type.'_Pointer',
94      _size        => Ctypes::sizeof('p'),
95      _offset      => 0,
96      _contents    => $contents,
97      _bytes       => undef,
98      _orig_type   => $type,
99      _typecode  => 'p',
100                };
101   for(keys(%{$attrs})) { $self->{$_} = $attrs->{$_}; };
102   bless $self => $class;
103
104   $self->{_rawcontents} =
105     tie $self->{_contents}, 'Ctypes::Type::Pointer::contents', $self;
106   $self->{_rawbytes} =
107     tie @{$self->{_bytes}},
108           'Ctypes::Type::Pointer::bytes',
109           $self;
110   $self->{_contents} = $contents;
111   return $self;
112 }
113
114 sub deref () : method {
115   return ${shift->{_contents}};
116 }
117
118 sub data { &_as_param_(@_) }
119
120 sub _as_param_ {
121   my $self = shift;
122   print "In ", $self->{_name}, "'s _As_param_, from ", join(", ",(caller(1))[0..3]), "\n" if $Debug == 1;
123   if( defined $self->{_data} 
124       and $self->{_datasafe} == 1 ) {
125     print "already have _as_param_:\n" if $Debug == 1;
126     print "  ", $self->{_data}, "\n" if $Debug == 1;
127     print "   ", unpack('b*', $self->{_data}), "\n" if $Debug == 1;
128     return \$self->{_data} 
129   }
130 # Can't use $self->{_contents} as FETCH will bork at _datasafe
131 # use $self->{_raw}{DATA} instead
132   $self->{_data} =
133     ${$self->{_rawcontents}{DATA}->_as_param_};
134   print "  ", $self->{_name}, "'s _as_param_ returning ok...\n" if $Debug == 1;
135   $self->{_datasafe} = 0;  # used by FETCH
136   return \$self->{_data};
137 }
138
139 sub _update_ {
140   my( $self, $arg ) = @_;
141   print "In ", $self->{_name}, "'s _UPDATE_, from ", join(", ",(caller(0))[0..3]), "\n" if $Debug == 1;
142   print "  self is ", $self, "\n" if $Debug == 1;
143   print "  arg is $arg\n" if $Debug == 1;
144   print "  which is\n", unpack('b*',$arg), "\n  to you and me\n" if $Debug == 1;
145   $arg = $self->{_data} unless $arg;
146
147   my $success = $self->{_rawcontents}{DATA}->_update_($arg);
148   if(!$success) {
149     croak($self->{_name}, ": Error updating contents!");
150   }
151
152 #  $self->{_data} = $self->_as_param_;
153   $self->{_datasafe} = 1;
154   return 1;
155 }
156
157 #
158 # Accessor generation
159 #
160 my %access = (
161   contents          => ['_contents'],
162   type              => ['_orig_type'],
163   offset            => ['_offset',undef,1],
164              );
165 for my $func (keys(%access)) {
166   no strict 'refs';
167   my $key = $access{$func}[0];
168   *$func = sub {
169     my $self = shift;
170     my $arg = shift;
171     croak("The $key method only takes one argument") if @_;
172     if($access{$func}[1] and defined($arg)){
173       eval{ $access{$func}[1]->($arg); };
174       if( $@ ) {
175         croak("Invalid argument for $key method: $@");
176       }
177     }
178     if($access{$func}[2] and defined($arg)) {
179       $self->{$key} = $arg if $arg;
180     }
181     return $self->{$key};
182   }
183 }
184
185 package Ctypes::Type::Pointer::contents;
186 use warnings;
187 use strict;
188 use Carp;
189 use Ctypes;
190
191 sub TIESCALAR {
192   print "In Bytes' TIESCALAR\n" if $Debug == 1;
193   my $class = shift;
194   my $owner = shift;
195   my $self = { _owner => $owner,
196                DATA  => undef,
197              };
198   print "    my owner is ", $self->{_owner}{_name}, "\n" if $Debug == 1;
199   return bless $self => $class;
200 }
201
202 sub STORE {
203   my( $self, $arg ) = @_;
204   print "In ", $self->{_owner}{_name}, "'s content STORE, from ", (caller(1))[0..3], "\n" if $Debug == 1;
205   if( not Ctypes::is_ctypes_compat($arg) ) {                              
206     if ( $arg =~ /^\d*$/ ) {                                              
207 croak("Cannot make Pointer to plain scalar; did you mean to say '\$ptr++'?")
208     }                                                                     
209   croak("Pointers are to Ctypes compatible objects only")                 
210   }          
211   $self->{_owner}{_data} = undef;
212   $self->{_owner}{_offset} = 0; # makes sense to reset offset
213   print "  ", $self->{_owner}{_name}, "'s content STORE returning ok...\n" if $Debug == 1;
214   return $self->{DATA} = $arg;
215 }
216
217 sub FETCH {
218   my $self = shift;
219   print "In ", $self->{_owner}{_name}, "'s content FETCH, from ", (caller(1))[0..3], "\n" if $Debug == 1;
220   if( defined $self->{_owner}{_data}
221       and $self->{_owner}{_datasafe} == 0 ) {
222     print "    Woop... _as_param_ is ", unpack('b*',$self->{_owner}{_data}),"\n" if $Debug == 1;
223     my $success = $self->{_owner}->_update_(${$self->{_owner}->_as_param_});
224     croak($self->{_name},": Could not update contents!") if not $success;
225   }
226   croak("Error! Data not safe!") if $self->{_owner}{_datasafe} != 1;
227   print "  ", $self->{_owner}{_name}, "'s content FETCH returning ok...\n" if $Debug == 1;
228   print "  Returning ", ${$self->{DATA}}, "\n" if $Debug == 1;
229   return $self->{DATA};
230 }
231
232 package Ctypes::Type::Pointer::bytes;
233 use warnings;
234 use strict;
235 use Carp;
236 use Ctypes;
237
238 sub TIEARRAY {
239   my $class = shift;
240   my $owner = shift;
241   my $self = { _owner => $owner,
242                DATA  => [],
243              };
244   return bless $self => $class;
245 }
246
247 sub STORE {
248   my( $self, $index, $arg ) = @_;
249   print "In ", $self->{_owner}{_name}, "'s Bytes STORE, from ", (caller(0))[0..3], "\n" if $Debug == 1;
250   if( ref($arg) ) {
251     carp("Only store simple scalar data through subscripted Pointers");
252     return undef;
253   }
254
255   my $data = $self->{_owner}{_contents}->_as_param_;
256   print "\tdata is $$data\n" if $Debug == 1;
257   my $each = Ctypes::sizeof($self->{_owner}{_orig_type});
258
259   my $offset = $index + $self->{_owner}{_offset};
260   if( $offset < 0 ) {
261     carp("Pointer cannot store before start of data");
262     return undef;
263   }
264   if( $offset >= length($$data)                  # start at end of data
265       or ($offset + $each) > length($$data) ) {  # or will go past it
266     carp("Pointer cannot store past end of data");
267   }
268
269   print "\teach is $each\n" if $Debug == 1;
270   print "\tdata length is ", length($$data), "\n" if $Debug == 1;
271   my $insert = pack($self->{_owner}{_orig_type},$arg);
272   print "\tinsert is ", unpack('b*',$insert), "\n" if $Debug == 1;
273   if( length($insert) != Ctypes::sizeof($self->{_owner}{_orig_type}) ) {
274     carp("You're about to break something...");
275 # ??? What would be useful feedback here? Aside from just not doing it..
276   }
277   print "\tdata before and after insert:\n" if $Debug == 1;
278   print unpack('b*',$$data), "\n" if $Debug == 1;
279   substr( $$data,
280           $each * $offset,
281           Ctypes::sizeof($self->{_owner}{_orig_type}),
282         ) =  $insert;
283   print unpack('b*',$$data), "\n" if $Debug == 1;
284   $self->{DATA}[$index] = $insert;  # don't think this can be used
285   $self->{_owner}{_contents}->_update_($$data);
286   print "  ", $self->{_owner}{_name}, "'s Bytes STORE returning ok...\n" if $Debug == 1;
287   return $insert;
288 }
289
290 sub FETCH {
291   my( $self, $index ) = @_;
292   print "In ", $self->{_owner}{_name}, "'s Bytes FETCH, from ", (caller(1))[0..3], "\n" if $Debug == 1;
293
294   my $type = $self->{_owner}{_orig_type};
295   if( $type =~ /[pv]/ ) {
296     carp("Pointer is to type ", $type,
297          "; can't know how to dereference data");
298     return undef;
299   }
300
301   my $data = $self->{_owner}{_contents}->_as_param_;
302   print "\tdata is $$data\n" if $Debug == 1;
303   my $each = Ctypes::sizeof($self->{_owner}{_orig_type});
304
305   my $offset = $index + $self->{_owner}{_offset};
306   if( $offset < 0 ) {
307     carp("Pointer cannot look back past start of data");
308     return undef;
309   }
310   my $start = $offset * $each;
311   # 1-byte types can start on last byte and be fine
312   if( $start + ($each - 1) > length($$data) ) {
313     carp("Pointer cannot look past end of data");
314     return undef;
315   }
316
317   print "\toffset is $offset\n" if $Debug == 1;
318   print "\teach is $each\n" if $Debug == 1;
319   print "\tstart is $start\n" if $Debug == 1;
320   print "\torig_type: ", $self->{_owner}{_orig_type}, "\n" if $Debug == 1;
321   print "\tdata length is ", length($$data), "\n" if $Debug == 1;
322   my $chunk = substr( $$data,
323                       $each * $offset,
324                       Ctypes::sizeof($self->{_owner}{_orig_type})
325                     );
326   print "\tchunk: ", unpack('b*',$chunk), "\n" if $Debug == 1;
327   $self->{DATA}[$index] = $chunk;
328   print "  ", $self->{_owner}{_name}, "'s Bytes FETCH returning ok...\n" if $Debug == 1;
329   return unpack($self->{_owner}{_orig_type},$chunk);
330 }
331
332 sub FETCHSIZE {
333   my $data = $_[0]->{_owner}{_contents}{_data}
334   ? $_[0]->{_owner}{_contents}{_data}
335   : $_[0]->{_owner}{_contents}->_as_param_;
336   return length($data) / Ctypes::sizeof($_[0]->{_owner}{_orig_type});
337 }
338
339 1;