2013年10月30日水曜日

Lazarus v1.1 FPC 2.7.1

Lazarus v1.1 FPC 2.7.1 にしてみました。
入れてからもう結構たつけど。

Lazarus v1.0.12 FPC 2.6.2 だと Windows 8 64bit 環境で OpenDialog と SaveDialog がクラッシュする事がありました。

それが直ってます。

diff するとかなり変わっている模様。

ソース見るとけっこう作業中っぽい部分がみられる・・・気がしないでもない。








2013年10月10日木曜日

lazarus版 synedit で crlf と eof の表示(暫定)

自前の過去のエディタで crlf と eof を表示していたので、現在のエディタにもやっぱり欲しくなったので実装しました。

とはいえ、私的な範囲以外での利用は推奨いたしかねる局所的で暫定的な対処で、派生などせず、synedit関連ファイルを書き換えて、デバイスコンテキストに直接描画をします。
変更箇所を抑えるために局所的に実装してあるため、フラグの状態を随時チェックしたり、デバイスコンテキストの操作も随時行うため効率もよくありません。
crlf は拾えなかったので、行末で描画します。
eof も同様に最終行の行末に描画します。
(highlighterが nil の場合に問題があります。仮対で最終行以降に[EOF]を表示しています。暫定に仮対も無い気もしますが) きちんと実装するなら、ラインバッファやTokenに #13と#10 を含める方向で広範囲にわたって書き直さないと駄目な気がします。 まあ、継承して対応できるかそのうちやってみます。
(lazarus 1.0.12,fpc 2.6.2 用です。既にgitやsvnの内容とは異なるようなので注意)

SynEditTypes.pp
  //TSynVisibleSpecialChar = (vscSpace, vscTabAtFirst, vscTabAtLast);
  TSynVisibleSpecialChar = (vscSpace, vscTabAtFirst, vscTabAtLast, vscCRLF, vscEOF); // # ADD
  TSynVisibleSpecialChars = set of TSynVisibleSpecialChar;         

LazSynTextArea.pp

583,591d582
<   {$DEFINE SHOW_CRLF_EOF}
<   {$IFDEF SHOW_CRLF_EOF}
<   bDoCRLF: boolean;   // # ADD
<   bDoEOF: boolean;    // # ADD
<   rcEOL: TRect;       // # ADD
<   EOLDone: boolean;   // # ADD
<   CRLFSZ: integer;    // # ADD
<   {$ENDIF}
<
617,678d607
<   {$IFDEF SHOW_CRLF_EOF}
<   procedure DrawCRLF; // # ADD
<   var
<     ExtSaveDC: HDC;
<     ExtPen: HPEN;
<   begin
<     if EOLDone then Exit;
<     ExtSaveDC:= SaveDC(dc);
<     try
<       ExtPen:= CreatePen(PS_INSIDEFRAME,1, ColorToRGB(clGray));
<       SelectObject(dc, ExtPen);
<       try
<         CRLFSZ := 4;//(rcEOL.Bottom - rcEOL.Top) div 2;
<         LCLIntf.MoveToEx(dc, rcEOL.Right + 1, rcEOL.Bottom - 2, nil);
<         LCLIntf.LineTo  (dc, rcEOL.Right + 1 + CRLFSZ, rcEOL.Bottom - 2);
<         LCLIntf.LineTo  (dc, rcEOL.Right + 1 + CRLFSZ, rcEOL.Bottom - 2 - CRLFSZ);
<         LCLIntf.LineTo  (dc, rcEOL.Right + 1, rcEOL.Bottom - 2);
<       finally
<         DeleteObject(ExtPen);
<       end;
<     finally
<       RestoreDC( dc, ExtSaveDC);
<       EOLDone:= True;
<     end;
<   end;
<   procedure DrawEOFText; // # ADD
<   var
<     ExtSaveDC: HDC;
<     hfNew,hfOld:HFONT;
<     lfText: TLOGFONT;
<   begin
<     if EOLDone then Exit;
<     ExtSaveDC:= SaveDC(dc);
<     try
<       LCLIntf.SetTextColor(dc,TColorRef(clSilver));
<       GetObject(GetStockObject(DEFAULT_GUI_FONT), sizeof(TLOGFONT), @lfText);
<       lfText.lfHeight:= 10;
<       hfNew := CreateFontIndirect(lfText);
<       hfOld := SelectObject(dc, hfNew);
<       try
<         SetBkMode(dc,TRANSPARENT);
<         SetTextColor(dc,ColorToRGB(clGray));
<         TextOut(dc, rcEOL.Right, rcEOL.Top, '[EOF]', 5);
<       finally
<         hfNew:= SelectObject(dc, hfOld);
<         DeleteObject(hfNew);
<       end;
<     finally
<       RestoreDC( dc, ExtSaveDC);
<       EOLDone:= True;
<     end;
<   end;
<   procedure DrawEOFLine; // # ADD
<   var
<     ExtSaveDC: HDC;
<   begin
<     ExtSaveDC:= SaveDC(dc);
<     LCLIntf.MoveToEx(dc, AClip.Left, AClip.Top, nil);
<     LCLIntf.LineTo(dc, AClip.Right, AClip.Top);
<     RestoreDC( dc, ExtSaveDC);
<   end;
<   {$ENDIF}
963,968d891
<
<         {$IFDEF SHOW_CRLF_EOF}
<         rcEOL:= rcToken; // # ADD
<         EOLDone:= False; // # ADD
<         {$ENDIF}
<
1316,1319d1239
<       {$IFDEF SHOW_CRLF_EOF}
<       if bDoCRLF and (CurTextIndex<MaxLine) then DrawCRLF; // # ADD
<       {$ENDIF}
<
1332,1336d1251
<   {$IFDEF SHOW_CRLF_EOF}
<   bDoCRLF := vscCRLF in FVisibleSpecialChars; // # ADD
<   bDoEOF := vscEOF in FVisibleSpecialChars;   // # ADD
<   {$ENDIF}
<
1392,1410d1306
<   {$IFDEF SHOW_CRLF_EOF}
<   // # ADD
<   // if fHilighter=nil, it displays too mach EOF when
<   // editor adding lines with enter key.
<   //if bDoEOF and Assigned(fHighlighter) then DrawEOFText; // # ADD
<   if bDoEOF then
<   begin
<     if Assigned(fHighlighter) then
<       DrawEOFText
<     else
<     begin
<       DrawCRLF;
<       //rcEOL.Right:= AClip.Left;
<       //rcEOL.Top  := AClip.Top;
<       EOLDone:=False;
<     end;
<   end;
<   {$ENDIF}
<
1423,1433d1318
<     {$IFDEF SHOW_CRLF_EOF}
<     // # ADD
<     if bDoEOF then
<     begin
<       DrawEOFLine;
<       rcEOL.Right:= AClip.Left;
<       rcEOL.Top  := AClip.Top;
<       if not Assigned(fHighlighter) then
<         DrawEOFText;
<     end;
<     {$ENDIF}

