#!/usr/bin/perl -w

use strict;

my %func;
my $prop;

open(H, ">try_perlapi.h") || die;
open(C, ">try_perlapi.c") || die;

my $note = "/* DO NOT EDIT!!!\n * Autogenerated by $0\n */\n\n";
print H $note;
print C $note;

my $ENABLE_JMPENV = $^O ne "MSWin32";

print C <<EOT;

#include <EXTERN.h>
#include <perl.h>
#include <Python.h>

#include "try_perlapi.h"
#include "perlmodule.h"
#include "lang_lock.h"
#include "thrd_ctx.h"
EOT

print C <<EOT if $ENABLE_JMPENV;

static LOGOP dummy_op;

void fake_inittry()
{
    Zero(&dummy_op, 1, LOGOP);
    dummy_op.op_flags |= OPf_WANT_SCALAR;
    dummy_op.op_next = Nullop;
}

static void
fake_entertry()
{
    PERL_CONTEXT *cx;
    I32 gimme;
    dCTXP;

    PL_op = (OP*)&dummy_op;
    gimme = GIMME_V;

    ENTER;
    SAVETMPS;

    push_return(Nullop);
    PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
    PUSHEVAL(cx, 0, 0);
    PL_eval_root = PL_op;
    PL_in_eval = EVAL_INEVAL;
    sv_setpvn(ERRSV, "", 0);
}

static void
fake_leavetry(I32 oldscope)
{
    dCTXP;
    if (PL_scopestack_ix > oldscope) {
        PERL_CONTEXT *cx;
        PMOP *newpm;
        I32 optype;
        SV **newsp;
        I32 gimme;

        POPBLOCK(cx,newpm);
        POPEVAL(cx);
        pop_return();
        PL_curpm = newpm;
    }

    FREETMPS;
    LEAVE;
}

EOT

while (<DATA>) {
    if (/^(\w.*?)(\w+)\(([^)]*)\)\s*$/) {
	gen_func() if %func;
	%func = ();
	undef($prop);
	@func{qw/type name args/} = ($1, $2, $3);

	# some trimming
	for (@func{qw/type args/}) {
	    s/^\s+//;
	    s/\s+$//;
	}
    }
    elsif (s/\s+(\w+)\s*:\s*//) {
	$prop = lc($1);
	$func{$prop} = $_;
	if ($prop eq "code" && !/^\s*$/) {
	    chomp($func{code});
	    $func{code} = "RETVAL = $func{code};";
	}
    }
    elsif ($prop) {
	$func{$prop} .= $_;
    }
    elsif (%func) {
	warn;
    }
    else {
	print;
    }
}
gen_func() if %func;
exit;
#-----------

sub gen_func
{
    print H "$func{type}\ttry_$func{name}($func{args});\n";

    my $fail = $func{fail};
    $fail = -1 unless defined $fail;
    $fail =~ s/\s+$//;

    my $code = $func{code} || die;
    $code =~ s/\s+$//s;

    # fix code indentation
    my $indent = 9999;
    my @code = split(/^/, $code);
    for (@code) {
	1 while s/\t/' ' x (8 - length($`) % 8)/e;  # expand tabs

	/^(\s*)/ || die;
	my $i = length($1);
	$indent = $i if $i < $indent;
    }

    if ($indent < 8) {
	for (@code) {
	    $_ = (" " x (8 - $indent)) . $_;
	}
    }
    $code = join("", @code);

    if ($ENABLE_JMPENV) {
	print C <<EOT;
$func{type}
try_$func{name}($func{args})
{
    dJMPENV;
    dCTXP;
    int jmp_status;
    volatile I32 oldscope = PL_scopestack_ix;
    $func{type} RETVAL;

    ASSERT_LOCK_PERL;
    fake_entertry();

    JMPENV_PUSH(jmp_status);
    if (jmp_status == 0) {

$code

    }
    else if (jmp_status == 3) {
        /* caught an exception, \$@ should be set */
        assert(SvTRUE(ERRSV));
        PYTHON_LOCK;
        propagate_errsv();
        PYTHON_UNLOCK;

        RETVAL = $fail;
    }
    else {
        fprintf(stderr, "should not happen, jmp_status = %d\\n", jmp_status);
    }
    JMPENV_POP;
    fake_leavetry(oldscope);
    return RETVAL;
}

EOT

    }
    else {
	print C <<EOT;
$func{type}
try_$func{name}($func{args})
{
    dCTXP;
    $func{type} RETVAL;
$code
    return RETVAL;
}

EOT
    }
}

########################################################################

__DATA__

int array_len(AV* av)
   FAIL: -1
   CODE: av_len(av)+1

SV** av_fetch(AV* av, I32 key, I32 lval)
   FAIL: NULL
   CODE: av_fetch(av, key, lval)

int SvGETMAGIC(SV* sv)
   FAIL: -1
   CODE:
     SvGETMAGIC(sv);
     RETVAL = 0;

int SvSETMAGIC(SV* sv)
   FAIL: -1
   CODE:
     SvSETMAGIC(sv);
     RETVAL = 0;