paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-24 10:09:33 +02:00
Code Issues Packages Projects Releases Wiki Activity

* New bug test

Browse Source 
git-svn-id: trunk@16090 -
This commit is contained in:
pierre 2010-10-06 16:37:14 +00:00
parent bdefb849fc
commit 45b526eff9
2 changed files with 57 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -10692,6 +10692,7 @@ tests/webtbs/tw1744.pp svneol=native#text/plain
tests/webtbs/tw17546.pp svneol=native#text/plain tests/webtbs/tw17546.pp svneol=native#text/plain
tests/webtbs/tw1754c.pp svneol=native#text/plain tests/webtbs/tw1754c.pp svneol=native#text/plain
tests/webtbs/tw1755.pp svneol=native#text/plain tests/webtbs/tw1755.pp svneol=native#text/plain
tests/webtbs/tw17550.pp svneol=native#text/plain
tests/webtbs/tw1758.pp svneol=native#text/plain tests/webtbs/tw1758.pp svneol=native#text/plain
tests/webtbs/tw1765.pp svneol=native#text/plain tests/webtbs/tw1765.pp svneol=native#text/plain
tests/webtbs/tw1779.pp svneol=native#text/plain tests/webtbs/tw1779.pp svneol=native#text/plain

56
tests/webtbs/tw17550.pp Normal file
View File

@ -0,0 +1,56 @@
{ %interactive }
{ %target=win32, win64 }
program consoleutf8;
{$mode objfpc}{$H+}
uses
windows,
sysutils;
var
written, oldcp, newcp: LongWord;
res: Word;
s: String;
begin
oldcp := GetConsoleOutputCP;
Writeln('Old code page is: ', oldcp);
newcp := CP_UTF8;
if not SetConsoleOutputCP(newcp) then begin
Writeln('Can not set output code page to ', newcp);
Writeln('Error: ', SysErrorMessage(GetLastOSError));
end;
s := 'Some UTF-8 text: ÖÄÜſ' + LineEnding;
written := 0;
if not WriteFile(TTextRec(Output).Handle, s[1], Length(s), written, Nil) then
Writeln('Error ', GetLastOSError, ': ', SysErrorMessage(GetLastOSError))
else
begin
Writeln('Length=',Length(s),' Written=',written);
if written<Length(s) then
Writeln('Correct conditions to test the bug')
else
begin
Writeln('Incorrect conditions to test the bug');
Writeln('Please change Console Font to "Lucida-Console"');
Writeln('And rerun the test');
end;
end;
{$I-}
Writeln('Some UTF-8 text: ÖÄÜſ');
res := IOResult;
if res <> 0 then
Writeln('IOResult was ', res);
{$I+}
if not SetConsoleOutputCP(oldcp) then
Writeln('Error reseting code page to ', oldcp);
if res <> 0 then
RunError(1)
else
Writeln('Test completed without error');
end.