Lazarus IDE も再構築して反映させたい場合はデフォルトSYNEDIT_DEFAULT_VISIBLESPECIALCHARSも変更する必要があります。

長いブロック内がビューに設定されている場合のIDE上部のツールチップ的なウィンドウにも[EOF]が出たりとか、いろいろ問題があるのでお勧め致しかねますが。

その後、IDEの設定で特殊文字の表示を有効にしてください。
(ツール→オプション→エディタ-一般-その他-特殊文字を表示) 特殊文字を表示すると、空白も「・」で表示されてしまいます。

空白の表示が見づらい場合は前景色のRGB値に+1する等して「既定のテキスト」の「バックグラウンド」とほぼ同じにしてください。(まったく同じにするとデフォルト色で描画されます)
(ツール→オプション→エディタ-表示-色-可視化された特殊文字-前景)

SynEdit.pp

324行目に追加
  SYNEDIT_DEFAULT_VISIBLESPECIALCHARS = [
    vscSpace,
    vscTabAtLast,
    vscCRLF,     // # ADD
    vscEOF       // # ADD
  ];   


IDEからCRLFの色やEOFのフォント設定の変更はできません。
SetTextColor や CreatePen、lfText を適当に書き換えればOKです。

以上。

2013年10月8日火曜日

GetTextExtentPoint() の TSize.cX の値

env: Lazarus IDE 1.0.12,FPC 2.6.2,Windows 8 Pro 64bit

 LclIntf.GetTextExtentPoint() と Windows.GetTextExtentPoint() に utf8文字列を与えた場合の結果が異なるようです。
 (us-ascii の場合は同じ)


IDEのコードエディタから GetTextExtentPoint() を辿ると winapih.inc と redef.inc のどちらかが開かれます。

Windows.GetTextExtentPoint は redef.inc
LCLIntf.GetTextExtentPoint は winapih.inc

に辿り着きます。

名前空間(Windows.)の部分を省略すると、どちらが呼ばれるかは uses の後ろにあるものほど優先されます。


Windows.GetTextExtentPoint(hDC, PChar(str), len, sz);

