#!/usr/local/bin/perl

# use Memory (2440);

# BEGIN { $ENV{'PERL_DL_NONLAZY'} = 1 }

use Carp;

$SIG{__DIE__} = sub { print "die ",shift,"\n" };


use Tk qw(exit);
# use Tk::Xrm;

use Tk::widgets qw(Button Label Menu Photo Optionmenu Pixmap);
use Tk::widgets qw(ErrorDialog Checkbutton Radiobutton Entry Message Listbox);


use Config;

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
{
 return shift->Button(@_)->pack(-side => 'left');
}

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

sub radiobutton
{
 my $top = shift;
 my $b = $top->Radiobutton(@_);
 $b->pack(-side => 'left');
 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;
 require Tk::Menubar;
 my $menu = $top->Menubar;
 my $file = $menu->Menubutton("-text" => "File","-underline" => 0, -bg => 'ivory',
            -tearoff => 0
           );
 $file->command("-label","Save","-command" => sub { print "Save\n" },"-underline" => 0);
 $file->command("-label","Delete","-command" => sub { print "Delete\n" },"-underline" => 0);
 $file->separator;
 $file->command("-label","Quit","-command" => sub { $top->destroy },"-underline" => 0);
 $file->pack("-side" => "left");

 $file = $menu->Menubutton(-text => "Options", -underline => 0, -font => 'fixed');

 $file->checkbutton('-label' => 'Strict ~Motif', '-variable' => 'Tk::strictMotif');

 $file->separator;
 $file->checkbutton('-label' => 'Oil checked', '-variable' => 'main::oil');
 $file->checkbutton('-label' => 'Water checked', '-variable' => \$Water);
 $file->cget('-menu')->bind('<ButtonRelease-1>',sub {print "Hey\n";});
 $file->command("-label","Interps", "-underline" => 0,
   "-command"  =>  sub { print 'Interps(',join(',',$file->interps),")\n" } );
 $file->pack("-side" => "left");

 $file = $menu->Menubutton(-text => "Exceptions",  -underline => 0);

 $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->pack("-side" => "left");

 my $help = $menu->Menubutton(-text => 'Help', -underline => 0,
                              -menuitems => [[ Command => '~Versions', -command => [\&ShowVersion, $top ]]]
                             );
 $help->pack(-side => 'right');
 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->cget("-cursor");
 $top->configure("-cursor"=>"watch");
 print "Event ",$Tk::event,"\n";
 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",-screen => $ENV{'DISPLAY'});
 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();

$con = $top->Scrolled('Text', -height => 6)->pack(-side => 'bottom', -fill => 'x');

tie *STDOUT,Tk::Text,$con->Subwidget('text');
tie *STDERR,Tk::Text,$con->Subwidget('text');

$top->optionAdd($top->Name.'*Dialog*Background', 'yellow');

$Tk::_mw_ = $top;

$top->bind('MainWindow','<Map>',
            sub {
                 printf "Mapped %.3g Sec. after bootstrap (u=%.3g s=%.3g)\n",Tk::Time_So_Far,times;
                 printf("%gK\n",Memory->used/1024) if (defined &Memory::used);
                 system("/bin/ps","-o",'vsz,osz,rss,pmem,time','-p',$$) if ($^O eq 'solaris');
                }
          );

$camel   = $top->Photo('-file'  => Tk->findINC("Xcamel.gif"));

# print "camel is ",$camel->width," wide\n";

if (@ARGV)
 {
  $top->CmdLine;
  print "ARGV now ",join(' ',@ARGV),"\n"
 }

sub ShowVersion
{my ($top) = @_;
 my $d = $top->Dialog(-title => 'Versions',
                      -popover => $top,
                      -image => $camel,
                      -text =>
"Core Tk version : $Tk::version
Tk patchLevel : $Tk::patchLevel
library : $Tk::library
perl/Tk Version : $Tk::VERSION\n",-justify => 'center');
 $d->Show;
}


$fred = "Initial Text";
$oil  = 1;
my $bl = $top->Balloon;

&menubar($top);

my $bf = $top->Frame->pack(-fill => 'x');

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

my $be = $bf->BrowseEntry(-variable => \$option )->pack(-side => 'right');
$be->insert('end',qw(one two three four));

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

my $q = &button($bf,"-image",$QuitPB,"-activeimage",$QuitPBa,
        "-command", sub { $top->destroy });
$bl->attach($q, -msg => "Exit Application");

&button($bf,"-text","Push me","-command",
         [ sub {print "push(",join(',',@_),")\n"}, 1, Two , "iii" ]);
&checkbutton($bf,"-text","oil","-variable",\$oil);
&checkbutton($bf,"-text","water","-variable",main::Water);
&radiobutton($bf,"-text","one","-variable",\$option,"-value"=>"one");
&radiobutton($bf,"-text","two","-variable",\$option,"-value"=>"two");
&radiobutton($bf,"-text","three","-variable",\$option,"-value"=>"three");
&button($bf,"-text","State","-command",
         sub {print "water=$main::Water oil=$oil option=$option\n"});
&button($bf,"-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");


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

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

$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 });

# Check that we have not broken array context again...

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

$top->Icon(-image => $camel);

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

$top->update("idletasks");

if (open(Gibberish,"</dev/tty"))
 {
  $top->fileevent(Gibberish,'readable',[sub { my ($fh) = @_; print "stdin:",scalar <$fh> },\*Gibberish]);
 }
else
 {
  warn "Cannot open /dev/tty:$!";
 }

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

Tk::MainLoop();