package ATR::Tk::DebugFrame;

use strict;
use warnings;

use ATR::Util;
use B 'svref_2object';

# Funky (cool and dangerous) CPAN modules:
use Tk::WidgetDump;
use Tk::ObjScanner;

use base qw(Tk::Derived Tk::Frame);
Tk::Widget->Construct('DebugFrame');

=head1 NAME

ATR::Tk::DebugFrame - extra buttons and hooks for the intrepid power user

=head1 SYNOPSIS

    # This hook allows full scary access to any internals; the class should not load on production systems
    $self->bind("<Control-Key-F12>" => sub {
		    require ATR::Tk::DebugFrame;
		    my $dbg = ATR::Tk::AtrMain->ShowType('DebugFrame');
		    $dbg->refresh;
		});

or

  use ATR::Tk::DebugFrame;
  my $dbg = $mw->DebugFrame->pack(-side => 'bottom');

=head1 DESCRIPTION

Allow convenient access to L<Tk::WidgetDump> and other
internals-exposing tools, pointed at any of your MainWindows.

Sets C<$ATR::DebugFrame>, which is used some places for deciding
whether to apply debug hooks.

=cut


$ATR::DebugFrame = 1; # always referred to with fully qualified name

our ($VERSION) = (qw$Revision: 1.7 $)[1];
# $Source: /nfs/disk54/badger/cvs/AniTrack/testlib/ATR/Tk/DebugFrame.pm,v $
# $Revision: 1.7 $ $Date: 2005/10/31 11:28:45 $

#----------------------------------------------------------------------------

sub Populate {
    my ($self, $args) = @_;
    $self->SUPER::Populate($args);

    $self->ConfigSpecs(-titlesetter => [qw[METHOD titleSetter TitleSetter]]);

    $self->Advertise(items =>
		     $self->Scrolled('HList', Name => 'scr_items',
				     -scrollbars => 'osoe',
				     -columns => 2)
		     ->pack(-side => 'top', -fill => 'both', -padx => 16, -pady => 16, -expand => 1));
    $self->OnDestroy([ $self, 'clearList' ]);

    my $ops = $self->Frame(Name => 'buttons_f')->pack(-side => 'bottom', -fill => 'x');
    $self->Advertise(ops_f => $ops);

    $ops->Button(-text => 'Refresh List',   -command => [ $self, 'refresh' ])->pack(-side => 'left');
    $ops->Button(-text => 'Widget Dump',    -command => [ $self, '_tk_selected', 'WidgetDump' ])->pack(-side => 'left');
    $ops->Button(-text => 'Object Scanner', -command => [ $self, '_tk_objscan' ])->pack(-side => 'left');
    $ops->Button(-text => 'Ditch debugger', -command => [ $self, '_tk_undebug' ])->pack(-side => 'right');

    $ops->Button(-text => 'List PE cache',  -command => [ $self, '_tk_showPEs' ])->pack(-side => 'left');
    $ops->Button(-text => 'List DataSessions', -command => [ $self, '_tk_showSess' ])->pack(-side => 'left');

    $self->atr_demo; # add AniTrack-specific stuff

    $self->afterIdle([ $self, 'refresh' ]);
}

sub titlesetter {
    my ($self, $value) = @_;
    $self->afterIdle(sub { $value->("Debug frame") }) if defined $value; # XXX:TABS_API do it late until the others are fixed
}

sub atr_demo { # See bin/atr-demo.pl
    my $self = shift;
    my $ops = $self->Subwidget('ops_f');

    my $menu = $self->Menu( main::get_menu_data() );
    $ops->Button(-text => 'Old menu',
		 -command => sub {
		     $menu->Popup(-popover => 'cursor');
		 })->pack(-side => 'right');
}

sub refresh {
    my $self = shift;
    return unless Tk::Exists($self);
    $self->clearList;

    my @MW = Tk::MainWindow->Existing;
    for (my $n=0; $n<@MW; $n++) {
	$self->_put($n, $MW[$n], $MW[$n]->title);
    }
}

sub clearList {
    my $self = shift;
    my $I = $self->Subwidget('items');
    $I->delete('all');
}

