line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package ExtUtils::ParseXS; |
2
|
18
|
|
|
18
|
|
304149
|
use strict; |
|
18
|
|
|
|
|
77
|
|
|
18
|
|
|
|
|
545
|
|
3
|
|
|
|
|
|
|
|
4
|
18
|
|
|
18
|
|
377
|
use 5.006001; |
|
18
|
|
|
|
|
61
|
|
5
|
18
|
|
|
18
|
|
105
|
use Cwd; |
|
18
|
|
|
|
|
34
|
|
|
18
|
|
|
|
|
1186
|
|
6
|
18
|
|
|
18
|
|
124
|
use Config; |
|
18
|
|
|
|
|
31
|
|
|
18
|
|
|
|
|
812
|
|
7
|
18
|
|
|
18
|
|
107
|
use Exporter 'import'; |
|
18
|
|
|
|
|
38
|
|
|
18
|
|
|
|
|
643
|
|
8
|
18
|
|
|
18
|
|
142
|
use File::Basename; |
|
18
|
|
|
|
|
36
|
|
|
18
|
|
|
|
|
2033
|
|
9
|
18
|
|
|
18
|
|
131
|
use File::Spec; |
|
18
|
|
|
|
|
44
|
|
|
18
|
|
|
|
|
684
|
|
10
|
18
|
|
|
18
|
|
8134
|
use Symbol; |
|
18
|
|
|
|
|
12416
|
|
|
18
|
|
|
|
|
2981
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
our $VERSION; |
13
|
|
|
|
|
|
|
BEGIN { |
14
|
18
|
|
|
18
|
|
71
|
$VERSION = '3.43_02'; |
15
|
18
|
|
|
|
|
8075
|
require ExtUtils::ParseXS::Constants; ExtUtils::ParseXS::Constants->VERSION($VERSION); |
|
18
|
|
|
|
|
402
|
|
16
|
18
|
|
|
|
|
8111
|
require ExtUtils::ParseXS::CountLines; ExtUtils::ParseXS::CountLines->VERSION($VERSION); |
|
18
|
|
|
|
|
363
|
|
17
|
18
|
|
|
|
|
8900
|
require ExtUtils::ParseXS::Utilities; ExtUtils::ParseXS::Utilities->VERSION($VERSION); |
|
18
|
|
|
|
|
381
|
|
18
|
18
|
|
|
|
|
8510
|
require ExtUtils::ParseXS::Eval; ExtUtils::ParseXS::Eval->VERSION($VERSION); |
|
18
|
|
|
|
|
1558
|
|
19
|
|
|
|
|
|
|
} |
20
|
|
|
|
|
|
|
$VERSION = eval $VERSION if $VERSION =~ /_/; |
21
|
|
|
|
|
|
|
|
22
|
18
|
|
|
|
|
46683
|
use ExtUtils::ParseXS::Utilities qw( |
23
|
|
|
|
|
|
|
standard_typemap_locations |
24
|
|
|
|
|
|
|
trim_whitespace |
25
|
|
|
|
|
|
|
C_string |
26
|
|
|
|
|
|
|
valid_proto_string |
27
|
|
|
|
|
|
|
process_typemaps |
28
|
|
|
|
|
|
|
map_type |
29
|
|
|
|
|
|
|
standard_XS_defs |
30
|
|
|
|
|
|
|
assign_func_args |
31
|
|
|
|
|
|
|
analyze_preprocessor_statements |
32
|
|
|
|
|
|
|
set_cond |
33
|
|
|
|
|
|
|
Warn |
34
|
|
|
|
|
|
|
current_line_number |
35
|
|
|
|
|
|
|
blurt |
36
|
|
|
|
|
|
|
death |
37
|
|
|
|
|
|
|
check_conditional_preprocessor_statements |
38
|
|
|
|
|
|
|
escape_file_for_line_directive |
39
|
|
|
|
|
|
|
report_typemap_failure |
40
|
18
|
|
|
18
|
|
136
|
); |
|
18
|
|
|
|
|
35
|
|
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
our @EXPORT_OK = qw( |
43
|
|
|
|
|
|
|
process_file |
44
|
|
|
|
|
|
|
report_error_count |
45
|
|
|
|
|
|
|
errors |
46
|
|
|
|
|
|
|
); |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
############################## |
49
|
|
|
|
|
|
|
# A number of "constants" |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
our ($C_group_rex, $C_arg); |
52
|
|
|
|
|
|
|
# Group in C (no support for comments or literals) |
53
|
|
|
|
|
|
|
$C_group_rex = qr/ [({\[] |
54
|
|
|
|
|
|
|
(?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )* |
55
|
|
|
|
|
|
|
[)}\]] /x; |
56
|
|
|
|
|
|
|
# Chunk in C without comma at toplevel (no comments): |
57
|
|
|
|
|
|
|
$C_arg = qr/ (?: (?> [^()\[\]{},"']+ ) |
58
|
|
|
|
|
|
|
| (??{ $C_group_rex }) |
59
|
|
|
|
|
|
|
| " (?: (?> [^\\"]+ ) |
60
|
|
|
|
|
|
|
| \\. |
61
|
|
|
|
|
|
|
)* " # String literal |
62
|
|
|
|
|
|
|
| ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal |
63
|
|
|
|
|
|
|
)* /xs; |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
# "impossible" keyword (multiple newline) |
66
|
|
|
|
|
|
|
my $END = "!End!\n\n"; |
67
|
|
|
|
|
|
|
# Match an XS Keyword |
68
|
|
|
|
|
|
|
my $BLOCK_regexp = '\s*(' . $ExtUtils::ParseXS::Constants::XSKeywordsAlternation . "|$END)\\s*:"; |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
sub new { |
73
|
25
|
|
|
25
|
1
|
560392
|
return bless {} => shift; |
74
|
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
our $Singleton = __PACKAGE__->new; |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
sub process_file { |
79
|
8
|
|
|
8
|
1
|
7419
|
my $self; |
80
|
|
|
|
|
|
|
# Allow for $package->process_file(%hash), $obj->process_file, and process_file() |
81
|
8
|
100
|
|
|
|
48
|
if (@_ % 2) { |
82
|
7
|
|
|
|
|
38
|
my $invocant = shift; |
83
|
7
|
100
|
|
|
|
44
|
$self = ref($invocant) ? $invocant : $invocant->new; |
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
else { |
86
|
1
|
|
|
|
|
3
|
$self = $Singleton; |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
|
89
|
8
|
|
|
|
|
53
|
my %options = @_; |
90
|
8
|
|
|
|
|
73
|
$self->{ProtoUsed} = exists $options{prototypes}; |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
# Set defaults. |
93
|
8
|
|
|
|
|
103
|
my %args = ( |
94
|
|
|
|
|
|
|
argtypes => 1, |
95
|
|
|
|
|
|
|
csuffix => '.c', |
96
|
|
|
|
|
|
|
except => 0, |
97
|
|
|
|
|
|
|
hiertype => 0, |
98
|
|
|
|
|
|
|
inout => 1, |
99
|
|
|
|
|
|
|
linenumbers => 1, |
100
|
|
|
|
|
|
|
optimize => 1, |
101
|
|
|
|
|
|
|
output => \*STDOUT, |
102
|
|
|
|
|
|
|
prototypes => 0, |
103
|
|
|
|
|
|
|
typemap => [], |
104
|
|
|
|
|
|
|
versioncheck => 1, |
105
|
|
|
|
|
|
|
FH => Symbol::gensym(), |
106
|
|
|
|
|
|
|
%options, |
107
|
|
|
|
|
|
|
); |
108
|
8
|
50
|
|
|
|
425
|
$args{except} = $args{except} ? ' TRY' : ''; |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
# Global Constants |
111
|
|
|
|
|
|
|
|
112
|
8
|
|
|
|
|
21
|
my ($Is_VMS, $SymSet); |
113
|
8
|
50
|
|
|
|
53
|
if ($^O eq 'VMS') { |
114
|
0
|
|
|
|
|
0
|
$Is_VMS = 1; |
115
|
|
|
|
|
|
|
# Establish set of global symbols with max length 28, since xsubpp |
116
|
|
|
|
|
|
|
# will later add the 'XS_' prefix. |
117
|
0
|
|
|
|
|
0
|
require ExtUtils::XSSymSet; |
118
|
0
|
|
|
|
|
0
|
$SymSet = ExtUtils::XSSymSet->new(28); |
119
|
|
|
|
|
|
|
} |
120
|
8
|
|
|
|
|
38
|
@{ $self->{XSStack} } = ({type => 'none'}); |
|
8
|
|
|
|
|
37
|
|
121
|
8
|
|
|
|
|
30
|
$self->{InitFileCode} = [ @ExtUtils::ParseXS::Constants::InitFileCode ]; |
122
|
8
|
|
|
|
|
19
|
$self->{Overload} = 0; # bool |
123
|
8
|
|
|
|
|
17
|
$self->{errors} = 0; # count |
124
|
8
|
|
|
|
|
23
|
$self->{Fallback} = '&PL_sv_undef'; |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
# Most of the 1500 lines below uses these globals. We'll have to |
127
|
|
|
|
|
|
|
# clean this up sometime, probably. For now, we just pull them out |
128
|
|
|
|
|
|
|
# of %args. -Ken |
129
|
|
|
|
|
|
|
|
130
|
8
|
|
|
|
|
37
|
$self->{RetainCplusplusHierarchicalTypes} = $args{hiertype}; |
131
|
8
|
|
|
|
|
28
|
$self->{WantPrototypes} = $args{prototypes}; |
132
|
8
|
|
|
|
|
27
|
$self->{WantVersionChk} = $args{versioncheck}; |
133
|
8
|
|
|
|
|
16
|
$self->{WantLineNumbers} = $args{linenumbers}; |
134
|
8
|
|
|
|
|
23
|
$self->{IncludedFiles} = {}; |
135
|
|
|
|
|
|
|
|
136
|
8
|
50
|
|
|
|
28
|
die "Missing required parameter 'filename'" unless $args{filename}; |
137
|
8
|
|
|
|
|
18
|
$self->{filepathname} = $args{filename}; |
138
|
|
|
|
|
|
|
($self->{dir}, $self->{filename}) = |
139
|
8
|
|
|
|
|
1084
|
(dirname($args{filename}), basename($args{filename})); |
140
|
8
|
|
|
|
|
53
|
$self->{filepathname} =~ s/\\/\\\\/g; |
141
|
8
|
|
|
|
|
35
|
$self->{IncludedFiles}->{$args{filename}}++; |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
# Open the output file if given as a string. If they provide some |
144
|
|
|
|
|
|
|
# other kind of reference, trust them that we can print to it. |
145
|
8
|
100
|
|
|
|
56
|
if (not ref $args{output}) { |
146
|
4
|
50
|
|
|
|
527
|
open my($fh), "> $args{output}" or die "Can't create $args{output}: $!"; |
147
|
4
|
|
|
|
|
30
|
$args{outfile} = $args{output}; |
148
|
4
|
|
|
|
|
16
|
$args{output} = $fh; |
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
# Really, we shouldn't have to chdir() or select() in the first |
152
|
|
|
|
|
|
|
# place. For now, just save and restore. |
153
|
8
|
|
|
|
|
30964
|
my $orig_cwd = cwd(); |
154
|
8
|
|
|
|
|
282
|
my $orig_fh = select(); |
155
|
|
|
|
|
|
|
|
156
|
8
|
|
|
|
|
161
|
chdir($self->{dir}); |
157
|
8
|
|
|
|
|
24312
|
my $pwd = cwd(); |
158
|
8
|
|
|
|
|
251
|
my $csuffix = $args{csuffix}; |
159
|
|
|
|
|
|
|
|
160
|
8
|
100
|
|
|
|
168
|
if ($self->{WantLineNumbers}) { |
161
|
6
|
|
|
|
|
47
|
my $cfile; |
162
|
6
|
100
|
|
|
|
134
|
if ( $args{outfile} ) { |
163
|
3
|
|
|
|
|
108
|
$cfile = $args{outfile}; |
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
else { |
166
|
3
|
|
|
|
|
24
|
$cfile = $args{filename}; |
167
|
3
|
50
|
|
|
|
116
|
$cfile =~ s/\.xs$/$csuffix/i or $cfile .= $csuffix; |
168
|
|
|
|
|
|
|
} |
169
|
6
|
|
|
|
|
518
|
tie(*PSEUDO_STDOUT, 'ExtUtils::ParseXS::CountLines', $cfile, $args{output}); |
170
|
6
|
|
|
|
|
117
|
select PSEUDO_STDOUT; |
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
else { |
173
|
2
|
|
|
|
|
69
|
select $args{output}; |
174
|
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
|
|
176
|
8
|
|
|
|
|
274
|
$self->{typemap} = process_typemaps( $args{typemap}, $pwd ); |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
# Move more settings from parameters to object |
179
|
8
|
|
|
|
|
155
|
foreach my $datum ( qw| argtypes except inout optimize | ) { |
180
|
32
|
|
|
|
|
418
|
$self->{$datum} = $args{$datum}; |
181
|
|
|
|
|
|
|
} |
182
|
8
|
|
|
|
|
48
|
$self->{strip_c_func_prefix} = $args{s}; |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
# Identify the version of xsubpp used |
185
|
8
|
|
|
|
|
340
|
print <
|
186
|
|
|
|
|
|
|
/* |
187
|
|
|
|
|
|
|
* This file was generated automatically by ExtUtils::ParseXS version $VERSION from the |
188
|
|
|
|
|
|
|
* contents of $self->{filename}. Do not edit this file, edit $self->{filename} instead. |
189
|
|
|
|
|
|
|
* |
190
|
|
|
|
|
|
|
* ANY CHANGES MADE HERE WILL BE LOST! |
191
|
|
|
|
|
|
|
* |
192
|
|
|
|
|
|
|
*/ |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
EOM |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
print("#line 1 \"" . escape_file_for_line_directive($self->{filepathname}) . "\"\n") |
198
|
8
|
100
|
|
|
|
179
|
if $self->{WantLineNumbers}; |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
# Open the input file (using $self->{filename} which |
201
|
|
|
|
|
|
|
# is a basename'd $args{filename} due to chdir above) |
202
|
8
|
50
|
|
|
|
688
|
open($self->{FH}, '<', $self->{filename}) or die "cannot open $self->{filename}: $!\n"; |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
FIRSTMODULE: |
205
|
8
|
|
|
|
|
368
|
while (readline($self->{FH})) { |
206
|
153
|
100
|
|
|
|
549
|
if (/^=/) { |
207
|
1
|
|
|
|
|
16
|
my $podstartline = $.; |
208
|
|
|
|
|
|
|
do { |
209
|
5
|
100
|
|
|
|
22
|
if (/^=cut\s*$/) { |
210
|
|
|
|
|
|
|
# We can't just write out a /* */ comment, as our embedded |
211
|
|
|
|
|
|
|
# POD might itself be in a comment. We can't put a /**/ |
212
|
|
|
|
|
|
|
# comment inside #if 0, as the C standard says that the source |
213
|
|
|
|
|
|
|
# file is decomposed into preprocessing characters in the stage |
214
|
|
|
|
|
|
|
# before preprocessing commands are executed. |
215
|
|
|
|
|
|
|
# I don't want to leave the text as barewords, because the spec |
216
|
|
|
|
|
|
|
# isn't clear whether macros are expanded before or after |
217
|
|
|
|
|
|
|
# preprocessing commands are executed, and someone pathological |
218
|
|
|
|
|
|
|
# may just have defined one of the 3 words as a macro that does |
219
|
|
|
|
|
|
|
# something strange. Multiline strings are illegal in C, so |
220
|
|
|
|
|
|
|
# the "" we write must be a string literal. And they aren't |
221
|
|
|
|
|
|
|
# concatenated until 2 steps later, so we are safe. |
222
|
|
|
|
|
|
|
# - Nicholas Clark |
223
|
1
|
|
|
|
|
5
|
print("#if 0\n \"Skipped embedded POD.\"\n#endif\n"); |
224
|
|
|
|
|
|
|
printf("#line %d \"%s\"\n", $. + 1, escape_file_for_line_directive($self->{filepathname})) |
225
|
1
|
50
|
|
|
|
21
|
if $self->{WantLineNumbers}; |
226
|
1
|
|
|
|
|
13
|
next FIRSTMODULE; |
227
|
|
|
|
|
|
|
} |
228
|
|
|
|
|
|
|
|
229
|
1
|
|
|
|
|
7
|
} while (readline($self->{FH})); |
230
|
|
|
|
|
|
|
# At this point $. is at end of file so die won't state the start |
231
|
|
|
|
|
|
|
# of the problem, and as we haven't yet read any lines &death won't |
232
|
|
|
|
|
|
|
# show the correct line in the message either. |
233
|
|
|
|
|
|
|
die ("Error: Unterminated pod in $self->{filename}, line $podstartline\n") |
234
|
0
|
0
|
|
|
|
0
|
unless $self->{lastline}; |
235
|
|
|
|
|
|
|
} |
236
|
152
|
100
|
|
|
|
569
|
last if ($self->{Package}, $self->{Prefix}) = |
237
|
|
|
|
|
|
|
/^MODULE\s*=\s*[\w:]+(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/; |
238
|
|
|
|
|
|
|
|
239
|
144
|
|
|
|
|
327
|
print $_; |
240
|
|
|
|
|
|
|
} |
241
|
8
|
50
|
|
|
|
45
|
unless (defined $_) { |
242
|
0
|
|
|
|
|
0
|
warn "Didn't find a 'MODULE ... PACKAGE ... PREFIX' line\n"; |
243
|
0
|
|
|
|
|
0
|
exit 0; # Not a fatal error for the caller process |
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
|
246
|
8
|
100
|
|
|
|
106
|
print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers}; |
247
|
|
|
|
|
|
|
|
248
|
8
|
|
|
|
|
132
|
standard_XS_defs(); |
249
|
|
|
|
|
|
|
|
250
|
8
|
100
|
|
|
|
67
|
print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers}; |
251
|
|
|
|
|
|
|
|
252
|
8
|
|
|
|
|
80
|
$self->{lastline} = $_; |
253
|
8
|
|
|
|
|
109
|
$self->{lastline_no} = $.; |
254
|
|
|
|
|
|
|
|
255
|
8
|
|
|
|
|
32
|
my $BootCode_ref = []; |
256
|
8
|
|
|
|
|
20
|
my $XSS_work_idx = 0; |
257
|
8
|
|
|
|
|
53
|
my $cpp_next_tmp = 'XSubPPtmpAAAA'; |
258
|
|
|
|
|
|
|
PARAGRAPH: |
259
|
8
|
|
|
|
|
111
|
while ($self->fetch_para()) { |
260
|
84
|
|
|
|
|
183
|
my $outlist_ref = []; |
261
|
|
|
|
|
|
|
# Print initial preprocessor statements and blank lines |
262
|
84
|
|
100
|
|
|
141
|
while (@{ $self->{line} } && $self->{line}->[0] !~ /^[^\#]/) { |
|
89
|
|
|
|
|
565
|
|
263
|
5
|
|
|
|
|
8
|
my $ln = shift(@{ $self->{line} }); |
|
5
|
|
|
|
|
12
|
|
264
|
5
|
|
|
|
|
20
|
print $ln, "\n"; |
265
|
5
|
100
|
|
|
|
42
|
next unless $ln =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/; |
266
|
3
|
|
|
|
|
12
|
my $statement = $+; |
267
|
3
|
|
|
|
|
17
|
( $self, $XSS_work_idx, $BootCode_ref ) = |
268
|
|
|
|
|
|
|
analyze_preprocessor_statements( |
269
|
|
|
|
|
|
|
$self, $statement, $XSS_work_idx, $BootCode_ref |
270
|
|
|
|
|
|
|
); |
271
|
|
|
|
|
|
|
} |
272
|
|
|
|
|
|
|
|
273
|
84
|
100
|
|
|
|
150
|
next PARAGRAPH unless @{ $self->{line} }; |
|
84
|
|
|
|
|
237
|
|
274
|
|
|
|
|
|
|
|
275
|
69
|
100
|
100
|
|
|
197
|
if ($XSS_work_idx && !$self->{XSStack}->[$XSS_work_idx]{varname}) { |
276
|
|
|
|
|
|
|
# We are inside an #if, but have not yet #defined its xsubpp variable. |
277
|
1
|
|
|
|
|
8
|
print "#define $cpp_next_tmp 1\n\n"; |
278
|
1
|
|
|
|
|
3
|
push(@{ $self->{InitFileCode} }, "#if $cpp_next_tmp\n"); |
|
1
|
|
|
|
|
11
|
|
279
|
1
|
|
|
|
|
3
|
push(@{ $BootCode_ref }, "#if $cpp_next_tmp"); |
|
1
|
|
|
|
|
3
|
|
280
|
1
|
|
|
|
|
10
|
$self->{XSStack}->[$XSS_work_idx]{varname} = $cpp_next_tmp++; |
281
|
|
|
|
|
|
|
} |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
$self->death( |
284
|
|
|
|
|
|
|
"Code is not inside a function" |
285
|
|
|
|
|
|
|
." (maybe last function was ended by a blank line " |
286
|
|
|
|
|
|
|
." followed by a statement on column one?)") |
287
|
69
|
50
|
|
|
|
238
|
if $self->{line}->[0] =~ /^\s/; |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
# initialize info arrays |
290
|
69
|
|
|
|
|
169
|
foreach my $member (qw(args_match var_types defaults arg_list |
291
|
|
|
|
|
|
|
argtype_seen in_out lengthof)) |
292
|
|
|
|
|
|
|
{ |
293
|
483
|
|
|
|
|
1223
|
$self->{$member} = {}; |
294
|
|
|
|
|
|
|
} |
295
|
69
|
|
|
|
|
172
|
$self->{proto_arg} = []; |
296
|
69
|
|
|
|
|
120
|
$self->{processing_arg_with_types} = 0; # bool |
297
|
69
|
|
|
|
|
123
|
$self->{proto_in_this_xsub} = 0; # counter & bool |
298
|
69
|
|
|
|
|
110
|
$self->{scope_in_this_xsub} = 0; # counter & bool |
299
|
69
|
|
|
|
|
124
|
$self->{interface} = 0; # bool |
300
|
69
|
|
|
|
|
124
|
$self->{interface_macro} = 'XSINTERFACE_FUNC'; |
301
|
69
|
|
|
|
|
121
|
$self->{interface_macro_set} = 'XSINTERFACE_FUNC_SET'; |
302
|
69
|
|
|
|
|
112
|
$self->{ProtoThisXSUB} = $self->{WantPrototypes}; # states 0 (none), 1 (yes), 2 (empty prototype) |
303
|
69
|
|
|
|
|
111
|
$self->{ScopeThisXSUB} = 0; # bool |
304
|
|
|
|
|
|
|
|
305
|
69
|
|
|
|
|
109
|
my $xsreturn = 0; |
306
|
|
|
|
|
|
|
|
307
|
69
|
|
|
|
|
97
|
$_ = shift(@{ $self->{line} }); |
|
69
|
|
|
|
|
161
|
|
308
|
69
|
|
|
|
|
238
|
while (my $kwd = $self->check_keyword("REQUIRE|PROTOTYPES|EXPORT_XSUB_SYMBOLS|FALLBACK|VERSIONCHECK|INCLUDE(?:_COMMAND)?|SCOPE")) { |
309
|
14
|
|
|
|
|
57
|
my $method = $kwd . "_handler"; |
310
|
14
|
|
|
|
|
178
|
$self->$method($_); |
311
|
14
|
50
|
|
|
|
29
|
next PARAGRAPH unless @{ $self->{line} }; |
|
14
|
|
|
|
|
132
|
|
312
|
0
|
|
|
|
|
0
|
$_ = shift(@{ $self->{line} }); |
|
0
|
|
|
|
|
0
|
|
313
|
|
|
|
|
|
|
} |
314
|
|
|
|
|
|
|
|
315
|
55
|
100
|
|
|
|
220
|
if ($self->check_keyword("BOOT")) { |
316
|
1
|
|
|
|
|
20
|
check_conditional_preprocessor_statements($self); |
317
|
1
|
|
|
|
|
4
|
push (@{ $BootCode_ref }, "#line $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} }] \"" |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
8
|
|
318
|
|
|
|
|
|
|
. escape_file_for_line_directive($self->{filepathname}) . "\"") |
319
|
1
|
50
|
33
|
|
|
18
|
if $self->{WantLineNumbers} && $self->{line}->[0] !~ /^\s*#\s*line\b/; |
320
|
1
|
|
|
|
|
3
|
push (@{ $BootCode_ref }, @{ $self->{line} }, ""); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
3
|
|
321
|
1
|
|
|
|
|
5
|
next PARAGRAPH; |
322
|
|
|
|
|
|
|
} |
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
# extract return type, function name and arguments |
325
|
54
|
|
|
|
|
238
|
($self->{ret_type}) = ExtUtils::Typemaps::tidy_type($_); |
326
|
54
|
50
|
|
|
|
162
|
my $RETVAL_no_return = 1 if $self->{ret_type} =~ s/^NO_OUTPUT\s+//; |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
# Allow one-line ANSI-like declaration |
329
|
0
|
|
|
|
|
0
|
unshift @{ $self->{line} }, $2 |
330
|
|
|
|
|
|
|
if $self->{argtypes} |
331
|
54
|
50
|
33
|
|
|
349
|
and $self->{ret_type} =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s; |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
# a function definition needs at least 2 lines |
334
|
|
|
|
|
|
|
$self->blurt("Error: Function definition too short '$self->{ret_type}'"), next PARAGRAPH |
335
|
54
|
50
|
|
|
|
102
|
unless @{ $self->{line} }; |
|
54
|
|
|
|
|
158
|
|
336
|
|
|
|
|
|
|
|
337
|
54
|
50
|
|
|
|
133
|
my $externC = 1 if $self->{ret_type} =~ s/^extern "C"\s+//; |
338
|
54
|
50
|
|
|
|
124
|
my $static = 1 if $self->{ret_type} =~ s/^static\s+//; |
339
|
|
|
|
|
|
|
|
340
|
54
|
|
|
|
|
85
|
my $func_header = shift(@{ $self->{line} }); |
|
54
|
|
|
|
|
117
|
|
341
|
54
|
50
|
|
|
|
464
|
$self->blurt("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH |
342
|
|
|
|
|
|
|
unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s; |
343
|
|
|
|
|
|
|
|
344
|
54
|
|
|
|
|
113
|
my ($class, $orig_args); |
345
|
54
|
|
|
|
|
290
|
($class, $self->{func_name}, $orig_args) = ($1, $2, $3); |
346
|
54
|
50
|
|
|
|
245
|
$class = "$4 $class" if $4; |
347
|
54
|
|
|
|
|
546
|
($self->{pname} = $self->{func_name}) =~ s/^($self->{Prefix})?/$self->{Packprefix}/; |
348
|
54
|
|
|
|
|
120
|
my $clean_func_name; |
349
|
54
|
|
|
|
|
258
|
($clean_func_name = $self->{func_name}) =~ s/^$self->{Prefix}//; |
350
|
54
|
|
|
|
|
164
|
$self->{Full_func_name} = "$self->{Packid}_$clean_func_name"; |
351
|
54
|
50
|
|
|
|
130
|
if ($Is_VMS) { |
352
|
0
|
|
|
|
|
0
|
$self->{Full_func_name} = $SymSet->addsym( $self->{Full_func_name} ); |
353
|
|
|
|
|
|
|
} |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
# Check for duplicate function definition |
356
|
54
|
|
|
|
|
118
|
for my $tmp (@{ $self->{XSStack} }) { |
|
54
|
|
|
|
|
161
|
|
357
|
57
|
50
|
|
|
|
265
|
next unless defined $tmp->{functions}{ $self->{Full_func_name} }; |
358
|
0
|
|
|
|
|
0
|
Warn( $self, "Warning: duplicate function definition '$clean_func_name' detected"); |
359
|
0
|
|
|
|
|
0
|
last; |
360
|
|
|
|
|
|
|
} |
361
|
54
|
|
|
|
|
272
|
$self->{XSStack}->[$XSS_work_idx]{functions}{ $self->{Full_func_name} }++; |
362
|
54
|
|
|
|
|
159
|
delete $self->{XsubAliases}; |
363
|
54
|
|
|
|
|
84
|
delete $self->{XsubAliasValues}; |
364
|
54
|
|
|
|
|
90
|
%{ $self->{Interfaces} } = (); |
|
54
|
|
|
|
|
126
|
|
365
|
54
|
|
|
|
|
92
|
@{ $self->{Attributes} } = (); |
|
54
|
|
|
|
|
108
|
|
366
|
54
|
|
|
|
|
93
|
$self->{DoSetMagic} = 1; |
367
|
|
|
|
|
|
|
|
368
|
54
|
|
|
|
|
121
|
$orig_args =~ s/\\\s*/ /g; # process line continuations |
369
|
54
|
|
|
|
|
143
|
my @args; |
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
my (@fake_INPUT_pre); # For length(s) generated variables |
372
|
54
|
|
|
|
|
0
|
my (@fake_INPUT); |
373
|
54
|
|
|
|
|
102
|
my $only_C_inlist_ref = {}; # Not in the signature of Perl function |
374
|
54
|
100
|
66
|
|
|
399
|
if ($self->{argtypes} and $orig_args =~ /\S/) { |
375
|
45
|
|
|
|
|
127
|
my $args = "$orig_args ,"; |
376
|
18
|
|
|
18
|
|
192
|
use re 'eval'; |
|
18
|
|
|
|
|
40
|
|
|
18
|
|
|
|
|
2472
|
|
377
|
45
|
50
|
|
|
|
231
|
if ($args =~ /^( (??{ $C_arg }) , )* $ /x) { |
378
|
45
|
|
|
|
|
158
|
@args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg); |
379
|
18
|
|
|
18
|
|
145
|
no re 'eval'; |
|
18
|
|
|
|
|
36
|
|
|
18
|
|
|
|
|
8272
|
|
380
|
45
|
|
|
|
|
109
|
for ( @args ) { |
381
|
64
|
|
|
|
|
212
|
s/^\s+//; |
382
|
64
|
|
|
|
|
212
|
s/\s+$//; |
383
|
64
|
|
|
|
|
291
|
my ($arg, $default) = ($_ =~ m/ ( [^=]* ) ( (?: = .* )? ) /x); |
384
|
64
|
|
|
|
|
325
|
my ($pre, $len_name) = ($arg =~ /(.*?) \s* |
385
|
|
|
|
|
|
|
\b ( \w+ | length\( \s*\w+\s* \) ) |
386
|
|
|
|
|
|
|
\s* $ /x); |
387
|
64
|
100
|
100
|
|
|
396
|
next unless defined($pre) && length($pre); |
388
|
7
|
|
|
|
|
15
|
my $out_type = ''; |
389
|
7
|
|
|
|
|
11
|
my $inout_var; |
390
|
7
|
100
|
66
|
|
|
49
|
if ($self->{inout} and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//) { |
391
|
3
|
|
|
|
|
7
|
my $type = $1; |
392
|
3
|
100
|
|
|
|
9
|
$out_type = $type if $type ne 'IN'; |
393
|
3
|
|
|
|
|
14
|
$arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//; |
394
|
3
|
|
|
|
|
13
|
$pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//; |
395
|
|
|
|
|
|
|
} |
396
|
7
|
|
|
|
|
13
|
my $islength; |
397
|
7
|
100
|
|
|
|
28
|
if ($len_name =~ /^length\( \s* (\w+) \s* \)\z/x) { |
398
|
1
|
|
|
|
|
4
|
$len_name = "XSauto_length_of_$1"; |
399
|
1
|
|
|
|
|
2
|
$islength = 1; |
400
|
1
|
50
|
|
|
|
3
|
die "Default value on length() argument: '$_'" |
401
|
|
|
|
|
|
|
if length $default; |
402
|
|
|
|
|
|
|
} |
403
|
7
|
50
|
33
|
|
|
21
|
if (length $pre or $islength) { # Has a type |
404
|
7
|
100
|
|
|
|
15
|
if ($islength) { |
405
|
1
|
|
|
|
|
3
|
push @fake_INPUT_pre, $arg; |
406
|
|
|
|
|
|
|
} |
407
|
|
|
|
|
|
|
else { |
408
|
6
|
|
|
|
|
13
|
push @fake_INPUT, $arg; |
409
|
|
|
|
|
|
|
} |
410
|
|
|
|
|
|
|
# warn "pushing '$arg'\n"; |
411
|
7
|
|
|
|
|
35
|
$self->{argtype_seen}->{$len_name}++; |
412
|
7
|
|
|
|
|
18
|
$_ = "$len_name$default"; # Assigns to @args |
413
|
|
|
|
|
|
|
} |
414
|
7
|
100
|
100
|
|
|
45
|
$only_C_inlist_ref->{$_} = 1 if $out_type eq "OUTLIST" or $islength; |
415
|
7
|
100
|
|
|
|
26
|
push @{ $outlist_ref }, $len_name if $out_type =~ /OUTLIST$/; |
|
2
|
|
|
|
|
6
|
|
416
|
7
|
100
|
|
|
|
26
|
$self->{in_out}->{$len_name} = $out_type if $out_type; |
417
|
|
|
|
|
|
|
} |
418
|
|
|
|
|
|
|
} |
419
|
|
|
|
|
|
|
else { |
420
|
18
|
|
|
18
|
|
145
|
no re 'eval'; |
|
18
|
|
|
|
|
38
|
|
|
18
|
|
|
|
|
250644
|
|
421
|
0
|
|
|
|
|
0
|
@args = split(/\s*,\s*/, $orig_args); |
422
|
0
|
|
|
|
|
0
|
Warn( $self, "Warning: cannot parse argument list '$orig_args', fallback to split"); |
423
|
|
|
|
|
|
|
} |
424
|
|
|
|
|
|
|
} |
425
|
|
|
|
|
|
|
else { |
426
|
9
|
|
|
|
|
61
|
@args = split(/\s*,\s*/, $orig_args); |
427
|
9
|
|
|
|
|
27
|
for (@args) { |
428
|
0
|
0
|
0
|
|
|
0
|
if ($self->{inout} and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\b\s*//) { |
429
|
0
|
|
|
|
|
0
|
my $out_type = $1; |
430
|
0
|
0
|
|
|
|
0
|
next if $out_type eq 'IN'; |
431
|
0
|
0
|
|
|
|
0
|
$only_C_inlist_ref->{$_} = 1 if $out_type eq "OUTLIST"; |
432
|
0
|
0
|
|
|
|
0
|
if ($out_type =~ /OUTLIST$/) { |
433
|
0
|
|
|
|
|
0
|
push @{ $outlist_ref }, undef; |
|
0
|
|
|
|
|
0
|
|
434
|
|
|
|
|
|
|
} |
435
|
0
|
|
|
|
|
0
|
$self->{in_out}->{$_} = $out_type; |
436
|
|
|
|
|
|
|
} |
437
|
|
|
|
|
|
|
} |
438
|
|
|
|
|
|
|
} |
439
|
54
|
50
|
|
|
|
136
|
if (defined($class)) { |
440
|
0
|
0
|
0
|
|
|
0
|
my $arg0 = ((defined($static) or $self->{func_name} eq 'new') |
441
|
|
|
|
|
|
|
? "CLASS" : "THIS"); |
442
|
0
|
|
|
|
|
0
|
unshift(@args, $arg0); |
443
|
|
|
|
|
|
|
} |
444
|
54
|
|
|
|
|
97
|
my $extra_args = 0; |
445
|
54
|
|
|
|
|
91
|
my @args_num = (); |
446
|
54
|
|
|
|
|
88
|
my $num_args = 0; |
447
|
54
|
|
|
|
|
95
|
my $report_args = ''; |
448
|
54
|
|
|
|
|
80
|
my $ellipsis; |
449
|
54
|
|
|
|
|
194
|
foreach my $i (0 .. $#args) { |
450
|
64
|
100
|
|
|
|
211
|
if ($args[$i] =~ s/\.\.\.//) { |
451
|
4
|
|
|
|
|
8
|
$ellipsis = 1; |
452
|
4
|
50
|
33
|
|
|
29
|
if ($args[$i] eq '' && $i == $#args) { |
453
|
4
|
|
|
|
|
10
|
$report_args .= ", ..."; |
454
|
4
|
|
|
|
|
9
|
pop(@args); |
455
|
4
|
|
|
|
|
9
|
last; |
456
|
|
|
|
|
|
|
} |
457
|
|
|
|
|
|
|
} |
458
|
60
|
100
|
|
|
|
149
|
if ($only_C_inlist_ref->{$args[$i]}) { |
459
|
3
|
|
|
|
|
5
|
push @args_num, undef; |
460
|
|
|
|
|
|
|
} |
461
|
|
|
|
|
|
|
else { |
462
|
57
|
|
|
|
|
102
|
push @args_num, ++$num_args; |
463
|
57
|
|
|
|
|
125
|
$report_args .= ", $args[$i]"; |
464
|
|
|
|
|
|
|
} |
465
|
60
|
100
|
|
|
|
168
|
if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) { |
466
|
1
|
|
|
|
|
2
|
$extra_args++; |
467
|
1
|
|
|
|
|
3
|
$args[$i] = $1; |
468
|
1
|
|
|
|
|
3
|
$self->{defaults}->{$args[$i]} = $2; |
469
|
1
|
|
|
|
|
6
|
$self->{defaults}->{$args[$i]} =~ s/"/\\"/g; |
470
|
|
|
|
|
|
|
} |
471
|
60
|
100
|
|
|
|
256
|
$self->{proto_arg}->[$i+1] = '$' unless $only_C_inlist_ref->{$args[$i]}; |
472
|
|
|
|
|
|
|
} |
473
|
54
|
|
|
|
|
122
|
my $min_args = $num_args - $extra_args; |
474
|
54
|
|
|
|
|
105
|
$report_args =~ s/"/\\"/g; |
475
|
54
|
|
|
|
|
172
|
$report_args =~ s/^,\s+//; |
476
|
54
|
|
|
|
|
235
|
$self->{func_args} = assign_func_args($self, \@args, $class); |
477
|
54
|
|
|
|
|
109
|
@{ $self->{args_match} }{@args} = @args_num; |
|
54
|
|
|
|
|
215
|
|
478
|
|
|
|
|
|
|
|
479
|
54
|
|
|
|
|
93
|
my $PPCODE = grep(/^\s*PPCODE\s*:/, @{ $self->{line} }); |
|
54
|
|
|
|
|
292
|
|
480
|
54
|
|
|
|
|
87
|
my $CODE = grep(/^\s*CODE\s*:/, @{ $self->{line} }); |
|
54
|
|
|
|
|
257
|
|
481
|
|
|
|
|
|
|
# Detect CODE: blocks which use ST(n)= or XST_m*(n,v) |
482
|
|
|
|
|
|
|
# to set explicit return values. |
483
|
54
|
|
66
|
|
|
227
|
my $EXPLICIT_RETURN = ($CODE && |
484
|
|
|
|
|
|
|
("@{ $self->{line} }" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x )); |
485
|
|
|
|
|
|
|
|
486
|
54
|
|
|
|
|
95
|
$self->{ALIAS} = grep(/^\s*ALIAS\s*:/, @{ $self->{line} }); |
|
54
|
|
|
|
|
238
|
|
487
|
|
|
|
|
|
|
|
488
|
54
|
|
|
|
|
98
|
my $INTERFACE = grep(/^\s*INTERFACE\s*:/, @{ $self->{line} }); |
|
54
|
|
|
|
|
157
|
|
489
|
|
|
|
|
|
|
|
490
|
54
|
50
|
|
|
|
124
|
$xsreturn = 1 if $EXPLICIT_RETURN; |
491
|
|
|
|
|
|
|
|
492
|
54
|
50
|
|
|
|
153
|
$externC = $externC ? qq[extern "C"] : ""; |
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
# print function header |
495
|
54
|
|
|
|
|
315
|
print Q(<<"EOF"); |
496
|
|
|
|
|
|
|
#$externC |
497
|
|
|
|
|
|
|
#XS_EUPXS(XS_$self->{Full_func_name}); /* prototype to pass -Wmissing-prototypes */ |
498
|
|
|
|
|
|
|
#XS_EUPXS(XS_$self->{Full_func_name}) |
499
|
|
|
|
|
|
|
#[[ |
500
|
|
|
|
|
|
|
# dVAR; dXSARGS; |
501
|
|
|
|
|
|
|
EOF |
502
|
54
|
100
|
|
|
|
283
|
print Q(<<"EOF") if $self->{ALIAS}; |
503
|
|
|
|
|
|
|
# dXSI32; |
504
|
|
|
|
|
|
|
EOF |
505
|
54
|
100
|
|
|
|
137
|
print Q(<<"EOF") if $INTERFACE; |
506
|
|
|
|
|
|
|
# dXSFUNCTION($self->{ret_type}); |
507
|
|
|
|
|
|
|
EOF |
508
|
|
|
|
|
|
|
|
509
|
54
|
|
|
|
|
200
|
$self->{cond} = set_cond($ellipsis, $min_args, $num_args); |
510
|
|
|
|
|
|
|
|
511
|
54
|
50
|
|
|
|
142
|
print Q(<<"EOF") if $self->{except}; |
512
|
|
|
|
|
|
|
# char errbuf[1024]; |
513
|
|
|
|
|
|
|
# *errbuf = '\\0'; |
514
|
|
|
|
|
|
|
EOF |
515
|
|
|
|
|
|
|
|
516
|
54
|
100
|
|
|
|
123
|
if($self->{cond}) { |
517
|
52
|
|
|
|
|
184
|
print Q(<<"EOF"); |
518
|
|
|
|
|
|
|
# if ($self->{cond}) |
519
|
|
|
|
|
|
|
# croak_xs_usage(cv, "$report_args"); |
520
|
|
|
|
|
|
|
EOF |
521
|
|
|
|
|
|
|
} |
522
|
|
|
|
|
|
|
else { |
523
|
|
|
|
|
|
|
# cv and items likely to be unused |
524
|
2
|
|
|
|
|
6
|
print Q(<<"EOF"); |
525
|
|
|
|
|
|
|
# PERL_UNUSED_VAR(cv); /* -W */ |
526
|
|
|
|
|
|
|
# PERL_UNUSED_VAR(items); /* -W */ |
527
|
|
|
|
|
|
|
EOF |
528
|
|
|
|
|
|
|
} |
529
|
|
|
|
|
|
|
|
530
|
|
|
|
|
|
|
#gcc -Wall: if an xsub has PPCODE is used |
531
|
|
|
|
|
|
|
#it is possible none of ST, XSRETURN or XSprePUSH macros are used |
532
|
|
|
|
|
|
|
#hence 'ax' (setup by dXSARGS) is unused |
533
|
|
|
|
|
|
|
#XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS |
534
|
|
|
|
|
|
|
#but such a move could break third-party extensions |
535
|
54
|
100
|
|
|
|
236
|
print Q(<<"EOF") if $PPCODE; |
536
|
|
|
|
|
|
|
# PERL_UNUSED_VAR(ax); /* -Wall */ |
537
|
|
|
|
|
|
|
EOF |
538
|
|
|
|
|
|
|
|
539
|
54
|
100
|
|
|
|
144
|
print Q(<<"EOF") if $PPCODE; |
540
|
|
|
|
|
|
|
# SP -= items; |
541
|
|
|
|
|
|
|
EOF |
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
# Now do a block of some sort. |
544
|
|
|
|
|
|
|
|
545
|
54
|
|
|
|
|
114
|
$self->{condnum} = 0; |
546
|
54
|
|
|
|
|
92
|
$self->{cond} = ''; # last CASE: conditional |
547
|
54
|
|
|
|
|
74
|
push(@{ $self->{line} }, "$END:"); |
|
54
|
|
|
|
|
146
|
|
548
|
54
|
|
|
|
|
86
|
push(@{ $self->{line_no} }, $self->{line_no}->[-1]); |
|
54
|
|
|
|
|
115
|
|
549
|
54
|
|
|
|
|
169
|
$_ = ''; |
550
|
54
|
|
|
|
|
206
|
check_conditional_preprocessor_statements(); |
551
|
54
|
|
|
|
|
91
|
while (@{ $self->{line} }) { |
|
55
|
|
|
|
|
136
|
|
552
|
|
|
|
|
|
|
|
553
|
55
|
100
|
|
|
|
132
|
$self->CASE_handler($_) if $self->check_keyword("CASE"); |
554
|
55
|
|
|
|
|
230
|
print Q(<<"EOF"); |
555
|
|
|
|
|
|
|
# $self->{except} [[ |
556
|
|
|
|
|
|
|
EOF |
557
|
|
|
|
|
|
|
|
558
|
|
|
|
|
|
|
# do initialization of input variables |
559
|
55
|
|
|
|
|
241
|
$self->{thisdone} = 0; |
560
|
55
|
|
|
|
|
94
|
$self->{retvaldone} = 0; |
561
|
55
|
|
|
|
|
149
|
$self->{deferred} = ""; |
562
|
55
|
|
|
|
|
100
|
%{ $self->{arg_list} } = (); |
|
55
|
|
|
|
|
117
|
|
563
|
55
|
|
|
|
|
96
|
$self->{gotRETVAL} = 0; |
564
|
55
|
|
|
|
|
208
|
$self->INPUT_handler($_); |
565
|
55
|
|
|
|
|
229
|
$self->process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD"); |
566
|
|
|
|
|
|
|
|
567
|
55
|
50
|
|
|
|
184
|
print Q(<<"EOF") if $self->{ScopeThisXSUB}; |
568
|
|
|
|
|
|
|
# ENTER; |
569
|
|
|
|
|
|
|
# [[ |
570
|
|
|
|
|
|
|
EOF |
571
|
|
|
|
|
|
|
|
572
|
55
|
50
|
33
|
|
|
239
|
if (!$self->{thisdone} && defined($class)) { |
573
|
0
|
0
|
0
|
|
|
0
|
if (defined($static) or $self->{func_name} eq 'new') { |
574
|
0
|
|
|
|
|
0
|
print "\tchar *"; |
575
|
0
|
|
|
|
|
0
|
$self->{var_types}->{"CLASS"} = "char *"; |
576
|
0
|
|
|
|
|
0
|
$self->generate_init( { |
577
|
|
|
|
|
|
|
type => "char *", |
578
|
|
|
|
|
|
|
num => 1, |
579
|
|
|
|
|
|
|
var => "CLASS", |
580
|
|
|
|
|
|
|
printed_name => undef, |
581
|
|
|
|
|
|
|
} ); |
582
|
|
|
|
|
|
|
} |
583
|
|
|
|
|
|
|
else { |
584
|
0
|
|
|
|
|
0
|
print "\t" . map_type($self, "$class *"); |
585
|
0
|
|
|
|
|
0
|
$self->{var_types}->{"THIS"} = "$class *"; |
586
|
0
|
|
|
|
|
0
|
$self->generate_init( { |
587
|
|
|
|
|
|
|
type => "$class *", |
588
|
|
|
|
|
|
|
num => 1, |
589
|
|
|
|
|
|
|
var => "THIS", |
590
|
|
|
|
|
|
|
printed_name => undef, |
591
|
|
|
|
|
|
|
} ); |
592
|
|
|
|
|
|
|
} |
593
|
|
|
|
|
|
|
} |
594
|
|
|
|
|
|
|
|
595
|
|
|
|
|
|
|
# These are set if OUTPUT is found and/or CODE using RETVAL |
596
|
55
|
|
|
|
|
142
|
$self->{have_OUTPUT} = $self->{have_CODE_with_RETVAL} = 0; |
597
|
|
|
|
|
|
|
|
598
|
55
|
|
|
|
|
108
|
my ($wantRETVAL); |
599
|
|
|
|
|
|
|
# do code |
600
|
55
|
50
|
|
|
|
138
|
if (/^\s*NOT_IMPLEMENTED_YET/) { |
601
|
0
|
|
|
|
|
0
|
print "\n\tPerl_croak(aTHX_ \"$self->{pname}: not implemented yet\");\n"; |
602
|
0
|
|
|
|
|
0
|
$_ = ''; |
603
|
|
|
|
|
|
|
} |
604
|
|
|
|
|
|
|
else { |
605
|
55
|
100
|
|
|
|
150
|
if ($self->{ret_type} ne "void") { |
606
|
|
|
|
|
|
|
print "\t" . map_type($self, $self->{ret_type}, 'RETVAL') . ";\n" |
607
|
34
|
50
|
|
|
|
176
|
if !$self->{retvaldone}; |
608
|
34
|
|
|
|
|
183
|
$self->{args_match}->{"RETVAL"} = 0; |
609
|
34
|
|
|
|
|
85
|
$self->{var_types}->{"RETVAL"} = $self->{ret_type}; |
610
|
34
|
|
|
|
|
146
|
my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} ); |
611
|
|
|
|
|
|
|
print "\tdXSTARG;\n" |
612
|
34
|
100
|
33
|
|
|
255
|
if $self->{optimize} and $outputmap and $outputmap->targetable; |
|
|
|
66
|
|
|
|
|
613
|
|
|
|
|
|
|
} |
614
|
|
|
|
|
|
|
|
615
|
55
|
100
|
66
|
|
|
336
|
if (@fake_INPUT or @fake_INPUT_pre) { |
616
|
5
|
|
|
|
|
10
|
unshift @{ $self->{line} }, @fake_INPUT_pre, @fake_INPUT, $_; |
|
5
|
|
|
|
|
17
|
|
617
|
5
|
|
|
|
|
11
|
$_ = ""; |
618
|
5
|
|
|
|
|
10
|
$self->{processing_arg_with_types} = 1; |
619
|
5
|
|
|
|
|
13
|
$self->INPUT_handler($_); |
620
|
|
|
|
|
|
|
} |
621
|
55
|
|
|
|
|
192
|
print $self->{deferred}; |
622
|
|
|
|
|
|
|
|
623
|
55
|
|
|
|
|
205
|
$self->process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD"); |
624
|
|
|
|
|
|
|
|
625
|
55
|
100
|
33
|
|
|
192
|
if ($self->check_keyword("PPCODE")) { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
626
|
4
|
|
|
|
|
16
|
$self->print_section(); |
627
|
4
|
50
|
|
|
|
7
|
$self->death("PPCODE must be last thing") if @{ $self->{line} }; |
|
4
|
|
|
|
|
14
|
|
628
|
4
|
50
|
|
|
|
13
|
print "\tLEAVE;\n" if $self->{ScopeThisXSUB}; |
629
|
4
|
|
|
|
|
9
|
print "\tPUTBACK;\n\treturn;\n"; |
630
|
|
|
|
|
|
|
} |
631
|
|
|
|
|
|
|
elsif ($self->check_keyword("CODE")) { |
632
|
35
|
|
|
|
|
121
|
my $consumed_code = $self->print_section(); |
633
|
35
|
100
|
|
|
|
178
|
if ($consumed_code =~ /\bRETVAL\b/) { |
634
|
27
|
|
|
|
|
65
|
$self->{have_CODE_with_RETVAL} = 1; |
635
|
|
|
|
|
|
|
} |
636
|
|
|
|
|
|
|
} |
637
|
|
|
|
|
|
|
elsif (defined($class) and $self->{func_name} eq "DESTROY") { |
638
|
0
|
|
|
|
|
0
|
print "\n\t"; |
639
|
0
|
|
|
|
|
0
|
print "delete THIS;\n"; |
640
|
|
|
|
|
|
|
} |
641
|
|
|
|
|
|
|
else { |
642
|
16
|
|
|
|
|
59
|
print "\n\t"; |
643
|
16
|
100
|
|
|
|
101
|
if ($self->{ret_type} ne "void") { |
644
|
7
|
|
|
|
|
19
|
print "RETVAL = "; |
645
|
7
|
|
|
|
|
18
|
$wantRETVAL = 1; |
646
|
|
|
|
|
|
|
} |
647
|
16
|
50
|
|
|
|
55
|
if (defined($static)) { |
|
|
50
|
|
|
|
|
|
648
|
0
|
0
|
|
|
|
0
|
if ($self->{func_name} eq 'new') { |
649
|
0
|
|
|
|
|
0
|
$self->{func_name} = "$class"; |
650
|
|
|
|
|
|
|
} |
651
|
|
|
|
|
|
|
else { |
652
|
0
|
|
|
|
|
0
|
print "${class}::"; |
653
|
|
|
|
|
|
|
} |
654
|
|
|
|
|
|
|
} |
655
|
|
|
|
|
|
|
elsif (defined($class)) { |
656
|
0
|
0
|
|
|
|
0
|
if ($self->{func_name} eq 'new') { |
657
|
0
|
|
|
|
|
0
|
$self->{func_name} .= " $class"; |
658
|
|
|
|
|
|
|
} |
659
|
|
|
|
|
|
|
else { |
660
|
0
|
|
|
|
|
0
|
print "THIS->"; |
661
|
|
|
|
|
|
|
} |
662
|
|
|
|
|
|
|
} |
663
|
16
|
|
|
|
|
40
|
my $strip = $self->{strip_c_func_prefix}; |
664
|
16
|
50
|
|
|
|
42
|
$self->{func_name} =~ s/^\Q$strip// |
665
|
|
|
|
|
|
|
if defined $strip; |
666
|
16
|
100
|
|
|
|
48
|
$self->{func_name} = 'XSFUNCTION' if $self->{interface}; |
667
|
16
|
|
|
|
|
63
|
print "$self->{func_name}($self->{func_args});\n"; |
668
|
|
|
|
|
|
|
} |
669
|
|
|
|
|
|
|
} |
670
|
|
|
|
|
|
|
|
671
|
|
|
|
|
|
|
# do output variables |
672
|
55
|
|
|
|
|
141
|
$self->{gotRETVAL} = 0; # 1 if RETVAL seen in OUTPUT section; |
673
|
55
|
|
|
|
|
157
|
undef $self->{RETVAL_code} ; # code to set RETVAL (from OUTPUT section); |
674
|
|
|
|
|
|
|
# $wantRETVAL set if 'RETVAL =' autogenerated |
675
|
55
|
50
|
|
|
|
120
|
($wantRETVAL, $self->{ret_type}) = (0, 'void') if $RETVAL_no_return; |
676
|
55
|
|
|
|
|
84
|
undef %{ $self->{outargs} }; |
|
55
|
|
|
|
|
187
|
|
677
|
|
|
|
|
|
|
|
678
|
55
|
|
|
|
|
197
|
$self->process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD"); |
679
|
|
|
|
|
|
|
|
680
|
|
|
|
|
|
|
# A CODE section with RETVAL, but no OUTPUT? FAIL! |
681
|
55
|
50
|
66
|
|
|
297
|
if ($self->{have_CODE_with_RETVAL} and not $self->{have_OUTPUT} and $self->{ret_type} ne 'void') { |
|
|
|
33
|
|
|
|
|
682
|
0
|
|
|
|
|
0
|
$self->Warn("Warning: Found a 'CODE' section which seems to be using 'RETVAL' but no 'OUTPUT' section."); |
683
|
|
|
|
|
|
|
} |
684
|
|
|
|
|
|
|
|
685
|
|
|
|
|
|
|
$self->generate_output( { |
686
|
|
|
|
|
|
|
type => $self->{var_types}->{$_}, |
687
|
|
|
|
|
|
|
num => $self->{args_match}->{$_}, |
688
|
|
|
|
|
|
|
var => $_, |
689
|
|
|
|
|
|
|
do_setmagic => $self->{DoSetMagic}, |
690
|
|
|
|
|
|
|
do_push => undef, |
691
|
55
|
|
|
|
|
106
|
} ) for grep $self->{in_out}->{$_} =~ /OUT$/, sort keys %{ $self->{in_out} }; |
|
55
|
|
|
|
|
238
|
|
692
|
|
|
|
|
|
|
|
693
|
55
|
|
|
|
|
93
|
my $prepush_done; |
694
|
|
|
|
|
|
|
# all OUTPUT done, so now push the return value on the stack |
695
|
55
|
50
|
66
|
|
|
351
|
if ($self->{gotRETVAL} && $self->{RETVAL_code}) { |
|
|
100
|
100
|
|
|
|
|
696
|
0
|
|
|
|
|
0
|
print "\t$self->{RETVAL_code}\n"; |
697
|
|
|
|
|
|
|
} |
698
|
|
|
|
|
|
|
elsif ($self->{gotRETVAL} || $wantRETVAL) { |
699
|
30
|
|
|
|
|
174
|
my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} ); |
700
|
30
|
|
66
|
|
|
251
|
my $trgt = $self->{optimize} && $outputmap && $outputmap->targetable; |
701
|
30
|
|
|
|
|
71
|
my $var = 'RETVAL'; |
702
|
30
|
|
|
|
|
69
|
my $type = $self->{ret_type}; |
703
|
|
|
|
|
|
|
|
704
|
30
|
100
|
|
|
|
76
|
if ($trgt) { |
705
|
|
|
|
|
|
|
my $what = $self->eval_output_typemap_code( |
706
|
|
|
|
|
|
|
qq("$trgt->{what}"), |
707
|
|
|
|
|
|
|
{var => $var, type => $self->{ret_type}} |
708
|
26
|
|
|
|
|
184
|
); |
709
|
26
|
50
|
33
|
|
|
265
|
if (not $trgt->{with_size} and $trgt->{type} eq 'p') { # sv_setpv |
710
|
|
|
|
|
|
|
# PUSHp corresponds to sv_setpvn. Treat sv_setpv directly |
711
|
0
|
|
|
|
|
0
|
print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n"; |
712
|
0
|
|
|
|
|
0
|
$prepush_done = 1; |
713
|
|
|
|
|
|
|
} |
714
|
|
|
|
|
|
|
else { |
715
|
26
|
|
|
|
|
62
|
my $tsize = $trgt->{what_size}; |
716
|
26
|
50
|
|
|
|
82
|
$tsize = '' unless defined $tsize; |
717
|
|
|
|
|
|
|
$tsize = $self->eval_output_typemap_code( |
718
|
|
|
|
|
|
|
qq("$tsize"), |
719
|
|
|
|
|
|
|
{var => $var, type => $self->{ret_type}} |
720
|
26
|
|
|
|
|
147
|
); |
721
|
26
|
|
|
|
|
188
|
print "\tXSprePUSH; PUSH$trgt->{type}($what$tsize);\n"; |
722
|
26
|
|
|
|
|
118
|
$prepush_done = 1; |
723
|
|
|
|
|
|
|
} |
724
|
|
|
|
|
|
|
} |
725
|
|
|
|
|
|
|
else { |
726
|
|
|
|
|
|
|
# RETVAL almost never needs SvSETMAGIC() |
727
|
|
|
|
|
|
|
$self->generate_output( { |
728
|
|
|
|
|
|
|
type => $self->{ret_type}, |
729
|
4
|
|
|
|
|
39
|
num => 0, |
730
|
|
|
|
|
|
|
var => 'RETVAL', |
731
|
|
|
|
|
|
|
do_setmagic => 0, |
732
|
|
|
|
|
|
|
do_push => undef, |
733
|
|
|
|
|
|
|
} ); |
734
|
|
|
|
|
|
|
} |
735
|
|
|
|
|
|
|
} |
736
|
|
|
|
|
|
|
|
737
|
55
|
100
|
|
|
|
160
|
$xsreturn = 1 if $self->{ret_type} ne "void"; |
738
|
55
|
|
|
|
|
130
|
my $num = $xsreturn; |
739
|
55
|
|
|
|
|
82
|
my $c = @{ $outlist_ref }; |
|
55
|
|
|
|
|
100
|
|
740
|
55
|
100
|
66
|
|
|
160
|
print "\tXSprePUSH;" if $c and not $prepush_done; |
741
|
55
|
100
|
|
|
|
108
|
print "\tEXTEND(SP,$c);\n" if $c; |
742
|
55
|
|
|
|
|
90
|
$xsreturn += $c; |
743
|
|
|
|
|
|
|
$self->generate_output( { |
744
|
|
|
|
|
|
|
type => $self->{var_types}->{$_}, |
745
|
|
|
|
|
|
|
num => $num++, |
746
|
|
|
|
|
|
|
var => $_, |
747
|
|
|
|
|
|
|
do_setmagic => 0, |
748
|
|
|
|
|
|
|
do_push => 1, |
749
|
55
|
|
|
|
|
75
|
} ) for @{ $outlist_ref }; |
|
55
|
|
|
|
|
135
|
|
750
|
|
|
|
|
|
|
|
751
|
|
|
|
|
|
|
# do cleanup |
752
|
55
|
|
|
|
|
159
|
$self->process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD"); |
753
|
|
|
|
|
|
|
|
754
|
55
|
50
|
|
|
|
191
|
print Q(<<"EOF") if $self->{ScopeThisXSUB}; |
755
|
|
|
|
|
|
|
# ]] |
756
|
|
|
|
|
|
|
EOF |
757
|
55
|
50
|
33
|
|
|
139
|
print Q(<<"EOF") if $self->{ScopeThisXSUB} and not $PPCODE; |
758
|
|
|
|
|
|
|
# LEAVE; |
759
|
|
|
|
|
|
|
EOF |
760
|
|
|
|
|
|
|
|
761
|
|
|
|
|
|
|
# print function trailer |
762
|
55
|
|
|
|
|
133
|
print Q(<<"EOF"); |
763
|
|
|
|
|
|
|
# ]] |
764
|
|
|
|
|
|
|
EOF |
765
|
55
|
50
|
|
|
|
270
|
print Q(<<"EOF") if $self->{except}; |
766
|
|
|
|
|
|
|
# BEGHANDLERS |
767
|
|
|
|
|
|
|
# CATCHALL |
768
|
|
|
|
|
|
|
# sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason); |
769
|
|
|
|
|
|
|
# ENDHANDLERS |
770
|
|
|
|
|
|
|
EOF |
771
|
55
|
100
|
|
|
|
126
|
if ($self->check_keyword("CASE")) { |
772
|
|
|
|
|
|
|
$self->blurt("Error: No 'CASE:' at top of function") |
773
|
1
|
50
|
|
|
|
15
|
unless $self->{condnum}; |
774
|
1
|
|
|
|
|
4
|
$_ = "CASE: $_"; # Restore CASE: label |
775
|
1
|
|
|
|
|
3
|
next; |
776
|
|
|
|
|
|
|
} |
777
|
54
|
50
|
|
|
|
227
|
last if $_ eq "$END:"; |
778
|
0
|
0
|
|
|
|
0
|
$self->death(/^$BLOCK_regexp/o ? "Misplaced '$1:'" : "Junk at end of function ($_)"); |
779
|
|
|
|
|
|
|
} |
780
|
|
|
|
|
|
|
|
781
|
54
|
50
|
|
|
|
135
|
print Q(<<"EOF") if $self->{except}; |
782
|
|
|
|
|
|
|
# if (errbuf[0]) |
783
|
|
|
|
|
|
|
# Perl_croak(aTHX_ errbuf); |
784
|
|
|
|
|
|
|
EOF |
785
|
|
|
|
|
|
|
|
786
|
54
|
100
|
|
|
|
123
|
if ($xsreturn) { |
787
|
34
|
50
|
|
|
|
183
|
print Q(<<"EOF") unless $PPCODE; |
788
|
|
|
|
|
|
|
# XSRETURN($xsreturn); |
789
|
|
|
|
|
|
|
EOF |
790
|
|
|
|
|
|
|
} |
791
|
|
|
|
|
|
|
else { |
792
|
20
|
100
|
|
|
|
77
|
print Q(<<"EOF") unless $PPCODE; |
793
|
|
|
|
|
|
|
# XSRETURN_EMPTY; |
794
|
|
|
|
|
|
|
EOF |
795
|
|
|
|
|
|
|
} |
796
|
|
|
|
|
|
|
|
797
|
54
|
|
|
|
|
223
|
print Q(<<"EOF"); |
798
|
|
|
|
|
|
|
#]] |
799
|
|
|
|
|
|
|
# |
800
|
|
|
|
|
|
|
EOF |
801
|
|
|
|
|
|
|
|
802
|
54
|
|
|
|
|
190
|
$self->{proto} = ""; |
803
|
54
|
100
|
|
|
|
129
|
unless($self->{ProtoThisXSUB}) { |
804
|
39
|
|
|
|
|
99
|
$self->{newXS} = "newXS_deffile"; |
805
|
39
|
|
|
|
|
81
|
$self->{file} = ""; |
806
|
|
|
|
|
|
|
} |
807
|
|
|
|
|
|
|
else { |
808
|
|
|
|
|
|
|
# Build the prototype string for the xsub |
809
|
15
|
|
|
|
|
50
|
$self->{newXS} = "newXSproto_portable"; |
810
|
15
|
|
|
|
|
28
|
$self->{file} = ", file"; |
811
|
|
|
|
|
|
|
|
812
|
15
|
50
|
|
|
|
62
|
if ($self->{ProtoThisXSUB} eq 2) { |
|
|
100
|
|
|
|
|
|
813
|
|
|
|
|
|
|
# User has specified empty prototype |
814
|
|
|
|
|
|
|
} |
815
|
|
|
|
|
|
|
elsif ($self->{ProtoThisXSUB} eq 1) { |
816
|
14
|
|
|
|
|
25
|
my $s = ';'; |
817
|
14
|
50
|
|
|
|
34
|
if ($min_args < $num_args) { |
818
|
0
|
|
|
|
|
0
|
$s = ''; |
819
|
0
|
|
|
|
|
0
|
$self->{proto_arg}->[$min_args] .= ";"; |
820
|
|
|
|
|
|
|
} |
821
|
14
|
100
|
|
|
|
29
|
push @{ $self->{proto_arg} }, "$s\@" |
|
2
|
|
|
|
|
6
|
|
822
|
|
|
|
|
|
|
if $ellipsis; |
823
|
|
|
|
|
|
|
|
824
|
14
|
|
|
|
|
21
|
$self->{proto} = join ("", grep defined, @{ $self->{proto_arg} } ); |
|
14
|
|
|
|
|
63
|
|
825
|
|
|
|
|
|
|
} |
826
|
|
|
|
|
|
|
else { |
827
|
|
|
|
|
|
|
# User has specified a prototype |
828
|
1
|
|
|
|
|
3
|
$self->{proto} = $self->{ProtoThisXSUB}; |
829
|
|
|
|
|
|
|
} |
830
|
15
|
|
|
|
|
36
|
$self->{proto} = qq{, "$self->{proto}"}; |
831
|
|
|
|
|
|
|
} |
832
|
|
|
|
|
|
|
|
833
|
54
|
100
|
66
|
|
|
200
|
if ($self->{XsubAliases} and keys %{ $self->{XsubAliases} }) { |
|
6
|
100
|
|
|
|
49
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
834
|
|
|
|
|
|
|
$self->{XsubAliases}->{ $self->{pname} } = 0 |
835
|
6
|
100
|
|
|
|
52
|
unless defined $self->{XsubAliases}->{ $self->{pname} }; |
836
|
6
|
|
|
|
|
15
|
foreach my $xname (sort keys %{ $self->{XsubAliases} }) { |
|
6
|
|
|
|
|
54
|
|
837
|
21
|
|
|
|
|
42
|
my $value = $self->{XsubAliases}{$xname}; |
838
|
21
|
|
|
|
|
35
|
push(@{ $self->{InitFileCode} }, Q(<<"EOF")); |
|
21
|
|
|
|
|
109
|
|
839
|
|
|
|
|
|
|
# cv = $self->{newXS}(\"$xname\", XS_$self->{Full_func_name}$self->{file}$self->{proto}); |
840
|
|
|
|
|
|
|
# XSANY.any_i32 = $value; |
841
|
|
|
|
|
|
|
EOF |
842
|
|
|
|
|
|
|
} |
843
|
|
|
|
|
|
|
} |
844
|
48
|
|
|
|
|
238
|
elsif (@{ $self->{Attributes} }) { |
845
|
1
|
|
|
|
|
2
|
push(@{ $self->{InitFileCode} }, Q(<<"EOF")); |
|
1
|
|
|
|
|
8
|
|
846
|
|
|
|
|
|
|
# cv = $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto}); |
847
|
1
|
|
|
|
|
4
|
# apply_attrs_string("$self->{Package}", cv, "@{ $self->{Attributes} }", 0); |
848
|
|
|
|
|
|
|
EOF |
849
|
|
|
|
|
|
|
} |
850
|
|
|
|
|
|
|
elsif ($self->{interface}) { |
851
|
1
|
|
|
|
|
3
|
foreach my $yname (sort keys %{ $self->{Interfaces} }) { |
|
1
|
|
|
|
|
5
|
|
852
|
1
|
|
|
|
|
3
|
my $value = $self->{Interfaces}{$yname}; |
853
|
1
|
50
|
|
|
|
7
|
$yname = "$self->{Package}\::$yname" unless $yname =~ /::/; |
854
|
1
|
|
|
|
|
3
|
push(@{ $self->{InitFileCode} }, Q(<<"EOF")); |
|
1
|
|
|
|
|
10
|
|
855
|
|
|
|
|
|
|
# cv = $self->{newXS}(\"$yname\", XS_$self->{Full_func_name}$self->{file}$self->{proto}); |
856
|
|
|
|
|
|
|
# $self->{interface_macro_set}(cv,$value); |
857
|
|
|
|
|
|
|
EOF |
858
|
|
|
|
|
|
|
} |
859
|
|
|
|
|
|
|
} |
860
|
|
|
|
|
|
|
elsif($self->{newXS} eq 'newXS_deffile'){ # work around P5NCI's empty newXS macro |
861
|
33
|
|
|
|
|
60
|
push(@{ $self->{InitFileCode} }, |
|
33
|
|
|
|
|
335
|
|
862
|
|
|
|
|
|
|
" $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n"); |
863
|
|
|
|
|
|
|
} |
864
|
|
|
|
|
|
|
else { |
865
|
13
|
|
|
|
|
22
|
push(@{ $self->{InitFileCode} }, |
|
13
|
|
|
|
|
134
|
|
866
|
|
|
|
|
|
|
" (void)$self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n"); |
867
|
|
|
|
|
|
|
} |
868
|
|
|
|
|
|
|
} # END 'PARAGRAPH' 'while' loop |
869
|
|
|
|
|
|
|
|
870
|
8
|
100
|
|
|
|
34
|
if ($self->{Overload}) { # make it findable with fetchmethod |
871
|
1
|
|
|
|
|
7
|
print Q(<<"EOF"); |
872
|
|
|
|
|
|
|
#XS_EUPXS(XS_$self->{Packid}_nil); /* prototype to pass -Wmissing-prototypes */ |
873
|
|
|
|
|
|
|
#XS_EUPXS(XS_$self->{Packid}_nil) |
874
|
|
|
|
|
|
|
#{ |
875
|
|
|
|
|
|
|
# dXSARGS; |
876
|
|
|
|
|
|
|
# PERL_UNUSED_VAR(items); |
877
|
|
|
|
|
|
|
# XSRETURN_EMPTY; |
878
|
|
|
|
|
|
|
#} |
879
|
|
|
|
|
|
|
# |
880
|
|
|
|
|
|
|
EOF |
881
|
1
|
|
|
|
|
4
|
unshift(@{ $self->{InitFileCode} }, <<"MAKE_FETCHMETHOD_WORK"); |
|
1
|
|
|
|
|
10
|
|
882
|
|
|
|
|
|
|
/* Making a sub named "$self->{Package}::()" allows the package */ |
883
|
|
|
|
|
|
|
/* to be findable via fetchmethod(), and causes */ |
884
|
|
|
|
|
|
|
/* overload::Overloaded("$self->{Package}") to return true. */ |
885
|
|
|
|
|
|
|
(void)$self->{newXS}("$self->{Package}::()", XS_$self->{Packid}_nil$self->{file}$self->{proto}); |
886
|
|
|
|
|
|
|
MAKE_FETCHMETHOD_WORK |
887
|
|
|
|
|
|
|
} |
888
|
|
|
|
|
|
|
|
889
|
|
|
|
|
|
|
# print initialization routine |
890
|
|
|
|
|
|
|
|
891
|
8
|
|
|
|
|
61
|
print Q(<<"EOF"); |
892
|
|
|
|
|
|
|
##ifdef __cplusplus |
893
|
|
|
|
|
|
|
#extern "C" |
894
|
|
|
|
|
|
|
##endif |
895
|
|
|
|
|
|
|
EOF |
896
|
|
|
|
|
|
|
|
897
|
8
|
|
|
|
|
62
|
print Q(<<"EOF"); |
898
|
|
|
|
|
|
|
#XS_EXTERNAL(boot_$self->{Module_cname}); /* prototype to pass -Wmissing-prototypes */ |
899
|
|
|
|
|
|
|
#XS_EXTERNAL(boot_$self->{Module_cname}) |
900
|
|
|
|
|
|
|
#[[ |
901
|
|
|
|
|
|
|
##if PERL_VERSION_LE(5, 21, 5) |
902
|
|
|
|
|
|
|
# dVAR; dXSARGS; |
903
|
|
|
|
|
|
|
##else |
904
|
|
|
|
|
|
|
# dVAR; ${\($self->{WantVersionChk} ? |
905
|
8
|
100
|
|
|
|
58
|
'dXSBOOTARGSXSAPIVERCHK;' : 'dXSBOOTARGSAPIVERCHK;')} |
906
|
|
|
|
|
|
|
##endif |
907
|
|
|
|
|
|
|
EOF |
908
|
|
|
|
|
|
|
|
909
|
|
|
|
|
|
|
#Under 5.8.x and lower, newXS is declared in proto.h as expecting a non-const |
910
|
|
|
|
|
|
|
#file name argument. If the wrong qualifier is used, it causes breakage with |
911
|
|
|
|
|
|
|
#C++ compilers and warnings with recent gcc. |
912
|
|
|
|
|
|
|
#-Wall: if there is no $self->{Full_func_name} there are no xsubs in this .xs |
913
|
|
|
|
|
|
|
#so 'file' is unused |
914
|
8
|
50
|
|
|
|
64
|
print Q(<<"EOF") if $self->{Full_func_name}; |
915
|
|
|
|
|
|
|
##if PERL_VERSION_LE(5, 8, 999) /* PERL_VERSION_LT is 5.33+ */ |
916
|
|
|
|
|
|
|
# char* file = __FILE__; |
917
|
|
|
|
|
|
|
##else |
918
|
|
|
|
|
|
|
# const char* file = __FILE__; |
919
|
|
|
|
|
|
|
##endif |
920
|
|
|
|
|
|
|
# |
921
|
|
|
|
|
|
|
# PERL_UNUSED_VAR(file); |
922
|
|
|
|
|
|
|
EOF |
923
|
|
|
|
|
|
|
|
924
|
8
|
|
|
|
|
62
|
print Q("#\n"); |
925
|
|
|
|
|
|
|
|
926
|
8
|
|
|
|
|
57
|
print Q(<<"EOF"); |
927
|
|
|
|
|
|
|
# PERL_UNUSED_VAR(cv); /* -W */ |
928
|
|
|
|
|
|
|
# PERL_UNUSED_VAR(items); /* -W */ |
929
|
|
|
|
|
|
|
EOF |
930
|
|
|
|
|
|
|
|
931
|
8
|
100
|
|
|
|
45
|
if( $self->{WantVersionChk}){ |
932
|
7
|
|
|
|
|
20
|
print Q(<<"EOF") ; |
933
|
|
|
|
|
|
|
##if PERL_VERSION_LE(5, 21, 5) |
934
|
|
|
|
|
|
|
# XS_VERSION_BOOTCHECK; |
935
|
|
|
|
|
|
|
## ifdef XS_APIVERSION_BOOTCHECK |
936
|
|
|
|
|
|
|
# XS_APIVERSION_BOOTCHECK; |
937
|
|
|
|
|
|
|
## endif |
938
|
|
|
|
|
|
|
##endif |
939
|
|
|
|
|
|
|
|
940
|
|
|
|
|
|
|
EOF |
941
|
|
|
|
|
|
|
} else { |
942
|
1
|
|
|
|
|
3
|
print Q(<<"EOF") ; |
943
|
|
|
|
|
|
|
##if PERL_VERSION_LE(5, 21, 5) && defined(XS_APIVERSION_BOOTCHECK) |
944
|
|
|
|
|
|
|
# XS_APIVERSION_BOOTCHECK; |
945
|
|
|
|
|
|
|
##endif |
946
|
|
|
|
|
|
|
|
947
|
|
|
|
|
|
|
EOF |
948
|
|
|
|
|
|
|
} |
949
|
|
|
|
|
|
|
|
950
|
8
|
100
|
66
|
|
|
149
|
print Q(<<"EOF") if defined $self->{XsubAliases} or defined $self->{interfaces}; |
951
|
|
|
|
|
|
|
# { |
952
|
|
|
|
|
|
|
# CV * cv; |
953
|
|
|
|
|
|
|
# |
954
|
|
|
|
|
|
|
EOF |
955
|
|
|
|
|
|
|
|
956
|
8
|
100
|
|
|
|
43
|
print Q(<<"EOF") if ($self->{Overload}); |
957
|
|
|
|
|
|
|
# /* register the overloading (type 'A') magic */ |
958
|
|
|
|
|
|
|
##if PERL_VERSION_LE(5, 8, 999) /* PERL_VERSION_LT is 5.33+ */ |
959
|
|
|
|
|
|
|
# PL_amagic_generation++; |
960
|
|
|
|
|
|
|
##endif |
961
|
|
|
|
|
|
|
# /* The magic for overload gets a GV* via gv_fetchmeth as */ |
962
|
|
|
|
|
|
|
# /* mentioned above, and looks in the SV* slot of it for */ |
963
|
|
|
|
|
|
|
# /* the "fallback" status. */ |
964
|
|
|
|
|
|
|
# sv_setsv( |
965
|
|
|
|
|
|
|
# get_sv( "$self->{Package}::()", TRUE ), |
966
|
|
|
|
|
|
|
# $self->{Fallback} |
967
|
|
|
|
|
|
|
# ); |
968
|
|
|
|
|
|
|
EOF |
969
|
|
|
|
|
|
|
|
970
|
8
|
|
|
|
|
25
|
print @{ $self->{InitFileCode} }; |
|
8
|
|
|
|
|
50
|
|
971
|
|
|
|
|
|
|
|
972
|
8
|
100
|
66
|
|
|
139
|
print Q(<<"EOF") if defined $self->{XsubAliases} or defined $self->{interfaces}; |
973
|
|
|
|
|
|
|
# } |
974
|
|
|
|
|
|
|
EOF |
975
|
|
|
|
|
|
|
|
976
|
8
|
100
|
|
|
|
23
|
if (@{ $BootCode_ref }) { |
|
8
|
|
|
|
|
31
|
|
977
|
1
|
|
|
|
|
4
|
print "\n /* Initialisation Section */\n\n"; |
978
|
1
|
|
|
|
|
5
|
@{ $self->{line} } = @{ $BootCode_ref }; |
|
1
|
|
|
|
|
9
|
|
|
1
|
|
|
|
|
3
|
|
979
|
1
|
|
|
|
|
6
|
$self->print_section(); |
980
|
1
|
|
|
|
|
3
|
print "\n /* End of Initialisation Section */\n\n"; |
981
|
|
|
|
|
|
|
} |
982
|
|
|
|
|
|
|
|
983
|
8
|
|
|
|
|
36
|
print Q(<<'EOF'); |
984
|
|
|
|
|
|
|
##if PERL_VERSION_LE(5, 21, 5) |
985
|
|
|
|
|
|
|
## if PERL_VERSION_GE(5, 9, 0) |
986
|
|
|
|
|
|
|
# if (PL_unitcheckav) |
987
|
|
|
|
|
|
|
# call_list(PL_scopestack_ix, PL_unitcheckav); |
988
|
|
|
|
|
|
|
## endif |
989
|
|
|
|
|
|
|
# XSRETURN_YES; |
990
|
|
|
|
|
|
|
##else |
991
|
|
|
|
|
|
|
# Perl_xs_boot_epilog(aTHX_ ax); |
992
|
|
|
|
|
|
|
##endif |
993
|
|
|
|
|
|
|
#]] |
994
|
|
|
|
|
|
|
# |
995
|
|
|
|
|
|
|
EOF |
996
|
|
|
|
|
|
|
|
997
|
|
|
|
|
|
|
warn("Please specify prototyping behavior for $self->{filename} (see perlxs manual)\n") |
998
|
8
|
50
|
|
|
|
45
|
unless $self->{ProtoUsed}; |
999
|
|
|
|
|
|
|
|
1000
|
8
|
|
|
|
|
203
|
chdir($orig_cwd); |
1001
|
8
|
|
|
|
|
141
|
select($orig_fh); |
1002
|
8
|
100
|
|
|
|
70
|
untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT; |
1003
|
8
|
|
|
|
|
141
|
close $self->{FH}; |
1004
|
|
|
|
|
|
|
|
1005
|
8
|
|
|
|
|
1137
|
return 1; |
1006
|
|
|
|
|
|
|
} |
1007
|
|
|
|
|
|
|
|
1008
|
|
|
|
|
|
|
sub report_error_count { |
1009
|
2
|
100
|
|
2
|
1
|
562199
|
if (@_) { |
1010
|
1
|
|
50
|
|
|
8
|
return $_[0]->{errors}||0; |
1011
|
|
|
|
|
|
|
} |
1012
|
|
|
|
|
|
|
else { |
1013
|
1
|
|
50
|
|
|
63
|
return $Singleton->{errors}||0; |
1014
|
|
|
|
|
|
|
} |
1015
|
|
|
|
|
|
|
} |
1016
|
|
|
|
|
|
|
*errors = \&report_error_count; |
1017
|
|
|
|
|
|
|
|
1018
|
|
|
|
|
|
|
# Input: ($self, $_, @{ $self->{line} }) == unparsed input. |
1019
|
|
|
|
|
|
|
# Output: ($_, @{ $self->{line} }) == (rest of line, following lines). |
1020
|
|
|
|
|
|
|
# Return: the matched keyword if found, otherwise 0 |
1021
|
|
|
|
|
|
|
sub check_keyword { |
1022
|
613
|
|
|
613
|
0
|
1004
|
my $self = shift; |
1023
|
613
|
|
66
|
|
|
2162
|
$_ = shift(@{ $self->{line} }) while !/\S/ && @{ $self->{line} }; |
|
54
|
|
|
|
|
182
|
|
|
54
|
|
|
|
|
259
|
|
1024
|
613
|
100
|
|
|
|
21160
|
s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2; |
1025
|
|
|
|
|
|
|
} |
1026
|
|
|
|
|
|
|
|
1027
|
|
|
|
|
|
|
sub print_section { |
1028
|
48
|
|
|
48
|
0
|
77
|
my $self = shift; |
1029
|
|
|
|
|
|
|
|
1030
|
|
|
|
|
|
|
# the "do" is required for right semantics |
1031
|
48
|
|
33
|
|
|
76
|
do { $_ = shift(@{ $self->{line} }) } while !/\S/ && @{ $self->{line} }; |
|
0
|
|
|
|
|
0
|
|
|
48
|
|
|
|
|
68
|
|
|
48
|
|
|
|
|
249
|
|
1032
|
|
|
|
|
|
|
|
1033
|
48
|
|
|
|
|
132
|
my $consumed_code = ''; |
1034
|
|
|
|
|
|
|
|
1035
|
33
|
|
|
|
|
71
|
print("#line ", $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1], " \"", |
|
33
|
|
|
|
|
141
|
|
1036
|
|
|
|
|
|
|
escape_file_for_line_directive($self->{filepathname}), "\"\n") |
1037
|
48
|
100
|
100
|
|
|
341
|
if $self->{WantLineNumbers} && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/; |
|
|
|
66
|
|
|
|
|
1038
|
48
|
|
100
|
|
|
901
|
for (; defined($_) && !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { |
|
83
|
|
|
|
|
6127
|
|
1039
|
83
|
|
|
|
|
290
|
print "$_\n"; |
1040
|
83
|
|
|
|
|
361
|
$consumed_code .= "$_\n"; |
1041
|
|
|
|
|
|
|
} |
1042
|
48
|
100
|
|
|
|
212
|
print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers}; |
1043
|
|
|
|
|
|
|
|
1044
|
48
|
|
|
|
|
6432
|
return $consumed_code; |
1045
|
|
|
|
|
|
|
} |
1046
|
|
|
|
|
|
|
|
1047
|
|
|
|
|
|
|
sub merge_section { |
1048
|
5
|
|
|
5
|
0
|
11
|
my $self = shift; |
1049
|
5
|
|
|
|
|
11
|
my $in = ''; |
1050
|
|
|
|
|
|
|
|
1051
|
5
|
|
66
|
|
|
59
|
while (!/\S/ && @{ $self->{line} }) { |
|
5
|
|
|
|
|
46
|
|
1052
|
5
|
|
|
|
|
13
|
$_ = shift(@{ $self->{line} }); |
|
5
|
|
|
|
|
33
|
|
1053
|
|
|
|
|
|
|
} |
1054
|
|
|
|
|
|
|
|
1055
|
5
|
|
66
|
|
|
304
|
for (; defined($_) && !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { |
|
5
|
|
|
|
|
104
|
|
1056
|
5
|
|
|
|
|
75
|
$in .= "$_\n"; |
1057
|
|
|
|
|
|
|
} |
1058
|
5
|
|
|
|
|
17
|
chomp $in; |
1059
|
5
|
|
|
|
|
16
|
return $in; |
1060
|
|
|
|
|
|
|
} |
1061
|
|
|
|
|
|
|
|
1062
|
|
|
|
|
|
|
sub process_keyword { |
1063
|
220
|
|
|
220
|
0
|
523
|
my($self, $pattern) = @_; |
1064
|
|
|
|
|
|
|
|
1065
|
220
|
|
|
|
|
494
|
while (my $kwd = $self->check_keyword($pattern)) { |
1066
|
53
|
|
|
|
|
160
|
my $method = $kwd . "_handler"; |
1067
|
53
|
|
|
|
|
335
|
$self->$method($_); |
1068
|
|
|
|
|
|
|
} |
1069
|
|
|
|
|
|
|
} |
1070
|
|
|
|
|
|
|
|
1071
|
|
|
|
|
|
|
sub CASE_handler { |
1072
|
2
|
|
|
2
|
0
|
4
|
my $self = shift; |
1073
|
2
|
|
|
|
|
4
|
$_ = shift; |
1074
|
|
|
|
|
|
|
$self->blurt("Error: 'CASE:' after unconditional 'CASE:'") |
1075
|
2
|
50
|
66
|
|
|
20
|
if $self->{condnum} && $self->{cond} eq ''; |
1076
|
2
|
|
|
|
|
7
|
$self->{cond} = $_; |
1077
|
2
|
|
|
|
|
8
|
trim_whitespace($self->{cond}); |
1078
|
2
|
100
|
|
|
|
16
|
print " ", ($self->{condnum}++ ? " else" : ""), ($self->{cond} ? " if ($self->{cond})\n" : "\n"); |
|
|
50
|
|
|
|
|
|
1079
|
2
|
|
|
|
|
13
|
$_ = ''; |
1080
|
|
|
|
|
|
|
} |
1081
|
|
|
|
|
|
|
|
1082
|
|
|
|
|
|
|
sub INPUT_handler { |
1083
|
60
|
|
|
60
|
0
|
108
|
my $self = shift; |
1084
|
60
|
|
|
|
|
94
|
$_ = shift; |
1085
|
60
|
|
|
|
|
927
|
for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { |
|
63
|
|
|
|
|
486
|
|
1086
|
63
|
50
|
|
|
|
148
|
last if /^\s*NOT_IMPLEMENTED_YET/; |
1087
|
63
|
100
|
|
|
|
264
|
next unless /\S/; # skip blank lines |
1088
|
|
|
|
|
|
|
|
1089
|
56
|
|
|
|
|
205
|
trim_whitespace($_); |
1090
|
56
|
|
|
|
|
177
|
my $ln = $_; |
1091
|
|
|
|
|
|
|
|
1092
|
|
|
|
|
|
|
# remove trailing semicolon if no initialisation |
1093
|
56
|
100
|
|
|
|
284
|
s/\s*;$//g unless /[=;+].*\S/; |
1094
|
|
|
|
|
|
|
|
1095
|
|
|
|
|
|
|
# Process the length(foo) declarations |
1096
|
56
|
100
|
|
|
|
194
|
if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) { |
1097
|
1
|
|
|
|
|
5
|
print "\tSTRLEN\tSTRLEN_length_of_$2;\n"; |
1098
|
1
|
|
|
|
|
4
|
$self->{lengthof}->{$2} = undef; |
1099
|
1
|
|
|
|
|
4
|
$self->{deferred} .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;\n"; |
1100
|
|
|
|
|
|
|
} |
1101
|
|
|
|
|
|
|
|
1102
|
|
|
|
|
|
|
# check for optional initialisation code |
1103
|
56
|
|
|
|
|
110
|
my $var_init = ''; |
1104
|
56
|
100
|
|
|
|
227
|
$var_init = $1 if s/\s*([=;+].*)$//s; |
1105
|
56
|
|
|
|
|
107
|
$var_init =~ s/"/\\"/g; |
1106
|
|
|
|
|
|
|
# *sigh* It's valid to supply explicit input typemaps in the argument list... |
1107
|
56
|
|
|
|
|
117
|
my $is_overridden_typemap = $var_init =~ /ST\s*\(|\$arg\b/; |
1108
|
|
|
|
|
|
|
|
1109
|
56
|
|
|
|
|
210
|
s/\s+/ /g; |
1110
|
56
|
50
|
|
|
|
461
|
my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s |
1111
|
|
|
|
|
|
|
or $self->blurt("Error: invalid argument declaration '$ln'"), next; |
1112
|
|
|
|
|
|
|
|
1113
|
|
|
|
|
|
|
# Check for duplicate definitions |
1114
|
|
|
|
|
|
|
$self->blurt("Error: duplicate definition of argument '$var_name' ignored"), next |
1115
|
|
|
|
|
|
|
if $self->{arg_list}->{$var_name}++ |
1116
|
56
|
50
|
66
|
|
|
414
|
or defined $self->{argtype_seen}->{$var_name} and not $self->{processing_arg_with_types}; |
|
|
|
33
|
|
|
|
|
1117
|
|
|
|
|
|
|
|
1118
|
56
|
|
|
|
|
141
|
$self->{thisdone} |= $var_name eq "THIS"; |
1119
|
56
|
|
|
|
|
95
|
$self->{retvaldone} |= $var_name eq "RETVAL"; |
1120
|
56
|
|
|
|
|
119
|
$self->{var_types}->{$var_name} = $var_type; |
1121
|
|
|
|
|
|
|
# XXXX This check is a safeguard against the unfinished conversion of |
1122
|
|
|
|
|
|
|
# generate_init(). When generate_init() is fixed, |
1123
|
|
|
|
|
|
|
# one can use 2-args map_type() unconditionally. |
1124
|
56
|
|
|
|
|
84
|
my $printed_name; |
1125
|
56
|
50
|
|
|
|
133
|
if ($var_type =~ / \( \s* \* \s* \) /x) { |
1126
|
|
|
|
|
|
|
# Function pointers are not yet supported with output_init()! |
1127
|
0
|
|
|
|
|
0
|
print "\t" . map_type($self, $var_type, $var_name); |
1128
|
0
|
|
|
|
|
0
|
$printed_name = 1; |
1129
|
|
|
|
|
|
|
} |
1130
|
|
|
|
|
|
|
else { |
1131
|
56
|
|
|
|
|
175
|
print "\t" . map_type($self, $var_type, undef); |
1132
|
56
|
|
|
|
|
170
|
$printed_name = 0; |
1133
|
|
|
|
|
|
|
} |
1134
|
56
|
|
|
|
|
135
|
$self->{var_num} = $self->{args_match}->{$var_name}; |
1135
|
|
|
|
|
|
|
|
1136
|
56
|
100
|
|
|
|
130
|
if ($self->{var_num}) { |
1137
|
52
|
|
|
|
|
182
|
my $typemap = $self->{typemap}->get_typemap(ctype => $var_type); |
1138
|
52
|
0
|
33
|
|
|
126
|
$self->report_typemap_failure($self->{typemap}, $var_type, "death") |
1139
|
|
|
|
|
|
|
if not $typemap and not $is_overridden_typemap; |
1140
|
52
|
|
50
|
|
|
306
|
$self->{proto_arg}->[$self->{var_num}] = ($typemap && $typemap->proto) || "\$"; |
1141
|
|
|
|
|
|
|
} |
1142
|
56
|
50
|
|
|
|
133
|
$self->{func_args} =~ s/\b($var_name)\b/&$1/ if $var_addr; |
1143
|
56
|
100
|
66
|
|
|
441
|
if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/ |
|
|
100
|
66
|
|
|
|
|
|
|
50
|
100
|
|
|
|
|
1144
|
|
|
|
|
|
|
or $self->{in_out}->{$var_name} and $self->{in_out}->{$var_name} =~ /^OUT/ |
1145
|
|
|
|
|
|
|
and $var_init !~ /\S/) { |
1146
|
3
|
50
|
|
|
|
8
|
if ($printed_name) { |
1147
|
0
|
|
|
|
|
0
|
print ";\n"; |
1148
|
|
|
|
|
|
|
} |
1149
|
|
|
|
|
|
|
else { |
1150
|
3
|
|
|
|
|
12
|
print "\t$var_name;\n"; |
1151
|
|
|
|
|
|
|
} |
1152
|
|
|
|
|
|
|
} |
1153
|
|
|
|
|
|
|
elsif ($var_init =~ /\S/) { |
1154
|
|
|
|
|
|
|
$self->output_init( { |
1155
|
|
|
|
|
|
|
type => $var_type, |
1156
|
|
|
|
|
|
|
num => $self->{var_num}, |
1157
|
2
|
|
|
|
|
48
|
var => $var_name, |
1158
|
|
|
|
|
|
|
init => $var_init, |
1159
|
|
|
|
|
|
|
printed_name => $printed_name, |
1160
|
|
|
|
|
|
|
} ); |
1161
|
|
|
|
|
|
|
} |
1162
|
|
|
|
|
|
|
elsif ($self->{var_num}) { |
1163
|
|
|
|
|
|
|
$self->generate_init( { |
1164
|
|
|
|
|
|
|
type => $var_type, |
1165
|
|
|
|
|
|
|
num => $self->{var_num}, |
1166
|
51
|
|
|
|
|
395
|
var => $var_name, |
1167
|
|
|
|
|
|
|
printed_name => $printed_name, |
1168
|
|
|
|
|
|
|
} ); |
1169
|
|
|
|
|
|
|
} |
1170
|
|
|
|
|
|
|
else { |
1171
|
0
|
|
|
|
|
0
|
print ";\n"; |
1172
|
|
|
|
|
|
|
} |
1173
|
|
|
|
|
|
|
} |
1174
|
|
|
|
|
|
|
} |
1175
|
|
|
|
|
|
|
|
1176
|
|
|
|
|
|
|
sub OUTPUT_handler { |
1177
|
31
|
|
|
31
|
0
|
53
|
my $self = shift; |
1178
|
31
|
|
|
|
|
63
|
$self->{have_OUTPUT} = 1; |
1179
|
|
|
|
|
|
|
|
1180
|
31
|
|
|
|
|
48
|
$_ = shift; |
1181
|
31
|
|
|
|
|
319
|
for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { |
|
50
|
|
|
|
|
340
|
|
1182
|
50
|
100
|
|
|
|
230
|
next unless /\S/; |
1183
|
31
|
50
|
|
|
|
6135
|
if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) { |
1184
|
0
|
0
|
|
|
|
0
|
$self->{DoSetMagic} = ($1 eq "ENABLE" ? 1 : 0); |
1185
|
0
|
|
|
|
|
0
|
next; |
1186
|
|
|
|
|
|
|
} |
1187
|
31
|
|
|
|
|
205
|
my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s; |
1188
|
|
|
|
|
|
|
$self->blurt("Error: duplicate OUTPUT argument '$outarg' ignored"), next |
1189
|
31
|
50
|
|
|
|
137
|
if $self->{outargs}->{$outarg}++; |
1190
|
31
|
100
|
66
|
|
|
216
|
if (!$self->{gotRETVAL} and $outarg eq 'RETVAL') { |
1191
|
|
|
|
|
|
|
# deal with RETVAL last |
1192
|
23
|
|
|
|
|
60
|
$self->{RETVAL_code} = $outcode; |
1193
|
23
|
|
|
|
|
36
|
$self->{gotRETVAL} = 1; |
1194
|
23
|
|
|
|
|
42
|
next; |
1195
|
|
|
|
|
|
|
} |
1196
|
|
|
|
|
|
|
$self->blurt("Error: OUTPUT $outarg not an argument"), next |
1197
|
8
|
50
|
|
|
|
36
|
unless defined($self->{args_match}->{$outarg}); |
1198
|
|
|
|
|
|
|
$self->blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next |
1199
|
8
|
50
|
|
|
|
21
|
unless defined $self->{var_types}->{$outarg}; |
1200
|
8
|
|
|
|
|
18
|
$self->{var_num} = $self->{args_match}->{$outarg}; |
1201
|
8
|
50
|
|
|
|
19
|
if ($outcode) { |
1202
|
0
|
|
|
|
|
0
|
print "\t$outcode\n"; |
1203
|
0
|
0
|
|
|
|
0
|
print "\tSvSETMAGIC(ST(" , $self->{var_num} - 1 , "));\n" if $self->{DoSetMagic}; |
1204
|
|
|
|
|
|
|
} |
1205
|
|
|
|
|
|
|
else { |
1206
|
|
|
|
|
|
|
$self->generate_output( { |
1207
|
|
|
|
|
|
|
type => $self->{var_types}->{$outarg}, |
1208
|
|
|
|
|
|
|
num => $self->{var_num}, |
1209
|
|
|
|
|
|
|
var => $outarg, |
1210
|
|
|
|
|
|
|
do_setmagic => $self->{DoSetMagic}, |
1211
|
8
|
|
|
|
|
51
|
do_push => undef, |
1212
|
|
|
|
|
|
|
} ); |
1213
|
|
|
|
|
|
|
} |
1214
|
|
|
|
|
|
|
delete $self->{in_out}->{$outarg} # No need to auto-OUTPUT |
1215
|
8
|
50
|
33
|
|
|
77
|
if exists $self->{in_out}->{$outarg} and $self->{in_out}->{$outarg} =~ /OUT$/; |
1216
|
|
|
|
|
|
|
} |
1217
|
|
|
|
|
|
|
} |
1218
|
|
|
|
|
|
|
|
1219
|
|
|
|
|
|
|
sub C_ARGS_handler { |
1220
|
4
|
|
|
4
|
0
|
14
|
my $self = shift; |
1221
|
4
|
|
|
|
|
9
|
$_ = shift; |
1222
|
4
|
|
|
|
|
15
|
my $in = $self->merge_section(); |
1223
|
|
|
|
|
|
|
|
1224
|
4
|
|
|
|
|
18
|
trim_whitespace($in); |
1225
|
4
|
|
|
|
|
20
|
$self->{func_args} = $in; |
1226
|
|
|
|
|
|
|
} |
1227
|
|
|
|
|
|
|
|
1228
|
|
|
|
|
|
|
sub INTERFACE_MACRO_handler { |
1229
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
1230
|
0
|
|
|
|
|
0
|
$_ = shift; |
1231
|
0
|
|
|
|
|
0
|
my $in = $self->merge_section(); |
1232
|
|
|
|
|
|
|
|
1233
|
0
|
|
|
|
|
0
|
trim_whitespace($in); |
1234
|
0
|
0
|
|
|
|
0
|
if ($in =~ /\s/) { # two |
1235
|
0
|
|
|
|
|
0
|
($self->{interface_macro}, $self->{interface_macro_set}) = split ' ', $in; |
1236
|
|
|
|
|
|
|
} |
1237
|
|
|
|
|
|
|
else { |
1238
|
0
|
|
|
|
|
0
|
$self->{interface_macro} = $in; |
1239
|
0
|
|
|
|
|
0
|
$self->{interface_macro_set} = 'UNKNOWN_CVT'; # catch later |
1240
|
|
|
|
|
|
|
} |
1241
|
0
|
|
|
|
|
0
|
$self->{interface} = 1; # local |
1242
|
0
|
|
|
|
|
0
|
$self->{interfaces} = 1; # global |
1243
|
|
|
|
|
|
|
} |
1244
|
|
|
|
|
|
|
|
1245
|
|
|
|
|
|
|
sub INTERFACE_handler { |
1246
|
1
|
|
|
1
|
0
|
4
|
my $self = shift; |
1247
|
1
|
|
|
|
|
1
|
$_ = shift; |
1248
|
1
|
|
|
|
|
5
|
my $in = $self->merge_section(); |
1249
|
|
|
|
|
|
|
|
1250
|
1
|
|
|
|
|
9
|
trim_whitespace($in); |
1251
|
|
|
|
|
|
|
|
1252
|
1
|
|
|
|
|
7
|
foreach (split /[\s,]+/, $in) { |
1253
|
1
|
|
|
|
|
2
|
my $iface_name = $_; |
1254
|
1
|
|
|
|
|
14
|
$iface_name =~ s/^$self->{Prefix}//; |
1255
|
1
|
|
|
|
|
4
|
$self->{Interfaces}->{$iface_name} = $_; |
1256
|
|
|
|
|
|
|
} |
1257
|
1
|
|
|
|
|
7
|
print Q(<<"EOF"); |
1258
|
|
|
|
|
|
|
# XSFUNCTION = $self->{interface_macro}($self->{ret_type},cv,XSANY.any_dptr); |
1259
|
|
|
|
|
|
|
EOF |
1260
|
1
|
|
|
|
|
3
|
$self->{interface} = 1; # local |
1261
|
1
|
|
|
|
|
4
|
$self->{interfaces} = 1; # global |
1262
|
|
|
|
|
|
|
} |
1263
|
|
|
|
|
|
|
|
1264
|
|
|
|
|
|
|
sub CLEANUP_handler { |
1265
|
1
|
|
|
1
|
0
|
3
|
my $self = shift; |
1266
|
1
|
|
|
|
|
2
|
$self->print_section(); |
1267
|
|
|
|
|
|
|
} |
1268
|
|
|
|
|
|
|
|
1269
|
|
|
|
|
|
|
sub PREINIT_handler { |
1270
|
4
|
|
|
4
|
0
|
10
|
my $self = shift; |
1271
|
4
|
|
|
|
|
13
|
$self->print_section(); |
1272
|
|
|
|
|
|
|
} |
1273
|
|
|
|
|
|
|
|
1274
|
|
|
|
|
|
|
sub POSTCALL_handler { |
1275
|
1
|
|
|
1
|
0
|
3
|
my $self = shift; |
1276
|
1
|
|
|
|
|
3
|
$self->print_section(); |
1277
|
|
|
|
|
|
|
} |
1278
|
|
|
|
|
|
|
|
1279
|
|
|
|
|
|
|
sub INIT_handler { |
1280
|
2
|
|
|
2
|
0
|
6
|
my $self = shift; |
1281
|
2
|
|
|
|
|
7
|
$self->print_section(); |
1282
|
|
|
|
|
|
|
} |
1283
|
|
|
|
|
|
|
|
1284
|
|
|
|
|
|
|
sub get_aliases { |
1285
|
16
|
|
|
16
|
0
|
28
|
my $self = shift; |
1286
|
16
|
|
|
|
|
38
|
my ($line) = @_; |
1287
|
16
|
|
|
|
|
28
|
my ($orig) = $line; |
1288
|
|
|
|
|
|
|
|
1289
|
|
|
|
|
|
|
# Parse alias definitions |
1290
|
|
|
|
|
|
|
# format is |
1291
|
|
|
|
|
|
|
# alias = value alias = value ... |
1292
|
|
|
|
|
|
|
|
1293
|
16
|
|
|
|
|
111
|
while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) { |
1294
|
16
|
|
|
|
|
55
|
my ($alias, $value) = ($1, $2); |
1295
|
16
|
|
|
|
|
35
|
my $orig_alias = $alias; |
1296
|
|
|
|
|
|
|
|
1297
|
|
|
|
|
|
|
# check for optional package definition in the alias |
1298
|
16
|
100
|
|
|
|
92
|
$alias = $self->{Packprefix} . $alias if $alias !~ /::/; |
1299
|
|
|
|
|
|
|
|
1300
|
|
|
|
|
|
|
# check for duplicate alias name & duplicate value |
1301
|
|
|
|
|
|
|
Warn( $self, "Warning: Ignoring duplicate alias '$orig_alias'") |
1302
|
16
|
50
|
|
|
|
67
|
if defined $self->{XsubAliases}->{$alias}; |
1303
|
|
|
|
|
|
|
|
1304
|
|
|
|
|
|
|
Warn( $self, "Warning: Aliases '$orig_alias' and '$self->{XsubAliasValues}->{$value}' have identical values") |
1305
|
16
|
50
|
|
|
|
51
|
if $self->{XsubAliasValues}->{$value}; |
1306
|
|
|
|
|
|
|
|
1307
|
16
|
|
|
|
|
56
|
$self->{XsubAliases}->{$alias} = $value; |
1308
|
16
|
|
|
|
|
128
|
$self->{XsubAliasValues}->{$value} = $orig_alias; |
1309
|
|
|
|
|
|
|
} |
1310
|
|
|
|
|
|
|
|
1311
|
16
|
50
|
|
|
|
53
|
blurt( $self, "Error: Cannot parse ALIAS definitions from '$orig'") |
1312
|
|
|
|
|
|
|
if $line; |
1313
|
|
|
|
|
|
|
} |
1314
|
|
|
|
|
|
|
|
1315
|
|
|
|
|
|
|
sub ATTRS_handler { |
1316
|
1
|
|
|
1
|
0
|
2
|
my $self = shift; |
1317
|
1
|
|
|
|
|
2
|
$_ = shift; |
1318
|
|
|
|
|
|
|
|
1319
|
1
|
|
|
|
|
166
|
for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { |
|
1
|
|
|
|
|
13
|
|
1320
|
1
|
50
|
|
|
|
13
|
next unless /\S/; |
1321
|
1
|
|
|
|
|
6
|
trim_whitespace($_); |
1322
|
1
|
|
|
|
|
2
|
push @{ $self->{Attributes} }, $_; |
|
1
|
|
|
|
|
4
|
|
1323
|
|
|
|
|
|
|
} |
1324
|
|
|
|
|
|
|
} |
1325
|
|
|
|
|
|
|
|
1326
|
|
|
|
|
|
|
sub ALIAS_handler { |
1327
|
6
|
|
|
6
|
0
|
22
|
my $self = shift; |
1328
|
6
|
|
|
|
|
14
|
$_ = shift; |
1329
|
|
|
|
|
|
|
|
1330
|
6
|
|
|
|
|
408
|
for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { |
|
22
|
|
|
|
|
141
|
|
1331
|
22
|
100
|
|
|
|
154
|
next unless /\S/; |
1332
|
16
|
|
|
|
|
66
|
trim_whitespace($_); |
1333
|
16
|
50
|
|
|
|
78
|
$self->get_aliases($_) if $_; |
1334
|
|
|
|
|
|
|
} |
1335
|
|
|
|
|
|
|
} |
1336
|
|
|
|
|
|
|
|
1337
|
|
|
|
|
|
|
sub OVERLOAD_handler { |
1338
|
1
|
|
|
1
|
0
|
3
|
my $self = shift; |
1339
|
1
|
|
|
|
|
1
|
$_ = shift; |
1340
|
|
|
|
|
|
|
|
1341
|
1
|
|
|
|
|
122
|
for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { |
|
1
|
|
|
|
|
12
|
|
1342
|
1
|
50
|
|
|
|
8
|
next unless /\S/; |
1343
|
1
|
|
|
|
|
5
|
trim_whitespace($_); |
1344
|
1
|
|
|
|
|
7
|
while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) { |
1345
|
1
|
50
|
|
|
|
5
|
$self->{Overload} = 1 unless $self->{Overload}; |
1346
|
1
|
|
|
|
|
6
|
my $overload = "$self->{Package}\::(".$1; |
1347
|
1
|
|
|
|
|
2
|
push(@{ $self->{InitFileCode} }, |
|
1
|
|
|
|
|
10
|
|
1348
|
|
|
|
|
|
|
" (void)$self->{newXS}(\"$overload\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n"); |
1349
|
|
|
|
|
|
|
} |
1350
|
|
|
|
|
|
|
} |
1351
|
|
|
|
|
|
|
} |
1352
|
|
|
|
|
|
|
|
1353
|
|
|
|
|
|
|
sub FALLBACK_handler { |
1354
|
1
|
|
|
1
|
0
|
6
|
my ($self, $setting) = @_; |
1355
|
|
|
|
|
|
|
|
1356
|
|
|
|
|
|
|
# the rest of the current line should contain either TRUE, |
1357
|
|
|
|
|
|
|
# FALSE or UNDEF |
1358
|
|
|
|
|
|
|
|
1359
|
1
|
|
|
|
|
5
|
trim_whitespace($setting); |
1360
|
1
|
|
|
|
|
2
|
$setting = uc($setting); |
1361
|
|
|
|
|
|
|
|
1362
|
1
|
|
|
|
|
27
|
my %map = ( |
1363
|
|
|
|
|
|
|
TRUE => "&PL_sv_yes", 1 => "&PL_sv_yes", |
1364
|
|
|
|
|
|
|
FALSE => "&PL_sv_no", 0 => "&PL_sv_no", |
1365
|
|
|
|
|
|
|
UNDEF => "&PL_sv_undef", |
1366
|
|
|
|
|
|
|
); |
1367
|
|
|
|
|
|
|
|
1368
|
|
|
|
|
|
|
# check for valid FALLBACK value |
1369
|
1
|
50
|
|
|
|
14
|
$self->death("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{$setting}; |
1370
|
|
|
|
|
|
|
|
1371
|
1
|
|
|
|
|
15
|
$self->{Fallback} = $map{$setting}; |
1372
|
|
|
|
|
|
|
} |
1373
|
|
|
|
|
|
|
|
1374
|
|
|
|
|
|
|
|
1375
|
|
|
|
|
|
|
sub REQUIRE_handler { |
1376
|
|
|
|
|
|
|
# the rest of the current line should contain a version number |
1377
|
1
|
|
|
1
|
0
|
4
|
my ($self, $ver) = @_; |
1378
|
|
|
|
|
|
|
|
1379
|
1
|
|
|
|
|
5
|
trim_whitespace($ver); |
1380
|
|
|
|
|
|
|
|
1381
|
1
|
50
|
|
|
|
3
|
$self->death("Error: REQUIRE expects a version number") |
1382
|
|
|
|
|
|
|
unless $ver; |
1383
|
|
|
|
|
|
|
|
1384
|
|
|
|
|
|
|
# check that the version number is of the form n.n |
1385
|
1
|
50
|
|
|
|
7
|
$self->death("Error: REQUIRE: expected a number, got '$ver'") |
1386
|
|
|
|
|
|
|
unless $ver =~ /^\d+(\.\d*)?/; |
1387
|
|
|
|
|
|
|
|
1388
|
1
|
50
|
|
|
|
11
|
$self->death("Error: xsubpp $ver (or better) required--this is only $VERSION.") |
1389
|
|
|
|
|
|
|
unless $VERSION >= $ver; |
1390
|
|
|
|
|
|
|
} |
1391
|
|
|
|
|
|
|
|
1392
|
|
|
|
|
|
|
sub VERSIONCHECK_handler { |
1393
|
|
|
|
|
|
|
# the rest of the current line should contain either ENABLE or |
1394
|
|
|
|
|
|
|
# DISABLE |
1395
|
1
|
|
|
1
|
0
|
8
|
my ($self, $setting) = @_; |
1396
|
|
|
|
|
|
|
|
1397
|
1
|
|
|
|
|
8
|
trim_whitespace($setting); |
1398
|
|
|
|
|
|
|
|
1399
|
|
|
|
|
|
|
# check for ENABLE/DISABLE |
1400
|
1
|
50
|
|
|
|
17
|
$self->death("Error: VERSIONCHECK: ENABLE/DISABLE") |
1401
|
|
|
|
|
|
|
unless $setting =~ /^(ENABLE|DISABLE)/i; |
1402
|
|
|
|
|
|
|
|
1403
|
1
|
50
|
|
|
|
6
|
$self->{WantVersionChk} = 1 if $1 eq 'ENABLE'; |
1404
|
1
|
50
|
|
|
|
9
|
$self->{WantVersionChk} = 0 if $1 eq 'DISABLE'; |
1405
|
|
|
|
|
|
|
|
1406
|
|
|
|
|
|
|
} |
1407
|
|
|
|
|
|
|
|
1408
|
|
|
|
|
|
|
sub PROTOTYPE_handler { |
1409
|
1
|
|
|
1
|
0
|
3
|
my $self = shift; |
1410
|
1
|
|
|
|
|
2
|
$_ = shift; |
1411
|
|
|
|
|
|
|
|
1412
|
1
|
|
|
|
|
2
|
my $specified; |
1413
|
|
|
|
|
|
|
|
1414
|
|
|
|
|
|
|
$self->death("Error: Only 1 PROTOTYPE definition allowed per xsub") |
1415
|
1
|
50
|
|
|
|
5
|
if $self->{proto_in_this_xsub}++; |
1416
|
|
|
|
|
|
|
|
1417
|
1
|
|
|
|
|
118
|
for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { |
|
1
|
|
|
|
|
10
|
|
1418
|
1
|
50
|
|
|
|
7
|
next unless /\S/; |
1419
|
1
|
|
|
|
|
2
|
$specified = 1; |
1420
|
1
|
|
|
|
|
6
|
trim_whitespace($_); |
1421
|
1
|
50
|
|
|
|
12
|
if ($_ eq 'DISABLE') { |
|
|
50
|
|
|
|
|
|
1422
|
0
|
|
|
|
|
0
|
$self->{ProtoThisXSUB} = 0; |
1423
|
|
|
|
|
|
|
} |
1424
|
|
|
|
|
|
|
elsif ($_ eq 'ENABLE') { |
1425
|
0
|
|
|
|
|
0
|
$self->{ProtoThisXSUB} = 1; |
1426
|
|
|
|
|
|
|
} |
1427
|
|
|
|
|
|
|
else { |
1428
|
|
|
|
|
|
|
# remove any whitespace |
1429
|
1
|
|
|
|
|
2
|
s/\s+//g; |
1430
|
1
|
50
|
|
|
|
4
|
$self->death("Error: Invalid prototype '$_'") |
1431
|
|
|
|
|
|
|
unless valid_proto_string($_); |
1432
|
1
|
|
|
|
|
4
|
$self->{ProtoThisXSUB} = C_string($_); |
1433
|
|
|
|
|
|
|
} |
1434
|
|
|
|
|
|
|
} |
1435
|
|
|
|
|
|
|
|
1436
|
|
|
|
|
|
|
# If no prototype specified, then assume empty prototype "" |
1437
|
1
|
50
|
|
|
|
4
|
$self->{ProtoThisXSUB} = 2 unless $specified; |
1438
|
|
|
|
|
|
|
|
1439
|
1
|
|
|
|
|
5
|
$self->{ProtoUsed} = 1; |
1440
|
|
|
|
|
|
|
} |
1441
|
|
|
|
|
|
|
|
1442
|
|
|
|
|
|
|
sub SCOPE_handler { |
1443
|
|
|
|
|
|
|
# Rest of line should be either ENABLE or DISABLE |
1444
|
1
|
|
|
1
|
0
|
5
|
my ($self, $setting) = @_; |
1445
|
|
|
|
|
|
|
|
1446
|
|
|
|
|
|
|
$self->death("Error: Only 1 SCOPE declaration allowed per xsub") |
1447
|
1
|
50
|
|
|
|
5
|
if $self->{scope_in_this_xsub}++; |
1448
|
|
|
|
|
|
|
|
1449
|
1
|
|
|
|
|
4
|
trim_whitespace($setting); |
1450
|
1
|
50
|
|
|
|
17
|
$self->death("Error: SCOPE: ENABLE/DISABLE") |
1451
|
|
|
|
|
|
|
unless $setting =~ /^(ENABLE|DISABLE)\b/i; |
1452
|
1
|
|
|
|
|
5
|
$self->{ScopeThisXSUB} = ( uc($1) eq 'ENABLE' ); |
1453
|
|
|
|
|
|
|
} |
1454
|
|
|
|
|
|
|
|
1455
|
|
|
|
|
|
|
sub PROTOTYPES_handler { |
1456
|
|
|
|
|
|
|
# the rest of the current line should contain either ENABLE or |
1457
|
|
|
|
|
|
|
# DISABLE |
1458
|
8
|
|
|
8
|
0
|
40
|
my ($self, $setting) = @_; |
1459
|
|
|
|
|
|
|
|
1460
|
8
|
|
|
|
|
57
|
trim_whitespace($setting); |
1461
|
|
|
|
|
|
|
|
1462
|
|
|
|
|
|
|
# check for ENABLE/DISABLE |
1463
|
8
|
50
|
|
|
|
139
|
$self->death("Error: PROTOTYPES: ENABLE/DISABLE") |
1464
|
|
|
|
|
|
|
unless $setting =~ /^(ENABLE|DISABLE)/i; |
1465
|
|
|
|
|
|
|
|
1466
|
8
|
100
|
|
|
|
72
|
$self->{WantPrototypes} = 1 if $1 eq 'ENABLE'; |
1467
|
8
|
100
|
|
|
|
50
|
$self->{WantPrototypes} = 0 if $1 eq 'DISABLE'; |
1468
|
8
|
|
|
|
|
31
|
$self->{ProtoUsed} = 1; |
1469
|
|
|
|
|
|
|
} |
1470
|
|
|
|
|
|
|
|
1471
|
|
|
|
|
|
|
sub EXPORT_XSUB_SYMBOLS_handler { |
1472
|
|
|
|
|
|
|
# the rest of the current line should contain either ENABLE or |
1473
|
|
|
|
|
|
|
# DISABLE |
1474
|
0
|
|
|
0
|
0
|
0
|
my ($self, $setting) = @_; |
1475
|
|
|
|
|
|
|
|
1476
|
0
|
|
|
|
|
0
|
trim_whitespace($setting); |
1477
|
|
|
|
|
|
|
|
1478
|
|
|
|
|
|
|
# check for ENABLE/DISABLE |
1479
|
0
|
0
|
|
|
|
0
|
$self->death("Error: EXPORT_XSUB_SYMBOLS: ENABLE/DISABLE") |
1480
|
|
|
|
|
|
|
unless $setting =~ /^(ENABLE|DISABLE)/i; |
1481
|
|
|
|
|
|
|
|
1482
|
0
|
0
|
|
|
|
0
|
my $xs_impl = $1 eq 'ENABLE' ? 'XS_EXTERNAL' : 'XS_INTERNAL'; |
1483
|
|
|
|
|
|
|
|
1484
|
0
|
|
|
|
|
0
|
print Q(<<"EOF"); |
1485
|
|
|
|
|
|
|
##undef XS_EUPXS |
1486
|
|
|
|
|
|
|
##if defined(PERL_EUPXS_ALWAYS_EXPORT) |
1487
|
|
|
|
|
|
|
## define XS_EUPXS(name) XS_EXTERNAL(name) |
1488
|
|
|
|
|
|
|
##elif defined(PERL_EUPXS_NEVER_EXPORT) |
1489
|
|
|
|
|
|
|
## define XS_EUPXS(name) XS_INTERNAL(name) |
1490
|
|
|
|
|
|
|
##else |
1491
|
|
|
|
|
|
|
## define XS_EUPXS(name) $xs_impl(name) |
1492
|
|
|
|
|
|
|
##endif |
1493
|
|
|
|
|
|
|
EOF |
1494
|
|
|
|
|
|
|
} |
1495
|
|
|
|
|
|
|
|
1496
|
|
|
|
|
|
|
|
1497
|
|
|
|
|
|
|
sub PushXSStack { |
1498
|
2
|
|
|
2
|
0
|
3
|
my $self = shift; |
1499
|
2
|
|
|
|
|
5
|
my %args = @_; |
1500
|
|
|
|
|
|
|
# Save the current file context. |
1501
|
2
|
|
|
|
|
28
|
push(@{ $self->{XSStack} }, { |
1502
|
|
|
|
|
|
|
type => 'file', |
1503
|
|
|
|
|
|
|
LastLine => $self->{lastline}, |
1504
|
|
|
|
|
|
|
LastLineNo => $self->{lastline_no}, |
1505
|
|
|
|
|
|
|
Line => $self->{line}, |
1506
|
|
|
|
|
|
|
LineNo => $self->{line_no}, |
1507
|
|
|
|
|
|
|
Filename => $self->{filename}, |
1508
|
|
|
|
|
|
|
Filepathname => $self->{filepathname}, |
1509
|
|
|
|
|
|
|
Handle => $self->{FH}, |
1510
|
2
|
|
|
|
|
4
|
IsPipe => scalar($self->{filename} =~ /\|\s*$/), |
1511
|
|
|
|
|
|
|
%args, |
1512
|
|
|
|
|
|
|
}); |
1513
|
|
|
|
|
|
|
|
1514
|
|
|
|
|
|
|
} |
1515
|
|
|
|
|
|
|
|
1516
|
|
|
|
|
|
|
sub INCLUDE_handler { |
1517
|
1
|
|
|
1
|
0
|
5
|
my $self = shift; |
1518
|
1
|
|
|
|
|
8
|
$_ = shift; |
1519
|
|
|
|
|
|
|
# the rest of the current line should contain a valid filename |
1520
|
|
|
|
|
|
|
|
1521
|
1
|
|
|
|
|
6
|
trim_whitespace($_); |
1522
|
|
|
|
|
|
|
|
1523
|
1
|
50
|
|
|
|
4
|
$self->death("INCLUDE: filename missing") |
1524
|
|
|
|
|
|
|
unless $_; |
1525
|
|
|
|
|
|
|
|
1526
|
1
|
50
|
|
|
|
10
|
$self->death("INCLUDE: output pipe is illegal") |
1527
|
|
|
|
|
|
|
if /^\s*\|/; |
1528
|
|
|
|
|
|
|
|
1529
|
|
|
|
|
|
|
# simple minded recursion detector |
1530
|
|
|
|
|
|
|
$self->death("INCLUDE loop detected") |
1531
|
1
|
50
|
|
|
|
6
|
if $self->{IncludedFiles}->{$_}; |
1532
|
|
|
|
|
|
|
|
1533
|
1
|
50
|
|
|
|
14
|
++$self->{IncludedFiles}->{$_} unless /\|\s*$/; |
1534
|
|
|
|
|
|
|
|
1535
|
1
|
50
|
33
|
|
|
9
|
if (/\|\s*$/ && /^\s*perl\s/) { |
1536
|
0
|
|
|
|
|
0
|
Warn( $self, "The INCLUDE directive with a command is discouraged." . |
1537
|
|
|
|
|
|
|
" Use INCLUDE_COMMAND instead! In particular using 'perl'" . |
1538
|
|
|
|
|
|
|
" in an 'INCLUDE: ... |' directive is not guaranteed to pick" . |
1539
|
|
|
|
|
|
|
" up the correct perl. The INCLUDE_COMMAND directive allows" . |
1540
|
|
|
|
|
|
|
" the use of \$^X as the currently running perl, see" . |
1541
|
|
|
|
|
|
|
" 'perldoc perlxs' for details."); |
1542
|
|
|
|
|
|
|
} |
1543
|
|
|
|
|
|
|
|
1544
|
1
|
|
|
|
|
5
|
$self->PushXSStack(); |
1545
|
|
|
|
|
|
|
|
1546
|
1
|
|
|
|
|
16
|
$self->{FH} = Symbol::gensym(); |
1547
|
|
|
|
|
|
|
|
1548
|
|
|
|
|
|
|
# open the new file |
1549
|
1
|
50
|
|
|
|
128
|
open($self->{FH}, $_) or $self->death("Cannot open '$_': $!"); |
1550
|
|
|
|
|
|
|
|
1551
|
1
|
|
|
|
|
16
|
print Q(<<"EOF"); |
1552
|
|
|
|
|
|
|
# |
1553
|
|
|
|
|
|
|
#/* INCLUDE: Including '$_' from '$self->{filename}' */ |
1554
|
|
|
|
|
|
|
# |
1555
|
|
|
|
|
|
|
EOF |
1556
|
|
|
|
|
|
|
|
1557
|
1
|
|
|
|
|
6
|
$self->{filename} = $_; |
1558
|
|
|
|
|
|
|
$self->{filepathname} = ( $^O =~ /^mswin/i ) |
1559
|
|
|
|
|
|
|
? qq($self->{dir}/$self->{filename}) # See CPAN RT #61908: gcc doesn't like backslashes on win32? |
1560
|
1
|
50
|
|
|
|
45
|
: File::Spec->catfile($self->{dir}, $self->{filename}); |
1561
|
|
|
|
|
|
|
|
1562
|
|
|
|
|
|
|
# Prime the pump by reading the first |
1563
|
|
|
|
|
|
|
# non-blank line |
1564
|
|
|
|
|
|
|
|
1565
|
|
|
|
|
|
|
# skip leading blank lines |
1566
|
1
|
|
|
|
|
19
|
while (readline($self->{FH})) { |
1567
|
2
|
100
|
|
|
|
28
|
last unless /^\s*$/; |
1568
|
|
|
|
|
|
|
} |
1569
|
|
|
|
|
|
|
|
1570
|
1
|
|
|
|
|
4
|
$self->{lastline} = $_; |
1571
|
1
|
|
|
|
|
3
|
$self->{lastline_no} = $.; |
1572
|
|
|
|
|
|
|
} |
1573
|
|
|
|
|
|
|
|
1574
|
|
|
|
|
|
|
sub QuoteArgs { |
1575
|
0
|
|
|
0
|
0
|
0
|
my $cmd = shift; |
1576
|
0
|
|
|
|
|
0
|
my @args = split /\s+/, $cmd; |
1577
|
0
|
|
|
|
|
0
|
$cmd = shift @args; |
1578
|
0
|
|
|
|
|
0
|
for (@args) { |
1579
|
0
|
0
|
0
|
|
|
0
|
$_ = q(").$_.q(") if !/^\"/ && length($_) > 0; |
1580
|
|
|
|
|
|
|
} |
1581
|
0
|
|
|
|
|
0
|
return join (' ', ($cmd, @args)); |
1582
|
|
|
|
|
|
|
} |
1583
|
|
|
|
|
|
|
|
1584
|
|
|
|
|
|
|
# code copied from CPAN::HandleConfig::safe_quote |
1585
|
|
|
|
|
|
|
# - that has doc saying leave if start/finish with same quote, but no code |
1586
|
|
|
|
|
|
|
# given text, will conditionally quote it to protect from shell |
1587
|
|
|
|
|
|
|
{ |
1588
|
|
|
|
|
|
|
my ($quote, $use_quote) = $^O eq 'MSWin32' |
1589
|
|
|
|
|
|
|
? (q{"}, q{"}) |
1590
|
|
|
|
|
|
|
: (q{"'}, q{'}); |
1591
|
|
|
|
|
|
|
sub _safe_quote { |
1592
|
1
|
|
|
1
|
|
5
|
my ($self, $command) = @_; |
1593
|
|
|
|
|
|
|
# Set up quote/default quote |
1594
|
1
|
50
|
33
|
|
|
9
|
if (defined($command) |
|
|
|
33
|
|
|
|
|
1595
|
|
|
|
|
|
|
and $command =~ /\s/ |
1596
|
|
|
|
|
|
|
and $command !~ /[$quote]/) { |
1597
|
0
|
|
|
|
|
0
|
return qq{$use_quote$command$use_quote} |
1598
|
|
|
|
|
|
|
} |
1599
|
1
|
|
|
|
|
2
|
return $command; |
1600
|
|
|
|
|
|
|
} |
1601
|
|
|
|
|
|
|
} |
1602
|
|
|
|
|
|
|
|
1603
|
|
|
|
|
|
|
sub INCLUDE_COMMAND_handler { |
1604
|
1
|
|
|
1
|
0
|
3
|
my $self = shift; |
1605
|
1
|
|
|
|
|
2
|
$_ = shift; |
1606
|
|
|
|
|
|
|
# the rest of the current line should contain a valid command |
1607
|
|
|
|
|
|
|
|
1608
|
1
|
|
|
|
|
4
|
trim_whitespace($_); |
1609
|
|
|
|
|
|
|
|
1610
|
1
|
50
|
|
|
|
5
|
$_ = QuoteArgs($_) if $^O eq 'VMS'; |
1611
|
|
|
|
|
|
|
|
1612
|
1
|
50
|
|
|
|
4
|
$self->death("INCLUDE_COMMAND: command missing") |
1613
|
|
|
|
|
|
|
unless $_; |
1614
|
|
|
|
|
|
|
|
1615
|
1
|
50
|
33
|
|
|
7
|
$self->death("INCLUDE_COMMAND: pipes are illegal") |
1616
|
|
|
|
|
|
|
if /^\s*\|/ or /\|\s*$/; |
1617
|
|
|
|
|
|
|
|
1618
|
1
|
|
|
|
|
5
|
$self->PushXSStack( IsPipe => 1 ); |
1619
|
|
|
|
|
|
|
|
1620
|
1
|
|
|
|
|
22
|
$self->{FH} = Symbol::gensym(); |
1621
|
|
|
|
|
|
|
|
1622
|
|
|
|
|
|
|
# If $^X is used in INCLUDE_COMMAND, we know it's supposed to be |
1623
|
|
|
|
|
|
|
# the same perl interpreter as we're currently running |
1624
|
1
|
|
|
|
|
53
|
my $X = $self->_safe_quote($^X); # quotes if has spaces |
1625
|
1
|
|
|
|
|
8
|
s/^\s*\$\^X/$X/; |
1626
|
|
|
|
|
|
|
|
1627
|
|
|
|
|
|
|
# open the new file |
1628
|
1
|
50
|
|
|
|
4355
|
open ($self->{FH}, "-|", $_) |
1629
|
|
|
|
|
|
|
or $self->death( $self, "Cannot run command '$_' to include its output: $!"); |
1630
|
|
|
|
|
|
|
|
1631
|
1
|
|
|
|
|
75
|
print Q(<<"EOF"); |
1632
|
|
|
|
|
|
|
# |
1633
|
|
|
|
|
|
|
#/* INCLUDE_COMMAND: Including output of '$_' from '$self->{filename}' */ |
1634
|
|
|
|
|
|
|
# |
1635
|
|
|
|
|
|
|
EOF |
1636
|
|
|
|
|
|
|
|
1637
|
1
|
|
|
|
|
36
|
$self->{filename} = $_; |
1638
|
1
|
|
|
|
|
40
|
$self->{filepathname} = $self->{filename}; |
1639
|
|
|
|
|
|
|
#$self->{filepathname} =~ s/\"/\\"/g; # Fails? See CPAN RT #53938: MinGW Broken after 2.21 |
1640
|
1
|
|
|
|
|
9
|
$self->{filepathname} =~ s/\\/\\\\/g; # Works according to reporter of #53938 |
1641
|
|
|
|
|
|
|
|
1642
|
|
|
|
|
|
|
# Prime the pump by reading the first |
1643
|
|
|
|
|
|
|
# non-blank line |
1644
|
|
|
|
|
|
|
|
1645
|
|
|
|
|
|
|
# skip leading blank lines |
1646
|
1
|
|
|
|
|
5376
|
while (readline($self->{FH})) { |
1647
|
2
|
100
|
|
|
|
44
|
last unless /^\s*$/; |
1648
|
|
|
|
|
|
|
} |
1649
|
|
|
|
|
|
|
|
1650
|
1
|
|
|
|
|
9
|
$self->{lastline} = $_; |
1651
|
1
|
|
|
|
|
22
|
$self->{lastline_no} = $.; |
1652
|
|
|
|
|
|
|
} |
1653
|
|
|
|
|
|
|
|
1654
|
|
|
|
|
|
|
sub PopFile { |
1655
|
10
|
|
|
10
|
0
|
30
|
my $self = shift; |
1656
|
|
|
|
|
|
|
|
1657
|
10
|
100
|
|
|
|
62
|
return 0 unless $self->{XSStack}->[-1]{type} eq 'file'; |
1658
|
|
|
|
|
|
|
|
1659
|
2
|
|
|
|
|
8
|
my $data = pop @{ $self->{XSStack} }; |
|
2
|
|
|
|
|
16
|
|
1660
|
2
|
|
|
|
|
11
|
my $ThisFile = $self->{filename}; |
1661
|
2
|
|
|
|
|
4
|
my $isPipe = $data->{IsPipe}; |
1662
|
|
|
|
|
|
|
|
1663
|
|
|
|
|
|
|
--$self->{IncludedFiles}->{$self->{filename}} |
1664
|
2
|
100
|
|
|
|
21
|
unless $isPipe; |
1665
|
|
|
|
|
|
|
|
1666
|
2
|
|
|
|
|
67
|
close $self->{FH}; |
1667
|
|
|
|
|
|
|
|
1668
|
2
|
|
|
|
|
35
|
$self->{FH} = $data->{Handle}; |
1669
|
|
|
|
|
|
|
# $filename is the leafname, which for some reason is used for diagnostic |
1670
|
|
|
|
|
|
|
# messages, whereas $filepathname is the full pathname, and is used for |
1671
|
|
|
|
|
|
|
# #line directives. |
1672
|
2
|
|
|
|
|
11
|
$self->{filename} = $data->{Filename}; |
1673
|
2
|
|
|
|
|
14
|
$self->{filepathname} = $data->{Filepathname}; |
1674
|
2
|
|
|
|
|
7
|
$self->{lastline} = $data->{LastLine}; |
1675
|
2
|
|
|
|
|
11
|
$self->{lastline_no} = $data->{LastLineNo}; |
1676
|
2
|
|
|
|
|
4
|
@{ $self->{line} } = @{ $data->{Line} }; |
|
2
|
|
|
|
|
11
|
|
|
2
|
|
|
|
|
4
|
|
1677
|
2
|
|
|
|
|
9
|
@{ $self->{line_no} } = @{ $data->{LineNo} }; |
|
2
|
|
|
|
|
6
|
|
|
2
|
|
|
|
|
16
|
|
1678
|
|
|
|
|
|
|
|
1679
|
2
|
50
|
66
|
|
|
42
|
if ($isPipe and $? ) { |
1680
|
0
|
|
|
|
|
0
|
--$self->{lastline_no}; |
1681
|
0
|
|
|
|
|
0
|
print STDERR "Error reading from pipe '$ThisFile': $! in $self->{filename}, line $self->{lastline_no}\n" ; |
1682
|
0
|
|
|
|
|
0
|
exit 1; |
1683
|
|
|
|
|
|
|
} |
1684
|
|
|
|
|
|
|
|
1685
|
2
|
|
|
|
|
19
|
print Q(<<"EOF"); |
1686
|
|
|
|
|
|
|
# |
1687
|
|
|
|
|
|
|
#/* INCLUDE: Returning to '$self->{filename}' from '$ThisFile' */ |
1688
|
|
|
|
|
|
|
# |
1689
|
|
|
|
|
|
|
EOF |
1690
|
|
|
|
|
|
|
|
1691
|
2
|
|
|
|
|
29
|
return 1; |
1692
|
|
|
|
|
|
|
} |
1693
|
|
|
|
|
|
|
|
1694
|
|
|
|
|
|
|
sub Q { |
1695
|
425
|
|
|
425
|
0
|
892
|
my($text) = @_; |
1696
|
425
|
|
|
|
|
2024
|
$text =~ s/^#//gm; |
1697
|
425
|
|
|
|
|
966
|
$text =~ s/\[\[/{/g; |
1698
|
425
|
|
|
|
|
789
|
$text =~ s/\]\]/}/g; |
1699
|
425
|
|
|
|
|
1489
|
$text; |
1700
|
|
|
|
|
|
|
} |
1701
|
|
|
|
|
|
|
|
1702
|
|
|
|
|
|
|
# Process "MODULE = Foo ..." lines and update global state accordingly |
1703
|
|
|
|
|
|
|
sub _process_module_xs_line { |
1704
|
8
|
|
|
8
|
|
100
|
my ($self, $module, $pkg, $prefix) = @_; |
1705
|
|
|
|
|
|
|
|
1706
|
8
|
|
|
|
|
64
|
($self->{Module_cname} = $module) =~ s/\W/_/g; |
1707
|
|
|
|
|
|
|
|
1708
|
8
|
50
|
|
|
|
84
|
$self->{Package} = defined($pkg) ? $pkg : ''; |
1709
|
8
|
100
|
|
|
|
52
|
$self->{Prefix} = quotemeta( defined($prefix) ? $prefix : '' ); |
1710
|
|
|
|
|
|
|
|
1711
|
8
|
|
|
|
|
49
|
($self->{Packid} = $self->{Package}) =~ tr/:/_/; |
1712
|
|
|
|
|
|
|
|
1713
|
8
|
|
|
|
|
25
|
$self->{Packprefix} = $self->{Package}; |
1714
|
8
|
50
|
|
|
|
43
|
$self->{Packprefix} .= "::" if $self->{Packprefix} ne ""; |
1715
|
|
|
|
|
|
|
|
1716
|
8
|
|
|
|
|
75
|
$self->{lastline} = ""; |
1717
|
|
|
|
|
|
|
} |
1718
|
|
|
|
|
|
|
|
1719
|
|
|
|
|
|
|
# Skip any embedded POD sections |
1720
|
|
|
|
|
|
|
sub _maybe_skip_pod { |
1721
|
564
|
|
|
564
|
|
902
|
my ($self) = @_; |
1722
|
|
|
|
|
|
|
|
1723
|
564
|
|
|
|
|
1294
|
while ($self->{lastline} =~ /^=/) { |
1724
|
1
|
|
|
|
|
7
|
while ($self->{lastline} = readline($self->{FH})) { |
1725
|
4
|
100
|
|
|
|
17
|
last if ($self->{lastline} =~ /^=cut\s*$/); |
1726
|
|
|
|
|
|
|
} |
1727
|
1
|
50
|
|
|
|
6
|
$self->death("Error: Unterminated pod") unless defined $self->{lastline}; |
1728
|
1
|
|
|
|
|
11
|
$self->{lastline} = readline($self->{FH}); |
1729
|
1
|
|
|
|
|
8
|
chomp $self->{lastline}; |
1730
|
1
|
|
|
|
|
5
|
$self->{lastline} =~ s/^\s+$//; |
1731
|
|
|
|
|
|
|
} |
1732
|
|
|
|
|
|
|
} |
1733
|
|
|
|
|
|
|
|
1734
|
|
|
|
|
|
|
# This chunk of code strips out (and parses) embedded TYPEMAP blocks |
1735
|
|
|
|
|
|
|
# which support a HEREdoc-alike block syntax. |
1736
|
|
|
|
|
|
|
sub _maybe_parse_typemap_block { |
1737
|
564
|
|
|
564
|
|
831
|
my ($self) = @_; |
1738
|
|
|
|
|
|
|
|
1739
|
|
|
|
|
|
|
# This is special cased from the usual paragraph-handler logic |
1740
|
|
|
|
|
|
|
# due to the HEREdoc-ish syntax. |
1741
|
564
|
100
|
|
|
|
1208
|
if ($self->{lastline} =~ /^TYPEMAP\s*:\s*<<\s*(?:(["'])(.+?)\1|([^\s'"]+?))\s*;?\s*$/) |
1742
|
|
|
|
|
|
|
{ |
1743
|
6
|
100
|
|
|
|
50
|
my $end_marker = quotemeta(defined($1) ? $2 : $3); |
1744
|
|
|
|
|
|
|
|
1745
|
|
|
|
|
|
|
# Scan until we find $end_marker alone on a line. |
1746
|
6
|
|
|
|
|
23
|
my @tmaplines; |
1747
|
6
|
|
|
|
|
16
|
while (1) { |
1748
|
34
|
|
|
|
|
76
|
$self->{lastline} = readline($self->{FH}); |
1749
|
34
|
50
|
|
|
|
93
|
$self->death("Error: Unterminated TYPEMAP section") if not defined $self->{lastline}; |
1750
|
34
|
100
|
|
|
|
214
|
last if $self->{lastline} =~ /^$end_marker\s*$/; |
1751
|
28
|
|
|
|
|
66
|
push @tmaplines, $self->{lastline}; |
1752
|
|
|
|
|
|
|
} |
1753
|
|
|
|
|
|
|
|
1754
|
|
|
|
|
|
|
my $tmap = ExtUtils::Typemaps->new( |
1755
|
|
|
|
|
|
|
string => join("", @tmaplines), |
1756
|
|
|
|
|
|
|
lineno_offset => 1 + ($self->current_line_number() || 0), |
1757
|
|
|
|
|
|
|
fake_filename => $self->{filename}, |
1758
|
6
|
|
50
|
|
|
55
|
); |
1759
|
6
|
|
|
|
|
27
|
$self->{typemap}->merge(typemap => $tmap, replace => 1); |
1760
|
|
|
|
|
|
|
|
1761
|
6
|
|
|
|
|
38
|
$self->{lastline} = ""; |
1762
|
|
|
|
|
|
|
} |
1763
|
|
|
|
|
|
|
} |
1764
|
|
|
|
|
|
|
|
1765
|
|
|
|
|
|
|
# Read next xsub into @{ $self->{line} } from ($lastline, readline($self->{FH})). |
1766
|
|
|
|
|
|
|
sub fetch_para { |
1767
|
92
|
|
|
92
|
0
|
212
|
my $self = shift; |
1768
|
|
|
|
|
|
|
|
1769
|
|
|
|
|
|
|
# parse paragraph |
1770
|
|
|
|
|
|
|
$self->death("Error: Unterminated '#if/#ifdef/#ifndef'") |
1771
|
92
|
50
|
66
|
|
|
363
|
if !defined $self->{lastline} && $self->{XSStack}->[-1]{type} eq 'if'; |
1772
|
92
|
|
|
|
|
157
|
@{ $self->{line} } = (); |
|
92
|
|
|
|
|
244
|
|
1773
|
92
|
|
|
|
|
143
|
@{ $self->{line_no} } = (); |
|
92
|
|
|
|
|
238
|
|
1774
|
92
|
100
|
|
|
|
268
|
return $self->PopFile() if not defined $self->{lastline}; # EOF |
1775
|
|
|
|
|
|
|
|
1776
|
82
|
100
|
|
|
|
350
|
if ($self->{lastline} =~ |
1777
|
|
|
|
|
|
|
/^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) |
1778
|
|
|
|
|
|
|
{ |
1779
|
8
|
|
|
|
|
114
|
$self->_process_module_xs_line($1, $2, $3); |
1780
|
|
|
|
|
|
|
} |
1781
|
|
|
|
|
|
|
|
1782
|
82
|
|
|
|
|
130
|
for (;;) { |
1783
|
564
|
|
|
|
|
1286
|
$self->_maybe_skip_pod; |
1784
|
|
|
|
|
|
|
|
1785
|
564
|
|
|
|
|
1214
|
$self->_maybe_parse_typemap_block; |
1786
|
|
|
|
|
|
|
|
1787
|
564
|
100
|
100
|
|
|
1346
|
if ($self->{lastline} !~ /^\s*#/ # not a CPP directive |
1788
|
|
|
|
|
|
|
# CPP directives: |
1789
|
|
|
|
|
|
|
# ANSI: if ifdef ifndef elif else endif define undef |
1790
|
|
|
|
|
|
|
# line error pragma |
1791
|
|
|
|
|
|
|
# gcc: warning include_next |
1792
|
|
|
|
|
|
|
# obj-c: import |
1793
|
|
|
|
|
|
|
# others: ident (gcc notes that some cpps have this one) |
1794
|
|
|
|
|
|
|
|| $self->{lastline} =~ /^\#[ \t]* |
1795
|
|
|
|
|
|
|
(?: |
1796
|
|
|
|
|
|
|
(?:if|ifn?def|elif|else|endif| |
1797
|
|
|
|
|
|
|
define|undef|pragma|error| |
1798
|
|
|
|
|
|
|
warning|line\s+\d+|ident) |
1799
|
|
|
|
|
|
|
\b |
1800
|
|
|
|
|
|
|
| (?:include(?:_next)?|import) |
1801
|
|
|
|
|
|
|
\s* ["<] .* [>"] |
1802
|
|
|
|
|
|
|
) |
1803
|
|
|
|
|
|
|
/x |
1804
|
|
|
|
|
|
|
) |
1805
|
|
|
|
|
|
|
{ |
1806
|
561
|
100
|
100
|
|
|
1530
|
last if $self->{lastline} =~ /^\S/ && @{ $self->{line} } && $self->{line}->[-1] eq ""; |
|
217
|
|
100
|
|
|
926
|
|
1807
|
489
|
|
|
|
|
677
|
push(@{ $self->{line} }, $self->{lastline}); |
|
489
|
|
|
|
|
1068
|
|
1808
|
489
|
|
|
|
|
687
|
push(@{ $self->{line_no} }, $self->{lastline_no}); |
|
489
|
|
|
|
|
861
|
|
1809
|
|
|
|
|
|
|
} |
1810
|
|
|
|
|
|
|
|
1811
|
|
|
|
|
|
|
# Read next line and continuation lines |
1812
|
492
|
100
|
|
|
|
1547
|
last unless defined($self->{lastline} = readline($self->{FH})); |
1813
|
482
|
|
|
|
|
858
|
$self->{lastline_no} = $.; |
1814
|
482
|
|
|
|
|
639
|
my $tmp_line; |
1815
|
|
|
|
|
|
|
$self->{lastline} .= $tmp_line |
1816
|
482
|
|
33
|
|
|
1202
|
while ($self->{lastline} =~ /\\$/ && defined($tmp_line = readline($self->{FH}))); |
1817
|
|
|
|
|
|
|
|
1818
|
482
|
|
|
|
|
728
|
chomp $self->{lastline}; |
1819
|
482
|
|
|
|
|
1063
|
$self->{lastline} =~ s/^\s+$//; |
1820
|
|
|
|
|
|
|
} |
1821
|
|
|
|
|
|
|
|
1822
|
|
|
|
|
|
|
# Nuke trailing "line" entries until there's one that's not empty |
1823
|
99
|
|
|
|
|
202
|
pop(@{ $self->{line} }), pop(@{ $self->{line_no} }) |
|
99
|
|
|
|
|
194
|
|
1824
|
82
|
|
100
|
|
|
156
|
while @{ $self->{line} } && $self->{line}->[-1] eq ""; |
|
181
|
|
|
|
|
694
|
|
1825
|
|
|
|
|
|
|
|
1826
|
82
|
|
|
|
|
218
|
return 1; |
1827
|
|
|
|
|
|
|
} |
1828
|
|
|
|
|
|
|
|
1829
|
|
|
|
|
|
|
sub output_init { |
1830
|
2
|
|
|
2
|
0
|
7
|
my $self = shift; |
1831
|
2
|
|
|
|
|
6
|
my $argsref = shift; |
1832
|
|
|
|
|
|
|
|
1833
|
|
|
|
|
|
|
my ($type, $num, $var, $init, $printed_name) |
1834
|
2
|
|
|
|
|
6
|
= @{$argsref}{qw(type num var init printed_name)}; |
|
2
|
|
|
|
|
14
|
|
1835
|
|
|
|
|
|
|
|
1836
|
|
|
|
|
|
|
# local assign for efficiently passing in to eval_input_typemap_code |
1837
|
2
|
100
|
|
|
|
17
|
local $argsref->{arg} = $num |
1838
|
|
|
|
|
|
|
? "ST(" . ($num-1) . ")" |
1839
|
|
|
|
|
|
|
: "/* not a parameter */"; |
1840
|
|
|
|
|
|
|
|
1841
|
2
|
50
|
|
|
|
13
|
if ( $init =~ /^=/ ) { |
1842
|
2
|
50
|
|
|
|
7
|
if ($printed_name) { |
1843
|
0
|
|
|
|
|
0
|
$self->eval_input_typemap_code(qq/print " $init\\n"/, $argsref); |
1844
|
|
|
|
|
|
|
} |
1845
|
|
|
|
|
|
|
else { |
1846
|
2
|
|
|
|
|
23
|
$self->eval_input_typemap_code(qq/print "\\t$var $init\\n"/, $argsref); |
1847
|
|
|
|
|
|
|
} |
1848
|
|
|
|
|
|
|
} |
1849
|
|
|
|
|
|
|
else { |
1850
|
0
|
0
|
0
|
|
|
0
|
if ( $init =~ s/^\+// && $num ) { |
|
|
0
|
|
|
|
|
|
1851
|
0
|
|
|
|
|
0
|
$self->generate_init( { |
1852
|
|
|
|
|
|
|
type => $type, |
1853
|
|
|
|
|
|
|
num => $num, |
1854
|
|
|
|
|
|
|
var => $var, |
1855
|
|
|
|
|
|
|
printed_name => $printed_name, |
1856
|
|
|
|
|
|
|
} ); |
1857
|
|
|
|
|
|
|
} |
1858
|
|
|
|
|
|
|
elsif ($printed_name) { |
1859
|
0
|
|
|
|
|
0
|
print ";\n"; |
1860
|
0
|
|
|
|
|
0
|
$init =~ s/^;//; |
1861
|
|
|
|
|
|
|
} |
1862
|
|
|
|
|
|
|
else { |
1863
|
0
|
|
|
|
|
0
|
$self->eval_input_typemap_code(qq/print "\\t$var;\\n"/, $argsref); |
1864
|
0
|
|
|
|
|
0
|
$init =~ s/^;//; |
1865
|
|
|
|
|
|
|
} |
1866
|
|
|
|
|
|
|
$self->{deferred} |
1867
|
0
|
|
|
|
|
0
|
.= $self->eval_input_typemap_code(qq/"\\n\\t$init\\n"/, $argsref); |
1868
|
|
|
|
|
|
|
} |
1869
|
|
|
|
|
|
|
} |
1870
|
|
|
|
|
|
|
|
1871
|
|
|
|
|
|
|
sub generate_init { |
1872
|
51
|
|
|
51
|
0
|
85
|
my $self = shift; |
1873
|
51
|
|
|
|
|
80
|
my $argsref = shift; |
1874
|
|
|
|
|
|
|
|
1875
|
|
|
|
|
|
|
my ($type, $num, $var, $printed_name) |
1876
|
51
|
|
|
|
|
82
|
= @{$argsref}{qw(type num var printed_name)}; |
|
51
|
|
|
|
|
157
|
|
1877
|
|
|
|
|
|
|
|
1878
|
51
|
|
|
|
|
95
|
my $argoff = $num - 1; |
1879
|
51
|
|
|
|
|
120
|
my $arg = "ST($argoff)"; |
1880
|
|
|
|
|
|
|
|
1881
|
51
|
|
|
|
|
88
|
my $typemaps = $self->{typemap}; |
1882
|
|
|
|
|
|
|
|
1883
|
51
|
|
|
|
|
116
|
$type = ExtUtils::Typemaps::tidy_type($type); |
1884
|
51
|
50
|
|
|
|
132
|
if (not $typemaps->get_typemap(ctype => $type)) { |
1885
|
0
|
|
|
|
|
0
|
$self->report_typemap_failure($typemaps, $type); |
1886
|
0
|
|
|
|
|
0
|
return; |
1887
|
|
|
|
|
|
|
} |
1888
|
|
|
|
|
|
|
|
1889
|
51
|
|
|
|
|
245
|
(my $ntype = $type) =~ s/\s*\*/Ptr/g; |
1890
|
51
|
|
|
|
|
323
|
(my $subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; |
1891
|
|
|
|
|
|
|
|
1892
|
51
|
|
|
|
|
143
|
my $typem = $typemaps->get_typemap(ctype => $type); |
1893
|
51
|
|
|
|
|
159
|
my $xstype = $typem->xstype; |
1894
|
|
|
|
|
|
|
#this is an optimization from perl 5.0 alpha 6, class check is skipped |
1895
|
|
|
|
|
|
|
#T_REF_IV_REF is missing since it has no untyped analog at the moment |
1896
|
|
|
|
|
|
|
$xstype =~ s/OBJ$/REF/ || $xstype =~ s/^T_REF_IV_PTR$/T_PTRREF/ |
1897
|
51
|
50
|
0
|
|
|
162
|
if $self->{func_name} =~ /DESTROY$/; |
1898
|
51
|
100
|
100
|
|
|
185
|
if ($xstype eq 'T_PV' and exists $self->{lengthof}->{$var}) { |
1899
|
1
|
50
|
|
|
|
9
|
print "\t$var" unless $printed_name; |
1900
|
1
|
|
|
|
|
8
|
print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n"; |
1901
|
|
|
|
|
|
|
die "default value not supported with length(NAME) supplied" |
1902
|
1
|
50
|
|
|
|
4
|
if defined $self->{defaults}->{$var}; |
1903
|
1
|
|
|
|
|
4
|
return; |
1904
|
|
|
|
|
|
|
} |
1905
|
50
|
50
|
|
|
|
165
|
$type =~ tr/:/_/ unless $self->{RetainCplusplusHierarchicalTypes}; |
1906
|
|
|
|
|
|
|
|
1907
|
50
|
|
|
|
|
192
|
my $inputmap = $typemaps->get_inputmap(xstype => $xstype); |
1908
|
50
|
100
|
|
|
|
111
|
if (not defined $inputmap) { |
1909
|
1
|
|
|
|
|
8
|
$self->blurt("Error: No INPUT definition for type '$type', typekind '$xstype' found"); |
1910
|
1
|
|
|
|
|
4
|
return; |
1911
|
|
|
|
|
|
|
} |
1912
|
|
|
|
|
|
|
|
1913
|
49
|
|
|
|
|
165
|
my $expr = $inputmap->cleaned_code; |
1914
|
|
|
|
|
|
|
# Note: This gruesome bit either needs heavy rethinking or documentation. I vote for the former. --Steffen |
1915
|
49
|
50
|
|
|
|
152
|
if ($expr =~ /DO_ARRAY_ELEM/) { |
1916
|
0
|
|
|
|
|
0
|
my $subtypemap = $typemaps->get_typemap(ctype => $subtype); |
1917
|
0
|
0
|
|
|
|
0
|
if (not $subtypemap) { |
1918
|
0
|
|
|
|
|
0
|
$self->report_typemap_failure($typemaps, $subtype); |
1919
|
0
|
|
|
|
|
0
|
return; |
1920
|
|
|
|
|
|
|
} |
1921
|
|
|
|
|
|
|
|
1922
|
0
|
|
|
|
|
0
|
my $subinputmap = $typemaps->get_inputmap(xstype => $subtypemap->xstype); |
1923
|
0
|
0
|
|
|
|
0
|
if (not $subinputmap) { |
1924
|
0
|
|
|
|
|
0
|
$self->blurt("Error: No INPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"); |
1925
|
0
|
|
|
|
|
0
|
return; |
1926
|
|
|
|
|
|
|
} |
1927
|
|
|
|
|
|
|
|
1928
|
0
|
|
|
|
|
0
|
my $subexpr = $subinputmap->cleaned_code; |
1929
|
0
|
|
|
|
|
0
|
$subexpr =~ s/\$type/\$subtype/g; |
1930
|
0
|
|
|
|
|
0
|
$subexpr =~ s/ntype/subtype/g; |
1931
|
0
|
|
|
|
|
0
|
$subexpr =~ s/\$arg/ST(ix_$var)/g; |
1932
|
0
|
|
|
|
|
0
|
$subexpr =~ s/\n\t/\n\t\t/g; |
1933
|
0
|
|
|
|
|
0
|
$subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g; |
1934
|
0
|
|
|
|
|
0
|
$subexpr =~ s/\$var/${var}\[ix_$var - $argoff]/; |
1935
|
0
|
|
|
|
|
0
|
$expr =~ s/DO_ARRAY_ELEM/$subexpr/; |
1936
|
|
|
|
|
|
|
} |
1937
|
49
|
50
|
|
|
|
120
|
if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments |
1938
|
0
|
|
|
|
|
0
|
$self->{ScopeThisXSUB} = 1; |
1939
|
|
|
|
|
|
|
} |
1940
|
|
|
|
|
|
|
|
1941
|
49
|
|
|
|
|
358
|
my $eval_vars = { |
1942
|
|
|
|
|
|
|
var => $var, |
1943
|
|
|
|
|
|
|
printed_name => $printed_name, |
1944
|
|
|
|
|
|
|
type => $type, |
1945
|
|
|
|
|
|
|
ntype => $ntype, |
1946
|
|
|
|
|
|
|
subtype => $subtype, |
1947
|
|
|
|
|
|
|
num => $num, |
1948
|
|
|
|
|
|
|
arg => $arg, |
1949
|
|
|
|
|
|
|
argoff => $argoff, |
1950
|
|
|
|
|
|
|
}; |
1951
|
|
|
|
|
|
|
|
1952
|
49
|
100
|
66
|
|
|
420
|
if (defined($self->{defaults}->{$var})) { |
|
|
100
|
|
|
|
|
|
1953
|
1
|
|
|
|
|
9
|
$expr =~ s/(\t+)/$1 /g; |
1954
|
1
|
|
|
|
|
5
|
$expr =~ s/ /\t/g; |
1955
|
1
|
50
|
|
|
|
4
|
if ($printed_name) { |
1956
|
0
|
|
|
|
|
0
|
print ";\n"; |
1957
|
|
|
|
|
|
|
} |
1958
|
|
|
|
|
|
|
else { |
1959
|
1
|
|
|
|
|
5
|
$self->eval_input_typemap_code(qq/print "\\t$var;\\n"/, $eval_vars); |
1960
|
|
|
|
|
|
|
} |
1961
|
1
|
50
|
|
|
|
9
|
if ($self->{defaults}->{$var} eq 'NO_INIT') { |
1962
|
0
|
|
|
|
|
0
|
$self->{deferred} .= $self->eval_input_typemap_code( |
1963
|
|
|
|
|
|
|
qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/, |
1964
|
|
|
|
|
|
|
$eval_vars |
1965
|
|
|
|
|
|
|
); |
1966
|
|
|
|
|
|
|
} |
1967
|
|
|
|
|
|
|
else { |
1968
|
1
|
|
|
|
|
10
|
$self->{deferred} .= $self->eval_input_typemap_code( |
1969
|
|
|
|
|
|
|
qq/"\\n\\tif (items < $num)\\n\\t $var = $self->{defaults}->{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/, |
1970
|
|
|
|
|
|
|
$eval_vars |
1971
|
|
|
|
|
|
|
); |
1972
|
|
|
|
|
|
|
} |
1973
|
|
|
|
|
|
|
} |
1974
|
|
|
|
|
|
|
elsif ($self->{ScopeThisXSUB} or $expr !~ /^\s*\$var =/) { |
1975
|
1
|
50
|
|
|
|
4
|
if ($printed_name) { |
1976
|
0
|
|
|
|
|
0
|
print ";\n"; |
1977
|
|
|
|
|
|
|
} |
1978
|
|
|
|
|
|
|
else { |
1979
|
1
|
|
|
|
|
4
|
$self->eval_input_typemap_code(qq/print "\\t$var;\\n"/, $eval_vars); |
1980
|
|
|
|
|
|
|
} |
1981
|
|
|
|
|
|
|
$self->{deferred} |
1982
|
1
|
|
|
|
|
7
|
.= $self->eval_input_typemap_code(qq/"\\n$expr;\\n"/, $eval_vars); |
1983
|
|
|
|
|
|
|
} |
1984
|
|
|
|
|
|
|
else { |
1985
|
47
|
50
|
|
|
|
121
|
die "panic: do not know how to handle this branch for function pointers" |
1986
|
|
|
|
|
|
|
if $printed_name; |
1987
|
47
|
|
|
|
|
202
|
$self->eval_input_typemap_code(qq/print "$expr;\\n"/, $eval_vars); |
1988
|
|
|
|
|
|
|
} |
1989
|
|
|
|
|
|
|
} |
1990
|
|
|
|
|
|
|
|
1991
|
|
|
|
|
|
|
sub generate_output { |
1992
|
14
|
|
|
14
|
0
|
29
|
my $self = shift; |
1993
|
14
|
|
|
|
|
22
|
my $argsref = shift; |
1994
|
|
|
|
|
|
|
my ($type, $num, $var, $do_setmagic, $do_push) |
1995
|
14
|
|
|
|
|
28
|
= @{$argsref}{qw(type num var do_setmagic do_push)}; |
|
14
|
|
|
|
|
46
|
|
1996
|
|
|
|
|
|
|
|
1997
|
14
|
|
|
|
|
44
|
my $arg = "ST(" . ($num - ($num != 0)) . ")"; |
1998
|
|
|
|
|
|
|
|
1999
|
14
|
|
|
|
|
31
|
my $typemaps = $self->{typemap}; |
2000
|
|
|
|
|
|
|
|
2001
|
14
|
|
|
|
|
44
|
$type = ExtUtils::Typemaps::tidy_type($type); |
2002
|
14
|
|
|
|
|
40
|
local $argsref->{type} = $type; |
2003
|
|
|
|
|
|
|
|
2004
|
14
|
50
|
|
|
|
39
|
if ($type =~ /^array\(([^,]*),(.*)\)/) { |
2005
|
0
|
|
|
|
|
0
|
print "\t$arg = sv_newmortal();\n"; |
2006
|
0
|
|
|
|
|
0
|
print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n"; |
2007
|
0
|
0
|
|
|
|
0
|
print "\tSvSETMAGIC($arg);\n" if $do_setmagic; |
2008
|
|
|
|
|
|
|
} |
2009
|
|
|
|
|
|
|
else { |
2010
|
14
|
|
|
|
|
43
|
my $typemap = $typemaps->get_typemap(ctype => $type); |
2011
|
14
|
50
|
|
|
|
39
|
if (not $typemap) { |
2012
|
0
|
|
|
|
|
0
|
$self->report_typemap_failure($typemaps, $type); |
2013
|
0
|
|
|
|
|
0
|
return; |
2014
|
|
|
|
|
|
|
} |
2015
|
|
|
|
|
|
|
|
2016
|
14
|
|
|
|
|
40
|
my $outputmap = $typemaps->get_outputmap(xstype => $typemap->xstype); |
2017
|
14
|
50
|
|
|
|
41
|
if (not $outputmap) { |
2018
|
0
|
|
|
|
|
0
|
$self->blurt("Error: No OUTPUT definition for type '$type', typekind '" . $typemap->xstype . "' found"); |
2019
|
0
|
|
|
|
|
0
|
return; |
2020
|
|
|
|
|
|
|
} |
2021
|
|
|
|
|
|
|
|
2022
|
14
|
|
|
|
|
59
|
(my $ntype = $type) =~ s/\s*\*/Ptr/g; |
2023
|
14
|
|
|
|
|
33
|
$ntype =~ s/\(\)//g; |
2024
|
14
|
|
|
|
|
101
|
(my $subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; |
2025
|
|
|
|
|
|
|
|
2026
|
14
|
|
|
|
|
110
|
my $eval_vars = {%$argsref, subtype => $subtype, ntype => $ntype, arg => $arg}; |
2027
|
14
|
|
|
|
|
57
|
my $expr = $outputmap->cleaned_code; |
2028
|
14
|
50
|
|
|
|
107
|
if ($expr =~ /DO_ARRAY_ELEM/) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2029
|
0
|
|
|
|
|
0
|
my $subtypemap = $typemaps->get_typemap(ctype => $subtype); |
2030
|
0
|
0
|
|
|
|
0
|
if (not $subtypemap) { |
2031
|
0
|
|
|
|
|
0
|
$self->report_typemap_failure($typemaps, $subtype); |
2032
|
0
|
|
|
|
|
0
|
return; |
2033
|
|
|
|
|
|
|
} |
2034
|
|
|
|
|
|
|
|
2035
|
0
|
|
|
|
|
0
|
my $suboutputmap = $typemaps->get_outputmap(xstype => $subtypemap->xstype); |
2036
|
0
|
0
|
|
|
|
0
|
if (not $suboutputmap) { |
2037
|
0
|
|
|
|
|
0
|
$self->blurt("Error: No OUTPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"); |
2038
|
0
|
|
|
|
|
0
|
return; |
2039
|
|
|
|
|
|
|
} |
2040
|
|
|
|
|
|
|
|
2041
|
0
|
|
|
|
|
0
|
my $subexpr = $suboutputmap->cleaned_code; |
2042
|
0
|
|
|
|
|
0
|
$subexpr =~ s/ntype/subtype/g; |
2043
|
0
|
|
|
|
|
0
|
$subexpr =~ s/\$arg/ST(ix_$var)/g; |
2044
|
0
|
|
|
|
|
0
|
$subexpr =~ s/\$var/${var}\[ix_$var]/g; |
2045
|
0
|
|
|
|
|
0
|
$subexpr =~ s/\n\t/\n\t\t/g; |
2046
|
0
|
|
|
|
|
0
|
$expr =~ s/DO_ARRAY_ELEM\n/$subexpr/; |
2047
|
0
|
|
|
|
|
0
|
$self->eval_output_typemap_code("print qq\a$expr\a", $eval_vars); |
2048
|
0
|
0
|
|
|
|
0
|
print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic; |
2049
|
|
|
|
|
|
|
} |
2050
|
|
|
|
|
|
|
elsif ($var eq 'RETVAL') { |
2051
|
4
|
|
|
|
|
9
|
my $orig_arg = $arg; |
2052
|
4
|
|
|
|
|
5
|
my $indent; |
2053
|
4
|
|
|
|
|
6
|
my $use_RETVALSV = 1; |
2054
|
4
|
|
|
|
|
7
|
my $do_mortal = 0; |
2055
|
4
|
|
|
|
|
6
|
my $do_copy_tmp = 1; |
2056
|
4
|
|
|
|
|
8
|
my $pre_expr; |
2057
|
4
|
|
|
|
|
13
|
local $eval_vars->{arg} = $arg = 'RETVALSV'; |
2058
|
4
|
|
|
|
|
21
|
my $evalexpr = $self->eval_output_typemap_code("qq\a$expr\a", $eval_vars); |
2059
|
|
|
|
|
|
|
|
2060
|
4
|
50
|
|
|
|
117
|
if ($expr =~ /^\t\Q$arg\E = new/) { |
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2061
|
|
|
|
|
|
|
# We expect that $arg has refcnt 1, so we need to |
2062
|
|
|
|
|
|
|
# mortalize it. |
2063
|
0
|
|
|
|
|
0
|
$do_mortal = 1; |
2064
|
|
|
|
|
|
|
} |
2065
|
|
|
|
|
|
|
# If RETVAL is immortal, don't mortalize it. This code is not perfect: |
2066
|
|
|
|
|
|
|
# It won't detect a func or expression that only returns immortals, for |
2067
|
|
|
|
|
|
|
# example, this RE must be tried before next elsif. |
2068
|
|
|
|
|
|
|
elsif ($evalexpr =~ /^\t\Q$arg\E\s*=\s*(boolSV\(|(&PL_sv_yes|&PL_sv_no|&PL_sv_undef)\s*;)/) { |
2069
|
4
|
|
|
|
|
17
|
$do_copy_tmp = 0; #$arg will be a ST(X), no SV* RETVAL, no RETVALSV |
2070
|
4
|
|
|
|
|
10
|
$use_RETVALSV = 0; |
2071
|
|
|
|
|
|
|
} |
2072
|
|
|
|
|
|
|
elsif ($evalexpr =~ /^\s*\Q$arg\E\s*=/) { |
2073
|
|
|
|
|
|
|
# We expect that $arg has refcnt >=1, so we need |
2074
|
|
|
|
|
|
|
# to mortalize it! |
2075
|
0
|
0
|
|
|
|
0
|
$use_RETVALSV = 0 if $ntype eq "SVPtr";#reuse SV* RETVAL vs open new block |
2076
|
0
|
|
|
|
|
0
|
$do_mortal = 1; |
2077
|
|
|
|
|
|
|
} |
2078
|
|
|
|
|
|
|
else { |
2079
|
|
|
|
|
|
|
# Just hope that the entry would safely write it |
2080
|
|
|
|
|
|
|
# over an already mortalized value. By |
2081
|
|
|
|
|
|
|
# coincidence, something like $arg = &PL_sv_undef |
2082
|
|
|
|
|
|
|
# works too, but should be caught above. |
2083
|
0
|
|
|
|
|
0
|
$pre_expr = "RETVALSV = sv_newmortal();\n"; |
2084
|
|
|
|
|
|
|
# new mortals don't have set magic |
2085
|
0
|
|
|
|
|
0
|
$do_setmagic = 0; |
2086
|
|
|
|
|
|
|
} |
2087
|
4
|
50
|
|
|
|
12
|
if($use_RETVALSV) { |
2088
|
0
|
|
|
|
|
0
|
print "\t{\n\t SV * RETVALSV;\n"; |
2089
|
0
|
|
|
|
|
0
|
$indent = "\t "; |
2090
|
|
|
|
|
|
|
} else { |
2091
|
4
|
|
|
|
|
19
|
$indent = "\t"; |
2092
|
|
|
|
|
|
|
} |
2093
|
4
|
50
|
|
|
|
15
|
print $indent.$pre_expr if $pre_expr; |
2094
|
|
|
|
|
|
|
|
2095
|
4
|
50
|
|
|
|
13
|
if($use_RETVALSV) { |
2096
|
|
|
|
|
|
|
#take control of 1 layer of indent, may or may not indent more |
2097
|
0
|
|
|
|
|
0
|
$evalexpr =~ s/^(\t| )/$indent/gm; |
2098
|
|
|
|
|
|
|
#"\t \t" doesn't draw right in some IDEs |
2099
|
|
|
|
|
|
|
#break down all \t into spaces |
2100
|
0
|
|
|
|
|
0
|
$evalexpr =~ s/\t/ /g; |
2101
|
|
|
|
|
|
|
#rebuild back into \t'es, \t==8 spaces, indent==4 spaces |
2102
|
0
|
|
|
|
|
0
|
$evalexpr =~ s/ /\t/g; |
2103
|
|
|
|
|
|
|
} |
2104
|
|
|
|
|
|
|
else { |
2105
|
4
|
50
|
33
|
|
|
51
|
if($do_mortal || $do_setmagic) { |
2106
|
|
|
|
|
|
|
#typemap entry evaled with RETVALSV, if we aren't using RETVALSV replace |
2107
|
0
|
|
|
|
|
0
|
$evalexpr =~ s/RETVALSV/RETVAL/g; #all uses with RETVAL for prettier code |
2108
|
|
|
|
|
|
|
} |
2109
|
|
|
|
|
|
|
else { #if no extra boilerplate (no mortal, no set magic) is needed |
2110
|
|
|
|
|
|
|
#after $evalexport, get rid of RETVALSV's visual cluter and change |
2111
|
4
|
|
|
|
|
47
|
$evalexpr =~ s/RETVALSV/$orig_arg/g;#the lvalue to ST(X) |
2112
|
|
|
|
|
|
|
} |
2113
|
|
|
|
|
|
|
} |
2114
|
|
|
|
|
|
|
#stop " RETVAL = RETVAL;" for SVPtr type |
2115
|
4
|
50
|
|
|
|
34
|
print $evalexpr if $evalexpr !~ /^\s*RETVAL = RETVAL;$/; |
2116
|
4
|
0
|
|
|
|
39
|
print $indent.'RETVAL'.($use_RETVALSV ? 'SV':'') |
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2117
|
|
|
|
|
|
|
.' = sv_2mortal(RETVAL'.($use_RETVALSV ? 'SV':'').");\n" if $do_mortal; |
2118
|
4
|
0
|
|
|
|
16
|
print $indent.'SvSETMAGIC(RETVAL'.($use_RETVALSV ? 'SV':'').");\n" if $do_setmagic; |
|
|
50
|
|
|
|
|
|
2119
|
|
|
|
|
|
|
#dont do "RETVALSV = boolSV(RETVAL); ST(0) = RETVALSV;", it is visual clutter |
2120
|
4
|
0
|
33
|
|
|
58
|
print $indent."$orig_arg = RETVAL".($use_RETVALSV ? 'SV':'').";\n" |
|
|
50
|
33
|
|
|
|
|
2121
|
|
|
|
|
|
|
if $do_mortal || $do_setmagic || $do_copy_tmp; |
2122
|
4
|
50
|
|
|
|
39
|
print "\t}\n" if $use_RETVALSV; |
2123
|
|
|
|
|
|
|
} |
2124
|
|
|
|
|
|
|
elsif ($do_push) { |
2125
|
2
|
|
|
|
|
7
|
print "\tPUSHs(sv_newmortal());\n"; |
2126
|
2
|
|
|
|
|
7
|
local $eval_vars->{arg} = "ST($num)"; |
2127
|
2
|
|
|
|
|
9
|
$self->eval_output_typemap_code("print qq\a$expr\a", $eval_vars); |
2128
|
2
|
50
|
|
|
|
20
|
print "\tSvSETMAGIC($arg);\n" if $do_setmagic; |
2129
|
|
|
|
|
|
|
} |
2130
|
|
|
|
|
|
|
elsif ($arg =~ /^ST\(\d+\)$/) { |
2131
|
8
|
|
|
|
|
37
|
$self->eval_output_typemap_code("print qq\a$expr\a", $eval_vars); |
2132
|
8
|
50
|
|
|
|
59
|
print "\tSvSETMAGIC($arg);\n" if $do_setmagic; |
2133
|
|
|
|
|
|
|
} |
2134
|
|
|
|
|
|
|
} |
2135
|
|
|
|
|
|
|
} |
2136
|
|
|
|
|
|
|
|
2137
|
|
|
|
|
|
|
|
2138
|
|
|
|
|
|
|
# Just delegates to a clean package. |
2139
|
|
|
|
|
|
|
# Shim to evaluate Perl code in the right variable context |
2140
|
|
|
|
|
|
|
# for typemap code (having things such as $ALIAS set up). |
2141
|
|
|
|
|
|
|
sub eval_output_typemap_code { |
2142
|
66
|
|
|
66
|
0
|
159
|
my ($self, $code, $other) = @_; |
2143
|
66
|
|
|
|
|
230
|
return ExtUtils::ParseXS::Eval::eval_output_typemap_code($self, $code, $other); |
2144
|
|
|
|
|
|
|
} |
2145
|
|
|
|
|
|
|
|
2146
|
|
|
|
|
|
|
sub eval_input_typemap_code { |
2147
|
53
|
|
|
53
|
0
|
125
|
my ($self, $code, $other) = @_; |
2148
|
53
|
|
|
|
|
163
|
return ExtUtils::ParseXS::Eval::eval_input_typemap_code($self, $code, $other); |
2149
|
|
|
|
|
|
|
} |
2150
|
|
|
|
|
|
|
|
2151
|
|
|
|
|
|
|
1; |
2152
|
|
|
|
|
|
|
|
2153
|
|
|
|
|
|
|
# vim: ts=2 sw=2 et: |