Skip to content

Commit 23ffcb8

Browse files
brickpoolbrickpool
committed
v0.2.3
1 parent ae2206d commit 23ffcb8

9 files changed

Lines changed: 231 additions & 79 deletions

File tree

‎Changes‎

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

3+
0.2.3 2025-11-27
4+
- Fix the switch of the wrapper functions
5+
- Fixed related ANSI and WCHAR tests
6+
- Fix buffer overflow in WriteConsoleOutputCharacterA
7+
38
0.2.2 2025-11-26
49
- Add author only tests
510
- Add samples to the distribution

‎MANIFEST‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,7 @@ LICENSE
55
Makefile.PL
66
MANIFEST This list of files
77
README.pod
8+
samples/10-print.pl
89
samples/clear-screen1.pl
910
samples/clear-screen2.pl
1011
samples/clear-screen3.pl

‎lib/Win32API/Console.pm‎

Lines changed: 90 additions & 62 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.2.2';
23+
our $VERSION = 'v0.2.3';
2424
$VERSION = eval $VERSION;
2525

2626
# authority '...'
@@ -1154,13 +1154,14 @@ sub FillConsoleOutputCharacterA { # $|undef ($handle, $char, $length, \%coord
11541154
: readonly($$written) ? ERROR_INVALID_PARAMETER
11551155
: 0
11561156
;
1157-
if ($Caller ne join(':' => caller)) {
1158-
$Caller = '';
1157+
if ($Caller) {
11591158
$char = Encode::ANSI::encode(substr($char, 0, 1),
1160-
Win32::GetConsoleOutputCP());
1159+
Win32::GetConsoleOutputCP()) if $Caller ne join(':' => caller);
1160+
$Caller = '';
11611161
}
11621162
my $r;
11631163
if (UNICODE) {
1164+
_utf8_off($char);
11641165
$r = $FillConsoleOutputCharacterA->Call($handle, $char, $length,
11651166
COORD::pack($coord), $$written = 0) || return undef;
11661167
}
@@ -1460,10 +1461,12 @@ sub GetConsoleOriginalTitleA { # $num|undef ($handle, $index)
14601461
substr($$buffer, $r) = '';
14611462

14621463
# Convert the Windows ANSI string to a Perl string (UTF-8)
1463-
if ($Caller ne join(':' => caller)) {
1464+
if ($Caller) {
1465+
if ($Caller ne join(':' => caller)) {
1466+
$$buffer = Encode::ANSI::decode($$buffer, CP_ACP);
1467+
$r = length($$buffer);
1468+
}
14641469
$Caller = '';
1465-
$$buffer = Encode::ANSI::decode($$buffer, CP_ACP);
1466-
$r = length($$buffer);
14671470
}
14681471
return $r;
14691472
}
@@ -1482,15 +1485,17 @@ sub GetConsoleOriginalTitleW { # $num|undef ($handle, $index)
14821485
$$buffer = bytes::substr($$buffer, 0, 2 * $r);
14831486

14841487
# Decode the UTF-16LE wide string into perl's internal string format (UTF-8)
1485-
if ($Caller ne join(':' => caller)) {
1488+
if ($Caller) {
1489+
if ($Caller ne join(':' => caller)) {
1490+
$$buffer = do { local $_;
1491+
my $err = Win32::GetLastError(); # Encode may set $^E
1492+
$_ = Encode::decode('UTF-16LE', $$buffer);
1493+
Win32::SetLastError($err);
1494+
$_;
1495+
};
1496+
$r = length($$buffer);
1497+
}
14861498
$Caller = '';
1487-
$$buffer = do { local $_;
1488-
my $err = Win32::GetLastError(); # Encode may set $^E
1489-
$_ = Encode::decode('UTF-16LE', $$buffer);
1490-
Win32::SetLastError($err);
1491-
$_;
1492-
};
1493-
$r = length($$buffer);
14941499
}
14951500
return $r;
14961501
}
@@ -1650,10 +1655,12 @@ sub GetConsoleTitleA { # $num|undef (\$buffer, $size)
16501655
}
16511656

16521657
# Convert the Windows ANSI string to a Perl string (UTF-8)
1653-
if ($Caller ne join(':' => caller)) {
1658+
if ($Caller) {
1659+
if ($Caller ne join(':' => caller)) {
1660+
$$buffer = Encode::ANSI::decode(substr($$buffer, 0, $size), CP_ACP);
1661+
$r = length($$buffer);
1662+
}
16541663
$Caller = '';
1655-
$$buffer = Encode::ANSI::decode(substr($$buffer, 0, $size), CP_ACP);
1656-
$r = length($$buffer);
16571664
}
16581665
return $r;
16591666
}
@@ -1675,12 +1682,14 @@ sub GetConsoleTitleW { # $num|undef (\$buffer, $size)
16751682
Win32::SetLastError($err);
16761683

16771684
# Decode the UTF-16LE wide string into perl's internal string format (UTF-8)
1678-
if ($Caller ne join(':' => caller)) {
1685+
if ($Caller) {
1686+
if ($Caller ne join(':' => caller)) {
1687+
my $err = Win32::GetLastError(); # Encode may set $^E
1688+
$$buffer = Encode::decode('UTF-16LE', $$buffer);
1689+
Win32::SetLastError($err);
1690+
$r = length($$buffer);
1691+
}
16791692
$Caller = '';
1680-
my $err = Win32::GetLastError(); # Encode may set $^E
1681-
$$buffer = Encode::decode('UTF-16LE', $$buffer);
1682-
Win32::SetLastError($err);
1683-
$r = length($$buffer);
16841693
}
16851694
return $r;
16861695
}
@@ -2171,10 +2180,12 @@ sub ReadConsoleA { # $|undef ($handle, \$buffer, $length, \$read, |undef)
21712180
}
21722181

21732182
# Convert the Windows ANSI string to a Perl string (UTF-8)
2174-
if ($Caller ne join(':' => caller)) {
2183+
if ($Caller) {
2184+
if ($Caller ne join(':' => caller)) {
2185+
$$buffer = Encode::ANSI::decode($$buffer, Win32::GetConsoleCP());
2186+
$$read = length($$buffer);
2187+
}
21752188
$Caller = '';
2176-
$$buffer = Encode::ANSI::decode($$buffer, Win32::GetConsoleCP());
2177-
$$read = length($$buffer);
21782189
}
21792190
return $r;
21802191
}
@@ -2208,12 +2219,14 @@ sub ReadConsoleW { # $|undef ($handle, \$buffer, $length, \$read, |\%control|
22082219
$$buffer = bytes::substr($$buffer, 0, 2 * $$read);
22092220

22102221
# Decode the UTF-16LE wide string into perl's internal string format (UTF-8)
2211-
if ($Caller ne join(':' => caller)) {
2222+
if ($Caller) {
2223+
if ($Caller ne join(':' => caller)) {
2224+
my $err = Win32::GetLastError(); # Encode may set $^E
2225+
$$buffer = Encode::decode('UTF-16LE', $$buffer);
2226+
Win32::SetLastError($err);
2227+
$$read = length($$buffer);
2228+
}
22122229
$Caller = '';
2213-
my $err = Win32::GetLastError(); # Encode may set $^E
2214-
$$buffer = Encode::decode('UTF-16LE', $$buffer);
2215-
Win32::SetLastError($err);
2216-
$$read = length($$buffer);
22172230
}
22182231
return $r;
22192232
}
@@ -2651,10 +2664,12 @@ sub ReadConsoleOutputCharacterA { # $|undef ($handle, \$buffer, $length, \%co
26512664
}
26522665

26532666
# Convert the Windows ANSI string to a Perl string (UTF-8)
2654-
if ($Caller ne join(':' => caller)) {
2667+
if ($Caller) {
2668+
if ($Caller ne join(':' => caller)) {
2669+
$$buffer = Encode::ANSI::decode($$buffer, Win32::GetConsoleOutputCP());
2670+
$$read = length($$buffer);
2671+
}
26552672
$Caller = '';
2656-
$$buffer = Encode::ANSI::decode($$buffer, Win32::GetConsoleOutputCP());
2657-
$$read = length($$buffer);
26582673
}
26592674
return $r;
26602675
}
@@ -2681,12 +2696,14 @@ sub ReadConsoleOutputCharacterW { # $|undef ($handle, \$buffer, $length, \%co
26812696
$$buffer = bytes::substr($$buffer, 0, 2 * $$read);
26822697

26832698
# Decode the UTF-16LE wide string into perl's internal string format (UTF-8)
2684-
if ($Caller ne join(':' => caller)) {
2699+
if ($Caller) {
2700+
if ($Caller ne join(':' => caller)) {
2701+
my $err = Win32::GetLastError(); # Encode may set $^E
2702+
$$buffer = Encode::decode('UTF-16LE', $$buffer);
2703+
Win32::SetLastError($err);
2704+
$$read = length($$buffer);
2705+
}
26852706
$Caller = '';
2686-
my $err = Win32::GetLastError(); # Encode may set $^E
2687-
$$buffer = Encode::decode('UTF-16LE', $$buffer);
2688-
Win32::SetLastError($err);
2689-
$$read = length($$buffer);
26902707
}
26912708
return $r;
26922709
}
@@ -2723,11 +2740,13 @@ sub ScrollConsoleScreenBufferA { # $|undef ($handle, \%scrollRect, \%clipRect
27232740

27242741
# If the Win32::Console XS function is not an ANSI function, simply use
27252742
# the Codepoint as WCHAR; otherwise, encode the Codepoint to ANSI format.
2726-
if ($Caller ne join(':' => caller)) {
2743+
if ($Caller) {
2744+
if ($Caller ne join(':' => caller)) {
2745+
$codepoint = ord
2746+
Encode::ANSI::encode(chr($codepoint), Win32::GetConsoleOutputCP())
2747+
unless UNICODE;
2748+
}
27272749
$Caller = '';
2728-
$codepoint = ord
2729-
Encode::ANSI::encode(chr($codepoint), Win32::GetConsoleOutputCP())
2730-
unless UNICODE;
27312750
}
27322751

27332752
# Calls the internal Win32::Console XS function, which uses a different order
@@ -3090,9 +3109,9 @@ sub SetConsoleTitleA { # $|undef ($title)
30903109
: 0
30913110
;
30923111
# Convert the Perl internal string (UTF-8) to an ANSI string if necessary
3093-
if ($Caller ne join(':' => caller)) {
3112+
if ($Caller) {
3113+
$title = Encode::ANSI::encode($title) if $Caller ne join(':' => caller);
30943114
$Caller = '';
3095-
$title = Encode::ANSI::encode($title);
30963115
}
30973116
if (UNICODE) {
30983117
return $SetConsoleTitleA->Call($title) || undef
@@ -3110,12 +3129,14 @@ sub SetConsoleTitleW { # $|undef ($title)
31103129
: 0
31113130
;
31123131
# Encode $title to WCHAR
3113-
if ($Caller ne join(':' => caller)) {
3132+
if ($Caller) {
3133+
if ($Caller ne join(':' => caller)) {
3134+
my $err = Win32::GetLastError(); # Encode may set $^E
3135+
$title = Encode::encode('UTF-16LE', $title);
3136+
Win32::SetLastError($err);
3137+
}
31143138
$Caller = '';
3115-
my $err = Win32::GetLastError(); # Encode may set $^E
3116-
$title = Encode::encode('UTF-16LE', $title);
3117-
Win32::SetLastError($err);
3118-
};
3139+
}
31193140
return $SetConsoleTitleW->Call($title) || undef;
31203141
}
31213142

@@ -3237,9 +3258,10 @@ sub WriteConsoleA { # $|undef ($handle, $buffer, \$written)
32373258
: 0
32383259
;
32393260
# Convert the Perl internal string (UTF-8) to an ANSI string if necessary
3240-
if ($Caller ne join(':' => caller)) {
3261+
if ($Caller) {
3262+
$buffer = Encode::ANSI::encode($buffer, Win32::GetConsoleOutputCP())
3263+
if $Caller ne join(':' => caller);
32413264
$Caller = '';
3242-
$buffer = Encode::ANSI::encode($buffer, Win32::GetConsoleOutputCP());
32433265
}
32443266

32453267
if (UNICODE) {
@@ -3264,11 +3286,13 @@ sub WriteConsoleW { # $|undef ($handle, $buffer, \$written)
32643286
: 0
32653287
;
32663288
# Encode $buffer to WCHAR
3267-
if ($Caller ne join(':' => caller)) {
3289+
if ($Caller) {
3290+
if ($Caller ne join(':' => caller)) {
3291+
my $err = Win32::GetLastError(); # Encode may set $^E
3292+
$buffer = Encode::encode('UTF-16LE', $buffer);
3293+
Win32::SetLastError($err);
3294+
}
32683295
$Caller = '';
3269-
my $err = Win32::GetLastError(); # Encode may set $^E
3270-
$buffer = Encode::encode('UTF-16LE', $buffer);
3271-
Win32::SetLastError($err);
32723296
}
32733297
my $length = bytes::length($buffer) >> 1;
32743298
return $WriteConsoleW->Call($handle, $buffer, $length, $$written = 0, undef)
@@ -3574,13 +3598,15 @@ sub WriteConsoleOutputCharacterA { # $|undef ($handle, $buffer, \%coord, \$wr
35743598
: 0
35753599
;
35763600
# Convert the Perl internal string (UTF-8) to an ANSI string if necessary
3577-
if ($Caller ne join(':' => caller)) {
3601+
if ($Caller) {
3602+
$buffer = Encode::ANSI::encode($buffer, Win32::GetConsoleOutputCP())
3603+
if $Caller ne join(':' => caller);
35783604
$Caller = '';
3579-
$buffer = Encode::ANSI::encode($buffer, Win32::GetConsoleOutputCP());
35803605
}
35813606

35823607
my $r;
35833608
if (UNICODE) {
3609+
_utf8_off($buffer);
35843610
$r = $WriteConsoleOutputCharacterA->Call($handle, $buffer, length($buffer),
35853611
COORD::pack($coord), $$written = 0) || return undef;
35863612
}
@@ -3606,11 +3632,13 @@ sub WriteConsoleOutputCharacterW { # $|undef ($handle, $buffer, \%coord, \$wr
36063632
: 0
36073633
;
36083634
# Encode $buffer to WCHAR
3609-
if ($Caller ne join(':' => caller)) {
3635+
if ($Caller) {
3636+
if ($Caller ne join(':' => caller)) {
3637+
my $err = Win32::GetLastError(); # Encode may set $^E
3638+
$buffer = Encode::encode('UTF-16LE', $buffer);
3639+
Win32::SetLastError($err);
3640+
}
36103641
$Caller = '';
3611-
my $err = Win32::GetLastError(); # Encode may set $^E
3612-
$buffer = Encode::encode('UTF-16LE', $buffer);
3613-
Win32::SetLastError($err);
36143642
}
36153643
my $length = bytes::length($buffer) >> 1;
36163644
return $WriteConsoleOutputCharacterW->Call($handle, $buffer, $length,

‎lib/Win32API/Console.pod‎

Lines changed: 9 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -27,17 +27,17 @@ character encoding they expect. The naming convention typically uses suffixes:
2727

2828
=item * C<FunctionNameA>
2929

30-
This variant expects C<ANSI> strings encoded in the console's current local
30+
This variant expects I<ANSI> strings encoded in the console's current local
3131
code page.
3232

3333
Example:
3434

3535
# Text must be an ANSI string encoded in the local code page
3636
FunctionNameA("Text");
3737

38-
The parameter is passed as a C<ANSI> string.
38+
The parameter is passed as a I<ANSI> string.
3939

40-
B<Note>: C<A>-Version uses C<ANSI> and is not recommended for international
40+
B<Note>: I<A>-Version uses I<ANSI> and is not recommended for international
4141
applications.
4242

4343
=item * C<FunctionNameW>
@@ -50,22 +50,22 @@ Example:
5050
use Encode;
5151
FunctionNameW( Encode::encode('UTF-16LE' => "Text") );
5252

53-
The parameter is passed as a C<WCHAR> string.
53+
The parameter is passed as a I<WCHAR> string.
5454

55-
B<Note>: C<W>-Version uses C<UTF-16LE> and is the quasi standard for Windows
55+
B<Note>: I<W>-Version uses C<UTF-16LE> and is the quasi standard for Windows
5656
applications.
5757

5858
=item * C<FunctionName>
5959

6060
This wrapper decides internally based on the compiler setting and automatically
61-
encodes/decodes the Perl string (UTF-8) to/from C<ANSI> or C<UTF-16LE> using
62-
L<Encode> in a call to the C<A> or C<W> variant.
61+
encodes/decodes the Perl string (UTF-8) to/from I<ANSI> or I<WCHAR> using
62+
L<Encode> in a call to the I<A> or I<W> variant.
6363

6464
=over 4
6565

66-
=item * If C<UNICODE> is enabled, the C<W> version is used.
66+
=item * If C<UNICODE> is enabled, the I<W> version is used.
6767

68-
=item * If C<UNICODE> is disabled, the C<A> version is used.
68+
=item * If C<UNICODE> is disabled, the I<A> version is used.
6969

7070
=back
7171

0 commit comments

Comments
 (0)