Devel::GDB::Reflect - Reflection API for GDB/C++

  use Devel::GDB;
  use Devel::GDB::Reflect;

  my $gdb = new Devel::GDB( -file => $foo );
  my $reflector = new Devel::GDB::Reflect( $gdb );

  print $gdb->get( "b foo.c:123" );
  $gdb->print( "myVariable" );

package Devel::GDB::Reflect;

use warnings;
use strict;

use Devel::GDB::Reflect::GDBGrammar;
use Devel::GDB::Reflect::PrettyPrinter;
use Data::Dumper;
use Devel::GDB;

our $VERSION   = '0.2';
our $MAX_DEPTH = 5;
our $MAX_WIDTH = 10;
our $INDENT    = 4;

sub load_delegates()
{
	my @insts = ();

	my $DELEGATE_NAMESPACE = __PACKAGE__ . "::DelegateProvider";
	(my $DELEGATE_SUBDIR   = $DELEGATE_NAMESPACE) =~ s!::!/!g;

	foreach my $root_dir (@INC)
	{
		my $dir = "$root_dir/$DELEGATE_SUBDIR";

		opendir(DIR, $dir) or next;
		my @delegate_providers = grep { /\.pm$/ && -f "$dir/$_" } readdir(DIR);
		closedir(DIR);

		foreach my $file (@delegate_providers)
		{
			die "Something wrong here: \$file = $file"
				unless $file =~ /^(.+)\.pm$/;

			my $modname = "${DELEGATE_NAMESPACE}::$1";

			require "$dir/$file";
			my $inst = eval "new $modname"
				or do { warn "Can't instantiate $modname; skipping"; next };

			print STDERR " => $modname\n";

			push @insts, $inst;
		}
	}

	return \@insts;
}

sub new($$)
{
	my $class = shift;
	my ($gdb) = @_;

	return bless
		{
			parser             => new Devel::GDB::Reflect::GDBGrammar(),
			gdb                => $gdb,
			class_cache        => {},
			delegate_cache     => {},
			delegate_providers => load_delegates(),
		};
}

sub print($$)
{
	my $self = shift;
	my ($var) = @_;

	$Devel::GDB::Reflect::PrettyPrinter::PAD = " " x $INDENT;
	$self->_print_rec(0, new Devel::GDB::Reflect::PrettyPrinter(), $var);
	print "\n";
}

sub get_completions($$)
{
    my $self = shift;
    my ($line) = @_;

    my ($result, $error) = $self->{gdb}->get("complete $line");
	die "Fatal Error: $error" if $error;

    return split "\n", $result;
}

sub get_member($$$);
sub get_member($$$)
{
	my $self = shift;
	my ($type, $query) = @_;

	if(ref $type ne 'HASH')
	{
		# Someone passed in a variable, not a type
		$type = $self->get_type($type);
	}

	my $class_spec = $self->_get_class($type->{quotename});
	return undef unless $class_spec->{members};

	foreach my $member (@{$class_spec->{members}})
	{
		foreach my $t ('variable', 'function')
		{
			return $member if (defined $member->{$t} and $member->{$t} eq $query);
		}
	}

	if(defined($class_spec->{parent}))
	{
		return $self->get_member($class_spec->{parent}, $query);
	}

	return undef;
}

