#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "ppport.h"
#include "ptable.h"

/* this gets weird segfaults on 5.8, and I have no idea why */
#if PERL_REVISION == 5 && (PERL_VERSION >= 10)
#define DH_ALLOW_SUB_PARAMETERS
#endif

#ifndef CopFILEGV_set
#define CopFILEGV_set(c, gv) ;; /* noop */
#endif
#ifndef CopARYBASE_get
#define CopARYBASE_get(c) c->cop_arybase
#endif
#ifndef CopARYBASE_set
#define CopARYBASE_set(c,v) c->cop_arybase = v
#endif

#if PERL_REVISION == 5 && (PERL_VERSION >= 10)
#define DH_PMOP_STASHSTARTU(o) o->op_pmstashstartu.op_pmreplstart
#else
#define DH_PMOP_STASHSTARTU(o) o->op_pmreplstart
#endif

#ifdef DH_ALLOW_SUB_PARAMETERS
#define SET(m,s)                                        \
    do {                                                \
        if (set) {                                      \
            if (apply_to_all) {                         \
                m ## _value = value;                    \
                walk_optree((OP*)cop, cop_ ## m ## _r); \
            }                                           \
            else {                                      \
                s;                                      \
            }                                           \
        }                                               \
    } while (0)
#else
#define SET(m,s) if (set) s
#endif

#define CALL_IMPL(m)                                      \
    if (GIMME_V == G_VOID && items < 2)                   \
        XSRETURN(0);                                      \
    RETVAL = cop_ ## m(mycop(code), value, items >= 2, code && SvROK(code))

#ifdef DH_ALLOW_SUB_PARAMETERS

#define WALK_OPTREE_CB(m,t)                    \
    static t m ## _value;                      \
    static void cop_ ## m ## _r(OP *op)        \
    {                                          \
        if (op->op_type == OP_NEXTSTATE) {     \
            COP *cop = (COP*)op;               \
            cop_ ## m(cop, m ## _value, 1, 0); \
        }                                      \
    }

typedef void (*walk_optree_cb_t)(OP*);

char *cop_stashpv(COP *cop, char *value, int set, int apply_to_all);
HV *cop_stash(COP *cop, HV *value, int set, int apply_to_all);
char *cop_file(COP *cop, char *value, int set, int apply_to_all);
GV *cop_filegv(COP *cop, GV *value, int set, int apply_to_all);
UV cop_seq(COP *cop, UV value, int set, int apply_to_all);
I32 cop_arybase(COP *cop, I32 value, int set, int apply_to_all);
U16 cop_line(COP *cop, U16 value, int set, int apply_to_all);
SV *cop_warnings(COP *cop, SV *value, int set, int apply_to_all);
SV *cop_io(COP *cop, SV *value, int set, int apply_to_all);

WALK_OPTREE_CB(stashpv, char*)
WALK_OPTREE_CB(stash, HV*)
WALK_OPTREE_CB(filegv, GV*)
/* XXX: should cop_seq be incremented, like cop_line is? */
WALK_OPTREE_CB(seq, UV)
WALK_OPTREE_CB(arybase, I32)
WALK_OPTREE_CB(warnings, SV*)
WALK_OPTREE_CB(io, SV*)

/* needs some custom behavior */
static U16 line_value;
static U16 line_base_value;
static char *line_base_file;
static void cop_line_r(OP *op)
{
    if (op->op_type == OP_NEXTSTATE &&
        !strcmp(line_base_file, cop_file((COP*)op, NULL, 0, 0))) {
        COP *cop = (COP*)op;
        cop_line(cop, line_value - line_base_value + cop_line(cop, 0, 0, 0),
                 1, 0);
    }
}

static char *file_value;
static char *file_base;
static void cop_file_r(OP *op)
{
    if (op->op_type == OP_NEXTSTATE &&
        !strcmp(file_base, cop_file((COP*)op, NULL, 0, 0))) {
        COP *cop = (COP*)op;
        cop_file(cop, file_value, 1, 0);
    }
}

static void _walk_optree(OP *o, walk_optree_cb_t cb, ptable *visited)
{
    for (; o; o = o->op_next) {
        if (ptable_fetch(visited, o))
            return;

        ptable_store(visited, o, o);

        cb(o);

        switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
        case OA_LOGOP:
            _walk_optree(cLOGOPo->op_other, cb, visited);
            break;
        case OA_LOOP:
            _walk_optree(cLOOPo->op_redoop, cb, visited);
            _walk_optree(cLOOPo->op_nextop, cb, visited);
            _walk_optree(cLOOPo->op_lastop, cb, visited);
            break;
        case OA_PMOP:
            if (o->op_type == OP_SUBST)
                _walk_optree(DH_PMOP_STASHSTARTU(cPMOPo), cb, visited);
            break;
        }
    }
}

void walk_optree(OP *o, walk_optree_cb_t cb)
{
    ptable *visited = ptable_new();
    _walk_optree(o, cb, visited);
    ptable_free(visited);
}

#endif

COP* mycop(SV* code)
{
#ifdef DH_ALLOW_SUB_PARAMETERS
    if (code && SvROK(code)) {
        if (SvTYPE(SvRV(code)) == SVt_PVCV) {
            code = SvRV(code);
            return (COP*)CvSTART(code);
        }
        else {
            croak("unknown reference type");
        }
    }
    else {
#endif
        int count;

        count = code && SvIOK(code) ? SvIV(code) : 0;
        if (count <= 0) {
            return PL_curcop;
        }
        else {
            return cxstack[cxstack_ix - count + 1].blk_oldcop;
        }
#ifdef DH_ALLOW_SUB_PARAMETERS
    }
#endif
}

