Source of charset.plp

<(common.inc.plp)><:

my $mode = exists $get{compare};
my @tablist = split m{/+}, $Request || 'default';

Html({
	title => 'charset cheat sheet',
	version => '1.4',
	canonical => "/charset/$Request" . ($mode && '?compare'),
	description => [
		"Reference sheet with all glyphs in common character encoding tables,",
		"and an overview of Unicode ranges and UTF-8 bytes.",
	],
	keywords => [qw'
		charset codepage unicode ascii utf8 latin glyph character encoding
		reference common overview table
	'],
	data => [qw(
		charset.inc.pl charset-encoding.inc.pl
		charset-unicode.inc.pl charset-ucplanes.inc.pl charset-utf8.inc.pl
	)],
});

use List::Util qw( first pairmap pairfirst pairs );

:>
<h1>Character encodings</h1>

<p>
<:
if ($tablist[0] eq 'unicode') {
	say "Detailed allocation of Unicode blocks.";
	print "See ", showlink("charsets", '/charset'), " to compare specific encodings";
}
else {

if ($tablist[0] eq 'default') {
	say "Overview of Unicode ", showlink("allocation", '/charset/unicode');
	say "and common latin code pages.";
	say "Compare alternate charsets:";
}
else {
	say "Charset comparison:";
}

print join " •\n", (
	map {
		join " ·\n", pairmap {
			showlink($b || ucfirst $a, '/charset'.($a && "/$a?compare"), $a eq $Request);
		} @{$_}
	}
	[
		iso      => 'ISO',
		win      => 'Windows',
		dos      => 'DOS',
		mac      => 'Apple',
		ebcdic   => 'EBCDIC',
		legacy   => 'legacy',
		symbols  => 'symbols',
		$tablist[0] eq 'default' ? () : ('' => 'common'),
	],
	[
		westeur  => 'West',
		centeur  => 'Central',
		norteur  => 'North European',
		turkish  => 0,
		greek    => 0,
		cyrillic => 0,
		hebrew   => 0,
	],
);

}
:>.
</p>

<:
use POSIX qw( ceil );
use Shiar_Sheet::FormatChar;
my $glyphs = Shiar_Sheet::FormatChar->new;
my @request;

my $charsets = Data('charset');

sub tabinput {
	# generate character table(s)
	my $input = shift or return;
	my $params = $input =~ s/[+](.*)\z// ? $1 : undef;
	my $charset = $charsets->{lc $input} || {};

	if (ref $charset ne 'HASH') {
		$params and Alert("Parameters ignored for $input",
			"Cannot apply <q>$params</q> to multiple charsets.",
		);
		tabinput($_) for ref $charset ? @{$charset} : $charset;
		return;
	}

	state $visible = {'' => 1};  # all present tables
	my %row = (offset => 0, cols => 16);
	$row{$_} = $charset->{$_} for qw( note table );  # copy metadata

	if (not defined $params) {
		my @parents = @{ $charset->{inherit} || [] };

		if (my ($parent, $part) = pairfirst { defined $visible->{$a} } @parents) {
			$row{parent} = $parent;
			$params = $part;
			$params = 80 unless $visible->{$parent}
				or ($input eq 'MacCroatian' and defined $visible->{MacRomanian});
		}
		elsif (defined $visible->{ascii}) {
			$row{parent} = $parents[0];
			$params = $parents[1] // 80;
			$params = 80 if hex $params >= 0x80;  # ascii offset at most
		}
		elsif (@parents) {
			$row{parent} = $parents[0];
			$params = $parents[1] if $parents[1] =~ /^0+-/;  # apply ascii end
		}
		$visible->{$_} //= 0 for $row{parent} || ();
	}

	for my $param (split /[+]+/, $params // '') {
		if ($param eq 'realsize') {
			$row{realsize}++;
		}
		elsif ($param =~ m{ \A cols = (\d+) \z }x) {
			$row{cols} = $1;
		}
		elsif ($param =~ m{ \A (?<start> \p{AHex}+) (?: [-] (?<end> \p{AHex}+) )? \z }x) {
			if (defined $row{endpoint}) {
				# extend earlier range
				my $skip = int(($row{endpoint} || $row{startpoint}) / $row{cols});
				for ($skip + 1 .. (hex($+{start}) / $row{cols}) - 1) {
					$row{skip}->{ $_ * $row{cols} }++;
				}
			}
			else {
				$row{startpoint} = hex $+{start};
			}
			$row{endpoint} = hex($+{end} || 0);
		}
		else {
			Alert("Unknown option <q>$param</q> for charset $input");
		}
	}

	if ($charset->{setup}) {
		eval { $charset->{setup}->(\%row) }
			or Alert("Incomplete setup of $input", $@);
	}
	$row{endpoint} ||= 0xFF;

	if (defined $row{table} or defined $row{cell}) {
		$row{set} //= $input;
	}
	elsif ($row{set} = Encode::resolve_alias($charset->{set} // $input)) {
		$row{offset} = delete $row{startpoint};
		if ($charset->{varchar}) {
			# array of possibly multiple characters per code point
			$row{table} = [
				map { Encode::decode($row{set}, pack 'C*', $_) } $row{offset} .. $row{endpoint}
			];
		}
		else {
			# ~16x faster than decoding in loop;
			# substr strings is twice as fast as splitting to an array
			$row{table} = Encode::decode($row{set}, pack 'C*', $row{offset} .. $row{endpoint});
		}

		$row{endpoint} -= $row{offset};
		$visible->{ascii}++;  # assume common base
		$row{set} = $input if $charset->{set};  # base override
	}
	else {
		Alert("Encoding <q>$input</q> unknown");
		return;
	}

	if (my $replace = $charset->{replace}) {
		while (my ($offset, $sub) = each %{$replace}) {
			$offset -= $row{offset};

			if (ref $row{table} eq 'ARRAY') {
				$row{table}->[$offset] = $sub
					if $offset >= 0 and $offset <= $row{endpoint};
				next;
			}

			my $length = length $sub;

			if ($offset < 0) {
				$offset > -$length or next; # at least one character after start
				# trim leftmost part to start at offset
				substr($sub, 0, -$offset) = '';
				$length += $offset;
				$offset = 0;
			}

			if ((my $excess = $row{endpoint} - $offset - $length + 1) < 0) {
				$excess > -$length or next;
				# trim rightmost part to prevent overflow
				substr($sub, $excess) = '';
				$length += $excess;
			}

			substr($row{table}, $offset, $length) = $sub;
		}
	}

	push @request, \%row;
	$visible->{ $row{set} } = 1 if $row{table};
}
tabinput($_) for @tablist;

my $NOCHAR = chr 0xFFFD;

sub range_cell {
	my ($info, $offset) = @_;
	my $table = $info->{cell} or return;
	my $def = $table->{$offset} or return;
	my ($len, $class, $name, $title) = @{$def};

	my $cols = $info->{cols};
	my $colsize = $table->{colsize} || 1;
	my $attr = '';
	$len /= $colsize;
	$name //= $len <= 2 ? 'res' : 'reserved';

	if (my $part = ($offset/$colsize - $info->{startpoint}) % $cols) {
		# continued row
		my $rest = $cols - $part;  # remaining
		$rest = $len if $len < $rest; #TODO: optimise
		if ($len -= $rest) {
			# continued on new row
			my @next = ($len * $colsize, "$class joinu");
			my $separate = $cols - $len > $rest;  # columns not on next row
			if ($len > $rest) {
				# minority remains
				push @next, $name, $title;
				$title ||= $name;
				$name = $separate && '…';
			}
			else {
				# minority on next row
				push @next, $separate && '"', $title || $name;
			}
			$table->{$offset + $colsize*$rest} //= \@next;
			$class .= ' joind';
		}
		$len = $rest;
	}
	elsif (my $rows = int($len / $cols)) {
		# multiple full rows
		my $rowsize = $colsize * $cols;
		if ($len -= $rows * $cols) {
			# partial row remains
			$table->{$offset + $rowsize * $rows} //= [$len*$colsize, "$class joinu", '', $title];
			$class .= ' joind';
		}

		unless ($info->{realsize}) {
			# coalesce multiple rows
			while ($rows > 3) {
				$info->{skip}->{$offset += $rowsize}++;
				$rows--;
			}
			if ($rows > 2) {
				$info->{skip}->{$offset += $rowsize} = 0;
			}
		}

		$attr .= sprintf ' rowspan=%d', $rows;
		$len = $cols;
	}

	$attr .= sprintf ' colspan=%d', $len unless $len == 1;
	$attr .= $1 if $class and $class =~ s/( \w+="[^"]*")//;
	$attr .= sprintf ' class="%s"', $class if $class;
	$attr .= sprintf ' title="%s"', EscapeHTML($title) if $title;
	return "<td$attr>$name\n";
}

for my $row (@request) {
	my $cols = $row->{cols};
	my $colsize = $row->{cell} && $row->{cell}->{colsize} || 1;
	my $coldigits = ceil(log($colsize * $cols) / log(16));  # uniform length of hexadecimal header
	my $rowdiv = 16 ** $coldigits;  # row divide for column digits
	$rowdiv = 1 if $rowdiv != $cols * $colsize;  # divide only if all columns are matched
	my $offset = $row->{startpoint} * $colsize || 0;

	printf '<div class="section"><table class="glyphs%s">', !$row->{cell} && ' charmap';
	my $title = $row->{set};
	$title .= " <aside>(over $_)</aside>" for $row->{parent} || ();
	$title .= " <aside>($_)</aside>" for $row->{note} || ();
	printf '<caption>%s</caption>', $title;
	print '<col>' x ($cols + 1);
	for my $section (qw{thead}) {
		print "<$section><tr><th>", $rowdiv == 1 ? '+' : '↱';
		printf '<th>%0*X', $coldigits, $_ * $colsize for 0 .. $cols - 1;
		print "\n";
	}

	print '<tbody>';
	while ($offset <= $row->{endpoint} * $colsize) {
		if ($row->{skip}->{$offset + $row->{offset}}) {
			$offset += $cols * $colsize;
			next;
		}

		print '<tr><th>';
		if (defined $row->{skip}->{$offset + $row->{offset}}) {
			print '⋮';
		}
		else {
			if (my $rowmod = $offset % $rowdiv) {
				# offset in column units
				printf '<small>+%X</small>', $rowmod;
			}
			else {
				# divided row offset
				printf '%X', ($offset + $row->{offset}) / $rowdiv;
			}
		}
		say '';

		for (1 .. $cols) {
			if ($row->{cell}) {
				print range_cell($row, $offset);
				next;
			}

			my $cp = $offset + $row->{offset};
			my $glyph = ref $row->{table} eq 'ARRAY' ? $row->{table}->[$offset] :
				substr $row->{table}, $offset, 1;
			my ($cell, $name, $class) = !defined $glyph || $glyph eq $NOCHAR ? () :
				$glyphs->glyph_html($glyph);

			if ($mode) {
				state $visible = {};
				$class = (
					$cp == ord $glyph ? 'l4' :
					$row->{parent} && $glyph eq
						Encode::decode($row->{parent}, pack 'C', $cp) ? 'l3' :
					!defined $cell ? undef :
					$visible->{$glyph} ? 'l2' :
					'l1'
				);
				$visible->{$glyph}++;
			}

			printf '<td title="%s"', $name;
			say $class ? sprintf(' class="X %s">%s', $class, $cell) : '>';
		}
		continue {
			$offset += $colsize;
		}
	}
	say '</table></div>';
}

:>
<hr>

<div class="legend">
	<table class="glyphs"><tr><: if ($mode) { :>
	<td class="X l4">unicode
	<td class="X l3">inherited
	<td class="X l2">existing
	<td class="X l1">original
	<td class="">unassigned
<: } else { :>
	<td class="X Cc">control
	<td class="X Zs"><span>whitespace</span>
	<td class="X Mn">diacritic<table class="glyphs"><tr>
		<td class="X Sk">letter
		</table>
	<td class="X Po">punctuation<table class="glyphs"><tr>
		<td class="X Pf">quote
		</table>
	<td class="X So">symbol<table class="glyphs"><tr>
		<td class="X Sm">math
		<td class="X Sc">currency
		</table>
	<td class="X No">numeric
	<td class="X Greek">greek<table class="glyphs"><tr>
		<td class="X Latin">latin
		<td class="X Cyrillic">cyrillic
		</table>
	<td class="X Aramaic">aramaic<table class="glyphs"><tr>
		<td class="X Brahmic">brahmic
		<td class="X Arabic">arabic
		</table>
	<td class="X Syllabic">syllabic<table class="glyphs"><tr>
		<td class="X African">african
		<td class="X Hiragana">japanese
		<td class="X Han">cjk
		<td class="X Bopomofo">chinese
		</table>
	<td class="X Alpha">alphabetic
	</table>

	<table class="glyphs"><tr>
	<td class="X">unicode 10.0
	<td class="X Xr">proposed
	<td class="X Xd">deprecated
	<td class="">unassigned
	<td class="X Xi">invalid
<: } :>	</table>
</div>

sheet.shiar.nl/source.plp version 1.4 created by Shiar • AGPLv3