Updating Pointer pod
[perl-ctypes: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;
15
16 =head1 NAME
17
18 Ctypes::Type::Pointer - What's that over there?
19
20 =head1 SYNOPSIS
21
22     use Ctypes;
23
24     my $int = c_int(5);
25     print $$int;                   #   5
26
27     my $ptr = Pointer( $int );
28     print $$ptr;                   #   SCALAR(0x9b3ba30)
29     print $$ptr[0];                #   5
30
31     $$ptr[0] = 10;
32     print $$int;                   #   10
33
34 =head1 ABSTRACT
35
36 This class emulates C pointers. Or rather, pointers to other
37 Ctypes objects (there's no raw memory manipulation going on here).
38
39 =head1 DESCRIPTION
40
41 In the current implementation, Pointer objects are the only Ctypes
42 type which come close to dealing with raw memory. For most types,
43 which simply represent a value, that value can be normally be cached
44 as a Perl scalar up until the point it is required by a C library
45 function. However, in order to emulate pointer arithmetic, Pointer
46 objects have to access the raw data fields of the Ctypes objects
47 to which they point whenever they are dereferenced.
48
49 This needn't happen on all occasions though. Since Ctypes types are
50 both 'object' and 'value', and it would be nice to use Pointers to
51 access both, Pointer objects can be 'dereferenced' in two different
52 ways.
53
54 =head3 Pointer as alias
55
56 When you wish to use a Pointer as a straight-forward alias to another
57 Ctypes Type object, you can use B<scalar dereferencing> of the
58 Pointer object, or the C<contents> object method.
59
60   my $int = c_int(10);
61   my $ptr = Pointer( $int );
62
63   print $ptr;             # SCALAR(0xb1ab1aa), the Pointer object
64   print $$prt;            # SCALAR(0xf00f000), the c_int object
65   print $ptr->contents;   # the c_int object again
66
67 This means that to use the C<c_int> object via the Pointer, you
68 can add (yet) another dollar-sign to perform dereferencing on the
69 returned C<c_int> object:
70
71   print $$$ptr;           # 10
72   $$$ptr = 25;
73   print $$int;            # 25
74
75 It might be helpful to remember what each sigil is doing what here:
76
77                       $$$ptr;
78                       ^^^
79                      / | \
80                     /  |  Sigil for the Pointer object
81   Dereferencing the    |
82   returned c_int, to  Scalar dereferncing of the
83   return the value    Pointer object, returning the
84                       c_int object
85
86 =head3 Pointer to data
87
88 The other way of using Pointer objects is in contexts of 'pointer
89 arithmetic', using them to index to arbitrary memory locations.
90 Due to Ctypes' current implementation (mainly Perl, as opposed
91 to mainly C), there is a limit to the arbitrariness of these
92 memory locations. You can use Pointers to access locations within
93 the C<data> fields of Ctypes objects, but you can't stray out
94 into uncharted memory. This has its advantages and disadvantages.
95 In any case, the situation would likely change should Ctypes move
96 to a mainly C implementation.
97
98 You access memory with Pointers using B<array dereferencing>.
99 If the type of the pointer is the same as the type of the object
100 you it's currently pointing to, C<$$ptr[0]> will return the value
101 held by the object. If the Pointer type and the object type
102 are different, then strange, hard to predict, but potentially
103 very useful things can happen. See below under the C<new> method
104 for an example.
105
106 =cut
107
108 ############################################
109 # TYPE::POINTER : PRIVATE FUNCTIONS & DATA #
110 ############################################
111
112 sub _add_overload {
113   my( $x, $y, $swap ) = @_;
114   my $ret;
115   if( defined($swap) ) {
116     if( !$swap ) { $ret = $x->{_offset} + $y; }
117     else { $ret = $y->{_offset} + $x; }
118   } else {           # += etc.
119     $x->{_offset} = $x->{_offset} + $y;
120     $ret = $x;
121   }
122   return $ret;
123 }
124
125 sub _array_overload {
126   print ". . .._wearemany_.. . .\n" if $Debug;
127   return shift->{_bytes};
128 }
129
130 sub _scalar_overload {
131   print "We are One ^_^\n" if $Debug;
132   return \shift->{_contents};
133 }
134
135 sub _subtract_overload {
136   my( $x, $y, $swap ) = @_;
137   my $ret;
138   if( defined($swap) ) {
139     if( !$swap ) { $ret = $x->{_offset} - $y; }
140     else { $ret = $x - $y->{_offset}; }
141   } else {           # -= etc.
142     $x->{_offset} -= $y;
143     $ret = $x;
144   }
145   return $ret;
146 }
147
148 ############################################
149 # TYPE::POINTER : PUBLIC FUNCTIONS & DATA  #
150 ############################################
151
152 =head1 METHODS
153
154 Ctypes::Type::Pointer provides the following methods.
155
156 =over
157
158 =item new OBJECT
159
160 =item new CTYPE, OBJECT
161
162 Like with Arrays and Structs, you'll rarely use Ctypes::Type::Pointer->new
163 directly since L<Ctypes> exports the C<Pointer> function by default.
164
165 Pointers can be instantiated in two ways. First, you can pass a Ctypes
166 object to which you want to create a pointer. The Pointer will be
167 typed according to that object.
168
169 Alternatively, you can pass a Ctype to indicate the type in the first
170 position, and the object at which to point in the second position. In this
171 way you can index into data at arbitrary intervals based on the size of
172 the 'type' of pointer you choose. For example, on a system where C<short>
173 is two octets and C<char> is one:
174
175   my $uint = c_uint(691693896);
176   my $charptr = Pointer( c_char, $uint );
177   print @$charptr, "\n";
178
179 Here, a Pointer has been made of type C<c_char>, four of which can be
180 elicited from the four-byte C<c_uint> number. The output of this code
181 on a Big-endian system would be a friendly greeting.
182
183 =cut
184
185 sub new {
186   my $class = ref($_[0]) || $_[0]; shift;
187   my( $type, $contents );
188   #  return undef unless defined($contents);  # No null pointers plz :)
189
190   if( scalar @_ == 1 ) {
191     $type = $contents = shift;
192   } elsif( scalar @_ > 1 ) {
193     $type = shift;
194     $contents = shift;
195   }
196
197   carp("Usage: Pointer( [type, ] \$object )") if @_;
198
199   return undef unless Ctypes::is_ctypes_compat($contents);
200
201   my $typecode = $type->typecode if ref($type);
202   #if( not Ctypes::sizeof($type) ) {
203   #  carp("Invalid Array type specified (first position argument)");
204   #  return undef;
205   #}
206   my $self = $class->_new( {
207      _name        => $type.'_Pointer',
208      _size        => Ctypes::sizeof('p'),
209      _offset      => 0,
210      _contents    => $contents,
211      _bytes       => undef,
212      _type        => $type,
213      _typecode    => 'p',
214   } );
215   $self->{_rawcontents} =
216     tie $self->{_contents}, 'Ctypes::Type::Pointer::contents', $self;
217   $self->{_rawbytes} =
218     tie @{$self->{_bytes}},
219           'Ctypes::Type::Pointer::bytes',
220           $self;
221   $self->{_contents} = $contents;
222   return $self;
223 }
224
225 =item copy
226
227 Return a copy of the Pointer object.
228
229 =cut
230
231 sub copy {
232   return Ctypes::Type::Pointer->new( $_[0]->contents );
233 }
234
235 =item deref
236
237 This accessor returns the Ctypes object to which the Pointer points,
238 like C<$$pointer>, but since it doesn't require the double sigil it
239 is useful in e.g. accessing members of compound objects like Arrays.
240
241 =cut
242
243 sub deref () : method {
244   return ${shift->{_contents}};
245 }
246
247 sub data { &_as_param_(@_) }
248
249 sub _as_param_ {
250   my $self = shift;
251   print "In ", $self->{_name}, "'s _As_param_, from ", join(", ",(caller(1))[0..3]), "\n" if $Debug;
252   if( defined $self->{_data}
253       and $self->{_datasafe} == 1 ) {
254     print "already have _as_param_:\n" if $Debug;
255     print "  ", $self->{_data}, "\n" if $Debug;
256     print "   ", unpack('b*', $self->{_data}), "\n" if $Debug;
257     return \$self->{_data}
258   }
259 # Can't use $self->{_contents} as FETCH will bork at _datasafe
260 # use $self->{_raw}{DATA} instead
261   $self->{_data} =
262     ${$self->{_rawcontents}{DATA}->_as_param_};
263   print "  ", $self->{_name}, "'s _as_param_ returning ok...\n" if $Debug;
264   $self->{_datasafe} = 0;  # used by FETCH
265   return \$self->{_data};
266 }
267
268 sub _update_ {
269   my( $self, $arg ) = @_;
270   print "In ", $self->{_name}, "'s _UPDATE_, from ", join(", ",(caller(0))[0..3]), "\n" if $Debug;
271   print "  self is ", $self, "\n" if $Debug;
272   print "  arg is $arg\n" if $Debug;
273   print "  which is\n", unpack('b*',$arg), "\n  to you and me\n" if $Debug;
274   $arg = $self->{_data} unless $arg;
275
276   my $success = $self->{_rawcontents}{DATA}->_update_($arg);
277   if(!$success) {
278     croak($self->{_name}, ": Error updating contents");
279   }
280 #
281 #  $self->{_data} = $self->_as_param_;
282   $self->{_datasafe} = 1;
283   return 1;
284 }
285
286 =item contents
287
288 This accessor returns the object to which the Pointer points (as
289 opposed to the I<value> represented by that object). C<$ptr-E<gt>
290 contents> is a synonym for C<$$ptr>, but since it doesn't require
291 the double-sigil syntax it can be used e.g. when accessing members
292 of compound objects like L<Arrays|Ctypes::Type::Array>.
293
294 =item type
295
296 This accessor returns the typecode of the type to which the Pointer
297 points. It is analogous to the pointer 'type' in C. Pointer I<objects>
298 themselves are always typecode 'p'.
299
300 =item offset NUMBER
301
302 =item offset
303
304 This method sets and/or returns the current offset of the Pointer
305 object. The offset of the Pointer object can also be manipulated by
306 using various mathematical operators on the object:
307
308   $pointer++;
309   $pointer--;
310   $pointer += 2;
311
312 Note that these are performed on the Pointer object itself (with one
313 sigil). Two sigils gets you the value the Pointer points to, and they're
314 not what you want to increment.
315
316 When using Perl array-style subscript dereferencing on the Pointer to
317 access chunks of data, the subscript B<is added to the offset>. The
318 following shows two ways to get the same result:
319
320   my $array = Array( c_int, [ 1, 2, 3, 4, 5 ] );
321   my $intptr = ( c_int, $array );      # offset is 0
322
323   print $$intptr[2];                   # 3
324   $intptr += 3;
325   print $$intptr[0];                   # 3
326
327 Note that since Perl translates negative subscripts into positive ones
328 based on array size, negative subscripts on Pointer objects do not
329 work.
330
331 =cut
332
333 #
334 # Accessor generation
335 #
336 my %access = (
337   contents          => ['_contents'],
338   offset            => ['_offset',undef,1],
339 );
340
341 sub type { $_[0]->{_type}->typecode; }
342 for my $func (keys(%access)) {
343   no strict 'refs';
344   my $key = $access{$func}[0];
345   *$func = sub {
346     my $self = shift;
347     my $arg = shift;
348     croak("The $key method only takes one argument") if @_;
349     if($access{$func}[1] and defined($arg)){
350       eval{ $access{$func}[1]->($arg); };
351       if( $@ ) {
352         croak("Invalid argument for $key method: $@");
353       }
354     }
355     if($access{$func}[2] and defined($arg)) {
356       $self->{$key} = $arg if $arg;
357     }
358     return $self->{$key};
359   }
360 }
361
362 package Ctypes::Type::Pointer::contents;
363 use warnings;
364 use strict;
365 use Carp;
366 use Ctypes;
367
368 sub TIESCALAR {
369   print "In Bytes' TIESCALAR\n" if $Debug;
370   my $class = shift;
371   my $owner = shift;
372   my $self = { _owner => $owner,
373                DATA  => undef,
374              };
375   print "    my owner is ", $self->{_owner}{_name}, "\n" if $Debug;
376   return bless $self => $class;
377 }
378
379 sub STORE {
380   my( $self, $arg ) = @_;
381   print "In ", $self->{_owner}{_name}, "'s content STORE, from ", (caller(1))[0..3], "\n" if $Debug;
382   if( not Ctypes::is_ctypes_compat($arg) ) {
383     if ( $arg =~ /^\d*$/ ) {
384       croak("Cannot make Pointer to plain scalar; did you mean to say '\$ptr++'?")
385     }
386     croak("Pointers are to Ctypes compatible objects only")
387   }
388   $self->{_owner}{_data} = undef;
389   $self->{_owner}{_offset} = 0; # makes sense to reset offset
390   print "  ", $self->{_owner}{_name}, "'s content STORE returning ok...\n" if $Debug;
391   return $self->{DATA} = $arg;
392 }
393
394 sub FETCH {
395   my $self = shift;
396   print "In ", $self->{_owner}{_name}, "'s content FETCH, from ", (caller(1))[0..3], "\n" if $Debug;
397   if( defined $self->{_owner}{_data}
398       or $self->{_owner}{_datasafe} == 0 ) {
399     print "    Woop... _as_param_ is ", unpack('b*',$self->{_owner}{_data}),"\n" if $Debug;
400     my $success = $self->{_owner}->_update_(${$self->{_owner}->_as_param_});
401     croak($self->{_name},": Could not update contents") if not $success;
402   }
403   croak("Error: Data not safe") if $self->{_owner}{_datasafe} != 1;
404   print "  ", $self->{_owner}{_name}, "'s content FETCH returning ok...\n" if $Debug;
405   print "  Returning ", ${$self->{DATA}}, "\n" if $Debug;
406   return $self->{DATA};
407 }
408
409 package Ctypes::Type::Pointer::bytes;
410 use warnings;
411 use strict;
412 use Carp;
413 use Ctypes;
414
415 sub TIEARRAY {
416   my $class = shift;
417   my $owner = shift;
418   my $self = { _owner => $owner,
419                DATA  => [],
420              };
421   return bless $self => $class;
422 }
423
424 sub STORE {
425   my( $self, $index, $arg ) = @_;
426   print "In ", $self->{_owner}{_name}, "'s Bytes STORE, from ", (caller(0))[0..3], "\n" if $Debug;
427   if( ref($arg) ) {
428     carp("Only store simple scalar data through subscripted Pointers");
429     return undef;
430   }
431
432   my $data = $self->{_owner}{_rawcontents}{DATA}->_as_param_;
433   print "\tdata is $$data\n" if $Debug;
434   my $each = $self->{_owner}{_type}->size;
435
436   my $offset = $index + $self->{_owner}{_offset};
437   if( $offset < 0 ) {
438     carp("Pointer cannot store before start of data");
439     return undef;
440   }
441   if( $offset >= length($$data)                  # start at end of data
442       or ($offset + $each) > length($$data) ) {  # or will go past it
443     carp("Pointer cannot store past end of data");
444   }
445
446   print "\teach is $each\n" if $Debug;
447   print "\tdata length is ", length($$data), "\n" if $Debug;
448   my $insert = pack($self->{_owner}{_type}->packcode,$arg);
449   print "\tinsert is ", unpack('b*',$insert), "\n" if $Debug;
450   if( length($insert) != $self->{_owner}{_type}->size ) {
451     carp("You're about to break something...");
452 # ??? What would be useful feedback here? Aside from just not doing it..
453   }
454   print "\tdata before and after insert:\n" if $Debug;
455   print unpack('b*',$$data), "\n" if $Debug;
456   substr( $$data,
457           $each * $offset,
458           $self->{_owner}{_type}->size,
459         ) =  $insert;
460   print unpack('b*',$$data), "\n" if $Debug;
461   $self->{DATA}[$index] = $insert;  # don't think this can be used
462   $self->{_owner}{_rawcontents}{DATA}->_update_($$data);
463   print "  ", $self->{_owner}{_name}, "'s Bytes STORE returning ok...\n" if $Debug;
464   return $insert;
465 }
466
467 sub FETCH {
468   my( $self, $index ) = @_;
469   print "In ", $self->{_owner}{_name}, "'s Bytes FETCH, from ", (caller(1))[0..3], "\n" if $Debug;
470
471   my $type = $self->{_owner}{_type};
472   if( $type->name =~ /[pv]/ ) {
473     carp("Pointer is to type ", $type,
474          "; can't know how to dereference data");
475     return undef;
476   }
477
478   my $data = $self->{_owner}{_rawcontents}{DATA}->_as_param_;
479   print "\tdata is $$data\n" if $Debug;
480   my $each = $self->{_owner}{_type}->size;
481
482   my $offset = $index + $self->{_owner}{_offset};
483   if( $offset < 0 ) {
484     carp("Pointer cannot look back past start of data");
485     return undef;
486   }
487   my $start = $offset * $each;
488   # 1-byte types can start on last byte and be fine
489   if( $start + ($each - 1) > length($$data) ) {
490     carp("Pointer cannot look past end of data");
491     return undef;
492   }
493
494   print "\toffset is $offset\n" if $Debug;
495   print "\teach is $each\n" if $Debug;
496   print "\tstart is $start\n" if $Debug;
497   print "\torig_type: ", $self->{_owner}{_type}->name, "\n" if $Debug;
498   print "\tdata length is ", length($$data), "\n" if $Debug;
499   my $chunk = substr( $$data,
500                       $each * $offset,
501                       $self->{_owner}{_type}->size
502                     );
503   print "\tchunk: ", unpack('b*',$chunk), "\n" if $Debug;
504   $self->{DATA}[$index] = $chunk;
505   print "  ", $self->{_owner}{_name}, "'s Bytes FETCH returning ok...\n" if $Debug;
506   return unpack($self->{_owner}{_type}->packcode,$chunk);
507 }
508
509 sub FETCHSIZE {
510   my $data = $_[0]->{_owner}{_rawcontents}{DATA}{_data}
511     ? $_[0]->{_owner}{_rawcontents}{DATA}{_data}
512     : $_[0]->{_owner}{_rawcontents}{DATA}->_as_param_;
513   my $type = $_[0]->{_owner}{_type};
514   return length($data) / $type->size;
515 }
516
517 sub EXISTS { 0 }  # makes no sense for ::bytes
518 sub EXTEND { }
519 sub UNSHIFT { croak("Pointer::bytes isn't a normal array - can't unshift") }
520 sub SHIFT { croak("Pointer::bytes isn't a normal array - can't shift") }
521 sub PUSH { croak("Pointer::bytes isn't a normal array - can't push") }
522 sub POP { croak("Pointer::bytes isn't a normal array - can't pop") }
523 sub SPLICE { croak("Pointer::bytes isn't a normal array - can't splice") }
524
525 1;