Skip to content

Commit 3f25306

Browse files
brickpoolbrickpool
committed
v0.1.5
1 parent cdcb4d8 commit 3f25306

2 files changed

Lines changed: 84 additions & 36 deletions

File tree

‎Changes‎

Lines changed: 7 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,11 @@
11
Revision history for Win32API::Console
22

3+
0.1.5 2025-11-19
4+
- Change regarding the use of Encode::Unicode
5+
- Fix ScrollConsoleScreenBuffer; XS uses WCHAR
6+
- Fix FillConsoleOutputCharacterA; uses CHAR
7+
- Fix don't set UTF8-Flag on ANSI strings
8+
39
0.1.4 2025-11-18
410
- Add "macros" (subs) to improve readability
511
- Add ANSI functions if XS was compiled with Unicode
@@ -14,8 +20,7 @@ Revision history for Win32API::Console
1420
0.1.2 2025-11-16
1521
- Add a TestConsole Module for automated tests
1622
- Fixed no WC_NO_BEST_FIT_CHARS when CP_UTF8
17-
- Change from Encode::encode('UTF-16', ..) to MultiByteToWideChar()
18-
- Change from Encode::decode('UTF-16', ..) to WideCharToMultiByte()
23+
- Change regarding the use of Encode::Unicode
1924
- Change emulation use for SetConsoleDisplayMode()
2025
- Change of osname detection for GetOSVersion()
2126
- Remove dependency on the Win32API::Registry module

‎lib/Win32API/Console.pm‎

Lines changed: 77 additions & 34 deletions
Original file line numberDiff line numberDiff line change
@@ -20,7 +20,7 @@ use version;
2020

2121
# version '...'
2222
our $version = '0.10';
23-
our $VERSION = 'v0.1.4';
23+
our $VERSION = 'v0.1.5';
2424
$VERSION = eval $VERSION;
2525

