From 45b526eff902405302436f2c46d670eebaa86208 Mon Sep 17 00:00:00 2001
From: pierre <pierre@freepascal.org>
Date: Wed, 6 Oct 2010 16:37:14 +0000
Subject: [PATCH]  * New bug test

git-svn-id: trunk@16090 -
---
 .gitattributes          |  1 +
 tests/webtbs/tw17550.pp | 56 +++++++++++++++++++++++++++++++++++++++++
 2 files changed, 57 insertions(+)
 create mode 100644 tests/webtbs/tw17550.pp

diff --git a/.gitattributes b/.gitattributes
index 7a435c2fc6..9d9443ebd9 100644
--- a/.gitattributes
+++ b/.gitattributes
@@ -10692,6 +10692,7 @@ tests/webtbs/tw1744.pp svneol=native#text/plain
 tests/webtbs/tw17546.pp svneol=native#text/plain
 tests/webtbs/tw1754c.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/tw1765.pp svneol=native#text/plain
 tests/webtbs/tw1779.pp svneol=native#text/plain
diff --git a/tests/webtbs/tw17550.pp b/tests/webtbs/tw17550.pp
new file mode 100644
index 0000000000..223be62505
--- /dev/null
+++ b/tests/webtbs/tw17550.pp
@@ -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.
+