git.shiar.nl / sheet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
index: release v1.18 with only altgr index linked
[sheet.git] / Shiar_Sheet / Keyboard.pm
diff --git a/Shiar_Sheet/Keyboard.pm b/Shiar_Sheet/Keyboard.pm
index d8d827440b474d88a68d680028ad95a682dd815f..c7e455b353616b10d7780c963c02c618cfba8e20 100644 (file)
--- a/Shiar_Sheet/Keyboard.pm
+++ b/Shiar_Sheet/Keyboard.pm
@@ -1,37 +1,45 @@
 package Shiar_Sheet::Keyboard;
 
 package Shiar_Sheet::Keyboard;
 
+use 5.010;
 use strict;
 use warnings;
 no  warnings 'uninitialized';  # save some useless checks for more legible code
 use Carp;
 
 use strict;
 use warnings;
 no  warnings 'uninitialized';  # save some useless checks for more legible code
 use Carp;
 
-our $VERSION = '1.01';
+our $VERSION = '2.10';
 
 
-my @casedesc = qw(ctrl shift);
+my @casedesc = (undef, qw/shift ctrl meta/, 'shift meta');
 my @rowdesc = qw(numeric top home bottom);
 my %keyrows = do 'keys.inc.pl';
 my @rowdesc = qw(numeric top home bottom);
 my %keyrows = do 'keys.inc.pl';
-
-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
+# 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 {
 );
 
 sub new {
-       my $self = shift;
-       my ($keys) = @_;
+       my $class = shift;
+       my ($self) = @_;
 
 
-       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 '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;
        };
        };
-       croak "%${parent}::sign not found" unless %$sign;
 
 
-       bless {sign => $sign, keys => $keys, map => 'qwerty'}, $self;
+       $self->{showkeys} = $PLP::Script::showkeys;
+       $self->{style   } = $PLP::Script::style;
+
+       bless $self, $class;
 }
 
 sub map {
 }
 
 sub map {
@@ -45,8 +53,10 @@ sub map {
 sub escapeclass {
        local $_ = shift;
        s/\^/_c/g;
 sub escapeclass {
        local $_ = shift;
        s/\^/_c/g;
+       s/\+/_m/g;
        s/\[/_sbo/g;
        s/\]/_sbc/g;
        s/\[/_sbo/g;
        s/\]/_sbc/g;
+       s/\\/_b/g;
        s/^$/_/;
        return $_;
 }
        s/^$/_/;
        return $_;
 }
@@ -59,85 +69,148 @@ sub escapehtml {
        return $_;
 }
 
        return $_;
 }
 
+sub escapedesc {
+       my $self = shift;
+       local $_ = shift;
+       s{ (< ([^>]*) >) }{ $self->{sign}->{$2} // $1 }xeg;
+       return $_;
+}
+
 sub keyunalias {
        my $self = shift;
        my ($key, $ancestry) = @_;
 
 sub keyunalias {
        my $self = shift;
        my ($key, $ancestry) = @_;
 
-       $key =~ s/(\S*?)(\^?\S)($|\s.*)/$2/;
+       $key =~ s/(\S*?)(\+?\^?\S)($|\s.*)/$2/;
        my $mode = $1;
        my $mode = $1;
-       my $keyinfo = $self->{keys}->{$mode}->{$key};
+       my $keyinfo = $self->{def}->{$mode}->{$key};
 
 
-       return [] unless defined $keyinfo;
-       return $keyinfo if ref $keyinfo;
-       return if $ancestry->{$key}++;  # endless loop failsafe
+       return unless defined $keyinfo;
+       $keyinfo =~ s/^=// or return $keyinfo;
+       return '' if $ancestry->{$key}++;  # endless loop failsafe
        return $self->keyunalias($keyinfo, $ancestry);
 }
 
        return $self->keyunalias($keyinfo, $ancestry);
 }
 
-sub print_key {
+sub print_letter {
        my $self = shift;
        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';
+       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;
+}
 
 
-#      $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
+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/^=(\S+)\s?//) { # alias
+               my $ref = $1;
+               $desc = $self->{sign}->{alias} . ($ref eq "\e" ? 'esc' : $ref);
+               $flags = join ' ', $self->keyunalias($ref), 'alias', $flags;
+       }
+       if (my $txt = $self->{key}->{$mode.$key}) {
+               ($desc, $mnem) = split /\n/, $self->escapedesc($txt);
+       }
+
+       my $keytxt = $self->print_letter($key, $mode);
           $keytxt .= "<small>$self->{sign}->{motion}</small>" if $flags =~ s/ ?\bargm\b//;  # motion argument
           $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(
+          $keytxt .= $self->{sign}->{$1} while $flags =~ s/(?:^| )(arg[a-ln-z]?)\b//;  # arguments
+       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))
        );
                ' 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"};
