package ATR::Tk::AtrMain;

use Tk;
use strict;
use warnings;

use base qw(Tk::Derived Tk::MainWindow);
Tk::Widget->Construct('AtrMain');

use Tk::NoteBook;
use Tk::ROText;
use Tk::Label;

use File::Temp;
use IO::Handle;

=head1 NAME

ATR::Tk::AtrMain - Main AniTrack window

=head1 DESCRIPTION

A MainWindow subclass containing tabstrip and status bar.

This class should have minimal dependencies so it can present a GUI
fairly quickly.  We then have a place to display and log the errors or
feedback during loading.

=cut

# $Id: AtrMain.pm,v 1.18 2005/05/17 14:31:34 mca Exp $

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

{
    my $instance;
    sub getInstance {
	my $pkg = shift;
	$instance = $pkg->new if !Tk::Exists($instance);
	return $instance;
    }

    my $page_serial = 0;
    sub __page_serial { $page_serial++ }
}

__PACKAGE__->getInstance()->_grabHandlers();


my %tkmeth2class; # key = $widget->MethodName for creating new; value = class name of created widget
# Populated as we go along, by makePageWidget

sub Populate {
    my ($self, $args) = @_;

    $self->maxVisible; # maximise early to avoid the jigglies as it comes up

    # XXX: No menu bar .. so we're missing quit, debug options
    $args->{-title} = 'AniTrack';
    $self->minsize(256,256);

    $self->SUPER::Populate($args);
    $self->_init_options;

    # base class lets this percolate down to the widgets we're just about to make
    $self->ConfigSpecs(-background => [qw[SELF background  Background]]);

    my $P = $self->privateData;

    {
	$P->{_statusArea} =
	  my $txt = $self->Scrolled('ROText', Name => 'status_area');
	$txt->pack(-side => 'bottom', -fill => 'x');
	$txt->menu(undef); # XXX: Restore a right-click menu to the ROText, but without that scary 'File > Exit' option
	$txt->tagConfigure('error', -foreground => 'red', -background => 'yellow');
	$txt->tagConfigure('warn',  -foreground => 'red');
	$txt->tagConfigure('info',  -foreground => 'darkgrey');
    }

    {
	$P->{_noteBook} =
	  my $nb = $self->NoteBook(Name => 'main_tabs');
	$nb->pack(-side => 'top', -fill => 'both', -expand => 1);
    }

    $self->_splash; # not just for decoration!

    $self->bind("<Control-Key-q>" => [ $self, 'destroy' ]);
    $self->bind("<Control-Key-p>" => [ $self, 'op_print' ]);

    # XXX:DEBUG 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;
		});

    # XXX: Scroll event catching seems to be broken for the header-area of a Scrolled(HList) ...?
    $self->bind('all', '<Button-4>' => [\&__tkScrollWheel, -5]);
    $self->bind('all', '<Button-5>' => [\&__tkScrollWheel,  5]);
}

sub __tkScrollWheel {
    my ($widget, $units) = @_;
    # Trundle up the widget tree until we find something that can scroll
    my $last;
    while (defined $widget && (!defined $last || $widget != $last)) {
	if ($widget->can('atrmainScroll')) {
	    # It's a widget that can scroll for us - use that and stop looking
	    $widget->atrmainScroll($units);
	    return;
	}
	$last = $widget;
	$widget = $widget->parent;
    }
    # fall out the bottom: nothing to do
}


sub _NOT_CALLED_atr_title { # is set on $args during creation
    my $self = shift;
    $self->title("AniTrack"); # XXX: ", user=".ATR::GTx->currentUser->getEmail
}

sub _statusArea { $_[0]->privateData->{_statusArea} }
sub _noteBook   { $_[0]->privateData->{_noteBook}   }

