Clone-0.45/000755 000767 000024 00000000000 13650401135 013275 5ustar00nicolasstaff000000 000000 Clone-0.45/Changes000644 000767 000024 00000016124 13650377302 014604 0ustar00nicolasstaff000000 000000 Revision history for Perl module Clone 0.45 2020-04-23 14:46:00 atoomic - bump B::COW requirement to fix big-endian issue 0.44 2020-04-20 11:30:00 atoomic - support Perls with COW disabled (plicease) - bump B::COW requirement for testing 0.43 2019-07-29 13:47:42 atoomic - fix an issue when cloning a NULL mg_ptr pointer 0.42 2019-07-19 23:06:04 garu - make handling of mg_ptr safer (ATOOMIC, Harald Jörg) - change license wording on some test files to make the entire dist released under the same terms as Perl itself (fixes GH#20) (GARU) 0.41 2018-10-25 10:20:03 garu - Check the CowREFCNT of a COWed PV (ATOOMIC) this should fix some issues people have been having with 0.40 on DBD drives and DBIx::Class - Make buildtools files not executable (Mohammad S Anwar) - Move bugtracker to Github (GARU) 0.40 2018-10-23 20:001:49 garu - reuse COWed PV when cloning (fixes RT97535) (ATOOMIC) - extra protection against potential infinite loop (ATOOMIC) - improved tests 0.39 2017-04-07 13:06:00 garu - use explicit '.' in tests since it may not be in @INC anymore in newer perls (fixes RT120648) (PLICEASE, SIMCOP) 0.38 2015-01-18 19:27:41 garu - typo fixes and improvements to the README (zmughal) - travis/coveralls integration (zmughal) 0.37 2014-05-15 16:45:33 garu - removed Carp dependency (GARU) - silenced some clang warnings (JACQUESG) - added a README (GARU) 0.36 2013-12-07 17:36:04 garu - fixed compilation issue on AIX and C89 (GAAS) 0.35 2013-09-05 13:26:54 garu - SV's can be NULL (shit happens) (fixes RT86217) (HMBRAND) - making tests compatible with older versions of Test::More (GARU) 0.34 2012-12-09 14:46:09 garu - making some tests optional (fixes RT81774) (GARU) - modernizing synopsis (GARU) 0.33 2012-11-24 11:37:22 garu - fix typo in croak message (Salvatore Bonaccorso) 0.32 2012-11-22 12:14:07 garu - Stop skipping SvROK handling for all magical scalars. This fixes RT issues 67105, 79730 and 80201 (FLORA). - making the Changes file compliant to the CPAN::Changes spec (GARU). - Fixing tests when Scalar::Util::weaken is not available. As a result, tests should now pass even in odd OpenBSD versions (GARU). - removed dubious documentation on the optional parameter until it is 'fixed'. Right now it just increases the refcount when it's 0, and clones otherwise (which isn't exactly what it says). This fixes RT issue 57773 (GARU). - updated remark on Storable's dclone() to address RT issue 50174 (GARU) - updated Makefile.PL to include test dependencies (GARU) 0.31 2009-01-20 04:54:37 ray - Made changes for build failure on Solaris, apparently compiler warnings from the last patch are errors in Solaris. - Also, brought Changes file up to date. 0.30 2008-12-14 03:33:14 ray - Updating log: Applied patches from RT # 40957 and #41551. 0.29 2008-12-14 03:32:41 ray - Updating log: Applied patches supplied by Andreas Koenig, see RT #34317. 0.28 2008-12-14 03:31:33 ray - Updating log: Made a change in CLONE_KEY to the way Clone stores refs in the ref hash. - Perl no longer uses the SvANY part of the SV struct in the same way which means the old way of storing the hash key is no longer unique. Thanks to Slaven Rezic for the patch. 0.27 2008-12-14 03:30:40 ray - Updating Log: Latest patch from Ruslan Zakirov. Patched another memory leak. 0.26 2007-10-15 04:52:42 ray - Made a change in CLONE_KEY to the way Clone stores refs in the ref hash. - Perl no longer uses the SvANY part of the SV struct in the same way which means the old way of storing the hash key is no longer unique. Thanks to Slaven Rezic for the patch. 0.25 2007-07-25 03:41:04 ray - Latest patch from Ruslan Zakirov. Patched another memory leak. 0.24 2007-07-25 03:33:57 ray - Bug fix for 5.9.*, for some reason the 'visible' logic is no longer working. I #if 'ed it out until I figure out what is going on. - Also removed an old redundant CLONE_STORE, could have been the cause of some memory leaks. 0.23 2007-04-20 05:40:27 ray - Applied patch so clone will contiue to work with newer perls. - Also fixed test to work with older perls. 0.22 2006-10-08 05:35:19 ray - D'oh! The 0.21 tardist that I just uploaded to CPAN contained the 0.20 Clone.xs file. This release is just in case any of the 0.21 releases get mirrored. 0.21 2006-10-08 04:02:56 ray - Clone was segfaulting due to a null SV object in a magical reference (a PERL_MAGIC_utf8). - 21859: Clone segfault (isolated example) 0.20 2006-03-08 17:15:23 ray - Commented out VERSION causes errors with DynaLoader in perl 5.6.1 (and probably all earlier versions. It was removed. 0.19 2006-03-06 07:22:32 ray - added a test and fix for tainted variables. - use a static VERSION in Clone.pm. 0.18 2005-05-23 15:34:31 ray - moved declaration to top of function, M$ (and other) C compilers choke. 0.17 2005-05-05 22:26:01 ray - Changed PERL_MAGIC_backref to '<' for compatability with 5.6 0.16 2005-04-20 15:49:35 ray - Bug fix for id 11997, "Clone dies horribly when Scalar::Util::weaken is around" see http://rt.cpan.org/Ticket/Display.html?id=11997 for details. 0.15.2.1 2005-05-05 21:55:30 ray - changed PERL_MAGIC_backref to '<' for backward compatibility with 5.6 0.15 2003-09-07 22:02:35 ray - VERSION 0.15 0.13.2.3 2003-09-07 21:51:03 ray - added support for unicode hash keys. This is only really a bug in 5.8.0 and the test in t/03scalar supports this. 0.14 2003-09-07 05:48:10 ray - VERSION 0.14 0.13.2.2 2003-09-07 05:45:52 ray - bug fix: refs to a qr (regexp) expression was causing a segfault. 0.13.2.1 2003-09-06 20:18:37 ray - Bug fix on cloning references, only set ROK in clone if it's set in ref. 0.13 2002-02-03 02:12:29 ray - VERSION 0.13 0.11.2.1 2002-02-03 02:10:30 ray - removed dependency on Storable for tests. 0.12 2001-09-30 20:35:27 ray - Version 0.12 release. 0.11 2001-07-29 19:30:27 ray - VERSION 0.11 0.10.2.3 2001-07-28 21:53:03 ray - fixed memory leaks on un-blessed references. 0.10.2.2 2001-07-28 21:52:41 ray - added test cases for circular reference bugs and memory leaks. 0.10.2.1 2001-07-28 21:52:15 ray - fixed circular reference bugs. 0.10 2001-04-29 21:48:45 ray - VERSION 0.10 0.09.2.3 2001-03-11 00:54:41 ray - change call to rv_clone in clone to sv_clone; this allows any scalar to be cloned. 0.09.2.2 2001-03-11 00:50:01 ray - version 0.09.3: cleaned up code, consolidated MAGIC. 0.09.2.1 2001-03-05 16:01:52 ray - added support for double-types. 0.09 2000-08-21 23:05:55 ray - added support for code refs 0.08 2000-08-11 17:08:24 ray - Release 0.08. 0.07 2000-08-01 00:31:24 ray - release 0.07. 0.06.2.3 2000-07-28 20:40:25 ray - added support for circular references 0.06.2.2 2000-07-28 19:04:14 ray - first pass at circular references. 0.06.2.1 2000-07-28 18:54:33 ray - added support for scalar types. 0.06 Thu May 25 17:48:59 2000 GMT - initial release to CPAN. 0.01 Tue May 16 08:55:10 2000 - original version; created by h2xs 1.19 Clone-0.45/MANIFEST000644 000767 000024 00000000500 13650401135 014421 0ustar00nicolasstaff000000 000000 Changes Clone.pm Clone.xs Makefile.PL MANIFEST META.yml Module meta-data (added by MakeMaker) README.md t/01array.t t/02hash.t t/03scalar.t t/04tie.t t/05dtype.t t/06refcnt.t t/07magic.t t/08fieldhash.t t/dclone.t t/dump.pl t/tied.pl META.json Module JSON meta-data (added by MakeMaker) Clone-0.45/t/000755 000767 000024 00000000000 13650401135 013540 5ustar00nicolasstaff000000 000000 Clone-0.45/README.md000644 000767 000024 00000003736 13647355066 014606 0ustar00nicolasstaff000000 000000 Clone - recursively copy Perl datatypes ======================================= [![Build Status](https://travis-ci.org/garu/Clone.png?branch=master)](https://travis-ci.org/garu/Clone) [![Coverage Status](https://coveralls.io/repos/garu/Clone/badge.png?branch=master)](https://coveralls.io/r/garu/Clone?branch=master) [![CPAN version](https://badge.fury.io/pl/Clone.svg)](https://metacpan.org/pod/Clone) This module provides a `clone()` method which makes recursive copies of nested hash, array, scalar and reference types, including tied variables and objects. ```perl use Clone 'clone'; my $data = { set => [ 1 .. 50 ], foo => { answer => 42, object => SomeObject->new, }, }; my $cloned_data = clone($data); $cloned_data->{foo}{answer} = 1; print $cloned_data->{foo}{answer}; # '1' print $data->{foo}{answer}; # '42' ``` You can also add it to your class: ```perl package Foo; use parent 'Clone'; sub new { bless {}, shift } package main; my $obj = Foo->new; my $copy = $obj->clone; ``` `clone()` takes a scalar argument and duplicates it. To duplicate lists, arrays or hashes, pass them in by reference, e.g. ```perl my $copy = clone (\@array); # or my %copy = %{ clone (\%hash) }; ``` See Also -------- [Storable](https://metacpan.org/pod/Storable)'s `dclone()` is a flexible solution for cloning variables, albeit slower for average-sized data structures. Simple and naive benchmarks show that Clone is faster for data structures with 3 or fewer levels, while `dclone()` can be faster for structures 4 or more levels deep. COPYRIGHT --------- Copyright 2001-2019 Ray Finch. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. AUTHOR ------ Ray Finch `` Breno G. de Oliveira `` and Florian Ragwitz `` perform routine maintenance releases since 2012. Clone-0.45/Clone.xs000644 000767 000024 00000025550 13647350422 014730 0ustar00nicolasstaff000000 000000 #include #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #define CLONE_KEY(x) ((char *) &x) #define CLONE_STORE(x,y) \ do { \ if (!hv_store(hseen, CLONE_KEY(x), PTRSIZE, SvREFCNT_inc(y), 0)) { \ SvREFCNT_dec(y); /* Restore the refcount */ \ croak("Can't store clone in seen hash (hseen)"); \ } \ else { \ TRACEME(("storing ref = 0x%x clone = 0x%x\n", ref, clone)); \ TRACEME(("clone = 0x%x(%d)\n", clone, SvREFCNT(clone))); \ TRACEME(("ref = 0x%x(%d)\n", ref, SvREFCNT(ref))); \ } \ } while (0) #define CLONE_FETCH(x) (hv_fetch(hseen, CLONE_KEY(x), PTRSIZE, 0)) static SV *hv_clone (SV *, SV *, HV *, int); static SV *av_clone (SV *, SV *, HV *, int); static SV *sv_clone (SV *, HV *, int); static SV *rv_clone (SV *, HV *, int); #ifdef DEBUG_CLONE #define TRACEME(a) printf("%s:%d: ",__FUNCTION__, __LINE__) && printf a; #else #define TRACEME(a) #endif static SV * hv_clone (SV * ref, SV * target, HV* hseen, int depth) { HV *clone = (HV *) target; HV *self = (HV *) ref; HE *next = NULL; int recur = depth ? depth - 1 : 0; assert(SvTYPE(ref) == SVt_PVHV); TRACEME(("ref = 0x%x(%d)\n", ref, SvREFCNT(ref))); hv_iterinit (self); while ((next = hv_iternext (self))) { SV *key = hv_iterkeysv (next); TRACEME(("clone item %s\n", SvPV_nolen(key) )); hv_store_ent (clone, key, sv_clone (hv_iterval (self, next), hseen, recur), 0); } TRACEME(("clone = 0x%x(%d)\n", clone, SvREFCNT(clone))); return (SV *) clone; } static SV * av_clone (SV * ref, SV * target, HV* hseen, int depth) { AV *clone = (AV *) target; AV *self = (AV *) ref; SV **svp; SV *val = NULL; I32 arrlen = 0; int i = 0; int recur = depth ? depth - 1 : 0; assert(SvTYPE(ref) == SVt_PVAV); TRACEME(("ref = 0x%x(%d)\n", ref, SvREFCNT(ref))); /* The following is a holdover from a very old version */ /* possible cause of memory leaks */ /* if ( (SvREFCNT(ref) > 1) ) */ /* CLONE_STORE(ref, (SV *)clone); */ arrlen = av_len (self); av_extend (clone, arrlen); for (i = 0; i <= arrlen; i++) { svp = av_fetch (self, i, 0); if (svp) av_store (clone, i, sv_clone (*svp, hseen, recur)); } TRACEME(("clone = 0x%x(%d)\n", clone, SvREFCNT(clone))); return (SV *) clone; } static SV * rv_clone (SV * ref, HV* hseen, int depth) { SV *clone = NULL; SV *rv = NULL; assert(SvROK(ref)); TRACEME(("ref = 0x%x(%d)\n", ref, SvREFCNT(ref))); if (!SvROK (ref)) return NULL; if (sv_isobject (ref)) { clone = newRV_noinc(sv_clone (SvRV(ref), hseen, depth)); sv_2mortal (sv_bless (clone, SvSTASH (SvRV (ref)))); } else clone = newRV_inc(sv_clone (SvRV(ref), hseen, depth)); TRACEME(("clone = 0x%x(%d)\n", clone, SvREFCNT(clone))); return clone; } static SV * sv_clone (SV * ref, HV* hseen, int depth) { SV *clone = ref; SV **seen = NULL; UV visible; int magic_ref = 0; if (!ref) { TRACEME(("NULL\n")); return NULL; } #if PERL_REVISION >= 5 && PERL_VERSION > 8 /* This is a hack for perl 5.9.*, save everything */ /* until I find out why mg_find is no longer working */ visible = 1; #else visible = (SvREFCNT(ref) > 1) || (SvMAGICAL(ref) && mg_find(ref, '<')); #endif TRACEME(("ref = 0x%x(%d)\n", ref, SvREFCNT(ref))); if (depth == 0) return SvREFCNT_inc(ref); if (visible && (seen = CLONE_FETCH(ref))) { TRACEME(("fetch ref (0x%x)\n", ref)); return SvREFCNT_inc(*seen); } TRACEME(("switch: (0x%x)\n", ref)); switch (SvTYPE (ref)) { case SVt_NULL: /* 0 */ TRACEME(("sv_null\n")); clone = newSVsv (ref); break; case SVt_IV: /* 1 */ TRACEME(("int scalar\n")); case SVt_NV: /* 2 */ TRACEME(("double scalar\n")); clone = newSVsv (ref); break; #if PERL_VERSION <= 10 case SVt_RV: /* 3 */ TRACEME(("ref scalar\n")); clone = newSVsv (ref); break; #endif case SVt_PV: /* 4 */ TRACEME(("string scalar\n")); /* * Note: when using a Debug Perl with READONLY_COW * we cannot do 'sv_buf_to_rw + sv_buf_to_ro' as these APIs calls are not exported */ #if defined(SV_COW_REFCNT_MAX) && !defined(PERL_DEBUG_READONLY_COW) /* only for simple PVs unblessed */ if ( SvIsCOW(ref) && !SvOOK(ref) && SvLEN(ref) > 0 ) { if ( CowREFCNT(ref) < (SV_COW_REFCNT_MAX - 1) ) { /* cannot use newSVpv_share as this going to use a new PV we do not want to clone it */ /* create a fresh new PV */ clone = newSV(0); sv_upgrade(clone, SVt_PV); SvPOK_on(clone); SvIsCOW_on(clone); /* points the str slot to the COWed one */ SvPV_set(clone, SvPVX(ref) ); CowREFCNT(ref)++; /* preserve cur, len, flags and utf8 flag */ SvCUR_set(clone, SvCUR(ref)); SvLEN_set(clone, SvLEN(ref)); SvFLAGS(clone) = SvFLAGS(ref); /* preserve all the flags from the original SV */ if (SvUTF8(ref)) SvUTF8_on(clone); } else { /* we are above SV_COW_REFCNT_MAX, create a new SvPV but preserve the COW */ clone = newSVsv (ref); SvIsCOW_on(clone); CowREFCNT(clone) = 0; /* set the CowREFCNT to 0 */ } } else { clone = newSVsv (ref); } #else clone = newSVsv (ref); #endif break; case SVt_PVIV: /* 5 */ TRACEME (("PVIV double-type\n")); case SVt_PVNV: /* 6 */ TRACEME (("PVNV double-type\n")); clone = newSVsv (ref); break; case SVt_PVMG: /* 7 */ TRACEME(("magic scalar\n")); clone = newSVsv (ref); break; case SVt_PVAV: /* 10 */ clone = (SV *) newAV(); break; case SVt_PVHV: /* 11 */ clone = (SV *) newHV(); break; #if PERL_VERSION <= 8 case SVt_PVBM: /* 8 */ #elif PERL_VERSION >= 11 case SVt_REGEXP: /* 8 */ #endif case SVt_PVLV: /* 9 */ case SVt_PVCV: /* 12 */ case SVt_PVGV: /* 13 */ case SVt_PVFM: /* 14 */ case SVt_PVIO: /* 15 */ TRACEME(("default: type = 0x%x\n", SvTYPE (ref))); clone = SvREFCNT_inc(ref); /* just return the ref */ break; default: croak("unknown type: 0x%x", SvTYPE(ref)); } /** * It is *vital* that this is performed *before* recursion, * to properly handle circular references. cb 2001-02-06 */ if ( visible && ref != clone ) CLONE_STORE(ref,clone); /* * We'll assume (in the absence of evidence to the contrary) that A) a * tied hash/array doesn't store its elements in the usual way (i.e. * the mg->mg_object(s) take full responsibility for them) and B) that * references aren't tied. * * If theses assumptions hold, the three options below are mutually * exclusive. * * More precisely: 1 & 2 are probably mutually exclusive; 2 & 3 are * definitely mutually exclusive; we have to test 1 before giving 2 * a chance; and we'll assume that 1 & 3 are mutually exclusive unless * and until we can be test-cased out of our delusion. * * chocolateboy: 2001-05-29 */ /* 1: TIED */ if (SvMAGICAL(ref) ) { MAGIC* mg; MGVTBL *vtable = 0; for (mg = SvMAGIC(ref); mg; mg = mg->mg_moremagic) { SV *obj = (SV *) NULL; /* we don't want to clone a qr (regexp) object */ /* there are probably other types as well ... */ TRACEME(("magic type: %c\n", mg->mg_type)); /* Some mg_obj's can be null, don't bother cloning */ if ( mg->mg_obj != NULL ) { switch (mg->mg_type) { case 'r': /* PERL_MAGIC_qr */ obj = mg->mg_obj; break; case 't': /* PERL_MAGIC_taint */ case '<': /* PERL_MAGIC_backref */ case '@': /* PERL_MAGIC_arylen_p */ continue; break; case 'P': /* PERL_MAGIC_tied */ case 'p': /* PERL_MAGIC_tiedelem */ case 'q': /* PERL_MAGIC_tiedscalar */ magic_ref++; /* fall through */ default: obj = sv_clone(mg->mg_obj, hseen, -1); } } else { TRACEME(("magic object for type %c in NULL\n", mg->mg_type)); } { /* clone the mg_ptr pv */ char *mg_ptr = mg->mg_ptr; /* default */ if (mg->mg_len >= 0) { /* copy the pv */ if (mg_ptr) { Newxz(mg_ptr, mg->mg_len+1, char); /* add +1 for the NULL at the end? */ Copy(mg->mg_ptr, mg_ptr, mg->mg_len, char); } } else if (mg->mg_len == HEf_SVKEY) { /* let's share the SV for now */ SvREFCNT_inc((SV*)mg->mg_ptr); /* maybe we also want to clone the SV... */ //if (mg_ptr) mg->mg_ptr = (char*) sv_clone((SV*)mg->mg_ptr, hseen, -1); } else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8) { /* copy the cache */ if (mg->mg_ptr) { STRLEN *cache; Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN); mg_ptr = (char *) cache; Copy(mg->mg_ptr, mg_ptr, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN); } } else if ( mg->mg_ptr != NULL) { croak("Unsupported magic_ptr clone"); } /* this is plain old magic, so do the same thing */ sv_magic(clone, obj, mg->mg_type, mg_ptr, mg->mg_len); } } /* major kludge - why does the vtable for a qr type need to be null? */ if ( (mg = mg_find(clone, 'r')) ) mg->mg_virtual = (MGVTBL *) NULL; } /* 2: HASH/ARRAY - (with 'internal' elements) */ if ( magic_ref ) { ;; } else if ( SvTYPE(ref) == SVt_PVHV ) clone = hv_clone (ref, clone, hseen, depth); else if ( SvTYPE(ref) == SVt_PVAV ) clone = av_clone (ref, clone, hseen, depth); /* 3: REFERENCE (inlined for speed) */ else if (SvROK (ref)) { TRACEME(("clone = 0x%x(%d)\n", clone, SvREFCNT(clone))); SvREFCNT_dec(SvRV(clone)); SvRV(clone) = sv_clone (SvRV(ref), hseen, depth); /* Clone the referent */ if (sv_isobject (ref)) { sv_bless (clone, SvSTASH (SvRV (ref))); } if (SvWEAKREF(ref)) { sv_rvweaken(clone); } } TRACEME(("clone = 0x%x(%d)\n", clone, SvREFCNT(clone))); return clone; } MODULE = Clone PACKAGE = Clone PROTOTYPES: ENABLE void clone(self, depth=-1) SV *self int depth PREINIT: SV *clone = &PL_sv_undef; HV *hseen = newHV(); PPCODE: TRACEME(("ref = 0x%x\n", self)); clone = sv_clone(self, hseen, depth); hv_clear(hseen); /* Free HV */ SvREFCNT_dec((SV *)hseen); EXTEND(SP,1); PUSHs(sv_2mortal(clone)); Clone-0.45/META.yml000644 000767 000024 00000001272 13650401135 014550 0ustar00nicolasstaff000000 000000 --- abstract: 'recursively copy Perl datatypes' author: - 'Ray Finch ' build_requires: B::COW: '0.004' ExtUtils::MakeMaker: '0' Test::More: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Clone no_index: directory: - t - inc resources: bugtracker: https://github.com/garu/Clone/issues license: http://dev.perl.org/licenses/ repository: http://github.com/garu/Clone version: '0.45' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Clone-0.45/Makefile.PL000644 000767 000024 00000001633 13650377061 015264 0ustar00nicolasstaff000000 000000 use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'Clone', 'AUTHOR' => 'Ray Finch ', 'VERSION_FROM' => 'Clone.pm', 'ABSTRACT_FROM' => 'Clone.pm', 'LICENSE' => 'perl', 'PL_FILES' => {}, 'TEST_REQUIRES' => { 'Test::More' => 0, 'B::COW' => '0.004', }, 'LIBS' => [''], # e.g., '-lm' 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' 'INC' => '', # e.g., '-I/usr/include/other' # 'OPTIMIZE' => '-g', # e.g., '-I/usr/include/other' 'OPTIMIZE' => '-O3', # e.g., '-I/usr/include/other' clean => { FILES => '_Inline' }, META_MERGE => { resources => { license => 'http://dev.perl.org/licenses/', bugtracker => 'https://github.com/garu/Clone/issues', repository => 'http://github.com/garu/Clone', }, }, ); Clone-0.45/Clone.pm000644 000767 000024 00000004453 13650377210 014707 0ustar00nicolasstaff000000 000000 package Clone; use strict; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD); require Exporter; require DynaLoader; require AutoLoader; @ISA = qw(Exporter DynaLoader); @EXPORT = qw(); @EXPORT_OK = qw( clone ); $VERSION = '0.45'; bootstrap Clone $VERSION; 1; __END__ =head1 NAME Clone - recursively copy Perl datatypes =for html Build Status Coverage Status CPAN version =head1 SYNOPSIS use Clone 'clone'; my $data = { set => [ 1 .. 50 ], foo => { answer => 42, object => SomeObject->new, }, }; my $cloned_data = clone($data); $cloned_data->{foo}{answer} = 1; print $cloned_data->{foo}{answer}; # '1' print $data->{foo}{answer}; # '42' You can also add it to your class: package Foo; use parent 'Clone'; sub new { bless {}, shift } package main; my $obj = Foo->new; my $copy = $obj->clone; =head1 DESCRIPTION This module provides a C method which makes recursive copies of nested hash, array, scalar and reference types, including tied variables and objects. C takes a scalar argument and duplicates it. To duplicate lists, arrays or hashes, pass them in by reference, e.g. my $copy = clone (\@array); # or my %copy = %{ clone (\%hash) }; =head1 SEE ALSO L's C is a flexible solution for cloning variables, albeit slower for average-sized data structures. Simple and naive benchmarks show that Clone is faster for data structures with 3 or fewer levels, while C can be faster for structures 4 or more levels deep. =head1 COPYRIGHT Copyright 2001-2019 Ray Finch. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 AUTHOR Ray Finch C<< >> Breno G. de Oliveira C<< >> and Florian Ragwitz C<< >> perform routine maintenance releases since 2012. =cut Clone-0.45/META.json000644 000767 000024 00000002271 13650401135 014720 0ustar00nicolasstaff000000 000000 { "abstract" : "recursively copy Perl datatypes", "author" : [ "Ray Finch " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Clone", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "test" : { "requires" : { "B::COW" : "0.004", "Test::More" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/garu/Clone/issues" }, "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "http://github.com/garu/Clone" } }, "version" : "0.45", "x_serialization_backend" : "JSON::PP version 4.04" } Clone-0.45/t/04tie.t000755 000767 000024 00000002446 13363703145 014672 0ustar00nicolasstaff000000 000000 # $Id: 04tie.t,v 0.18 2006/10/08 03:37:29 ray Exp $ # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..5\n"; } END {print "not ok 1\n" unless $loaded;} use Clone qw( clone ); $loaded = 1; print "ok 1\n"; ######################### End of black magic. my $test = 2; require './t/dump.pl'; require './t/tied.pl'; my ($a, @a, %a); tie $a, TIED_SCALAR; tie %a, TIED_HASH; tie @a, TIED_ARRAY; $a{a} = 0; $a{b} = 1; my $b = [\%a, \@a, \$a]; my $c = clone($b); my $d1 = &dump($b); my $d2 = &dump($c); print "not" unless $d1 eq $d2; print "ok ", $test++, "\n"; my $t1 = tied(%{$b->[0]}); my $t2 = tied(%{$c->[0]}); $d1 = &dump($t1); $d2 = &dump($t2); print "not" unless $d1 eq $d2; print "ok ", $test++, "\n"; $t1 = tied(@{$b->[1]}); $t2 = tied(@{$c->[1]}); $d1 = &dump($t1); $d2 = &dump($t2); print "not" unless $d1 eq $d2; print "ok ", $test++, "\n"; $t1 = tied(${$b->[2]}); $t2 = tied(${$c->[2]}); $d1 = &dump($t1); $d2 = &dump($t2); print "not" unless $d1 eq $d2; print "ok ", $test++, "\n"; Clone-0.45/t/07magic.t000755 000767 000024 00000004212 13517644306 015171 0ustar00nicolasstaff000000 000000 # $Id: 07magic.t,v 1.8 2019/07/16 15:32:45 ray Exp $ use strict; use Clone; use Test::More tests => 10; SKIP: { eval "use Data::Dumper"; skip "Data::Dumper not installed", 1 if $@; SKIP: { eval "use Scalar::Util qw( weaken )"; skip "Scalar::Util not installed", 1 if $@; my $x = { a => "worked\n" }; my $y = $x; weaken($y); my $z = Clone::clone($x); ok( Dumper($x) eq Dumper($z), "Cloned weak reference"); } ## RT 21859: Clone segfault (isolated example) SKIP: { my $string = "HDDR-WD-250JS"; eval { use utf8; utf8::upgrade($string); }; skip $@, 1 if $@; $string = sprintf ('<>%s<>%s', '#EA0', substr ($string, 0, 4), substr ($string, 4), ); my $z = Clone::clone($string); ok( Dumper($string) eq Dumper($z), "Cloned magic utf8"); } } SKIP: { eval "use Taint::Runtime qw(enable taint_env)"; skip "Taint::Runtime not installed", 1 if $@; taint_env(); my $x = ""; for (keys %ENV) { $x = $ENV{$_}; last if ( $x && length($x) > 0 ); } my $y = Clone::clone($x); ## ok(Clone::clone($tainted), "Tainted input"); ok( Dumper($x) eq Dumper($y), "Tainted input"); } SKIP: { eval q{require Devel::Peek; require B; 1 } or skip "Devel::Peek or B missing", 7; my $clone_ref; { # one utf8 string my $content = "a\r\n"; utf8::upgrade($content); # set the PERL_MAGIC_utf8 index($content, "\n"); my $pv = B::svref_2object( \$content ); is ref($pv), 'B::PVMG', "got a PV"; ok $pv->MAGIC, "PV as a magic set"; is $pv->MAGIC->TYPE, 'w', 'PERL_MAGIC_utf8'; Devel::Peek::Dump( $content ); # Now clone it $clone_ref = Clone::clone(\$content); #is svref_2object( $clone_ref )->MAGIC->PTR, undef, 'undef ptr'; # And inspect it with Devel::Peek. $pv = B::svref_2object( $clone_ref ); is ref($pv), 'B::PVMG', "clone - got a PV"; ok $pv->MAGIC, "clone - PV as a magic set"; is $pv->MAGIC->TYPE, 'w', 'clone - PERL_MAGIC_utf8'; Devel::Peek::Dump( $$clone_ref ); ok 1, "Dump without segfault"; } } Clone-0.45/t/dclone.t000755 000767 000024 00000005207 13517644306 015213 0ustar00nicolasstaff000000 000000 #!./perl # $Id: dclone.t,v 0.18 2006/10/08 03:37:29 ray Exp $ # # Id: dclone.t,v 0.6.1.1 2000/03/02 22:21:05 ram Exp # # Copyright (c) 1995-1998, Raphael Manfredi # # You may redistribute and/or modify this file # under the same terms as Perl itself. # # $Log: dclone.t,v $ # Revision 0.18 2006/10/08 03:37:29 ray # Commented out VERSION causes errors with DynaLoader in perl 5.6.1 (and # probably all earlier versions. It was removed. # # Revision 0.14 2003/09/07 22:02:36 ray # VERSION 0.15 # # Revision 0.13.2.1 2003/09/07 21:51:13 ray # added support for unicode hash keys. This is only really a bug in 5.8.0 and # the test in t/03scalar supports this. # # Revision 0.13 2002/06/12 06:41:55 ray # VERSION 0.13 # # Revision 0.11 2001/07/29 19:31:05 ray # VERSION 0.11 # # Revision 0.10.2.1 2001/07/28 21:47:49 ray # commented out print statements. # # Revision 0.10 2001/04/29 21:56:10 ray # VERSION 0.10 # # Revision 0.9 2001/03/05 00:11:49 ray # version 0.9 # # Revision 0.9 2000/08/21 23:06:34 ray # added support for code refs # # Revision 0.8 2000/08/11 17:08:36 ray # Release 0.08. # # Revision 0.7 2000/08/01 00:31:42 ray # release 0.07 # # Revision 0.6 2000/07/28 21:37:20 ray # "borrowed" code from Storable # # Revision 0.6.1.1 2000/03/02 22:21:05 ram # patch9: added test case for "undef" bug in hashes # # Revision 0.6 1998/06/04 16:08:25 ram # Baseline for first beta release. # require './t/dump.pl'; # use Storable qw(dclone); use Clone qw(clone); print "1..9\n"; $a = 'toto'; $b = \$a; $c = bless {}, CLASS; $c->{attribute} = 'attrval'; %a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c); @a = ('first', undef, 3, -4, -3.14159, 456, 4.5, $b, \$a, $a, $c, \$c, \%a); print "not " unless defined ($aref = clone(\@a)); print "ok 1\n"; $dumped = &dump(\@a); print "ok 2\n"; $got = &dump($aref); print "ok 3\n"; # print $got; # print $dumped; # print $_, "\n" for (@a); # print $_, "\n" foreach (@$aref); print "not " unless $got eq $dumped; print "ok 4\n"; package FOO; @ISA = qw(Clone); sub make { my $self = bless {}; $self->{key} = \%main::a; return $self; }; package main; $foo = FOO->make; print "not " unless defined($r = $foo->clone); print "ok 5\n"; # print &dump($foo); # print &dump($r); print "not " unless &dump($foo) eq &dump($r); print "ok 6\n"; # Ensure refs to "undef" values are properly shared during cloning my $hash; push @{$$hash{''}}, \$$hash{a}; print "not " unless $$hash{''}[0] == \$$hash{a}; print "ok 7\n"; my $cloned = clone(clone($hash)); print "not " unless $$cloned{''}[0] == \$$cloned{a}; print "ok 8\n"; $$cloned{a} = "blah"; print "not " unless $$cloned{''}[0] == \$$cloned{a}; print "ok 9\n"; Clone-0.45/t/dump.pl000755 000767 000024 00000007136 13517644306 015067 0ustar00nicolasstaff000000 000000 ;# Id: dump.pl,v 0.7 2000/08/03 22:04:45 ram Exp ;# ;# Copyright (c) 1995-2000, Raphael Manfredi ;# ;# You may redistribute and/or modify this file ;# under the same terms as Perl itself. ;# ;# Log: dump.pl,v ;# Revision 0.7 2000/08/03 22:04:45 ram ;# Baseline for second beta release. ;# sub ok { my ($num, $ok) = @_; print "not " unless $ok; print "ok $num\n"; } package dump; %dump = ( 'SCALAR' => 'dump_scalar', 'ARRAY' => 'dump_array', 'HASH' => 'dump_hash', 'REF' => 'dump_ref', 'CODE' => 'dump_code', ); # Given an object, dump its transitive data closure sub main'dump { my ($object) = @_; die "Not a reference!" unless ref($object); local %dumped; local %object; local $count = 0; local $dumped = ''; &recursive_dump($object, 1); return $dumped; } # This is the root recursive dumping routine that may indirectly be # called by one of the routine it calls... # The link parameter is set to false when the reference passed to # the routine is an internal temporay variable, implying the object's # address is not to be dumped in the %dumped table since it's not a # user-visible object. sub recursive_dump { my ($object, $link) = @_; # Get something like SCALAR(0x...) or TYPE=SCALAR(0x...). # Then extract the bless, ref and address parts of that string. my $what = "$object"; # Stringify my ($bless, $ref, $addr) = $what =~ /^(\w+)=(\w+)\((0x.*)\)$/; ($ref, $addr) = $what =~ /^(\w+)\((0x.*)\)$/ unless $bless; # Special case for references to references. When stringified, # they appear as being scalars. However, ref() correctly pinpoints # them as being references indirections. And that's it. $ref = 'REF' if ref($object) eq 'REF'; # Make sure the object has not been already dumped before. # We don't want to duplicate data. Retrieval will know how to # relink from the previously seen object. if ($link && $dumped{$addr}++) { my $num = $object{$addr}; $dumped .= "OBJECT #$num seen\n"; return; } my $objcount = $count++; $object{$addr} = $objcount; # Call the appropriate dumping routine based on the reference type. # If the referenced was blessed, we bless it once the object is dumped. # The retrieval code will perform the same on the last object retrieved. die "Unknown simple type '$ref'" unless defined $dump{$ref}; &{$dump{$ref}}($object); # Dump object &bless($bless) if $bless; # Mark it as blessed, if necessary $dumped .= "OBJECT $objcount\n"; } # Indicate that current object is blessed sub bless { my ($class) = @_; $dumped .= "BLESS $class\n"; } # Dump single scalar sub dump_scalar { my ($sref) = @_; my $scalar = $$sref; unless (defined $scalar) { $dumped .= "UNDEF\n"; return; } my $len = length($scalar); $dumped .= "SCALAR len=$len $scalar\n"; } # Dump array sub dump_array { my ($aref) = @_; my $items = 0 + @{$aref}; $dumped .= "ARRAY items=$items\n"; foreach $item (@{$aref}) { unless (defined $item) { $dumped .= 'ITEM_UNDEF' . "\n"; next; } $dumped .= 'ITEM '; &recursive_dump(\$item, 1); } } # Dump hash table sub dump_hash { my ($href) = @_; my $items = scalar(keys %{$href}); $dumped .= "HASH items=$items\n"; foreach $key (sort keys %{$href}) { $dumped .= 'KEY '; &recursive_dump(\$key, undef); unless (defined $href->{$key}) { $dumped .= 'VALUE_UNDEF' . "\n"; next; } $dumped .= 'VALUE '; &recursive_dump(\$href->{$key}, 1); } } # Dump reference to reference sub dump_ref { my ($rref) = @_; my $deref = $$rref; # Follow reference to reference $dumped .= 'REF '; &recursive_dump($deref, 1); # $dref is a reference } # Dump code sub dump_code { my ($sref) = @_; $dumped .= "CODE\n"; } 1; Clone-0.45/t/05dtype.t000755 000767 000024 00000002737 13071231470 015233 0ustar00nicolasstaff000000 000000 # $Id: 05dtype.t,v 0.18 2006/10/08 03:37:29 ray Exp $ # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) my $has_data_dumper; BEGIN { $| = 1; my $tests = 1; eval q[use Data::Dumper]; if (!$@) { $has_data_dumper = 1; $tests++; } print "1..$tests\n"; } END {print "not ok 1\n" unless $loaded;} use Clone; $loaded = 1; print "ok 1\n"; ######################### End of black magic. # Insert your test code below (better if it prints "ok 13" # (correspondingly "not ok 13") depending on the success of chunk 13 # of the test code): eval 'use Storable qw( dclone )'; if ($@) { print "ok 2 # skipping Storable not found\n"; exit; } # use Storable qw( dclone ); $^W = 0; $test = 2; sub ok { printf("ok %d\n", $test++); } sub not_ok { printf("not ok %d\n", $test++); } use strict; package Test::Hash; @Test::Hash::ISA = qw( Clone ); sub new() { my ($class) = @_; my $self = {}; $self->{x} = 0; $self->{x} = {value => 1}; bless $self, $class; } package main; my ($master, $clone1); my $a = Test::Hash->new(); my $b = $a->clone; my $c = dclone($a); if ($has_data_dumper) { Dumper($a, $b) eq Dumper($a, $c) ? ok() : not_ok; } # print Dumper($a, $b); # print Dumper($a, $c); Clone-0.45/t/01array.t000755 000767 000024 00000003341 13071231470 015210 0ustar00nicolasstaff000000 000000 # $Id: 01array.t,v 0.19 2006/10/08 03:37:29 ray Exp $ # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) my $has_data_dumper; BEGIN { $| = 1; my $tests = 6; eval q[use Data::Dumper]; if (!$@) { $has_data_dumper = 1; $tests++; } print "1..$tests\n"; } END {print "not ok 1\n" unless $loaded;} use Clone qw( clone ); $loaded = 1; print "ok 1\n"; ######################### End of black magic. # Insert your test code below (better if it prints "ok 13" # (correspondingly "not ok 13") depending on the success of chunk 13 # of the test code): package Test::Array; use vars @ISA; @ISA = qw(Clone); sub new { my $class = shift; my @self = @_; bless \@self, $class; } package main; sub ok { print "ok $test\n"; $test++ } sub not_ok { print "not ok $test\n"; $test++ } $^W = 0; $test = 2; my $a = Test::Array->new( 1, [ 'two', [ 3, ['four'] ], ], ); my $b = $a->clone(0); my $c = $a->clone(2); # TEST 2 $b->[1][0] eq 'two' ? ok : not_ok; # TEST 3 $b->[1] == $a->[1] ? ok : not_ok; # TEST 4 $c->[1] != $a->[1] ? ok : not_ok; # TEST 5 $c->[1][1][1] == $a->[1][1][1] ? ok : not_ok; my @circ = (); $circ[0] = \@circ; $aref = clone(\@circ); if ($has_data_dumper) { Dumper(\@circ) eq Dumper($aref) ? ok : not_ok; } # test for unicode support { my $a = [ chr(256) => 1 ]; my $b = clone( $a ); ord( $a->[0] ) == ord( $b->[0] ) ? ok : not_ok; } Clone-0.45/t/06refcnt.t000755 000767 000024 00000011340 13517644167 015376 0ustar00nicolasstaff000000 000000 # $Id: 06refcnt.t,v 0.22 2007/07/25 03:41:06 ray Exp $ # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) my $HAS_WEAKEN; BEGIN { $| = 1; my $plan = 25; eval 'use Scalar::Util qw( weaken isweak );'; if ($@) { $HAS_WEAKEN = 0; $plan = 15; } else { $HAS_WEAKEN = 1; } print "1..$plan\n"; } END { print "not ok 1\n" unless $loaded; } use Clone qw( clone ); $loaded = 1; print "ok 1\n"; ######################### End of black magic. # Insert your test code below (better if it prints "ok 13" # (correspondingly "not ok 13") depending on the success of chunk 13 # of the test code): # code to test for memory leaks ## use Benchmark; ## use Data::Dumper; # use Storable qw( dclone ); $^W = 1; $test = 2; use strict; package Test::Hash; @Test::Hash::ISA = qw( Clone ); sub new() { my ($class) = @_; my $self = {}; bless $self, $class; } my $ok = 0; END { $ok = 1; } sub DESTROY { my $self = shift; printf("not ") if $ok; printf( "ok %d - DESTROY\n", $::test++ ); } package main; { my $a = Test::Hash->new(); my $b = $a->clone; # my $c = dclone($a); } # benchmarking bug { my $a = Test::Hash->new(); my $sref = sub { my $b = clone($a) }; $sref->(); } # test for cloning unblessed ref { my $a = {}; my $b = clone($a); bless $a, 'Test::Hash'; bless $b, 'Test::Hash'; } # test for cloning unblessed ref { my $a = []; my $b = clone($a); bless $a, 'Test::Hash'; bless $b, 'Test::Hash'; } # test for cloning ref that was an int(IV) { my $a = 1; $a = []; my $b = clone($a); bless $a, 'Test::Hash'; bless $b, 'Test::Hash'; } # test for cloning ref that was a string(PV) { my $a = ''; $a = []; my $b = clone($a); bless $a, 'Test::Hash'; bless $b, 'Test::Hash'; } # test for cloning ref that was a magic(PVMG) { my $a = *STDOUT; $a = []; my $b = clone($a); bless $a, 'Test::Hash'; bless $b, 'Test::Hash'; } # test for cloning weak reference if ($HAS_WEAKEN) { { my $a = Test::Hash->new; my $b = { r => $a }; $a->{r} = $b; weaken( $b->{'r'} ); my $c = clone($a); } # another weak reference problem, this one causes a segfault in 0.24 { my $a = Test::Hash->new; { my $b = [ $a, $a ]; $a->{r} = $b; weaken( $b->[0] ); weaken( $b->[1] ); } my $c = clone($a); # check that references point to the same thing is( $c->{'r'}[0], $c->{'r'}[1], "references point to the same thing" ); isnt( $c->{'r'}[0], $a->{'r'}[0], "a->{r}->[0] ne c->{r}->[0]" ); require B; my $c_obj = B::svref_2object($c); is( $c_obj->REFCNT, 1, 'c REFCNT = 1' ) or diag( "refcnt is ", $c_obj->REFCNT ); my $cr_obj = B::svref_2object( $c->{'r'} ); is( $cr_obj->REFCNT, 1, 'cr REFCNT = 1' ) or diag( "refcnt is ", $cr_obj->REFCNT ); my $cr_0_obj = B::svref_2object( $c->{'r'}->[0] ); is( $cr_0_obj->REFCNT, 1, 'c->{r}->[0] REFCNT = 1' ) or diag( "refcnt is ", $cr_0_obj->REFCNT ); my $cr_1_obj = B::svref_2object( $c->{'r'}->[1] ); is( $cr_1_obj->REFCNT, 1, 'c->{r}->[1] REFCNT = 1' ) or diag( "refcnt is ", $cr_1_obj->REFCNT ); } } exit; sub diag { my (@msg) = @_; print STDERR join( ' ', '#', @msg, "\n" ); return; } sub ok { my $msg = shift; $msg = '' unless defined $msg; $msg = ' - ' . $msg if length $msg; printf( "ok %d%s\n", $::test++, $msg ); return 1; } sub not_ok { my $msg = shift; $msg = '' unless defined $msg; printf( "not ok %d %s\n", $::test++, $msg ); return; } sub is { my ( $x, $y, $msg ) = @_; # dumb for now $x = 'undef' if !defined $x; $y = 'undef' if !defined $y; if ( !defined $x && !defined $y ) { return ok($msg); } if ( !defined $x || !defined $y ) { return not_ok($msg); } if ( $x eq $y ) { return ok($msg); } else { return not_ok($msg); } } sub isnt { my ( $x, $y, $msg ) = @_; # dumb for now $x = 'undef' if !defined $x; $y = 'undef' if !defined $y; if ( !defined $x && !defined $y ) { return no_ok($msg); } if ( !defined $x || !defined $y ) { return ok($msg); } if ( $x eq $y ) { return not_ok($msg); } else { return ok($msg); } } Clone-0.45/t/PaxHeader/03scalar.t000755 000767 000024 00000000036 13647352602 017322 xustar00nicolasstaff000000 000000 30 mtime=1587402114.318749494 Clone-0.45/t/03scalar.t000755 000767 000024 00000005453 13647352602 015361 0ustar00nicolasstaff000000 000000 # $Id: 03scalar.t,v 0.19 2006/10/08 03:37:29 ray Exp $ # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) use B q{svref_2object}; use B::COW; my $has_data_dumper; BEGIN { $| = 1; my $tests = 12; $tests += 2 if B::COW::can_cow(); eval q[use Data::Dumper]; if (!$@) { $has_data_dumper = 1; $tests++; } print "1..$tests\n"; } END {print "not ok 1\n" unless $loaded;} use Clone qw( clone ); $loaded = 1; print "ok 1\n"; ######################### End of black magic. # Insert your test code below (better if it prints "ok 13" # (correspondingly "not ok 13") depending on the success of chunk 13 # of the test code): package Test::Scalar; use vars @ISA; @ISA = qw(Clone); sub new { my $class = shift; my $self = shift; bless \$self, $class; } sub DESTROY { my $self = shift; # warn "DESTROYING $self"; } package main; sub ok { my ( $check, $msg ) = @_; $msg = '' unless defined $msg; if ( $check ) { print "ok $test $msg\n"; } else { print "not ok $test $msg\n"; } $test++; return; } $^W = 0; $test = 2; my $a = Test::Scalar->new(1.0); my $b = $a->clone(1); ok( $$a == $$b, '$$a == $$b' ); ok( $a != $b, '$a != $b' ); { print "# using a reference on a string (CowREFCNT == 0).\n"; my $c = \"something"; my $d = Clone::clone($c, 2); ok( $$c == $$d, 'test 2 scalar content' ); ok( $c != $d, 'SV are differents SVs' ); } { print "# using a reference on one SvPV (CowREFCNT > 0).\n"; my $str = "my string"; my $c = \$str; my $d = Clone::clone($c, 2); ok( $$c == $$d, 'test 2 scalar content' ); ok( $c != $d, 'SV are differents SVs' ); if ( B::COW::can_cow() ) { my $sv_c = svref_2object( $c ); my $sv_d = svref_2object( $d ); ok( $sv_c->FLAGS & B::SVf_IsCOW, 'COW flag set on c' ); ok( $sv_d->FLAGS & B::SVf_IsCOW, 'COW flag set on d' ); } } $$d .= 'abcd'; ok( $$c ne $$d, 'only one scalar changed' ); my $circ = undef; $circ = \$circ; $aref = clone($circ); if ($has_data_dumper) { ok( Dumper($circ) eq Dumper($aref), 'Dumper check' ); } # the following used to produce a segfault, rt.cpan.org id=2264 undef $a; $b = clone($a); ok( $$a == $$b, 'int check' ); # used to get a segfault cloning a ref to a qr data type. my $str = 'abcdefg'; my $qr = qr/$str/; my $qc = clone( $qr ); ok( $qr eq $qc, 'string check' ) or warn "$qr vs $qc"; ok( $str =~ /$qc/, 'regexp check' ); # test for unicode support { my $a = \( chr(256) ); my $b = clone( $a ); ok( ord($$a) == ord($$b) ); } Clone-0.45/t/08fieldhash.t000755 000767 000024 00000000705 13071231470 016031 0ustar00nicolasstaff000000 000000 # $Id: 07magic.t,v 1.8 2007/04/20 05:40:48 ray Exp $ use strict; use warnings; use Clone 'clone'; BEGIN { use Test::More; eval { require Hash::Util::FieldHash; Hash::Util::FieldHash->import('fieldhash'); }; if ($@) { plan skip_all => 'Hash::Util::FieldHash not available'; } else { plan tests => 1; } } fieldhash my %hash; my $var = {}; exists $hash{ \$var }; my $cloned = clone($var); cmp_ok($cloned, '!=', $var); Clone-0.45/t/02hash.t000755 000767 000024 00000004254 13071231470 015022 0ustar00nicolasstaff000000 000000 # $Id: 02hash.t,v 0.19 2006/10/08 03:37:29 ray Exp $ # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) my $has_data_dumper; BEGIN { $| = 1; my $tests = 11; eval q[use Data::Dumper]; if (!$@) { $has_data_dumper = 1; $tests++; } print "1..$tests\n"; } END {print "not ok 1\n" unless $loaded;} use Clone qw( clone ); $loaded = 1; print "ok 1\n"; ######################### End of black magic. # Insert your test code below (better if it prints "ok 13" # (correspondingly "not ok 13") depending on the success of chunk 13 # of the test code): package Test::Hash; use vars @ISA; @ISA = qw(Clone); sub new { my $class = shift; my %self = @_; bless \%self, $class; } sub DESTROY { my $self = shift; # warn "DESTROYING $self"; } package main; sub ok { print "ok $test\n"; $test++ } sub not_ok { print "not ok $test\n"; $test++ } $^W = 0; $test = 2; my $a = Test::Hash->new( level => 1, href => { level => 2, href => { level => 3, href => { level => 4, }, }, }, ); $a->{a} = $a; my $b = $a->clone(0); my $c = $a->clone(3); $a->{level} == $b->{level} ? ok : not_ok; $b->{href} == $a->{href} ? ok : not_ok; $c->{href} != $a->{href} ? ok : not_ok; $b->{href}{href} == $a->{href}{href} ? ok : not_ok; $c->{href}{href} != $a->{href}{href} ? ok : not_ok; $c->{href}{href}{level} == 3 ? ok : not_ok; $c->{href}{href}{href}{level} == 4 ? ok : not_ok; $b->{href}{href}{href} == $a->{href}{href}{href} ? ok : not_ok; $c->{href}{href}{href} == $a->{href}{href}{href} ? ok : not_ok; my %circ = (); $circ{c} = \%circ; my $cref = clone(\%circ); if ($has_data_dumper) { Dumper(\%circ) eq Dumper($cref) ? ok : not_ok; } # test for unicode support { my $a = { chr(256) => 1 }; my $b = clone( $a ); ord( (keys(%$a))[0] ) == ord( (keys(%$b))[0] ) ? ok : not_ok; } Clone-0.45/t/tied.pl000755 000767 000024 00000004347 13517644306 015050 0ustar00nicolasstaff000000 000000 #!./perl # $Id: tied.pl,v 0.18 2006/10/08 03:37:29 ray Exp $ # # Copyright (c) 1995-1998, Raphael Manfredi # # You may redistribute and/or modify this file # under the same terms as Perl itself. # # $Log: tied.pl,v $ # Revision 0.18 2006/10/08 03:37:29 ray # Commented out VERSION causes errors with DynaLoader in perl 5.6.1 (and # probably all earlier versions. It was removed. # # Revision 0.14 2003/09/07 22:02:36 ray # VERSION 0.15 # # Revision 0.13.2.1 2003/09/07 21:51:13 ray # added support for unicode hash keys. This is only really a bug in 5.8.0 and # the test in t/03scalar supports this. # # Revision 0.13 2002/06/12 06:41:55 ray # VERSION 0.13 # # Revision 0.11 2001/07/29 19:31:05 ray # VERSION 0.11 # # Revision 0.10 2001/04/29 21:56:10 ray # VERSION 0.10 # # Revision 0.9 2001/03/05 00:11:49 ray # version 0.9 # # Revision 0.9 2000/08/21 23:06:34 ray # added support for code refs # # Revision 0.8 2000/08/11 17:08:36 ray # Release 0.08. # # Revision 0.7 2000/08/01 00:43:48 ray # release 0.07. # # Revision 0.6.2.1 2000/08/01 00:42:53 ray # modified to use as a require statement. # # Revision 0.6 2000/08/01 01:38:38 ray # "borrowed" code from Storable # # Revision 0.6 1998/06/04 16:08:40 ram # Baseline for first beta release. # require './t/dump.pl'; package TIED_HASH; sub TIEHASH { my $self = bless {}, shift; return $self; } sub FETCH { my $self = shift; my ($key) = @_; $main::hash_fetch++; return $self->{$key}; } sub STORE { my $self = shift; my ($key, $value) = @_; $self->{$key} = $value; } sub FIRSTKEY { my $self = shift; scalar keys %{$self}; return each %{$self}; } sub NEXTKEY { my $self = shift; return each %{$self}; } package TIED_ARRAY; sub TIEARRAY { my $self = bless [], shift; return $self; } sub FETCH { my $self = shift; my ($idx) = @_; $main::array_fetch++; return $self->[$idx]; } sub STORE { my $self = shift; my ($idx, $value) = @_; $self->[$idx] = $value; } sub FETCHSIZE { my $self = shift; return @{$self}; } package TIED_SCALAR; sub TIESCALAR { my $scalar; my $self = bless \$scalar, shift; return $self; } sub FETCH { my $self = shift; $main::scalar_fetch++; return $$self; } sub STORE { my $self = shift; my ($value) = @_; $$self = $value; } 1;