Completed update of data ownership chaining
[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 Data::Dumper;
7 use overload
8   '+'      => \&_add_overload,
9   '-'      => \&_substract_overload,
10   '${}'    => \&_scalar_overload,
11   '@{}'    => \&_array_overload,
12   fallback => 'TRUE';
13
14 our @ISA = qw|Ctypes::Type|;
15 my $Debug = 0;
16
17 =head1 NAME
18
19 Ctypes::Type::Pointer - What's that over there?
20
21 =head1 SYNOPSIS
22
23   (see t/Pointer.t for now)
24
25 =cut
26
27 ############################################
28 # TYPE::POINTER : PRIVATE FUNCTIONS & DATA #
29 ############################################
30
31 sub _add_overload {
32   my( $x, $y, $swap ) = @_;
33   my $ret;
34   if( defined($swap) ) {
35     if( !$swap ) { $ret = $x->{offset} + $y; }
36     else { $ret = $y->{offset} + $x; }
37   } else {           # += etc.
38     $x->{offset} = $x->{offset} + $y;
39     $ret = $x;
40   }
41   return $ret;
42 }
43
44 sub _array_overload {
45   print ". . .._wearemany_.. . .\n" if $Debug == 1;
46   return shift->{bytes};
47 }
48
49 sub _scalar_overload {
50   print "We are One ^_^\n" if $Debug == 1;
51   return \shift->{contents}; 
52 }
53
54 sub _subtract_overload {
55   my( $x, $y, $swap ) = @_;
56   my $ret;
57   if( defined($swap) ) {
58     if( !$swap ) { $ret = $x->{offset} - $y; }
59     else { $ret = $x - $y->{offset}; }
60   } else {           # -= etc.
61     $x->{offset} -= $y;
62     $ret = $x;
63   }
64   return $ret;
65 }
66
67 ############################################
68 # TYPE::POINTER : PUBLIC FUNCTIONS & DATA  #
69 ############################################
70
71 sub new {
72   my $class = ref($_[0]) || $_[0]; shift;
73   my( $type, $contents );
74 #  return undef unless defined($contents);  # No null pointers plz :)
75
76   if( scalar @_ == 1 ) {
77     $type = $contents = shift;
78   } elsif( scalar @_ > 1 ) {
79     $type = shift;
80     $contents = shift;
81   }
82
83   carp("Useage: Pointer( [type, ] \$object )") if @_;
84
85   return undef unless Ctypes::is_ctypes_compat($contents);
86
87   $type = $type->_typecode_ if ref($type);
88   if( not Ctypes::sizeof($type) ) {
89     carp("Invalid Array type specified (first position argument)");
90     return undef;
91   }
92   my $self = $class->SUPER::_new;
93   my $attrs = {
94      name        => $type.'_Pointer',
95      size        => Ctypes::sizeof('p'),
96      offset      => 0,
97      contents    => $contents,
98      bytes       => undef,
99      orig_type   => $type,
100      _typecode_  => 'p',
101                };
102   for(keys(%{$attrs})) { $self->{$_} = $attrs->{$_}; };
103   bless $self => $class;
104
105   $self->{_rawcontents} =
106     tie $self->{contents}, 'Ctypes::Type::Pointer::contents', $self;
107   $self->{_rawbytes} =
108     tie @{$self->{bytes}},
109           'Ctypes::Type::Pointer::bytes',
110           $self;
111   $self->{contents} = $contents;
112   return $self;
113 }
114
115 sub deref () : method {
116   return ${shift->{contents}};
117 }
118
119 sub _as_param_ {
120   my $self = shift;
121   print "In ", $self->{name}, "'s _As_param_, from ", join(", ",(caller(1))[0..3]), "\n" if $Debug == 1;
122   if( defined $self->{_data} 
123       and $self->{_datasafe} == 1 ) {
124     print "already have _as_param_:\n" if $Debug == 1;
125     print "  ", $self->{_data}, "\n" if $Debug == 1;
126     print "   ", unpack('b*', $self->{_data}), "\n" if $Debug == 1;
127     return \$self->{_data} 
128   }
129 # Can't use $self->{contents} as FETCH will bork at _datasafe
130 # use $self->{_raw}{DATA} instead
131   $self->{_data} =
132     ${$self->{_rawcontents}{DATA}->_as_param_};
133   print "  ", $self->{name}, "'s _as_param_ returning ok...\n" if $Debug == 1;
134   $self->{_datasafe} = 0;  # used by FETCH
135   return \$self->{_data};
136 }
137
138 sub _update_ {
139   my( $self, $arg ) = @_;
140   print "In ", $self->{name}, "'s _UPDATE_, from ", join(", ",(caller(0))[0..3]), "\n" if $Debug == 1;
141   print "  self is ", $self, "\n" if $Debug == 1;
142   print "  arg is $arg\n" if $Debug == 1;
143   print "  which is\n", unpack('b*',$arg), "\n  to you and me\n" if $Debug == 1;
144   $arg = $self->{_data} unless $arg;
145
146   my $success = $self->{_rawcontents}{DATA}->_update_($arg);
147   if(!$success) {
148     croak($self->{name}, ": Error updating contents!");
149   }
150
151 #  $self->{_data} = $self->_as_param_;
152   $self->{_datasafe} = 1;
153   return 1;
154 }
155
156 #
157 # Accessor generation
158 #
159 my %access = (
160   _typecode_        => ['_typecode_'],
161   name              => ['name'],
162   size              => ['size'],
163   contents          => ['contents'],
164   type              => ['orig_type'],
165   offset            => ['offset',undef,1],
166              );
167 for my $func (keys(%access)) {
168   no strict 'refs';
169   my $key = $access{$func}[0];
170   *$func = sub {
171     my $self = shift;
172     my $arg = shift;
173     croak("The $key method only takes one argument") if @_;
174     if($access{$func}[1] and defined($arg)){
175       eval{ $access{$func}[1]->($arg); };
176       if( $@ ) {
177         croak("Invalid argument for $key method: $@");
178       }
179     }
180     if($access{$func}[2] and defined($arg)) {
181       $self->{$key} = $arg if $arg;
182     }
183     return $self->{$key};
184   }
185 }
186
187 package Ctypes::Type::Pointer::contents;
188 use warnings;
189 use strict;
190 use Carp;
191 use Ctypes;
192
193 sub TIESCALAR {
194   my $class = shift;
195   my $owner = shift;
196   my $self = { owner => $owner,
197                DATA  => undef,
198              };
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 "insert 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;