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