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 = 'v2.06';

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 = qw(
	^@ NUL ^a SOH ^b STX ^c ETX  ^d EOT ^e ENQ ^f ACK ^g BEL
	^h BS  ^i tab ^j LF  ^k VT   ^l FF  ^m CR  ^n SO  ^o SI
	^p DLE ^q DC1 ^r DC2 ^s DC3  ^t DC4 ^u NAK ^v SYN ^w ETB
	^x CAN ^y EM  ^z SUB ^[ ESC  ^\ FS  ^] GS  ^^ RS  ^_ US
	^? DEL
);

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;
	};

	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/^$/_/;
	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)($|\s.*)/$2/;
	my $mode = $1;
	my $keyinfo = $self->{def}->{$mode}->{$key};

	return unless defined $keyinfo;
	$keyinfo =~ s/^=// or return $keyinfo;
	return '' if $ancestry->{$key}++;  # endless loop failsafe
	return $self->keyunalias($keyinfo, $ancestry);
}

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

	if (not defined $flags) {
		$flags = $key eq '^0' ? 'ni' : 'no';
	}
	elsif ($flags =~ s/^=//) { # alias
		$desc = $self->{sign}->{alias};
		$desc .= $flags eq "\e" ? 'esc' : $flags;
		$flags = $self->keyunalias($flags) . ' alias';
	}
	if (my $txt = $self->{key}->{$mode.$key}) {
		($desc, $mnem) = split /\n/, $self->escapedesc($txt);
	}

#	$key = $keytrans{$key} if defined $keytrans{$key};
	my $keytxt = $key eq "\e" ? 'Esc' : $self->{def}{$mode}{lead} . escapehtml($key) if $key ne '^0';
	   $keytxt .= $self->{sign}->{$1} while $flags =~ s/(?:^| )(arg[a-ln-z]?)\b//;  # arguments
	   $keytxt .= "<small>$self->{sign}->{motion}</small>" if $flags =~ s/ ?\bargm\b//;  # motion argument
	   $keytxt =~ s{\^(?=.)}{<small>^</small>};  # element around ctrl-identifier
	   $keytxt =~ s{\+(?=.)}{<small>+</small>};  # meta
	my $keyhint = defined($mnem) && qq{ title="$mnem"};
	   $keytxt  = "<b$keyhint>$keytxt</b>";
	   $keytxt .= ' '.$desc if defined $desc;
	   $keytxt = qq{<a href="/$1">$keytxt</a>} if $flags =~ s/ ?\blink(\S*)//;
	my $onclick = $flags =~ s/ ?\bmode(\S*)// && defined $self->{def}{$1} && sprintf(
		' onclick="setmode(%s)"',
		$1 eq '' ? '' : sprintf(q{'mode%s'}, escapeclass($1))
	);
	$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} };

	print '<table id="rows" class="keys">'."\n\n";

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

		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)  # 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) = @_;

	print qq{\t\t<dl class="legend $class">\n};
	printf("\t\t".'<dt class="%s">%s'."\n\t\t\t".'<dd>%s'."\n",
		$_, map { $self->escapedesc($_) } @{ $self->{flag}->{$_} || ["($_)", '...'] }
	) for @$flags;
	print "\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',
			},
		},
		key => {
			'leada' => ['description', 'comments (on hover)'],
		},
		mode => {
			'lead' => 'mode description',
		},
	});
	$keys->map('dvorak') or die "Keyboard map not found";
	
	$keys->print_rows;

=head1 DESCRIPTION

Used by http://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.

