package Shiar_Sheet::Keyboard;

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

our $VERSION = 'v2.02';

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

	my $parent = (caller)[0];  # calling module
	my $sign = do {
		no strict 'refs';  # temporarily allow variable references
		\%{ $parent.'::sign' };  # return %sign from parent
	};
	croak "%${parent}::sign not found" unless %$sign;
	$self->{sign} = $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 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;
	return $keyinfo->[0] if ref $keyinfo;
	return '' if $ancestry->{$key}++;  # endless loop failsafe
	return $self->keyunalias($keyinfo, $ancestry);
}

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

	if (not defined $flags) {
		$flags = [$key eq '^0' ? 'ni' : 'no'];
	}
	elsif (not ref $flags) { # alias
		my $desc = $self->{sign}->{alias};
		$desc .= $flags eq "\e" ? 'esc' : $flags;
		$flags = [$self->keyunalias($flags) . ' alias', $desc];
	}
	my ($flags, $desc, $mnem) = @{$flags};
	if (my $txt = $self->{key}->{$mode.$key}) {
		($desc, $mnem) = @{$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<li class="$flags"$onclick>$keytxt};
	print "\n";
}

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

	print '<ul id="rows">'."\n\n";

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

		printf qq{<li class="row row%d"><ul>\n}, $row+1;
		for my $basemode (@modes) {
			my @moderows = split /\s+/,
				defined $moderows{$basemode} ? $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;

				printf "\t<li%s>", $basemode ne '' && sprintf(
					' class="%s"', 'mode mode' . escapeclass($basemode)
				);
				printf('<h3>%s<small>: %s</small></h3>', # XXX insert &nbsp; here to fix msie<=6
						$self->{mode}->{$mode} || "mode $basemode",
						"$rowdesc[$row] row $casedesc[$case]"
				) unless $row < 0;
				print "\n";
				my $caseclass = 'keys';
				   $caseclass .= ' lead' if defined $modekeys->{lead};  # leading command key shown
				   $caseclass .= " $casedesc[$case]" if defined $casedesc[$case];
				print qq{\t\t<ul class="$caseclass">\n};
				$self->print_key($mode, $_, $modekeys->{$_}) for @$keycase;
				print qq{\t\t</ul>\n};
			} # case

		} # submode

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

	print "</ul>\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",
		$_, @{ $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.

