use strict;
# http://msdn.microsoft.com/en-us/goglobal/bb688121.aspx#eaaac - is relevant? locales
# http://gilesey.wordpress.com/2012/12/30/initailizing-mfccrt-for-consumption-of-regional-settings-internationalizationc/
# !!! http://stackoverflow.com/questions/8289492/find-out-when-keyboard-layout-is-changed
# If we could find the HWND of our console... GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow(), NULL))
# http://support.microsoft.com/kb/124103
# HWND WINAPI GetConsoleWindow(void);
# Win32::Console has GetConsoleHWND() but only in C!!!
# SetConsoleFlags() reports failure when succeeding (we worked around this)
# ReadConsoleW() has buffer overflows and returns junk on reads more than 1 char when more than 1 char is available
# We got stuck into the default input locale; how to get out and be sensitive to input settings changes?
# Win32::API has problems with: arguments void, return type short, arguments of type long long are considered as long...
# Apparently, return type of "int" is interpreted as "unsigned int" (on 64-bit OS???, any build)
{ my $f;
sub GetKeyboardState (;$) { # Argument: nothing, undef (will auto-vivify) or 256-byte string (byte! use pack 'C', not chr)
require Win32::API; # should be short!:
$f ||= Win32::API->new(q(user32), qq[int GetKeyboardState(char *s)]) or die "Import failed: $!";
my($s) = (@_ ? \shift : \my $tmp);
defined $$s or $$s = ' ' x 256;
256 == length $$s or die "GetKeyboardState(): wrong size of output buffer";
$f->Call($$s) or die "GetKeyboardState() failed: $^E";
$$s
}}
{ my $f;
sub GetKeyState ($) {
require Win32::API;
$f ||= Win32::API->new(q(user32), qq[int GetKeyState(int n)]) or die "Import failed: $!";
my($k) = shift;
$f->Call($k); # or die "GetKeyState($k) failed: $^E";
}}
my %pointer_ints = qw(4 int 8 __int64);
my %pointer_types = qw(4 L 8 Q);
my $HANDLE_t = $pointer_ints{length pack 'p', ''} or die "Cannot work with this pointer size";
my $HANDLE_p = $pointer_types{length pack 'p', ''} or die "Cannot work with this pointer type";
{ my $f;
sub GetKeyboardLayout (;$) {
require Win32::API;
$f ||= Win32::API->new(q(user32), qq[$HANDLE_t GetKeyboardLayout(long tId)]) or die "Import failed: $!";
my $tId = (shift || 0);
$f->Call($tId)
}}
{ my $f;
sub ActivateKeyboardLayout ($;$) {
require Win32::API;
$f ||= Win32::API->new(q(user32), qq[$HANDLE_t ActivateKeyboardLayout($HANDLE_t new, unsigned long flags)]) or die "Import failed: $!";
my($hkl, $fl) = (shift, shift || 0);
$f->Call($hkl, $fl)
}}
{ my $f;
sub GetKeyboardLayoutList () {
require Win32::API;
$f ||= Win32::API->new(q(user32), qq[int GetKeyboardLayoutList(int n, char *s)]) or die "Import failed: $!";
my $n = $f->Call(0, undef) or die "Unexpected: no keyboard layout found";
my $s = '_' x ($n*(length pack 'p', ''));
my $nn = $f->Call($n, $s) or die "No keyboard layout returned (out of $n)";
($n == $nn) or die "Only $nn keyborad layouts (out of $n) returned";
unpack "$HANDLE_p*", $s;
}}
{ my $f;
sub ToUnicode ($;$$$) {
require Win32::API;
$f ||= Win32::API->new(q(user32),
qq[int ToUnicode(unsigned int wVirtKey, unsigned int wScanCode, char *lpKeyState, char* pwszBuff, int cchBuff, unsigned int wFlags)]) or die "Import failed: $!";
my($vk, $sc, $kst, $menu) = (shift, shift, shift, shift);
$kst = "\0" x 256 unless defined $kst;
256 == length $kst or die "keystate buffer of unexpected length)";
$sc = 0 unless defined $sc;
my $buf = '_' x (2*5); # 4 shorts and (not delivered) 0 trailing short
my $rc = $f->Call($vk, $sc, $kst, $buf, length($buf)/2, $menu||0); # or die "ToUnicode() failed: $^E";
warn "\t\tToUnicode() ==> $rc\n";
return unless $rc; # Not a in-char-sequence event
return undef if $rc < 0 or $rc >= 0x80000000; # dead key (bug with forced `unsigned´ in Win32::API???
substr $buf, 2*$rc, 1000, ''; # Truncate
# $buf =~ s/^((..)*)(?=\0\0)/$1/s
require Encode;
Encode::decode('UTF-16LE', $buf);
}}
{ my $f;
sub ToUnicodeEx ($;$$$$) {
require Win32::API;
$f ||= Win32::API->new(q(user32),
qq[int ToUnicodeEx(unsigned int wVirtKey, unsigned int wScanCode, char *lpKeyState, char* pwszBuff, int cchBuff, unsigned int wFlags, $HANDLE_t kbd)]) or die "Import failed: $!";
my($vk, $sc, $kst, $kbd, $menu) = (shift, shift, shift, shift, shift);
$kst = "\0" x 256 unless defined $kst;
256 == length $kst or die "keystate buffer of unexpected length)";
$sc = 0 unless defined $sc;
$kbd = GetKeyboardLayout unless defined $kbd;
my $buf = '_' x (2*5); # 4 shorts and (not actually delivered) 0 trailing short
my $rc = $f->Call($vk, $sc, $kst, $buf, length($buf)/2, $menu || 0, $kbd); # or die "ToUnicode() failed: $^E";
warn sprintf "\t\tToUnicodeEx() ==> %d;\tkbd = %#x\n", $rc, $kbd;
return unless $rc; # Not a in-char-sequence event
return undef if $rc < 0 or $rc >= 0x80000000; # dead key (bug with forced `unsigned´ in Win32::API???
require Encode;
Encode::decode('UTF-16LE', substr $buf, 0, 2*$rc);
}}
my $struct_len = 0;
my %event_types = qw( 1 lsssSx![L]L 2 ssx![L]LLL 4 ss 8 L 16 L );
my $L; # Alignment???
$struct_len < ($L = length pack "s x![L] $_ x![L]", (1) x (1+length)) and $struct_len = $L for values %event_types;
# warn "estimate_str_len=$struct_len";
{ my $f;
sub ReadConsoleEvents (;$$) {
require Win32::API;
$f ||= Win32::API->new(q(kernel32), qq[int ReadConsoleInputW($HANDLE_t h, char *s, long c, char *cc)]);
my($fh, $c) = (shift, shift || 1);
$fh = \*STDIN unless defined $fh;
ref $fh and ($fh = GetOsFHandle $fh or die "fh($fh) has no Win32 handle");
my $i = q(1) x ($struct_len * $c);
my $o = q(1111);
$f->Call($fh, $i, $c, $o) or die "ReadConsoleInputW() failed: $^E";
$o = unpack 'l', $o or die "ReadConsoleInputW() returned 0 entries";
my @T = map { unpack 's', substr $i, $_*$struct_len, $struct_len } 0..$o-1;
map { [unpack "s x![L] $event_types{$T[$_]}", substr $i, $_*$struct_len, $struct_len] } 0..$o-1;
}}
sub __ConsoleMode ($) {
require Win32::Console;
my $fh = shift;
ref $fh and ($fh = GetOsFHandle $fh or die "fh($fh) has no Win32 handle");
$^E = 0;
Win32::Console::_GetConsoleMode($fh) or not $^E;
}
sub ConsoleFlag_s ($$;$) {
my($fh, $f, $on) = (shift, shift, shift);
$on = 1 unless defined $on;
require Win32::Console;
ref $fh and ($fh = GetOsFHandle $fh or die "fh($fh) has no Win32 handle");
local $^E = 0;
my $omode = my $mode = Win32::Console::_GetConsoleMode($fh) or not $^E or die "not a Console";
$on ? $mode |= $f : $mode &= ~$f;
unless (Win32::Console::_SetConsoleMode($fh, $mode)) { # XXX _SetConsoleMode always reports failure??? (invalid parameter)
my $o_E = $^E;
my $nmode = Win32::Console::_GetConsoleMode($fh);
my $what = "setting a mode (from $omode to $mode; res=$nmode): $o_E";
($nmode or not $^E) or ($nmode == $mode) or die "error $what";
warn "warning: SetConsoleMode() buggy: $what";
}
$omode
}
{ my $f;
sub WriteConsole ($;$) {
require Win32::API;
$f ||= Win32::API->new(q(kernel32), qq[int WriteConsoleW($HANDLE_t h, char *s, long c, char *cc, $HANDLE_t reserved)]);
my($s, $fh, $l) = (shift, shift);
1 & ($l = length $s) and die "Must get an even number of bytes";
$l >>= 1 or return 1;
$fh = \*STDOUT unless defined $fh;
ref $fh and ($fh = GetOsFHandle $fh or die "fh($fh) has no Win32 handle");
my $o = q(1111);
$f->Call($fh, $s, $l, $o, 0) or die "WriteConsoleW() failed: $^E";
$o = unpack 'l', $o;
$o == $l or die "WriteConsoleW() wrote only $o chars out of $l";
1
}}
{ my $f;
sub __ReadConsole ($;$) {
require Win32::API;
$f ||= Win32::API->new(q(kernel32), qq[int ReadConsoleW($HANDLE_t h, char *s, long c, char *cc, $HANDLE_t control)]);
my($l, $fh) = (shift, shift);
my $s = '_' x (2*$l + 4) or return ''; # Apparently, we get \x65 appended??? To protect, allocate 4 > 1 bytes
$fh = \*STDIN unless defined $fh;
ref $fh and ($fh = GetOsFHandle $fh or die "fh($fh) has no Win32 handle");
my $o = q(1111);
$f->Call($fh, $s, $l, $o, 0) or die "ReadConsoleW() failed: $^E";
$o = unpack 'l', $o;
warn "got <", (join ' ', map sprintf("%#02x", ord), split //, $s), "> $o of $l read\n";
my($overrun) = ((substr $s, 2*$o) =~ /^([^_]*)/);
warn "overrun <", (join ' ', map sprintf("%#02x", ord), split //, $overrun), ">\n" if length $overrun;
substr $s, 2*$o, (length $s) - 2*$o, '';
$s
}}
sub readConsole ($;$) {
my($l, $fh, $s) = (shift, shift);
$fh = \*STDIN unless defined $fh;
(read $fh, $s, $l), return $s unless -t $fh and try_checkConsole $fh; # -t is very successful, but just in case...
require Encode;
my $prev = '';
($s = __ReadConsole($l, $fh)) =~ /.[\xd8-\xdb]\z/s and $s .= __ReadConsole(1, $fh); # LittleEndian Surrogates
Encode::decode('UTF-16LE', $s);
}
{ my $f;
sub GetConsoleWindow () {
require Win32::API;
$f ||= Win32::API->new(q(kernel32), qq[$HANDLE_t GetConsoleWindow()]) or die "Import failed: $!";
$f->Call();
}}
{ my $f;
sub GetWindowThreadProcessId ($) {
require Win32::API;
$f ||= Win32::API->new(q(user32), qq[long GetWindowThreadProcessId($HANDLE_t hwnd, char *s)]) or die "Import failed: $!";
my($hwnd, $s) = shift;
if (my $needPID = wantarray) {
$s = '_' x 4;
}
my $o = $f->Call($hwnd, $s);
return $o unless wantarray;
($o, unpack 'L', $s);
}}
1;