char *cop_label(COP *cop, char *value, int set, int apply_to_all)
{
#ifdef CopLABEL
    return (char *) CopLABEL(cop);
#else
    if (set)
        cop->cop_label = strdup(value);

    return cop->cop_label ? cop->cop_label : Nullch;
#endif
}

char *cop_stashpv(COP *cop, char *value, int set, int apply_to_all)
{
    SET(stashpv, CopSTASHPV_set(cop, value));

    return CopSTASHPV(cop);
}

HV *cop_stash(COP *cop, HV *value, int set, int apply_to_all)
{
    SET(stash, CopSTASH_set(cop, value));

    return CopSTASH(cop);
}

char *cop_file(COP *cop, char *value, int set, int apply_to_all)
{
    if (set) {
#ifdef DH_ALLOW_SUB_PARAMETERS
        if (apply_to_all) {
            file_value = value;
            file_base = cop_file(cop, NULL, 0, 0);
            walk_optree((OP*)cop, cop_file_r);
        }
        else
#endif
            CopFILE_set(cop, value);
    }

    return CopFILE(cop);
}

GV *cop_filegv(COP *cop, GV *value, int set, int apply_to_all)
{
    SET(filegv, CopFILEGV_set(cop, value));

    return CopFILEGV(cop);
}

UV cop_seq(COP *cop, UV value, int set, int apply_to_all)
{
    SET(seq, cop->cop_seq = value);

    return cop->cop_seq;
}

I32 cop_arybase(COP *cop, I32 value, int set, int apply_to_all)
{
    SET(arybase, CopARYBASE_set(cop, value));

    return CopARYBASE_get(cop);
}

U16 cop_line(COP *cop, U16 value, int set, int apply_to_all)
{
    if (set) {
#ifdef DH_ALLOW_SUB_PARAMETERS
        if (apply_to_all) {
            line_value = value;
            line_base_value = cop_line(cop, 0, 0, 0);
            line_base_file = cop_file(cop, NULL, 0, 0);
            walk_optree((OP*)cop, cop_line_r);
        }
        else
#endif
            cop->cop_line = value;
    }

    return cop->cop_line;
}

SV *cop_warnings(COP *cop, SV *value, int set, int apply_to_all)
{
#if PERL_REVISION == 5 && (PERL_VERSION >= 10)
    return &PL_sv_undef;
#else
    SET(warnings, cop->cop_warnings = newSVsv(value));

    if ( PTR2UV(cop->cop_warnings) > 255 ) {
        /* pointer to the lexical SV */
        return SvREFCNT_inc(cop->cop_warnings);
    }
    else {
        /* UV of global warnings flags */
        return newSVuv( PTR2UV(cop->cop_warnings) );
    }
#endif
}

SV *cop_io(COP *cop, SV *value, int set, int apply_to_all)
{
#if PERL_REVISION == 5 && (PERL_VERSION >= 7 && PERL_VERSION < 10)
    SET(io, cop->cop_io = newSVsv(value));

    return cop->cop_io ? SvREFCNT_inc(cop->cop_io) : newSVpvn("", 0);
#else
    return &PL_sv_undef;
#endif
}

MODULE = Devel::Hints	PACKAGE = Devel::Hints

char *
cop_label(code=NULL, value=NULL)
	SV*		code
	char*		value
    CODE:
        if (items >= 2 && SvROK(code))
            croak("Can't set the label of a coderef");
        CALL_IMPL(label);
    OUTPUT:
	RETVAL

char *
cop_stashpv(code=NULL, value=NULL)
	SV*		code
	char*		value
    CODE:
        CALL_IMPL(stashpv);
    OUTPUT:
	RETVAL

HV *
cop_stash(code=NULL, value=NULL)
	SV*		code
	HV*		value
    CODE:
        CALL_IMPL(stash);
    OUTPUT:
	RETVAL

char *
cop_file(code=NULL, value=NULL)
	SV*		code
	char*		value
    CODE:
        CALL_IMPL(file);
    OUTPUT:
	RETVAL

GV *
cop_filegv(code=NULL, value=NULL)
	SV*		code
	GV*		value
    CODE:
        CALL_IMPL(filegv);
    OUTPUT:
	RETVAL

UV
cop_seq(code=NULL, value=0)
	SV*		code
	UV		value
    CODE:
        CALL_IMPL(seq);
    OUTPUT:
	RETVAL

I32
cop_arybase(code=NULL, value=0)
	SV*		code
	I32		value
    CODE:
        CALL_IMPL(arybase);
    OUTPUT:
	RETVAL

U16
cop_line(code=NULL, value=0)
	SV*		code
	U16		value
    CODE:
        CALL_IMPL(line);
    OUTPUT:
	RETVAL

SV *
cop_warnings(code=NULL, value=NULL)
	SV*		code
	SV*		value
    CODE:
        CALL_IMPL(warnings);
    OUTPUT:
	RETVAL

SV *
cop_io(code=NULL, value=NULL)
	SV*		code
	SV*		value
    CODE:
        CALL_IMPL(io);
    OUTPUT:
	RETVAL