が呼ばれると sz.cX は予想の倍ぐらいか実際のバイト数ぐらいの値になります。
UTF8 を そのまま ascii のバイトコードで画面出力した時の横幅と同じようです。
(ということでデコードされていない模様)

なので GetTextExtentPoint()に頼って文字列のExtUTF8Out()等を行うとズレまくります。

例えば

LOGFONT
lfFaceName:Meiryo UI
lfHeight:-12

の場合で

sz: TSize;
str:='新しいテキスト ドキュメント.txt'; // string,utf8
len:=length(str); // integer,len=44 (bytecount)

Windows.GetTextExtentPoint(hDC, PChar(str), len, sz); //(Windows.GetTextExtentPoint32()もGetTextExtentPoint32Wも同じ)
sz.cX=233 sz.cY=16

LCLIntf.GetTextExtentPoint(hDC, PChar(str), len, sz);
sz.cX=146 sz.cY=16

となります。


この仕様の違いに気が付かず、バグだと思い込み単純なテストアプリケーションを作成して調査した所、バグが再現せずしばらく悩んでしまいました。
LCLIntf が参照されていたために再現しなかったのです。

明示的に Windows.GetTextExtentPoint を呼び出す事で再現しました。


ということで。

ユニット順を見直したり、LCLIntf.GetTextExtentPoint() のようにして明示的に呼びだすように注意したほうがよさそうです。

以下テストコード。
クリックするたびにLCLintf, Windows, バイトコードゲージ "."に 切り替わります。
利用する場合は、UTF8で保存してください。
(文字列定数が UTF8 でなければならないので)

主要なコードは Test_ で始まる procedure です。
クラスのほうはバックグラウンドです。

unit Unit1;

{$mode delphi}{$H+}

interface

uses
  Windows, Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs,
  LCLIntf, LCLType, LazUTF8, LConvEncoding;

const
  color_guide_h = $99ccff;
  color_end_h   = $0099ff;

  color_guide_v = $ff9999;
  color_end_v   = $cc9999;

  color_bg      = $250000;
  color_fg      = clSilver;

  margin = 8;
type
  TProcType = (prTextOut,prEnd,prGuide,prMargin);
  TTestPosition = procedure (const proctype:TProcType; const rc: TRect; var x,y:integer; const sz: TSize) of object;
  TTestProc = procedure (dc: THandle; rc: TRect; var x, y: integer; testpos: TTestPosition; const str: string);
  { TForm1 }

  TForm1 = class(TForm)
    procedure FormClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDblClick(Sender: TObject);
    procedure FormPaint(Sender: TObject);
  private
    { private declarations }
    xmax: integer;
    FTest: TTestProc;
    procedure HorizontalLeft(const proctype:TProcType; const rc: TRect; var x,y:integer; const sz: TSize);
    procedure HorizontalRight(const proctype:TProcType; const rc: TRect; var x,y:integer; const sz: TSize);
    procedure VirticalTop(const proctype:TProcType; const rc: TRect; var x,y:integer; const sz: TSize);
    procedure VirticalBottom(const proctype:TProcType; const rc: TRect; var x,y:integer; const sz: TSize);
    procedure DoTest( test: TTestProc);
  public
    { public declarations }
    procedure Test;
    property TestProc:TTestProc read FTest write FTest;
  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

{ TForm1 }

procedure Test_LCLIntf_GetTextExtentPoint(dc: THandle; rc: TRect; var x, y: integer;
  testpos: TTestPosition; const str: string);
var
  len: integer;
  sz: TSize;
begin
    len:= Length(str);
    LCLIntf.GetTextExtentPoint( dc, PChar(str), len, {%H-}sz);
    testpos( prTextOut, rc, x, y, sz);
    ExtUTF8Out( dc, x, y, ETO_Opaque, nil, PChar(str), len, nil);
    testpos( prEnd    , rc, x, y, sz);
    testpos( prGuide  , rc, x, y, sz);
    testpos( prMargin , rc, x, y, sz);
end;

procedure Test_Windows_GetTextExtentPoint(dc: THandle; rc: TRect; var x, y: integer;
  testpos: TTestPosition; const str: string);

var
  len: integer;
  sz: TSize;
begin
    len:= Length(str);
    Windows.GetTextExtentPoint( dc, PChar(str), len, {%H-}sz);
    testpos( prTextOut, rc, x, y, sz);
    ExtUTF8Out( dc, x, y, ETO_Opaque, nil, PChar(str), len, nil);
    testpos( prEnd    , rc, x, y, sz);
    testpos( prGuide  , rc, x, y, sz);
    testpos( prMargin , rc, x, y, sz);