sub eval($$)
{
	my $self = shift;
	my ($expr) = @_;

	my ($result, $error) = $self->{gdb}->get("output $expr");
	die "Fatal Error: $error" if $error;

	# We're going to assume that it succeeded if $result either starts with an
	# open brace (it's a struct or class of some sort), OR it's is not
	# terminated with a newline (which is how error messages are shown).
	return undef if($result =~ /^[^{].*\n/); return $result; }

sub _print_rec($$$;$)
{
	my $self = shift;
	my ($depth, $pp, $var, $type) = @_;

	my $pp_fh = $pp->{fh};

	#
	# Control for excessive recursion
	#
	if($depth >= $MAX_DEPTH)
	{
		print $pp_fh "{ ... }";
		return;
	}

	#
	# Get the type of $var, unless we're told what it is
	#

    unless(defined $type)
    {
        $type = $self->get_type($var) or return;
    }

	#
	# Find candidate delegates for this type, unless we already have one cached
	#

    unless(defined $self->{delegate_cache}->{$type->{quotename}})
    {
        my @delegates = ();

        foreach my $inst (@{$self->{delegate_providers}})
        {
            push @delegates, $inst->get_delegates($type, $var, $self);
        }

        if(!@delegates)
        {
            print $pp_fh "[No delegate found!]";
            return;
        }

        #
        # Take the highest-priority one
        #

        my $delegate = (sort { $b->{priority} <=> $a->{priority} } @delegates)[0];
        $self->{delegate_cache}->{$type->{quotename}} = $delegate;
    }

    my $delegate = $self->{delegate_cache}->{$type->{quotename}}
        or die "Something wrong here";

	#
	# Now use $delegate to either dump the object as-is, or iterate
	#

	my $pp_child = new Devel::GDB::Reflect::PrettyPrinter( $pp,
														   $delegate->{print_open_brace},
														   $delegate->{print_separator},
														   $delegate->{print_close_brace} );

	my $callback = sub { $self->_print_rec($depth+1, $pp_child, @_) };
    my $printer = $delegate->{factory}->($var);

	if($delegate->{can_iterate})
	{
		for(my $i=0 ; $i<$MAX_WIDTH && $printer->has_next() ; $i++)
		{
			$printer->print_next($callback, $pp_child->{fh});
		}

		my $pp_child_fh = $pp_child->{fh};
		print $pp_child_fh "..." if($printer->has_next());
	}
	else
	{
		$printer->print($callback, $pp_child->{fh});
	}

	$pp_child->finish($delegate->{print_newline});
}

sub _get_class($$)
{
	my $self = shift;
	my ($typename) = @_;

	unless(defined $self->{class_cache}->{$typename})
	{
		my ($result, $error) = $self->{gdb}->get("ptype $typename");
		die "Fatal Error: $error" if $error;

		my $class_spec = $self->{parser}->parse($result);
		unless(defined $class_spec)
		{
			$DB::single = 2;
			print STDERR "Failed parsing type '$typename'!\n";
			return undef;
		}

		$self->{class_cache}->{$typename} = $class_spec;
	}

	return $self->{class_cache}->{$typename};
}

##
## It would be better to use "whatis" here, rather than "ptype", but GDB
## is stupid.  There, I said it. :-)
##
## If $var is of type std::string, "whatis $var" gives "type = string",
## while "ptype $var" gives the full type specification.
##
sub get_type($$)
{
	my $self = shift;
	my ($var) = @_;

	my ($result, $error) = $self->{gdb}->get("ptype $var");
	die "Fatal Error: $error" if $error;

	if($result !~ /^type =/)
	{
		print STDERR $result;
		return undef;
	}

	# Strip off the class definition, if any.  This is ugly, but it avoids
	# expensively parsing the entire class...
	$result =~ s/ : .*//s;
	$result =~ s/{.*//s;

	my $type = $self->{parser}->parse($result);

	unless(defined $type)
	{
		print STDERR "Failed parsing type!\n  Result was: $result\n";
		return undef;
	}

	return $type;
}

1;

__END__

 ============================================================================
 == This is the old grammar, used by Parse::RecDescent.  This was too slow ==
 == for my tastes, so I rewrote the grammar for Parse::Yapp.  This new     ==
 == grammar is in GDBGrammar.{yp,pm}.                                      ==
 ==                                                                        ==
 == Just keeping this here for now, because I am incapable of deleting     ==
 == anything :-)                                                           ==
 ============================================================================

$GRAMMAR = q`
    Start:
        'type' '=' Typedef /\Z/
            { $item[3]; }

    Typedef:
        TypeModifier(s?) ClassDef
      | PCompoundType

    BasicType:
        'void'
      | 'int'
      | 'long'
      | 'float'
      | 'double'
      | 'char'
      | 'size_t'
      | 'ssize_t'

    PCompoundType:
        CompoundType Star(s?)
        {{
            fullname  => join(' ', $item[1]->{fullname}, @{$item[2]}),
            shortname => $item[1]->{shortname},
			quotename => join(' ', @{$item[1]->{decorated}->[0]},
			                       q(') . $item[1]->{decorated}->[1] . q('),
			                       @{$item[1]->{decorated}->[2]},
			                       @{$item[2]}),
        }}

    Star:
        '*'
      | '&'
      | 'const'

    CompoundType:
        TypeModifier CompoundType
        {{
            fullname    => join(' ', $item[1], $item[2]->{fullname}),
            shortname   => $item[2]->{shortname},
			decorated   => [[$item[1], @{$item[2]->{decorated}->[0]}],
			                $item[2]->{decorated}->[1],
			                [@{$item[2]->{decorated}->[2]}]],
        }}
      | BasicType
        {{
            fullname    => $item[1],
            shortname   => $item[1],
			decorated   => [[], $item[1], []],
        }}
      | Type
        {
			$item[1]
		}

    TypeModifier:
        'unsigned'
      | 'long'
      | 'mutable'
      | 'const'
      | 'static'
      | 'const' '*'
            { join ' ', @item[1..$#item] }

    ClassDef:
        'class' Type (':' AccessMod(?) Type)(?) '{' ClassMember(s?) '}'
        {{
            'class'       => $item[2]->{fullname},
            'class_short' => $item[2]->{shortname},
            'parent'      => $item[3][0]->{fullname},
            'members'     => [ grep { ref } @{$item[5]} ],
        }}

    ClassMember:
        AccessMod ':'
            { $return = ""; 1; }
      | FunctionDecl
      | VarDecl

    VarDecl:
        PCompoundType Identifier ';'
        {{
            'variable' => $item[2],
            'type'     => $item[1],
        }}

    FunctionDecl:
        PCompoundType Identifier TemplateSpec(?) '(' PCompoundType(s? /,/) ')' FunctionKeyword(?) ';'
        {{
            'function' => $item[2],
            'type'     => $item[1],
            'params'   => $item[5],
        }}
      | Identifier '(' PCompoundType(s? /,/) ')' ';' # Constructor / Destructor
        {{
            'function' => $item[1],
            'type'     => undef,
            'params'   => $item[3],
        }}

    FunctionKeyword: 'const'

    SpecializedType:
        Identifier TemplateSpec(?)
        {{
            fullname  => $item[1] . $item[2][0],
            shortname => $item[1]
        }}

    Type:
        TypeKeyword(s?) SpecializedType(s /::/)
        {{
            fullname  => join ('::', map { $_->{fullname} } @{$item[2]}),
            shortname => $item[2][$#{$item[2]}]->{shortname},
			decorated => [[], join ('::', map { $_->{fullname} } @{$item[2]}), []],
        }}

    TypeKeyword: 'class' | 'struct'

    TemplateSpec:
        '<' PCompoundType(s? /,/) '>'
        {
            '< ' . join(',', map { $_->{fullname} } @{$item[2]}) . ' >'
        }

    Identifier:
        /operator[<>\[\]=+!-]+/
      | /[A-Za-z_~][A-Za-z0-9_]*/

    AccessMod:
        'private'
      | 'protected'
      | 'public'
`;