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