#!/usr/local/bin/perl -w

use strict;

use lib (qw(./blib .));

use Tk;
use Carp;

use Tk::Pretty ; 
require Tk::ErrorDialog;

# print Pretty([1,2,[3,4],{one,[2,3]}],Fred,\&pretty),"\n";

my ($rubbish,$option);


sub showbinding
{
 my $w = shift;
 foreach ($w->bind())
  {
   print "$w $_ = ",$w->bind($_),"\n";
  }
}

sub test_back_trace
{
 my ($w,$count) = @_;
 if ($count)
  {
   test_back_trace($w,$count-1);
  }
 else
  {
   $w->BackTrace("Moan");
  }
}

sub back_trace
{
 my @info;
 my $i = 0;
 while (@info = caller($i))
  {
   print "$i: ",join(' ',@info),"\n";
   $i++;
  }
}

sub send_test 
{
 my ($w) = @_;
 my $result = eval { $w->send('basic_demo',"Hi there") };
 die "Send failed '$@'" if ($@);
 print "Send returned '$result'\n";
}

sub entry 
{
 my $top = shift;
 my $scroll = shift;
 my $f  = ($scroll) ? $top->Frame() : $top;
 my $e  = $f->Entry(relief =>"ridge",@_);
 $e->pack(side =>"top",fill =>"x",expand =>"yes");
 $e->bind("<Any-Enter>", sub { shift->focus() });
 $e->bind("<Any-FocusIn>",  sub { shift->configure(relief => "sunken") });
 $e->bind("<Any-FocusOut>", sub { shift->configure(relief => "ridge" ) });
 if ($scroll)
  {
   my $es = $f->Scrollbar(orient =>"horizontal",command =>["view",$e]);
   $e->configure(scrollcommand =>["set",$es]); 
   $es->pack(side =>"bottom",fill =>"x");
   $f->pack(side =>"top");
  }
 return $e;
}

sub listbox
{
 my $top = shift;
 my $l = $top->ScrlListbox(selectmode =>"extended",'label' => 'Listbox');
 foreach (@_) 
  {
   $l->insert("end", "item" . $_);
  }
 $l->pack(side =>"top",fill =>"both",expand =>"yes");
 return $l;
}

sub button
{
 my $top = shift;
 my $b = $top->Button(@_);
 $b->pack(side =>"top");
 return $b;
}

sub checkbutton
{
 my $top = shift;
 my $b = $top->Checkbutton(@_);
 $b->pack(side =>"top");
 return $b;
}

sub radiobutton
{
 my $top = shift;
 my $b = $top->Radiobutton(@_);
 $b->pack(side =>"top");
 return $b;
}

sub label 
{
 my $top = shift;
 my $w = $top->Label((@_) ? @_ : (text => "A Label") );
 $w->pack(side =>"bottom",fill =>"x");
 return $w;
}

sub message
{
 my $top = shift;
 my $w = $top->Message(text =>"Press keys in blue square");
 configure $w foreground =>"blue";
 $w->pack(fill =>"x");
 return $w;
}

sub keys
{my $top = shift;
 my $w = $top->Frame(width =>40, height =>40,relief => "ridge", 
                     background => "blue", border => 7,
                     takefocus => 1);
 $w->bind("<Enter>", "focus");
 $w->bind("<FocusIn>", 'NoOp');
 $w->bind("<Any-Escape>",  sub { shift->toplevel->destroy()});
 $w->bind("<Any-KeyPress>",
      sub { my $w = shift;
            my $e = $w->XEvent;
            # print "Key(",join(',',@_),")\n";
            my $K = $e->K();
            my $A = $e->A();
            print "press $K $A\n" 
          });
 $w->pack;
 return $w;
}


sub menubar
{my $top  = shift;
 my $menu = $top->Frame();
 my $file = $menu->Menubutton(text => "File",underline => 0);
 $file->command('label' =>"Save",command => sub { print "Save\n" },underline => 0);
 $file->command('label' =>"Delete",command => sub { print "Delete\n" },underline => 0);
 $file->command('label' =>"Quit",command => sub { $top->destroy },underline => 0);
 $file->checkbutton('label' => 'Oil checked', variable => \$rubbish);
 $file->checkbutton('label' => 'Checked Oil', variable => \$rubbish);
 $file->separator;
 $file->command('label' =>"Exit",command => sub { exit 0 },underline => 0);
 $file->command('label' =>"Close",command => sub { close Gibberish },underline => 0);
 $file->command('label' =>"Moan",command => [ \&test_back_trace, $file, 3 ],underline => 0);
 $file->command('label' =>"Trace",command => \&back_trace,underline => 0);
 $file->command('label' =>"Send",command => [\&send_test,$top] );
 $file->command('label' =>"Interps", underline => 0,
   command =>  sub { print 'Interps(',join(',',$file->interps),")\n" } );

 $file->pack(side => "left");
 $file->cget('menu')->bind('<ButtonRelease-1>',sub {print "Hey\n";});
 $menu->pack(side => "top");
 return $menu;
}

