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