git.shiar.nl / sheet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
digraphs: link to and from altgr keyboards
[sheet.git] / Shiar_Sheet / Keyboard.pm
diff --git a/Shiar_Sheet/Keyboard.pm b/Shiar_Sheet/Keyboard.pm
index 936b811f08c0e1e66be0c22ff7f32f3133660959..4d1c54eba23fb71f309ace67ecfa14572feeb19d 100644 (file)
--- a/Shiar_Sheet/Keyboard.pm
+++ b/Shiar_Sheet/Keyboard.pm
@@ -1,11 +1,12 @@
 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 = 'v2.02';
+our $VERSION = '3.01';
 
 my @casedesc = (undef, qw/shift ctrl meta/, 'shift meta');
 my @rowdesc = qw(numeric top home bottom);
 
 my @casedesc = (undef, qw/shift ctrl meta/, 'shift meta');
 my @rowdesc = qw(numeric top home bottom);
@@ -13,12 +14,12 @@ 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;
 
 # 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
+my %keytrans = (
+       '^h' => "\x{232B}", # BS
+       '^i' => "\x{21E5}", # TAB
+       '^m' => "\x{21B5}", # CR
+       '^?' => "\x{2326}", # DEL
+       '^[' => "\x{238B}", # ESC
 );
 
 sub new {
 );
 
 sub new {
@@ -29,13 +30,14 @@ sub new {
        croak 'No key definitions specified' unless ref $self->{def} eq 'HASH';
        $self->{map} ||= 'qwerty';
 
        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
+       $self->{sign} ||= do {
+               require Shiar_Sheet::KeySigns;
+               Shiar_Sheet::KeySigns->VERSION(1.04);
+               \%Shiar_Sheet::KeySigns::sign;
        };
        };
-       croak "%${parent}::sign not found" unless %$sign;
-       $self->{sign} = $sign;
+
+       $self->{showkeys} = $PLP::Script::showkeys;
+       $self->{style   } = $PLP::Script::style;
 
        bless $self, $class;
 }
 
        bless $self, $class;
 }
@@ -54,6 +56,7 @@ sub escapeclass {
        s/\+/_m/g;
        s/\[/_sbo/g;
        s/\]/_sbc/g;
        s/\+/_m/g;
        s/\[/_sbo/g;
        s/\]/_sbc/g;
+       s/\\/_b/g;
        s/^$/_/;
        return $_;
 }
        s/^$/_/;
        return $_;
 }
@@ -66,118 +69,161 @@ 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$)/$2/;
        my $mode = $1;
        my $keyinfo = $self->{def}->{$mode}->{$key};
 
        return unless defined $keyinfo;
        my $mode = $1;
        my $keyinfo = $self->{def}->{$mode}->{$key};
 
        return unless defined $keyinfo;
-       return $keyinfo->[0] if ref $keyinfo;
+       return $keyinfo unless ref $keyinfo eq 'SCALAR';
+       $keyinfo = ${$keyinfo};
        return '' if $ancestry->{$key}++;  # endless loop failsafe
        return $self->keyunalias($keyinfo, $ancestry);
 }
 
        return '' if $ancestry->{$key}++;  # endless loop failsafe
        return $self->keyunalias($keyinfo, $ancestry);
 }
 