# Make new page + widget; don't raise the page
# Tidy up if errors detected during widget creation/recommission()ing, then re-die
sub makePageWidget {
    my ($self, $widgType, %args) = @_;
    my $nb = $self->_noteBook;
    my $num = __page_serial();
    my $page = $nb->add("pg$num", # page name not particularly relevant
			-label => "XXX: Incomplete ($num/$widgType)");

    # Create the widget under $self but pack it in $page.  Then we
    # have the option of repacking in another page later.

    my ($guiCard, $guiProb);
    my $spareH = $self->_spareWidgets;
    my $widgClass = $tkmeth2class{$widgType}; # undef, if we've not seen one before
    if ($widgClass && $spareH->{$widgClass} && @{ $spareH->{$widgClass} }) {
	# We have a decommission()ed widget to use
	$guiCard = shift @{ $spareH->{$widgClass} };
	if ($guiCard->can('recommission')) {
	    # We must wake it up.  Detect errors.
	    $guiProb = ($@ || '[unspecified problem]') unless eval {
		$guiCard->recommission(%args);
		1;
	    };
	}
    } else {
	# Have to make a new one
	$guiProb = ($@ || '[unspecified problem]') unless eval {

	    $guiCard = $self->$widgType(%args);

	    # Remember the widget-class that the method created
	    $tkmeth2class{$widgType} = ref($guiCard);

	    # Hook to deal with untidy death of page
	    $guiCard->OnDestroy([ $self, '_pageDied', $page ]);
	    1;
	};
    }

    if (defined $guiProb) {
	foreach my $w ($page, $guiCard) {
	    $w->destroy if Tk::Exists($w);
	}
	die "Cannot display this: $guiProb";
    } else {
	$guiCard->pack(-in => $page, -fill => 'both', -expand => 1);
	$self->_unsplash;
    }

    return ($guiCard, $page);
}

# Returns none (if no match), one (if reference match: page or a page
# child) or some (if classname match)
sub _getPageForWidget {
    my ($self, $widg) = @_;
    my $nb = $self->_noteBook;
    my @ret;
    foreach my $pg ($nb->children) {
	my @page_items = $self->_pageContents($pg);
	if (ref($widg)) {
	    return $pg if $widg == $pg; # doh!
	    return $pg if grep { $widg == $_ } @page_items;
	} else {
	    push @ret, $pg if grep { $_->isa($widg) } @page_items;
	}
    }
    return @ret;
}

# Get the union of $page->children, $page->packSlaves/gridSlaves
# in no particular order
sub _pageContents {
    my ($self, $page) = @_;
    my @w = ($page->children, $page->packSlaves, $page->placeSlaves, $page->gridSlaves);
    my %w;
    @w{@w} = @w;
    return values %w;
}

sub _getPageForName {
    my ($self, $pagename) = @_;
    my $nb = $self->_noteBook;
    foreach my $pg ($nb->children) {
	return $pg if Tk::Exists($pg) && $pg->Name eq $pagename;
    }
    return undef;
}

sub ShowPeCard {
    my ($called, $peCard) = @_;
    my $pkg = __PACKAGE__;
    ($called, $peCard) = ($pkg, @_) if ref($called) && !$called->isa($pkg);
    my $self = ref($called) ? $called : $called->getInstance;
    my $twiddle = $self->busyIndicator;

    my $type;
    if (!ref($peCard)) {
	$type = $peCard;
	$peCard = undef; # a blank card
    } elsif ($peCard->isa('ATR::MicePE::MatingPair')) {
	$type = 'MatingCard';
    } elsif ($peCard->isa('ATR::MicePE::Weaning')) {
	$type = 'WeaningCard';
    } else {
	die "Don't know how to display this $peCard ".$peCard->debugId;
    }

    my ($card, $page) = $self->makePageWidget($type);
    $card->setCard($peCard);
    my $title = $peCard ? $peCard->getCardName : "New $type";
    $self->_noteBook->pageconfigure($page->name, -label => $title);

    $self->_noteBook->raise($page->name);
    $self->update;

    return $card;
}

sub ShowColony {
    my ($called, $colName) = @_;
    my $self = ref($called) ? $called : $called->getInstance;

    my ($ed, $page) = $self->makePageWidget('ColonyEd', -colonyName => $colName);
    my $title = defined $colName ? "Colony $colName" : "New colony";
    $self->_noteBook->pageconfigure($page->name, -label => $title);

    $self->_noteBook->raise($page->name);
    $self->update;
    return $ed;
}

sub ShowType {
    my ($self, $makeType) = @_;
    $self = __PACKAGE__ if !$self;
    $self = $self->getInstance if !ref($self);

    # Try to find a page containing such a widget
    my $classType = $tkmeth2class{$makeType};
    my ($page, $widget, $twiddle);

    if (defined $classType) {
	# We've made one of these before, try to find one
	($page) = $self->_getPageForWidget($classType);
	$widget = ($self->_pageContents($page))[0] if $page;
    }

    if (!$widget) {
	$twiddle = $self->busyIndicator;
	($widget, $page) = $self->makePageWidget($makeType);
	my $title = $makeType;
	$title =~ s/^Atr//;
	$self->_noteBook->pageconfigure($page->name, -label => $title);
    }

    $self->_noteBook->raise($page->name);
    $self->update;

    return $widget;
}


=head2 busyIndicator()

Set the mouse pointer to 'watch' and return an object which will reset
it to the previous state when it goes out of scope.

