<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">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}-&gt;configure(-title=&gt;"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}-&gt;DefineBitmap("downarrow_Icon" =&gt; 17,9, $downarrow_bits);
	  
$codepage{font_name} = codepage_create_font($codepage_fontfam);

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

$codepage{select_frm} = $codepage{main}-&gt;Frame(-bd=&gt;1, -relief=&gt;'groove', #-bg=&gt;'yellow',
	)-&gt;pack(-anchor=&gt;'n', -side=&gt;'top', -fill =&gt;'x', ); #-expand=&gt;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] &gt;= hex $max_codepoints) {
        	#  displaying codepoints above U10000 get an error in Tk.
        	#print "$entity $count (from $$range[0], to $$range[1])";
        	#printf "%06X -&gt; %06X\n", $$range[0], $$range[1];
        	#print "\n";
	}
	else { push @listed_charblocks, $entity; }
    }
}

my $charscripts = charscripts();
#$codepage{select_frm}-&gt;Label(-text=&gt;'Blocks')-&gt;pack( -side   =&gt; 'left', -anchor =&gt; 'w', -padx =&gt; 10);
$codepage{select_frm}-&gt;BrowseEntry(
	-label=&gt;'Blocks',
	-textvariable =&gt; \$codepage{block},
	-choices =&gt; [ sort @listed_charblocks ], #[sort keys %{$charblocks}],
	-state =&gt; 'readonly',
	-command=&gt;sub{
		if ( ($codepage{block} =~ /CJK Unified/) and
			($codepage{main}-&gt;messageBox(-type=&gt; "YesNo", -message =&gt; "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=&gt;'white',
	-disabledforeground=&gt;'black',
	-width  =&gt; 35,
	-listheight=&gt;20,
	)-&gt;pack( -side   =&gt; 'left', -anchor =&gt; 'w', -padx =&gt; 2, -pady =&gt; 8);

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

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

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

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

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

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

	
$codepage{codepoint_btn_frame} = $codepage{right_frm}-&gt;LabFrame(
	-label=&gt;'Code Point Search', -bd=&gt;1,
	)-&gt;pack(-anchor=&gt;'n', -side=&gt;'top', -fill =&gt;'both', -expand=&gt;0, -ipadx=&gt;10, -ipady=&gt;5);
$codepage{codepoint_btn_frame}-&gt;Entry(-textvariable=&gt;\$codepage{search_point},
	-width=&gt;8, )-&gt;pack(-side=&gt;'left');
$codepage{search_hex} = 'hexon';
$codepage{codepoint_btn_frame}-&gt;Radiobutton(
	-text=&gt;'Hex', -value=&gt;'hexon', -variable=&gt; \$codepage{search_hex},
	)-&gt;pack(-side =&gt; 'left',  -padx =&gt; 5, -pady =&gt; 0,);
$codepage{codepoint_btn_frame}-&gt;Radiobutton(
	-text=&gt;'Dec', -value=&gt;'hexoff', -variable=&gt; \$codepage{search_hex},
	)-&gt;pack(-side =&gt; 'left',  -padx =&gt; 5, -pady =&gt; 0,);	
$codepage{codepoint_btn_frame}-&gt;Radiobutton(
	-text=&gt;'Char', -value=&gt;'char', -variable=&gt; \$codepage{search_hex},
	)-&gt;pack(-side =&gt; 'left',  -padx =&gt; 5, -pady =&gt; 0,);
		
$codepage{codepoint_btn_frame}-&gt;Button(-text=&gt;'Search',
	-command=&gt;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}-&gt;messageBox(-message =&gt; "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}-&gt;messageBox(-message =&gt; "Search data $value is not a valid value");
			codepage_unselect();
			return; 
			}
		my $x = charblock($value);
		if (!$x)
			{
			$codepage{main}-&gt;messageBox(-message =&gt; "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=&gt;8, )-&gt;pack(-side=&gt;'right',-padx=&gt;6);

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

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

		
$codepage{codepoint_btn_byname_frame}[2]-&gt;Button(-text=&gt;'Search',
	-command=&gt;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}-&gt;messageBox(-message =&gt; "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}-&gt;Busy(-recurse=&gt;1);
		for ($start..$max_codepoints)
			{
			my $charinf  = charinfo($_);
			my $name = $charinf-&gt;{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}-&gt;Unbusy(-recurse=&gt;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 &gt; $#word_patterns);
					if ($neg_match and $match)
						{
						$codepage{block} = charblock($_);
						codepage_buttons($codepage{block}, 'charblock');
						do_button($btns_hash{$current_entity}{$_}, $_, '' );
						$codepage{main}-&gt;Unbusy(-recurse=&gt;1);	
						return;
						}
					}
				}
			}
		$codepage{main}-&gt;Unbusy(-recurse=&gt;1);	
		$codepage{main}-&gt;messageBox(-message =&gt; "Search for $codepage{search_byname_point} was not successful.");
		},
	-width=&gt;8, 
	)-&gt;pack(-side=&gt;'right',-padx=&gt;6);

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

$codeframe_btns{$current_entity}{$current_button_nbr}-&gt;configure(
	-foreground=&gt;'red', 
	-background=&gt;'grey',
	-activeforeground=&gt;'red', 
	-activebackground=&gt;'grey'
	); #-background=&gt;'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{$_}-&gt;configure(-text=&gt;$cd-&gt;{$_}) }
for ( qw( upper lower title ) ) { 
	if ( $cd-&gt;{$_} )
		{$code_labels{$_}-&gt;configure(-text=&gt; $cd-&gt;{$_} . '   '. chr(hex $cd-&gt;{$_} ) . ' '    )}
	}
if ($cd-&gt;{mirrored} eq 'Y') {
	$code_labels{mirrored}-&gt;configure(-text=&gt; $cd-&gt;{mirrored} . ' ' . $uni_mirror{$cd-&gt;{code}} . '    '. chr(hex($uni_mirror{$cd-&gt;{code}})) . ' '    );
	}
$code_labels{bidi}-&gt;configure(-text=&gt; $cd-&gt;{bidi} . '   ['. $bidi{$cd-&gt;{bidi}} . ']'    );
$code_labels{category}-&gt;configure(-text=&gt; $cd-&gt;{category} . '   '. $uni_category{$cd-&gt;{category}} . ' '    );

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

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


my $charinfo = charinfo($current_dec_code);
my $charinf = $charinfo-&gt;{name};
	
if ( $option eq 'insert') {
	if ((!$charinf) or ( $charinf eq '&lt;control&gt;' ))	{}
	else 	{ # 'Character', 'UCD(hex)', 'chr(dec)', 'UCN', 'None'
		if	($codepage{insert_type} eq 'Character') { $codepage{codepage_text_entry}-&gt;insert('insert', chr($current_dec_code));	}
		elsif	($codepage{insert_type} eq 'UCD(hex)') { $codepage{codepage_text_entry}-&gt;insert('insert', '\\x{'. sprintf('%04x',$current_dec_code) . '}'); }
		elsif	($codepage{insert_type} eq 'chr(dec)') { $codepage{codepage_text_entry}-&gt;insert('insert', 'chr('. $current_dec_code . ')') ; }
		elsif	($codepage{insert_type} eq 'UCN') { $codepage{codepage_text_entry}-&gt;insert('insert', 'U'. sprintf('%04x',$current_dec_code)); }
		elsif	($codepage{insert_type} eq 'Full') { $codepage{codepage_text_entry}-&gt;insert('insert', '\\N{'. $cd-&gt;{name} . '}'); }
		elsif	($codepage{insert_type} eq 'None') {}
		}
	if ($codepage{insert_newline} eq 'true') 
		{ $codepage{codepage_text_entry}-&gt;insert('insert', "\n");}
	$codepage{codepage_text_entry}-&gt;see('insert');
	}
	
	$codepage{script} = $cd-&gt;{script};
	#$codepage{block} = $cd-&gt;{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 -&gt; %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}-&gt;configure(-label=&gt;$heading . ' Range ' . $heading2);

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

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

$current_entity = $entity;	
$codeframe{$entity} = $codepage{pane}-&gt;Frame()-&gt;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}-&gt;Frame(#-bg=&gt;'#ff0088',
	)-&gt;pack(-side=&gt;'top', -padx=&gt;3, -pady=&gt;1, -fill=&gt;'x', -expand=&gt;1);
$hframes_labels[$line] = $codeframe_lines{$entity}{$line}-&gt;Label(#-bg=&gt;'#ff8888',
	-text=&gt;"U$hex",-width=&gt;$l_label_width )-&gt;pack(-anchor=&gt;'w', -side=&gt;'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-&gt;{name};
	if ((!$charinf) or ( $charinf eq '&lt;control&gt;' )) {$uni = ''}
	$codeframe_btns{$entity}{$current_button_nbr} = $codeframe_lines{$entity}{$line}-&gt;Button(#-bg=&gt;'purple',
		-text=&gt;$uni,
		-font=&gt;$codepage{font_name},
		-width=&gt;2,
		-command=&gt; [\&amp;do_button, $current_button_nbr, $current_dec_code, 'insert'],
		)-&gt;pack(-side=&gt;'left', -padx=&gt;1, -pady=&gt;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}-&gt;attach($codeframe_btns{$entity}{$current_button_nbr},
		-balloonmsg =&gt; "U$hex $charinf", 
		-statusmsg =&gt; "U$hex $charinf");
	$codeframe_btns{$entity}{$current_button_nbr}-&gt;bind('&lt;ButtonPress-3&gt;', sub { popup_character($uni,'mouse') } );
	$codeframe_btns{$entity}{$current_button_nbr}-&gt;bind('&lt;ButtonRelease-3&gt;', sub { $codepage{popupchar}-&gt;destroy; } );
	$codeframe_btns{$entity}{$current_button_nbr}-&gt;bind('&lt;ButtonPress-2&gt;', sub { popup_character($uni,'mouse') } );
	$codeframe_btns{$entity}{$current_button_nbr}-&gt;bind('&lt;ButtonRelease-2&gt;', sub { $codepage{popupchar}-&gt;destroy; } );
	$codepage{max_button} = $current_button_nbr;
	$current_dec_code++;
	$current_button_nbr++;
	}
	$process_line_no++;
	$common_hash{main}-&gt;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}-&gt;configure(-font =&gt; $codepage{font_name} );
		}
	}
		
