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