#!/usr/local/bin/perl
# use Memory (2440);
# BEGIN { $ENV{'PERL_DL_NONLAZY'} = 1 }
use Carp;
$SIG{__DIE__} = \&Carp::confess;
use Tk qw(exit);
# use Tk::Xrm;
use Tk::widgets qw(Button Label Menu Photo Optionmenu Pixmap Balloon);
use Tk::widgets qw(Scrollbar Checkbutton Radiobutton Entry
                   Message BrowseEntry 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], -width => '4m');
   $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',-takefocus => 1);
 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 $s = $e->s();
            my $K = $e->K();
            my $A = $e->A();
            my $k = $e->k();
            my $c = chr($k);
            print "press $s$K ($k) '$c' $A\n"
          });
 $w->pack();
 return $w;
}
sub menubar
{my $top  = shift;
 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 = $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);
 my $om = $file->cget('-menu');
 $om->bind('<ButtonRelease-1>',[ sub {my ($b,$arg,$orig) = @_; print "Hey ",join(' ',map($_->PathName,$b,$arg),$orig),"\n";}, $om, $om->PathName] );
 $file->command("-label","Interps", "-underline" => 0,
   "-command"  =>  sub { print 'Interps(',join(',',$file->interps),")\n" } );
 $file = $menu->Menubutton(-text => "Exceptions",  -underline => 0);
 $file->command("-label","Busy","-command"  => \&MakeBusy,"-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, $menu, 3 ],"-underline" => 0);
 $file->command("-label","Trace","-command" => \&back_trace,"-underline" => 0);
 $file->command("-label","Wrong","-command" => sub { $top->configure(-gibberish => 'junk') });
 $file->command("-label","Send","-command"  => [\&send_test,$top] );
 $menu->separator;
 $menu->cascade(-label => 'Other', -underline => 1,
                              -menuitems => [[ Command => '~Busy',
                               -command => \&MakeBusy]]
                             );
 $menu->cascade(-label => 'Help', -underline => 0,
                              -menuitems => [[ Command => '~Versions', -command => [\&ShowVersion, $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->cget("-cursor");
 $top->configure("-cursor"=>"watch");
 $w->Popup(-popover => $top, -popanchor => 'c', -overanchor => 'c');
 $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();
$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(-format => 'gif', -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,
                      -fg  => '#800000',
                      -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');
my $bigfont = "-Adobe-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*";
my $om = $bf->Optionmenu(-textvariable => \$option, -font => $bigfont,
                 -options => [qw(one two three four)],
                 -command => sub { print "Optionmenu set to: ",shift,"\n"}
                )->pack(-side => 'right');
my $f = $om->cget('-font');
my $ps;
my $sz = $f->PostscriptFontName($ps);
print "Font is $f $$f $ps ($sz)\n";
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,-command => \&MakeBusy);
&checkbutton($bf,"-text","water","-variable",main::Water);
&radiobutton($bf,"-text","one","-variable",\$option,"-value"=>"one",-command => \&MakeBusy);
&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" => \&MakeBusy);
sub MakeBusy
{
 $top->Busy(-recurse => 1);
 warn "Waiting\n";
 my $done = 0;
 $top->after(6000, sub { $done = 1; warn "Fired\n" });
 Tk::DoOneEvent(0) until ($done);
 $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 ($^O ne 'MSWin32')
 {
  if (open(Gibberish, '<&STDIN'))
   {
    $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();