sub _put {
    my ($self, $hpath, $data, $text) = @_;
    my $I = $self->Subwidget('items');

    $I->add($hpath, -data => $data);
    $I->itemCreate($hpath, 0, -itemtype => 'text', -text => "$data");
    $I->itemCreate($hpath, 1, -itemtype => 'text', -text => $text);
}

sub _selected {
    my $self = shift;
    my $I = $self->Subwidget('items');

    my ($selPath) = $I->info('selection');
    die "No selection" unless defined $selPath;

    my $selData = $I->info('data', $selPath);
    return $selData;
}

sub _tk_selected {
    my ($self, $method, @args) = @_;
    $self->_selected->$method(@args);
}

sub _tk_objscan {
    my ($self) = @_;
    Tk::ObjScanner::scan_object($self->_selected);
}

sub _tk_undebug {
    my $self = shift;
    $self->destroy;

    my $filename = __PACKAGE__;
    $filename =~ s{::}{/}g;
    $filename .= ".pm";
    warn "info: ".__PACKAGE__." hereby forgets that it was loaded from ".delete $INC{$filename};
}

sub _tk_showPEs {
    my $self = shift;
    my $gtx = ATR::GTx->singleton;
    ### Hairy private stuff follows
    my $pe_cache_hash = $gtx->_pe_cache->{cache};
    my @keys = sort { $a <=> $b } keys %$pe_cache_hash;

    my %type = map {( $_->idEntityType => $_ )} qw(ATR::MicePE::Mouse ATR::MicePE::MatingPair ATR::MicePE::Weaning);
    my $remain = 0;
    warn (join "",
	  "-- PE cache dump ----\n",
	  (safemap {
	      my $key = shift;
	      my $pe = $pe_cache_hash->{$key};
	      my $refcnt  = $pe ? (svref_2object($pe)->REFCNT)-1 : 0;
	      my $pe_type = $pe ? $pe->getIdEntityType : '';
	      $remain ++ if $pe;
	      sprintf(" %8d [%2d]  %-20s\n", $key, $refcnt, $type{$pe_type} || $pe_type);
	  } @keys),
	  " > $remain item(s)\n");
    Tk::ObjScanner::scan_object($gtx);
}

sub _tk_showSess {
    my $self = shift;
    my @sess = sort { $a cmp $b } ATR::DataSession->debugList;
    warn (join "",
	  "-- DataSession list ---- XXX: could show MicePEs and PEs inside\n",
	  (map {
	      my $refcnt  = (svref_2object($_)->REFCNT)-1;
	      sprintf(" %-30s [%2d] %s\n", $_, $refcnt, $_->getDebug);
	  } @sess),
	  " > ".@sess." item(s)\n");
    Tk::ObjScanner::scan_object(\@sess);
}


=head2 Tk::Widget->numDescendants

A convenience method for use from the L<Tk::ObjScanner>.  Returns the
total number of widgets descended from the invoking object.

=cut

sub Tk::Widget::numDescendants {
    my $w = shift;
    return scalar $w->Descendants();
}


#----------------------------------------------------------------------------

sub showall {
    foreach my $self (Tk::MainWindow->Existing()) {
	print "$self:\n";
    my $do_show = sub {
	my ($item, $lvl) = @_;
	my $path = $item->PathName; # mostly includes name at the end
#	my $Name = $item->Name;
	my $name = $item->name;
#	my $Class = $item->Class;
	my $class = $item->class;
	my $type = ref($item);
	$type .= ", class=$class" unless $type eq "Tk::$class";
	$type .= ", name=$name" unless $path =~ /\.$name$/;
	print "  ", $path, " "x(40-length($path)), " "x$lvl, "($type)\n";
	return 1;
    };
    widget_traverse($do_show, $self);
    }
}

# cmp. $widget->Walk($coderef => @args) implemented in Tk::Widget,
# documented in "Mastering Perl/Tk" but not in POD
sub widget_traverse {
    my ($do_code, $widg, $lvl, $parent_info) = @_;
    $lvl ||= 0;
    my $info = $do_code->($widg, $lvl, $parent_info);
    return if defined $parent_info && !defined $info;
    foreach my $kid ($widg->children) {
	widget_traverse($do_code, $kid, $lvl+1, $info);
    }
}


#----------------------------------------------------------------------------

warn "info: Loaded ".__PACKAGE__." v$VERSION";

1;
