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