package Shiar_Sheet::Keyboard;

use 5.010;
use strict;
use warnings;
no  warnings 'uninitialized';  # save some useless checks for more legible code
use Carp;

our $VERSION = '3.01';

my @casedesc = (undef, qw/shift ctrl meta/, 'shift meta');
my @rowdesc = qw(numeric top home bottom);
my %keyrows = do 'keys.inc.pl';
# add first two cases of each row again with each char prepended by + (alt)
push @$_, map { [map {"+$_"} @$_] } @$_[0,1] for map {@$_} values %keyrows;

my %keytrans = (
	'^h' => "\x{232B}", # BS
	'^i' => "\x{21E5}", # TAB
	'^m' => "\x{21B5}", # CR
	'^?' => "\x{2326}", # DEL
	'^[' => "\x{238B}", # ESC
);

sub new {
	my $class = shift;
	my ($self) = @_;

	croak 'Invalid keyboard definitions specified' unless ref $self eq 'HASH';
	croak 'No key definitions specified' unless ref $self->{def} eq 'HASH';
	$self->{map} ||= 'qwerty';

	$self->{sign} ||= do {
		require Shiar_Sheet::KeySigns;
		Shiar_Sheet::KeySigns->VERSION(1.04);
		\%Shiar_Sheet::KeySigns::sign;
	};

	$self->{showkeys} = $PLP::Script::showkeys;
	$self->{style   } = $PLP::Script::style;

	bless $self, $class;
}

sub map {
	my $self = shift;
	my ($mapname) = @_;

	return $self->{map} = $mapname if defined $keyrows{$mapname};
	return undef;
}

sub escapeclass {
	local $_ = shift;
	s/\^/_c/g;
	s/\+/_m/g;
	s/\[/_sbo/g;
	s/\]/_sbc/g;
	s/\\/_b/g;
	s/^$/_/;
	return $_;
}

sub escapehtml {
	local $_ = shift;
	s/</&lt;/g;
	s/>/&gt;/g;
	s/  / &nbsp;/g;
	return $_;
}

sub escapedesc {
	my $self = shift;
	local $_ = shift;
	s{ (< ([^>]*) >) }{ $self->{sign}->{$2} // $1 }xeg;
	return $_;
}

sub keyunalias {
	my $self = shift;
	my ($key, $ancestry) = @_;

	$key =~ s/(\S*?)(\+?\^?\S$)/$2/;
	my $mode = $1;
	my $keyinfo = $self->{def}->{$mode}->{$key};

	return unless defined $keyinfo;
	return $keyinfo unless ref $keyinfo eq 'SCALAR';
	$keyinfo = ${$keyinfo};
	return '' if $ancestry->{$key}++;  # endless loop failsafe
	return $self->keyunalias($keyinfo, $ancestry);
}

sub print_letter {
	my $self = shift;
	my ($key, $mode) = @_;

	return if $key eq '^0';
	return 'Esc' if $key eq "\e";
	return $keytrans{$key} if defined $keytrans{$key};
	my $html = $self->{def}{$mode}{lead} . escapehtml($key);
	   $html =~ s{\^(?=.)}{<small>^</small>};  # element around ctrl-identifier
	   $html =~ s{\+(?=.)}{<small>+</small>};  # meta
	return $html;
}

sub print_key {
	my $self = shift;
	my ($mode, $key, $def) = @_;

	if (not defined $def) {
		$def = [$key eq '^0' ? 'ni' : 'no'];
	}
	elsif (ref $def eq 'SCALAR') {
		$def = [undef, $def];
	}
	if (ref $def ne 'ARRAY') {
		carp "print_key: invalid definition for $mode$key: $def";
		return;
	}
	my ($flags, $txt) = @{$def};
	if (ref $txt eq 'SCALAR') {
		my $ref = ${$txt};
		$def = $self->keyunalias($ref);
		$ref = 'esc' if $ref eq "\e";
		$flags //= $def->[0] if ref $def eq 'ARRAY';
		$txt = $self->{sign}->{alias} . $ref;
		$flags .= ' alias';
	}
	my ($desc, $mnem) = split /\n/, $self->escapedesc($txt);

	my $onclick = $flags =~ s/ ?\bmode(\S*)// && defined $self->{def}{$1} && sprintf(
		' onclick="setmode(%s)"',
		$1 eq '' ? '' : sprintf(q{'mode%s'}, escapeclass($1))
	);
	my $keyhint = defined($mnem) && qq{ title="$mnem"};
	if ($self->{tableclass} =~ /\bbig\b/) {
		$onclick .= $keyhint;
		$keyhint = '';
	}
	my $keytxt = $self->print_letter($key, $mode);
	   $keytxt .= "<small>$self->{sign}->{motion}</small>" if $flags =~ s/ ?\bargm\b//;  # motion argument
	   $keytxt .= $self->{sign}->{$1} while $flags =~ s/(?:^| )(arg[a-ln-z]?)\b//;  # arguments
	   $keytxt  = "<b$keyhint>$keytxt</b>";
	   $keytxt .= ' '.$desc if defined $desc;
	   $keytxt = qq{<a href="/$1">$keytxt</a>} if $flags =~ s/ ?\blink(\S*)//;
	$flags =~ s/\bx\w+/ext/;
	$flags =~ s/\bv\d+/new/;
	$flags .= ' chr'.ord(substr $key, -1) if $key ne '^0';

	print qq{\t\t<td class="$flags"$onclick>$keytxt};
	print "\n";
}

