#
# PERL Modul
# Tk-Frontend Basic Class
#
# Copyright (C) 1998,1999 Dirk Tostmann (tostmann@tiss.com)
#
# $rcs = ' $Id: Application.pm 1.3 1999/01/22 18:31:12 MASTER Exp $ ' ;	
#
#######################################################
package Tk::Application;
#######################################################
#
$Tk::Application::VERSION = 0.03;
#
use Tk;
use Tk::Label;
use Tk::CmdLine;
use Tk::Balloon;
use FreezeThaw qw(freeze thaw);
use strict;
#
#######################################################
sub new {
  my $that  = shift;
  my $class = ref($that) || $that;
  my $self  = {
	       TW     => MainWindow->new(),
	       APPNAME=> shift || 'TkApplication',
	       TITLE  => shift,
	       FONT   => '-*-Helvetica-Medium-R-Normal--*-150-*-*-*-*-*-*',
	       FIXFONT=> '-*-courier-Medium-R-Normal--*-150-*-*-*-*-*-*',
	      };
  
  return unless $self->{TW};
  
  bless $self, $class; 
  
  $self->{TITLE} = $self->{APPNAME} unless $self->{TITLE};
  
  $self->{TW}->protocol('WM_DELETE_WINDOW' => sub{$self->QUIT});
  
  $self;
}
#
#
#######################################################
sub RUN { 
  my $self = shift;
  
  MainLoop;
}

