update-headers

#!/usr/bin/perl

use strict;
use warnings;
use Cwd;

my $path = $ARGV[0]
	or die "Path to Perl sources is required";

require "$path/regen/embed_lib.pl";

my $wrapall = 1;

# Unstable functions used by swiftperl
my %unstable_ok = map { $_ => 1 } qw/
	newXS_flags
	sv_dump
	sv_utf8_decode
/;

# Backported to older versions of Perl (see macro.h)
my @compat = qw/
	croak_sv
	mg_findext
/;

# Backward incompatible functions
my %skip = map { $_ => 1 } qw/
	blockhook_register
	cv_get_call_checker
	cv_set_call_checker
	cv_set_call_checker_flags
	newFOROP
	newUNOP_AUX
	newWHILEOP
	pad_add_anon
	sv_nolocking
	sv_vcatpvfn
	sv_vsetpvfn
/, @compat;

# embed.fnc has no nullability info for retval
my %retval_nullable = (
	av_delete      => 1,
	av_fetch       => 1,
	av_make        => 0,
	av_pop         => 0,
	av_shift       => 0,
	av_store       => 1,
	cv_name        => 0,
	get_av         => 1,
	get_cv         => 1,
	get_hv         => 1,
	get_sv         => 1,
	hv_delete      => 1,
	hv_delete_ent  => 1,
	hv_fetch       => 1,
	hv_fetch_ent   => 1,
	hv_iternext    => 1,
	hv_scalar      => 0,
	hv_store       => 1,
	hv_store_ent   => 1,
	newAV          => 0,
	newHV          => 0,
	newRV_noinc    => 0,
	newSV          => 0,
	newSV_type     => 0,
	newSVhek       => 0,
	newSViv        => 0,
	newSVnv        => 0,
	newSVpvn       => 0,
	newSVpvn_flags => 0,
	newSVpvn_share => 0,
	newSVrv        => 0,
	newSVsv        => 1,
	newSVuv        => 0,
	newXS          => 0,
	newXS_flags    => 0,
	perl_alloc     => 1,
	sv_2mortal     => 1,
	sv_magicext    => 0,
	sv_reftype     => 0,
	sv_setref_iv   => 0,
	sv_setref_nv   => 0,
	sv_setref_pv   => 0,
	sv_setref_pvn  => 0,
	sv_setref_uv   => 0,
	vmess          => 0,
);

# Backward compatibility fix
my %force_context = map { $_ => 1 } qw/
	croak_xs_usage
	croak_no_modify
	cv_const_sv
	is_utf8_string
	is_utf8_string_loc
	is_utf8_string_loclen
	mg_find
	mg_magical
	sv_backoff
	utf8_hop
/;

# To simplify usage from Swift
my %force_bool = (
	av_fetch      => [2],
	foldEQ        => ["return"],
	foldEQ_locale => ["return"],
	gv_init       => [4],
	hv_fetch      => [3],
	hv_fetch_ent  => [2],
	sv_eq         => ["return"],
	sv_eq_flags   => ["return"],
	sv_isa        => ["return"],
	sv_isobject   => ["return"],
	sv_ref        => [2],
	sv_reftype    => [1],
	sv_true       => ["return"],
);

my %fix = (
	perl_parse => sub { $_[2][1] =~ s/^/NULLOK / },
	sv_dump    => sub { $_[2][0] =~ s/NULLOK/NN/ },
);

my ($embed, $core, $ext, $api) = setup_embed("$path/");

my $apidocs = apidocs();
my %docs = map %$_, values %$apidocs;

open my $min, '<', 'macro.in' or die $!;
open my $m, '>', 'macro.h' or die $!;
print $m <<EOF;
// !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
// This file is built by update-headers from data in macro.in.
// Any changes made here will be lost!
//
// Edit macro.in and run update-headers to effect changes.

EOF
while (<$min>) {
	chomp;
	if (/^(?:\/\/.*|)$/) {
		print $m "$_\n";
		next;
	}
	my ($flags, $retval, $func, @args) = split /\|/, $_;
	my $no_context = $flags =~ /n/;
	my $plain_call = $flags =~ /P/;
	my $getter = $flags =~ /g/;
	my $setter = $flags =~ /s/;
	my $custom = $flags =~ /C/;
	my $argnames = join ', ', map { /([\w_]+)$/ && $1 } @args;
	if ($setter) {
		$argnames = " = $argnames";
	} elsif (!$getter && !$plain_call) {
		$argnames = "($argnames)";
	}
	my $args = @args ? join ', ', @args : 'void';
	my $swname = $func;
	my $swproto = join "", map "_:", @args;
	unless ($no_context) {
		$swname = "PerlInterpreter.$swname";
		$swname = "getter:$swname" if $getter;
		$swname = "setter:$swname" if $setter;
		$swproto = "self:$swproto";
		$args = @args ? "pTHX_ $args" : "pTHX";
	}
	print $m format_doc($docs{$func});
	my $set = $setter ? "_set" : "";
	my $return = $retval eq 'void' ? "" : "return ";
	my $body;
	if ($custom) {
		while (<$min>) {
			last if /^\}$/;
			$body .= $_;
		}
	} else {
		$body = "\t$return$func$argnames;\n";
	}
	print $m "SWIFT_NAME($swname($swproto))\nPERL_STATIC_INLINE $retval CPerlMacro_$func$set($args) {\n$body}\n";
	print $m "\n";
}
close $m;
close $min;

open my $f, '>', 'func.h' or die "Cannot write to func.h: $!";
print $f <<EOF;
// !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
// This file is built by update-headers from data in embed.fnc.
// Any changes made here will be lost!
//
// Edit update-headers and run it to effect changes.