2626
# authority '...'
@@ -1121,7 +1121,7 @@ sub FillConsoleOutputCharacterA { # $|undef ($handle, $char, $length, \%coord
11211121
$char = Encode::ANSI::encode(substr($char, 0, 1),
11221122
Win32::GetConsoleOutputCP());
11231123
my $r = UNICODE
1124-
? $FillConsoleOutputCharacterA->Call($handle, ord($char), $length,
1124+
? $FillConsoleOutputCharacterA->Call($handle, $char, $length,
11251125
COORD::pack($coord), $$written = 0)
11261126
: do {
11271127
Win32::SetLastError(0);
@@ -1349,7 +1349,7 @@ sub GetConsoleFontSize { # \%coord|undef ($handle, $index)
13491349
my ($width, $height) = COORD::unpack($dwFontSize);
13501350

13511351
if (EMULATE_FONT_SIZE and !$width || !$height) {
1352-
my $err = Win32::GetLastError();
1352+
my $err = Win32::GetLastError(); # Encode may set $^E
13531353
TRY: eval {
13541354
require Win32::GuiTest;
13551355
my $hwnd = _GetConsoleHwnd();
@@ -1437,7 +1437,12 @@ sub GetConsoleOriginalTitleW { # $num|undef ($handle, $index)
14371437
my $r = $GetConsoleOriginalTitleW->Call($$buffer, $size) || return undef;
14381438

14391439
# Decode the UTF-16LE wide string into perl's internal string format (UTF-8)
1440-
$$buffer = _WideCharToMultiByte(bytes::substr($$buffer, 0, 2 * $r), CP_UTF8);
1440+
$$buffer = do { local $_;
1441+
my $err = Win32::GetLastError(); # Encode may set $^E
1442+
$_ = Encode::decode('UTF-16LE', bytes::substr($$buffer, 0, 2 * $r));
1443+
Win32::SetLastError($err);
1444+
$_;
1445+
};
14411446
return length($$buffer);
14421447
}
14431448

@@ -1608,7 +1613,12 @@ sub GetConsoleTitleW { # $num|undef (\$buffer, $size)
16081613
my $r = $GetConsoleTitleW->Call($$buffer, $size) || return undef;
16091614

16101615
# Decode the UTF-16LE wide string into perl's internal string format (UTF-8)
1611-
$$buffer = _WideCharToMultiByte(bytes::substr($$buffer, 0, 2 * $r), CP_UTF8);
1616+
$$buffer = do { local $_;
1617+
my $err = Win32::GetLastError(); # Encode may set $^E
1618+
$_ = Encode::decode('UTF-16LE', bytes::substr($$buffer, 0, 2 * $r));
1619+
Win32::SetLastError($err);
1620+
$_;
1621+
};
16121622
return length($$buffer);
16131623
}
16141624

@@ -1741,11 +1751,13 @@ sub GetCurrentConsoleFontEx { # $|undef ($handle, $max, \%info)
17411751
# Extract and decode the FaceName field (WCHAR[LF_FACESIZE], 64 bytes)
17421752
# at the end of the structure, interpreting it as UTF-16LE.
17431753
my $name = do { local $_;
1754+
my $err = Win32::GetLastError(); # Encode may set $^E
17441755
$_ = bytes::substr($lpFontInfoEx,
17451756
CONSOLE_FONT_INFOEX_SIZE - (2 * LF_FACESIZE), (2 * LF_FACESIZE))
17461757
if defined $lpFontInfoEx;
17471758
$_ = unpack('A*', $_) if defined;
1748-
$_ = _WideCharToMultiByte($_, CP_UTF8);
1759+
$_ = Encode::decode('UTF-16LE', $_) if defined;
1760+
Win32::SetLastError($err);
17491761
$_;
17501762
};
17511763

@@ -2585,8 +2597,12 @@ sub ReadConsoleOutputCharacterW { # $|undef ($handle, \$buffer, $length, \%co
25852597
COORD::pack($coord), $$read = 0) || undef;
25862598

25872599
# Decode the UTF-16LE wide string into perl's internal string format (UTF-8)
2588-
$$buffer = _WideCharToMultiByte(bytes::substr($$buffer, 0, 2 * $$read),
2589-
CP_UTF8);
2600+
$$buffer = do { local $_;
2601+
my $err = Win32::GetLastError(); # Encode may set $^E
2602+
$_ = Encode::decode('UTF-16LE', bytes::substr($$buffer, 0, 2 * $$read));
2603+
Win32::SetLastError($err);
2604+
$_;
2605+
};
25902606
return defined $$buffer ? $r : undef;
25912607
}
25922608

@@ -2621,20 +2637,27 @@ sub ScrollConsoleScreenBufferA { # $|undef ($handle, \%scrollRect, \%clipRect
26212637
: 0
26222638
;
26232639
# Unpack CHAR_INFO structure: character (2 bytes) and attribute (2 bytes)
2624-
my ($char, $attr) = unpack('WS', pack('L', $fill));
2640+
my ($codepoint, $attr) = unpack('SS', pack('L', $fill));
26252641

26262642
# If the Win32::Console XS function is not an ANSI function, simply convert
2627-
# the Perl string to WCHAR; otherwise, convert the Perl string to ANSI.
2628-
$char = UNICODE
2629-
? _MultiByteToWideChar($char, CP_UTF8)
2630-
: Encode::ANSI::encode($char, Win32::GetConsoleOutputCP());
2643+
# the Codepoint to WCHAR; otherwise, encode the Codepoint to ANSI format.
2644+
$codepoint = ord(
2645+
UNICODE
2646+
? do { local $_;
2647+
my $err = Win32::GetLastError(); # Encode may set $^E
2648+
$_ = Encode::encode('UTF-16LE', chr($codepoint));
2649+
Win32::SetLastError($err);
2650+
$_;
2651+
}
2652+
: Encode::ANSI::encode(chr($codepoint), Win32::GetConsoleOutputCP())
2653+
);
26312654

26322655
# Calls the internal Win32::Console XS function, which uses a different order
26332656
return Win32::Console::_ScrollConsoleScreenBuffer(
26342657
$handle, # console output handle
26352658
SMALL_RECT::list($scrollRect), # source rectangle to scroll
26362659
COORD::list($destCoord), # destination coordinate
2637-
$char, $attr, # fill character and attribute
2660+
$codepoint, $attr, # fill codepoint and attribute
26382661
$clipRect # optional clipping rectangle
26392662
? SMALL_RECT::list($clipRect)
26402663
: SMALL_RECT::list($scrollRect)
@@ -2900,7 +2923,12 @@ sub SetCurrentConsoleFontEx { # $|undef ($handle, $max, \%info)
29002923
}
29012924

29022925
# Encode FaceName to WCHAR
2903-
my $wide = _MultiByteToWideChar($info->{FaceName}, CP_UTF8);
2926+
my $wide = do { local $_;
2927+
my $err = Win32::GetLastError(); # Encode may set $^E
2928+
$_ = Encode::encode('UTF-16LE', $info->{FaceName});
2929+
Win32::SetLastError($err);
2930+
$_;
2931+
};
29042932

29052933
# Pack the CONSOLE_FONT_INFOEX structure with all required fields:
29062934
# cbSize (DWORD), nFont (DWORD), dwFontSize.X (SHORT), dwFontSize.Y (SHORT),
@@ -3052,7 +3080,12 @@ sub SetConsoleTitleW { # $|undef ($title)
30523080
: 0
30533081
;
30543082
# Encode $title to WCHAR
3055-
my $wide = _MultiByteToWideChar($title, CP_UTF8);
3083+
my $wide = do { local $_;
3084+
my $err = Win32::GetLastError(); # Encode may set $^E
3085+
$_ = Encode::encode('UTF-16LE', $title);
3086+
Win32::SetLastError($err);
3087+
$_;
3088+
};
30563089
return $SetConsoleTitleW->Call($wide) || undef;
30573090
}
30583091

@@ -3145,7 +3178,12 @@ sub WriteConsoleW { # $|undef ($handle, $buffer, \$written)
31453178
: 0
31463179
;
31473180
# Encode $buffer to WCHAR
3148-
my $wide = _MultiByteToWideChar($buffer, CP_UTF8);
3181+
my $wide = do { local $_;
3182+
my $err = Win32::GetLastError(); # Encode may set $^E
3183+
$_ = Encode::encode('UTF-16LE', $buffer);
3184+
Win32::SetLastError($err);
3185+
$_;
3186+
};
31493187
return $WriteConsoleW->Call($handle, $wide, length($buffer), $$written = 0,
31503188
undef) || undef;
31513189
}
@@ -3480,7 +3518,12 @@ sub WriteConsoleOutputCharacterW { # $|undef ($handle, $buffer, \%coord, \$wr
34803518
;
34813519
my $dwWriteCoord = COORD::pack($coord);
34823520
# Encode $buffer to WCHAR
3483-
my $wide = _MultiByteToWideChar($buffer, CP_UTF8);
3521+
my $wide = do { local $_;
3522+
my $err = Win32::GetLastError(); # Encode may set $^E
3523+
$_ = Encode::encode('UTF-16LE', $buffer);
3524+
Win32::SetLastError($err);
3525+
$_;
3526+
};
34843527
return $WriteConsoleOutputCharacterW->Call($handle, $wide, length($buffer),
34853528
$dwWriteCoord, $$written = 0) || undef;
34863529
}
@@ -3806,7 +3849,9 @@ sub Encode::ANSI::encode { # $ansi ($str, |$codepage)
38063849
my ($str, $cpi) = @_;
38073850
$cpi ||= CP_ACP;
38083851
if ($cpi != CP_UTF8 && $str =~ /[\xC0-\xf7]/) {
3809-
my $wide = _MultiByteToWideChar($str, CP_UTF8);
3852+
my $err = Win32::GetLastError(); # Encode may set $^E
3853+
my $wide = Encode::encode('UTF-16LE', $str);
3854+
Win32::SetLastError($err);
38103855
my $ansi = _WideCharToMultiByte($wide, $cpi);
38113856
return $ansi if defined $ansi;
38123857
}
@@ -3816,14 +3861,18 @@ sub Encode::ANSI::encode { # $ansi ($str, |$codepage)
38163861
# Decode the ANSI string into a Perl string using the system code page or
38173862
# C<$codepage>, if specified.
38183863
#
3819-
# B<Note>: If the code page is CP_UFT8, no conversion takes place.
3864+
# B<Note>: If the code page is CP_UTF8, no conversion takes place.
38203865
sub Encode::ANSI::decode { # $str ($ansi, |$codepage)
38213866
my ($ansi, $cpi) = @_;
38223867
$cpi ||= CP_ACP;
3823-
if ($cpi != CP_UTF8 || $ansi =~ /[^\x00-\x7f]/) {
3868+
if ($cpi != CP_UTF8 && $ansi =~ /[^\x00-\x7f]/) {
38243869
my $wide = _MultiByteToWideChar($ansi, $cpi);
3825-
my $str = _WideCharToMultiByte($wide, CP_UTF8);
3826-
return $str if defined $str;
3870+
if (defined $wide) {
3871+
my $err = Win32::GetLastError(); # Encode may set $^E
3872+
my $str = Encode::decode('UTF-16LE', $wide);
3873+
Win32::SetLastError($err);
3874+
return $str;
3875+
}
38273876
}
38283877
return $ansi;
38293878
}
@@ -4117,10 +4166,7 @@ sub _utf8_on ($) {
41174166
# Fallback if the internal routine is no longer available
41184167
*_utf8_on = Encode->can('_utf8_on') || sub {
41194168
my $is_utf8 = Encode::is_utf8($_[0]);
4120-
unless ($is_utf8) {
4121-
$_[0] = Encode::decode('UTF-8', $_[0]);
4122-
$^E = 0;
4123-
}
4169+
$_[0] = Encode::decode('UTF-8', $_[0]) unless $is_utf8;
41244170
return $is_utf8;
41254171
};
41264172
goto &_utf8_on;
@@ -4132,10 +4178,7 @@ sub _utf8_off ($) {
41324178
# Fallback if the internal routine is no longer available
41334179
*_utf8_off = Encode->can('_utf8_off') || sub {
41344180
my $is_utf8 = Encode::is_utf8($_[0]);
4135-
if ($is_utf8) {
4136-
$_[0] = Encode::encode('UTF-8', $_[0]);
4137-
$^E = 0;
4138-
}
4181+
$_[0] = Encode::encode('UTF-8', $_[0]) if $is_utf8;
41394182
return $is_utf8;
41404183
};
41414184
goto &_utf8_off;
@@ -4149,7 +4192,7 @@ sub _MultiByteToWideChar { # $wstr|undef ($str, |$cp)
41494192
$cp = CP_ACP unless defined $cp;
41504193
my $len = bytes::length($str) || return '';
41514194
_utf8_off($str);
4152-
Win32::SetLastError(0); # Encode may set $^E
4195+
Win32::SetLastError(0);
41534196
my $wlen = $MultiByteToWideChar->Call($cp, 0, $str, $len, undef, 0)
41544197
|| return undef;
41554198
my $wide = "\0" x (2 * $wlen);
@@ -4180,8 +4223,8 @@ sub _WideCharToMultiByte { # $str|undef ($wstr, |$cp)
41804223
$str, $len, undef, undef);
41814224
}
41824225
substr($str, $len) = '';
4183-
_utf8_on($str);
4184-
Win32::SetLastError(0); # Encode may set $^E
4226+
_utf8_on($str) if $cp == CP_UTF8;
4227+
Win32::SetLastError(0);
41854228
return $str;
41864229
}
41874230

0 commit comments

Comments
 (0)