XS.pm

package X::XS;

# ... some other code (loading XS in my case)

our (%TRACE_PKGS,%TRACE_OBJS,$TRACE_FD);

if ($ENV{X_XS_TRACE}) {
    enable_trace($ENV{X_XS_TRACE});
}

sub enable_trace {
    my ($opts_str) = @_;

    require Class::Method::Modifiers;
    require Package::Stash;
    require Data::Dumper;
    require Scalar::Util;
    require Data::Visitor::Callback;

    my @opts = split(':',$opts_str|'');
    my %opts;
    foreach (@opts) {
        if (/^(.+?)=(.+)$/) {
            $opts{$1} = $2;
        }
        else {
            $opts{$_} = 1;
        }
    }

    my $fh;
    if ($opts{logf}) {
        open($fh, ">", $opts{logf});
    }
    $TRACE_FD = $fh || \*STDERR;

    print $TRACE_FD <<HEAD_END;
#!perl
our %S; # our symbol table

HEAD_END

    my @trace_pkgs = qw/X::World X::XS X::XS::Actor X::XS::ActorFilter X::XS::Quests X::XS::WareHouse/;
    %TRACE_PKGS = map { $_ => 1 } @trace_pkgs;
    for my $pkg (@trace_pkgs) {
        print $TRACE_FD "use $pkg;\n";
        __enable_trace_for_pkg($pkg);
    }
}

sub __enable_trace_for_pkg {
    my ($pkg) = @_;
    my $s = Package::Stash->new($pkg);
    my @subnames = $s->list_all_symbols('CODE');
    foreach my $subname (grep { $_ && !/^__/ } @subnames) {
        Class::Method::Modifiers::install_modifier($pkg, 'around', $subname, sub {
                my $orig = shift;
                my @args = @_;

                my $type;
                $type = 'method' if Scalar::Util::blessed($args[0]) && $args[0]->isa($pkg);
                $type = 'destroy' if $type && $subname eq 'DESTROY';

                my $wantarray = wantarray;
                my @ret;
                if ($wantarray) {
                    @ret = $orig->(@_);
                }
                else {
                    $ret[0] = $orig->(@_);
                }

                if (!$type) {
                    $type = Scalar::Util::blessed($ret[0]) && $ret[0]->isa($pkg) ? 'new' : 'func';
                }

                my $assign_str = '';
                if (Scalar::Util::blessed($ret[0]) && $TRACE_PKGS{ ref($ret[0]) }) {
                    my $refstr = Scalar::Util::refaddr($ret[0]);
                    $assign_str = "\$S{$refstr} = ";
                    $TRACE_OBJS{$refstr} = $refstr;
                }

                if ($type eq 'method') {
                    my $refstr = Scalar::Util::refaddr(shift @args);
                    if (exists $TRACE_OBJS{$refstr}) {
                        my $arguments = __trace_args(\@args);
                        print $TRACE_FD "${assign_str}\$S{$refstr}->$subname($arguments);\n";
                    }
                }
                elsif ($type eq 'destroy') {
                    my $refstr = Scalar::Util::refaddr(shift @args);
                    if (exists $TRACE_OBJS{$refstr}) {
                        print $TRACE_FD "delete \$S{$refstr};\n";
                        delete $TRACE_OBJS{$refstr};
                    }
                }
                elsif ($type eq 'new') {
                    my $refstr = Scalar::Util::refaddr($ret[0]);
                    shift @args;
                    my $arguments = __trace_args(\@args);
                    print $TRACE_FD "${assign_str}${pkg}->$subname($arguments);\n";
                }
                else {
                    my $arguments = __trace_args(\@args);
                    print $TRACE_FD "${assign_str}${pkg}::$subname($arguments);\n";
                }
                return $wantarray ? @ret : $ret[0];
            });
    }
}

sub __trace_args {
    my ($args) = @_;
    return "" unless @$args;
    my $v = Data::Visitor::Callback->new(
        ignore_return_values => 1,
        object => sub {
            my $refstr = Scalar::Util::refaddr($_);
            if (exists $TRACE_OBJS{$refstr}) {
                $_ = "{{{S{$refstr}}}}";
            }
        }
    );
    $v->visit($args);
    local $Data::Dumper::Terse=1;
    local $Data::Dumper::Indent=0;
    my $dump = join(',',Data::Dumper::Dumper(@$args));
    $dump =~ s/'{{{S{(\d+)}}}}'/\$S{$1}/g;
    return $dump;
}

1;