###############################################################################
##
##    Typemap for Memcached::libmemcached objects
##
##    Copyright (c) 2007 Tim Bunce
##    All rights reserved.
##
###############################################################################
## vi:et:sw=4 ts=4

TYPEMAP

# --- some basic types not in the perl 5.6 typemap
const char *           T_PV
size_t                 T_UV


# --- simple types ---
memcached_behavior                      T_IV
memcached_return                        T_RETURN

# --- generic simple types ---
# general uint16_t
uint16_t                                T_UV
# XXX need to at least document this as an issue
# Could also check at build time if this perl has 64bit ints and use UV if so
uint64_t                                T_NV

# --- perl api private abstraction typedefs ---
lmc_key                                 T_KEY
lmc_value                               T_VALUE
lmc_expiration                          T_EXPIRATION
lmc_data_flags_t                        T_FLAGS

# --- complex types (incl. objects, typedef name encodes class name) ---
# XXX memory management may be reworked to store structure in scalars
Memcached__libmemcached                 T_PTROBJ_RVIV


INPUT
T_HVREF
    if (!SvROK($arg) || !SvTYPE(SvRV($arg))==SVt_PVHV)
        Perl_croak(aTHX_ \"$var is not a hash reference\");
    $var = (HV*)SvRV($arg);

INPUT
T_RETURN
        /* T_RETURN */
        $var = (SvOK($arg)) ? ($type)SvIV($arg) : 0;

OUTPUT
T_RETURN:init
        /* T_RETURN:init */
        if (LMC_TRACE_LEVEL(ptr)) {
            if (LMC_TRACE_LEVEL(ptr) > 1 || !LMC_RETURN_OK($var))
                warn(\"\t<= %s return %d %s\", \"${func_name}\", $var, memcached_strerror(ptr, $var));
        }
        RECORD_RETURN_ERR(ptr, $var);
T_RETURN
        /* T_RETURN */
        if (!SvREADONLY($arg)) {
            if (LMC_RETURN_OK($var)) {
                sv_setsv($arg, &PL_sv_yes);
            }
            else if ($var == MEMCACHED_NOTFOUND) {
                sv_setsv($arg, &PL_sv_no);
            }
            else {
                SvOK_off($arg);
            }
        }

INPUT
T_PV
        /* treat undef as null pointer (output does the inverse) */
        $var = (SvOK($arg)) ? ($type)SvPV_nolen($arg) : NULL;

INPUT
T_KEY
        /* T_KEY */
        $var = ($type)SvPV($arg, $length_var);

OUTPUT
T_KEY
        /* T_KEY */
        /* assumes the existance of a key_length variable holding the length */
        if (!SvREADONLY($arg))
            sv_setpvn((SV*)$arg, $var, key_length);

INPUT
T_VALUE
        /* T_VALUE - main code in T_VALUE:pre_call below (so it can access/modify flags) */
        /* mention $length_var here to keep ParseXS happy for now */
T_VALUE:pre_call
        /* T_VALUE:pre_call */
        if (SvOK(LMC_STATE(ptr)->cb_context->set_cb)) {
            /* XXX ignoring flags till we have a better mechanism */
            SV *key_sv, *value_sv, *flags_sv;
            /* these SVs may get cached inside lmc_cb_context_st and reused across calls */
            /* which would save the create,mortalize,destroy costs for each invocation  */
            key_sv   = sv_2mortal(newSVpv(key,   STRLEN_length_of_key));
            value_sv = sv_mortalcopy($arg); /* original SV, as it may be a ref */
            flags_sv = sv_2mortal(newSVuv(flags));
            SvREADONLY_on(key_sv); /* just to be sure for now, may allow later */
            _cb_fire_perl_set_cb(ptr, key_sv, value_sv, flags_sv);
            /* recover possibly modified values (except key) */
            $var = SvPV(value_sv, $length_var);
            flags = SvUV(flags_sv);
        }
        else {
            $var = ($type)SvPV($arg, $length_var);
        }
        

OUTPUT
T_VALUE
        /* T_VALUE */
        /* assumes the existance of a value_length variable holding the length */
        if (!SvREADONLY($arg))
            sv_setpvn((SV*)$arg, $var, value_length);

INPUT
T_FLAGS
        /* T_FLAGS */
        $var = (SvOK($arg)) ? ($type)SvUV($arg) : 0;

OUTPUT
T_FLAGS
        /* T_FLAGS */
        if (!SvREADONLY($arg))
            sv_setuv($arg, (UV)$var);

INPUT
T_EXPIRATION
        /* T_EXPIRATION */
        /* XXX add logic for default expiration */
        $var = ($type)SvUV($arg)


INPUT
T_PTROBJ_RVIV
        /* T_PTROBJ_RVIV */
        if (!SvOK($arg)) {  /* undef         */
            $var = NULL;    /* treat as null */
        }
        else if (sv_derived_from($arg, \"${(my $ntt=$ntype)=~s/__/::/g;\$ntt}\")) {
            if (SvROK($arg) && SvOK(SvRV($arg))) {
                IV tmp = SvIV((SV*)SvRV($arg));
                $var = INT2PTR($type, tmp);
            }
            else { /* already freed */
                $var = NULL;
            }
        }
        else
            croak(\"$var is not of type ${(my $ntt=$ntype)=~s/__/::/g;\$ntt}\");
        if (LMC_TRACE_LEVEL($var) >= 2)
            warn(\"\t=> %s(%s %s = 0x%p)\", \"${func_name}\", \"${ntype}\", \"${var}\", (void*)$var);

OUTPUT
T_PTROBJ_RVIV
        /* T_PTROBJ_RVIV */
        if (!$var)          /* if null */
            SvOK_off($arg); /* then return as undef instead of reaf to undef */
        else {
            lmc_state_st *lmc_state = lmc_state_new($arg);
            sv_setref_pv($arg, \"${(my $ntt=$ntype)=~s/__/::/g;\$ntt}\", $var);
            memcached_callback_set($var, MEMCACHED_CALLBACK_USER_DATA,        lmc_state);
            memcached_callback_set($var, MEMCACHED_CALLBACK_CLEANUP_FUNCTION, lmc_state_cleanup);
        }
        if (LMC_TRACE_LEVEL($var) >= 2)
            warn(\"\t<= %s(%s %s = %p)\", \"${func_name}\", \"${ntype}\", \"${var}\", (void*)$var);