-sub print_key {
+sub print_letter {
        my $self = shift;
        my $self = shift;
-       my ($mode, $key, $flags) = @_;
+       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;
+}
 
 
-       my $txt = $self->{key}->{$mode.$key};
-       my ($desc, $mnem) = defined $txt ? @$txt : ();
+sub print_key {
+       my $self = shift;
+       my ($mode, $key, $def) = @_;
 
 
-       if (not defined $flags) {
-               $flags = $key eq '^0' ? 'ni' : 'no';
+       if (not defined $def) {
+               $def = [$key eq '^0' ? 'ni' : 'no'];
+       }
+       elsif (ref $def eq 'SCALAR') {
+               $def = [undef, $def];
        }
        }
-       elsif (not ref $flags) { # alias
-               $desc = $self->{sign}->{alias} . $flags;
-               $flags = $self->keyunalias($flags) . ' alias';
+       if (ref $def ne 'ARRAY') {
+               carp "print_key: invalid definition for $mode$key: $def";
+               return;
        }
        }
-       else {
-               $flags = $flags->[0];
+       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);
 
 
-#      $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))
        );
        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';
 
        $flags .= ' chr'.ord(substr $key, -1) if $key ne '^0';
 
-       print qq{\t\t<li class="$flags"$onclick>$keytxt};
+       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 ($rowsspec, $defrows) = @_;
+       $defrows ||= [2, 1, 0];
        my %moderows = (
        my %moderows = (
-               -DEFAULT => !@_ ? '' : split(/(?:\s*([^=\s]*)=\s*)/, shift),
+               -DEFAULT => defined $rowsspec && $rowsspec ne '' &&
+                       split(/\s* ([^=\s]*) = \s*/x, $rowsspec),
                # plus specific mode overrides prefixed by '='
        );
                # plus specific mode overrides prefixed by '='
        );
-       my $defrows = shift || [2, 1, 0];
        my @modes = sort keys %{ $self->{def} };
 
        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];
 
        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 ($row < 0 ? '' : @modes) {
+#              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+/,
                        my @moderows = split /\s+/,
-                               defined $moderows{$basemode} ? $moderows{$basemode} : $moderows{-DEFAULT};
+                               $row < 0 ? '1' : # top row (esc key) always unshifted
+                               $moderows{$basemode} // $moderows{-DEFAULT};
 
                for my $submode (@moderows ? @moderows : '') {
                        my $mode = $basemode . $submode;
 
                for my $submode (@moderows ? @moderows : '') {
                        my $mode = $basemode . $submode;
-                       my @caserows = $mode =~ s/(\d+)(?:-(\d+))?$//
-                               ? (map {$_ - 1} split //, $row == 0 && $2 || $1)  # user override
+                       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;
                                : @$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<li%s>", $basemode ne '' && sprintf(
-                                       ' class="%s"', 'mode mode' . escapeclass($basemode)
+                               printf "\t<tr%s>", @caseclass > 0 && sprintf(
+                                       ' class="%s"', join ' ', @caseclass
                                );
                                );
-                               printf('<h3>%s<small>: %s</small></h3>', # XXX insert &nbsp; here to fix msie<=6
-                                               $self->{mode}->{$mode} || "mode $basemode",
+                               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";
                                                "$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;
                                $self->print_key($mode, $_, $modekeys->{$_}) for @$keycase;
-                               print qq{\t\t</ul>\n};
+                               print qq{\t\t</tr>\n};
                        } # case
 
                } # submode
 
                } # basemode
                        } # case
 
                } # submode
 
                } # basemode
-               print qq{\t</ul>\n};
+               print qq{\t</tbody>\n};
        } # row
        } # row
+
+       print "</table>\n";
 }
 
 sub print_legend {
        my $self = shift;
        my ($class, $flags) = @_;
 
 }
 
 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}->{$_} || ["($_)", '...'] }
+       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;
        ) for @$flags;
-       print "\t\t</dl>";
+       say "\t\t</dl>";
 }
 
 1;
 }
 
 1;
@@ -193,13 +239,10 @@ Shiar_Sheet::Keyboard - Output HTML for key sheets
        my $keys = Shiar_Sheet::Keyboard({
                def => {
                        'lead' => {
        my $keys = Shiar_Sheet::Keyboard({
                def => {
                        'lead' => {
-                               'A' => 'a', # alias
-                               'a' => ['classes'],
+                               'A' => \'a', # alias
+                               'a' => ['classes', 'description', 'hover comments'],
                        },
                },
                        },
                },
-               key => {
-                       'leada' => ['description', 'comments (on hover)'],
-               },
                mode => {
                        'lead' => 'mode description',
                },
                mode => {
                        'lead' => 'mode description',
                },
@@ -210,7 +253,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