lib/ExtUtils/xsubpp

   1 #!./miniperl
   2
   3 =head1 NAME
   4
   5 xsubpp - compiler to convert Perl XS code into C code
   6
   7 =head1 SYNOPSIS
   8
   9 B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-typemap typemap>] ... file.xs
  10
  11 =head1 DESCRIPTION
  12
  13 I<xsubpp> will compile XS code into C code by embedding the constructs
  14 necessary to let C functions manipulate Perl values and creates the glue
  15 necessary to let Perl access those functions.  The compiler uses typemaps to
  16 determine how to map C function parameters and variables to Perl values.
  17
  18 The compiler will search for typemap files called I<typemap>.  It will use
  19 the following search path to find default typemaps, with the rightmost
  20 typemap taking precedence.
  21
  22         ../../../typemap:../../typemap:../typemap:typemap
  23
  24 =head1 OPTIONS
  25
  26 =over 5
  27
  28 =item B<-C++>
  29
  30 Adds ``extern "C"'' to the C code.
  31
  32
  33 =item B<-except>
  34
  35 Adds exception handling stubs to the C code.
  36
  37 =item B<-typemap typemap>
  38
  39 Indicates that a user-supplied typemap should take precedence over the
  40 default typemaps.  This option may be used multiple times, with the last
  41 typemap having the highest precedence.
  42
  43 =item B<-v>
  44
  45 Prints the I<xsubpp> version number to standard output, then exits.
  46
  47 =item B<-prototypes>
  48
  49 By default I<xsubpp> will not automatically generate prototype code for
  50 all xsubs. This flag will enable prototypes.
  51
  52 =item B<-noversioncheck>
  53
  54 Disables the run time test that determines if the object file (derived
  55 from the C<.xs> file) and the C<.pm> files have the same version
  56 number.
  57
  58 =item B<-nolinenumbers>
  59
  60 Prevents the inclusion of `#line' directives in the output.
  61
  62 =back
  63
  64 =head1 ENVIRONMENT
  65
  66 No environment variables are used.
  67
  68 =head1 AUTHOR
  69
  70 Larry Wall
  71
  72 =head1 MODIFICATION HISTORY
  73
  74 See the file F<changes.pod>.
  75
  76 =head1 SEE ALSO
  77
  78 perl(1), perlxs(1), perlxstut(1)
  79
  80 =cut
  81
  82 require 5.002;
  83 use Cwd;
  84 use vars '$cplusplus';
  85 use vars '%v';
  86
  87 use Config;
  88
  89 sub Q ;
  90
  91 # Global Constants
  92
  93 $XSUBPP_version = "1.9507";
  94
  95 my ($Is_VMS, $SymSet);
  96 if ($^O eq 'VMS') {
  97     $Is_VMS = 1;
  98     # Establish set of global symbols with max length 28, since xsubpp
  99     # will later add the 'XS_' prefix.
 100     require ExtUtils::XSSymSet;
 101     $SymSet = new ExtUtils::XSSymSet 28;
 102 }
 103
 104 $FH = 'File0000' ;
 105
 106 $usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-s pattern] [-typemap typemap]... file.xs\n";
 107
 108 $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
 109 # mjn
 110 $OBJ   = 1 if $Config{'ccflags'} =~ /PERL_OBJECT/i;
 111
 112 $except = "";
 113 $WantPrototypes = -1 ;
 114 $WantVersionChk = 1 ;
 115 $ProtoUsed = 0 ;
 116 $WantLineNumbers = 1 ;
 117 SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) {
 118     $flag = shift @ARGV;
 119     $flag =~ s/^-// ;
 120     $spat = quotemeta shift,    next SWITCH     if $flag eq 's';
 121     $cplusplus = 1,     next SWITCH     if $flag eq 'C++';
 122     $WantPrototypes = 0, next SWITCH    if $flag eq 'noprototypes';
 123     $WantPrototypes = 1, next SWITCH    if $flag eq 'prototypes';
 124     $WantVersionChk = 0, next SWITCH    if $flag eq 'noversioncheck';
 125     $WantVersionChk = 1, next SWITCH    if $flag eq 'versioncheck';
 126     # XXX left this in for compat
 127     $WantCAPI = 1, next SWITCH    if $flag eq 'object_capi';
 128     $except = " TRY",   next SWITCH     if $flag eq 'except';
 129     push(@tm,shift),    next SWITCH     if $flag eq 'typemap';
 130     $WantLineNumbers = 0, next SWITCH   if $flag eq 'nolinenumbers';
 131     $WantLineNumbers = 1, next SWITCH   if $flag eq 'linenumbers';
 132     (print "xsubpp version $XSUBPP_version\n"), exit
 133         if $flag eq 'v';
 134     die $usage;
 135 }
 136 if ($WantPrototypes == -1)
 137   { $WantPrototypes = 0}
 138 else
 139   { $ProtoUsed = 1 }
 140
 141
 142 @ARGV == 1 or die $usage;
 143 ($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)#
 144         or ($dir, $filename) = $ARGV[0] =~ m#(.*)\\(.*)#
 145         or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)#
 146         or ($dir, $filename) = ('.', $ARGV[0]);
 147 chdir($dir);
 148 $pwd = cwd();
 149
 150 ++ $IncludedFiles{$ARGV[0]} ;
 151
 152 my(@XSStack) = ({type => 'none'});      # Stack of conditionals and INCLUDEs
 153 my($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA");
 154
 155
 156 sub TrimWhitespace
 157 {
 158     $_[0] =~ s/^\s+|\s+$//go ;
 159 }
 160
 161 sub TidyType
 162 {
 163     local ($_) = @_ ;
 164
 165     # rationalise any '*' by joining them into bunches and removing whitespace
 166     s#\s*(\*+)\s*#$1#g;
 167     s#(\*+)# $1 #g ;
 168
 169     # change multiple whitespace into a single space
 170     s/\s+/ /g ;
 171
 172     # trim leading & trailing whitespace
 173     TrimWhitespace($_) ;
 174
 175     $_ ;
 176 }
 177
 178 $typemap = shift @ARGV;
 179 foreach $typemap (@tm) {
 180     die "Can't find $typemap in $pwd\n" unless -r $typemap;
 181 }
 182 unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
 183                 ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
 184                 ../typemap typemap);
 185 foreach $typemap (@tm) {
 186     next unless -e $typemap ;
 187     # skip directories, binary files etc.
 188     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
 189         unless -T $typemap ;
 190     open(TYPEMAP, $typemap)
 191         or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
 192     $mode = 'Typemap';
 193     $junk = "" ;
 194     $current = \$junk;
 195     while (<TYPEMAP>) {
 196         next if /^\s*#/;
 197         my $line_no = $. + 1;
 198         if (/^INPUT\s*$/)   { $mode = 'Input';   $current = \$junk;  next; }
 199         if (/^OUTPUT\s*$/)  { $mode = 'Output';  $current = \$junk;  next; }
 200         if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk;  next; }
 201         if ($mode eq 'Typemap') {
 202             chomp;
 203             my $line = $_ ;
 204             TrimWhitespace($_) ;
 205             # skip blank lines and comment lines
 206             next if /^$/ or /^#/ ;
 207             my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
 208                 warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
 209             $type = TidyType($type) ;
 210             $type_kind{$type} = $kind ;
 211             # prototype defaults to '$'
 212             $proto = "\$" unless $proto ;
 213             warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
 214                 unless ValidProtoString($proto) ;
 215             $proto_letter{$type} = C_string($proto) ;
 216         }
 217         elsif (/^\s/) {
 218             $$current .= $_;
 219         }
 220         elsif ($mode eq 'Input') {
 221             s/\s+$//;
 222             $input_expr{$_} = '';
 223             $current = \$input_expr{$_};
 224         }
 225         else {
 226             s/\s+$//;
 227             $output_expr{$_} = '';
 228             $current = \$output_expr{$_};
 229         }
 230     }
 231     close(TYPEMAP);
 232 }
 233
 234 foreach $key (keys %input_expr) {
 235     $input_expr{$key} =~ s/\n+$//;
 236 }
 237
 238 $END = "!End!\n\n";             # "impossible" keyword (multiple newline)
 239
 240 # Match an XS keyword
 241 $BLOCK_re= '\s*(' . join('|', qw(
 242         REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT
 243         CLEANUP ALIAS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
 244         SCOPE INTERFACE INTERFACE_MACRO C_ARGS
 245         )) . "|$END)\\s*:";
 246
 247 # Input:  ($_, @line) == unparsed input.
 248 # Output: ($_, @line) == (rest of line, following lines).
 249 # Return: the matched keyword if found, otherwise 0
 250 sub check_keyword {
 251         $_ = shift(@line) while !/\S/ && @line;
 252         s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
 253 }
 254
 255
 256 if ($WantLineNumbers) {
 257     {
 258         package xsubpp::counter;
 259         sub TIEHANDLE {
 260             my ($class, $cfile) = @_;
 261             my $buf = "";
 262             $SECTION_END_MARKER = "#line --- \"$cfile\"";
 263             $line_no = 1;
 264             bless \$buf;
 265         }
 266
 267         sub PRINT {
 268             my $self = shift;
 269             for (@_) {
 270                 $$self .= $_;
 271                 while ($$self =~ s/^([^\n]*\n)//) {
 272                     my $line = $1;
 273                     ++ $line_no;
 274                     $line =~ s|^\#line\s+---(?=\s)|#line $line_no|;
 275                     print STDOUT $line;
 276                 }
 277             }
 278         }
 279
 280         sub PRINTF {
 281             my $self = shift;
 282             my $fmt = shift;
 283             $self->PRINT(sprintf($fmt, @_));
 284         }
 285
 286         sub DESTROY {
 287             # Not necessary if we're careful to end with a "\n"
 288             my $self = shift;
 289             print STDOUT $$self;
 290         }
 291     }
 292
 293     my $cfile = $filename;
 294     $cfile =~ s/\.xs$/.c/i or $cfile .= ".c";
 295     tie(*PSEUDO_STDOUT, 'xsubpp::counter', $cfile);
 296     select PSEUDO_STDOUT;
 297 }
 298
 299 sub print_section {
 300     # the "do" is required for right semantics
 301     do { $_ = shift(@line) } while !/\S/ && @line;
 302
 303     print("#line ", $line_no[@line_no - @line -1], " \"$filename\"\n")
 304         if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
 305     for (;  defined($_) && !/^$BLOCK_re/o;  $_ = shift(@line)) {
 306         print "$_\n";
 307     }
 308     print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers;
 309 }
 310
 311 sub merge_section {
 312     my $in = '';
 313
 314     while (!/\S/ && @line) {
 315         $_ = shift(@line);
 316     }
 317
 318     for (;  defined($_) && !/^$BLOCK_re/o;  $_ = shift(@line)) {
 319         $in .= "$_\n";
 320     }
 321     chomp $in;
 322     return $in;
 323 }
 324
 325 sub process_keyword($)
 326 {
 327     my($pattern) = @_ ;
 328     my $kwd ;
 329
 330     &{"${kwd}_handler"}()
 331         while $kwd = check_keyword($pattern) ;
 332 }
 333
 334 sub CASE_handler {
 335     blurt ("Error: `CASE:' after unconditional `CASE:'")
 336         if $condnum && $cond eq '';
 337     $cond = $_;
 338     TrimWhitespace($cond);
 339     print "   ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
 340     $_ = '' ;
 341 }
 342
 343 sub INPUT_handler {
 344     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
 345         last if /^\s*NOT_IMPLEMENTED_YET/;
 346         next unless /\S/;       # skip blank lines
 347
 348         TrimWhitespace($_) ;
 349         my $line = $_ ;
 350
 351         # remove trailing semicolon if no initialisation
 352         s/\s*;$//g unless /[=;+].*\S/ ;
 353
 354         # check for optional initialisation code
 355         my $var_init = '' ;
 356         $var_init = $1 if s/\s*([=;+].*)$//s ;
 357         $var_init =~ s/"/\\"/g;
 358
 359         s/\s+/ /g;
 360         my ($var_type, $var_addr, $var_name) = /^(.*?[^& ]) *(\&?) *\b(\w+)$/s
 361             or blurt("Error: invalid argument declaration '$line'"), next;
 362
 363         # Check for duplicate definitions
 364         blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
 365             if $arg_list{$var_name} ++  ;
 366
 367         $thisdone |= $var_name eq "THIS";
 368         $retvaldone |= $var_name eq "RETVAL";
 369         $var_types{$var_name} = $var_type;
 370         # XXXX This check is a safeguard against the unfinished conversion of
 371         # generate_init().  When generate_init() is fixed,
 372         # one can use 2-args map_type() unconditionally.
 373         if ($var_type =~ / \( \s* \* \s* \) /x) {
 374           # Function pointers are not yet supported with &output_init!
 375           print "\t" . &map_type($var_type, $var_name);
 376           $name_printed = 1;
 377         } else {
 378           print "\t" . &map_type($var_type);
 379           $name_printed = 0;
 380         }
 381         $var_num = $args_match{$var_name};
 382
 383         $proto_arg[$var_num] = ProtoString($var_type)
 384             if $var_num ;
 385         if ($var_addr) {
 386             $var_addr{$var_name} = 1;
 387             $func_args =~ s/\b($var_name)\b/&$1/;
 388         }
 389         if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/) {
 390           if ($name_printed) {
 391             print ";\n";
 392           } else {
 393             print "\t$var_name_after;\n";
 394           }
 395         } elsif ($var_init =~ /\S/) {
 396             &output_init($var_type, $var_num, $var_name, $var_init, $name_printed);
 397         } elsif ($var_num) {
 398             # generate initialization code
 399             &generate_init($var_type, $var_num, $var_name, $name_printed);
 400         } else {
 401             print ";\n";
 402         }
 403     }
 404 }
 405
 406 sub OUTPUT_handler {
 407     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
 408         next unless /\S/;
 409         if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
 410             $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0);
 411             next;
 412         }
 413         my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
 414         blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
 415             if $outargs{$outarg} ++ ;
 416         if (!$gotRETVAL and $outarg eq 'RETVAL') {
 417             # deal with RETVAL last
 418             $RETVAL_code = $outcode ;
 419             $gotRETVAL = 1 ;
 420             next ;
 421         }
 422         blurt ("Error: OUTPUT $outarg not an argument"), next
 423             unless defined($args_match{$outarg});
 424         blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
 425             unless defined $var_types{$outarg} ;
 426         $var_num = $args_match{$outarg};
 427         if ($outcode) {
 428             print "\t$outcode\n";
 429             print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic;
 430         } else {
 431             &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
 432         }
 433     }
 434 }
 435
 436 sub C_ARGS_handler() {
 437     my $in = merge_section();
 438
 439     TrimWhitespace($in);
 440     $func_args = $in;
 441 }
 442
 443 sub INTERFACE_MACRO_handler() {
 444     my $in = merge_section();
 445
 446     TrimWhitespace($in);
 447     if ($in =~ /\s/) {          # two
 448         ($interface_macro, $interface_macro_set) = split ' ', $in;
 449     } else {
 450         $interface_macro = $in;
 451         $interface_macro_set = 'UNKNOWN_CVT'; # catch later
 452     }
 453     $interface = 1;             # local
 454     $Interfaces = 1;            # global
 455 }
 456
 457 sub INTERFACE_handler() {
 458     my $in = merge_section();
 459
 460     TrimWhitespace($in);
 461
 462     foreach (split /[\s,]+/, $in) {
 463         $Interfaces{$_} = $_;
 464     }
 465     print Q<<"EOF";
 466 #       XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
 467 EOF
 468     $interface = 1;             # local
 469     $Interfaces = 1;            # global
 470 }
 471
 472 sub CLEANUP_handler() { print_section() }
 473 sub PREINIT_handler() { print_section() }
 474 sub INIT_handler()    { print_section() }
 475
 476 sub GetAliases
 477 {
 478     my ($line) = @_ ;
 479     my ($orig) = $line ;
 480     my ($alias) ;
 481     my ($value) ;
 482
 483     # Parse alias definitions
 484     # format is
 485     #    alias = value alias = value ...
 486
 487     while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
 488         $alias = $1 ;
 489         $orig_alias = $alias ;
 490         $value = $2 ;
 491
 492         # check for optional package definition in the alias
 493         $alias = $Packprefix . $alias if $alias !~ /::/ ;
 494
 495         # check for duplicate alias name & duplicate value
 496         Warn("Warning: Ignoring duplicate alias '$orig_alias'")
 497             if defined $XsubAliases{$alias} ;
 498
 499         Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
 500             if $XsubAliasValues{$value} ;
 501
 502         $XsubAliases = 1;
 503         $XsubAliases{$alias} = $value ;
 504         $XsubAliasValues{$value} = $orig_alias ;
 505     }
 506
 507     blurt("Error: Cannot parse ALIAS definitions from '$orig'")
 508         if $line ;
 509 }
 510
 511 sub ALIAS_handler ()
 512 {
 513     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
 514         next unless /\S/;
 515         TrimWhitespace($_) ;
 516         GetAliases($_) if $_ ;
 517     }
 518 }
 519
 520 sub REQUIRE_handler ()
 521 {
 522     # the rest of the current line should contain a version number
 523     my ($Ver) = $_ ;
 524
 525     TrimWhitespace($Ver) ;
 526
 527     death ("Error: REQUIRE expects a version number")
 528         unless $Ver ;
 529
 530     # check that the version number is of the form n.n
 531     death ("Error: REQUIRE: expected a number, got '$Ver'")
 532         unless $Ver =~ /^\d+(\.\d*)?/ ;
 533
 534     death ("Error: xsubpp $Ver (or better) required--this is only $XSUBPP_version.")
 535         unless $XSUBPP_version >= $Ver ;
 536 }
 537
 538 sub VERSIONCHECK_handler ()
 539 {
 540     # the rest of the current line should contain either ENABLE or
 541     # DISABLE
 542
 543     TrimWhitespace($_) ;
 544
 545     # check for ENABLE/DISABLE
 546     death ("Error: VERSIONCHECK: ENABLE/DISABLE")
 547         unless /^(ENABLE|DISABLE)/i ;
 548
 549     $WantVersionChk = 1 if $1 eq 'ENABLE' ;
 550     $WantVersionChk = 0 if $1 eq 'DISABLE' ;
 551
 552 }
 553
 554 sub PROTOTYPE_handler ()
 555 {
 556     my $specified ;
 557
 558     death("Error: Only 1 PROTOTYPE definition allowed per xsub")
 559         if $proto_in_this_xsub ++ ;
 560
 561     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
 562         next unless /\S/;
 563         $specified = 1 ;
 564         TrimWhitespace($_) ;
 565         if ($_ eq 'DISABLE') {
 566            $ProtoThisXSUB = 0
 567         }
 568         elsif ($_ eq 'ENABLE') {
 569            $ProtoThisXSUB = 1
 570         }
 571         else {
 572             # remove any whitespace
 573             s/\s+//g ;
 574             death("Error: Invalid prototype '$_'")
 575                 unless ValidProtoString($_) ;
 576             $ProtoThisXSUB = C_string($_) ;
 577         }
 578     }
 579
 580     # If no prototype specified, then assume empty prototype ""
 581     $ProtoThisXSUB = 2 unless $specified ;
 582
 583     $ProtoUsed = 1 ;
 584
 585 }
 586
 587 sub SCOPE_handler ()
 588 {
 589     death("Error: Only 1 SCOPE declaration allowed per xsub")
 590         if $scope_in_this_xsub ++ ;
 591
 592     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
 593                 next unless /\S/;
 594                 TrimWhitespace($_) ;
 595         if ($_ =~ /^DISABLE/i) {
 596                    $ScopeThisXSUB = 0
 597         }
 598         elsif ($_ =~ /^ENABLE/i) {
 599                    $ScopeThisXSUB = 1
 600         }
 601     }
 602
 603 }
 604
 605 sub PROTOTYPES_handler ()
 606 {
 607     # the rest of the current line should contain either ENABLE or
 608     # DISABLE
 609
 610     TrimWhitespace($_) ;
 611
 612     # check for ENABLE/DISABLE
 613     death ("Error: PROTOTYPES: ENABLE/DISABLE")
 614         unless /^(ENABLE|DISABLE)/i ;
 615
 616     $WantPrototypes = 1 if $1 eq 'ENABLE' ;
 617     $WantPrototypes = 0 if $1 eq 'DISABLE' ;
 618     $ProtoUsed = 1 ;
 619
 620 }
 621
 622 sub INCLUDE_handler ()
 623 {
 624     # the rest of the current line should contain a valid filename
 625
 626     TrimWhitespace($_) ;
 627
 628     death("INCLUDE: filename missing")
 629         unless $_ ;
 630
 631     death("INCLUDE: output pipe is illegal")
 632         if /^\s*\|/ ;
 633
 634     # simple minded recursion detector
 635     death("INCLUDE loop detected")
 636         if $IncludedFiles{$_} ;
 637
 638     ++ $IncludedFiles{$_} unless /\|\s*$/ ;
 639
 640     # Save the current file context.
 641     push(@XSStack, {
 642         type            => 'file',
 643         LastLine        => $lastline,
 644         LastLineNo      => $lastline_no,
 645         Line            => \@line,
 646         LineNo          => \@line_no,
 647         Filename        => $filename,
 648         Handle          => $FH,
 649         }) ;
 650
 651     ++ $FH ;
 652
 653     # open the new file
 654     open ($FH, "$_") or death("Cannot open '$_': $!") ;
 655
 656     print Q<<"EOF" ;
 657 #
 658 #/* INCLUDE:  Including '$_' from '$filename' */
 659 #
 660 EOF
 661
 662     $filename = $_ ;
 663
 664     # Prime the pump by reading the first
 665     # non-blank line
 666
 667     # skip leading blank lines
 668     while (<$FH>) {
 669         last unless /^\s*$/ ;
 670     }
 671
 672     $lastline = $_ ;
 673     $lastline_no = $. ;
 674
 675 }
 676
 677 sub PopFile()
 678 {
 679     return 0 unless $XSStack[-1]{type} eq 'file' ;
 680
 681     my $data     = pop @XSStack ;
 682     my $ThisFile = $filename ;
 683     my $isPipe   = ($filename =~ /\|\s*$/) ;
 684
 685     -- $IncludedFiles{$filename}
 686         unless $isPipe ;
 687
 688     close $FH ;
 689
 690     $FH         = $data->{Handle} ;
 691     $filename   = $data->{Filename} ;
 692     $lastline   = $data->{LastLine} ;
 693     $lastline_no = $data->{LastLineNo} ;
 694     @line       = @{ $data->{Line} } ;
 695     @line_no    = @{ $data->{LineNo} } ;
 696
 697     if ($isPipe and $? ) {
 698         -- $lastline_no ;
 699         print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n"  ;
 700         exit 1 ;
 701     }
 702
 703     print Q<<"EOF" ;
 704 #
 705 #/* INCLUDE: Returning to '$filename' from '$ThisFile' */
 706 #
 707 EOF
 708
 709     return 1 ;
 710 }
 711
 712 sub ValidProtoString ($)
 713 {
 714     my($string) = @_ ;
 715
 716     if ( $string =~ /^$proto_re+$/ ) {
 717         return $string ;
 718     }
 719
 720     return 0 ;
 721 }
 722
 723 sub C_string ($)
 724 {
 725     my($string) = @_ ;
 726
 727     $string =~ s[\\][\\\\]g ;
 728     $string ;
 729 }
 730
 731 sub ProtoString ($)
 732 {
 733     my ($type) = @_ ;
 734
 735     $proto_letter{$type} or "\$" ;
 736 }
 737
 738 sub check_cpp {
 739     my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
 740     if (@cpp) {
 741         my ($cpp, $cpplevel);
 742         for $cpp (@cpp) {
 743             if ($cpp =~ /^\#\s*if/) {
 744                 $cpplevel++;
 745             } elsif (!$cpplevel) {
 746                 Warn("Warning: #else/elif/endif without #if in this function");
 747                 print STDERR "    (precede it with a blank line if the matching #if is outside the function)\n"
 748                     if $XSStack[-1]{type} eq 'if';
 749                 return;
 750             } elsif ($cpp =~ /^\#\s*endif/) {
 751                 $cpplevel--;
 752             }
 753         }
 754         Warn("Warning: #if without #endif in this function") if $cpplevel;
 755     }
 756 }
 757
 758
 759 sub Q {
 760     my($text) = @_;
 761     $text =~ s/^#//gm;
 762     $text =~ s/\[\[/{/g;
 763     $text =~ s/\]\]/}/g;
 764     $text;
 765 }
 766
 767 open($FH, $filename) or die "cannot open $filename: $!\n";
 768
 769 # Identify the version of xsubpp used
 770 print <<EOM ;
 771 /*
 772  * This file was generated automatically by xsubpp version $XSUBPP_version from the
 773  * contents of $filename. Do not edit this file, edit $filename instead.
 774  *
 775  *      ANY CHANGES MADE HERE WILL BE LOST!
 776  *
 777  */
 778
 779 EOM
 780
 781
 782 print("#line 1 \"$filename\"\n")
 783     if $WantLineNumbers;
 784
 785 while (<$FH>) {
 786     last if ($Module, $Package, $Prefix) =
 787         /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
 788
 789     if ($OBJ) {
 790         s/#if(?:def\s|\s+defined)\s*(\(__cplusplus\)|__cplusplus)/#if defined(__cplusplus) && !defined(PERL_OBJECT)/;
 791     }
 792     print $_;
 793 }
 794 &Exit unless defined $_;
 795
 796 print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers;
 797
 798 $lastline    = $_;
 799 $lastline_no = $.;
 800
 801 # Read next xsub into @line from ($lastline, <$FH>).
 802 sub fetch_para {
 803     # parse paragraph
 804     death ("Error: Unterminated `#if/#ifdef/#ifndef'")
 805         if !defined $lastline && $XSStack[-1]{type} eq 'if';
 806     @line = ();
 807     @line_no = () ;
 808     return PopFile() if !defined $lastline;
 809
 810     if ($lastline =~
 811         /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
 812         $Module = $1;
 813         $Package = defined($2) ? $2 : '';       # keep -w happy
 814         $Prefix  = defined($3) ? $3 : '';       # keep -w happy
 815         $Prefix = quotemeta $Prefix ;
 816         ($Module_cname = $Module) =~ s/\W/_/g;
 817         ($Packid = $Package) =~ tr/:/_/;
 818         $Packprefix = $Package;
 819         $Packprefix .= "::" if $Packprefix ne "";
 820         $lastline = "";
 821     }
 822
 823     for(;;) {
 824         if ($lastline !~ /^\s*#/ ||
 825             # CPP directives:
 826             #   ANSI:   if ifdef ifndef elif else endif define undef
 827             #           line error pragma
 828             #   gcc:    warning include_next
 829             #   obj-c:  import
 830             #   others: ident (gcc notes that some cpps have this one)
 831             $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
 832             last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
 833             push(@line, $lastline);
 834             push(@line_no, $lastline_no) ;
 835         }
 836
 837         # Read next line and continuation lines
 838         last unless defined($lastline = <$FH>);
 839         $lastline_no = $.;
 840         my $tmp_line;
 841         $lastline .= $tmp_line
 842             while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
 843
 844         chomp $lastline;
 845         $lastline =~ s/^\s+$//;
 846     }
 847     pop(@line), pop(@line_no) while @line && $line[-1] eq "";
 848     1;
 849 }
 850
 851 PARAGRAPH:
 852 while (fetch_para()) {
 853     # Print initial preprocessor statements and blank lines
 854     while (@line && $line[0] !~ /^[^\#]/) {
 855         my $line = shift(@line);
 856         print $line, "\n";
 857         next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
 858         my $statement = $+;
 859         if ($statement eq 'if') {
 860             $XSS_work_idx = @XSStack;
 861             push(@XSStack, {type => 'if'});
 862         } else {
 863             death ("Error: `$statement' with no matching `if'")
 864                 if $XSStack[-1]{type} ne 'if';
 865             if ($XSStack[-1]{varname}) {
 866                 push(@InitFileCode, "#endif\n");
 867                 push(@BootCode,     "#endif");
 868             }
 869
 870             my(@fns) = keys %{$XSStack[-1]{functions}};
 871             if ($statement ne 'endif') {
 872                 # Hide the functions defined in other #if branches, and reset.
 873                 @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns;
 874                 @{$XSStack[-1]}{qw(varname functions)} = ('', {});
 875             } else {
 876                 my($tmp) = pop(@XSStack);
 877                 0 while (--$XSS_work_idx
 878                          && $XSStack[$XSS_work_idx]{type} ne 'if');
 879                 # Keep all new defined functions
 880                 push(@fns, keys %{$tmp->{other_functions}});
 881                 @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
 882             }
 883         }
 884     }
 885
 886     next PARAGRAPH unless @line;
 887
 888     if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) {
 889         # We are inside an #if, but have not yet #defined its xsubpp variable.
 890         print "#define $cpp_next_tmp 1\n\n";
 891         push(@InitFileCode, "#if $cpp_next_tmp\n");
 892         push(@BootCode,     "#if $cpp_next_tmp");
 893         $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++;
 894     }
 895
 896     death ("Code is not inside a function"
 897            ." (maybe last function was ended by a blank line "
 898            ." followed by a a statement on column one?)")
 899         if $line[0] =~ /^\s/;
 900
 901     # initialize info arrays
 902     undef(%args_match);
 903     undef(%var_types);
 904     undef(%var_addr);
 905     undef(%defaults);
 906     undef($class);
 907     undef($static);
 908     undef($elipsis);
 909     undef($wantRETVAL) ;
 910     undef(%arg_list) ;
 911     undef(@proto_arg) ;
 912     undef($proto_in_this_xsub) ;
 913     undef($scope_in_this_xsub) ;
 914     undef($interface);
 915     $interface_macro = 'XSINTERFACE_FUNC' ;
 916     $interface_macro_set = 'XSINTERFACE_FUNC_SET' ;
 917     $ProtoThisXSUB = $WantPrototypes ;
 918     $ScopeThisXSUB = 0;
 919
 920     $_ = shift(@line);
 921     while ($kwd = check_keyword("REQUIRE|PROTOTYPES|VERSIONCHECK|INCLUDE")) {
 922         &{"${kwd}_handler"}() ;
 923         next PARAGRAPH unless @line ;
 924         $_ = shift(@line);
 925     }
 926
 927     if (check_keyword("BOOT")) {
 928         &check_cpp;
 929         push (@BootCode, "#line $line_no[@line_no - @line] \"$filename\"")
 930           if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/;
 931         push (@BootCode, @line, "") ;
 932         next PARAGRAPH ;
 933     }
 934
 935
 936     # extract return type, function name and arguments
 937     ($ret_type) = TidyType($_);
 938
 939     # a function definition needs at least 2 lines
 940     blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
 941         unless @line ;
 942
 943     $static = 1 if $ret_type =~ s/^static\s+//;
 944
 945     $func_header = shift(@line);
 946     blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
 947         unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*$/s;
 948
 949     ($class, $func_name, $orig_args) =  ($1, $2, $3) ;
 950     $class = "$4 $class" if $4;
 951     ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
 952     ($clean_func_name = $func_name) =~ s/^$Prefix//;
 953     $Full_func_name = "${Packid}_$clean_func_name";
 954     if ($Is_VMS) { $Full_func_name = $SymSet->addsym($Full_func_name); }
 955
 956     # Check for duplicate function definition
 957     for $tmp (@XSStack) {
 958         next unless defined $tmp->{functions}{$Full_func_name};
 959         Warn("Warning: duplicate function definition '$clean_func_name' detected");
 960         last;
 961     }
 962     $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
 963     %XsubAliases = %XsubAliasValues = %Interfaces = ();
 964     $DoSetMagic = 1;
 965
 966     @args = split(/\s*,\s*/, $orig_args);
 967     if (defined($class)) {
 968         my $arg0 = ((defined($static) or $func_name eq 'new')
 969                     ? "CLASS" : "THIS");
 970         unshift(@args, $arg0);
 971         ($orig_args = "$arg0, $orig_args") =~ s/^$arg0, $/$arg0/;
 972     }
 973     $orig_args =~ s/"/\\"/g;
 974     $min_args = $num_args = @args;
 975     foreach $i (0..$num_args-1) {
 976             if ($args[$i] =~ s/\.\.\.//) {
 977                     $elipsis = 1;
 978                     $min_args--;
 979                     if ($args[$i] eq '' && $i == $num_args - 1) {
 980                         pop(@args);
 981                         last;
 982                     }
 983             }
 984             if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
 985                     $min_args--;
 986                     $args[$i] = $1;
 987                     $defaults{$args[$i]} = $2;
 988                     $defaults{$args[$i]} =~ s/"/\\"/g;
 989             }
 990             $proto_arg[$i+1] = "\$" ;
 991     }
 992     if (defined($class)) {
 993             $func_args = join(", ", @args[1..$#args]);
 994     } else {
 995             $func_args = join(", ", @args);
 996     }
 997     @args_match{@args} = 1..@args;
 998
 999     $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
1000     $CODE = grep(/^\s*CODE\s*:/, @line);
1001     # Detect CODE: blocks which use ST(n)= or XST_m*(n,v)
1002     #   to set explicit return values.
1003     $EXPLICIT_RETURN = ($CODE &&
1004                 ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
1005     $ALIAS  = grep(/^\s*ALIAS\s*:/,  @line);
1006     $INTERFACE  = grep(/^\s*INTERFACE\s*:/,  @line);
1007
1008     # print function header
1009     print Q<<"EOF";
1010 #XS(XS_${Full_func_name})
1011 #[[
1012 #    dXSARGS;
1013 EOF
1014     print Q<<"EOF" if $ALIAS ;
1015 #    dXSI32;
1016 EOF
1017     print Q<<"EOF" if $INTERFACE ;
1018 #    dXSFUNCTION($ret_type);
1019 EOF
1020     if ($elipsis) {
1021         $cond = ($min_args ? qq(items < $min_args) : 0);
1022     }
1023     elsif ($min_args == $num_args) {
1024         $cond = qq(items != $min_args);
1025     }
1026     else {
1027         $cond = qq(items < $min_args || items > $num_args);
1028     }
1029
1030     print Q<<"EOF" if $except;
1031 #    char errbuf[1024];
1032 #    *errbuf = '\0';
1033 EOF
1034
1035     if ($ALIAS)
1036       { print Q<<"EOF" if $cond }
1037 #    if ($cond)
1038 #       Perl_croak(aTHX_ "Usage: %s($orig_args)", GvNAME(CvGV(cv)));
1039 EOF
1040     else
1041       { print Q<<"EOF" if $cond }
1042 #    if ($cond)
1043 #       Perl_croak(aTHX_ "Usage: $pname($orig_args)");
1044 EOF
1045
1046     print Q<<"EOF" if $PPCODE;
1047 #    SP -= items;
1048 EOF
1049
1050     # Now do a block of some sort.
1051
1052     $condnum = 0;
1053     $cond = '';                 # last CASE: condidional
1054     push(@line, "$END:");
1055     push(@line_no, $line_no[-1]);
1056     $_ = '';
1057     &check_cpp;
1058     while (@line) {
1059         &CASE_handler if check_keyword("CASE");
1060         print Q<<"EOF";
1061 #   $except [[
1062 EOF
1063
1064         # do initialization of input variables
1065         $thisdone = 0;
1066         $retvaldone = 0;
1067         $deferred = "";
1068         %arg_list = () ;
1069         $gotRETVAL = 0;
1070
1071         INPUT_handler() ;
1072         process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|PROTOTYPE|SCOPE") ;
1073
1074         print Q<<"EOF" if $ScopeThisXSUB;
1075 #   ENTER;
1076 #   [[
1077 EOF
1078
1079         if (!$thisdone && defined($class)) {
1080             if (defined($static) or $func_name eq 'new') {
1081                 print "\tchar *";
1082                 $var_types{"CLASS"} = "char *";
1083                 &generate_init("char *", 1, "CLASS");
1084             }
1085             else {
1086                 print "\t$class *";
1087                 $var_types{"THIS"} = "$class *";
1088                 &generate_init("$class *", 1, "THIS");
1089             }
1090         }
1091
1092         # do code
1093         if (/^\s*NOT_IMPLEMENTED_YET/) {
1094                 print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n";
1095                 $_ = '' ;
1096         } else {
1097                 if ($ret_type ne "void") {
1098                         print "\t" . &map_type($ret_type, 'RETVAL') . ";\n"
1099                                 if !$retvaldone;
1100                         $args_match{"RETVAL"} = 0;
1101                         $var_types{"RETVAL"} = $ret_type;
1102                 }
1103
1104                 print $deferred;
1105
1106         process_keyword("INIT|ALIAS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS") ;
1107
1108                 if (check_keyword("PPCODE")) {
1109                         print_section();
1110                         death ("PPCODE must be last thing") if @line;
1111                         print "\tLEAVE;\n" if $ScopeThisXSUB;
1112                         print "\tPUTBACK;\n\treturn;\n";
1113                 } elsif (check_keyword("CODE")) {
1114                         print_section() ;
1115                 } elsif (defined($class) and $func_name eq "DESTROY") {
1116                         print "\n\t";
1117                         print "delete THIS;\n";
1118                 } else {
1119                         print "\n\t";
1120                         if ($ret_type ne "void") {
1121                                 print "RETVAL = ";
1122                                 $wantRETVAL = 1;
1123                         }
1124                         if (defined($static)) {
1125                             if ($func_name eq 'new') {
1126                                 $func_name = "$class";
1127                             } else {
1128                                 print "${class}::";
1129                             }
1130                         } elsif (defined($class)) {
1131                             if ($func_name eq 'new') {
1132                                 $func_name .= " $class";
1133                             } else {
1134                                 print "THIS->";
1135                             }
1136                         }
1137                         $func_name =~ s/^($spat)//
1138                             if defined($spat);
1139                         $func_name = 'XSFUNCTION' if $interface;
1140                         print "$func_name($func_args);\n";
1141                 }
1142         }
1143
1144         # do output variables
1145         $gotRETVAL = 0;
1146         undef $RETVAL_code ;
1147         undef %outargs ;
1148         process_keyword("OUTPUT|ALIAS|PROTOTYPE");
1149
1150         # all OUTPUT done, so now push the return value on the stack
1151         if ($gotRETVAL && $RETVAL_code) {
1152             print "\t$RETVAL_code\n";
1153         } elsif ($gotRETVAL || $wantRETVAL) {
1154             # RETVAL almost never needs SvSETMAGIC()
1155             &generate_output($ret_type, 0, 'RETVAL', 0);
1156         }
1157
1158         # do cleanup
1159         process_keyword("CLEANUP|ALIAS|PROTOTYPE") ;
1160
1161         print Q<<"EOF" if $ScopeThisXSUB;
1162 #   ]]
1163 EOF
1164         print Q<<"EOF" if $ScopeThisXSUB and not $PPCODE;
1165 #   LEAVE;
1166 EOF
1167
1168         # print function trailer
1169         print Q<<EOF;
1170 #    ]]
1171 EOF
1172         print Q<<EOF if $except;
1173 #    BEGHANDLERS
1174 #    CATCHALL
1175 #       sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
1176 #    ENDHANDLERS
1177 EOF
1178         if (check_keyword("CASE")) {
1179             blurt ("Error: No `CASE:' at top of function")
1180                 unless $condnum;
1181             $_ = "CASE: $_";    # Restore CASE: label
1182             next;
1183         }
1184         last if $_ eq "$END:";
1185         death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function");
1186     }
1187
1188     print Q<<EOF if $except;
1189 #    if (errbuf[0])
1190 #       Perl_croak(aTHX_ errbuf);
1191 EOF
1192
1193     if ($ret_type ne "void" or $EXPLICIT_RETURN) {
1194         print Q<<EOF unless $PPCODE;
1195 #    XSRETURN(1);
1196 EOF
1197     } else {
1198         print Q<<EOF unless $PPCODE;
1199 #    XSRETURN_EMPTY;
1200 EOF
1201     }
1202
1203     print Q<<EOF;
1204 #]]
1205 #
1206 EOF
1207
1208     my $newXS = "newXS" ;
1209     my $proto = "" ;
1210
1211     # Build the prototype string for the xsub
1212     if ($ProtoThisXSUB) {
1213         $newXS = "newXSproto";
1214
1215         if ($ProtoThisXSUB eq 2) {
1216             # User has specified empty prototype
1217             $proto = ', ""' ;
1218         }
1219         elsif ($ProtoThisXSUB ne 1) {
1220             # User has specified a prototype
1221             $proto = ', "' . $ProtoThisXSUB . '"';
1222         }
1223         else {
1224             my $s = ';';
1225             if ($min_args < $num_args)  {
1226                 $s = '';
1227                 $proto_arg[$min_args] .= ";" ;
1228             }
1229             push @proto_arg, "$s\@"
1230                 if $elipsis ;
1231
1232             $proto = ', "' . join ("", @proto_arg) . '"';
1233         }
1234     }
1235
1236     if (%XsubAliases) {
1237         $XsubAliases{$pname} = 0
1238             unless defined $XsubAliases{$pname} ;
1239         while ( ($name, $value) = each %XsubAliases) {
1240             push(@InitFileCode, Q<<"EOF");
1241 #        cv = newXS(\"$name\", XS_$Full_func_name, file);
1242 #        XSANY.any_i32 = $value ;
1243 EOF
1244         push(@InitFileCode, Q<<"EOF") if $proto;
1245 #        sv_setpv((SV*)cv$proto) ;
1246 EOF
1247         }
1248     }
1249     elsif ($interface) {
1250         while ( ($name, $value) = each %Interfaces) {
1251             $name = "$Package\::$name" unless $name =~ /::/;
1252             push(@InitFileCode, Q<<"EOF");
1253 #        cv = newXS(\"$name\", XS_$Full_func_name, file);
1254 #        $interface_macro_set(cv,$value) ;
1255 EOF
1256             push(@InitFileCode, Q<<"EOF") if $proto;
1257 #        sv_setpv((SV*)cv$proto) ;
1258 EOF
1259         }
1260     }
1261     else {
1262         push(@InitFileCode,
1263              "        ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
1264     }
1265 }
1266
1267 # print initialization routine
1268
1269 print Q<<"EOF";
1270 ##ifdef __cplusplus
1271 #extern "C"
1272 ##endif
1273 EOF
1274
1275 print Q<<"EOF";
1276 #XS(boot_$Module_cname)
1277 EOF
1278
1279 print Q<<"EOF";
1280 #[[
1281 #    dXSARGS;
1282 #    char* file = __FILE__;
1283 #
1284 EOF
1285
1286 print Q<<"EOF" if $WantVersionChk ;
1287 #    XS_VERSION_BOOTCHECK ;
1288 #
1289 EOF
1290
1291 print Q<<"EOF" if defined $XsubAliases or defined $Interfaces ;
1292 #    {
1293 #        CV * cv ;
1294 #
1295 EOF
1296
1297 print @InitFileCode;
1298
1299 print Q<<"EOF" if defined $XsubAliases or defined $Interfaces ;
1300 #    }
1301 EOF
1302
1303 if (@BootCode)
1304 {
1305     print "\n    /* Initialisation Section */\n\n" ;
1306     @line = @BootCode;
1307     print_section();
1308     print "\n    /* End of Initialisation Section */\n\n" ;
1309 }
1310
1311 print Q<<"EOF";;
1312 #    XSRETURN_YES;
1313 #]]
1314 #
1315 EOF
1316
1317 warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
1318     unless $ProtoUsed ;
1319 &Exit;
1320
1321 sub output_init {
1322     local($type, $num, $var, $init, $name_printed) = @_;
1323     local($arg) = "ST(" . ($num - 1) . ")";
1324
1325     if(  $init =~ /^=/  ) {
1326         if ($name_printed) {
1327           eval qq/print " $init\\n"/;
1328         } else {
1329           eval qq/print "\\t$var $init\\n"/;
1330         }
1331         warn $@   if  $@;
1332     } else {
1333         if(  $init =~ s/^\+//  &&  $num  ) {
1334             &generate_init($type, $num, $var, $name_printed);
1335         } elsif ($name_printed) {
1336             print ";\n";
1337             $init =~ s/^;//;
1338         } else {
1339             eval qq/print "\\t$var;\\n"/;
1340             warn $@   if  $@;
1341             $init =~ s/^;//;
1342         }
1343         $deferred .= eval qq/"\\n\\t$init\\n"/;
1344         warn $@   if  $@;
1345     }
1346 }
1347
1348 sub Warn
1349 {
1350     # work out the line number
1351     my $line_no = $line_no[@line_no - @line -1] ;
1352
1353     print STDERR "@_ in $filename, line $line_no\n" ;
1354 }
1355
1356 sub blurt
1357 {
1358     Warn @_ ;
1359     $errors ++
1360 }
1361
1362 sub death
1363 {
1364     Warn @_ ;
1365     exit 1 ;
1366 }
1367
1368 sub generate_init {
1369     local($type, $num, $var) = @_;
1370     local($arg) = "ST(" . ($num - 1) . ")";
1371     local($argoff) = $num - 1;
1372     local($ntype);
1373     local($tk);
1374
1375     $type = TidyType($type) ;
1376     blurt("Error: '$type' not in typemap"), return
1377         unless defined($type_kind{$type});
1378
1379     ($ntype = $type) =~ s/\s*\*/Ptr/g;
1380     ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1381     $tk = $type_kind{$type};
1382     $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
1383     $type =~ tr/:/_/;
1384     blurt("Error: No INPUT definition for type '$type' found"), return
1385         unless defined $input_expr{$tk} ;
1386     $expr = $input_expr{$tk};
1387     if ($expr =~ /DO_ARRAY_ELEM/) {
1388         blurt("Error: '$subtype' not in typemap"), return
1389             unless defined($type_kind{$subtype});
1390         blurt("Error: No INPUT definition for type '$subtype' found"), return
1391             unless defined $input_expr{$type_kind{$subtype}} ;
1392         $subexpr = $input_expr{$type_kind{$subtype}};
1393         $subexpr =~ s/ntype/subtype/g;
1394         $subexpr =~ s/\$arg/ST(ix_$var)/g;
1395         $subexpr =~ s/\n\t/\n\t\t/g;
1396         $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
1397         $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
1398         $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
1399     }
1400     if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments
1401         $ScopeThisXSUB = 1;
1402     }
1403     if (defined($defaults{$var})) {
1404             $expr =~ s/(\t+)/$1    /g;
1405             $expr =~ s/        /\t/g;
1406             if ($name_printed) {
1407               print ";\n";
1408             } else {
1409               eval qq/print "\\t$var;\\n"/;
1410               warn $@   if  $@;
1411             }
1412             $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t    $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
1413             warn $@   if  $@;
1414     } elsif ($ScopeThisXSUB or $expr !~ /^\t\$var =/) {
1415             if ($name_printed) {
1416               print ";\n";
1417             } else {
1418               eval qq/print "\\t$var;\\n"/;
1419               warn $@   if  $@;
1420             }
1421             $deferred .= eval qq/"\\n$expr;\\n"/;
1422             warn $@   if  $@;
1423     } else {
1424             die "panic: do not know how to handle this branch for function pointers"
1425               if $name_printed;
1426             eval qq/print "$expr;\\n"/;
1427             warn $@   if  $@;
1428     }
1429 }
1430
1431 sub generate_output {
1432     local($type, $num, $var, $do_setmagic) = @_;
1433     local($arg) = "ST(" . ($num - ($num != 0)) . ")";
1434     local($argoff) = $num - 1;
1435     local($ntype);
1436
1437     $type = TidyType($type) ;
1438     if ($type =~ /^array\(([^,]*),(.*)\)/) {
1439             print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
1440             print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1441     } else {
1442             blurt("Error: '$type' not in typemap"), return
1443                 unless defined($type_kind{$type});
1444             blurt("Error: No OUTPUT definition for type '$type' found"), return
1445                 unless defined $output_expr{$type_kind{$type}} ;
1446             ($ntype = $type) =~ s/\s*\*/Ptr/g;
1447             $ntype =~ s/\(\)//g;
1448             ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1449             $expr = $output_expr{$type_kind{$type}};
1450             if ($expr =~ /DO_ARRAY_ELEM/) {
1451                 blurt("Error: '$subtype' not in typemap"), return
1452                     unless defined($type_kind{$subtype});
1453                 blurt("Error: No OUTPUT definition for type '$subtype' found"), return
1454                     unless defined $output_expr{$type_kind{$subtype}} ;
1455                 $subexpr = $output_expr{$type_kind{$subtype}};
1456                 $subexpr =~ s/ntype/subtype/g;
1457                 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1458                 $subexpr =~ s/\$var/${var}[ix_$var]/g;
1459                 $subexpr =~ s/\n\t/\n\t\t/g;
1460                 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
1461                 eval "print qq\a$expr\a";
1462                 warn $@   if  $@;
1463                 print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
1464             }
1465             elsif ($var eq 'RETVAL') {
1466                 if ($expr =~ /^\t\$arg = new/) {
1467                     # We expect that $arg has refcnt 1, so we need to
1468                     # mortalize it.
1469                     eval "print qq\a$expr\a";
1470                     warn $@   if  $@;
1471                     print "\tsv_2mortal(ST(0));\n";
1472                     print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
1473                 }
1474                 elsif ($expr =~ /^\s*\$arg\s*=/) {
1475                     # We expect that $arg has refcnt >=1, so we need
1476                     # to mortalize it!
1477                     eval "print qq\a$expr\a";
1478                     warn $@   if  $@;
1479                     print "\tsv_2mortal(ST(0));\n";
1480                     print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
1481                 }
1482                 else {
1483                     # Just hope that the entry would safely write it
1484                     # over an already mortalized value. By
1485                     # coincidence, something like $arg = &sv_undef
1486                     # works too.
1487                     print "\tST(0) = sv_newmortal();\n";
1488                     eval "print qq\a$expr\a";
1489                     warn $@   if  $@;
1490                     # new mortals don't have set magic
1491                 }
1492             }
1493             elsif ($arg =~ /^ST\(\d+\)$/) {
1494                 eval "print qq\a$expr\a";
1495                 warn $@   if  $@;
1496                 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1497             }
1498     }
1499 }
1500
1501 sub map_type {
1502     my($type, $varname) = @_;
1503
1504     $type =~ tr/:/_/;
1505     $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
1506     if ($varname) {
1507       if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) {
1508         (substr $type, pos $type, 0) = " $varname ";
1509       } else {
1510         $type .= "\t$varname";
1511       }
1512     }
1513     $type;
1514 }
1515
1516
1517 sub Exit {
1518 # If this is VMS, the exit status has meaning to the shell, so we
1519 # use a predictable value (SS$_Normal or SS$_Abort) rather than an
1520 # arbitrary number.
1521 #    exit ($Is_VMS ? ($errors ? 44 : 1) : $errors) ;
1522     exit ($errors ? 1 : 0);
1523 }