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