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