#!/pro/bin/perl

use strict;
use warnings;

binmode STDOUT, ":utf8";

use Getopt::Long qw(:config nopermute bundling);
my @opt_m;
my $opt_v = 0;
my $opt_f = 0;
GetOptions (
    "m:s"  => \@opt_m,	# show map(s)
    "v:1"  => \$opt_v,
    "f"    => \$opt_f,
    ) or die "usage: uchar [-v] [-m base[:count] [ -m base[:count] ] ... | char ... | -f char\n";

use PROCURA::Diac 4.14;
use charnames ":alias" => ":pro";

my %xlat = (
    ":)"	=> "\N{WHITE SMILING FACE}",
    ":("	=> "\N{WHITE FROWNING FACE}",
    "->"	=> "\N{WHITE RIGHT POINTING INDEX}",
    "<-"	=> "\N{WHITE LEFT POINTING INDEX}",
    phone	=> "\N{WHITE TELEPHONE}",
    death	=> "\N{SKULL AND CROSSBONES}",
    euro	=> "\N{EURO SIGN}",
    );

@opt_m == 1 && !$opt_m[0] and
    @opt_m = qw( 00a0:df 2000:3f 20a0:1f 2140:1f 2190:1f 21c0:1f 2630:1f );

if ($opt_f) {
    sub Names ()
    {
	do "unicore/Name.pl";
	} # Names

    my (%name, %cp, $n);
    for (split m/\n/ => Names ()) {
	s/\s+$//;
	my ($cp, $cp2, $name) = split m/\t/, $_, 3;
	$name =~ m/[a-z]/ and next;	# Non-character
	($cp, $cp2) = map { hex "0$_" } ($cp, $cp2);
	$name{$cp} = $name;
	$cp{$name} //= $cp;
	}
    my $found = 0;
    foreach my $w (['\b', '\b'], ['\b', ''], ['', '']) {
	my $pat = join ".*", map { "$w->[0]$_$w->[1]" } map { split m/_/ } @ARGV;
	$pat = qr{$pat}i;
	foreach my $name (sort grep m/$pat/ => keys %cp) {
	    my $cp  = $cp{$name};
	    my $c   = chr $cp;
	    my $pro = DiacLookup ("utf8", $c);
	    $name =~ m/^COMBINING / and $c = " $c";
	    printf "%06x %s %-15s %s\n", $cp, $c,
		$pro && $pro->[1] ? $pro->[2] : "", $name;
	    $found++;
	    }
	$found and last;
	}
    exit;
    }

if (@opt_m) {
    @opt_m == 1 and push @opt_m, @ARGV;
    @opt_m == 1 && $opt_m[0] =~ m/^(0|all|\*)$/ and @opt_m = ("a0:5f", map { sprintf "%x", 0x100 * $_ } 1..0x2e);
    for (@opt_m) {
	my ($base, $count) =
	    map { m/^0?x?([\da-f]+)$/i ? hex $1 : 0 }
	    split m/:/, "$_:7f";
	$count += $base;
	print "        0123456789abcdef 0123456789abcdef\n";
	while ($base <= $count) {
	    printf "0x%04x:\t", $base;
	    print chr ($base + $_) for  0 .. 15;
	    print " ";
	    print chr ($base + $_) for 16 .. 31;
	    print "\n";
	    $base += 32;
	    }
	print "\n";
	}
    exit;
    }

my $c;
for (@ARGV) {
    exists $xlat{$_} and $_ = $xlat{$_}, next;
    s/^(?:0?x)?([a-f\d]+)$/chr hex $1/e and next;
    $c = DiacLookup ("utf8", $_)        and $c->[1] and $_ = $c->[3], next;
    $c = DiacLookup ("utf8", $_."_IDX") and $c->[1] and $_ = $c->[3], next;
    $c = charnames::vianame ($_)                    and $_ = chr $c,  next;
    $c = charnames::vianame (uc $_)                 and $_ = chr $c;
    }
if ($opt_v) {
    $_ .= " \\N{".charnames::viacode (ord ($_))."}" for @ARGV;
    }
print join "", @ARGV, "\n";