+#!/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;
+
+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 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 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.
+