1###############################################################################
2##
3##    Typemap for Memcached::libmemcached objects
4##
5##    Copyright (c) 2007 Tim Bunce
6##    All rights reserved.
7##
8###############################################################################
9## vi:et:sw=4 ts=4
10
11TYPEMAP
12
13# --- some basic types not in the perl 5.6 typemap
14const char *           T_PV
15size_t                 T_UV
16
17
18# --- simple types ---
19memcached_behavior                      T_IV
20memcached_callback                      T_IV
21memcached_return                        T_RETURN
22
23# --- generic simple types ---
24# general uint16_t
25uint16_t                                T_UV
26# XXX need to at least document this as an issue
27# Could also check at build time if this perl has 64bit ints and use UV if so
28uint64_t                                T_NV
29
30# --- perl api private abstraction typedefs ---
31lmc_key                                 T_KEY
32lmc_value                               T_VALUE
33lmc_expiration                          T_EXPIRATION
34lmc_data_flags_t                        T_FLAGS
35
36# --- complex types (incl. objects, typedef name encodes class name) ---
37# XXX memory management may be reworked to store structure in scalars
38Memcached__libmemcached                 T_MEMCACHED
39
40
41INPUT
42T_HVREF
43    if (!SvROK($arg) || !SvTYPE(SvRV($arg))==SVt_PVHV)
44        Perl_croak(aTHX_ \"$var is not a hash reference\");
45    $var = (HV*)SvRV($arg);
46
47INPUT
48T_RETURN
49        /* T_RETURN */
50        $var = (SvOK($arg)) ? ($type)SvIV($arg) : 0;
51
52OUTPUT
53T_RETURN:init
54        /* T_RETURN:init */
55        LMC_RECORD_RETURN_ERR(\"${func_name}\", ptr, $var);
56T_RETURN
57        /* T_RETURN */
58        if (!SvREADONLY($arg)) {
59            if (LMC_RETURN_OK($var)) {
60                sv_setsv($arg, &PL_sv_yes);
61            }
62            else if ($var == MEMCACHED_NOTFOUND) {
63                sv_setsv($arg, &PL_sv_no);
64            }
65            else {
66                SvOK_off($arg);
67            }
68        }
69
70INPUT
71T_PV
72        /* treat undef as null pointer (output does the inverse) */
73        $var = (SvOK($arg)) ? ($type)SvPV_nolen($arg) : NULL;
74
75INPUT
76T_KEY
77        /* T_KEY */
78        $var = ($type)SvPV($arg, $length_var);
79
80OUTPUT
81T_KEY
82        /* T_KEY */
83        /* assumes the existance of a key_length variable holding the length */
84        if (!SvREADONLY($arg))
85            sv_setpvn((SV*)$arg, $var, key_length);
86
87INPUT
88T_VALUE
89        /* T_VALUE - main code in T_VALUE:pre_call below (so it can access/modify flags) */
90        /* mention $length_var here to keep ParseXS happy for now */
91T_VALUE:pre_call
92        /* T_VALUE:pre_call */
93        if (SvOK(LMC_STATE_FROM_PTR(ptr)->cb_context->set_cb)) {
94            /* XXX ignoring flags till we have a better mechanism */
95            SV *key_sv, *value_sv, *flags_sv;
96            /* these SVs may get cached inside lmc_cb_context_st and reused across calls */
97            /* which would save the create,mortalize,destroy costs for each invocation  */
98            key_sv   = sv_2mortal(newSVpv(key,   STRLEN_length_of_key));
99            value_sv = sv_mortalcopy($arg); /* original SV, as it may be a ref */
100            flags_sv = sv_2mortal(newSVuv(flags));
101            SvREADONLY_on(key_sv); /* just to be sure for now, may allow later */
102            _cb_fire_perl_set_cb(ptr, key_sv, value_sv, flags_sv);
103            /* recover possibly modified values (except key) */
104            $var = SvPV(value_sv, $length_var);
105            flags = SvUV(flags_sv);
106        }
107        else {
108            $var = ($type)SvPV($arg, $length_var);
109        }
110
111OUTPUT
112T_VALUE
113        /* T_VALUE */
114        /* assumes the existance of a value_length variable holding the length */
115        if (!SvREADONLY($arg))
116            sv_setpvn((SV*)$arg, $var, value_length);
117
118INPUT
119T_FLAGS
120        /* T_FLAGS */
121        $var = (SvOK($arg)) ? ($type)SvUV($arg) : 0;
122
123OUTPUT
124T_FLAGS
125        /* T_FLAGS */
126        if (!SvREADONLY($arg))
127            sv_setuv($arg, (UV)$var);
128
129INPUT
130T_EXPIRATION
131        /* T_EXPIRATION */
132        $var = (SvOK($arg)) ? ($type)SvUV($arg) : 0;
133
134OUTPUT
135T_MEMCACHED
136        /* T_MEMCACHED */
137        if (!$var)          /* if null */
138            SvOK_off($arg); /* then return as undef instead of reaf to undef */
139        else {
140            /* setup $arg as a ref to a blessed hash hv */
141            lmc_state_st *lmc_state;
142            HV *hv = newHV();
143            const char *classname = \"${(my $ntt=$ntype)=~s/__/::/g;\$ntt}\";
144            /* take (sub)class name to use from class_sv if appropriate */
145            if (class_sv && SvOK(class_sv) && sv_derived_from(class_sv, classname))
146                classname = (SvROK(class_sv)) ? sv_reftype(class_sv, 0) : SvPV_nolen(class_sv);
147            sv_setsv($arg, sv_2mortal(newRV_noinc((SV*)hv)));
148            (void)sv_bless($arg, gv_stashpv(classname, TRUE));
149
150            /* allocate an lmc_state struct and attach via MEMCACHED_CALLBACK_USER_DATA */
151            lmc_state = lmc_state_new($var, hv);
152            memcached_callback_set($var, MEMCACHED_CALLBACK_USER_DATA, lmc_state);
153
154            /* now attach $var to the HV */
155            /* done as two steps to avoid sv_magic SvREFCNT_inc and MGf_REFCOUNTED */
156            sv_magic((SV*)hv, NULL, '~', NULL, 0);
157            LMC_STATE_FROM_SV($arg) = (void*)lmc_state;
158        }
159        if (LMC_TRACE_LEVEL_FROM_PTR($var) >= 2)
160            warn(\"\t<= %s(%s %s = %p)\", \"${func_name}\", \"${ntype}\", \"${var}\", (void*)$var);
161
162INPUT
163T_MEMCACHED
164        /* T_MEMCACHED */
165        if (!SvOK($arg)) {  /* undef         */
166            $var = NULL;    /* treat as null */
167        }
168        else if (sv_derived_from($arg, \"${(my $ntt=$ntype)=~s/__/::/g;\$ntt}\")) {
169            if (SvROK($arg)) {
170                $var = (memcached_st*)LMC_PTR_FROM_SV($arg);
171            }
172            else { /* memcached_st ptr already freed or is a class name */
173                $var = NULL;
174            }
175        }
176        else
177            croak(\"$var is not of type ${(my $ntt=$ntype)=~s/__/::/g;\$ntt}\");
178        if (LMC_TRACE_LEVEL_FROM_PTR($var) >= 2)
179            warn(\"\t=> %s(%s %s = 0x%p)\", \"${func_name}\", \"${ntype}\", \"${var}\", (void*)$var);
180
181