1#include <assert.h> 2 3#include "EXTERN.h" 4#include "perl.h" 5#include "XSUB.h" 6 7static char *rcs_id = "$Id: Clone.xs,v 0.31 2009/01/20 04:54:37 ray Exp $"; 8 9#define CLONE_KEY(x) ((char *) &x) 10 11#define CLONE_STORE(x,y) \ 12do { \ 13 if (!hv_store(hseen, CLONE_KEY(x), PTRSIZE, SvREFCNT_inc(y), 0)) { \ 14 SvREFCNT_dec(y); /* Restore the refcount */ \ 15 croak("Can't store clone in seen hash (hseen)"); \ 16 } \ 17 else { \ 18 TRACEME(("storing ref = 0x%x clone = 0x%x\n", ref, clone)); \ 19 TRACEME(("clone = 0x%x(%d)\n", clone, SvREFCNT(clone))); \ 20 TRACEME(("ref = 0x%x(%d)\n", ref, SvREFCNT(ref))); \ 21 } \ 22} while (0) 23 24#define CLONE_FETCH(x) (hv_fetch(hseen, CLONE_KEY(x), PTRSIZE, 0)) 25 26static SV *hv_clone (SV *, SV *, HV *, int); 27static SV *av_clone (SV *, SV *, HV *, int); 28static SV *sv_clone (SV *, HV *, int); 29static SV *rv_clone (SV *, HV *, int); 30 31#ifdef DEBUG_CLONE 32#define TRACEME(a) printf("%s:%d: ",__FUNCTION__, __LINE__) && printf a; 33#else 34#define TRACEME(a) 35#endif 36 37static SV * 38hv_clone (SV * ref, SV * target, HV* hseen, int depth) 39{ 40 HV *clone = (HV *) target; 41 HV *self = (HV *) ref; 42 HE *next = NULL; 43 int recur = depth ? depth - 1 : 0; 44 45 assert(SvTYPE(ref) == SVt_PVHV); 46 47 TRACEME(("ref = 0x%x(%d)\n", ref, SvREFCNT(ref))); 48 49 hv_iterinit (self); 50 while (next = hv_iternext (self)) 51 { 52 SV *key = hv_iterkeysv (next); 53 TRACEME(("clone item %s\n", SvPV_nolen(key) )); 54 hv_store_ent (clone, key, 55 sv_clone (hv_iterval (self, next), hseen, recur), 0); 56 } 57 58 TRACEME(("clone = 0x%x(%d)\n", clone, SvREFCNT(clone))); 59 return (SV *) clone; 60} 61 62static SV * 63av_clone (SV * ref, SV * target, HV* hseen, int depth) 64{ 65 AV *clone = (AV *) target; 66 AV *self = (AV *) ref; 67 SV **svp; 68 SV *val = NULL; 69 I32 arrlen = 0; 70 int i = 0; 71 int recur = depth ? depth - 1 : 0; 72 73 assert(SvTYPE(ref) == SVt_PVAV); 74 75 TRACEME(("ref = 0x%x(%d)\n", ref, SvREFCNT(ref))); 76 77 /* The following is a holdover from a very old version */ 78 /* possible cause of memory leaks */ 79 /* if ( (SvREFCNT(ref) > 1) ) */ 80 /* CLONE_STORE(ref, (SV *)clone); */ 81 82 arrlen = av_len (self); 83 av_extend (clone, arrlen); 84 85 for (i = 0; i <= arrlen; i++) 86 { 87 svp = av_fetch (self, i, 0); 88 if (svp) 89 av_store (clone, i, sv_clone (*svp, hseen, recur)); 90 } 91 92 TRACEME(("clone = 0x%x(%d)\n", clone, SvREFCNT(clone))); 93 return (SV *) clone; 94} 95 96static SV * 97rv_clone (SV * ref, HV* hseen, int depth) 98{ 99 SV *clone = NULL; 100 SV *rv = NULL; 101 102 assert(SvROK(ref)); 103 104 TRACEME(("ref = 0x%x(%d)\n", ref, SvREFCNT(ref))); 105 106 if (!SvROK (ref)) 107 return NULL; 108 109 if (sv_isobject (ref)) 110 { 111 clone = newRV_noinc(sv_clone (SvRV(ref), hseen, depth)); 112 sv_2mortal (sv_bless (clone, SvSTASH (SvRV (ref)))); 113 } 114 else 115 clone = newRV_inc(sv_clone (SvRV(ref), hseen, depth)); 116 117 TRACEME(("clone = 0x%x(%d)\n", clone, SvREFCNT(clone))); 118 return clone; 119} 120 121static SV * 122sv_clone (SV * ref, HV* hseen, int depth) 123{ 124 SV *clone = ref; 125 SV **seen = NULL; 126#if PERL_REVISION >= 5 && PERL_VERSION > 8 127 /* This is a hack for perl 5.9.*, save everything */ 128 /* until I find out why mg_find is no longer working */ 129 UV visible = 1; 130#else 131 UV visible = (SvREFCNT(ref) > 1) || (SvMAGICAL(ref) && mg_find(ref, '<')); 132#endif 133 int magic_ref = 0; 134 135 TRACEME(("ref = 0x%x(%d)\n", ref, SvREFCNT(ref))); 136 137 if (depth == 0) 138 return SvREFCNT_inc(ref); 139 140 if (visible && (seen = CLONE_FETCH(ref))) 141 { 142 TRACEME(("fetch ref (0x%x)\n", ref)); 143 return SvREFCNT_inc(*seen); 144 } 145 146 TRACEME(("switch: (0x%x)\n", ref)); 147 switch (SvTYPE (ref)) 148 { 149 case SVt_NULL: /* 0 */ 150 TRACEME(("sv_null\n")); 151 clone = newSVsv (ref); 152 break; 153 case SVt_IV: /* 1 */ 154 TRACEME(("int scalar\n")); 155 case SVt_NV: /* 2 */ 156 TRACEME(("double scalar\n")); 157 clone = newSVsv (ref); 158 break; 159#if PERL_VERSION <= 10 160 case SVt_RV: /* 3 */ 161 TRACEME(("ref scalar\n")); 162 clone = newSVsv (ref); 163 break; 164#endif 165 case SVt_PV: /* 4 */ 166 TRACEME(("string scalar\n")); 167 clone = newSVsv (ref); 168 break; 169 case SVt_PVIV: /* 5 */ 170 TRACEME (("PVIV double-type\n")); 171 case SVt_PVNV: /* 6 */ 172 TRACEME (("PVNV double-type\n")); 173 clone = newSVsv (ref); 174 break; 175 case SVt_PVMG: /* 7 */ 176 TRACEME(("magic scalar\n")); 177 clone = newSVsv (ref); 178 break; 179 case SVt_PVAV: /* 10 */ 180 clone = (SV *) newAV(); 181 break; 182 case SVt_PVHV: /* 11 */ 183 clone = (SV *) newHV(); 184 break; 185 #if PERL_VERSION <= 8 186 case SVt_PVBM: /* 8 */ 187 #elif PERL_VERSION >= 11 188 case SVt_REGEXP: /* 8 */ 189 #endif 190 case SVt_PVLV: /* 9 */ 191 case SVt_PVCV: /* 12 */ 192 case SVt_PVGV: /* 13 */ 193 case SVt_PVFM: /* 14 */ 194 case SVt_PVIO: /* 15 */ 195 TRACEME(("default: type = 0x%x\n", SvTYPE (ref))); 196 clone = SvREFCNT_inc(ref); /* just return the ref */ 197 break; 198 default: 199 croak("unkown type: 0x%x", SvTYPE(ref)); 200 } 201 202 /** 203 * It is *vital* that this is performed *before* recursion, 204 * to properly handle circular references. cb 2001-02-06 205 */ 206 207 if ( visible ) 208 CLONE_STORE(ref,clone); 209 210 /* 211 * We'll assume (in the absence of evidence to the contrary) that A) a 212 * tied hash/array doesn't store its elements in the usual way (i.e. 213 * the mg->mg_object(s) take full responsibility for them) and B) that 214 * references aren't tied. 215 * 216 * If theses assumptions hold, the three options below are mutually 217 * exclusive. 218 * 219 * More precisely: 1 & 2 are probably mutually exclusive; 2 & 3 are 220 * definitely mutually exclusive; we have to test 1 before giving 2 221 * a chance; and we'll assume that 1 & 3 are mutually exclusive unless 222 * and until we can be test-cased out of our delusion. 223 * 224 * chocolateboy: 2001-05-29 225 */ 226 227 /* 1: TIED */ 228 if (SvMAGICAL(ref) ) 229 { 230 MAGIC* mg; 231 MGVTBL *vtable = 0; 232 233 for (mg = SvMAGIC(ref); mg; mg = mg->mg_moremagic) 234 { 235 SV *obj = (SV *) NULL; 236 /* we don't want to clone a qr (regexp) object */ 237 /* there are probably other types as well ... */ 238 TRACEME(("magic type: %c\n", mg->mg_type)); 239 /* Some mg_obj's can be null, don't bother cloning */ 240 if ( mg->mg_obj != NULL ) 241 { 242 switch (mg->mg_type) 243 { 244 case 'r': /* PERL_MAGIC_qr */ 245 obj = mg->mg_obj; 246 break; 247 case 't': /* PERL_MAGIC_taint */ 248 continue; 249 break; 250 case '<': /* PERL_MAGIC_backref */ 251 continue; 252 break; 253 case '@': /* PERL_MAGIC_arylen_p */ 254 continue; 255 break; 256 default: 257 obj = sv_clone(mg->mg_obj, hseen, -1); 258 } 259 } else { 260 TRACEME(("magic object for type %c in NULL\n", mg->mg_type)); 261 } 262 magic_ref++; 263 /* this is plain old magic, so do the same thing */ 264 sv_magic(clone, 265 obj, 266 mg->mg_type, 267 mg->mg_ptr, 268 mg->mg_len); 269 } 270 /* major kludge - why does the vtable for a qr type need to be null? */ 271 if ( mg = mg_find(clone, 'r') ) 272 mg->mg_virtual = (MGVTBL *) NULL; 273 } 274 /* 2: HASH/ARRAY - (with 'internal' elements) */ 275 if ( magic_ref ) 276 { 277 ;; 278 } 279 else if ( SvTYPE(ref) == SVt_PVHV ) 280 clone = hv_clone (ref, clone, hseen, depth); 281 else if ( SvTYPE(ref) == SVt_PVAV ) 282 clone = av_clone (ref, clone, hseen, depth); 283 /* 3: REFERENCE (inlined for speed) */ 284 else if (SvROK (ref)) 285 { 286 TRACEME(("clone = 0x%x(%d)\n", clone, SvREFCNT(clone))); 287 SvREFCNT_dec(SvRV(clone)); 288 SvRV(clone) = sv_clone (SvRV(ref), hseen, depth); /* Clone the referent */ 289 if (sv_isobject (ref)) 290 { 291 sv_bless (clone, SvSTASH (SvRV (ref))); 292 } 293 if (SvWEAKREF(ref)) { 294 sv_rvweaken(clone); 295 } 296 } 297 298 TRACEME(("clone = 0x%x(%d)\n", clone, SvREFCNT(clone))); 299 return clone; 300} 301 302MODULE = Clone PACKAGE = Clone 303 304PROTOTYPES: ENABLE 305 306void 307clone(self, depth=-1) 308 SV *self 309 int depth 310 PREINIT: 311 SV *clone = &PL_sv_undef; 312 HV *hseen = newHV(); 313 PPCODE: 314 TRACEME(("ref = 0x%x\n", self)); 315 clone = sv_clone(self, hseen, depth); 316 hv_clear(hseen); /* Free HV */ 317 SvREFCNT_dec((SV *)hseen); 318 EXTEND(SP,1); 319 PUSHs(sv_2mortal(clone)); 320