delphi - writeln (“:width” 说明符的明显副作用会导致输出中出现问号)

Question

我有以下代码(RAD Studio XE2，Windows 7 x64):

program letters;

{$APPTYPE CONSOLE}

{$DEFINE BOO}

const
  ENGLISH_ALPHABET = 'abcdefghijklmnopqrstuvwxyz';

begin
{$IFDEF BOO}
  writeln;
{$ENDIF}
  write(ENGLISH_ALPHABET[1]:3);

  readln;
end.

当{$DEFINE BOO}指令关闭时，我有以下(预期)输出(为了便于阅读，空格被替换为点):

..a

当指令打开时，我有以下(意外的)输出:

// empty line here
?..a

与预期不同

// empty line here
..a

当我将 const ENGLISH_ALPHABET 更改为 const ENGLISH_ALPHABET: AnsiString 时，打印的预期输出不带疑问字符。当 :3 格式被删除或更改为 :1 时，没有问号。当输出重定向到文件(通过 AssignFile(Output, 'boo.log') 或从命令行)时，不再出现问号。

此行为的正确解释是什么？

Answer 1

这是 RTL 中的一个相当奇怪的错误。对 write 的调用解析为对 _WriteWChar 的调用。这个函数的实现是这样的:

function _WriteWChar(var t: TTextRec; c: WideChar; width: Integer): Pointer;
begin
  if width <= 1 then
    result := _Write0WChar(t, c)
  else
  begin
    if t.UTF16Buffer[0] <> #0 then
    begin
      _Write0WChar(t, '?');
      t.UTF16Buffer[0] := #0;
    end;

    _WriteSpaces(t, width - 1);
    Result := _Write0WChar(t, c);
  end;
end;

您看到的 ? 是由上面的代码发出的。

那么，为什么会发生这种情况呢？我可以构建的最简单的 SSCCE 是这样的:

{$APPTYPE CONSOLE}
const
  ENGLISH_ALPHABET = 'abcdefghijklmnopqrstuvwxyz';
begin
  writeln;
  write(ENGLISH_ALPHABET[1]:3);
end.

因此，您的第一次调用 writeln 解析为:

function _WriteLn(var t: TTextRec): Pointer;
begin
  if (t.Flags and tfCRLF) <> 0 then
    _Write0Char(t, _AnsiChr(cCR));
  Result := _Write0Char(t, _AnsiChr(cLF));
  _Flush(t);
end;

在这里，您将单个字符，cLF，ASCII 字符 10，换行符推送到输出文本记录上。这会导致 t.MBCSBuffer 被输入 cLF 字符。该字符保留在缓冲区中，这很好，因为 System._Write0Char.WriteUnicodeFromMBCSBuffer 会执行以下操作:

t.MBCSLength := 0;
t.MBCSBufPos := 0;

但是当_WriteWChar执行时，它会不加区别地查找t.UTF16Buffer。在 TTextRec 中声明如下:

type
  TTextRec = packed record 
    ....
    MBCSLength: ShortInt;
    MBCSBufPos: Byte;
    case Integer of
      0: (MBCSBuffer: array[0..5] of _AnsiChr);
      1: (UTF16Buffer: array[0..2] of WideChar);
  end;

因此，MBCSBuffer 和 UTF16Buffer 共享相同的存储。

该错误是 _WriteWChar 在未首先检查缓冲区长度的情况下不应查看 t.UTF16Buffer 的内容。由于 TTextRec 没有 UTF16Length，因此如何实现并不是很明显。相反，如果 t.UTF16Buffer 包含有意义的内容，则约定其长度由 -t.MBCSLength 给出!

所以_WriteWChar也许应该是:

function _WriteWChar(var t: TTextRec; c: WideChar; width: Integer): Pointer;
begin
  if width <= 1 then
    result := _Write0WChar(t, c)
  else
  begin
    if (t.MBCSLength < 0) and (t.UTF16Buffer[0] <> #0) then
    begin
      _Write0WChar(t, '?');
      t.UTF16Buffer[0] := #0;
    end;

    _WriteSpaces(t, width - 1);
    Result := _Write0WChar(t, c);
  end;
end;

这是一个相当卑鄙的黑客，修复了_WriteWChar。请注意，我无法获取 System._WriteSpaces 的地址来调用它。如果你迫切想解决这个问题，这是可以做的。

{$APPTYPE CONSOLE}

uses
  Windows;

procedure PatchCode(Address: Pointer; const NewCode; Size: Integer);
var
  OldProtect: DWORD;
begin
  if VirtualProtect(Address, Size, PAGE_EXECUTE_READWRITE, OldProtect) then
  begin
    Move(NewCode, Address^, Size);
    FlushInstructionCache(GetCurrentProcess, Address, Size);
    VirtualProtect(Address, Size, OldProtect, @OldProtect);
  end;
end;

type
  PInstruction = ^TInstruction;
  TInstruction = packed record
    Opcode: Byte;
    Offset: Integer;
  end;

procedure RedirectProcedure(OldAddress, NewAddress: Pointer);
var
  NewCode: TInstruction;
begin
  NewCode.Opcode := $E9;//jump relative
  NewCode.Offset := NativeInt(NewAddress)-NativeInt(OldAddress)-SizeOf(NewCode);
  PatchCode(OldAddress, NewCode, SizeOf(NewCode));
end;

var
  _Write0WChar: function(var t: TTextRec; c: WideChar): Pointer;

function _Write0WCharAddress: Pointer;
asm
  MOV     EAX, offset System.@Write0WChar
end;

function _WriteWCharAddress: Pointer;
asm
  MOV     EAX, offset System.@WriteWChar
end;

function _WriteWChar(var t: TTextRec; c: WideChar; width: Integer): Pointer;
var
  i: Integer;
begin
  if width <= 1 then
    result := _Write0WChar(t, c)
  else
  begin
    if (t.MBCSLength < 0) and (t.UTF16Buffer[0] <> #0) then
    begin
      _Write0WChar(t, '?');
      t.UTF16Buffer[0] := #0;
    end;

    for i := 1 to width - 1 do
      _Write0WChar(t, ' ');
    Result := _Write0WChar(t, c);
  end;
end;

const
  ENGLISH_ALPHABET = 'abcdefghijklmnopqrstuvwxyz';

begin
  @_Write0WChar := _Write0WCharAddress;
  RedirectProcedure(_WriteWCharAddress, @_WriteWChar);

  writeln;
  write(ENGLISH_ALPHABET[1]:3);
end.

我提交了QC#123157 .