end;

procedure Test_Windows_GetTextExtentPoint_UTF8Decode(dc: THandle; rc: TRect; var x, y: integer;
  testpos: TTestPosition; const str: string);

var
  len: integer;
  sz: TSize;
  tmp: string;
  p,e: PChar;
begin
    len:= Length(str);
    Windows.GetTextExtentPoint( dc, PChar(str), len, {%H-}sz);
    testpos( prTextOut, rc, x, y, sz);
    ExtUTF8Out( dc, x, y, ETO_Opaque, nil, PChar(UTF8Decode(str)), len, nil);

    SetLength(tmp,len);
    copymemory(@tmp[1],@str[1],len);

    p:= @tmp[1];
    e:= p + len;
    while p<e do
    begin
      p^:='.';
      inc(p);
    end;

    ExtUTF8Out( dc, x, y, ETO_Opaque, nil, PChar(tmp), len, nil);
    testpos( prEnd    , rc, x, y, sz);
    testpos( prGuide  , rc, x, y, sz);
    testpos( prMargin , rc, x, y, sz);
end;

procedure TForm1.FormClick(Sender: TObject);
begin
  Tag:= Tag + 1;
  case Tag of
   0:begin
     Caption:='LCLIntf.GetTextExtentPoint()';
     TestProc:= Test_LCLIntf_GetTextExtentPoint
   end;
   1:begin
     Caption:='Windows.GetTextExtentPoint()';
     TestProc:= Test_Windows_GetTextExtentPoint
   end;
   2:begin
     Caption:='Windows.GetTextExtentPoint(),ExtUTF8Out(UTF8Decode)';
     TestProc:= Test_Windows_GetTextExtentPoint_UTF8Decode
   end;
   else
   begin
     Tag:= -1;
     Click;
   end;
  end;

  Repaint;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Font.Name:='MS Gothic';
  Click;
end;

procedure TForm1.FormDblClick(Sender: TObject);
begin
  Click;
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  Test;
end;

procedure TForm1.HorizontalLeft(const proctype: TProcType; const rc: TRect; var x, y: integer; const sz: TSize);
begin
    case proctype of
      prTextOut: x:= rc.Left;
      prEnd:
        begin
          inc(x,sz.cX);
          if xmax<x then xmax:=x;
          dec(x,sz.cX);
          Canvas.Pen.Color:= color_end_h;
          Canvas.MoveTo(x + sz.cX ,y);
          inc(y,sz.cY);
          Canvas.LineTo(x + sz.cX ,y);
        end;
      prGuide  :
        begin
          Canvas.Pen.Color:= color_guide_h;
          Canvas.MoveTo(rc.Left ,y);
          Canvas.LineTo(rc.Right,y);
        end;
      prMargin : inc(y,margin);
    end;
end;

procedure TForm1.HorizontalRight(const proctype: TProcType; const rc: TRect;
  var x, y: integer; const sz: TSize);
begin
    case proctype of
      prTextOut: x:= rc.Right - sz.cX;
      prEnd:
        begin
          Canvas.Pen.Color:= color_end_h;
          dec(x,sz.cX);
          Canvas.MoveTo(x + sz.cX ,y);
          inc(y,sz.cY);
          Canvas.LineTo(x + sz.cX ,y);
        end;
      prGuide  :
        begin
          Canvas.Pen.Color:= color_guide_h;
          Canvas.MoveTo(rc.Left ,y);
          Canvas.LineTo(rc.Right,y);
        end;
      prMargin : inc(y,margin);
    end;
end;

procedure TForm1.VirticalTop(const proctype: TProcType; const rc: TRect; var x,
  y: integer; const sz: TSize);
begin
    case proctype of
      prTextOut: y:= rc.Top + sz.cX;
      prEnd:
        begin
          Canvas.Pen.Color:= color_end_v;
          dec(y,sz.cX);
          Canvas.MoveTo(x ,y + sz.cX);
          inc(x,sz.cY);
          Canvas.LineTo(x ,y + sz.cX);
        end;
      prGuide  :
        begin
          Canvas.Pen.Color:= color_guide_v;
          Canvas.MoveTo(x, rc.Top);
          Canvas.LineTo(x, rc.Bottom);
        end;
      prMargin : inc(x,margin);
    end;
end;

procedure TForm1.VirticalBottom(const proctype: TProcType; const rc: TRect;
  var x, y: integer; const sz: TSize);
