lib/Stem/Debug.pm

   1 #!/usr/local/bin/perl
   2
   3 package Stem::Debug ;
   4
   5 use strict ;
   6 use Data::Dumper ;
   7 use Scalar::Util qw( openhandle ) ;
   8
   9 use base 'Exporter' ;
  10 our @EXPORT_OK = qw ( dump_data dump_socket dump_owner ) ;
  11
  12 sub dump_data {
  13
  14         my( $data ) = @_ ;
  15
  16         local $Data::Dumper::Sortkeys = \&dump_filter ;
  17
  18         return Dumper $data ;
  19 }
  20
  21 sub dump_filter {
  22
  23         my( $href ) = @_ ;
  24
  25         my @keys ;
  26
  27         my %fh_dumps ;
  28
  29         while( my( $key, $val ) = each %{$href} ) {
  30
  31                 if( my $fh_val = dump_socket( $val ) ) {
  32
  33                         my $fh_key = "$key.FH" ;
  34                         $fh_dumps{$fh_key} = $fh_val ;
  35                         push @keys, $fh_key ;
  36                         next ;
  37                 }
  38
  39                 push @keys, $key ;
  40         }
  41
  42         @{$href}{ keys %{fh_dumps} } = values %{fh_dumps} ;
  43
  44 #print "KEYS [@keys]\n" ;
  45
  46         return [ sort @keys ] ;
  47 }
  48
  49 sub dump_socket {
  50
  51         my ( $sock ) = @_ ;
  52
  53         return 'UNDEF' unless defined $sock ;
  54         return 'EMPTY' unless $sock ;
  55         return 'NOT REF' unless ref $sock ;
  56
  57         return 'NOT GLOB' unless $sock =~ /GLOB/ ;
  58
  59 warn "SOCK [$sock]\n" ;
  60
  61         my $fdnum = fileno( $sock ) ;
  62
  63         return 'NO FD' unless defined $fdnum ;
  64
  65         my $opened = openhandle( $sock ) ? 'OPEN' : 'CLOSED' ;
  66
  67 #       return "CLOSED $sock" if $opened eq 'CLOSED' ;
  68
  69 #       $fdnum = 'NONE' unless defined $fdnum ;
  70
  71 #       my $fdnum = "FOO" ;
  72
  73 #       return "FD [$fdnum]" unless $sock->isa('IO::Socket') ;
  74
  75         return "FD [$fdnum] *$opened*   $sock" ;
  76 }
  77
  78
  79
  80 sub dump_owner {
  81
  82         my ( $owner ) = @_ ;
  83
  84         my $owner_dump = "$owner" ;
  85
  86         while( $owner->{object} ) {
  87
  88                 $owner = $owner->{object} ;
  89                 $owner_dump .= " -> $owner " ;
  90         }
  91
  92         return $owner_dump ;
  93 }
  94
  95 1 ;