KGS::Listener::Debug

KGS documentation Contained in the KGS distribution.

Index

Code Index:

Tries to dump the given perl-ref into a nicely-formatted human-readable-format (currently uses either Data::Dumper or Dumpvalue) but tries to be very robust about internal errors, i.e. this functions always tries to output as much usable data as possible without die'ing.

KGS documentation Contained in the KGS distribution. 
package KGS::Listener::Debug;

use base KGS::Listener;

sub dumphex($) {
   my ($data) = @_;
   my $dump;

   for (my $ofs = 0; $ofs < length $data; $ofs += 16) {
      my $sub = substr $data, $ofs, 16;
      my $hex = unpack "H*", $sub;
      $sub =~ y/\x20-\x7e\xa0-\xff/./c;
      $dump .= sprintf "%04x: %-8s %-8s %-8s %-8s %s\n",
               $ofs,
               (substr $hex,  0, 8), (substr $hex,  8, 8),
               (substr $hex, 16, 8), (substr $hex, 24, 8),
               $sub;
   }

   $dump;
}


sub dumpval($) {
   eval {
      local $SIG{__DIE__};
      my $d;
      require Data::Dumper;
      $d = new Data::Dumper([$_[0]], ["*var"]);
      $d->Terse(1);
      $d->Indent(2);
      $d->Quotekeys(0);
      $d->Useqq(0);
      $d = $d->Dump();
      $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
      $d;
   } || "[unable to dump $_[0]: '$@']";
}

sub KGS::User::dump {
   my ($self, $i) = @_;

   (
       (sprintf "%s (%08lx)", $self->{name}, $self->{flags}),
       1,
   )
}

sub KGS::GameRecord::dump {
   my ($self, $i) = @_;

   (
       (sprintf "komi %s size %d flags %04x", $self->komi, $self->size, $self->{flags}),
       0,
   )
}

sub dumpmsg_($$) {
   my ($indent, $val) = @_;
   $indent++;

   if (ref $val) {
      my $i = "   " x $indent;
      my $r = "$val ";

      if (my $can = UNIVERSAL::can ($val, "dump")) {
         my ($r_, $done) = $can->($val, "$i   ");
         return $r_ if $done;
         $r .= $r_;
      }

      $r .= "\n";

      if (UNIVERSAL::isa ($val, HASH::)) {
         for my $k (sort keys %$val) {
            $r .= sprintf "%s%s => %s\n", $i, $k, dumpmsg_ ($indent, $val->{$k});
         }
      } elsif (UNIVERSAL::isa ($val, ARRAY::)) {
         for (0 .. $#$val) {
            $r .= sprintf "%s%03d: %s\n", $i, $_, dumpmsg_ ($indent, $val->[$_]);
         }
      } else {
         $r .= "$i\{$val\}\n";
      }
      substr $r, 0, -1;
   } else {
      if ($val =~ /^-?[0-9]+$/) {
         sprintf "%s%s (=%x)", $i, $val, $val;
      } else {
         $val =~ s/[\x00-\x1f\x7f-\x9f]/sprintf "\x{%02x}", ord $1/ge;
         "\"$val\"";
      }
   }
}

sub dumpmsg($$) {
   my ($header, $msg) = @_;

   $msg = { %$msg };
   my $data = delete $msg->{DATA};
   my $trail = delete $msg->{TRAILING_DATA};

   "$header\: TYPE " . (delete $msg->{type}) . "\n"
   . (dumphex $data)
   . (length $trail ? "TRAILING DATA:\n" . dumphex $trail : "")
   . (dumpmsg_ 0, $msg) . "\n";
}

sub inject_any {
   my ($self, $msg) = @_;

   if (exists $msg->{channel}) {
      if ($msg->{type} eq "upd_games") {
      } elsif ($msg->{type} eq "join") {
      } elsif ($msg->{type} eq "part") {
      } elsif ($msg->{type} eq "pubmsg") {
      } elsif ($msg->{type} eq "del_game") {
      } elsif ($msg->{type} eq "upd_game") {
      } elsif ($msg->{type} eq "set_tree") {
      } elsif ($msg->{type} eq "join_room") {
      } elsif ($msg->{type} eq "part_room") {
      } elsif ($msg->{type} eq "desc_room") {
      } elsif ($msg->{type} eq "msg_room") {
      #} elsif ($msg->{type} eq "upd_tree") {
      } elsif ($msg->{type} eq "set_node") {
      } elsif ($msg->{type} eq "set_tree") {
      } elsif ($msg->{type} eq "upd_observers") {
      } elsif ($msg->{type} eq "del_observer") {
      } else {
         warn "receivedC $msg->{type} ". dumpval($msg);
      }
   } else {
      if ($msg->{type} eq "login") {
      } elsif ($msg->{type} eq "list_rooms") {
      } elsif ($msg->{type} eq "upd_rooms") {
      } elsif ($msg->{type} eq "chal_defaults") {
      } elsif ($msg->{type} eq "timewarning_default") {
      } else {
         warn "receivedG $msg->{type} ". dumpval($msg);
      }
   }
   #warn "received* $msg->{type} ". dumpval($msg);
}

1;