#!/usr/bin/perl

require 5.008;
use strict;
use warnings;
use Tk;
use Tk::Pane;
use Tk::Text;
use Tk::BrowseEntry;
use Tk::Balloon;
use charnames();

use constant OS_Win => $^O =~ /Win/;

die "You need to upgrade to a later version of Perl/Tk.\n"
  unless ( $Tk::version ge 8.4 );

my ( $fontname, $fontsize ) = ( 'Times', 16 );
my $font        = "{$fontname} $fontsize";
my $activecolor = '#abcdef';
my ( $globalx, $globaly );
my $utftop;

my $top = MainWindow->new;

my $dragimg = $top->Photo(
    -format => 'gif',
    -data   =>
'R0lGODlhDAAMALMAAISChNTSzPz+/AAAAOAAyukAwRIA4wAAd8oA0MEAe+MTYHcAANAGg
+nsAAGAA
AAAAACH5BAAAAAAALAAAAAAMAAwAAwQfMMg5BaDYXiw178AlcJ6VhYFXoSoosm7KvrR8zf
+XHRQA7'
);

my $text = $top->Scrolled(
    'Text',
    -exportselection => 'true',
    -scrollbars      => 'se',
    -background      => 'white',
    -font            => "{$fontname} 14"
  )->pack(
    -expand => 1,
    -fill   => 'both',
  );

my $menu = $text->Menu( -type => 'menubar' );

$top->configure( -menu => $menu );

$menu->Button( -label => 'Unicode-Character-Search', -command => \&uch
+ar );

drag($text);

MainLoop;

sub uchar {
    if ( defined $utftop ) {
        $utftop->deiconify;
        $utftop->raise;
    }
    else {
        require q(unicore/Blocks.pl);
        require q(unicore/Name.pl);
        my $utftop = $top->Toplevel;
        $utftop->title('Find A Unicode Character');
        $utftop->geometry('550x400');

        my ( %blocks, $sizelabel, @textchars, @textlabels );

        for ( split /\n/, do 'unicore/Blocks.pl' ) {
            my @array = split /\t/, $_;
            $blocks{ $array[2] } = [ @array[ 0, 1 ] ];
        }

        my $button_frame = $utftop->Frame->pack;
        my $search_frame = $utftop->Frame->pack(
            -side   => 'top',
            -anchor => 'n',
            -pady   => 4
        );

        my $pane = $utftop->Scrolled(
            'Pane',
            -background => 'white',
            -scrollbars => 'se',
            -sticky     => 'wne',
          )->pack(
            -expand => 'y',
            -fill   => 'both',
            -anchor => 'nw'
          );

        drag($pane);

        my $fontlist = $button_frame->BrowseEntry(
            -label     => 'Font',
            -browsecmd => sub { font_propagate( \@textchars ) },
            -variable  => \$fontname,
          )->grid(
            -row    => 1,
            -column => 1,
            -padx   => 8,
            -pady   => 2
          );

        $fontlist->insert( 'end', sort( $top->fontFamilies ) );

        my $bigger = $button_frame->Button(
            -activebackground => $activecolor,
            -text             => 'Bigger',
            -command          => sub {
                $fontsize++;
                font_propagate( \@textchars );
                $sizelabel->configure( -text => $fontsize );
            },
          )->grid(
            -row    => 1,
            -column => 2,
            -padx   => 2,
            -pady   => 2
          );

        $sizelabel = $button_frame->Label( -textvariable => \$fontsize
+ )->grid(
            -row    => 1,
            -column => 3,
            -padx   => 2,
            -pady   => 2
        );
        my $smaller = $button_frame->Button(
            -activebackground => $activecolor,
            -text             => 'Smaller',
            -command          => sub {
                $fontsize--;
                font_propagate( \@textchars );
                $sizelabel->configure( -text => $fontsize );
            },
          )->grid(
            -row    => 1,
            -column => 4,
            -padx   => 2,
            -pady   => 2
          );

        $search_frame->Label( -text => 'Search Characteristics ', )->g
+rid(
            -row    => 1,
            -column => 1
        );

        my $characteristics = $search_frame->Entry(
            -width      => 40,
            -background => 'white'
          )->grid(
            -row    => 1,
            -column => 2
          );

        my $doit = $search_frame->Button(
            -text    => 'Search',
            -command => sub {
                for ( @textchars, @textlabels ) {
                    $_->destroy;
                }
                my $row = 0;
                @textlabels = @textchars = ();
                my @searches = split /\s+/, uc( $characteristics->get 
+);
                my @lines    = split /\n/,  do 'unicore/Name.pl';
                while (@lines) {
                    my @char_info = split /\t+/, shift @lines;
                    my ( $ord, $name ) = ( $char_info[0], $char_info[-
+1] );
                    last if ( hex $ord > 65535 );
                    my $count = 0;
                    for my $search (@searches) {
                        $count++;
                        last unless $name =~ /\b$search\b/;
                        if ( @searches == $count ) {
                            my $block = '';
                            for ( keys %blocks ) {
                                if (   hex( $blocks{$_}[0] ) <= hex($o
+rd)
                                    && hex( $blocks{$_}[1] ) >= hex($o
+rd) )
                                {
                                    $block = $_;
                                    last;
                                }
                            }
                            $textchars[$row] = $pane->Label(
                                -text       => chr( hex $ord ),
                                -font       => $font,
                                -background => 'white',
                              )->grid(
                                -row    => $row,
                                -column => 0,
                                -padx   => 4,
                              );

                            $textlabels[$row] = $pane->Label(
                                -text => "$name  -  Ordinal $ord  -  $
+block",
                                -background => 'white',
                              )->grid(
                                -row    => $row,
                                -column => 1,
                                -sticky => 'w'
                              );

                            utfchar_bind( $textchars[$row] );
                            utflabel_bind(
                                $textlabels[$row],  $block,
                                $blocks{$block}[0], $blocks{$block}[1]
                            );
                            $row++;
                            $utftop->update;
                        }
                    }
                }
            },
          )->grid(
            -row    => 1,
            -column => 3
          );

        $characteristics->bind( '<Return>' => sub { $doit->invoke } );
    }
}

