package Shiar_Sheet::Keyboard;

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

our $VERSION = '1.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 $self = shift;
	my ($keys) = @_;

	croak 'Invalid key table specified' unless ref $keys eq 'HASH';
	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;

	bless {sign => $sign, keys => $keys, map => 'qwerty'}, $self;
}

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->{keys}->{$mode}->{$key};

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

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

	$keyinfo = [ $self->{sign}->{alias}.$keyinfo, $self->keyunalias($keyinfo)->[1] . ' alias' ]
		if defined $keyinfo and not ref $keyinfo;  # alias
	my ($desc, $flags, $mnem) = @$keyinfo if defined $keyinfo;
	defined $desc or $flags = $key eq '^0' ? 'ni' : 'no';

#	$key = $keytrans{$key} if defined $keytrans{$key};
	my $keytxt = $mode . 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
	my $onclick = $flags =~ s/ ?\bmode(\S*)// && defined $self->{keys}{$1} && sprintf(
		' onclick="setmode(%s)"',
		$1 eq '' ? '' : sprintf(q{'mode%s'}, escapeclass($1))
	);
	$onclick .= sprintf(q{ onclick="document.location='%s'"}, $1)
		if $flags =~ s/ ?\blink(\S*)//;
	my $keyhint = defined($mnem) && qq{ title="$mnem"};

	print qq{\t\t<li class="$flags"$onclick><b$keyhint>$keytxt</b>};
	print ' ', $desc if defined $desc;
	print "\n";
}

sub print_rows {
	my $self = shift;
	my $static = shift;
	my @moderows = $static ? split(/\s+/, $static) : sort keys %{ $self->{keys} };

	for (my $row = 0; $row <= $#{ $keyrows{$self->{map}} }; $row++) {
		my $keyrow = $keyrows{$self->{map}}->[$row];
		my @caserows = 0 .. $#$keyrow;

		print qq{<li class="row row$row"><ul>\n};
		for my $modefull (@moderows) {
			my $mode = $modefull;
			my @showcase = $mode =~ s/(\d+)(?:-(\d+))?$//
				? (map {3 - $_} split //, $row == 0 && $2 || $1) : @caserows;
			my $modekeys = $self->{keys}{$mode};

			for my $case (@showcase) {
				my $keycase = $keyrow->[$case] or next;
				  @$keycase or next;

				printf "\t<li%s>", $mode ne '' && sprintf(
					' class="%s"', ($static ? '' : 'mode ') . 'mode' . escapeclass($mode)
				);
				printf("<h3>%s<small>: %s</small></h3>\n", # XXX insert &nbsp; here to fix msie<=6
						$modekeys->{desc} || "mode $mode",
						"$rowdesc[$row] row $casedesc[$case]"
				);
				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($modekeys->{lead}, $_, $modekeys->{$_}) for @$keycase;
				print qq{\t\t</ul>\n};
			} # case

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

1;

=head1 NAME

Shiar_Sheet::Keyboard - Output HTML for key sheets

=head1 SYNOPSIS

	our %sign = (alias => 'see: ');
	
	my $keys = Shiar_Sheet::Keyboard({
		'mode' => {
			desc => 'mode description',
			'A' => 'a', # alias
			'a' => ['description', 'classes', 'comments (on hover)'],
		},
	});
	$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.