#
#######################################################
sub SETUP {
  my $self = shift;
  $self->{TW}->title($self->{TITLE}) if $self->{TITLE};
  
  $self->{MENUBAR} = $self->{TW}->Frame(qw/-relief raised -bd 2/);
  $self->{MENUBAR}->pack(-side => 'top', -fill => 'x');
  $self->create_statusbar;
  $self->create_menubar;
  
  # Create Main Frame
  $self->{MF} = $self->{TW}->Frame(qw//);
  $self->{MF}->pack(-side => 'top', -fill => 'both', -expand => 1);
  
  
  $self->{BALLOON} = $self->{TW}->Balloon(-statusbar => $self->{STATUSBAR});
  1;
}

#######################################################
sub QUIT {
  my $self = shift;
  $self->{TW}->destroy;
}

#####################################################################
sub THAW {
  my $self = shift;
  
  open(TXT, $self->ini_file) || return;
  my $data='';
  while (<TXT>) {
    $data .= $_;
  }

  close(TXT);
  
  return unless $data;
  
  my @DATA = ();
  
  eval{(@DATA) = thaw($data);};
  
  return if $@;
  
  $self->ShowMsg("config loaded from ".$self->ini_file);
  
  $self->load(\@DATA);
}

#####################################################################
sub FREEZE {
  my $self = shift;
  
  my $vars = [];
  $self->store($vars);
  my $data = freeze(@$vars);
  
  open(TXT, ">".$self->ini_file) || return;
  print TXT $data;
  close(TXT);
}

######################################################################
sub store($$) {
 my ($self,$vars) = @_;
# $self->SUPER::store($vars);
 push @$vars, $self->{TITLE};
 push @$vars, $self->{FONT};
 push @$vars, $self->{FIXFONT};
 
};

######################################################################
sub load($$) {
  my ($self,$vars) = @_;
  # $self->SUPER::load($vars);
  $self->{TITLE}   = shift (@$vars) || 'TkApplication';
  $self->{XFONT}    = shift (@$vars) || '-*-Arial-Medium-R-Normal--*-140-*-*-*-*-*-*';
  $self->{XFIXFONT} = shift (@$vars) || '-*-Courier-*-*-*--*-160-*-*-*-*-*-*';
}

#######################################################
sub ini_file {
  my $self = shift;
  
  # sourceExe comes from perl2exe...
  my $path = $ENV{sourceExe} || $0;
  
  $path =~ s/\\/\//g;
  $path =~ s/\/[^\/]+$//;
  
  if ($^O =~ /win/i) {
    return "$path/".$self->{APPNAME}.'.ini'; 
  } else {
    return $ENV{HOME}.'/.'.$self->{APPNAME}; 
  }
}
#######################################################
sub create_statusbar {
  my $self = shift;
  my $feedback = $self->{TW}->Frame();
  $feedback->pack(-side => 'bottom', -fill => 'x');
  $self->{STATUSBAR} = $feedback->Label(
					-relief      => 'sunken',
					-height      => 1,
					-background  => 'gray',
					-borderwidth => 2,
					-anchor      => 'w',				   
				       );
  $self->{STATUSBAR}->pack(-side => 'left', -fill => 'x', -expand => 1);
}

#######################################################
sub NotDone {
  my $self = shift;
  print "Do NIL\n";
}

#######################################################
# Just an example, overwrite it!
sub create_menubar {
  my $self = shift;
  
  $self->mkmb('File', 0, 'File related stuff',
	      [
	       ['Open',      \&NotDone,     0],
	       ['New',       \&NotDone,     0],
	       ['Print',     \&NotDone,     0],
	       ['Exit',      sub{ $self->QUIT},        0],
	      ]);
  
  $self->mkmb('Help', 0, 'There when you need it',
	      [
	       ['About..',   \&NotDone,     0],
	       ['Intro',     \&NotDone,     0],
	       ['Contents',  \&NotDone,     0],
	      ],'right');
  
}

#######################################################
sub ShowMsg {
  my $self = shift;
  my $msg  = shift;
  $self->{STATUSBAR}->configure(-text=>$msg);  
  $self->{STATUSBAR}->update;
}

#######################################################
sub ClearMsg {
  my $self = shift;
  $self->ShowMsg('');
}

#######################################################
sub mkmb {
  
  # (Ripped from nTk examples)
  # Make a Menubutton widget; note that the menu is automatically created.  
  # We maintain a list of the Menubutton references since some callers 
  # need to refer to the Menubutton, as well as to suppress stray name 
  # warnings with Perl -w.
  
  require Tk::Menubutton;
  
  my $self = shift;
  my($mb_label, $mb_label_underline, $mb_msg, $mb_list_ref, $side) = @_;
  my $mb = $self->{MENUBAR}->Menubutton(
					-text       => $mb_label, 
					-underline  => $mb_label_underline,
				       );
  my($menu) = $mb->Menu(-tearoff => 0);
  $mb->configure(-menu => $menu);
  
  my $mb_list;
  foreach $mb_list (@{$mb_list_ref}) {
    if ($mb_list->[0] eq '-') {
      $mb->separator; 
    } else {
      $mb->command(
		   -label      => $mb_list->[0], 
		   -command    => $mb_list->[1] , 
		   -underline  => $mb_list->[2], 
		   -font       => $self->{FONT},
		  );
    }
  }
  $mb->pack( -side => $side || 'left');
  $self->{TW}->bind($mb, '<Enter>' => sub { $self->ShowMsg($mb_msg)} );
  $self->{TW}->bind($mb, '<Leave>' => sub { $self->ClearMsg});
  
  $self->{MButtons}->{$mb_label} = $mb;
  return $mb;
  
}				# end mkmb

###########################################################
sub MsgBox {
  my $self = shift;
  $self->{TW}->messageBox(
			  -message => shift,
			  -icon => shift || 'error', 
			  -type => shift || 'OK',
			  -title => shift || $self->{TITLE},
			 );   
}

###########################################################
sub ErrorMsgBox {
  my $self = shift;
  $self->MsgBox(shift,'error','OK');
}

###########################################################
sub InfoMsgBox {
  my $self = shift;
  $self->MsgBox(shift,'info','OK');
}

###########################################################
sub attach_balloon {
  my $self = shift;
  my $obj  = shift || return;
  $self->{BALLOON}->attach($obj,
			   -msg => shift,
			   -statusmsg => shift,  
			   );
}
###########################################################
1;