#!/usr/bin/env perl
use 5.010;
use strict;
use warnings;
use utf8;

use open OUT => ':utf8', ':std';
use Data::Dump 'pp';

our $VERSION = '1.00';

my %info = (
	"\xAD"     => {string => '-'},
	"\x{200E}" => {string => '→'},
	"\x{200F}" => {string => '←'},
);
$info{chr $_} //= {} for 32 .. 126;

eval {
	my $tables = do 'unicode-table.inc.pl' or die $@ || $!;
	for (values %$tables) {
		for (values %$_) {
			for (@$_) {
				length $_ == 1 or next;  # ignore meta values
				s/\\//;  # unescape
				$info{$_} //= {};
			}
		}
	}
	1;
} or warn "Failed reading unicode tables: $@";

eval {
	require HTML::Entities;
	while (my ($char, $entity) = each %HTML::Entities::char2entity) {
		$entity =~ /[a-zA-Z]/ or next;  # only actual aliases
		$info{$char}->{html} = substr($entity, 1, -1);
	}
	1;
} or warn "Failed importing html entities: $@";

my %diinc = (
	'digraphs.inc.pl' => 'u-di',
);
for (keys %diinc) {
	-e $_ or next;
	my $di = do $_ or die "Error reading digraphs file $_: ", $@ || $!;
	while (my ($mnem, $cp) = each %$di) {
		length $mnem == 2 or next;  # limit to digraphs
		$cp = chr $cp->[0] if ref $cp;  # old style array
		$info{$cp}->{di} //= $mnem;
		$info{$cp}->{class}->{$_}++ for $diinc{$_};
	}
}

for my $chr (keys %info) {
	my $cp = ord $chr;
	# attempt to get unicode character information
	my $info = eval {
		require Unicode::UCD;
		Unicode::UCD::charinfo($cp)
			|| { block => '?', category => 'Xn', name => '', script => '' }
	} or next;

	$info->{$_} = $info{$chr}->{$_} for qw(di html class string);

	# categorise by unicode types and writing script
	$info->{class}->{$_}++ for $info->{category};
	$info->{class}->{"u-$_"}++ for $info->{script} || ();

	# add custom categories for certain blocks
	$info->{class}->{Xa}++ if $info->{block} eq 'Basic Latin';
	$info->{class}->{Xl}++ if $info->{block} eq 'Latin-1 Supplement';

	given ($cp) {
		when ($info->{string}) {
			# keep predefined presentational string
		}
		when ($info->{combining}) {
			# overlay combining accents
			$info->{string} = chr(9676) . $chr;
		}
		when (($cp & ~0b1001_1111) == 0 or $cp == 127) {
			# control characters (first 32 chars from 0 and 128)
			# rename to something more descriptive
			$info->{name} = $info->{unicode10}
				? '<'.$info->{unicode10}.'>'  # the old name was much more useful
				: sprintf('<control U+%04X>', $cp);  # at least identify by value
			# show descriptive symbols instead of control chars themselves
			$info->{string} = $cp < 32 ? chr($cp + 0x2400) : chr(0xFFFD);
		}
	}

	$info{$chr} = $info;
}

# output perl code of hash
say '+{';
for my $cp (sort keys %info) {
	$info{$cp}->{classstr} = join(' ', sort keys %{ $info{$cp}->{class} });
	# convert info hashes into arrays of strings to output in display order
	my $row = [ map { $info{$cp}->{$_} } qw/classstr name di html string/ ];
	# strip off trailing missing values (especially string may be unknown)
	defined $row->[-1] ? last : pop @$row for 1 .. @$row;
	# final line (assume safe within single quotes)
	say sprintf '"\x{%X}" => [%s],',
		ord $cp, join(',', map { escapeq($_) } @$row);
}
say '}';

sub escapeq {
	my $_ = shift;
	return 'undef' if not defined;
	s/(['\\])/\\$1/g;
	return "'$_'";
}

__END__

=head1 NAME

convert-unicode.pl - Gather Unicode character details in Perl array

=head1 SYNOPSIS

    convert-unicode > unicode-char.inc.pl

Test by printing the description of U+0041 (latin A):

    perl -e'$u = do "unicode-char.inc.pl"; print $u->{A}->[1]'

=head1 AUTHOR

Mischa POSLAWSKY <perl@shiar.org>

=head1 LICENSE

Licensed under the GNU Affero General Public License version 3.

