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__ |