#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "ppport.h"
#include "hook_op_check.h"
#include "hook_op_ppaddr.h"
#define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
#define PERL_DECIMAL_VERSION \
    PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
#define PERL_VERSION_GE(r,v,s) \
    (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
STATIC SV * dispatch = NULL;
STATIC OP *
execute_call_back (pTHX_ OP *op, void *user_data) {
    /* Called at execution time to override the system op.  It just
     * calls _dispatch() and returns its result */
    dSP;
    SV* result;
    int ret;
    ENTER;
    SAVETMPS;
    /* The top of the stack should be the scalar whose case is to be changed.
       Instead of popping and then pushing it, just claim the MARK is before 
       it */
    PUSHMARK(SP - 1);
    /* Add the name of the function this is replacing, 'uc', lcfirst', etc. */
    XPUSHs(sv_2mortal(newSVpv(PL_op_name[op->op_type], 0)));
    PUTBACK;
    if (dispatch == NULL) {
        dispatch = (SV *) get_cv("Unicode::Casing::_dispatch", 0);
    }
    if ((ret = call_sv(dispatch, GIMME_V)) != 1) {
        Perl_croak(aTHX_ "panic: Unicode::Casing::_dispatch returned %d values instead of 1\n", ret);
    }
    SPAGAIN;
    result = POPs;
    SvREFCNT_inc(result);
    FREETMPS;
    LEAVE;
    /* S_fold_constant expects us to return either a
     * temp (from the pad or otherwise) or an immortal,
     * and fails an assertion if we don't. So mark this
     * as a temp.
     */
    SvTEMP_on(result);
    XPUSHs(result);
    RETURN;
}
STATIC
OP *
check_call_back(pTHX_ OP *op, void *user_data) {
    /* Whenever 'op' is encountered in the parse, this function is
     * called.  It adds a hook to call our substitute function at
     * execution time */
    hook_op_ppaddr (op, execute_call_back, user_data);
    return op;
}
STATIC
opcode
opcode_from_name(pTHX_ const char* const name) {
    /* Strict input checking is not done, as this is tightly coupled
        * with Perl code that should do that for us */
    if (*name == 'u') {
        if (strlen(name) > 2) {
            return OP_UCFIRST;
        } else {
            return OP_UC;
        }
    }
#if PERL_VERSION_GE(5,15,8)
    else if (*name == 'f') {
        return OP_FC;
    }
#endif
    else if (strlen(name) > 2) {
        return OP_LCFIRST;
    }
    return OP_LC;
}
MODULE = Unicode::Casing                PACKAGE = Unicode::Casing               
UV
setup(type)
        char * type;
    PROTOTYPE: $
    CODE:
    /* setup() is called to set up function 'type': one of 'uc', 'ucfirst',
     * 'lc', 'lcfirst', or 'fc to be overridden by a user-defined equivalent. */
    /* Set check_call_back() to be called whenever 'op' is
        * encountered in the parse */
    RETVAL = (UV) hook_op_check(opcode_from_name(aTHX_ type),
                                check_call_back,
                                NULL);
    OUTPUT:
        RETVAL
void
teardown(type, id)
        char *type
        UV id;
    CODE:
        hook_op_check_remove(opcode_from_name(aTHX_ type), id);