The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/tools/local/perl -w
use strict;
use Tk;
my $mw  = MainWindow->new;
my @but;
my @tab;

use Carp;
#$SIG{__WARN__} = \&Carp::confess;

my $page = 0;
my $pagehex = '0x00';
my $l = $mw->Label(-text => 'Page:',-justify => 'right',-anchor => 'e');
my $s = $mw->Spinbox(-width => 4, -to => 255, -from => 0, -format => "%3.0f", -textvariable => \$page,-justify => 'left');
my $h = $mw->Label(-width => 4, -textvariable => \$pagehex, -justify => 'left');
Tk::grid($l,$s,$h);
$s->configure(-command =>\&set_page);
my $uf = $mw->fontCreate(-family => 'lucida sans', -size => 16);
my $lf = $mw->fontCreate(-family => 'courier', -size => 12);
print join(' ',$mw->fontActual($uf)),"\n";
my @h;
my @lab;
push @h,$mw->Label(-text => '');
for my $i (0x0..0xf)
 {
  my $l = $mw->Label(-text => sprintf("0x%04X",$i), -font => $lf,
          -justify => 'c', -anchor => 'c', -relief => 'ridge');
  push(@h,$l);
 }
Tk::grid(@h,-sticky => 'nsew');
for my $i (0x00..0xff)
 {
  my $s = chr($i);
  my $b = $mw->Button(-text => $s, -font => $uf, -justify => 'c', -anchor => 'c');

  push(@but,$b);
  push(@tab,$b);
  if ($i % 16 == 15)
   {
    my $l = $mw->Label(-text => sprintf("0x%03X",$i & 0xF0), -font => $lf,
                 -justify => 'c',  -relief => 'ridge');
    push(@lab,$l);
    Tk::grid($l,splice(@but,0,16),-sticky => 'nsew');
   }
 }
set_page($s);
$mw->update;
$mw->gridPropagate(0);
MainLoop;

sub set_page
{
 my ($e) = @_;
 $pagehex = sprintf("0x%02X",$page);
 for my $i (0..0xf)
  {
   $lab[$i]->configure(-text => sprintf("0x%04X",($page<<8)+($i<<4)));
  }
 for my $i (0x00..0xFF)
  {
   my $b = $tab[$i];
   my $u = ($page<<8) | $i;
   my $c = chr($u);
   my $s = $c; # "$c\n".sprintf("%02X",$i);
#  die "bug $i" unless utf8::valid($s);
   $b->configure(-text => $s);
  }
}