sub print_rows {
	my $self = shift;
	my ($rowsspec, $defrows) = @_;
	$defrows ||= [2, 1, 0];
	my %moderows = (
		-DEFAULT => defined $rowsspec && $rowsspec ne '' &&
			split(/\s* ([^=\s]*) = \s*/x, $rowsspec),
		# plus specific mode overrides prefixed by '='
	);
	my @modes = sort keys %{ $self->{def} };

	printf '<table id="rows" class="%s">'."\n\n", $self->{tableclass} // 'keys';

print_row:
	for (my $row = -1; $row <= $#{ $keyrows{$self->{map}} }; $row++) {
		my $keyrow = $row < 0 ? [["\e"]] : $keyrows{$self->{map}}->[$row];

#		grep {
#			defined $self->{def}->{''}->{$_} or defined $self->{def}->{g}->{$_}
#		} map { @{$_} } @{$keyrow} or next;

		printf qq{<tbody class="row row%d">\n}, $row+1;
		for my $basemode (@modes) {
			my @moderows = split /\s+/,
				$row < 0 ? '1' : # top row (esc key) always unshifted
				$moderows{$basemode} // $moderows{-DEFAULT};

		for my $submode (@moderows ? @moderows : '') {
			my $mode = $basemode . $submode;
			my @caserows = $mode =~ s/(\d+)(?:-(\d*))?$//
				? (map {$_ - 1} split //, $row == 0 ? $2 // $1 : $1)  # user override
				: @$defrows;  # default
			my $modekeys = $self->{def}{$mode};

			for my $case (@caserows) {
				my $keycase = $keyrow->[$case] or next;
				  @$keycase or next;
				my @caseclass;
				push @caseclass, 'mode', 'mode'.escapeclass($basemode) if $basemode ne '';
				push @caseclass, 'lead' if defined $modekeys->{lead};  # leading command key shown
				push @caseclass, $casedesc[$case] if defined $casedesc[$case];

				printf "\t<tr%s>", @caseclass > 0 && sprintf(
					' class="%s"', join ' ', @caseclass
				);
				printf('<th>%s<small>: %s</small></th>', # XXX insert &nbsp; here to fix msie<=6
						$self->escapedesc($self->{mode}->{$mode} || "mode $basemode"),
						"$rowdesc[$row] row $casedesc[$case]"
				) unless $row < 0;
				print "\n";
				$self->print_key($mode, $_, $modekeys->{$_}) for @$keycase;
				print qq{\t\t</tr>\n};
			} # case

		} # submode

		} # basemode
		print qq{\t</tbody>\n};
	} # row

	print "</table>\n";
}

sub print_legend {
	my $self = shift;
	my ($class, $flags) = @_;

	say qq{\t\t<dl class="legend $class">};
	printf("\t\t".'<dt class="%s">%s'."\n\t\t\t".'<dd>%s</dd>'."\n",
		$_, map { $self->escapedesc($_) } @{ $self->{flag}->{$_} || ["($_)", '...'] }
	) for @$flags;
	say "\t\t</dl>";
}

1;

=head1 NAME

Shiar_Sheet::Keyboard - Output HTML for key sheets

=head1 SYNOPSIS

	our %sign = (alias => 'see: ');
	
	my $keys = Shiar_Sheet::Keyboard({
		def => {
			'lead' => {
				'A' => \'a', # alias
				'a' => ['classes', 'description', 'hover comments'],
			},
		},
		mode => {
			'lead' => 'mode description',
		},
	});
	$keys->map('dvorak') or die "Keyboard map not found";
	
	$keys->print_rows;

=head1 DESCRIPTION

Used by https://sheet.shiar.nl to display keyboard sheets.
Assumes specific stylesheets and javascript from this site,
so probably not of much use elsewhere.

=head1 AUTHOR

Mischa POSLAWSKY <perl@shiar.nl>

=head1 LICENSE

Licensed under the GNU Affero General Public License version 3.

