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