File Coverage

blib/lib/XS/Install/ParseXS.pm

Criterion	Covered	Total	%
statement	48	292	16.4
branch	0	132	0.0
condition	1	70	1.4
subroutine	15	32	46.8
pod	0	11	0.0
total	64	537	11.9

package # hide from CPAN indexer
    XS::Install::ParseXS;
use strict;
use warnings;
use feature 'state';
no warnings 'redefine';
use ExtUtils::ParseXS;
use ExtUtils::ParseXS::Eval;
use ExtUtils::ParseXS::Utilities;
use ExtUtils::Typemaps;
use ExtUtils::Typemaps::InputMap;
use ExtUtils::Typemaps::OutputMap;

my (@pre_callbacks, @no_typemap_callbacks);
our ($top_typemaps, $cur_typemaps);
our $cplus = grep { /-C\+\+/ } @ARGV;
my $re_quot1 = qr/"(?:[^"\\]+|\\.)*"/;
my $re_quot2 = qr/'(?:[^'\\]+|\\.)*'/;
my $re_quot  = qr/(?:$re_quot1|$re_quot2)/;
my $re_comment_single = qr#//[^\n]*\n#;
my $re_comment_multi  = qr#/\*.*?\*/#ms;
my $re_ignored = qr/(?:$re_quot|$re_comment_single|$re_comment_multi)/ms;
my $re_braces = qr#(?\{(?>[^/"'{}]+|$re_ignored|(?&braces)|/)*\})#ms;
our $re_xsub = qr/(XS_EUPXS\(XS_[a-zA-Z0-9_]+\))[^{]+($re_braces)/ms;
our $re_boot = qr/(XS_EXTERNAL\(boot_[a-zA-Z0-9_]+\))[^{]+($re_braces)/ms;

sub add_pre_callback        { push @pre_callbacks, shift; }
sub add_post_callback       { push @CatchEnd::post_callbacks, shift; }
sub add_no_typemap_callback { push @no_typemap_callbacks, shift; }

sub call {
	my ($cbs, @args) = @_;
	$_->(@args) for @$cbs;
}

sub code_start_idx {
	my $lines = shift;
    my $idx;
    for (my $i = 2; $i < @$lines; ++$i) {
        return $i+1 if $lines->[$i] =~ /^(PP)?CODE\s*:/;
    }
    die "code start not found";
}

sub code_end_idx {
    my $lines = shift;
    my $idx = code_start_idx($lines);
    for (; $idx < @$lines; ++$idx) {
        return $idx if $lines->[$idx] =~ /^[a-zA-Z0-9]+\s*:/;
    }
    return $idx;
}

sub is_empty {
    my $lines = shift;
    return code_start_idx($lines) == code_end_idx($lines);
}

sub insert_code_top {
	my ($parser, $code) = @_;
	my $lines = $parser->{line};
	my $linno = $parser->{line_no};
    my $idx = code_start_idx($lines);
    splice(@$lines, $idx, 0, $code);
    splice(@$linno, $idx, 0, $linno->[$idx] // $linno->[-1]);
}

sub insert_code_bottom {
	my ($parser, $code) = @_;
    my $lines = $parser->{line};
    my $linno = $parser->{line_no};
    my $idx = code_end_idx($lines);
    splice(@$lines, $idx, 0, $code);
    splice(@$linno, $idx, 0, $linno->[$idx] // $linno->[-1]);
}

my $orig_pmxl = \&ExtUtils::ParseXS::_process_module_xs_line;
*ExtUtils::ParseXS::_process_module_xs_line = sub {
    my ($self, $module, $pkg, $prefix) = @_;
	$orig_pmxl->(@_);
	$self->{xsi}{module} = $module;
	$self->{xsi}{inline_mode} = 0;
};

sub get_mode {
	return '' unless $_[0] =~ /^MODE\s*:\s*(\w+)\s*$/;
	return uc($1);
}

# pre process XS function
my $orig_fetch_para = \&ExtUtils::ParseXS::fetch_para;
*ExtUtils::ParseXS::fetch_para = sub {
    my $self = shift;
    my $ret = $orig_fetch_para->($self, @_);
    my $lines = $self->{line};
    my $linno = $self->{line_no};
    return $ret unless @$lines;

    if (get_mode($lines->[0]) eq 'INLINE') {
    	$self->{xsi}{inline_mode} = 1;
    	shift @$lines;
    	shift @$linno;
    }

    if ($self->{xsi}{inline_mode}) {
    	while (@$lines) {
    		my $line = shift @$lines;
    		shift @$linno;
    	    if (get_mode($line) eq 'XS') {
    	    	$self->{xsi}{inline_mode} = 0;
    	    	last;
    	    }
    	    print "$line\n";
    	}
    	return $ret unless @$lines;
    }

    # concat 2 lines codes (functions with default behaviour) to make it preprocessed like C-like synopsis
    if (@$lines == 2) {
        $lines->[0] .= ' '.$lines->[1];
        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; }
    }

    my %attrs;

    if ($lines->[0] and $lines->[0] =~ /^(.+?)\s+([^\s()]+\s*(\((?:[^()]|(?3))*\)))\s*(.*)/) {
        my ($type, $sig, $rest) = ($1, $2, $4);
        shift @$lines;
        my $deflinno = shift @$linno;

        my $remove_closing;
        if ((my $idx = index($rest, '{')) >= 0) { # move following text on next line
            $remove_closing = 1;
            my $content = substr($rest, $idx+1);
            substr($rest, $idx) = '';
            if ($content =~ /\S/) {
                unshift @$lines, $content;
                unshift @$linno, $deflinno;
            }
        } elsif ($lines->[0] and $lines->[0] =~ s/^\s*\{//) { # '{' on next line
            $remove_closing = 1;
            if ($lines->[0] !~ /\S/) { # nothing remains, delete entire line
                shift @$lines;
                shift @$linno;
            }
        }

        if ($remove_closing) {
            $lines->[-1] =~ s/}\s*;?\s*$//;
            if ($lines->[-1] !~ /\S/) { pop @$lines; pop @$linno; }

            if (!$lines->[0] or $lines->[0] !~ /\S/) { # no code remains, but body was present ({}), add empty code to prevent default behaviour
                $lines->[0] = ' ';
                $linno->[0] ||= $deflinno;
            }
        }

        if (length $lines->[0]) {
        	unshift @$lines, $type =~ /^void(\s|$)/ ? 'PPCODE:' : 'CODE:';
            unshift @$linno, $deflinno;
        }

        if ($rest =~ /:(.+)/) {
            my $attrs_str = $1;
            %attrs = ($attrs_str =~ /\s*([A-Za-z]+)\s*(?:\(([^()]*)\)|)\s*/g);
        }

        while (my ($attr, $val) = each %attrs) {
        	$attr = uc($attr);
        	if ($attr eq 'ALIAS' && (my @alias = split /\s*,\s*/, $val)) {
                foreach my $alias_entry (reverse @alias) {
                    unshift @$lines, "    $alias_entry";
                    unshift @$linno, $deflinno;
                }
                unshift @$lines, 'ALIAS:';
                unshift @$linno, $deflinno;
        	}
        	elsif ($attr eq 'CONST') { next }
        	elsif (defined $val) {
        		unshift @$lines, "$attr: $val";
                unshift @$linno, $deflinno;
        	}
        }

        unshift @$lines, $sig;
        unshift @$lines, $type;
        unshift @$linno, $deflinno for 1..2;
    }

    # make BOOT's code in personal scope
    if ($lines->[0] =~ /^BOOT\s*:/) {
        splice(@$lines, 1, 0, "    {");
        splice(@$linno, 1, 0, $linno->[0]);
        push @$lines, "    }";
        push @$linno, $linno->[-1];
    }

    map {
        s/\b__PACKAGE__\b/"$self->{Package}"/g;
        s/\b__MODULE__\b/"$self->{xsi}{module}"/g;
    } @$lines;

    my $out_type = $lines->[0] or return $ret;
    # filter out junk, because first line might be "BOOT:", "PROTOTYPES: ...", "INCLUDE: ...", "#ifdef", etc
    return $ret if !$out_type or $out_type =~ /^#/ or $out_type =~ /^[_A-Z]+\s*:([^:]|$)/;

    # parse signature -> $func and @args
    my $sig = $lines->[1];
    $sig =~ /^([^(]+)\((.*)\)\s*$/ or die "bad signature: '$sig', at $self->{filepathname}, function $self->{pname}";
    my $func = $1;
    my $args_str = $2;
    $func =~ s/^\s+//; $func =~ s/\s+$//;
    my @args;
    my $variadic;
    for my $str (split /\s*,\s*/, $args_str) {
    	my %info;
    	$info{default} = $1 if $str =~ s/\s*=\s*(.+)$//;
        $info{name}    = '';
    	$info{name}    = $1 if $str =~ s/([a-zA-Z0-9_\$]+)\s*$//;
        $info{type}    = $str;
    	if ($str eq '...') {
    		$variadic = 1;
    		next;
    	}
    	if (!$info{type}) { # arg with no name
            $info{type} = $info{name};
    		$info{name} = '';
    	}

    	map { s/^\s+//; s/\s+$// } values %info;
    	push @args, \%info;
    }

    if ($func =~ s/^(.+):://) { # replace 'Class::meth' with 'meth(Class* THIS)'
        unshift @args, $func eq 'new' ? {name => 'CLASS', type => 'SV*', orig_type => $1} :
                                        {name => 'THIS',  type => "$1*"};
    }

    my $first_arg = $args[0];
    $first_arg->{type} = 'const '.$first_arg->{type} if exists($attrs{const}) or exists($attrs{CONST});
    my $is_method = $first_arg && $first_arg->{name} eq 'THIS';

    my $para = join("\n", @$lines);

    if ($para !~ /^(PP)?CODE\s*:/m) { # empty function, replace with $func(@args) or $first_arg->$func(@rest_args)
        my $void = $out_type =~ /^void(?:\s|$)/;
        push @$lines, $void ? 'PPCODE:' : 'CODE:';
        push @$linno, $linno->[-1];
        if ($func ne 'new' and ($func ne 'DESTROY' or !$is_method)) {
            my $code = '';
	        my @real_args = @args;
	        if ($is_method) {
	        	shift @real_args;
	        	$code = $first_arg->{name}.'->';
	        }
	        $code .= $func.'('.join(', ', map { $_->{name} } @real_args).')';
	        $code = "RETVAL = $code" unless $void;
            push @$lines, "        $code;";
            push @$linno, $linno->[-1];
        }
    	$para = join("\n", @$lines);
    }

    if ($para =~ /^CODE\s*:/m and $para !~ /^OUTPUT\s*:/m) { # add OUTPUT:RETVAL unless any
        push @$lines, 'OUTPUT:', '    RETVAL';
        push @$linno, $linno->[-1] for 1..2;
        $para = join("\n", @$lines);
    }

    my $cb_args = {
        ret      => $out_type,
        func     => $func,
        args     => \@args,
        variadic => $variadic,
    };
    call(\@pre_callbacks, $self, $cb_args);

    # form final signature for ParseXS
    my @args_lines = map { "$_->{type} $_->{name}".(defined($_->{default}) ? " = $_->{default}" : '') } @args;
    push @args_lines, '...' if $variadic;
    $sig = $func.' ('.join(', ', @args_lines).')';

    $lines->[0] = $out_type;
    $lines->[1] = $sig;

    if (is_empty($lines)) {
    	if ($func eq 'DESTROY' and $is_method) {
    		insert_code_top($self, "    delete THIS;");
    	}
    	elsif ($func eq 'new') {
    		insert_code_top($self, "    RETVAL = ".default_constructor($out_type, \@args).';');
    	}
    }

    return $ret;
};

sub default_constructor {
	my ($ret_type, $args) = @_;
    my @pass_args = @$args;
    my $fa = shift @pass_args;
    my $args_str = join(', ', map { $_->{name} } @pass_args);
    my $new_type = $fa->{orig_type};
    unless ($new_type) {
        $new_type = $ret_type;
        $new_type =~ s/\s*\*$//;
    }
    my $ret = "new $new_type($args_str)";

    $ret = "$ret_type($ret)" unless $ret_type =~ /\*$/;

    return $ret;
}

{
    my $orig_merge = \&ExtUtils::Typemaps::merge;
    my $orig_parse = \&ExtUtils::Typemaps::_parse;
    my $orig_get   = \&ExtUtils::Typemaps::get_typemap;

    *ExtUtils::Typemaps::get_typemap = sub {
        my $ret = $orig_get->(@_);
        return $ret if $ret;
        call(\@no_typemap_callbacks, @_);
        return $orig_get->(@_);
    };

    *ExtUtils::Typemaps::merge = sub {
        $top_typemaps = $_[0];
        return $orig_merge->(@_);
    };

    *ExtUtils::Typemaps::_parse = sub {
        local $cur_typemaps = $_[0];
        return $orig_parse->(@_);
    };
}

{
    # remove ugly default behaviour, it always overrides typemaps in xsubpp's command line
    *ExtUtils::ParseXS::Utilities::standard_typemap_locations = sub {
        my $inc = shift;
        my @ret;
        push @ret, 'typemap' if -e 'typemap';
        return @ret;
    };
}

{
    package # hide from CPAN
        CatchEnd;
    use strict;
    use feature 'say';

    our @post_callbacks;

    my ($out, $orig_stdout);
    open $orig_stdout, '>&', STDOUT;
    close STDOUT;
    open STDOUT, '>', \$out or die $!; # This shouldn't fail

    #post-process XS out
    sub END {
        $out //= '';
        select $orig_stdout;

        $out =~ s/^MODE\s*:.+//mg;

        # remove XS function C-prototype (it causes warnings on many compilers)
        $out =~ s/XS_EUPXS\(XS_[a-zA-Z0-9_]+\);.*\n/\n/mg;

        # remove XS BOOT function C-prototype
        $out =~ s/XS_EXTERNAL\(boot_[a-zA-Z0-9_]+\);.*\n/\n/mg;

        XS::Install::ParseXS::call(\@post_callbacks, \$out);
        print $out;
    }
}

{
	package #hide from CPAN
            ExtUtils::ParseXS;
	my $END = "!End!\n\n";
	my $BLOCK_regexp = '\s*(' . $ExtUtils::ParseXS::Constants::XSKeywordsAlternation . "|$END)\\s*:";
    # copy-paste from ExtUtils::ParseXS to fix Typemaps with references (&). ParseXS was simply removing it from type
    # only one line changed with regexp
    # my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
    *INPUT_handler = sub {
	  my $self = shift;
	  $_ = shift;
	  for (;  !/^$BLOCK_regexp/o;  $_ = shift(@{ $self->{line} })) {
	    last if /^\s*NOT_IMPLEMENTED_YET/;
	    next unless /\S/;        # skip blank lines

	    trim_whitespace($_);
	    my $ln = $_;

	    # remove trailing semicolon if no initialisation
	    s/\s*;$//g unless /[=;+].*\S/;

	    # Process the length(foo) declarations
	    if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) {
	      print "\tSTRLEN\tSTRLEN_length_of_$2;\n";
	      $self->{lengthof}->{$2} = undef;
	      $self->{deferred} .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;\n";
	    }

	    # check for optional initialisation code
	    my $var_init = '';
	    $var_init = $1 if s/\s*([=;+].*)$//s;
	    $var_init =~ s/"/\\"/g;
	    # *sigh* It's valid to supply explicit input typemaps in the argument list...
	    my $is_overridden_typemap = $var_init =~ /ST\s*\(|\$arg\b/;

	    s/\s+/ /g;
	    my $var_addr = '';
	    my ($var_type, $var_name) = /^(.*?[^\s])\s*\b(\w+)$/s
	      or $self->blurt("Error: invalid argument declaration '$ln'"), next;

	    # Check for duplicate definitions
	    $self->blurt("Error: duplicate definition of argument '$var_name' ignored"), next
	      if $self->{arg_list}->{$var_name}++
	        or defined $self->{argtype_seen}->{$var_name} and not $self->{processing_arg_with_types};

	    $self->{thisdone} |= $var_name eq "THIS";
	    $self->{retvaldone} |= $var_name eq "RETVAL";
	    $self->{var_types}->{$var_name} = $var_type;
	    # XXXX This check is a safeguard against the unfinished conversion of
	    # generate_init().  When generate_init() is fixed,
	    # one can use 2-args map_type() unconditionally.
	    my $printed_name;
	    if ($var_type =~ / \( \s* \* \s* \) /x) {
	      # Function pointers are not yet supported with output_init()!
	      print "\t" . map_type($self, $var_type, $var_name);
	      $printed_name = 1;
	    }
	    else {
	      print "\t" . map_type($self, $var_type, undef);
	      $printed_name = 0;
	    }
	    $self->{var_num} = $self->{args_match}->{$var_name};

	    if ($self->{var_num}) {
	      my $typemap = $self->{typemap}->get_typemap(ctype => $var_type);
	      $self->report_typemap_failure($self->{typemap}, $var_type, "death")
	        if not $typemap and not $is_overridden_typemap;
	      $self->{proto_arg}->[$self->{var_num}] = ($typemap && $typemap->proto) || "\$";
	    }
	    $self->{func_args} =~ s/\b($var_name)\b/&$1/ if $var_addr;
	    if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
	      or $self->{in_out}->{$var_name} and $self->{in_out}->{$var_name} =~ /^OUT/
	      and $var_init !~ /\S/) {
	      if ($printed_name) {
	        print ";\n";
	      }
	      else {
	        print "\t$var_name;\n";
	      }
	    }
	    elsif ($var_init =~ /\S/) {
	      $self->output_init( {
	        type          => $var_type,
	        num           => $self->{var_num},
	        var           => $var_name,
	        init          => $var_init,
	        printed_name  => $printed_name,
	      } );
	    }
	    elsif ($self->{var_num}) {
	      $self->generate_init( {
	        type          => $var_type,
	        num           => $self->{var_num},
	        var           => $var_name,
	        printed_name  => $printed_name,
	      } );
	    }
	    else {
	      print ";\n";
	    }
	  }
	};
}

1;