X-Git-Url: http://git.shiar.nl/sheet.git/blobdiff_plain/5fadf3bba74628ae85920b5c2d71f804e3256601..HEAD:/font.plp diff --git a/font.plp b/font.plp index 95630b2..7019573 100644 --- a/font.plp +++ b/font.plp @@ -1,118 +1,286 @@ <(common.inc.plp)><: +my $font = $Request; + Html({ - title => 'character support sheet', - version => 'v1.0', - keywords => [qw' - unicode glyph char character reference common ipa symbol sign mark table digraph - '], - stylesheet => [qw'light dark mono circus red'], - data => [qw'unicode-table.inc.pl unicode-char.inc.pl'], + title => 'font coverage '.($font ? "for $font" : 'sheet'), + version => '1.4', + keywords => [qw( + unicode font glyph char character support overview cover coverage + script block symbol sign mark reference table + )], + stylesheet => [qw( light dark mono circus red )], + data => [qw( data/unicode-cover.inc.pl )], }); +if ($font) { + my $fontmeta = eval { Data("data/font/$font") } + or Abort("Unknown font $font", '404 font not found', ref $@ && $@->[1]); + + my $map = eval { + $get{map} or return; + + my $groupinfo = Data('data/unicode-cover'); + + my ($cat, $name) = split m{/}, $get{map}, 2 or die "invalid map\n"; + if (!$name) { + ($cat, $name) = ('table', $cat); + } + + my $row = $groupinfo->{$cat}->{$name} + or die "unknown character group $cat/$name\n"; + my $query = $row->{query}; + + my @map; + for (map { split /[^\d-]/ } $query) { + my @range = split /-/, $_, 2; + m/^[0-9]+$/ or die "Invalid code point $_ in query $query\n" for @range; + push @map, $_ for $range[0] .. ($range[1] // $range[0]); + } + return \@map; + }; + Abort($@, '404 invalid query') if $@; + + require Unicode::UCD; + + my $pagerows = 0x200; + my $pagecols = 32; + my $offset = eval { + local $_ = $get{q} || 0; + return $_ if /\A\d+\z/; # numeric + return hex $1 if /\A (?: 0?x | u\W* ) ([0-9a-f]+) \z/ix; # hexadecimal + return $_->[0]->[0] for Unicode::UCD::charblock(ucfirst) || (); # block + die "Unknown offset query '$_'\n"; + }; + Abort($@, '400 invalid offset') if $@; + + say "

Font coverage

"; + say "

$_

" for EscapeHTML($fontmeta->{name}); + printf("

Version %s released %s contains %d glyphs.", + !!$_->[2] && qq( title="revision $_->[2]"), + $_->[1], $_->[0], + scalar @{ $fontmeta->{cover} }, + ) for [ + grep { $_ } + ($fontmeta->{date} || '?') =~ s/T.*//r, + EscapeHTML($fontmeta->{version}), + $fontmeta->{revision}, + ]; + for ($fontmeta->{os}) { + say '
'; + print ucfirst join(' ', + "distributed", + (map { "by $_" } $fontmeta->{oscorp} || "various sources"), + (map { "with $_" } $_ || ()), + ('and published as freeware "Core Web font"') x ($_ eq 'Windows 2000'), + (map { "under a $_ license" } + map { $fontmeta->{license} ? qq($_) : $_ } + $_ && $_ ne 'Android' ? 'proprietary' : 'free', + ), + ); + print '.'; + } + say '

'; + say "

$_

