use strict;
use warnings;

use Unicode::UCD qw(charinfo charblock charblocks charscripts charscript casespec compexcl);

use POSIX qw(ceil);
use Tk;
use Tk::LabFrame;
use Tk::Balloon;
use Tk::Pane;
use Tk::BrowseEntry;
use Tk::StayOnTop;

# Inits
#
my $VERSION      = '0.01';
my $COPYRIGHT     = 'Copyright 2004 - Chris Whiting. All rights reserved.';

my %common_hash;
my %codepage;
my %codeframe;
my %codeframe_lines;
my %codeframe_btns;
my $current_entity;
my $l_label_width = 6;
my $process_line_no = 0;
my $max_codepoints = 10000;

my %code_labels;
my @hframes;
my @hframes_labels;

my %btns_hash;
my @btns_head;

my %codepage_fonts;
my $codepage_fontfam = 'Arial';
my %bidi;
populate_bidi();

my %uni_category;
populate_category();

my %uni_mirror;
populate_mirrors();

$common_hash{main} = new MainWindow;
$common_hash{main}->configure(-title=>"Codepage - UniCode Version " . Unicode::UCD::UnicodeVersion() );

codepage_display();
MainLoop;

#-----------------------------------
	
sub codepage_display {

my $downarrow_bits = pack("b17"x9,
	".111111111111111.",
	"..1111111111111..",
	"...11111111111...",
	"....111111111....",
	".....1111111.....",
	"......11111......",
	".......111.......".
	"........1........".
	"........1........"
	); 
$common_hash{main}->DefineBitmap("downarrow_Icon" => 17,9, $downarrow_bits);
	  
$codepage{font_name} = codepage_create_font($codepage_fontfam);

$codepage{main} = $common_hash{main}->Frame(#-bg=>'green',
	)->pack(-anchor=>'n', -side=>'top', -fill =>'both', -expand=>1);

$codepage{select_frm} = $codepage{main}->Frame(-bd=>1, -relief=>'groove', #-bg=>'yellow',
	)->pack(-anchor=>'n', -side=>'top', -fill =>'x', ); #-expand=>1

my @listed_charblocks;
my $charblocks = charblocks();
for my $entity (keys %{$charblocks}) {
my $ranges = charblock($entity); my $count = 0;
while (my $range = shift @$ranges){
        $count++;
        if ($$range[0] >= hex $max_codepoints) {
        	#  displaying codepoints above U10000 get an error in Tk.
        	#print "$entity $count (from $$range[0], to $$range[1])";
        	#printf "%06X -> %06X\n", $$range[0], $$range[1];
        	#print "\n";
	}
	else { push @listed_charblocks, $entity; }
    }
}

my $charscripts = charscripts();
#$codepage{select_frm}->Label(-text=>'Blocks')->pack( -side   => 'left', -anchor => 'w', -padx => 10);
$codepage{select_frm}->BrowseEntry(
	-label=>'Blocks',
	-textvariable => \$codepage{block},
	-choices => [ sort @listed_charblocks ], #[sort keys %{$charblocks}],
	-state => 'readonly',
	-command=>sub{
		if ( ($codepage{block} =~ /CJK Unified/) and
			($codepage{main}->messageBox(-type=> "YesNo", -message => "This block is large and may produce unpredictable results.  Continue?")  eq 'No') )
				{return}
		codepage_buttons($codepage{block}, 'charblock');
		#print "current_entity $current_entity codepage{current_entity}{selnbr} $codepage{$current_entity}{selnbr}\n";
		if ($codepage{$current_entity}{selnbr}) 
			{do_button($codepage{$current_entity}{selnbr} , $codepage{$current_entity}{sel_dec_code} ,  '');}
		},
	-disabledbackground=>'white',
	-disabledforeground=>'black',
	-width  => 35,
	-listheight=>20,
	)->pack( -side   => 'left', -anchor => 'w', -padx => 2, -pady => 8);

$codepage{select_frm}->Button(
	-bitmap => "downarrow_Icon",
	#-text=> "\x{25bc}",
	-anchor=>'s',
	-relief => 'flat',
	-command => sub { list_pop(); }
	)->pack(-side => 'left', -anchor=>'s', -ipadx => 2, -ipady => 6);

my @fonts = sort $common_hash{main}->fontFamilies;

my $newfont;
	
my $browsefont = $codepage{select_frm}->BrowseEntry(
	-label=>'Font Family',
	-textvariable => \$codepage_fontfam,
	-choices => [@fonts],
	-state => 'readonly',
	-disabledbackground=>'white',
	-disabledforeground=>'black',
	-browsecmd => sub {
		code_page_button_reconfig($codepage_fontfam);
		},
	-width  => 22,
)->pack( -side   => 'left',  -anchor => 'w', -padx => 0);

$codepage{select_frm}->Button(
	-bitmap => "downarrow_Icon",
	-anchor=>'s',
	-relief => 'flat',
	-command => sub { list_pop2(); }
	)->pack(-side => 'left', -anchor=>'s', -ipadx => 2, -ipady => 6);

$codepage{more_less} = $codepage{select_frm}->Button(-text=>'<<<Less', 
	-command => sub {
		if ( $codepage{more_less}->cget(-text)=~/More/)
			{
			$codepage{more_less}->configure(-text=>'<<<Less');
			$codepage{right_frm}->pack(-anchor=>'w', -side=>'left', -fill =>'both', -expand=>0,);
			}
		else
			{
			$codepage{more_less}->configure(-text=>'More>>>');
			$codepage{right_frm}->packForget;
			}
		},
	)->pack(-side=>'left', );
				
$codepage{main_frm} = $codepage{main}->Frame(#-bg=>'red',
	)->pack(-anchor=>'w', -side=>'top', -fill =>'both', -expand=>1);

$codepage{left_frm} = $codepage{main_frm}->Frame()->pack(-anchor=>'w', -side=>'left', -fill =>'both', -expand=>0,);
	
$codepage{codepage_frm} = $codepage{left_frm}->LabFrame(#-bg=>'blue', 
	-label=>'', -bd=>1,)->pack(-anchor=>'n', -side=>'top', -fill =>'both', -expand=>1);
	
	
$codepage{right_frm} = $codepage{main_frm}->Frame()->pack(-anchor=>'w', -side=>'left', -fill =>'both', -expand=>0,);

	
$codepage{codepoint_btn_frame} = $codepage{right_frm}->LabFrame(
	-label=>'Code Point Search', -bd=>1,
	)->pack(-anchor=>'n', -side=>'top', -fill =>'both', -expand=>0, -ipadx=>10, -ipady=>5);
$codepage{codepoint_btn_frame}->Entry(-textvariable=>\$codepage{search_point},
	-width=>8, )->pack(-side=>'left');
$codepage{search_hex} = 'hexon';
$codepage{codepoint_btn_frame}->Radiobutton(
	-text=>'Hex', -value=>'hexon', -variable=> \$codepage{search_hex},
	)->pack(-side => 'left',  -padx => 5, -pady => 0,);
$codepage{codepoint_btn_frame}->Radiobutton(
	-text=>'Dec', -value=>'hexoff', -variable=> \$codepage{search_hex},
	)->pack(-side => 'left',  -padx => 5, -pady => 0,);	
$codepage{codepoint_btn_frame}->Radiobutton(
	-text=>'Char', -value=>'char', -variable=> \$codepage{search_hex},
	)->pack(-side => 'left',  -padx => 5, -pady => 0,);
		
$codepage{codepoint_btn_frame}->Button(-text=>'Search',
	-command=>sub {
		$codepage{current_button_nbr} = '';
		codepage_clear_ents();
		my $value = $codepage{search_point};
		if ($codepage{search_hex} eq 'char')
			{
			$value = ord($value);
			}
		elsif (($codepage{search_hex} eq 'hexon') and ($value =~ /[^0-9a-fA-F]/))
			{
			$codepage{main}->messageBox(-message => "Search data $value is not a valid hex value");
			codepage_unselect();
			return;
			}				
		elsif ($codepage{search_hex} eq 'hexon')

			{ $value = hex($value) }
		elsif (($codepage{search_hex} eq 'hexoff') and ($value =~ /[^0-9]/))
			{ $codepage{main}->messageBox(-message => "Search data $value is not a valid value");
			codepage_unselect();
			return; 
			}
		my $x = charblock($value);
		if (!$x)
			{
			$codepage{main}->messageBox(-message => "Code Point $value was not found");
			
			codepage_unselect();
			return;
			}
			codepage_buttons($x, 'charblock');
			$codepage{block} = $x;
			if (exists $btns_hash{$current_entity}{ $value }  ) #$btns_hash{$codepage{current_entity}}{$current_dec_code}
				{
				do_button($btns_hash{$current_entity}{$value}, $value, '' );
				}
		},
	-width=>8, )->pack(-side=>'right',-padx=>6);

$codepage{codepoint_byname_frame} = $codepage{right_frm}->LabFrame(
	-label=>'Code Point Search by Name', -bd=>1,
	)->pack(-anchor=>'n', -side=>'top', -fill =>'both', -expand=>0, );
for (0..2) {
	$codepage{codepoint_btn_byname_frame}[$_] = $codepage{codepoint_byname_frame}->Frame(
	)->pack(-anchor=>'n', -side=>'top', -fill =>'both', -expand=>0, );
	}

$codepage{codepoint_btn_byname_frame}[0]->Entry(-textvariable=>\$codepage{search_byname_point},
	-width=>35, )->pack(-side=>'left',-fill=>'x', -expand=>1,);
$codepage{search_byname_type} = 'regexp';
$codepage{codepoint_btn_byname_frame}[1]->Radiobutton(
	-text=>'Regexp', -value=>'regexp', -variable=> \$codepage{search_byname_type},
	)->pack(-side => 'left',  -padx => 10, -pady => 0,);
$codepage{codepoint_btn_byname_frame}[1]->Radiobutton(
	-text=>'Exact', -value=>'exact', -variable=> \$codepage{search_byname_type},
	)->pack(-side => 'left',  -padx => 10, -pady => 0,);
$codepage{codepoint_btn_byname_frame}[1]->Radiobutton(
	-text=>'+-Word Match', -value=>'word', -variable=> \$codepage{search_byname_type},
	)->pack(-side => 'left',  -padx => 10, -pady => 0,);
$codepage{search_from_where} = 'here';
$codepage{codepoint_btn_byname_frame}[2]->Checkbutton(
	-text=>'Start from beginning', -onvalue=>'beg', -offvalue=>'here', -variable=> \$codepage{search_from_where},
	)->pack(-side => 'left',  -padx => 2, -pady => 0,);

		
$codepage{codepoint_btn_byname_frame}[2]->Button(-text=>'Search',
	-command=>sub {
		
		my $start;
		if ($codepage{search_from_where} eq 'beg') {$start = 0}
		elsif ( $codepage{$current_entity}{sel_dec_code} ) { $start = $codepage{$current_entity}{sel_dec_code}}
		else {$start = 0}
		$start++;
		my $testtext = 'abcd';
		my $regexp = $codepage{search_byname_point};
		if (($codepage{search_byname_type} eq 'regexp') and 
			(!defined (eval { $testtext =~ /$regexp/i } ) ))
			{$codepage{main}->messageBox(-message => "Regexp $codepage{search_byname_point} is not valid.");  return; }
		elsif ($codepage{search_byname_type} eq 'exact')
			{ $regexp =~ s/([\[\^\$\-\]\/(){}*+.|?])/\\$1/  }  # \[\^\$\-\]\/(){}*+.|?

		my @word_patterns; my $cnt = 0;
		if	($codepage{search_byname_type} eq 'word')
			{
			my @words = split(/\s+/, $regexp);
			for (@words)
				{
				my $search_word = $_;
				$search_word =~ /^([+-]*)(.*)/;
				($word_patterns[$cnt]{ADDINDR},$word_patterns[$cnt]{WORD}) = ($1,$2);
				$cnt++;
				}
			}
		$codepage{main}->Busy(-recurse=>1);
		for ($start..$max_codepoints)
			{
			my $charinf  = charinfo($_);
			my $name = $charinf->{name};
			if ($name)
				{
				if 	((($codepage{search_byname_type} eq 'regexp') and
					( $name =~ /$regexp/i)) or
					(($codepage{search_byname_type} eq 'exact') and
					( $name =~ /$regexp/i)))
					{
					$codepage{block} = charblock($_);
					codepage_buttons($codepage{block}, 'charblock');
					do_button($btns_hash{$current_entity}{$_}, $_, '' );
					$codepage{main}->Unbusy(-recurse=>1);
					return;
					}
				elsif	($codepage{search_byname_type} eq 'word')
					{
					my $neg_match = 1;
					my $match = 1;
					$cnt = 0;
					
					do
						{
						if (($word_patterns[$cnt]{ADDINDR} eq '-') and ($name =~ /$word_patterns[$cnt]{WORD}/i ) )
							{ $neg_match = 0;  }
						elsif ($word_patterns[$cnt]{ADDINDR} eq '-') {}
						elsif ($name !~ /$word_patterns[$cnt]{WORD}/i )
							{ $match = 0;  }
						$cnt++;
						} until ($cnt > $#word_patterns);
					if ($neg_match and $match)
						{
						$codepage{block} = charblock($_);
						codepage_buttons($codepage{block}, 'charblock');
						do_button($btns_hash{$current_entity}{$_}, $_, '' );
						$codepage{main}->Unbusy(-recurse=>1);	
						return;
						}
					}
				}
			}
		$codepage{main}->Unbusy(-recurse=>1);	
		$codepage{main}->messageBox(-message => "Search for $codepage{search_byname_point} was not successful.");
		},
	-width=>8, 
	)->pack(-side=>'right',-padx=>6);

$codepage{code_frm} = $codepage{right_frm}->LabFrame(
	-label=>'Code Point Details', -bd=>1,)->pack(-anchor=>'w', -side=>'top', -fill =>'both', -expand=>1, -ipady=>5);

$codepage{code_pt_pane} = $codepage{code_frm}->Scrolled('Pane',
    -scrollbars => 'se',
    -width=>300,
    -sticky=>'nw'
 )->pack(-side=>'top', -anchor=>'n', -expand => 1, -fill => 'both',-ipadx=>0, -padx=>0);

my @labels = ( 'General', 'Case', 'Numeric Type', 'BiDirectional Parameters');
for (0..3) { 
$codepage{code_frm_top}[$_] = $codepage{code_pt_pane}->LabFrame(-label=>$labels[$_], )->pack(-side=>'top', -fill =>'both',);
$codepage{code_frm_labs}[$_] = $codepage{code_frm_top}[$_]->Frame()->pack(-anchor=>'n', -side=>'left', -fill =>'none',);
$codepage{code_frm_ents}[$_] = $codepage{code_frm_top}[$_]->Frame( )->pack(-anchor=>'n', -side=>'left', -expand=>0, -fill =>'both',);
}

for (qw(name code block script mirrored  )) {
	$codepage{code_frm_labs}[0]->Label( -text=>uc($_).':', -width=>14, -anchor=>'e' )->pack(-anchor=>'e',);
	$code_labels{$_} = $codepage{code_frm_ents}[0]->Label(-text=>'', -anchor=>'w' , -width=>60)->pack(-side=>'top', -anchor=>'w', -fill =>'x', -expand=>0,);
	}

for (qw(upper lower title condition  status mapping  )) {
	$codepage{code_frm_labs}[1]->Label(-text=>uc($_).':', -width=>14, -anchor=>'e' )->pack(-anchor=>'e',);
	$code_labels{$_} = $codepage{code_frm_ents}[1]->Label(-text=>'', -anchor=>'w' , -width=>60)->pack(-anchor=>'w', -fill =>'x', -expand=>0,);
	}

for (qw(decimal digit numeric )) {
	$codepage{code_frm_labs}[2]->Label(-text=>uc($_).':', -width=>14, -anchor=>'e' )->pack(-anchor=>'e',);
	$code_labels{$_} = $codepage{code_frm_ents}[2]->Label(-text=>'', -anchor=>'w' , -width=>60)->pack(-anchor=>'w', -fill =>'x', -expand=>0,);
	}

for (qw( category bidi combining  decomposition  compexcl )) {
	$codepage{code_frm_labs}[3]->Label(-text=>uc($_).':', -width=>14, -anchor=>'e' )->pack(-anchor=>'e',);
	$code_labels{$_} = $codepage{code_frm_ents}[3]->Label(-text=>'', -anchor=>'w' , -width=>60)->pack(-anchor=>'w', -fill =>'x', -expand=>0,);
	}
	
$codepage{statusfrm} = $codepage{main}->Frame(-bd=>1,-relief=>'sunken')->pack(-anchor=>'w', -side=>'bottom', -fill =>'x',);
$codepage{statusbar} = $codepage{statusfrm}->Label(-text=>"Welcome to Perl CodePage",-background=>'#ffffd5',-anchor=>'w',)->pack( -fill =>'both',);
$codepage{balloon} = $codepage{main}->Balloon(-initwait => 700,  
		-state => 'both',
		-foreground => 'black',
		-background => '#ffffd5', 
		-balloonposition=>'mouse',
		-statusbar => $codepage{statusbar}                 
		);
		
$codepage{codepage_text_entry_frame} = $codepage{main}->LabFrame(
	-label=>'Edit Buffer',
	)->pack(-side => 'bottom', -fill=>'x', -expand => '0', -padx => 0, );

$codepage{codepage_text_entry} = $codepage{codepage_text_entry_frame}->Scrolled(
			'Text',
			-scrollbars=>'se',
			-exportselection=>1,
			-font=>$codepage{font_name},
			-state=> 'normal',
			-wrap => 'none',
			-height=>4,
			-width =>40,
			)->pack(-side => 'left', -fill=>'x', -expand => '1', -padx => 5, );

$codepage{codepage_text_entry}->menu(undef) if $codepage{codepage_text_entry}->can("menu");
$codepage{codepage_text_entry}->update;									
$codepage{text_popup} = $codepage{codepage_text_entry}->Menu(-tearoff => 0);
	  	

$codepage{text_popup}->command(-label => 'Magnify Selected', 
	-command => sub{
	$codepage{main}->Busy(-recurse=>1);
	popup_character($codepage{codepage_text_entry}->getSelected, 'mouse'); 
	});

$codepage{codepage_text_entry}->bind('<ButtonPress-3>', sub {
		$codepage{text_popup}->Popup(-popover => 'cursor', -popanchor => 'nw');   });
				
$codepage{codepage_text_entry}->bind('<MouseWheel>' => [ sub {
		$_[0]->yview('scroll', -($_[1] / 120) * 3, 'units') },
	Ev('D') ]);

			  					
$codepage{codepage_text_btn_frame} = $codepage{codepage_text_entry_frame}->Frame()->pack(-side => 'right', -fill=>'none', -expand => '0', -padx => 0, );
$codepage{codepage_text_btn_frame}->Button(-text =>  'Clear',
	-width =>8,
	-command => sub {
	$codepage{codepage_text_entry}->delete('1.0','end');
	},
	)->pack(-side => 'top', -fill=>'none', -expand => '0', -padx => 0, );
$codepage{codepage_text_btn_frame}->Button(-text =>  'Copy',
	-width =>8,
	-command => sub {
	$codepage{codepage_text_entry}->selectAll;
	$codepage{codepage_text_entry}->clipboardCopy;
	},
	)->pack(-side => 'top', -fill=>'none', -expand => '0', -padx => 0, );
$codepage{codepage_text_btn_frame}->Button(-text =>  'SelectAll',
	-width =>8,
	-command => sub {
	$codepage{codepage_text_entry}->selectAll;
	},
	)->pack(-side => 'top', -fill=>'none', -expand => '0', -padx => 0, );
$codepage{codepage_text_btn_frame}->Button(-text =>  "Magnify\nSelected",
	-width =>8,
	-command => sub {
	$codepage{main}->Busy(-recurse=>1);
	popup_character($codepage{codepage_text_entry}->getSelected, 'anywhere');
	},
	)->pack(-side => 'top', -fill=>'none', -expand => '0', -padx => 0, );
$codepage{heading} = $codepage{codepage_frm}->Frame()->pack(-side=>'top', -ipadx=>30, -padx=>23, -pady=>1, -fill=>'x', -expand=>0);#(-side=>'top', -fill=>'none', -expand=>0);
$codepage{spacer} = $codepage{heading}->Label(-text=>'',-width=>$l_label_width)->pack(-anchor=>'w', -side=>'left', );
	
for my $char (0..15) {
	my $hex = uc(sprintf('%x' ,$char ));
	if (!Exists $btns_head[$char])
		{
		$btns_head[$char] = $codepage{heading}->Button(#-bg=>'green',
			-text=>$hex,
			-font=>$codepage{font_name},
			-width=>2,
			-state=>'disabled',
			-relief=>'flat',
			)->pack(-side=>'left', -padx=>1, -pady=>1);
		}
	else {
		$btns_head[$char]->configure(
			-text=>$hex,
			-font=>$codepage{font_name},
			);
		$btns_head[$char]->pack(-side=>'left', -padx=>1, -pady=>1);
		}
	}

$codepage{pane} = $codepage{codepage_frm}->Scrolled('Pane', #-bg=>'magenta',
    -scrollbars => 'se',
    -width=>550,
    -height=>450,
    -sticky=>'nw'
 )->pack(-side=>'top', -expand => 1, -fill => 'both',-ipadx=>30, -padx=>20);

$codepage{option_frame} = $codepage{left_frm}->LabFrame(-label=>'Edit Buffer Insert Mode',
 )->pack(-side=>'top', -expand => 1, -fill => 'x',);

$codepage{insert_type} = 'Character';
for ('Character', 'UCD(hex)', 'chr(dec)', 'UCN', 'Full', 'None') {
$codepage{option_frame}->Radiobutton(-text=> $_,
	-variable=>\$codepage{insert_type},
	-value=> $_,
	)->pack( -side => 'left', -expand => 0, -padx => 12);	
}
$codepage{insert_newline} = 'false';
$codepage{option_frame}->Checkbutton(-text=> 'New Line',
	-variable=>\$codepage{insert_newline},
	-onvalue=> 'true',
	-offvalue=> 'false',
	)->pack( -side => 'left', -expand => 0, -padx => 12);	
$codepage{block} = 'Basic Latin';	
codepage_buttons($codepage{block}, 'charblock');

$common_hash{main}->bind('<Right>', sub { shifter(1); } );
$common_hash{main}->bind('<Left>', sub { shifter(-1); } );
$common_hash{main}->bind('<Up>', sub { shifter(-16); } );
$common_hash{main}->bind('<Down>', sub { shifter(16); } );
}
#-----------------------------------

sub codepage_unselect  {
$codepage{$current_entity}{selnbr} = '';
$codepage{$current_entity}{selected}->configure(
	-foreground=>'black', 
	-background=>'SystemButtonFace',
	-activeforeground=>'black', 
	-activebackground=>'SystemButtonFace'
	) if Exists $codepage{$current_entity}{selected};
}

#-----------------------------------

sub shifter {
my ($amount) = @_;
if (($codepage{$current_entity}{selnbr} + $amount < 0) or
	( $codepage{$current_entity}{selnbr} + $amount > $codepage{max_button}  )) 
		{ return }

do_button($codepage{$current_entity}{selnbr} + $amount, $codepage{$current_entity}{sel_dec_code} + $amount ,  '');
$codepage{pane}->see($codepage{$current_entity}{selected});
}

#-----------------------------------

sub do_button {
my ($current_button_nbr, $current_dec_code, $option) = @_;

$codepage{$current_entity}{selected}->configure(
	-foreground=>'black', 
	-background=>'SystemButtonFace',
	-activeforeground=>'black', 
	-activebackground=>'SystemButtonFace'
	) if Exists $codepage{$current_entity}{selected};

$codeframe_btns{$current_entity}{$current_button_nbr}->configure(
	-foreground=>'red', 
	-background=>'grey',
	-activeforeground=>'red', 
	-activebackground=>'grey'
	); #-background=>'grey25'
		
my $cd = charinfo($current_dec_code);

for (qw(name code block script mirrored upper lower title condition decimal digit numeric category bidi combining  decomposition    ))
	{ $code_labels{$_}->configure(-text=>$cd->{$_}) }
for ( qw( upper lower title ) ) { 
	if ( $cd->{$_} )
		{$code_labels{$_}->configure(-text=> $cd->{$_} . '   '. chr(hex $cd->{$_} ) . ' '    )}
	}
if ($cd->{mirrored} eq 'Y') {
	$code_labels{mirrored}->configure(-text=> $cd->{mirrored} . ' ' . $uni_mirror{$cd->{code}} . '    '. chr(hex($uni_mirror{$cd->{code}})) . ' '    );
	}
$code_labels{bidi}->configure(-text=> $cd->{bidi} . '   ['. $bidi{$cd->{bidi}} . ']'    );
$code_labels{category}->configure(-text=> $cd->{category} . '   '. $uni_category{$cd->{category}} . ' '    );

$code_labels{compexcl}->configure(-text=> compexcl($current_dec_code) );

my $casespc = casespec($current_dec_code);
for ( qw( upper lower title condition) ) { 
	if ( $casespc->{$_} )
		{$code_labels{$_}->configure(-text=> $casespc->{$_})};# 
	}
	
my $casefld = casespec($current_dec_code);
for ( qw( status mapping) ) { 
	if ( $casefld->{$_} )
		{$code_labels{$_}->configure(-text=> $casefld->{$_})};# 
	}
	
$code_labels{bidi}->configure(-text=> $cd->{bidi} . '   ['. $bidi{$cd->{bidi}} . ']'    );
$code_labels{compexcl}->configure(-text=> compexcl($current_dec_code) );


my $charinfo = charinfo($current_dec_code);
my $charinf = $charinfo->{name};
	
if ( $option eq 'insert') {
	if ((!$charinf) or ( $charinf eq '<control>' ))	{}
	else 	{ # 'Character', 'UCD(hex)', 'chr(dec)', 'UCN', 'None'
		if	($codepage{insert_type} eq 'Character') { $codepage{codepage_text_entry}->insert('insert', chr($current_dec_code));	}
		elsif	($codepage{insert_type} eq 'UCD(hex)') { $codepage{codepage_text_entry}->insert('insert', '\\x{'. sprintf('%04x',$current_dec_code) . '}'); }
		elsif	($codepage{insert_type} eq 'chr(dec)') { $codepage{codepage_text_entry}->insert('insert', 'chr('. $current_dec_code . ')') ; }
		elsif	($codepage{insert_type} eq 'UCN') { $codepage{codepage_text_entry}->insert('insert', 'U'. sprintf('%04x',$current_dec_code)); }
		elsif	($codepage{insert_type} eq 'Full') { $codepage{codepage_text_entry}->insert('insert', '\\N{'. $cd->{name} . '}'); }
		elsif	($codepage{insert_type} eq 'None') {}
		}
	if ($codepage{insert_newline} eq 'true') 
		{ $codepage{codepage_text_entry}->insert('insert', "\n");}
	$codepage{codepage_text_entry}->see('insert');
	}
	
	$codepage{script} = $cd->{script};
	#$codepage{block} = $cd->{block};
	$codepage{$current_entity}{selnbr} = $current_button_nbr;
	$codepage{$current_entity}{sel_dec_code} = $current_dec_code;
	$codepage{$current_entity}{selected} = $codeframe_btns{$current_entity}{$current_button_nbr};
	
}
#-----------------------------------

sub codepage_buttons {
	
my ( $entity , $type) = @_;

my $code = 0;
my ($from, $to);
my $ranges;
if 	($type eq 'charblock') { $ranges = charblock($entity); }
elsif 	($type eq 'charscript') { $ranges = charscript($entity); }

#printf "Read script $entity. %d ranges exist.\n", scalar(@$ranges);

my $process_range_no = 0;

codepage_clear_ents();

my $heading2;	
while (my $range = shift @$ranges){
        $heading2 = sprintf "%06X -> %06X\n", $$range[0], $$range[1];
        ($from, $to) = ($$range[0], $$range[1]);

my $current_dec_code = $from;
my $maxline = ceil (($to - $from) / 16) -1;
my $current_button_nbr = 0; #$codepage{max_button} + 1;


my $heading;
if 	($type eq 'charblock') { $heading = charblock($current_dec_code); }
elsif 	($type eq 'charscript') { $heading = charscript($current_dec_code); }

$codepage{codepage_frm}->configure(-label=>$heading . ' Range ' . $heading2);

if (( eval (exists $codeframe{$current_entity}) ) and (eval Exists $codeframe{$current_entity} )) { $codeframe{$current_entity}->packForget; }

if (Exists $codeframe{$entity} ) {
	$codeframe{$entity}->pack;
	$current_entity = $entity;
	return;
	}

$current_entity = $entity;	
$codeframe{$entity} = $codepage{pane}->Frame()->pack;

my $start_line = 0; 

my $end_line = $maxline; 	
for my $line ($start_line..$end_line) {
	
my $hex = uc(sprintf('%04x' ,$current_dec_code ));
$codeframe_lines{$entity}{$line} = $codeframe{$entity}->Frame(#-bg=>'#ff0088',
	)->pack(-side=>'top', -padx=>3, -pady=>1, -fill=>'x', -expand=>1);
$hframes_labels[$line] = $codeframe_lines{$entity}{$line}->Label(#-bg=>'#ff8888',
	-text=>"U$hex",-width=>$l_label_width )->pack(-anchor=>'w', -side=>'left', );

for my $char (0..15) {
	$hex = uc(sprintf('%04x' ,$current_dec_code ));
	my $uni = chr($current_dec_code);
	
	my $charinfo = charinfo($current_dec_code);
	my $charinf = $charinfo->{name};
	if ((!$charinf) or ( $charinf eq '<control>' )) {$uni = ''}
	$codeframe_btns{$entity}{$current_button_nbr} = $codeframe_lines{$entity}{$line}->Button(#-bg=>'purple',
		-text=>$uni,
		-font=>$codepage{font_name},
		-width=>2,
		-command=> [\&do_button, $current_button_nbr, $current_dec_code, 'insert'],
		)->pack(-side=>'left', -padx=>1, -pady=>1);
	
	$btns_hash{$entity}{$current_dec_code} = $current_button_nbr;
		
		
		my $stat;
#    code             code point with at least four hexdigits
#    name             name of the character IN UPPER CASE
#    category         general category of the character
#    combining        classes used in the Canonical Ordering Algorithm
#    bidi             bidirectional category
#    decomposition    character decomposition mapping
#    decimal          if decimal digit this is the integer numeric value
#    digit            if digit this is the numeric value
#    numeric          if numeric is the integer or rational numeric value
#    mirrored         if mirrored in bidirectional text
#    unicode10        Unicode 1.0 name if existed and different
#    comment          ISO 10646 comment field
#    upper            uppercase equivalent mapping
#    lower            lowercase equivalent mapping
#    title            titlecase equivalent mapping    block            block the character belongs to (used in \p{In...})
#    script           script the character belongs to
		
	if (!$charinf) { $charinf = ''}
	
	$codepage{balloon}->attach($codeframe_btns{$entity}{$current_button_nbr},
		-balloonmsg => "U$hex $charinf", 
		-statusmsg => "U$hex $charinf");
	$codeframe_btns{$entity}{$current_button_nbr}->bind('<ButtonPress-3>', sub { popup_character($uni,'mouse') } );
	$codeframe_btns{$entity}{$current_button_nbr}->bind('<ButtonRelease-3>', sub { $codepage{popupchar}->destroy; } );
	$codeframe_btns{$entity}{$current_button_nbr}->bind('<ButtonPress-2>', sub { popup_character($uni,'mouse') } );
	$codeframe_btns{$entity}{$current_button_nbr}->bind('<ButtonRelease-2>', sub { $codepage{popupchar}->destroy; } );
	$codepage{max_button} = $current_button_nbr;
	$current_dec_code++;
	$current_button_nbr++;
	}
	$process_line_no++;
	$common_hash{main}->update;
	}
	

  $process_range_no++;
  } #end while loop
}
#-----------------------------------

sub code_page_button_reconfig {
	
my ($newfont) = @_;
$codepage{font_name} = codepage_create_font($newfont);

for my $x (keys %codeframe_btns) {
	for my $y (keys %{$codeframe_btns{$x}}) {
		$codeframe_btns{$x}{$y}->configure(-font => $codepage{font_name} );
		}
	}
		
for (0..$#btns_head) {
	$btns_head[$_]->configure(-font=>$codepage{font_name});
	}
$codepage{codepage_text_entry}->configure(-font=>$codepage{font_name});
}
	
#-----------------------------------

sub codepage_create_font {
my ($newfont) = @_;
my $name = $newfont; #'codepage' . $newfont;
if (!exists $codepage_fonts{$newfont}) {
	$codepage_fonts{$newfont} = $common_hash{main}->fontCreate( 
		$newfont,
		-family	=>	$newfont, 
		);
	}
return $newfont;
}
		
#-----------------------------------

sub read_script {
my $script = shift;
my $ranges = charblock($script);
printf "Read script $script. %d ranges exist.\n", scalar(@$ranges);

while (my $range = shift @$ranges){
        printf "%06X -> %06X\n", $$range[0], $$range[1];
   }
}

#------------------------------
sub codepage_clear_ents() {
# clear  previous entries
for (qw(name code block script mirrored upper lower title condition  status mapping decimal digit numeric category bidi combining  decomposition  compexcl ))
	{ $code_labels{$_}->configure(-text=>'') if Exists $code_labels{$_}; }
}

#------------------------------
sub list_pop {
my $popdown1 = $common_hash{main}->Menu(-tearoff => 0);

$popdown1->delete(0, 'end');
foreach my $p (sort keys %codeframe) {
	my $ent;
	$ent = $popdown1->command(
		-label => $p,
		-underline => 0,
		-command =>  sub{
		codepage_buttons($ent->cget(-label) , 'charblock');
		$codepage{block} = $ent->cget(-label);
		if ($codepage{$current_entity}{selnbr}) 
			{do_button($codepage{$current_entity}{selnbr} , $codepage{$current_entity}{sel_dec_code} ,  '');}
			},
                    );
		}
$popdown1->Popup(-popover => 'cursor', -popanchor => 'nw', -background => 'white');   		 

}
#------------------------------
sub list_pop2 {
my $popdown1 = $common_hash{main}->Menu(-tearoff => 0);
$popdown1->delete(0, 'end');
foreach my $p (sort keys %codepage_fonts) {
	my $ent;
	$ent = $popdown1->command( -label => $p, -underline => 0, 
		-command =>  sub{
			code_page_button_reconfig($ent->cget(-label) );
			$codepage_fontfam = $ent->cget(-label);
			},
                    );
		}
$popdown1->Popup(-popover => 'cursor', -popanchor => 'nw', -background => 'white');   		 

}

#------------------------------
sub popup_character {
my ($char,$position) = @_;
$codepage{popupchar} = $codepage{main}->Toplevel();

$codepage{popupchar}->overrideredirect(1);
$codepage{popupchar}->transient($codepage{main});
$codepage{popupchar}->stayOnTop;

my ($x, $y);
if ($position eq 'mouse') {
$x = $common_hash{main}->pointerx;
$y = $common_hash{main}->pointery;
}
else {
my $g = $common_hash{main}->geometry;
my ($w, $h);
($w, $h, $x, $y) = split /[x+]/, $common_hash{main}->geometry;

$x = $x + ($w/2);
$y = $y + ($h/2);
}
$codepage{popupchar}->geometry(sprintf('+%d+%d', $x, $y));

if (!$codepage_fonts{'popup' . $codepage{font_name}}) {
$codepage_fonts{'popup' . $codepage{font_name}} = $common_hash{main}->fontCreate( 
	'pupup_font'.$codepage{font_name},
	-family	=> $codepage{font_name}, 
	-size => -100,
	);
}
$codepage{popupfrm} = $codepage{popupchar}->Frame(-bg=>'#ffffd5',-bd=>5,-relief=>'raise')->pack;
$codepage{popuplabel} = $codepage{popupfrm}->Label( -text=>$char, -bg=>'#ffffd5', -font=>$codepage_fonts{'popup' . $codepage{font_name}}, )->pack;
$codepage{popupchar}->bind('<ButtonPress-1>', sub {$codepage{popupchar}->destroy; $codepage{main}->Unbusy(-recurse=>1);  });
$codepage{popupfrm}->focus;
}
#------------------------------

sub populate_bidi {
$bidi{LRE}	= 'Left-to-Right Embedding';
$bidi{LRO}	= 'Left-to-Right Override';
$bidi{RLE}	= 'Right-to-Left Embedding';
$bidi{RLO}	= 'Right-to-Left Override';
$bidi{PDF}	= 'Pop Directional Format';

$bidi{L}	= 'Left-to-Right';
$bidi{R}	= 'Right-to-Left';
$bidi{AL}	= 'Right-to-Left Arabic';
$bidi{EN}	= 'European Number';
$bidi{ES}	= 'European Number Separator';
$bidi{ET}	= 'European Number Terminator';
$bidi{AN}	= 'Arabic Number';
$bidi{CS}	= 'Common Number Separator';
$bidi{NSM}	= 'Non-Spacing Mark';
$bidi{BN}	= 'Boundary Neutral';
$bidi{B}	= 'Paragraph Separator';
$bidi{S}	= 'Segment Separator';
$bidi{WS}	= 'Whitespace';
$bidi{ON}	= 'Other Neutrals';	
}

#-----------------------------------

sub populate_category {
$uni_category{Lu} = 'Letter, Uppercase';
$uni_category{Ll} = 'Letter, Lowercase';
$uni_category{Lt} = 'Letter, Titlecase';
$uni_category{Lm} = 'Letter, Modifier';
$uni_category{Lo} = 'Letter, Other';
$uni_category{Mn} = 'Mark, Nonspacing';
$uni_category{Mc} = 'Mark, Spacing Combining';
$uni_category{Me} = 'Mark, Enclosing';
$uni_category{Nd} = 'Number, Decimal Digit';
$uni_category{Nl} = 'Number, Letter';
$uni_category{No} = 'Number, Other';
$uni_category{Pc} = 'Punctuation, Connector';
$uni_category{Pd} = 'Punctuation, Dash';
$uni_category{Ps} = 'Punctuation, Open';
$uni_category{Pe} = 'Punctuation, Close';
$uni_category{Pi} = 'Punctuation, Initial quote';
$uni_category{Pf} = 'Punctuation, Final quote';
$uni_category{Po} = 'Punctuation, Other';
$uni_category{Sm} = 'Symbol, Math';
$uni_category{Sc} = 'Symbol, Currency';
$uni_category{Sk} = 'Symbol, Modifier';
$uni_category{So} = 'Symbol, Other';
$uni_category{Zs} = 'Separator, Space';
$uni_category{Zl} = 'Separator, Line';
$uni_category{Zp} = 'Separator, Paragraph';
$uni_category{Cc} = 'Other, Control';
$uni_category{Cf} = 'Other, Format';
$uni_category{Cs} = 'Other, Surrogate';
$uni_category{Co} = 'Other, Private Use';
$uni_category{Cn} = 'Other, Not Assigned';
}

#-----------------------------------

sub populate_mirrors {
my $filename = $INC[0] . '/unicore/BidiMirroring.txt';
if (!-e $filename) { $codepage{main}->messageBox(-message => "$filename was not found.  No mirror information will be supplied."); return;}
if (!defined ( open(TEXTFILE,   '<',   "$filename")  )  )
	{ $codepage{main}->messageBox(-message => "Cannot open text file $filename: $!"); return;}
while ( <TEXTFILE> ) {
	if ($_ =~ /\s*([0-9A-F]{4});\s*([0-9A-F]{4})/)
		{ $uni_mirror{$1} = $2;  }
	}
close TEXTFILE;
}
#-----------------------------------

__END__

=pod

=head1 NAME

codepage.pl - Display Unicode Codepages with Perl/Tk.

=head1 SYNOPSIS

    % perl codepage.pl

=head1 DESCRIPTION

Codepage.pl displays Unicode Codepages and is written in pure Perl/Tk. It has the
following features:

=over 4

=item *

Selection and display of Unicode Blocks within the Unicode database.

=item *

Selection and display of Codepoint properties.

=item *

Display of Codepages for a specified font.

=item *

Various search techniques for Code point names including:
Regular Expression
Exact match
+-String matches (Google-like)

=item *

Placement of selected code points in a text widget (optionally inserting the character, unicode name, unicode format, chr() format).

=item *

Magification of characters.


=back

=head1 STATUS AND LIMITATIONS

Codepage displays code points in the range U0000 - U10000.  Code points after that seem to have problems being inserted into the text widget.

The script creates a button for each unicode character. CJK Unified blocks have so many characters that it causes strange results in Tk.  Therefore, before attampting to display a CJK Unified block, a warning will be issued.

=head1 REQUIREMENTS

Perl/Tk.
Unicode Character Database (Unicode::UCD)

Perl Unicode Mirror file (not supported by (Unicode::UCD):
$INC[0]/unicore/BidiMirroring.txt;

=head1 OPTIONAL COMPONENTS

=head1 TIPS

=over 4

=item *

Right click on a code point to magnify the unicode character using the specified font.

=item *

Right click on text in the text window to magnify the text.

=back

=head1 TODO

=over 4

=item *

This script may be more useful as a module since some Tk written text editors may benefit from the ability to view codepages and insert 'other' non-native Unicode characters.  I am not sure if this would be a Tk::Codepage module or a Unicode::Codepage module.

=item *

Advanced search cpabilities.

=item *

Display codepage blocks beyond U10000.  This, however, may not be possible with Perk/Tk.

=back

=head1 BUGS

If you think you found a bug, or you want to discuss anything
Codepage-related, then please drop me a note at I<chrisjcra@cpan.org>.

=head1 COPYRIGHTS

Copyright 2004 - Chris Whiting.

This program is distributed under the same terms as Perl itself.


=end