To reduce dependency, may do nothing and return C<undef> if the
necessary helper isn't yet loaded.

=cut

sub busyIndicator {
    my $self = shift;
    return undef unless ATR::Util::ScopeHelper->can('new');

    my $old_shape = $self->cget('-cursor');
    my $busy = ATR::Util::ScopeHelper->new
      (sub {
	   $self->configure(-cursor => $old_shape);
       });
    $self->configure(-cursor => [ 'watch', 'black', 'white' ]);

    return $busy;
}


=head2 closeItemDelayed($widget)

Close the page $widget, or the page which contains $widget as a child.
Do this in an C<afterIdle> to avoid problems with callers who are in a
Tk button callback inside the victim.

Caller is responsible for not removing the last page without
re-creating a splash or placeholder page.  (Tk::NoteBook doesn't like
that.)

=cut

sub closeItemDelayed {
    my ($self, $widget) = @_;

    # Show previous page before zapping old one.  You can't use it
    # because the app is still busy, but there is something to see.
    my $nb = $self->_noteBook;
    $nb->raise($nb->info("focusprev"));
    $nb->update;

    # The caller is often a button callback on the card, so we can't kill it 'til later
    $self->afterIdle([$self, '_closeItem', $widget ]);
}

# Returns: hashref for storage, key=type, value=listref containing widgets
# _closeItem will put here any page child it can('decommission')
sub _spareWidgets { $_[0]->privateData->{spares} ||= { } }

sub _closeItem { # only private so we have benefit of the "focus previous" action
    my ($self, $widget) = @_;
    my ($pg) = $self->_getPageForWidget($widget);
    return if !Tk::Exists($pg);

    # destroy is faster when widgets are off-screen.

    # Since widgets are kids of $self not the page, they need
    # destroying too.  Unless we hang on to them.
    my $spareH = $self->_spareWidgets;
    my @destroy = ($pg);

    foreach my $w ($self->_pageContents($pg)) {
	my $hider = ($w->manager)."Forget";
	$w->$hider;
	if ($w->can('decommission')) {
	    # Stow it for later
	    $w->decommission;
	    push @{ $spareH->{ref($w)} }, $w;
	} else {
	    # Ditch it
	    push @destroy, $w;
	}
    }
    $self->update;
    foreach my $w (@destroy) {
	$w->privateData->{closed_ok} = 1;
	$w->destroy;
    }
}


sub _pageDied {
    my ($self, $page) = @_;
    if (!$page->privateData->{closed_ok}) {
	my $pg = $page->Name;
	my $lbl = $self->_noteBook->pagecget($pg, '-label');
	warn "NoteBook contents in page $pg='$lbl' went away unexpectedly\n";
	$page->destroy;
	$self->update;
    }
}