EOF

foreach (@$api) {
	if (@$_ == 1) {
		print $f "$_->[0]\n";
		next;
	}
	my ($flags, $retval, $func, @args) = @$_;
	$fix{$func}($flags, $retval, \@args) if $fix{$func};
	next if $skip{$func};
	next if $flags =~ /D/;           # Function is deprecated
	unless ($unstable_ok{$func}) {
		next if $flags =~ /M/;       # May change
		next unless $flags =~ /d/;   # Function has documentation (somewhere) in the source
	}
	my $no_context = $flags =~ /n/;  # Has no implicit interpreter/thread context argument
	my $perl_prefix = $flags =~ /p/; # Function in source code has a Perl_ prefix
	my $macro = $flags =~ /m/;       # Implemented as a macro
	my $inline = $flags =~ /i/;      # Static inline: function in source code has a S_ prefix
	my $no_prefix = $flags =~ /o/;   # Has no Perl_foo or S_foo compatibility macro
	next if $no_prefix && $func !~ /perl_/;
	next if grep { $_ eq "..." } @args;
	my $argnames = join ', ', map { /([\w_]+)$/ && $1 } @args;
	foreach (@args) {
		if (s/NULLOK //) {
			s/(\* ?|\S+_t )/$1_Nullable /g;
		} elsif (s/NN //) {
			s/(\* ?|\S+_t )/$1_Nonnull /g;
		}
	}
	my $fix = $wrapall;
	if (defined(my $nullable = $retval_nullable{$func})) {
		my $attr = $nullable ? '_Nullable' : '_Nonnull';
		$retval =~ s/\*/ *$attr/g;
		$fix = 1;
	} elsif ($retval =~ /\*/) {
		next;
	}
	if (my $where = $force_bool{$func}) {
		$fix = 1;
		foreach my $w (@$where) {
			if ($w eq "return") {
				$retval = "bool";
			} else {
				$args[$w] =~ s/^.* /bool /;
			}
		}
	}
	my $args = @args ? join ', ', @args : 'void';
	my $swname = $func;
	$swname =~ s/^perl_// if $no_prefix && !$no_context;
	my $swproto = join "", map "_:", @args;
	if ($no_context && !$force_context{$func}) {
		if ($no_prefix && $swname =~ s/^perl_/PerlInterpreter./) {
			$swproto =~ s/^_:/self:/ if @args && $args[0] =~ /PerlInterpreter/;
		}
	} else {
		$swname = "PerlInterpreter.$swname";
		$swproto = "self:$swproto";
		$args = @args ? "pTHX_ $args" : "pTHX";
		$fix = 1 if $force_context{$func};
	}
	print $f "#ifdef $func\n" unless $no_prefix;
	print $f format_doc($docs{$func});
	if ($macro || $fix) {
		my $return = $retval eq 'void' ? "" : "return ";
		print $f "SWIFT_NAME($swname($swproto))\nPERL_STATIC_INLINE $retval CPerl_$func($args) {\n\t$return$func($argnames);\n}\n";
	} elsif ($inline) {
		print $f "SWIFT_NAME($swname($swproto))\nPERL_STATIC_INLINE $retval S_$func($args);\n";
	} elsif ($perl_prefix || $no_prefix) {
		my $prefix = $perl_prefix ? "Perl_" : "";
		print $f "SWIFT_NAME($swname($swproto))\nPERL_CALLCONV $retval $prefix$func($args);\n";
	} else {
		die "Wanna one of [mpio] flags";
	}
	print $f "#endif\n" unless $no_prefix;

	print $f "\n";
}

close $f;

sub apidocs {
	my $cwd = Cwd::cwd();
	my $autodoc;
	open my $af, '<', "$path/autodoc.pl" or die $!;
	while (<$af>) {
		last if /^my \@missing_api/;
		$autodoc .= $_;
	}
	close $af;
	$autodoc .= "\$docs{api}\n";

	my $docs = eval $autodoc;
	chdir $cwd;
	return $docs;
}

sub format_doc {
	my ($doc) = @_;
	return unless $doc;
	my $text = $doc->[1];
	$text =~ s#([\@\\])#$1$1#g;
	$text =~ s#^\n##;
	$text =~ s#\n$##;
	$text =~ s#((?:^[ \t]+.*?\n)+)#my $x = $1; my ($s) = $x =~ /^([ \t]+)/; $x =~ s/^$s//mg; "\@code\n$x\@endcode\n"#mge;
	$text =~ s#E<lt([^<>]*?)>#<$1#;
	$text =~ s#E<gt([^<>]*?)>#>$1#;
	$text =~ s#C<([^<>]+?)>#my $c = $1; $c =~ s/ / \@c /g; "\@c $c"#sge;
	$text =~ s#B<([^<>]+?)>#my $c = $1; $c =~ s/ / \@b /g; "\@b $c"#sge;
	$text =~ s#I<([^<>]+?)>#my $c = $1; $c =~ s/ / \@i /g; "\@i $c"#sge;
	$text =~ s#L<([^<>]+?)/([^<>]+?)>#$2 in $1#sg;
	$text =~ s#L</([^<>]+?)>#$1#sg;
	$text =~ s#L<([^<>]+?)>#$1#sg;
	$text =~ s#F<([^<>]+?)>#$1#sg;
	$text =~ s#S<([^<>]+?)>#$1#sg;
	$text =~ s#C<(.+?)>#my $c = $1; $c =~ s/ / \@c /g; "\@c $c"#sge;
	$text =~ s#^#/// #mg;
	$text =~ s# +$##mg;
	return $text;
}