File Coverage

File:blib/lib/ExtUtils/ParseXS.pm
Coverage:59.7%

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