Clone-0.39/ 000755 000765 000024 00000000000 13071673132 012611 5 ustar 00garu staff 000000 000000 Clone-0.39/Changes 000755 000765 000024 00000014202 13071671734 014114 0 ustar 00garu staff 000000 000000 Revision history for Perl module Clone
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.39/Clone.pm 000755 000765 000024 00000004453 13071671774 014232 0 ustar 00garu staff 000000 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.39';
bootstrap Clone $VERSION;
1;
__END__
=head1 NAME
Clone - recursively copy Perl datatypes
=for html
=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-2017 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.39/Clone.xs 000755 000765 000024 00000020755 12333425417 014242 0 ustar 00garu staff 000000 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"));
clone = newSVsv (ref);
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 )
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 */
continue;
break;
case '<': /* PERL_MAGIC_backref */
continue;
break;
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));
}
/* this is plain old magic, so do the same thing */
sv_magic(clone,
obj,
mg->mg_type,
mg->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.39/Makefile.PL 000755 000765 000024 00000001607 12333425521 014567 0 ustar 00garu staff 000000 000000 use ExtUtils::MakeMaker;
WriteMakefile(
'NAME' => 'Clone',
'AUTHOR' => 'Ray Finch ',
'VERSION_FROM' => 'Clone.pm',
'ABSTRACT_FROM' => 'Clone.pm',
'LICENSE' => 'perl',
'PL_FILES' => {},
'BUILD_REQUIRES' => {
'Test::More' => 0,
},
'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 => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=Clone',
repository => 'http://github.com/garu/Clone',
},
},
);
Clone-0.39/MANIFEST 000644 000765 000024 00000000475 13071673132 013750 0 ustar 00garu staff 000000 000000 Changes
Clone.pm
Clone.xs
Makefile.PL
MANIFEST
META.yml Module meta-data (added by MakeMaker)
README
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.39/META.json 000644 000765 000024 00000002176 13071673132 014240 0 ustar 00garu staff 000000 000000 {
"abstract" : "recursively copy Perl datatypes",
"author" : [
"Ray Finch "
],
"dynamic_config" : 1,
"generated_by" : "ExtUtils::MakeMaker version 7.1002, CPAN::Meta::Converter version 2.150005",
"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" : {
"Test::More" : "0"
}
},
"configure" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"runtime" : {
"requires" : {}
}
},
"release_status" : "stable",
"resources" : {
"bugtracker" : {
"web" : "http://rt.cpan.org/NoAuth/Bugs.html?Dist=Clone"
},
"license" : [
"http://dev.perl.org/licenses/"
],
"repository" : {
"url" : "http://github.com/garu/Clone"
}
},
"version" : "0.39",
"x_serialization_backend" : "JSON::PP version 2.27300_01"
}
Clone-0.39/META.yml 000644 000765 000024 00000001246 13071673131 014064 0 ustar 00garu staff 000000 000000 ---
abstract: 'recursively copy Perl datatypes'
author:
- 'Ray Finch '
build_requires:
Test::More: '0'
configure_requires:
ExtUtils::MakeMaker: '0'
dynamic_config: 1
generated_by: 'ExtUtils::MakeMaker version 7.1002, CPAN::Meta::Converter version 2.150005'
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
requires: {}
resources:
bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Clone
license: http://dev.perl.org/licenses/
repository: http://github.com/garu/Clone
version: '0.39'
x_serialization_backend: 'CPAN::Meta::YAML version 0.018'
Clone-0.39/README 000644 000765 000024 00000003736 13071672035 013503 0 ustar 00garu staff 000000 000000 Clone - recursively copy Perl datatypes
=======================================
[](https://travis-ci.org/garu/Clone)
[](https://coveralls.io/r/garu/Clone?branch=master)
[](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-2017 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.39/t/ 000755 000765 000024 00000000000 13071673131 013053 5 ustar 00garu staff 000000 000000 Clone-0.39/t/01array.t 000755 000765 000024 00000003341 12333425216 014522 0 ustar 00garu staff 000000 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.39/t/02hash.t 000755 000765 000024 00000004254 12333425216 014334 0 ustar 00garu staff 000000 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.39/t/03scalar.t 000755 000765 000024 00000003720 12333425216 014654 0 ustar 00garu staff 000000 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.)
my $has_data_dumper;
BEGIN {
$| = 1;
my $tests = 9;
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 { print "ok $test\n"; $test++ }
sub not_ok { print "not ok $test\n"; $test++ }
$^W = 0;
$test = 2;
my $a = Test::Scalar->new(1.0);
my $b = $a->clone(1);
$$a == $$b ? ok : not_ok;
$a != $b ? ok : not_ok;
my $c = \"test 2 scalar";
my $d = Clone::clone($c, 2);
$$c == $$d ? ok : not_ok;
$c != $d ? ok : not_ok;
my $circ = undef;
$circ = \$circ;
$aref = clone($circ);
if ($has_data_dumper) {
Dumper($circ) eq Dumper($aref) ? ok : not_ok;
}
# the following used to produce a segfault, rt.cpan.org id=2264
undef $a;
$b = clone($a);
$$a == $$b ? ok : not_ok;
# used to get a segfault cloning a ref to a qr data type.
my $str = 'abcdefg';
my $qr = qr/$str/;
my $qc = clone( $qr );
$qr eq $qc ? ok : not_ok;
$str =~ /$qc/ ? ok : not_ok;
# test for unicode support
{
my $a = \( chr(256) );
my $b = clone( $a );
ord($$a) == ord($$b) ? ok : not_ok;
}
Clone-0.39/t/04tie.t 000755 000765 000024 00000002446 13071666561 014207 0 ustar 00garu staff 000000 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.39/t/05dtype.t 000755 000765 000024 00000002737 12333425216 014545 0 ustar 00garu staff 000000 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.39/t/06refcnt.t 000755 000765 000024 00000005422 12333425216 014674 0 ustar 00garu staff 000000 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 = 20;
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;
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 = {};
bless $self, $class;
}
my $ok = 0;
END { $ok = 1; };
sub DESTROY
{
my $self = shift;
printf("not ") if $ok;
printf("ok %d\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 = new Test::Hash();
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 = new Test::Hash();
{
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
print "not " unless $c->{'r'}[0] == $c->{'r'}[1];
printf "ok %d\n", $::test++;
}
}
Clone-0.39/t/07magic.t 000755 000765 000024 00000002324 12333425216 014472 0 ustar 00garu staff 000000 000000 # $Id: 07magic.t,v 1.8 2007/04/20 05:40:48 ray Exp $
use strict;
use Clone;
use Test::More tests => 3;
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");
}
Clone-0.39/t/08fieldhash.t 000755 000765 000024 00000000705 12333425216 015343 0 ustar 00garu staff 000000 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.39/t/dclone.t 000755 000765 000024 00000005276 13071666561 014532 0 ustar 00garu staff 000000 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 only under the terms of the Artistic License,
# as specified in the README file that comes with the distribution.
#
# $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.39/t/dump.pl 000755 000765 000024 00000007223 12335232374 014366 0 ustar 00garu staff 000000 000000 ;# Id: dump.pl,v 0.7 2000/08/03 22:04:45 ram Exp
;#
;# Copyright (c) 1995-2000, Raphael Manfredi
;#
;# You may redistribute only under the terms of the Artistic License,
;# as specified in the README file that comes with the distribution.
;#
;# 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.39/t/tied.pl 000755 000765 000024 00000004434 13071666561 014356 0 ustar 00garu staff 000000 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 only under the terms of the Artistic License,
# as specified in the README file that comes with the distribution.
#
# $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;