sub utflabel_bind {
    my ( $widget, $block, $start, $end ) = @_;
    $widget->bind( '<Enter>',
        sub { $widget->configure( -background => $activecolor ); } );
    $widget->bind( '<Leave>',
        sub { $widget->configure( -background => 'white' ); } );
    $widget->bind(
        '<ButtonPress-1>',
        sub {
            $widget->toplevel->Busy( -recurse => 1 );
            utfpopup( $block, $start, $end );
            $widget->toplevel->Unbusy( -recurse => 1 );
        }
    );
}

sub utfchar_bind {
    my $widget = shift;
    $widget->bind( '<Enter>',
        sub { $widget->configure( -background => $activecolor ); } );
    $widget->bind( '<Leave>',
        sub { $widget->configure( -background => 'white' ) } );
    $widget->bind(
        '<ButtonPress-3>',
        sub {
            $widget->clipboardClear;
            $widget->clipboardAppend( $widget->cget('-text') );
            $widget->configure( -relief => 'sunken' );
        }
    );
    $widget->bind(
        '<ButtonRelease-3>',
        sub {
            $widget->configure( -relief => 'flat' );
        }
    );
    $widget->bind(
        '<ButtonPress-1>',
        sub {
            $widget->configure( -relief => 'sunken' );
            $text->insert( 'insert', $widget->cget('-text') );
        }
    );
    $widget->bind(
        '<ButtonRelease-1>',
        sub {
            $widget->configure( -relief => 'flat' );
        }
    );
}