begin
    case proctype of
      prTextOut: y:= rc.Bottom;
      prEnd:
        begin
          Canvas.Pen.Color:= color_end_v;
          dec( y,sz.cX);
          dec( y,sz.cX);
          Canvas.MoveTo(x, y + sz.cX);
          inc( x,sz.cY);
          Canvas.LineTo(x, y + sz.cX);
        end;
      prGuide  :
        begin
          Canvas.Pen.Color:= color_guide_v;
          Canvas.MoveTo(x, rc.Top);
          Canvas.LineTo(x, rc.Bottom);
        end;
      prMargin : inc(x,margin);
    end;
end;

procedure TForm1.DoTest( test: TTestProc);
const
  str0= 'ascii.txt';
  str1= '日本語あいうえお';
  str2= '日本語 + ascii';
  str3= '♥♥♥';
var
  lfText: TLOGFONT;
  hfNew, hfOld: HFONT;
  rc: TRect;
  hDC:THandle;
  gx,gy: integer;
begin
  rc := ClientRect;
  inc(rc.Left  , 8);
  inc(rc.Top   , 8);
  dec(rc.Right , 8);
  dec(rc.Bottom, 8);
  xmax:= 0;

  Canvas.Brush.Color:= color_bg;
  Canvas.FillRect(rc);

  hDC:= Canvas.Handle;
  GetObject(Font.Reference.Handle, sizeof(TLOGFONT), @lfText);

  // Horizontal

  hfNew := CreateFontIndirect(lfText);
  hfOld := SelectObject(hDC, hfNew);
  try
      SetBkMode(hDC, TRANSPARENT);
      SetTextColor( hDC, color_fg);

      gx:= rc.Left;
      gy:= rc.Top;

      test( hDC, rc, gx,gy, HorizontalLeft, str0);
      test( hDC, rc, gx,gy, HorizontalLeft, str1);
      test( hDC, rc, gx,gy, HorizontalLeft, str2);
      test( hDC, rc, gx,gy, HorizontalLeft, str3);

      test( hDC, rc, gx,gy, HorizontalRight, str0);
      test( hDC, rc, gx,gy, HorizontalRight, str1);
      test( hDC, rc, gx,gy, HorizontalRight, str2);
      test( hDC, rc, gx,gy, HorizontalRight, str3);

  finally
    hfNew:= SelectObject(hDC, hfOld);
    DeleteObject(hfNew);
  end;

  // Virtical

  lfText.lfEscapement  := 90 * 10;
  lfText.lfOrientation := lfText.lfEscapement;

  hfNew := CreateFontIndirect(lfText);
  hfOld := SelectObject(hDC, hfNew);
  try
      gx:= xmax + 10;
      gy:= rc.Bottom;

      test( hDC, rc, gx,gy, VirticalTop, str0);
      test( hDC, rc, gx,gy, VirticalTop, str1);
      test( hDC, rc, gx,gy, VirticalTop, str2);
      test( hDC, rc, gx,gy, VirticalTop, str3);

      test( hDC, rc, gx,gy, VirticalBottom, str0);
      test( hDC, rc, gx,gy, VirticalBottom, str1);
      test( hDC, rc, gx,gy, VirticalBottom, str2);
      test( hDC, rc, gx,gy, VirticalBottom, str3);

  finally
    hfNew:= SelectObject(hDC, hfOld);
    DeleteObject(hfNew);
  end;
end;

procedure TForm1.Test;
begin
  if Assigned(FTest) then
  DoTest(FTest);
end;

end.

2013年10月3日木曜日

Lazarus 付属の SynEdit の 文字幅のバグ

Lazarus の SynEdit には文字幅が2文字分でなければならないのに、1文字扱いになってしまう文字があり、それらの文字を使うと隣接する文字が問題の文字にめり込みます。

日本語では、 「」等の括弧や、★や■ 等の記号がその影響をうけているのを確認しており、私用のエディタにおいても、そのうち対策せねばなるまいと、気にしていました。
例えば、「テスト」等と書くと、「が隠れて見えなくなってしまいます。

調べてみると、既に対策してくださっている方がいらっしゃるようです。

以下にポストされています。
http://www.cnblogs.com/stevenlaz/p/3166464.htm

記事中の2つのファイルが必要です。
SynEditTextDoubleWidthChars.pas
SynEditTextDoubleWidthChars2.pas

これらを (Lazarusディレクトリ)\components\synedit に配置します。

元々の SynEditTextDoubleWidthChars.pas は SynEditTextDoubleWidthChars.old 等にリネームして退避しておくとよいでしょう。

あとは、コンパイルしなおせば解決します。


before: after:

なんと ””が、直っていませんね・・・。
やはり一筋縄ではいかなそうです。

Thanks.