/usr/local/CPAN/Devel-GDB-Reflect/Devel/GDB/Reflect/DelegateProvider/STL.pm
package Devel::GDB::Reflect::DelegateProvider::STL;
use warnings;
use strict;
use Devel::GDB::Reflect::MessageMethod qw( anon );
sub new($)
{
my $class = shift;
return bless {};
}
sub get_delegates($$$$)
{
my $self = shift;
my ($type, $var, $reflector) = @_;
my @delegates = ();
if(my $inst = _get_string_delegate($type, $var, $reflector))
{
push @delegates, $inst;
}
if(my $inst = _get_pair_delegate($type, $var, $reflector))
{
push @delegates, $inst;
}
if(my $inst = _get_vector_delegate($type, $var, $reflector))
{
push @delegates, $inst;
}
if(my $inst = _get_tree_delegate($type, $var, $reflector))
{
push @delegates, $inst;
}
return @delegates;
}
sub _get_string_delegate($$$)
{
my ($i_type, $i_var, $reflector) = @_;
my ($basetype, $expr);
# Dock the priority if this doesn't appear to be a string
my $priority = ($i_type->{shortname} eq 'string' or $i_type->{shortname} eq 'basic_string') ? 0 : -10;
# GCC 3.4.4 / GCC 4.1.1
if( defined( $reflector->get_member($i_type, '_M_dataplus') ) &&
defined( my $basemember = $reflector->get_member("($i_var)._M_dataplus", '_M_p') ))
{
$expr = '"($var)._M_dataplus._M_p"';
$basetype = $basemember->{type};
}
# STLport 5.0.1 with _STLP_DONT_USE_SHORT_STRING_OPTIM
elsif( defined( $basemember = $reflector->get_member($i_type, '_M_start') ))
{
$expr = '"($var)._M_start"';
$basetype = $basemember->{type};
}
# STLport 5.0.1 with _STLP_USE_SHORT_STRING_OPTIM
elsif( defined( $reflector->get_member($i_type, '_M_buffers') ) &&
defined( $reflector->get_member($i_type, '_M_end_of_storage') ) &&
defined( $reflector->get_member("($i_var)._M_buffers", '_M_static_buf') ) &&
defined( $basemember = $reflector->get_member("($i_var)._M_buffers", '_M_dynamic_buf') ) &&
defined( $reflector->get_member("($i_var)._M_end_of_storage", '_M_data') ))
{
$expr = '"(($var)._M_buffers._M_static_buf + sizeof(($var)._M_buffers._M_static_buf) == ($var)._M_end_of_storage._M_data) ? (($basetype->{quotename}) ($var)._M_buffers._M_static_buf) : ($var)._M_buffers._M_dynamic_buf"';
$basetype = $basemember->{type};
}
else
{
return undef;
}
return
{
print_open_brace => "",
print_close_brace => "",
print_separator => "",
can_iterate => 0,
priority => $priority,
factory => sub
{
my ($var) = @_;
# Is this a bug in perl? If eval($expr) references a variable that
# hasn't been accessed before in this scope (e.g. $basetype), it's
# undefined in the scope of the eval().
my $junk = $basetype;
my $expr = eval($expr);
return anon
{
print => sub
{
my ($callback, $fh) = @_;
return $callback->($expr, $basetype);
}
}
}
}
}
sub _get_pair_delegate($$$)
{
my ($i_type, $i_var, $reflector) = @_;
unless($i_type->{shortname} eq 'pair')
{
return undef;
}
unless( defined( $reflector->get_member($i_type, 'first') ) &&
defined( $reflector->get_member($i_type, 'second') ))
{
return undef;
}
return
{
can_iterate => 0,
priority => 0,
print_open_brace => "",
print_close_brace => "",
print_separator => "=>",
factory => sub
{
my ($var) = @_;
return anon
{
print => sub
{
my ($callback, $fh) = @_;
$callback->("($var).first");
$callback->("($var).second");
}
}
}
}
}
sub _get_vector_delegate($$$)
{
my ($i_type, $i_var, $reflector) = @_;
my ($basetype, $impl);
unless($i_type->{shortname} eq 'vector')
{
return undef;
}
$impl = defined( $reflector->get_member($i_type, '_M_impl') ) ? '._M_impl' : '';
unless( defined( $reflector->get_member("($i_var)$impl", '_M_start') ) &&
defined( $reflector->get_member("($i_var)$impl", '_M_finish') ) &&
defined( $basetype = $reflector->get_type("(*(($i_var)$impl._M_start))") ))
{
return undef;
}
return
{
print_newline => 1,
priority => 0,
can_iterate => 1,
factory => sub
{
my ($var) = @_;
my ($begin_addr, $end_addr, $increment);
unless( defined( $begin_addr = $reflector->eval("(unsigned long) ($var)$impl._M_start") ) &&
defined( $end_addr = $reflector->eval("(unsigned long) ($var)$impl._M_finish") ) &&
defined( $increment = $reflector->eval("sizeof(*($var)$impl._M_start)") ))
{
die "Internal error";
}
my $cur_addr = $begin_addr;
my $last_newline;
return anon
{
has_next => sub
{
return $cur_addr < $end_addr;
},
print_next => sub
{
my ($callback, $fh) = @_;
$callback->("*(($basetype->{quotename} *) $cur_addr)", $basetype);
$cur_addr += $increment;
},
}
}
}
}
sub _get_tree_delegate($$$)
{
my ($i_type, $i_var, $reflector) = @_;
my ($nodetype, $basetype, $begin_expr, $end_expr);
# Dock the priority if we're not dealing with an STL set or map
my $priority = ($i_type->{shortname} eq 'set' or $i_type->{shortname} eq 'map') ? 0 : -10;
# GCC 3.4.4 / GCC 4.1.1
if( defined( $reflector->eval( "($i_var)._M_t._M_impl._M_header._M_left") ) &&
defined( my $nodemember = $reflector->get_member("($i_var)._M_t", "_M_get_node") ))
{
$nodetype = $nodemember->{type}->{quotename};
$begin_expr = '_M_impl._M_header._M_left';
$end_expr = '_M_impl._M_header';
}
# STLport 5.0.1
elsif( defined( $reflector->eval( "($i_var)._M_t._M_header._M_data._M_left") ) &&
defined( my $treemember = $reflector->get_member($i_type, "_M_t") ))
{
# Make a huge leap of faith here and assume that (a) the third template
# parameter to _M_t is the _Value type; and (b) the correct value for
# $nodetype is NAMESPACE::_Rb_tree_node<_Value>
my $value_t = $treemember->{type}->{template}->[2]
or return undef;
$treemember->{type}->{fullname} =~ /^((?:[A-Za-z0-9_]+::)*)_Rb_tree\b/
or return undef;
my $namespace = $1;
$nodetype = "'${namespace}_Rb_tree_node< $value_t >' *";
$begin_expr = '_M_header._M_data._M_left';
$end_expr = '_M_header';
}
else
{
return undef;
}
unless( defined( $basetype = $reflector->get_type("(($nodetype *) 0)->_M_value_field") ))
{
return undef;
}
return
{
print_open_brace => "{",
print_close_brace => "}",
print_newline => 1,
can_iterate => 1,
priority => $priority,
factory => sub
{
my ($var) = @_;
my ($begin_addr, $end_addr);
unless( defined( $begin_addr = $reflector->eval("(unsigned long) ($var)._M_t.$begin_expr") ) &&
defined( $end_addr = $reflector->eval("(unsigned long) &($var)._M_t.$end_expr") ))
{
die "Internal error";
}
my $cur_addr = $begin_addr;
my $last_newline;
return anon
{
has_next => sub
{
return $cur_addr != $end_addr;
},
print_next => sub
{
my ($callback, $fh) = @_;
$callback->("(($nodetype) $cur_addr)->_M_value_field", $basetype);
$cur_addr = _Rb_tree_increment($reflector, $cur_addr, $nodetype);
},
}
}
}
}
##
## Advance the iterator as in _Rb_tree_increment()
## (It would be nice to walk the tree recursively instead...)
##
sub _Rb_tree_increment($$$)
{
my ($reflector, $__x, $nodetype) = @_;
my $_M_right = $reflector->eval("(unsigned long) (($nodetype) $__x)->_M_right");
die "Something wrong here!" unless defined($_M_right);
if($_M_right)
{
$__x = $_M_right;
my $_M_left;
while($_M_left = $reflector->eval("(unsigned long) (($nodetype) $__x)->_M_left"))
{
$__x = $_M_left;
}
die "Something wrong here!" unless defined($_M_left);
}
else
{
my $__y = $reflector->eval("(unsigned long) (($nodetype) $__x)->_M_parent")
or die "Something wrong here!";
while($__x == $reflector->eval("(unsigned long) (($nodetype) $__y)->_M_right"))
{
$__x = $__y;
$__y = $reflector->eval("(unsigned long) (($nodetype) $__y)->_M_parent")
or die "Something wrong here!";
}
$_M_right = $reflector->eval("(unsigned long) (($nodetype) $__x)->_M_right");
die "Something wrong here" unless defined($_M_right);
if($_M_right != $__y)
{
$__x = $__y;
}
}
return $__x;
}
1;