File Coverage

lib/ExtUtils/Typemaps/ObjectMap.pm
Criterion Covered Total %
statement 13 13 100.0
branch n/a
condition n/a
subroutine 4 4 100.0
pod 1 1 100.0
total 18 18 100.0


line stmt bran cond sub pod time code
1             package ExtUtils::Typemaps::ObjectMap;
2              
3 1     1   1118 use strict;
  1         3  
  1         35  
4 1     1   5 use warnings;
  1         2  
  1         28  
5 1     1   5 use ExtUtils::Typemaps;
  1         2  
  1         151  
6              
7             our $VERSION = '1.05';
8              
9             our @ISA = qw(ExtUtils::Typemaps);
10              
11             =head1 NAME
12              
13             ExtUtils::Typemaps::ObjectMap - A set of typemaps for opaque C/C++ objects
14              
15             =head1 SYNOPSIS
16              
17             use ExtUtils::Typemaps::ObjectMap;
18             # First, read my own type maps:
19             my $private_map = ExtUtils::Typemaps->new(file => 'my.map');
20            
21             # Then, get the object map set and merge it into my maps
22             $private_map->merge(typemap => ExtUtils::Typemaps::ObjectMap->new);
23            
24             # Now, write the combined map to an output file
25             $private_map->write(file => 'typemap');
26              
27             =head1 DESCRIPTION
28              
29             C is an C
30             subclass that provides a set of mappings for using pointers to
31             C/C++ objects as opaque objects from Perl.
32              
33             These mappings are taken verbatim from Dean Roehrich's C.
34             They are:
35              
36             # "perlobject.map" Dean Roehrich, version 19960302
37             #
38             # TYPEMAPs
39             #
40             # HV * -> unblessed Perl HV object.
41             # AV * -> unblessed Perl AV object.
42             #
43             # INPUT/OUTPUT maps
44             #
45             # O_* -> opaque blessed objects
46             # T_* -> opaque blessed or unblessed objects
47             #
48             # O_OBJECT -> link an opaque C or C++ object to a blessed Perl object.
49             # T_OBJECT -> link an opaque C or C++ object to an unblessed Perl object.
50             # O_HvRV -> a blessed Perl HV object.
51             # T_HvRV -> an unblessed Perl HV object.
52             # O_AvRV -> a blessed Perl AV object.
53             # T_AvRV -> an unblessed Perl AV object.
54              
55             =head1 METHODS
56              
57             These are the overridden methods:
58              
59             =head2 new
60              
61             Creates a new C object.
62             It acts as any other C object, except that
63             it has the object maps initialized.
64              
65             =cut
66              
67             sub new {
68 2     2 1 535 my $class = shift;
69              
70 2         21 my $self = $class->SUPER::new(@_);
71 2         70 $self->add_string(string => <<'END_TYPEMAP');
72             # "perlobject.map" Dean Roehrich, version 19960302
73             #
74             # TYPEMAPs
75             #
76             # HV * -> unblessed Perl HV object.
77             # AV * -> unblessed Perl AV object.
78             #
79             # INPUT/OUTPUT maps
80             #
81             # O_* -> opaque blessed objects
82             # T_* -> opaque blessed or unblessed objects
83             #
84             # O_OBJECT -> link an opaque C or C++ object to a blessed Perl object.
85             # T_OBJECT -> link an opaque C or C++ object to an unblessed Perl object.
86             # O_HvRV -> a blessed Perl HV object.
87             # T_HvRV -> an unblessed Perl HV object.
88             # O_AvRV -> a blessed Perl AV object.
89             # T_AvRV -> an unblessed Perl AV object.
90              
91             TYPEMAP
92              
93             HV * T_HvRV
94             AV * T_AvRV
95              
96              
97             ######################################################################
98             OUTPUT
99              
100             # The Perl object is blessed into 'CLASS', which should be a
101             # char* having the name of the package for the blessing.
102             O_OBJECT
103             sv_setref_pv( $arg, CLASS, (void*)$var );
104              
105             T_OBJECT
106             sv_setref_pv( $arg, Nullch, (void*)$var );
107              
108             # Cannot use sv_setref_pv() because that will destroy
109             # the HV-ness of the object. Remember that newRV() will increment
110             # the refcount.
111             O_HvRV
112             $arg = sv_bless( newRV((SV*)$var), gv_stashpv(CLASS,1) );
113              
114             T_HvRV
115             $arg = newRV((SV*)$var);
116              
117             # Cannot use sv_setref_pv() because that will destroy
118             # the AV-ness of the object. Remember that newRV() will increment
119             # the refcount.
120             O_AvRV
121             $arg = sv_bless( newRV((SV*)$var), gv_stashpv(CLASS,1) );
122              
123             T_AvRV
124             $arg = newRV((SV*)$var);
125              
126              
127             ######################################################################
128             INPUT
129              
130             O_OBJECT
131             if( sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG) )
132             $var = ($type)SvIV((SV*)SvRV( $arg ));
133             else{
134             warn( \"${Package}::$func_name() -- $var is not a blessed SV reference\" );
135             XSRETURN_UNDEF;
136             }
137              
138             T_OBJECT
139             if( SvROK($arg) )
140             $var = ($type)SvIV((SV*)SvRV( $arg ));
141             else{
142             warn( \"${Package}::$func_name() -- $var is not an SV reference\" );
143             XSRETURN_UNDEF;
144             }
145              
146             O_HvRV
147             if( sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVHV) )
148             $var = (HV*)SvRV( $arg );
149             else {
150             warn( \"${Package}::$func_name() -- $var is not a blessed HV reference\" );
151             XSRETURN_UNDEF;
152             }
153              
154             T_HvRV
155             if( SvROK($arg) && (SvTYPE(SvRV($arg)) == SVt_PVHV) )
156             $var = (HV*)SvRV( $arg );
157             else {
158             warn( \"${Package}::$func_name() -- $var is not an HV reference\" );
159             XSRETURN_UNDEF;
160             }
161              
162             O_AvRV
163             if( sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVAV) )
164             $var = (AV*)SvRV( $arg );
165             else {
166             warn( \"${Package}::$func_name() -- $var is not a blessed AV reference\" );
167             XSRETURN_UNDEF;
168             }
169              
170             T_AvRV
171             if( SvROK($arg) && (SvTYPE(SvRV($arg)) == SVt_PVAV) )
172             $var = (AV*)SvRV( $arg );
173             else {
174             warn( \"${Package}::$func_name() -- $var is not an AV reference\" );
175             XSRETURN_UNDEF;
176             }
177              
178             END_TYPEMAP
179              
180 2         6253 return $self;
181             }
182              
183             1;
184              
185             __END__