for (0..$#btns_head) {
	$btns_head[$_]-&gt;configure(-font=&gt;$codepage{font_name});
	}
$codepage{codepage_text_entry}-&gt;configure(-font=&gt;$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}-&gt;fontCreate( 
		$newfont,
		-family	=&gt;	$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 -&gt; %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{$_}-&gt;configure(-text=&gt;'') if Exists $code_labels{$_}; }
}

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

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

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

}

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

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

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

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

if (!$codepage_fonts{'popup' . $codepage{font_name}}) {
$codepage_fonts{'popup' . $codepage{font_name}} = $common_hash{main}-&gt;fontCreate( 
	'pupup_font'.$codepage{font_name},
	-family	=&gt; $codepage{font_name}, 
	-size =&gt; -100,
	);
}
$codepage{popupfrm} = $codepage{popupchar}-&gt;Frame(-bg=&gt;'#ffffd5',-bd=&gt;5,-relief=&gt;'raise')-&gt;pack;
$codepage{popuplabel} = $codepage{popupfrm}-&gt;Label( -text=&gt;$char, -bg=&gt;'#ffffd5', -font=&gt;$codepage_fonts{'popup' . $codepage{font_name}}, )-&gt;pack;
$codepage{popupchar}-&gt;bind('&lt;ButtonPress-1&gt;', sub {$codepage{popupchar}-&gt;destroy; $codepage{main}-&gt;Unbusy(-recurse=&gt;1);  });
$codepage{popupfrm}-&gt;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}-&gt;messageBox(-message =&gt; "$filename was not found.  No mirror information will be supplied."); return;}
if (!defined ( open(TEXTFILE,   '&lt;',   "$filename")  )  )
	{ $codepage{main}-&gt;messageBox(-message =&gt; "Cannot open text file $filename: $!"); return;}
while ( &lt;TEXTFILE&gt; ) {
	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&lt;chrisjcra@cpan.org&gt;.

=head1 COPYRIGHTS

Copyright 2004 - Chris Whiting.

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


=end
</pre></body></html>