view release on metacpan or  search on metacpan

lib/App/Chart/Gtk2/Diagnostics.pm  view on Meta::CPAN

  my $window = $self->window
    || return "(X-Resource -- no window realized, no server connection)\n";
  $window->can('XID')
    || return "(X-Resource -- not running on X11)\n";
  my $xid = $window->XID;
  eval { require X11::Protocol; 1 }
    || return "(X-Resource -- X11::Protocol module not available)\n";

  my $display = $window->get_display;
  my $display_name = $display->get_name;
  my $X = eval { X11::Protocol->new ($display_name) }
    || return "(X-Resource -- cannot connect to \"$display_name\": $@)\n";
  my $ret;
  if (! eval {
    if (! $X->init_extension ('X-Resource')) {
      $ret = "(X-Resource -- server doesn't have this extension\n";
    } else {
      $ret = "X-Resource server resources (X11::Protocol)\n";
      if (my @res = $X->XResourceQueryClientResources ($xid)) {
        my $count_width = 0;
        for (my $i = 1; $i <= $#res; $i++) {
          $count_width = max($count_width, length($res[$i]));
        }
        while (@res) {
          my $type_atom = shift @res;
          my $count = shift @res;
          $ret .= sprintf ("  %*d  %s\n",
                           $count_width,$count, $X->atom_name($type_atom));
        }
      } else {
        $ret = "  no resources in use\n";
      }
    }
    1;
  }) {
    (my $err = $@) =~ s/^/  /mg;
    $ret .= $err;
  }
  return $ret;
}

#------------------------------------------------------------------------------
# generic helpers

# return true if $class is not a subclass of anything in $class_list (an
# arrayref)
sub is_toplevel_class {
  my ($class, $class_list) = @_;
  return ! List::Util::first {$class ne $_ && $class->isa($_)} @$class_list;
}

# return a string of the contents of a hash (passed as a hashref)
sub hash_format {
  my ($h) = @_;
  my $nf = App::Chart::number_formatter();

  require Scalar::Util;
  my %mung;
  foreach my $key (keys %$h) {
    my $value = $h->{$key};
    if (Scalar::Util::looks_like_number ($value)) {
      $mung{$key} = $nf->format_number ($value);
    } elsif (ref ($_) && ref($_) eq 'HASH') {
      $mung{$key} = "subhash, " . scalar(keys %{$_}) . " keys";
    } else {
      $mung{$key} = $value;
    }
  }

  my $field_width = max (map {length} keys   %mung);
  my $value_width = max (map {length} values %mung);

  return join ('', map { sprintf ("  %-*s  %*s\n",
                                  $field_width, $_,
                                  $value_width, $mung{$_})
                       } sort keys %mung);
}

1;
__END__

=head1 NAME

App::Chart::Gtk2::Diagnostics -- diagnostics dialog module

=head1 SYNOPSIS

 use App::Chart::Gtk2::Diagnostics;
 App::Chart::Gtk2::Diagnostics->popup();

=head1 WIDGET HIERARCHY

C<App::Chart::Gtk2::Diagnostics> is a subclass of C<Gtk2::Dialog>.

    Gtk2::Widget
      Gtk2::Container
        Gtk2::Bin
          Gtk2::Window
            Gtk2::Dialog
              App::Chart::Gtk2::Diagnostics

=head1 DESCRIPTION

A C<App::Chart::Gtk2::Diagnostics> dialog shows various bits of diagnostic
information like memory use, database size, etc.

=head1 FUNCTIONS

=over 4

=item C<< App::Chart::Gtk2::Diagnostics->popup() >>

Present a C<Diagnostics> dialog to the user.  C<popup()> creates and then
re-uses a single dialog, re-presenting it (C<< $widget->present() >>) and
refreshing its contents each time.  A single diagnostics dialog like this
will be enough for most uses.

=item C<< $dialog = App::Chart::Gtk2::Diagnostics->new() >>

Create and return a new Diagnostics dialog widget.  Initially it's empty and
C<refresh()> must be called to put some diagnostic information in it.