" for EscapeHTML($fontmeta->{copyright}) || (); + + require Shiar_Sheet::FormatChar; + my $glyphs = Shiar_Sheet::FormatChar->new; + + my %cover = map { ($_ => 1) } @{ $fontmeta->{cover} }; # lookup map + + say <<"EOT"; + + +EOT + say ''; + + my $offsetlink = '?' . join('&', + (map { $_ . '=' . EncodeURI($get{$_}) } grep { defined $get{$_} } qw{ map }), + 'q', + ); + say "" for join(' ', grep {$_} + $offset > $pagerows && sprintf('◄', $offsetlink, 0), + $offset > 0 && sprintf( + '', + $offsetlink, $offset - $pagerows, + ), + sprintf('U+%04X', $map ? $map->[$offset] : $offset), + Unicode::UCD::charblock($map ? $map->[$offset] : $offset), + $offset + $pagerows < ($map ? @{$map} : 0x11_0000) && sprintf( + '', + $offsetlink, $offset + $pagerows, + ), + ); + + for my $cp ($offset .. $offset+$pagerows-1) { + $cp = $map->[$cp] or next if $map; + + state $colpos; + my $block = Unicode::UCD::charblock($cp); + if ($block ne (state $sameblock = $block) and $block ne 'No_Block') { + print ''; + printf '
$_
%s', $pagecols+1, $block + unless $block eq 'No_Block'; + say ''; + $sameblock = $block; + $colpos = 0; + } + + if ($map) { + # compare previous code point and indicate gaps + state $lastcp = 0; + if ($cp != ++$lastcp) { + if (!$colpos or $colpos++ % $pagecols > $pagecols - 3) { + # nearly last column, start new row + $colpos = 0; + } + else { + # mark repositioning in existing row + printf '%X', $cp; + } + $lastcp = $cp; + } + } + + say sprintf '
%X', $cp if $colpos++ % $pagecols == 0; + + my $info = $glyphs->glyph_info($cp); + my ($class, $name, $mnem, $entity, $string) = @{$info}; + my $np = $class =~ /\bC\S\b/; # noprint if control or invalid + # display literal character, with placeholder circle if non-spacing/enclosing + $string ||= ($class =~ /\bM[ne]\b/ && chr 9676) . chr($cp); + my $html = $np ? !!$cover{$cp} && sprintf("&#%d;", $cp) : + EscapeHTML($string); + say sprintf '%s', + !$class ? ('l0', $cp, '', '') : ( + $cover{$cp} ? $np ? 'l2' : 'l5' : $np ? 'Xi' : 'l1', + $cp, !!$name && ": $name", + $html + ); + } + say '
'; + + exit; +} + :> -

Character support

+

Font coverage

-Selected characters from Unicode preset -or range. +Character support of Unicode +blocks and presets.

