File Coverage

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

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