Data-Transform-ExplicitMetadata
view release on metacpan or search on metacpan
lib/Data/Transform/ExplicitMetadata.pm view on Meta::CPAN
Tied variables are re-tied by localizing the appropriate TIE* method to return
the tied data. The variable's original data is filled in before calling tie().
The IO slot of typeglobs is recreated by opening the handle with the same
descriptor number and open mode. It will first try fcntl() with F_GETFL
to determine the open mode, falling back to using FileHandle::Fmode if it's
available. Finally, it will first try re-opening the file descriptor in
read mode, then write mode.
Coderefs cannot be decoded properly. They are recreated by returning a
reference to a dummy sub that returns a message explaning the situation.
=back
=head1 SEE ALSO
L<JSON>, L<Sereal>, L<Data::Dumper>, L<FileHandle::Fmode>
=head1 AUTHOR
use File::Temp;
use Test::More tests => 8;
subtest test_scalar => sub {
plan tests => 8;
my $tester = sub {
my($original, $desc) = @_;
my $encoded = encode($original);
is($encoded, $original, "encode $desc");
my $decoded = decode($encoded);
is($decoded, $original, "decode $desc");
};
$tester->(1, 'number');
$tester->('a string', 'string');
$tester->('', 'empty string');
$tester->(undef, 'undef');
};
subtest test_simple_references => sub {
plan tests => 6;
my $expected = {
__value => ref($original) eq 'SCALAR' ? $$original : $original,
__reftype => Scalar::Util::reftype($original),
__refaddr => Scalar::Util::refaddr($original),
};
$expected->{__blesstype} = Scalar::Util::blessed($original) if Scalar::Util::blessed($original);
is_deeply($encoded, $expected, "encode $test");
my $decoded = decode($encoded);
is_deeply($decoded, $original, "decode $test");
}
};
subtest test_filehandle => sub {
plan skip_all => q(Filehandle open mode tests don't work on Windows)
if ($^O =~ m/MSWin/);
plan tests => 5;
encode_filehandle_test_open_mode();
};
my $encoded = encode($original);
my $expected = {
__value => "$original",
__reftype => 'CODE',
__refaddr => Scalar::Util::refaddr($original),
};
is_deeply($encoded, $expected, 'encode coderef');
my $decoded = decode($encoded);
is(ref($decoded), 'CODE', 'decoded to a coderef');
};
subtest test_refref => sub {
plan tests => 2;
my $hash = { };
my $original = \$hash;
my $expected = {
__reftype => 'REF',
__refaddr => Scalar::Util::refaddr($original),
__value => {
__reftype => 'HASH',
__refaddr => Scalar::Util::refaddr($hash),
__value => { }
}
};
my $encoded = encode($original);
is_deeply($encoded, $expected, 'encode ref reference');
my $decoded = decode($encoded);
is_deeply($decoded, $original, 'decode ref reference');
};
subtest test_regex => sub {
plan tests => 3;
my $original = qr(a regex \w)m;
my $expected = {
__reftype => 'REGEXP',
__refaddr => Scalar::Util::refaddr($original),
__value => [ 'a regex \w', 'm' ],
};
my $encoded = encode($original);
is_deeply($encoded, $expected, 'encode regex');
my $decoded = decode($encoded);
is("$decoded", "$original", 'decode regex');
isa_ok($decoded, 'Regexp');
};
subtest test_vstring => sub {
plan tests => 6;
my $original = v1.2.3.4;
my $expected = {
__reftype => 'VSTRING',
__value => [ 1, 2, 3, 4 ],
};
my $encoded = encode($original);
is_deeply($encoded, $expected, 'encode vstring');
my $decoded = decode($encoded);
is($decoded, $original, 'decode vstring');
is(ref(\$decoded),
$^V ge v5.10.0 ? 'VSTRING' : 'SCALAR',
'ref to decoded');
my $vstring = v1.2.3.4;
$original = \$vstring;
$expected->{__refaddr} = Scalar::Util::refaddr($original);
$encoded = encode($original);
is_deeply($encoded, $expected, 'encode vstring ref');
$decoded = decode($encoded);
is($$decoded, $$original, 'decode vstring ref');
is(ref($decoded),
$^V ge v5.10.0 ? 'VSTRING' : 'SCALAR',
'decoded ref');
};
t/blessed.t view on Meta::CPAN
my $expected = {
__refaddr => refaddr($original),
__reftype => 'ARRAY',
__blessed => $bless_package,
__value => [ 1, 2, 3 ],
};
my $encoded = encode($original);
is_deeply($encoded, $expected, 'encode blessed array');
my $decoded = decode($encoded);
is_deeply($decoded, $original, 'decode blessed array');
isa_ok($decoded, $bless_package);
my $open_mode = delete $encoded->{__value}{array}{__value}[3]{__value}{IOmode};
SKIP: {
skip(q(Filehandle open mode tests don't work on Windows), 1) if ($^O =~ m/MSWin/);
ok(($open_mode eq '>') || ($open_mode eq '+<'),
'IO slot open mode');
};
is_deeply($encoded, $expected, 'encode nested data structure');
my $decoded = decode($encoded);
# globs need special inspection
my $original_overloaded_glob = delete($original->{glob});
my $decoded_overloaded_glob = delete($decoded->{glob});
my $original_stdout_glob = splice(@{$original->{array}}, 3, 1);
my $decoded_stdout_glob = splice(@{$decoded->{array}}, 3, 1);
is_deeply($decoded, $original, 'decode nested data structure');
ok(defined(fileno $decoded_stdout_glob), 'decoded stdout glob has fileno');
is(fileno($decoded_stdout_glob), fileno($original_stdout_glob), 'decoded stdout glob has correct fileno');
is(ref(*{$decoded_overloaded_glob}{CODE}), 'CODE', 'overloaded glob code');
is_deeply(*{$decoded_overloaded_glob}{SCALAR}, \$overloaded_glob, 'overloaded glob scalar');
is_deeply(*{$decoded_overloaded_glob}{ARRAY}, \@overloaded_glob, 'overloaded glob array');
is_deeply(*{$decoded_overloaded_glob}{HASH}, \%overloaded_glob, 'overloaded glob hash');
}
sub test_nested_with_duplicate_ref {
my $nested_array = [ 1 ];
my $original = [ $nested_array, $nested_array ];
my $expected = {
__reftype => 'ARRAY',
__refaddr => refaddr($original),
__value => [
{
__reftype => 'ARRAY',
__refaddr => refaddr($nested_array),
__recursive => 1,
__value => '$VAR->[0]',
}
],
};
my $encoded = encode($original);
is_deeply($encoded, $expected, 'encode array with duplicated element refs');
my $decoded = decode($encoded);
is_deeply($decoded, $original, 'decode array with duplicated element refs');
}
t/recursive.t view on Meta::CPAN
__value => '$VAR->[2]',
},
],
},
],
};
my $encoded = encode($original);
is_deeply($encoded, $expected, 'encode recursive data structure');
my $decoded = decode($encoded);
is_deeply($decoded, $original, 'decode recursive data structure');
};
subtest recurse_hash => sub {
my $nested = { bar => 'bar' };
$nested->{nested} = $nested;
my $original = { foo => 'foo', nested => $nested };
my $expected = {
__refaddr => refaddr($original),
__reftype => 'HASH',
t/recursive.t view on Meta::CPAN
__recursive => 1,
__value => '$VAR->{nested}'
}
}
}
}
};
my $encoded = encode($original);
is_deeply($encoded, $expected, 'encode recursive hash');
my $decoded = decode($encoded);
is_deeply($decoded, $original, 'decode recursive hash');
};
subtest recurse_ref1 => sub {
my $a = 1;
my $b = \$a;
my $original = \$b;
$a = \$original;
my $expected = {
__refaddr => refaddr($original),
t/recursive.t view on Meta::CPAN
__reftype => 'REF',
__recursive => 1,
__value => '$VAR',
}
}
}
};
my $encoded = encode($original);
is_deeply($encoded, $expected, 'encode ref reference');
my $decoded = decode($encoded);
is_deeply($decoded, $original, 'decode ref reference');
undef($a); # break the cycle
};
subtest recurse_ref2 => sub {
my $c = 1;
my $b = \$c;
$c = \$b;
my $a = \$b;
my $original = \$a;
t/recursive.t view on Meta::CPAN
__reftype => 'REF',
__recursive => 1,
__value => '${$VAR}',
},
}
}
};
my $encoded = encode($original);
is_deeply($encoded, $expected, 'encode ref, circularity not at root');
my $decoded = decode($encoded);
is_deeply($decoded, $original, 'decode ref, circularity not at root');
undef($a);
};
subtest recurse_glob => sub {
use vars '@typeglob','$typeglob';
@typeglob = (\@typeglob);
my $original = \*typeglob;
t/recursive.t view on Meta::CPAN
SCALAR => {
__refaddr => refaddr(\$typeglob),
__reftype => 'SCALAR',
__value => undef,
},
},
};
my $encoded = encode($original);
is_deeply($encoded, $expected, 'encode glob');
my $decoded = decode($encoded);
is(ref($decoded), 'GLOB', 'decode glob');
my $decoded_array = *{$decoded}{ARRAY};
is_deeply($decoded_array, $decoded_array, 'decoded array from glob');
};
subtest blessed => sub {
my $original = bless [ ], 'BlessedArray';
push @$original, (1, $original);
my $expected = {
__refaddr => refaddr($original),
__reftype => 'ARRAY',
__blessed => 'BlessedArray',
t/recursive.t view on Meta::CPAN
__blessed => 'BlessedArray',
__recursive => 1,
__value => '$VAR',
},
],
};
my $encoded = encode($original);
is_deeply($encoded, $expected, 'encode recursive with blessed item');
my $decoded = decode($encoded);
is_deeply($decoded, $original, 'decode from encoded');
isa_ok($decoded, 'BlessedArray', 'decoded blessed properly');
isa_ok($decoded->[1], 'BlessedArray', 'recursed decoded blessed properly');
};
__value => {
__reftype => 'ARRAY',
__refaddr => refaddr(tied $original),
__blessed => 'Data::Transform::ExplicitMetadata::TiedScalar',
__value => [ $tied_value ],
}
};
my $encoded = encode(\$original);
is_deeply($encoded, $expected, 'encode tied scalar');
my $decoded = decode($encoded);
is($$decoded, $tied_value, 'decode tied scalar')
}
sub test_tied_array {
my @original = ( 'an','array');
my $tied_value = 'haha';
tie @original, 'Data::Transform::ExplicitMetadata::TiedArray', $tied_value;
my $expected = {
__reftype => 'ARRAY',
__refaddr => refaddr(\@original),
__tied => [ 'an', 'array' ],
__value => {
__reftype => 'SCALAR',
__refaddr => refaddr(tied @original),
__blessed => 'Data::Transform::ExplicitMetadata::TiedArray',
__value => $tied_value,
}
};
my $encoded = encode(\@original);
is_deeply($encoded, $expected, 'encode tied array');
my $decoded = decode($encoded);
is($decoded->[2], $tied_value, 'decode tied array');
}
sub test_tied_hash {
my %original = ( one => 1 );
my $tied_value = 'secret';
tie %original, 'Data::Transform::ExplicitMetadata::TiedHash', $tied_value;
my $expected = {
__reftype => 'HASH',
__refaddr => refaddr(\%original),
__tied => { one => 1 },
__value => {
__reftype => 'SCALAR',
__refaddr => refaddr(tied %original),
__blessed => 'Data::Transform::ExplicitMetadata::TiedHash',
__value => $tied_value,
}
};
my $encoded = encode(\%original);
is_deeply($encoded, $expected, 'encode tied hash');
my $decoded = decode($encoded);
is($decoded->{foo}, $tied_value, 'decode tied hash');
}
sub test_tied_handle {
open(my $original, __FILE__);
my $tied_value = 'secret';
my $fileno = fileno($original);
tie *$original, 'Data::Transform::ExplicitMetadata::TiedHandle', $tied_value;
my $expected = {
__reftype => 'GLOB',
__refaddr => refaddr($original),
};
my $encoded = encode($original);
ok(delete($encoded->{__tied}->{SCALAR}->{__refaddr}), 'tied original glob scalar has refaddr');
if ($^O =~ m/MSWin/) {
# FMode doesn't work on Windows
delete $_->{__tied}->{IOmode} foreach ($encoded, $expected);
}
is_deeply($encoded, $expected, 'encode tied handle');
my $decoded = decode($encoded);
is(scalar(<$decoded>), $tied_value, 'decode tied handle');
}
package Data::Transform::ExplicitMetadata::TiedScalar;
sub TIESCALAR {
my $class = shift;
my @self = @_;
return bless \@self, __PACKAGE__;
}
( run in 0.312 second using v1.01-cache-2.11-cpan-26ccb49234f )