Write/Writeln でデバッグ情報をメモコントロールに書きたい

Tip

昔のろくなデバッガがなかった頃のプログラミングでは Write や Writeln を多用してデバッグ情報をコンソールに出力したものですが最近はあまり使わなくなりました。それでも、プログラムの複雑なシーケンスを見るのに、いちいちデバッガでブレークポイントを設定して追うよりもトレース情報を残して解析した方が便利なことがあります。

Delphi の GUI アプリケーションでは標準出力 Output は使えないようになっています。無理に書こうとすると EInOutError 例外が発生しますし、そもそも書く先がありません。ファイルを Assign しておけば、Write/Wrieln が使えるようになり、後でファイルを開けばトレースが見えますが、すぐに見れないのがちょっとだけ不便です

そこで、標準出力を TStrings 型のオブジェクト（例えば TMemo や TRichEdit の Lines property）に Assign する方法を紹介します。この方法では、メモコントロールやリッチエディットコントロールにトレース情報を書き出し、表示できます。

TStrings を Outout にAssign するにはそれ用のテキストファイルドライバが必要です。以下に出力専用の TStrings 用とヌルデバイス用のテキストファイルドライバを示します。

unit TextDevs;

interface

uses classes, SysUtils;

procedure AssignStrings(var F: TextFile; AStrings: TStrings);
procedure AssignNull(var F: TextFile);

implementation


{AssigmStrings}

type
  TUserData = record
    Strings: TStrings; {出力先}
    Index:   Integer;  {出力位置}
  end;

  PUserData = ^TUserData;

function WriteStrings(var F: TTextRec): Integer;
var pos: Integer;
    str: string;
begin
  with PUserData(@F.UserData)^ do begin
    pos := F.BufPos;
    while (pos >= 1) and 
          ((F.BufPtr[pos-1] = #10) or (F.BufPtr[pos-1] = #13)) do
      Dec(pos);

    SetString(Str, F.BufPtr, pos);

    {誰か Strings を触った？}
    if (Index < Strings.Count-1) or (Index > Strings.Count) then
      Index := Strings.Count;

    if Index = Strings.Count-1 then
      Strings[Index] := Strings[Index] + str  {行の残りを追加}
    else
      Strings.Add(str);                       {新しい行を追加}

    {行末が有った？}
    if pos <> F.BufPos then Inc(Index);

    F.BufPos := 0; {BufPos は０にする。マニュアルどおり}
    Result := 0;   {正常終了}
  end;
end;

function OpenStrings(var F: TTextRec): Integer;
begin
  {入力はサポートしない}
  if F.Mode = fmInput then begin
    Result := -1;  {0以外を返すと例外があがる}
    Exit;
  end;

  F.BufPos := 0;

  with PUserData(@F.UserData)^ do begin
    {出力とフラッシュ関数をセット}
    F.InOutFunc := @WriteStrings;
    F.FlushFunc := @WriteStrings;

    if F.Mode = fmInOut then begin   {Append}
      F.Mode := fmOutput;
      Index := Strings.Count;        {文末へ移動}
    end
    else begin                       {ReWrite}
      Strings.Clear;                 {Strings を消去}
      Index := 0;                    {文頭へ移動}
    end;
  end;
  Result := 0;                       {正常終了}
end;

function CloseStrings(var F: TTextRec): Integer;
begin
  F.Mode := fmClosed; {これが無いとうまく動かない。何故？}
  Result := 0;
end;

procedure AssignStrings(var F: TextFile; AStrings: TStrings);
begin
  {テキストファイルの初期化}
  with TTextRec(F) do begin
    Mode := fmClosed;          {モードをクローズにする}
    BufSize := SizeOf(Buffer); {バッファを TTextRec 内のバッファに設定}
    BufPtr := @Buffer;
    OpenFunc := @OpenStrings;  {Open/Close関数の設定}
    CloseFunc := @CloseStrings;
    Name[0] := #0;             {ファイル名は無し}
    {ユーザ領域に TStrings を設定}
    PUserData(@UserData)^.Strings := AStrings;
  end;
end;



{AssignNull}

function WriteNull(var F: TTextRec): Integer;
begin
  F.BufPos := 0; {BufPos は０にする。マニュアルどおり}
  Result := 0;   {正常終了}
end;

function OpenNull(var F: TTextRec): Integer;
begin
  {入力はサポートしない}
  if F.Mode = fmInput then begin
    Result := -1;  {0以外を返すと例外があがる}
    Exit;
  end;

  F.BufPos := 0;

  {出力とフラッシュ関数をセット}
  F.InOutFunc := @WriteNull;
  F.FlushFunc := @WriteNull;

  if F.Mode = fmInOut then   {Append}
    F.Mode := fmOutput;

  Result := 0;               {正常終了}
end;

function CloseNull(var F: TTextRec): Integer;
begin
  F.Mode := fmClosed;
  Result := 0;
end;

procedure AssignNull(var F: TextFile);
begin
  {テキストファイルの初期化}
  with TTextRec(F) do begin
    Mode := fmClosed;          {モードをクローズにする}
    BufSize := SizeOf(Buffer); {バッファを TTextRec 内のバッファに設定}
    BufPtr := @Buffer;
    OpenFunc := @OpenNull;     {Open/Close関数の設定}
    CloseFunc := @CloseNull;
    Name[0] := #0;             {ファイル名は無し}
  end;
end;

end.

使い方は簡単です。適当なフォーム（ここでは TTraceForm）にメモコントロール（又はリッチエディットコントロール）を貼り付けて、メインフォームのイベントハンドラで

procedure TForm1.FormCreate(Sender: TObject);
begin
  with TTraceForm.Create(Application) do {トレース出力用フォームを動的に生成}
    AssignStrings(Output, Memo1.Lines);  {メモを Output に Assign}
  ReWrite(Output);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  CloseFile(Output);
end;

として下さい。後は、Write/WriteLn で書けば、メモコントロールに出力されます。

デバッグが済んだら、フォームの OnCreate を

procedure TForm1.FormCreate(Sender: TObject);
begin
  AssignNull(Output);
  ReWrite(Output);
end;

と書き換えれば、Write/Writeln の出力は全て捨てられるため、プログラムを書き換える必要がありません。

尚、お判りとは思いますが、メモコントロールが Output がクローズされる前に削除されると、エラーが起きますので、トレース用フォームがクローズされる前に Output をクローズするようにしてください。

解説

Delphi のマニュアルの一つ、「Object Pascal 言語ガイド」の第8章「テキストファイルデバイスドライバ」にわずか３ページですがテキストファイルドライバの情報が若干載っています。また11章「メモリ関連」にファイル型のレコードの詳細が載っています。このわずかな資料からテキストファイルドライバを書くのは困難です。実際 TStrings 用のテキストファイルドライバを書くのは試行錯誤の連続でした。

しかし、一度書き方が判ってしまえば、いろいろなものを「テキストファイル」に見せかけることが出来るので、面白い応用が有るかもしれません。この Tip が参考になれば幸いです。