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

use AddINC qw(. ./blib);

use Tk qw(exit $tk_library $tk_version $tk_patchLevel);

use Pretty ; 

sub findINC
{
 my $what = shift;
 my $dir  = (grep(-r "$_/$what",@INC))[0];
 return "$dir/$what";
}

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

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

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

sub send_test 
{
 my $result = eval { Tk::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->ScrolledListbox("-selectmode"=>"extended");
 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->configure("-menu",$fm);
 $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 { Tk->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"  => [ sub { &back_trace(); die "Test of error handler" }, 1, 2],"-underline" => 0);
 $file->command("-label","Trace","-command" => \&back_trace,"-underline" => 0);
 $file->command("-label","Send","-command"  => \&send_test );
 $file->command("-label","Interps", "-underline" => 0,
   "-command"  =>  sub { print 'Interps(',join(',',Tk->interps),")\n" } );

 $file->pack("-side" => "left");
 $menu->pack("-side" => "top");
 return $menu;
}

sub entry_check
{
 my ($i);
 for ($i = 0; $i < $entry->width; $i++)
  {
   my $cur = $entry->index('@'.$i);
   print "$i => $cur\n";
  }
}

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

sub popdown
{
 my $w = shift;
 my $top = $w->MainWindow;
 $top->configure("-cursor"=> $w->{Cursor});
 $w->grab("release");
 $w->wm("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;
}

$top = MainWindow->new();

print "tk_library = $tk_library
tk_version=$tk_version
tk_patchLevel = $tk_patchLevel\n";


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

&menubar($top);

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

&button($top,"-image",$QuitPB,"-activeimage",$QuitPBa,
        "-command", sub { Tk->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\n"});
&button($top,"-text","Chop","-command", sub { chop($fred) });

$main::Water = 1;


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

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

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

$pic = $top->Photo("-file" => findINC("Tk/demos/images/teapot.ppm"));

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

$p = &button($top,"-text" => "popup picture", "-command" => [ \&popup , $d ]);


#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",'@'.findINC("Tk.xbm"));

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

Tk->update("idletasks");

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

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

Tk::MainLoop();

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