view release on metacpan or  search on metacpan

lib/Panda/Install/ParseXS.pm  view on Meta::CPAN

        splice(@$lines, 1, 1);
        splice(@$linno, 1, 1);
    }
    
    if ($lines->[0] and $lines->[0] =~ /^([A-Z]+)\s*\{/) {
        $lines->[0] = "$1:";
        if ($lines->[-1] =~ /^\}/) { pop @$lines; pop @$linno; }
    }
    
    if ($lines->[0] and $lines->[0] =~ /^(.+?)\s+([^\s()]+\s*(\((?:[^()]+|(?3))*\)))\s*(.*)/) {
        my ($type, $sig, $attrs) = ($1, $2, $4);
        $self->{_xsub_attrs} = { $attrs =~ /:\s*([A-Z]+)\s*(?:\(([^()]*)\)|)\s*/gc };
        my $alias = $self->{_xsub_attrs}->{ALIAS};
        my $remove_closing;
        
        if ((my $idx = index($lines->[0], '{')) > 0) { # move following text on next line
            $remove_closing = 1;
            my $content = substr($lines->[0], $idx);
            if ($content !~ /^\{\s*$/) {
                $content =~ s/^\{//;
                splice(@$lines, 1, 0, $content);
                splice(@$linno, 1, 0, $linno->[0]);
            }
        } elsif ($lines->[1] and $lines->[1] =~ s/^\s*\{//) { # '{' on next line
            $remove_closing = 1;
            if ($lines->[1] !~ /\S/) { # nothing remains, delete entire line
                splice(@$lines, 1, 1);
                splice(@$linno, 1, 1);
            }
        }

        if ($remove_closing) {
            $lines->[-1] =~ s/}\s*;?\s*$//;
            if ($lines->[-1] !~ /\S/) { pop @$lines; pop @$linno; }
            
            if (!$lines->[1] or $lines->[1] !~ /\S/) { # no code remains, but body was present ({}), add empty code to prevent default behaviour
                splice(@$lines, 1, 0, ' ');
                splice(@$linno, 1, 0, $linno->[0]);
            }
        }
        
        $lines->[0] = $type;
        
        $self->{_empty_func} = 0;
        if (!$lines->[1]) {{ # empty sub
            $self->{_empty_func} = 1;
            my ($class, $func, $var);
            if ($sig =~ /^([^:]+)::([a-zA-Z0-9_\$]+)/) {
                ($class, $func, $var) = ("$1*", $2, 'THIS');
            } elsif ($sig =~ /^([a-zA-Z0-9_\$]+)\s*\(\s*([a-zA-Z0-9_\$*]+)\s+\*?([a-zA-Z0-9_\$]+)\)/) {
                ($class, $func, $var) = ($2, $1, $3);
            } else { last }
            my $in_tmap = $self->{typemap}->get_inputmap(ctype => $class) or last;
            if ($func eq 'DESTROY' and $var eq 'THIS' and $in_tmap->{_attrs}{PREVENT_DEFAULT_DESTROY}) {
                splice(@$lines, 1, 0, ' ');
                splice(@$linno, 1, 0, $linno->[0]);
            }
        }}
                
        if ($lines->[1] and $lines->[1] !~ /^[A-Z]+\s*:/) {
            splice(@$lines, 1, 0, $type =~ /^void(\s|$)/ ? 'PPCODE:' : 'CODE:');
            splice(@$linno, 1, 0, $linno->[0]);
        }
        
        if ($alias) {
            my @alias = split /\s*,\s*/, $alias;
            if (@alias) {
                foreach my $alias_entry (reverse @alias) {
                    splice(@$lines, 1, 0, "    $alias_entry");
                    splice(@$linno, 1, 0, $linno->[0]);
                }
                splice(@$lines, 1, 0, 'ALIAS:');
                splice(@$linno, 1, 0, $linno->[0]);
            }
        }
        
        splice(@$lines, 1, 0, $sig);
        splice(@$linno, 1, 0, $linno->[0]);
    } else {
        %{$self->{_xsub_attrs}} = ();
    }

    my $para = join("\n", @$lines);
    
    if ($para =~ /^CODE\s*:/m and $para !~ /^OUTPUT\s*:/m) {
        push @$lines, 'OUTPUT:', '    RETVAL';
        push @$linno, $linno->[-1]+1 for 1..2;
        $para = join("\n", @$lines);
    }
    
    if (my $out_ctype = $lines->[0]) {{
        $out_ctype =~ s/^\s+//g;
        $out_ctype =~ s/\s+$//g;
        my $out_tmap = $self->{typemap}->get_outputmap(ctype => $out_ctype) or last;
        my $init_code = $out_tmap->{_init_code} or last;
        my $idx;
        for (my $i = 2; $i < @$lines; ++$i) {
            next unless $lines->[$i] =~ /^\s*[a-zA-Z0-9]+\s*:/;
            $idx = $i;
            last;
        }
        last unless $idx;
        splice(@$lines, $idx, 0, $init_code);
        splice(@$linno, $idx, 0, $linno->[0]);
    }}

    $after_fetch_para->($self) if $after_fetch_para;
    
    return $ret;
}

# post process XS function
sub print_section {
    my $self = shift;
    my $lines = $self->{line};
    my $linno = $self->{line_no};
    
    # find typemap_in|outcast<>()
    my $re_parens = $Panda::Install::ParseXS::re_parens;
    my $re_gtlt   = $Panda::Install::ParseXS::re_gtlt;
    my %gen_funcs;