sub utfpopup {
    my ( $block, $start, $end ) = @_;

    my ( $sizelabel, @buttons );
    my $rows = ( ( hex $end ) - ( hex $start ) + 1 ) / 16 - 1;

    my $utfpop = $top->Toplevel();
    $utfpop->geometry('600x300+10+10');
    $utfpop->title( $block . ': ' . $start . ' - ' . $end );

    my $balloon = $utfpop->Balloon( -initwait => 750 );

    my $top_frame = $utfpop->Frame->pack;
    my $fontlist  = $top_frame->BrowseEntry(
        -label     => 'Font',
        -browsecmd => sub { font_propagate( \@buttons ) },
        -variable  => \$fontname,
      )->grid(
        -row    => 1,
        -column => 1,
        -padx   => 8,
        -pady   => 2
      );

    my $bigger = $top_frame->Button(
        -activebackground => $activecolor,
        -text             => 'Bigger',
        -command          => sub {
            $fontsize++;
            font_propagate( \@buttons );
            $sizelabel->configure( -text => $fontsize );
        },
      )->grid(
        -row    => 1,
        -column => 2,
        -padx   => 2,
        -pady   => 2
      );

    $sizelabel = $top_frame->Label( -textvariable => \$fontsize )->gri
+d(
        -row    => 1,
        -column => 3,
        -padx   => 2,
        -pady   => 2
    );

    my $smaller = $top_frame->Button(
        -activebackground => $activecolor,
        -text             => 'Smaller',
        -command          => sub {
            $fontsize--;
            font_propagate( \@buttons );
            $sizelabel->configure( -text => $fontsize );
        },
      )->grid(
        -row    => 1,
        -column => 4,
        -padx   => 2,
        -pady   => 2
      );

    $fontlist->insert( 'end', sort( $top->fontFamilies ) );

    my $pane = $utfpop->Scrolled(
        'Pane',
        -background => 'white',
        -scrollbars => 'se',
        -sticky     => 'nswe'
      )->pack(
        -expand => 'y',
        -fill   => 'both'
      );

    drag($pane);

    for my $y ( 0 .. $rows ) {
        for my $x ( 0 .. 15 ) {
            my $name = hex($start) + ( $y * 16 ) + $x;
            my $hex   = uc sprintf "%04x", $name;
            my $msg   = "Dec. $name, Hex. $hex";
            my $cname = charnames::viacode($name);
            $msg .= ", $cname" if $cname;
            $name = 0 unless $cname;
            $buttons[ ( $y * 16 ) + $x ] = $pane->Button(
                -activebackground   => $activecolor,
                -text               => chr($name),
                -font               => $font,
                -relief             => 'flat',
                -borderwidth        => 0,
                -background         => 'white',
                -command            => [ \&pututf, $utfpop ],
                -highlightthickness => 0,
              )->grid(
                -row    => $y,
                -column => $x
              );
            $buttons[ ( $y * 16 ) + $x ]->bind(
                '<ButtonPress-3>',
                sub {
                    $text->clipboardClear;
                    $text->clipboardAppend(
                        $buttons[ ( $y * 16 ) + $x ]->cget('-text') );
                }
            );
            $balloon->attach( $buttons[ ( $y * 16 ) + $x ],
                -balloonmsg => $msg, );
            $utfpop->update;
        }
    }
    $utfpop->protocol(
        'WM_DELETE_WINDOW' => sub { $balloon->destroy; $utfpop->destro
+y; } );
}

sub pututf {
    my $container = shift;
    my @xy        = $container->pointerxy;
    my $widget    = $container->containing(@xy);
    my $letter    = $widget->cget( -text );
    return unless $letter;
    my @ranges = $text->tagRanges('sel');
    $text->delete(@ranges) if @ranges;
    $text->insert( 'insert', $letter );
    $text->focus;
}

sub font_propagate {
    my $array = shift;
    $font = "{$fontname} $fontsize";
    for (@$array) {
        $_->configure( -font => $font );
    }
}

sub drag {
    my $widget = shift;
    my $corner;
    if ( defined $widget->Subwidget('corner') ) {
        $corner = $widget->Subwidget('corner');
    }
    else {
        $corner = $widget->Frame->pack( -side => 'bottom', -anchor => 
+'se' );
    }
    my $corner_label =
      $corner->Label( -image => $dragimg )
      ->pack( -side => 'right', -anchor => 'se' );
    $corner_label->bind(
        '<Enter>',
        sub {
            if (OS_Win) {
                $corner->configure( -cursor => 'size_nw_se' );
            }
            else {
                $corner->configure( -cursor => 'sizing' );
            }
        }
    );
    $corner_label->bind( '<Leave>',
        sub { $corner->configure( -cursor => 'arrow' ) } );
    $corner_label->bind(
        '<1>',
        sub {
            ( $globalx, $globaly ) =
              ( $widget->toplevel->pointerx, $widget->toplevel->pointe
+ry );
        }
    );
    $corner_label->bind(
        '<B1-Motion>',
        sub {
            my $x =
              $widget->toplevel->width - $globalx + $widget->toplevel-
+>pointerx;
            my $y = $widget->toplevel->height - $globaly +
              $widget->toplevel->pointery;
            ( $globalx, $globaly ) =
              ( $widget->toplevel->pointerx, $widget->toplevel->pointe
+ry );
            $widget->toplevel->geometry( $x . 'x' . $y );
        }
    );
}
[download]