<: -use 5.010; -use Shiar_Sheet::FormatChar; -my $glyphs = Shiar_Sheet::FormatChar->new; -my %oslist = ( - win95 => [qw/arial ariuni verdana times/], - mac10 => [qw//], - oss => ['dv ss', qw/droid c2k guf/], +my $cover = Data('data/unicode-cover'); + +my @ossel = @{ $cover->{osdefault} }; +my @fontlist = map { @{ $cover->{os}->{$_} } } @ossel; - android => ['droid'], +my @rows = ( + 'version/11', + 'version/63', + 'block/Latin-1 Supplement', + 'block/Latin Extended-A', + 'block/Latin Extended Additional', + 'block/Latin Extended-B', + 'script/Latin', + 'script/Greek', + 'script/Cyrillic', + 'script/Arabic', + 'script/Hebrew', + 'script/Devanagari', + 'script/Thai', + 'script/Hangul', + 'table/japanese', + 'script/Han', + 'table/ipa', + 'table/punctuation', + 'block/Dingbats', + 'table/symbols', + 'category/Sc', # currency + 'table/math', + 'category/Sm', # mathematical + 'table/arrows/single', + 'table/lines/single', + 'table/block', + 'table/lines', + 'table/html', ); -my @ossel = qw(win95 oss); -my $tables = do 'unicode-table.inc.pl' or die $@ || $!; -my (%font, @fontlist); +if (my $group = $get{q}) { + my $grouprows = $cover->{$group} + or Abort("Unknown character category $_", 404); + @rows = map { "$group/$_" } sort keys %{$grouprows}; +} + +# output character list + +print ''; +print ''; +print "" + for map { scalar @{ $cover->{os}->{$_} } } @ossel; + +print ''; +print ''; } -:> - +say "
'; for my $os (@ossel) { - my $osfonts = $oslist{$os}; - for my $fontid (@{$osfonts}) { - push @fontlist, $fontid; - my ($fontmeta, @fontrange) = do "ttfsupport/$fontid.inc.pl"; - $fontmeta or next; - $font{$fontid} = { - -id => $fontmeta->{id} || $fontid, - -name => $fontmeta->{name}, - map { (chr $_ => 1) } @fontrange - }; - } + my $osfonts = $cover->{os}->{$os}; + my $osfont = $cover->{fonts}->[ $osfonts->[0] ]; # first font + printf '%s', scalar @{$osfonts}, $osfont->{os} || '' } -my @config = qw( - punctuation/common punctuation/marks - latin/sample - symbols/signs1 - math/logic -); -$_ and m{/*+(.+)} and @config = split /[ ]/, $1 for $ENV{PATH_INFO}, $get{q}; -@config = qw(ipa/cons ipa/vowels) if 0; - -for (@config) { - my ($tablegroup, $tablename) = split m{/}, $_, 2; - - print ''; - printf '', "$tablegroup: $tablename"; - say ''; - print '' x 3; - print "" for 2, map { scalar @{$oslist{$_}} } @ossel; - print ''; - print ''; - my $table = $tables->{$tablegroup}->{$tablename}; - - for my $chr (@$table) { - $chr =~ m/^\./ .. 1 or next; - given ($chr) { - when (/^[.]/) { - print "\n"; - next; - } - when ([qw(> - =)]) { - next; - } +print ''; +print ''; + $name = sprintf 'Unicode v%.1f', $name / 10 if $group eq 'version'; + $name = sprintf '%s', EncodeURI("/chars/$group/$name"), EscapeHTML($name) + if $row->{count} and $row->{count} < 1280; + print '
%s
char'; - print 'name'; - print 'dihtml'; - printf('%s', - (map { - scalar @{$_}, - join(', ', map { $_->{-name} } @font{ @{$_} }), - } $oslist{$_}), - $_, - ) for @ossel; - say '
'; +printf('%s', map { EscapeHTML($_) } + join("\n", $_->{name}, $_->{description}), + "/font/$_->{file}", + $_->{abbr}, +) for @{ $cover->{fonts} }[@fontlist]; +say ''; + +for (@rows) { + my ($group, $name) = split m{/}, $_, 2; + my $row = $cover->{$group}->{$name}; + + print '
', $name; + print '', $row->{count}; + for my $count (@{ $row->{support} }[@fontlist]) { + if (not defined $count) { + print '?'; + next; + } + if (not $count) { + print '✘'; + next; + } + if ($count == $row->{count}) { + print '✔'; + next; } - my $ex = s/^-//; - my $codepoint = ord $chr; - my $ascii = $codepoint <= 127; - - print "
$chr\n"; - my $info = $glyphs->glyph_info($codepoint); - my ($class, $name, $mnem, $html, $string) = @$info; - print "$_" for sprintf('%X', $codepoint), EscapeHTML($name); - printf '%s', @$_ for ( - [$ascii ? 'l0' : defined $mnem ? 'l4' : 'l1', $mnem // ''], - [$ascii ? 'l0' : defined $html ? 'l4' : 'l1', $html // ''], - (map { - !$font{$_}->{-id} ? [l0 => "$_?"] : - $font{$_}->{$chr} ? [l4 => $font{$_}->{-id}] : [l1 => ''] - } @fontlist), - ); + my $rel = $count / $row->{count}; + my $class = $rel < .5 ? 2 : $rel < .9 ? 3 : 4; + printf '%d', "l$class", $rel*10; } - say "
\n"; + say '
\n"; + +:>