+       $flags =~ s/\bx\w+/ext/;
+       $flags =~ s/\bv\d+/new/;
+       $flags .= ' chr'.ord(substr $key, -1) if $key ne '^0';
 
 
-       print qq{\t\t<li class="$flags"$onclick><b$keyhint>$keytxt</b>};
-       print ' ', $desc if defined $desc;
+       print qq{\t\t<td class="$flags"$onclick>$keytxt};
        print "\n";
 }
 
 sub print_rows {
        my $self = shift;
        print "\n";
 }
 
 sub print_rows {
        my $self = shift;
-       my $static = shift;
-       my @moderows = $static ? split(/\s+/, $static) : sort keys %{ $self->{keys} };
+       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';
 
 
-       for (my $row = 0; $row <= $#{ $keyrows{$self->{map}} }; $row++) {
-               my $keyrow = $keyrows{$self->{map}}->[$row];
-               my @caserows = 0 .. $#$keyrow;
+print_row:
+       for (my $row = -1; $row <= $#{ $keyrows{$self->{map}} }; $row++) {
+               my $keyrow = $row < 0 ? [["\e"]] : $keyrows{$self->{map}}->[$row];
 
 
-               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};
+#              grep {
+#                      defined $self->{def}->{''}->{$_} or defined $self->{def}->{g}->{$_}
+#              } map { @{$_} } @{$keyrow} or next;
 
 
-                       for my $case (@showcase) {
+               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 $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<li%s>", $mode ne '' && sprintf(
-                                       ' class="%s"', ($static ? '' : 'mode ') . 'mode' . escapeclass($mode)
+                               printf "\t<tr%s>", @caseclass > 0 && sprintf(
+                                       ' class="%s"', join ' ', @caseclass
                                );
                                );
-                               printf("<h3>%s<small>: %s</small></h3>\n", # XXX insert &nbsp; here to fix msie<=6
-                                               $modekeys->{desc} || "mode $mode",
+                               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]"
                                                "$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};
+                               ) unless $row < 0;
+                               print "\n";
+                               $self->print_key($mode, $_, $modekeys->{$_}) for @$keycase;
+                               print qq{\t\t</tr>\n};
                        } # case
 
                        } # case
 
-               } # mode
-               print qq{\t</ul>\n};
+               } # submode
+
+               } # basemode
+               print qq{\t</tbody>\n};
        } # row
        } # 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;
 }
 
 1;
@@ -151,10 +224,17 @@ Shiar_Sheet::Keyboard - Output HTML for key sheets
        our %sign = (alias => 'see: ');
        
        my $keys = Shiar_Sheet::Keyboard({
        our %sign = (alias => 'see: ');
        
        my $keys = Shiar_Sheet::Keyboard({
-               'mode' => {
-                       desc => 'mode description',
-                       'A' => 'a', # alias
-                       'a' => ['description', 'classes', 'comments (on hover)'],
+               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->map('dvorak') or die "Keyboard map not found";
@@ -163,7 +243,7 @@ Shiar_Sheet::Keyboard - Output HTML for key sheets
 
 =head1 DESCRIPTION
 
 
 =head1 DESCRIPTION
 
-Used by http://sheet.shiar.nl to display keyboard sheets.
+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.
 
 Assumes specific stylesheets and javascript from this site,
 so probably not of much use elsewhere.
 
sheet.shiar.nl - software cheat sheets