sub popup 
{my $w = shift;
 my $e = $w->XEvent;
 my $top = $w->MainWindow;
 $w->{Cursor} = $top->cget("cursor");
 $top->configure(cursor =>"watch");
 if (defined $e)
  {
   $w->wm("geometry",$e->X . "x" . $e->Y);
  }
 $w->deiconify;
 $w->update;
 $w->grab;
}

sub popdown
{
 my $w = shift;
 my $top = $w->MainWindow;
 $top->configure(cursor => $w->{Cursor});
 $w->grab("release");
 $w->withdraw;
}


sub dialogue
{my $top = shift;
 my $t = $top->Toplevel(class =>"Dialogue");
 my $l = &label($t,@_);
 my $b = &button($t,text =>"OK",command =>[ \&popdown ,$t]);
 $t->wm("group",$top);
 $t->wm("transient",$top);
 $t->wm("withdraw");
 $t->wm("minsize",0,0);
 $l->pack(side => "top", expand => 1, fill => "both"); 
 $b->pack(side => "bottom");
 $t->wm("protocol","WM_DELETE_WINDOW",[\&popdown,$t]);
 return $t;
}

my $top = MainWindow->new();
$top->CmdLine;

print "version=$Tk::version
patchLevel = $Tk::patchLevel
Version = $Tk::Version\n";


my $fred = "Initial Text";
my $opt  = 1;
my $oil  = 1;

&menubar($top);

$top->Optionmenu(textvariable => \$option, 
                 options => [qw(one two three four)],
                 command => sub { print "Optionmenu set to: ",shift,"\n"}
                )->pack;


my $QuitPB  = $top->Pixmap(-file => "./Tk/demos/images/QuitPB.xpm");
my $QuitPBa = $top->Pixmap(-file => "./Tk/demos/images/QuitPBa.xpm");

&button($top,image =>$QuitPB,activeimage =>$QuitPBa,
        command => sub { $top->destroy });
&button($top,text =>"Push me",command =>
         [ sub {print "push(",join(',',@_),")\n"}, 1, 'Two' , "iii" ]);
&checkbutton($top,text =>"oil",variable =>\$oil);
&checkbutton($top,text =>"water",variable => "main::Water");
&radiobutton($top,text =>"one",variable =>\$opt,value =>1);
&radiobutton($top,text =>"two",variable =>\$opt,value =>2);
&radiobutton($top,text =>"three",variable =>\$opt,value =>3);
&button($top,text =>"State",command =>
         sub {print "water=$main::Water oil=$oil option=$opt menu=$option\n"});
&button($top,text =>"Chop",command => sub { chop($fred) });

$main::Water = 1;


my $entry = &entry($top,0,width =>"30",textvariable =>\$fred);
&message($top);
&keys($top);
&label($top,bitmap =>"info");

my $p = &button($top,text => "Strict Motif", command => sub { $Tk::strictMotif = !$Tk::strictMotif });

my $l = &listbox($top,1..25);
&button($top,bitmap =>'@'.Tk->findINC("demos/images/c.icon"),command => [ sub { shift->SetList(<*.c>) }, $l ] );

my $pic = $top->Photo(-file => Tk->findINC("demos/images/earthris.gif"));

my $d = dialogue($top, image => $pic );

$p = &button($top,text => "popup picture", command => [ \&popup , $d ]);
$p = &button($top,text => "bisque", command => [ 'bisque', $top ]);
$p = &button($top,text => "Busy", 
     command => sub { $top->Busy; $top->after(5000); $top->Unbusy });

#foreach (Tk::bind("Tk::Menu"))
# {
#  print "bind(",Pretty($_),":",Pretty(Tk::bind("Tk::Menu",$_)),")\n"; 
# }


#print "     cget:",Pretty($p->cget("command")),")\n"; 
#print "configure:",Pretty($p->configure("command")),")\n"; 


# Check that we have not broken array context again...
print &Pretty(configure $p "background"),"\n";

# print join(',',$top->children),"\n";


$top->wm("minsize",0,0);
$top->wm("iconbitmap",'@'.Tk->findINC("Tk.xbm"));

$top->property("set",'MYPROP','AREA',32,[1,2,3,4,5]);

$top->update("idletasks");

open('Gibberish',"</dev/tty") || die "Cannot open /dev/tty:$!";

$top->fileevent('Gibberish','readable',[sub { local (*FH) = @_; print "stdin:",scalar <FH> },*Gibberish]);

# print "Buttons: ",join(',',map($_->PathName,$top->decendants('Button'))),"\n";
# print "packinfo: ",join(',',$l->packInfo),"\n";

Tk::MainLoop();

#foreach (keys %$top)
# {
#  print "$_ = ",Pretty($top->{$_}),"\n";
# }
