Last active
March 9, 2022 14:09
-
-
Save HaraldJoerg/1108155847ab48a1c115a8054e878d5a to your computer and use it in GitHub Desktop.
Extend the Perl debugger to display Object::Pad objects
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
package dumpvar; | |
=encoding utf8 | |
=head1 NAME | |
Devel::opaddb.pm - Display Object::Pad objects in Perl's debugger | |
=head1 SYNOPSIS | |
perl -d:opaddb your/program.pl | |
=head1 DESCRIPTION | |
This module enhances Perl's builtin debugger's ability to display | |
L<Object::Pad|https://metacpan.org/pod/Object::Pad> objects. It shows the name of the fields, base classes | |
and roles in addition to their values. | |
=head2 NORMAL USE | |
Drop this file in a directory within your C<@INC> path in a directory | |
F<Devel>, so that Perl can find it as module C<Devel::opaddb>. Then | |
start the debugger by enabling this module as debugger: | |
perl -d:opaddb your/program.pl | |
=head2 PURPOSE | |
As much as L<Object::Pad> is being used as a testbed for | |
L<Corinna|https://github.com/Ovid/Cor>, this module might serve as a | |
testbed for what we might want to expect from the Perl debugger when | |
Corinna objects are in the wild. | |
It is the author's belief that the missing support for debugging, | |
either with the Perl debugger or with L<Data::Dumper> and friends, is | |
a major obstacle for the adoption of OO frameworks like L<Class::Std>. | |
Their "inside out" objects provide nice encapsulation, but also | |
difficult bug hunting. | |
=head1 EXAMPLE | |
Here's an output comparison for a simple object. | |
Perl's builtin debugger: | |
DB<1> x $sphere | |
0 Sphere=ARRAY(0x565204bbfd28) | |
0 Point=HASH(0x565204a90bc8) | |
'Object::Pad/fields' => ARRAY(0x565204bbfcb0) | |
0 ARRAY(0x565204bbfbf0) | |
0 '-1' | |
1 '-2' | |
2 '-3' | |
1 'Center' | |
1 4 | |
2 'BLACK' | |
Devel::opaddb debugger: | |
DB<1> x $sphere | |
0 Sphere=ARRAY(0x55724f5e5da0) | |
-> Object::Pad object with 2 field(s): | |
field $center = Point=HASH(0x55724f4b1588) | |
-> Object::Pad object with 1 field(s): | |
field $name = 'Center' | |
-> extends Vector with 1 field(s): | |
field @coords = ARRAY(0x55724f5e5cc8) | |
0 '-1' | |
1 '-2' | |
2 '-3' | |
field $radius = 4 | |
-> consumes: | |
role Pigment with 1 field(s): | |
field $color = 'BLACK' | |
=head1 CAVEATS | |
L<Object::Pad> is an experimental module and still evolving, and this | |
debugger is even more experimental and tries to catch up. | |
=head1 BUGS | |
=over 4 | |
=item * There's no debugger interface to access an indivdual field by | |
its name. | |
=item * There's no proper indentation for nested objects. | |
=back | |
=head1 RESTRICTIONS | |
This module doesn't play well with other debugger extensions which | |
change the format of the debugger output. It overrides changes made | |
in F<.perldb>. | |
L<Object::Pad> needs to be version 0.52 or better if objects consume | |
roles which have their own field(s) - ([rt.cpan.org #138927]). | |
=head1 NOTES | |
This is a hack. The Perl debugger isn't very invitating for | |
extensions, and the author didn't spend much time to write a complete | |
Perl debugger. It works by overriding the function C<dumpvar::unwrap> | |
which is provided by Perl's F<dumpvar.pl>. The function in this | |
module is almost a verbatim copy. Two short chunks have been added to | |
call new routines which handle Object::Pad objects in C<NATIVE> and | |
C<HASH> representation. | |
=head1 AUTHOR | |
Harald Jörg, <haj@posteo.de> | |
=head1 COPYRIGHT AND LICENSE | |
COPYRIGHT 2021-2022 Harald Jörg | |
This library is free software; you may redistribute it and/or | |
modify it under the same terms as Perl itself. | |
=cut | |
# We apologize for that, but the debugger uses a lot of variables | |
# which might- or not - be provided by the user. | |
no warnings; | |
# Load the original debugger, and also immediately load dumpvar.pl. | |
# We want our function to override dumpvar.pl's, and not vice versa. | |
require 'perl5db.pl'; | |
require 'dumpvar.pl'; | |
package dumpvar; | |
# unwrap_object: | |
sub unwrap_object { | |
my ($v) = @_; | |
require Object::Pad::MOP::Class; # | |
my $class = Object::Pad::MOP::Class->for_class(ref $v); | |
unwrap_opad_object($v,$class); | |
} | |
sub unwrap_opad_object { | |
my ($v,$class) = @_; | |
print "${sp} -> Object::Pad object"; | |
unwrap_object_fields($v,$class); | |
unwrap_object_roles($v,$class); | |
my @parents = $class->superclasses; | |
if (@parents) { | |
for my $parent (@parents) { | |
print "$sp -> extends ", $parent->name; | |
unwrap_opad_object($v,$parent); | |
} | |
} | |
} | |
sub unwrap_object_fields { | |
my ($object,$class) = @_; | |
my @fields = $class->fields; | |
if (@fields) { | |
print " with ", scalar @fields, " field(s):\n"; | |
for my $field(@fields) { | |
print "$sp field ",$field->name, " = "; | |
DumpElem($field->value($object), $s, $m-1), | |
} | |
} | |
else { | |
print " without fields\n"; | |
} | |
} | |
sub unwrap_object_roles { | |
my ($object,$class) = @_; | |
my @roles = $class->roles; | |
if (@roles) { | |
print "$sp -> consumes:\n"; | |
for my $role(@roles) { | |
print "$sp role ", $role->name; | |
unwrap_object_fields($object,$role); | |
} | |
} | |
} | |
sub DumpElem; # unwrap calls this sub without params, so predeclare it | |
# The following is an almost verbatim copy of &dumpvar::unwrap, as | |
# available from dumpvar.pl in the Perl core. Two blocks have been | |
# inserted here, marked like this: | |
# # *** begin support of Object::Pad objects | |
# ... inserted code here | |
# # *** end support of Object::Pad objects | |
no warnings 'redefine'; | |
*dumpvar::unwrap = sub { | |
return if $DB::signal; | |
local($v) = shift ; | |
local($s) = shift ; # extra no of spaces | |
local($m) = shift ; # maximum recursion depth | |
return if $m == 0; | |
local(%v,@v,$sp,$value,$key,@sortKeys,$more,$shortmore,$short) ; | |
local($tHashDepth,$tArrayDepth) ; | |
$sp = " " x $s ; | |
$s += 3 ; | |
eval { | |
# Check for reused addresses | |
if (ref $v) { | |
my $val = $v; | |
$val = &{'overload::StrVal'}($v) | |
if %overload:: and defined &{'overload::StrVal'}; | |
# Match type and address. | |
# Unblessed references will look like TYPE(0x...) | |
# Blessed references will look like Class=TYPE(0x...) | |
$val =~ s/^.*=//; # suppress the Class part, just keep TYPE(0x...) | |
($item_type, $address) = | |
$val =~ /([^\(]+) # Keep stuff that's | |
# not an open paren | |
\( # Skip open paren | |
(0x[0-9a-f]+) # Save the address | |
\) # Skip close paren | |
$/x; # Should be at end now | |
if (!$dumpReused && defined $address) { | |
$address{$address}++ ; | |
if ( $address{$address} > 1 ) { | |
print "${sp}-> REUSED_ADDRESS\n" ; | |
return ; | |
} | |
} | |
} elsif (ref \$v eq 'GLOB') { | |
# This is a raw glob. Special handling for that. | |
$address = "$v" . ""; # To avoid a bug with globs | |
$address{$address}++ ; | |
if ( $address{$address} > 1 ) { | |
print "${sp}*DUMPED_GLOB*\n" ; | |
return ; | |
} | |
} | |
if (ref $v eq 'Regexp') { | |
# Reformat the regexp to look the standard way. | |
my $re = "$v"; | |
$re =~ s,/,\\/,g; | |
print "$sp-> qr/$re/\n"; | |
return; | |
} | |
# *** begin support of Object::Pad objects | |
if ( $item_type eq 'HASH' && | |
UNIVERSAL::isa($v,'Object::Pad::UNIVERSAL') ) { | |
&unwrap_object($v); | |
} | |
# *** end support of Object::Pad objects | |
elsif ( $item_type eq 'HASH' ) { | |
# Hash ref or hash-based object. | |
my @sortKeys = sort keys(%$v) ; | |
undef $more ; | |
$tHashDepth = $#sortKeys ; | |
$tHashDepth = $#sortKeys < $hashDepth-1 ? $#sortKeys : $hashDepth-1 | |
unless $hashDepth eq '' ; | |
$more = "....\n" if $tHashDepth < $#sortKeys ; | |
$shortmore = ""; | |
$shortmore = ", ..." if $tHashDepth < $#sortKeys ; | |
$#sortKeys = $tHashDepth ; | |
if ($compactDump && !grep(ref $_, values %{$v})) { | |
#$short = $sp . | |
# (join ', ', | |
# Next row core dumps during require from DB on 5.000, even with map {"_"} | |
# map {&stringify($_) . " => " . &stringify($v->{$_})} | |
# @sortKeys) . "'$shortmore"; | |
$short = $sp; | |
my @keys; | |
for (@sortKeys) { | |
push @keys, &stringify($_) . " => " . &stringify($v->{$_}); | |
} | |
$short .= join ', ', @keys; | |
$short .= $shortmore; | |
(print "$short\n"), return if length $short <= $compactDump; | |
} | |
for $key (@sortKeys) { | |
return if $DB::signal; | |
$value = $ {$v}{$key} ; | |
print "$sp", &stringify($key), " => "; | |
DumpElem $value, $s, $m-1; | |
} | |
print "$sp empty hash\n" unless @sortKeys; | |
print "$sp$more" if defined $more ; | |
} | |
# *** begin support of Object::Pad objects | |
elsif ( $item_type eq 'ARRAY' && | |
UNIVERSAL::isa($v,'Object::Pad::UNIVERSAL') ) { | |
&unwrap_object($v); | |
} | |
# *** end support of Object::Pad objects | |
elsif ( $item_type eq 'ARRAY' ) { | |
# Array ref or array-based object. Also: undef. | |
# See how big the array is. | |
$tArrayDepth = $#{$v} ; | |
undef $more ; | |
# Bigger than the max? | |
$tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1 | |
if defined $arrayDepth && $arrayDepth ne ''; | |
# Yep. Don't show it all. | |
$more = "....\n" if $tArrayDepth < $#{$v} ; | |
$shortmore = ""; | |
$shortmore = " ..." if $tArrayDepth < $#{$v} ; | |
if ($compactDump && !grep(ref $_, @{$v})) { | |
if ($#$v >= 0) { | |
$short = $sp . "0..$#{$v} " . | |
join(" ", | |
map {exists $v->[$_] ? stringify $v->[$_] : "empty"} (0..$tArrayDepth) | |
) . "$shortmore"; | |
} else { | |
$short = $sp . "empty array"; | |
} | |
(print "$short\n"), return if length $short <= $compactDump; | |
} | |
#if ($compactDump && $short = ShortArray($v)) { | |
# print "$short\n"; | |
# return; | |
#} | |
for $num (0 .. $tArrayDepth) { | |
return if $DB::signal; | |
print "$sp$num "; | |
if (exists $v->[$num]) { | |
if (defined $v->[$num]) { | |
DumpElem $v->[$num], $s, $m-1; | |
} | |
else { | |
print "undef\n"; | |
} | |
} else { | |
print "empty field\n"; | |
} | |
} | |
print "$sp empty array\n" unless @$v; | |
print "$sp$more" if defined $more ; | |
} elsif ( $item_type eq 'SCALAR' ) { | |
unless (defined $$v) { | |
print "$sp-> undef\n"; | |
return; | |
} | |
print "$sp-> "; | |
DumpElem $$v, $s, $m-1; | |
} elsif ( $item_type eq 'REF' ) { | |
print "$sp-> $$v\n"; | |
return unless defined $$v; | |
unwrap($$v, $s+3, $m-1); | |
} elsif ( $item_type eq 'CODE' ) { | |
# Code object or reference. | |
print "$sp-> "; | |
dumpsub (0, $v); | |
} elsif ( $item_type eq 'GLOB' ) { | |
# Glob object or reference. | |
print "$sp-> ",&stringify($$v,1),"\n"; | |
if ($globPrint) { | |
$s += 3; | |
dumpglob($s, "{$$v}", $$v, 1, $m-1); | |
} elsif (defined ($fileno = eval {fileno($v)})) { | |
print( (' ' x ($s+3)) . "FileHandle({$$v}) => fileno($fileno)\n" ); | |
} | |
} elsif (ref \$v eq 'GLOB') { | |
# Raw glob (again?) | |
if ($globPrint) { | |
dumpglob($s, "{$v}", $v, 1, $m-1) if $globPrint; | |
} elsif (defined ($fileno = eval {fileno(\$v)})) { | |
print( (' ' x $s) . "FileHandle({$v}) => fileno($fileno)\n" ); | |
} | |
} | |
}; | |
if ($@) { | |
print( (' ' x $s) . "<< value could not be dumped: $@ >>\n"); | |
} | |
return; | |
}; | |
1; |
This gist is no longer maintained: It has been moved to a repository at https://github.com/HaraldJoerg/Object-Pad-Debugger!
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Now updated for Object::Pad 0.60 (in particular, the renaming of 'slot' to 'field' is now done)!