Skip to content

Commit

Permalink
Camelcade/Perl5-IDEA#2839 Added test for object descriptor creation
Browse files Browse the repository at this point in the history
The issue is how we serialize lexical variables. I presume same goes for the global variables.
`peek` methods providing us with hash `name => reference_to_variable`, not the `name => variable`, so we need to skip one level here.
  • Loading branch information
hurricup committed Mar 30, 2024
1 parent 714a812 commit c6a6c28
Show file tree
Hide file tree
Showing 3 changed files with 230 additions and 45 deletions.
78 changes: 34 additions & 44 deletions lib/Devel/Camelcadedb.pm
Original file line number Diff line number Diff line change
Expand Up @@ -398,83 +398,68 @@ sub _get_file_source_handler
);
}

sub _get_reference_subelements
{
my ($request_serialized_object) = @_;
my $transaction_wrapper = _deserialize( $request_serialized_object );
my ($transaction_id, $request_object) = @$transaction_wrapper{qw/id data/};
sub _compute_reference_subelements {
my $request_object = shift;

my ($offset, $size, $key) = @$request_object{qw/offset limit key/};
my $data = [ ];
my $data = [];

my $source_data;

if ($key =~ /^\*(.+?)(?:\{($glob_slots)\})?$/) # hack for globs by names
{
no strict 'refs';
my ( $name, $slot) = ($1, $2);
my ($name, $slot) = ($1, $2);

if ($slot)
{
if ($slot) {
$source_data = *{$name}{$slot};
}
else
{
else {
$source_data = \*{$name};
}

_report "Got glob ref $key => $source_data" if $_dev_mode;
}
else
{
else {
$source_data = $_references_cache{$key};
}
if ($source_data)
{
my $reftype = Scalar::Util::reftype( $source_data );
if ($source_data) {
my $reftype = Scalar::Util::reftype($source_data);

if ($reftype eq 'ARRAY' && $#$source_data >= $offset)
{
if ($reftype eq 'ARRAY' && $#$source_data >= $offset) {
my $last_index = $offset + $size;

for (my $item_number = $offset; $item_number < $last_index && $item_number < @$source_data; $item_number++)
{
push @$data, _get_reference_descriptor( "[$item_number]", \$source_data->[$item_number] );
for (my $item_number = $offset; $item_number < $last_index && $item_number < @$source_data; $item_number++) {
push @$data, _get_reference_descriptor("[$item_number]", \$source_data->[$item_number]);
}
}
elsif ($reftype eq 'HASH')
{
my $hash_iterator = Hash::StoredIterator::hash_get_iterator( $source_data );
elsif ($reftype eq 'HASH') {
my $hash_iterator = Hash::StoredIterator::hash_get_iterator($source_data);
my @keys = sort keys %$source_data;
Hash::StoredIterator::hash_set_iterator( $source_data, $hash_iterator );
Hash::StoredIterator::hash_set_iterator($source_data, $hash_iterator);

if ($#keys >= $offset)
{
if ($#keys >= $offset) {
my $last_index = $offset + $size;

for (my $item_number = $offset; $item_number < $last_index && $item_number < @keys; $item_number++)
{
for (my $item_number = $offset; $item_number < $last_index && $item_number < @keys; $item_number++) {
my $hash_key = $keys[$item_number];
push @$data, _get_reference_descriptor( "'$hash_key'", \$source_data->{$hash_key} );
push @$data, _get_reference_descriptor("'$hash_key'", \$source_data->{$hash_key});
}
}
}
elsif ($reftype eq 'REF')
{
elsif ($reftype eq 'REF') {
push @$data, _get_reference_descriptor($source_data, $$source_data);
}
elsif ($reftype eq 'GLOB')
{
elsif ($reftype eq 'GLOB') {
no strict 'refs';

foreach my $glob_slot (@glob_slots)
{
foreach my $glob_slot (@glob_slots) {
my $reference = *$source_data{$glob_slot};
next unless $reference;
my $desciptor = _get_reference_descriptor( $glob_slot, \$reference );
my $desciptor = _get_reference_descriptor($glob_slot, \$reference);

# hack for DB namespace, see https://github.com/hurricup/Perl5-IDEA/issues/1151
if ($glob_slot eq 'HASH' && $key =~ /^\*(::)*(main::)*(::)*DB(::)?$/)
{
if ($glob_slot eq 'HASH' && $key =~ /^\*(::)*(main::)*(::)*DB(::)?$/) {
$desciptor->{expandable} = \0;
$desciptor->{size} = 0;
}
Expand All @@ -483,18 +468,23 @@ sub _get_reference_subelements
}

}
else
{
else {
_report "Dont know how to iterate $reftype" if $_dev_mode;
}

}
else
{
else {
_report "No source data for $key\n" if $_dev_mode;
}
return $data;
}

_send_transaction_response( $transaction_id, $data );
sub _get_reference_subelements
{
my ($request_serialized_object) = @_;
my $transaction_wrapper = _deserialize( $request_serialized_object );
my ($transaction_id, $request_object) = @$transaction_wrapper{qw/id data/};
_send_transaction_response($transaction_id, _compute_reference_subelements($request_object));
}

sub _format_variables_hash
Expand Down
70 changes: 69 additions & 1 deletion t/reference_descriptor_serializer.t
Original file line number Diff line number Diff line change
Expand Up @@ -4,13 +4,48 @@ use strict;
use warnings;
use Test::More;
use Data::Dumper;
$Data::Dumper::Sortkeys = \1;
$Data::Dumper::Deepcopy = \1;

subtest "Cyclic reference" => sub{
my $OVERWRITE_RESULTS = 0;

sub check_results_with_file {
my $test_name = shift;
my $result = shift;

$result =~ s/(^\s+|\r|\s+$)//gsi;
$result =~ s/^##teamcity/teamcity/gm;
$result =~ s/(HASH|REF|SCALAR|ARRAY)\(0x[a-f0-9]+\)/$1(...)/gs;
if ($^O eq 'MSWin32') {
$result =~ s{\\}{/}gs;
}
my $result_file_path = "testData/results/$test_name.txt";
if (!$OVERWRITE_RESULTS && -f $result_file_path) {
open my $if, $result_file_path || fail("Error creating output file: $result_file_path, $!");
my $expected = join '', <$if>;
close $if;
$expected =~ s/(^\s+|\s+$)//gsi;
is($result, $expected, $test_name);
}
else {
open my $of, ">$result_file_path" || fail("Error creating output file: $result_file_path, $!");
print $of $result;
close $of;
fail($test_name);
print STDERR "Output file is missing. Created a $result_file_path\n";
}
}

sub setup_debugger {
$ENV{PERL5_DEBUG_AUTOSTART} = 0;
$ENV{PERL5_DEBUG_ROLE} = 'server';
$ENV{PERL5_DEBUG_HOST} = 'localhost';
$ENV{PERL5_DEBUG_PORT} = 42;
require Devel::Camelcadedb;
}

subtest "Cyclic reference" => sub {
setup_debugger();

my $reference = 'test';
my $reference2 = \$reference;
Expand All @@ -20,4 +55,37 @@ subtest "Cyclic reference" => sub{
pass();
};

subtest "Object Descriptor" => sub {
setup_debugger();

my $something = bless { foo => 42 }, 'Foo::Bar';
my $scalar = 42;
my @array = (42);
my %hash = (key => 42);
my $scalar_ref = \$scalar;
my $array_ref = \@array;
my $hash_ref = \%hash;

use PadWalker qw/peek_my/;
my $my_variables = peek_my(0);
my $my_variables_descriptor = DB::_format_variables_hash($my_variables);

my $result = "Object: \n" . Dumper($something) . "\n";

my $descriptor = DB::_get_reference_descriptor("something", $something);
$result .= "\nDescriptor: \n" . Dumper($descriptor) . "\n";

$result .= "\nMy variables descriptor: \n" . Dumper($my_variables_descriptor) . "\n";

ok($descriptor->{'expandable'}, "Object descriptor is expandable");
my $subelements = DB::_compute_reference_subelements({
offset => 0,
limit => 100,
key => $descriptor->{key}
});
$result .= "\nSubelements:\n" . Dumper($subelements);

check_results_with_file("object_descriptor", $result);
};

done_testing();
127 changes: 127 additions & 0 deletions testData/results/object_descriptor.txt
Original file line number Diff line number Diff line change
@@ -0,0 +1,127 @@
Object:
$VAR1 = bless( {
'foo' => 42
}, 'Foo::Bar' );


Descriptor:
$VAR1 = {
'blessed' => \1,
'expandable' => \1,
'is_utf' => \0,
'key' => 'Foo::Bar=HASH(...)',
'name' => 'something',
'ref_depth' => 0,
'size' => 1,
'type' => 'Foo::Bar=HASH(...)',
'value' => 'size = 1'
};


My variables descriptor:
$VAR1 = [
{
'blessed' => \0,
'expandable' => \0,
'is_utf' => \0,
'key' => 'SCALAR(...)',
'name' => '$OVERWRITE_RESULTS',
'ref_depth' => 0,
'size' => 0,
'type' => 'SCALAR(...)',
'value' => '"0"'
},
{
'blessed' => \0,
'expandable' => \1,
'is_utf' => \0,
'key' => 'REF(...)',
'name' => '$array_ref',
'ref_depth' => 1,
'size' => 1,
'type' => 'ARRAY(...)',
'value' => 'REF(...)'
},
{
'blessed' => \0,
'expandable' => \1,
'is_utf' => \0,
'key' => 'REF(...)',
'name' => '$hash_ref',
'ref_depth' => 1,
'size' => 1,
'type' => 'HASH(...)',
'value' => 'REF(...)'
},
{
'blessed' => \0,
'expandable' => \0,
'is_utf' => \0,
'key' => 'SCALAR(...)',
'name' => '$scalar',
'ref_depth' => 0,
'size' => 0,
'type' => 'SCALAR(...)',
'value' => '"42"'
},
{
'blessed' => \0,
'expandable' => \1,
'is_utf' => \0,
'key' => 'REF(...)',
'name' => '$scalar_ref',
'ref_depth' => 1,
'size' => 1,
'type' => 'SCALAR(...)',
'value' => 'REF(...)'
},
{
'blessed' => \0,
'expandable' => \1,
'is_utf' => \0,
'key' => 'REF(...)',
'name' => '$something',
'ref_depth' => 1,
'size' => 1,
'type' => 'Foo::Bar=HASH(...)',
'value' => 'REF(...)'
},
{
'blessed' => \0,
'expandable' => \1,
'is_utf' => \0,
'key' => 'HASH(...)',
'name' => '%hash',
'ref_depth' => 0,
'size' => 1,
'type' => 'HASH(...)',
'value' => 'size = 1'
},
{
'blessed' => \0,
'expandable' => \1,
'is_utf' => \0,
'key' => 'ARRAY(...)',
'name' => '@array',
'ref_depth' => 0,
'size' => 1,
'type' => 'ARRAY(...)',
'value' => 'size = 1'
}
];


Subelements:
$VAR1 = [
{
'blessed' => \0,
'expandable' => \0,
'is_utf' => \0,
'key' => 'SCALAR(...)',
'name' => '\'foo\'',
'ref_depth' => 0,
'size' => 0,
'type' => 'SCALAR(...)',
'value' => '"42"'
}
];

0 comments on commit c6a6c28

Please sign in to comment.