sub _init_options {
    my $self = shift;

    my $data_font = '-*-helvetica-medium-r-normal-*-*-140-*-*-*-*-iso8859-1';
    # Helvetica aka. Arial(Microsoft)
    # was:  -adobe-courier-medium-r-normal-*-*-180-*-*-*-*-iso8859-*

    # Set up our options database (man Tk::options), so I don't have
    # to specify options per-widget
    my $Xname = $self->Class;
    my @options = split /[\r\n]+/, <<STUFF;

# nb. order is significant: last match wins

# XXX:DEBUG
*mouse_editor*font: -adobe-helvetica-bold-r-normal-*-*-140-100-100-*-*-iso8859-1

# Generic
*Label.font: -adobe-helvetica-normal-r-normal-*-*-180-100-100-*-*-iso8859-1
*Title*font: -*-times-bold-r-normal-*-*-240-*-*-p-*-*-*
*HList*font: -adobe-helvetica-normal-r-normal-*-*-180-100-100-*-*-iso8859-1

*Button.font: -adobe-helvetica-bold-r-normal-*-*-140-100-100-*-*-iso8859-1
*Button.foreground: purple
*Menu.foreground: purple
*Button.activeBackground: black
*Button.activeForeground: white

 # Data fields
*UpdateFieldButton.padX: 6
*UpdateFieldButton.padY: 0
# default Button.pad=(3m,1m)
*UpdateFieldButton.disabledForeground: #737373
# default Button.disabledForeground: #a3a3a3

*UpdateFieldButton.font: $data_font
*UpdateFieldEntry.font: $data_font
*UpdateFieldDate.font: $data_font

*UpdateFieldEntry.Width: 20

*Entry.font: -adobe-courier-medium-r-normal-*-*-240-*-*-*-*-iso8859-*
  # was -adobe-helvetica-medium-r-normal--17-120-100-100-p-88-iso8859-1
  # was the same as *Label.font in old ExoSeq.pm
*Entry.background: white
# can't specify just the Entry .. will need to hack widget
# *BrowseEntry.background: white


*Entry*highlightThickness: 2
*Button*highlightThickness: 2
*Listbox*highlightThickness: 2

*tearOff: false

 # Specific item styles in cards
*card_f.borderWidth: 3
*card_f.relief: solid
*head_f.borderWidth: 2
*head_f.relief: groove
*WeaningCard*lic_f.borderWidth: 1
*MatingCard*lic_f.borderWidth: 0
*lic_f.relief: sunken
*progs_f.borderWidth: 1
*progs_f.relief: sunken
*mice_f.borderWidth: 1
*buttons_f.relief: sunken
*buttons_f.borderWidth: 2

*main_tabs.ipadx: 8
*main_tabs.ipady: 8
*main_tabs.borderWidth: 2
*main_tabs.relief: raised

*status_area.scrollbars: e
*status_area*takeFocus: false
*status_area.rotext.background: white
*status_area.rotext.height: 6
*status_area.rotext.wrap: char
*status_area.rotext.font: corpus 12

# *highlightColor: black
# *highlightBackground: darkgrey
*selectBackground: darkblue
*selectForeground: white

*ColonyEd*Section.relief: raised
*ColonyEd*Section.borderWidth: 3
*ColonyEd*Section*Heading.foreground: blue
*ColonyEd*Section.Locus.borderWidth: 1
*ColonyEd*Section.Locus.relief: solid
*col_getrolereason.top.Heading.foreground: blue
*col_getrolereason.top*HList.width: 55

STUFF

    foreach my $opt (@options) {
	next if $opt =~ /^\s*(#|$)/;
	my ($k, $v) = split /\s*:\s*/, $opt, 2;
	$k =~ s/^([.*])/$Xname$1/;
	$self->optionAdd($k, $v, 'startupFile');
    }

    return $self;
}

sub op_print { # ctrl-p : print current page's card
    my $self = shift;
    my $pagename = $self->_noteBook->raised;
    my $page = $self->_getPageForName($pagename);
    my ($card) = $self->_pageContents($page) if $page;
    if (!$page || !$card || !$card->can('op_print')) {
	warn "Operation failed: Couldn't figure out which card to print\n"; # XXX: Categorise warning
	return;
    }

    $card->op_print;
}

sub furnitureFont {
    my $self = shift;
    return $self->privateData->{furnitureFont} ||= do {
	my $f = $self->Font('furniture');
	$f->configure(-family => 'helvetica', -size => 9*2.3/1.2);
	$f;
    };
}


#----------------------------------------------------------------------------
#
# Resize window to visible area - should take into account panel/dock/start bar etc.
# Slightly dim implementation that only takes the first expose event, which may not be enough.

sub maxVisible {
    my $self = shift;

    $self->bind('<Expose>' => [ $self, '_tkExpose', map {($_, Tk::Ev($_) )} qw(x y h w) ]);
    $self->packPropagate(0);
    $self->FullScreen;
}

sub _tkExpose {
    my ($self, %vis) = @_;
    $self->bind('<Expose>' => undef);

    my %old;
    my $oldGeom = $self->geometry; # 1265x994+0+0
    @old{qw{w h x y}} = ($oldGeom =~ /^(\d+)x(\d+)\+(\d+)\+(\d+)$/);
    return if !scalar keys %old;

#warn "Resize from (".(join "|", %old).") for visible (".(join "|", %vis).")\n";

    $old{w} = $vis{w};
    $old{h} = $vis{h};
    if ($vis{x} > 0) {
	$old{x} += $vis{x};
	$old{w} -= $vis{x};
    }
    if ($vis{'y'} > 0) {
	$old{'y'} += $vis{'y'};
	$old{'h'} -= $vis{'y'};
    }

    $self->geometry("$old{w}x$old{h}+$old{x}+$old{y}");

    $self->sizefrom('program');
    $self->positionfrom('program');
}


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

=head2 _splash()

Tk::NoteBook seems to need at least one page present before its first
C<update>, else it permanently hides the tabstrip.

This method creates a self-destroying page which is a sensible use for
the bodge page.

=cut

sub _splash {
    my $self = shift;
    my ($lbl, $page) = $self->makePageWidget
      ('Label',
       -text => 'Opening database...', # ...and compiling, and stuff
       -font => 'helvetica 32');
    $self->_noteBook->pageconfigure($page->name, -label => 'Loading...');
    $self->log_text('info', 'Starting...');
    $self->privateData->{_splash} = $page;
    $self->update;
}

sub _unsplash {
    my ($self) = @_;
    my $splashPage = $self->privateData->{_splash};
    return if !Tk::Exists($splashPage); # already gone

    my @pages = $self->_noteBook->pages;
    if (@pages > 1) {
	# This is our purpose: never leave zero pages
	$self->log_text('info', 'Started');
	# a minor race here:
	$self->closeItemDelayed($splashPage);
	undef $self->privateData->{_splash};
    }

    $self->ProfileWindow->iconify if $self->can('ProfileWindow');
}


#----------------------------------------------------------------------------
#
# Logging/status


sub log_text {
    my ($self, $level, $text) = @_;

    $text .= "\n" unless $text =~ /\n$/;

    my $fh = $self->_getLogFh;
    $fh->print(time(), "\t$level\t$text") if $fh;

    my $txt = $self->_statusArea;
    my $from = $txt->index('end - 1 chars');
    $txt->insert('end', $text);
    $txt->tagAdd($level, $from, 'end - 1 chars');

    $txt->see('end');
    $txt->yview($from);

## DON'T UPDATE!  Callers of warn() don't expect their afterIdle's to happen yet
#    $txt->update('idletasks');
}

sub getLogFh { $_[0]->_getLogFh }

sub _getLogFh {
    my $P = $_[0]->privateData;
    return $P->{_logFh} if exists $P->{_logFh};

    my $now = time();
    my ($fh, $name) = eval
      { File::Temp::tempfile
	  ("$now-XXXXXXX",
	   DIR => '/nfs/team71/psg/mca/tmp/atr-debug-logs',
	   SUFFIX => '.log');
	# mkdir ~/tmp/atr-debug-logs
	# chmod 0733 ~/tmp/atr-debug-logs
    };
    if (!$fh) {
	warn "Failed to make debug log: $@";
    } else {
	$fh->autoflush(1);
	chmod 0640, $name;
    }
    $P->{_logFh} = $fh;
}

sub _hasLogger {
    my $self = shift;
    return (Tk::Exists($self) &&
	    Tk::Exists($self->_statusArea));
}

sub _grabHandlers {
    my $self = shift;


    # One instance of this class expects to be in charge of errors.
    # Detect conflict & bail
    die "Found old warning handler" if $SIG{__WARN__};
    die "Found old die handler"     if $SIG{__DIE__};

# Set stuff up first...

    my $fh;
    my $old_stderr;

    # Warn handler applies throughout
    my $warn_h = sub {
	my $msg = shift;
	if ($self->_hasLogger) {
	    my $type = 'warn';
	    $type = 'info' if $msg =~ s/^DBG:\s*/  debug: /;
	    $type = 'info' if $msg =~ /^info:/i;
	    $self->log_text($type, $msg);
	} else {
	    # Main window has gone away...  do the best we can
	    print $old_stderr "Warning: $msg";
	    print $fh "Warning: $msg" if $fh;
	}
    };

    # Die handler is relevant until MainLoop starts
    # Then it will be overridden by Tk, Tk::Error is relevant instead
    my $die_h = sub {
	die @_ if $^S; # bail out if we're in an eval
	my $msg = shift;
	$self->wedged(1);
	if ($self->_hasLogger) {
	    $self->log_text('error', $msg);
	    $self->log_text('error', "Please close the window to exit the program");
	    $self->Busy(-recurse => 1);
	    Tk::MainLoop;
	    Tk::exit(0);
	} else {
	    # Main window has gone away...  do the best we can
	    print $old_stderr "Error: $msg";
	    print $fh "Error: $msg" if $fh;
	}
    };

    my $tk_error = sub {
	my ($widget, $error, @locations) = @_;
	$self->wedged(1);
	# $widget will be a MainWindow or 'Tk'
	if ($self->_hasLogger) {
	    $self->log_text('error', $error);
	} else {
	    # Main window has gone away...  do the best we can
	    print $old_stderr "TkError: $error";
	    print $fh "TkError: $error" if $fh;
	}
	print $fh ((join "\n  ", "TkError locations:", @locations), "\n")
	  if $fh;
    };

# Now install it...

    $SIG{__DIE__} = $die_h;
    $SIG{__WARN__} = $warn_h;

    $fh = $self->_getLogFh; # first call warns if it can't write

    no strict 'refs';
    $old_stderr = *STDERR;
    *STDERR = $fh if $fh;
    # nb. STDERR will include output from processes launched for printing, etc.

    *Tk::Error = $tk_error;
}

sub wedged {
    my $P = (shift)->privateData;
    if (@_) {
	$P->{wedged} = shift;
    } else {
	return $P->{wedged};
    }
}


1;
