2013年11月4日月曜日

Lazarus IDE 1.1 の todolist のソートがおかしい。

Lazarus v1.1, FPC 2.7.1 で todolist のカラムソートで asc/desc のトグルができなくなっています。
2.6.2 と比較するとわかる事なのですが todolist.lfm から ListView の AutoSortプロパティが削除されデフォルト(true) になっているためのようです。
todolist.pas を開いて F12 でフォームを表示して、オブジェクトインスペクタから AutoSort を False に設定してLazarusを再構築すれば直ります。
あるいはlfmをテキストで開いてAutoSort=True を追加しても構わないと思います。
座標等の余計なプロパティが変わってしまうのでテキストで追加したほうがいいかもしれません。


FPC 2.6.2 には AutoSort=True とありました。
FPC 2.7.1 ではなぜ消されてしまったのでしょうね。・・・。
誤って行削除のショートカットキーでも押してしまったかのようです。

それと、todolist.pas を開いたまま IDE の表示メニューから "ToDo List" を表示すると
なぜか todolist.lfm がデザイナで開かれてしまう事があるようです・・・。
それを閉じてもう一度呼び出せば正常に開かれます。
(rev43370 でもなおってない模様)

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.

2013年9月15日日曜日

Lazarus 1.0.10 to 1.0.12

Lazarus 1.0.10 の環境から ようやく Lazarus 1.0.12 に移行しました。

FPCは 2.6.2 のままのようです。

http://forum.lazarus.freepascal.org/index.php/topic,21876.msg128492/topicseen.html#new

http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch#Fixes_for_1.0.12_.28Merged.29

http://wiki.lazarus.freepascal.org/User_Changes_2.6.2

バグの修正が結構あるようなのでアップデートしておいたほうが良さそうです。

最初に 1.0.10 をアンインストールすることなく、1.0.12 のインストーラーを起動しても大丈夫です。

途中でアンインストールできますし、両バージョンを生かした環境も作れるようです。

インストール途中に旧バージョンをアンインストールした場合は、残ったファイルのうちLCLや Components 等で特に変更した覚えのないものは削除したほうが良いと思います(私的には)

設定などはIDE起動時にアップグレードされて引き継がれます。

特に問題無さそうです。

以上です。

TFileStream の 438 の謎


Lazarus,FPC の

(from FileUtil streams.inc)

constructor TFileStream.Create(const AFileName: string; Mode: Word);

begin
  Create(AFileName,Mode,438);
end;  

438 というのが、あります。

https://github.com/graemeg/freepascal/blob/master/rtl/solaris/ostypes.inc


 S_IRUSR = $100;           { Read permission for owner   }
 S_IWUSR = $080;           { Write permission for owner  }
 S_IXUSR = $040;           { Exec  permission for owner  }
 S_IRGRP = $020;           { Read permission for group   }
 S_IWGRP = $010;           { Write permission for group  }
 S_IXGRP = $008;           { Exec permission for group   }
 S_IROTH = $004;           { Read permission for world   }
 S_IWOTH = $002;           { Write permission for world  }
 S_IXOTH = $001;           { Exec permission for world   }  

ググっても出てこないので一応計算してみると

S_IRUSR  or S_IWUSR or S_IRGRP or
S_IWGRP or S_IROTH  or S_IWOTH = 438 でした。

それだけ。

すっきり。

Windows の場合 0 でも良さそうです。

TFileStream - THandleObject - TStream - TObject

ちなみに、このconstructor TFileStream.Create は、2つあり、どちらの Create も inherited されていません。
何故なのでしょう。

Create は THandleStream で初めて実装されています。
派生元の THandleStream は Handle の設定しかしていません。
こちらは inherited されているようですが・・・。

THandleStream の FHandle がスコープにあるので、アクセスできます。
それで一応、FHandleに値は設定もされているし動作も影響無さそうです。
var
 h: THandle;
inheritec Create( h)

とするか

FHandle:= h;

とするかの違いしかありません。

destructor も inherited されていませんが、TFileStream で初めて実装されます。

こちらも全く問題無さそうです。

一瞬放置されたコードなのかと思ってしまいました。

Delphi も一応確認したら似たような感じでした。





PS
Delphi の定義と異なるらしい。(上記の定義はFPCのもの。)詳細不明。(最新のは持ってないので)

2013年9月14日土曜日

TThreadList.Duplicates は dupIgnore

TStringList も TThreadList も Duplicates の型は同じです。

TDuplicates = (dupIgnore, dupAccept, dupError);

(Delphi とは順番が違いますが、先頭は同じなので default 指定や、コンストラクタ等で値が設定されていなければ dupIgnore になります)

dupIgnore は同じ値を追加しようとしても無視されて追加されません。

しかし、 TStringList は Sorted=True にしないと、dupIgnore が機能しません。

なので

Duplicates が dupIgnore のままであっても

sl:=TStringList.Create;
sl.Add('A');
sl.Add('A');
sl.Add('A');

とやると

sl.Count = 3 です。


sl:=TStringList.Create;
sl.Sorted:=True;
sl.Add('A');
sl.Add('A');
sl.Add('A');

とすれば

sl.Count = 1 です。

問題なのは TThreadList で、Duplicates のデフォルトは同じように dupIgnore になっています。
Sorted プロパティなどは無く、インスタンス作成直後から同じ値が追加されない仕様です。

TThreadList で、オブジェクトのインスタンスなどを管理する場合は、毎回異なる値が追加されるので問題ありませんが、その他の目的で利用しようと思う場合は注意が必要です。

obj:= TTest.Create;
lst:= TThreadList.Create;
lst.Add(obj1);
lst.Add(obj1);
lst.Add(obj1);

with lst.LockList do
try
  OutPutDebugString(PChar(IntToStr(Count))
finally
  lst.UnlockList;
end;

イベントログに表示される Count は 1 です。

なので、重複を許可したい場合は、インスタンス作成後に Duplicates:= dupAccept に設定するのを忘れないようにしないといけません。

lst:= TThreadList.Create;
lst.Duplicates:= dupAccept;
lst.Add(obj1);
lst.Add(obj1);
lst.Add(obj1);

with lst.LockList do
try
  OutPutDebugString(PChar(IntToStr(Count))
finally
  lst.UnlockList;
end;

イベントログに表示される Count は 3 です。

ということを忘れたまま、オブジェクトのスタック的なものを実装しようとしているとハマってしまいますのでご注意あれ。

ちなみに TList は Duplicates プロパティはありません。


FPC も Delphi も同じです。

2013年9月11日水曜日

Lazarus IDE でのコードの辿り方。宣言と実現部の切り替えとか。

Lazarus IDE でのコードの辿り方。

Interface部 と Implementation部 の切り替え。

CTRL + SHIFT + UP(カーソルキー↑)
CTRL + SHIFT + DOWN(カーソルキー↓)


他のIDE同様、関数や変数名等の単語 を CTRL + マウスクリック すると宣言部までジャンプしてくれます。(手続き・関数の場合は実装まで)

また、CTRL + SHIFT + UP で、宣言と実現部を交互に切り替えてジャンプできます。
UP も DOWN も同じです。

ライブラリの実装が .inc により分離されているものが多く、この機能なしにはコードを深く辿ることが困難なように思います。


以上。

IFNDEF DELPHI は使わない

Delphi 互換のコードを書く場合に、{$IFNDEF DELPHI} は使わないほうが良いらしい。

やってたし・・・。

また、Lazarus, FPC でコンパイルする場合、指示しなくとも FPC が DEFINE される。

という事なので、{$IFDEF FPC} と {$IFNDEF FPC} ならば使っても問題無さそうです。

気が付いてよかった・・・。


情報元: http://wiki.freepascal.org/Code_Conversion_Guide#Compiler_Issues

によると

{$MODE Delphi} によって Delphi モード にした場合に、DELPHI が DEFINE されてしまう。

なので IFNDEF Delphi が FPC 上であってもコンパイルされなくなってしまう。

また、Delphi 互換のコードを書く場合、{$MODE} は Delphi によってエラーとされてしまうので

{$IFDEF FPC}
  {$MODE Delphi}
{$ENDIF}

のように書くといいそう。

そのうち Delphi でもコンパイルしてみようとは思っていたけど、Delphi の環境無いからテストできぬ。

2013年9月10日火曜日

Lazarus IDE をドッキング対応にする


Lazarus IDE をドッカブルにできるようです。
使うかどうかはともかく一応できたようです。
既にSDIで慣れてしまいましたが・・・。

インストールとアンインストール
(1) パッケージパッケージをインストールもしくはアンインストール
(2) anchordock anchordockingdsgn をダブルクリックして左側のインストールに表示させます。
保存してIDEを再構築」します。
(アンインストールは同様にインストール項目からダブルクリックしてこれらを外して再構築すればOKです。)


 



昔の Delphi 風
再構築が完了して再起動されると、そのままでは難ありな配置になっていますので調整します。
ドッキングするにはべベル部分をドラッグして他のウィンドウに重ねます。




近頃の IDE 風



のように配置できるようになります。
ウィンドウの情報を保存するにはツールから保存しないといけないようです。
IDEを終了、再起動しただけでは配置が復元されませんでした。

べベル(Headers)の非表示
べベルを右クリックして、ポップアップメニューの Show Headersオフにすると、べベルが表示されなくなります。

べベル(Headers)の再表示
べベルがなくなると、調整できなくなってしまいます。
公式の方法は不明ですが、とりあえず
べベルを再表示するには

  表示アンカーエディタを表示

から表示されるアンカーエディタのべベルを右クリックして Show Headersオンにすれば他のウィ ンドウのべベルも表示されるようになります。



以上です。

LevenshteinDistance

あんまりネタもないので、たまにはコードでも書いてみよう。

LevenshteinDistance については wiki 参照。

http://ja.wikipedia.org/wiki/レーベンシュタイン距離

書いては見たけど使わないことになってしまった。

まあたいしたものではないけど。
勿体ない気もするので晒しておきます。

NewBSD License のもと、ご自由に。

一応 Lazarus,FPC 用に書いたつもりですが、基本的に私はObjectPascal については Borland系 のコードしか書けないので Delphi でも動くはずです。
(FillByteはZeroMemoryにしてください)

課題とか。
とりあえず、arrayはとりましたが興味が失せてきたので終わりにします。
式を単純化したり変数やアドレスの計算も減らせそうです。

wikiのまんまの関数は基礎についての解説の一部なんだと思うんですが、おそらく

     // const  SignChars=[33..47,58..63,91..96,123..126];

        case  b1^-b2^ of
          0:
            cost:= 0; // 同じ文字

          -32,32:
            cost:= 2  // 大文字、小文字

          else        // 違う文字
            begin
              if (b1^ = 32) or (b2^ = 32) then
                cost:= 3   // どちらかが空白
              else
              if (b1^ in SignChars) and (b2^ in SignChars) then // *1
                cost:= 1   // どちらも記号
              else
              if (b1^ in SignChars) or (b2^ in SignChars) then
                cost:= 4   // 記号とAaZz
              else
              if (b1^ in [48..57]) and (b2^ in [48..57]) then
                cost:= 1   // どちらも数字
              else
              if (b1^ in [48..57]) or (b2^ in [48..57]) then
                cost:= 4   // 数値とAaZz
              else
                cost:= 5;  //その他(上記以外の文字)
            end;
        end;


のようにして使う事を前提に書かれた解説だと思うんですが、どうなんだろう。
実例が知りたいのだけど、ググっても海外含めて追加・削除・置換しか出てこないんでスッキリしない。
コスト判定が行動主体だけではあんまり意味ないような気がする。
(以下に組み込む場合は、dIns:= iptr^; // + 1; を  dIns:= iptr^+4; // + 5; ぐらいに調整。us-ascii しか考慮していません)

上のまんまなんだけど、例えば数字。
tes4 と入力して tes5 と tes3 は近いほうがいいと思いますし、test はそれより遠いほうがいいように思います。
まあやっぱその辺は状況に応じてカスタムするんだろうな。
そのまま使うわけないよな・・・。


以下コード。

function LevenshteinDistance(s1, s2: string): integer; experimental;
var
  arr : pointer;  // data

  isz : integer;  // size of integer
  sz  : integer;  // total size
  xlen,           // s1 length +1
  ylen: integer;  // s2 length +1

  x,y : integer;
  xptr,
  yptr,
  iptr: pinteger;
  b1,b2: pbyte;   // s1,s2 pointer

  dIns,           // insert cost
  dDel,           // delete cost
  dRpl,           // replace cost
  dRes,           // result
  cost: integer;  // cost

  dist1,           // distance of dIns,dDel address
  dist2: integer;  // distance of dDel,dRpl address
begin
  xlen:= Length(s1)+1;
  ylen:= Length(s2)+1;

  isz:= SizeOf(integer);
  sz:= (xlen * ylen) * isz;
  GetMem(arr,sz);
  try
  {$IFDEF DELPHI}
  ZeroMemory(arr,sz);  // Delphi, or Lazarus,FPC with Windows.pas
  {$ELSE}    
   FillByte(arr^,0,sz);
  {$ENDIF}

    //[x,0]
    xptr:= arr;
    for x:=0 to xlen-1 do
    begin
      xptr^:= x;
      inc(xptr);
    end;
    //[0,y]
    yptr:= arr;
    for y:=0 to ylen-1 do
    begin
      yptr^:= y;
      inc(yptr,xlen);
    end;

    for x:=0 to xlen-1 do
    begin
      for y:=0 to ylen-1 do
      begin
        //iptr := arr + ((x  ) + ((y  )*xlen))*isz;
        iptr := arr;
        inc(iptr, (x  ) + ((y  )*xlen));
      end;
    end;

    x:= 1;
    y:= 1;
    dist1:= ((x-1) + ((y  )*xlen)) - ((x  ) + ((y-1)*xlen));
    dist2:= ((x-1) + ((y-1)*xlen)) - ((x-1) + ((y  )*xlen));

    //b1:=PByte(PChar(s1));
    b1:=@s1[1];
    for x:=1 to xlen-1 do
    begin
      //b2:=PByte(PChar(s2));
      b2:=@s2[1];
      for y:=1 to ylen-1 do
      begin
          // 最後に足す事にして全ての cost から -1 する
          if b1^-b2^=0 then
             cost:= -1 // 0
          else
             cost:= 0; // 1;

        //iptr:= arr + ((x  ) + ((y-1)*xlen))*isz;
        iptr:= arr;
        inc(iptr,(x  ) + ((y-1)*xlen));
        dIns:= iptr^;  // + 1;

        //iptr:= arr + ((x-1) + ((y  )*xlen))*isz;
        //iptr:= arr;
        //inc(iptr,(x-1) + ((y  )*xlen));
        inc(iptr,dist1);
        dDel:= iptr^;  // + 1;

        //iptr:= arr + ((x-1) + ((y-1)*xlen))*isz;
        //iptr:= arr;
        //inc(iptr,(x-1) + ((y-1)*xlen));
        inc(iptr,dist2);
        dRpl:= iptr^ + cost;

        dRes:= dIns;
        if dRes>dDel then dRes:= dDel;
        if dRes>dRpl then dRes:= dRpl;

        //iptr := arr + ((x  ) + ((y  )*xlen))*isz;
        iptr:= arr;
        inc(iptr,(x  ) + ((y  )*xlen));

        //iptr^:=dRes;
        iptr^:=dRes + 1; //最後に足せばいい

        inc(b2);
      end;
      inc(b1);
    end;

    //iptr:= arr + ((xlen-1) + ((ylen-1)*xlen))*isz;
    iptr:= arr;
    inc(iptr,(xlen-1) + ((ylen-1)*xlen));

    Result := iptr^;
  finally
    FreeMem(arr,sz);
  end;
end;

補足
コメントアウトされたコードは最適化前のコードです。
直後のコードと等価です。

注意
inc で進むポインタのアドレスは isz 倍しなくても大丈夫です。
逆に iptr のアドレスを計算する際は arr から 進める分を isz 倍しないと、おかしくなります。

2013年8月29日木曜日

構築やコンパイルをした後に自動的にコマンドを実行

構築やコンパイルをした後に自動的にコマンドを実行することができます。
各構築モードごとに設定できます。

リリースモードを指定してコンパイルした時のみ、コンパイル済みのファイルをリリース用のディレクトリにコピーしたりなど便利に使えそうです。

コマンドは、「コンパイラオプション」の「コンパイル」で指定できます。
コマンドプロンプトで使えるコマンドは一応そのまま使えそうです。
実行結果は、IDE のメッセージウィンドウで確認できますが、文字化けします。
コマンドが出力したメッセージを正しく表示できないようです。
なので、バッチファイルを作り、コードページを変更したほうが良さそうです。
しかし、コードページ 932 (日本語)、65001 (UTF8) のどちらでも文字化けしてしまいました。
chcp 437ascii を指定し、結果は英文で受け取るしかなさそうです。

以下は設定とバッチファイルの例です。

設定の例

次の後の実行」の「コマンド」の欄に記述します。
$ProjPath()\_release.bat $TargetFile()

$ProjPath()でプロジェクトディレクトリがコマンドに渡ります。
$TargetFile()でコンパイルされてできたバイナリのファイル名が渡ります。

$ProjPath()等のマクロはメニューの「ツール」→「外部ツールの設定」→編集または追加→「マクロ」の欄 で一覧が確認できます。

バッチファイルの例
_release.bat で保存
@echo off
chcp 437

set RELEASE_DIR=D:\MyTOOLS\64bit\tcesyn\

if not exist %RELEASE_DIR%NUL goto err
echo copying...
C:\Windows\System32\xcopy.exe /Y "%1" %RELEASE_DIR%
echo completed.
goto eof

:err
@echo %RELEASE_DIR%
@echo That directory not found.

:eof

以上です。

Lazarus IDE


画像は Lazarus 1.0.10 の見た目。

2週間ほど使ったのでその感想でも書いてみようかと。

Windows CE,Linux,Ubuntu,unix,arm,Android,iOS となんでも行けるようです。
試してはいませんが。

IDEの起動がメモ帳並に速いので、けっこう気楽に落とせます。
次に開いた時も、表示していたコードの位置も覚えててくれるので、起動したままであったかのように継続して作業できます。
便利すぎます。

コンパイルは Delphi に比べれば遅いものの、他と比べれば速いほうでしょう。
旧Borland は凄かった。

Delphi 同様、コンパイルしたものが単体で実行できるように作ることができます。
作ったものの実行速度も速いほうだと思います。
特に最近の某フレームワーク依存のものに比べると軽く感じます。

コンポーネントパレットは、昔のDelphi よりも充実してます。
(今のDelphi は分かりません)
無いものも探せばそこそこあります。
Delphi の資産もけっこう使いまわせるようです。
何かに依存したつくりでなければ、そのままコンパイルできるようです。
Delphi ソースを変換する機能がついています。

ウィンドウは MDI風でもなく、各ウィンドウもドックできません。
と、他と見劣りするかもしれません。
最初は私も戸惑いましたが、慣れとは怖いもので。
2週間ほど使った結果、まったく気にならなくなりました。
MDI はもともと好きではないんで、むしろ好ましく思います。

ドッキングできたようです。
こちらで紹介しています。
http://laznyan.blogspot.jp/2013/09/lazarus-ide.html

マルチディスプレイで使ってると、あちこちウィンドウを動かします。
どうも、それをシングルディスプレイにした時に、外に出ているウィンドウが戻ってきてくれません。
なので、準備運動がてらにウィンドウ再配置ツール的なものを最初につくったほうが良さそうです。


すでに 1.0.12 があるようですが、まだ未確認です。

PS
2013/09/10 ドッキング対応について追記しました。

2013年8月28日水曜日

Lazarus での Memory Leak チェック

Lazarus IDE での Memory Leak のチェック。
Delphi では FastMM にお世話になりましたが。

プロジェクトオプション→コンパイラオプション

デバッグ中: (上段)
  実行時エラーの後方探索で行番号を表示 (-gl) をチェック

デバッグ中: (中段)
  Heaptrcユニットを使用 (-gh) をチェック。






以上で heaptrc を uses に書かなくても heaptrc が使われるようになり、SetHeapTraceOutput等が使えるようになります。

GDBのためのデバッグ情報生成もチェックしておいてください。


これだけだと、アプリケーション終了時にメッセージダイアログで情報が表示されてしまいます。

プロジェクトファイル(.lpr) の 冒頭に (beginの後)

  if FileExists('heap.trc') then DeleteFile('heap.trc');
  SetHeapTraceOutput('heap.trc');

を追加しておきます。
こうすると heap.trc が出力されるようになります。
heap.trc はメモ帳等で開いても読めますが、それを IDE のメニューの「ツール」→ Leak View から読み込むと heap.trc の内容をIDEで表示してくれます。

項目をクリックするとその行にジャンプもできます。

なお、FileExists は SysUtils を要求します。

モードの構築で、Memory Leak Check などを定義し(前の記事参照
-dLEAKCHECK を「その他」のカスタムオプションに設定し、前述のオプションも含めてしまい

uses
{$IFDEF LEAKCHECK},SysUtils{$ENDIF}

begin の後に
{$IFDEF LEAKCHECK}
  if FileExists('heap.trc') then DeleteFile('heap.trc');
  SetHeapTraceOutput('heap.trc');
{$ENDIF}

としておけば、切り替えも簡単です。


関連


構築モード で DEFINE を指定する。(あるいはコード中から構築モードを検出する)

Lazarus の コンパイラオプションの「モードの構築」から構築モードに

「リリース」



「デバッグ」

を作ったとします。


それをコード中から検出する事はできませんが、

コンパイラオプションの「その他」のカスタムオプションで DEFINE を指定することができます。

なので、

構築モードが「デバッグ」 の時は、「その他」のカスタムオプションに

-dDEBUG

と書いておけば {$DEFINE DEBUG} した事になるようです。



コード中から

{$IFDEF DEBUG}
writeln('This is debug.');
{$ENDIF}

のようにして間接的に構築モードを検出することもできます。

そうなると、DEFINE は DEFINEで、構築モードは構築モードで別々に考えてコードを書いても問題ないという事にもなります。


2013年8月27日火曜日

Windows OSが 64bit かどうか判定する。

64bit の Windows で実行中のアプリケーションから OS が 64bit かどうか判定する。

手順は

 http://msdn.microsoft.com/en-us/library/windows/desktop/ms684139(v=vs.85).aspx



 http://www.delphigroups.info/2/5/795988.html

等が見つかります。

が、これは 32bit アプリケーションが Windows の WOW64 上で実行されているかどうかの判定しかできません。

実行中のアプリケーションが64bitの場合 kernel32 の IsWow64Process は False を返します。

当然と言えば当然なのだけどしばらく悩みました。

Lazarus に移植した古臭い起動環境判定のユニットの一部の関数が 32bit としか返さないので、なぜなのかと読み返したらそういうことでした。

ということで、IsWow64Process に頼って OS が 64bit かどうか判定しているような場合は問題となります。

Lazarus,FPC みたいにクロスプラットフォーム対応で、Windows でも 32bit 版と64bit版が用意されているような開発環境では配慮したほうが良さそうです。

で、 64bit かどうか判定するには SizeOf で pointer 等のサイズを求めればOKのようです。
コンパイラオプションでサイズが変わる可能性がある型は避けたほうが良いように思います。

case SizeOf(pointer) of
 4: Result:='32bit';
 8: Result:='64bit';
end;

ちなみに各環境での結果は以下の通りです。

アプリ, OS, SizeOf結果, IsWOW64Process
32bit アプリケーション, 32bit Windows OS : SizeOf(pointer)=4, IsWow64Process=False
32bit アプリケーション, 64bit Windows OS : SizeOf(pointer)=4, IsWow64Process=True
64bit アプリケーション, 32bit Windows OS : ダイアログでエラー表示。起動しない。
64bit アプリケーション, 64bit Windows OS : SizeOf(pointer)=8, IsWow64Process=False

普段から SizeOf で型のサイズを使ってバッファのサイズを計算する習慣というのが Pascalの世界ではあちこちで推奨されていたはずなので判定の意味はないかもしれません。

判定などせずともコンパイラを変えればそのまま動くはずです。
リソースから32bit用、64bit用、それぞれのデータファイルを環境に応じて出力するような場合とか、API切り替えたり、OS環境そのものを表示する場合ぐらいにしか困ることは無いのかもしれません。


旧式からの移植は危険かもしれません。
たまたま動いているだけな気がします。
こんなのは氷山の一角なのでしょうね。


Lazarus, Unique Instance, CreateMutex

旧式のエディタと同様にインスタンスを唯一にしようと思いました。

その辺のコードも旧式から使いまわせそうでしたが、Ubuntuでも使おうと思い始めたので、今以上に Windows 寄りになってしまうと少々困ります。
すでに結構課題がたまっている状況・・・。

CreateMutex は問題なく機能し、FindWindow 等も使えるらしくコンパイルは通りますが

どうも FindWindow が 0 しか返してくれません。

まあいいや。

http://wiki.lazarus.freepascal.org/UniqueInstance

によると

https://code.google.com/p/luipack/

の uniqueinstance-1.0.zip というのがあります。

動作テストでは、ほとんど張るだけで OKでした。

uniqueinstanceは、unix と windows で動くようです。
うーん。ubuntu に対応できるか不安だがなんとかなるでしょう・・・。

uses に uniqueinstance を加えて

Identifier にユニークな名前を与えて Enabled を True にするだけです。

デザイナで張るならパッケージを Lazarus IDEに加えて IDE を再構築する必要があります。
必要なければプロジェクトに加えるだけでOKです。

UniqueInstanceOnOtherInstance の イベントハンドラで起動オプション(コマンドラインパラメータ)を受けとれます。

Enabled の実態が FEnabled になっており動的な切り替えによる再初期化やクリーンナップ等は実装されていません。

そのままだとデザイン時に張られていて Enabled=Trueになっていないと動きません(恐らく)

TComponent.Loaded を override して、そこで初期化等をしている模様です。
これを継承して Enabled が設定されたタイミングで Loaded が呼ばれるように変更します。

Reload だけ直に呼べばいいようにも思います。

  TUniqueInstanceLateLoad=class(TUniqueInstance)
  private
    function GetEnabled: boolean;
    procedure SetEnabled(AValue: boolean);
  protected
    procedure Loaded; override;
    procedure ReLoad;
    property Enabled: boolean read GetEnabled write SetEnabled;
  end;

implementation

function TUniqueInstanceLateLoad.GetEnabled: boolean;
begin
  Result:= inherited Enabled;
end;

procedure TUniqueInstanceLateLoad.SetEnabled(AValue: boolean);
begin
  if GetEnabled<>AValue then
  begin
     (inherited Enabled):= AValue;

     Assert(AValue);

     // FEnabled=True のタイミングで Loaded を実行
     Reload;
  end;
end;

procedure TUniqueInstanceLateLoad.Loaded;
begin
  // nothing
end;

procedure TUniqueInstanceLateLoad.ReLoad;
begin
  inherited Loaded;
end;  

これでデザイナを使わずに動的な生成に対応できます。

  FUnique:= TUniqueInstanceLateLoad.Create(Self);
  FUnique.Name:='UNI01';
  FUnique.UpdateInterval:= 1000;
  FUnique.OnOtherInstance:=UniqueInstanceOnOtherInstance;
  FUnique.Identifier:= 'unique_name'
  FUnique.Enabled:=True;

それだけ。

UniqueInstanceOnOtherInstance のイベントハンドラの Parameters: array of string は、0 オリジン。

他に関数バージョンのuniqueinstanceraw があります。


function InstanceRunning(const Identifier: String; SendParameters: Boolean = False): Boolean;

こちらは指定したインスタンスが既存かどうか確認できます。

if IstanceRunning('MYAPP',  True) then
begin
  Application.Terminate;
end

メインユニット(プロジェクトファイル)なんかで使うと便利そうです。
SendParamaters は True にするとコマンドラインパラメータを既存のプロセスに送ってくれます。(はず)


細かいことをしたい場合は、TSimpleIPCServer等を TUniqueInstanceを参考にクラスとか作って使ったほうがよさそうです。

PS
やっぱり、機能単位でメソッドやプロパティを分離して再配置することにしました。
フォーラムなどを読んでいると、もともと旧バージョンはそのような使い方をしていたらしく、現状における最新版は、さらに簡単に使えるようにしたもののようです。
なので、uniqueinstance.pas と uniqueinstanceraw.pas を参考に別のクラスを作ったほうが制御しやすいと思いました。

PS2
このユニット、windows 限定で使おうとするなら
SimpleIPCWrapper.InitServer(FIPCServer); と
SimpleIPCWrapper.IsServerRunning(Client); は
使わずに単に
FIPCServer.StartServer; と
Client.ServerRunning; でよさそうです。

ということはSimpleIPCWrapperは必要なくなり
simpleipc を直接使っているのと変わりなくなります。
つまりはそこが肝で、どううやらこれの使い方を学べばもっと用途に合ったコードが書けそうです。



2013年8月20日火曜日

コードエディタ

Delphi 3 ぐらいから作って使ってた およそ15年ぐらい使い続けたエディタが、Windows 8ではいろいろと問題がでてきて、Windows 8 pro 64bit用のコードエディタがほしくて、Lazarus で作っていたのだけど。

基本機能はほぼ実装できたように思う。



外観もほぼ同じ。
前の: http://eisen-japan.blogspot.jp/2013/08/blog-post_3604.html


アイコンなどは使わない方針。
タブが左側にあるのが特徴。

エディタの機能は SynEdit の機能がそのまま全面に出ている。
私は、文字コードの選択と、分割とクローンさえあればOKなので、それしか追加の機能はない。
検索と置換、あとは、SynEdit 由来の Hilighter と CTRL+J などのシンクロエディットと、マクロの記録再生などを実装。


コマンドプロンプトやメールアクセス機能は、この際なくてもいいかと思うので、無しにしようかと。
時代にあってないし。

サテライトビューというか広範囲ビューも、10年以上使って、おそらく総計数時間しか使ってなかったんでいらない気もする。
とはいえ、何かしらそれに代わる機能がほしいような気もするので構想中。

印刷機能も、前のはあったけど、結局印刷したのは数回だった気がするので未実装。

Lazarus の SynEdit には、HTMLエクスポート機能などのコンポーネントもあるので。
それらも利用するかどうか検討してもいいかもしれない。

Delphi 用に作った XMLパーサが、ほぼそのまま動くようだったので利用。
それゆえ 各種情報管理に TStringList を使わなくなったせいか、前のより起動・終了もかなり軽い。
マクロなども、前のより統制が取れて使いやすくなった。
検索・置換なども前のは、ほぼD3時に書いたコードをそのまま放置だったけど。
今回のは書き直したので、だいぶマシになった。

クローンからドックする時も ウィンドウハンドルの再設定するのではなく、新しくエディタのインスタンスから作成しなおす方針で実装。

一度作ったインスタンスを使いまわしたほうが初期化少なくて軽かろうと当時は思っていたのだけど。
ウィンドウハンドルの再設定時に初期化処理等で、メッセージが飛びまくるゆえ、各種ロックとアンロックを繰り返しながら1つ1つ処理していくため、かえって処理に時間がかかっていた。

ので、だいぶ軽くなり、ドック時のちらつきなどもなくなった。

あとは、履歴ぐらいがあればOKか。
そういや、バイナリエディタはどうするか・・・。

2013年8月16日金曜日

Lazarus で String と PChar を扱う場合の注意

環境:Lazarus IDE v1.0.10,FPC v2.6.2,-MDelphi

文字列関係は、まあいろいろあって面倒くさい。

Delphi 5 - 2007 → Lazarus で String と PChar を扱う場合の注意。

function test: string;
var
 tmp: String;
 s,e,p: PChar;

begin

 tmp:='AA';

 s:= @tmp[1];          //開始
 e:= s + length(tmp);  //終了
 p:= s;                //走査用

 while p&lt;e do
 begin
   if p^='A' then
      p^:='B'
   else
      p^:=chr(byte(p^)+1); //C,D,E,F....
   inc(p);
 end;
 Result:= tmp;
end;

この関数は、毎回 "BB" を返すことを想定している。
関数を呼び出す度に tmp は "AA" になるので結果は "BB"になる。

Delphi 5 だと想定通りの結果を返す。

何度呼び出そうとも tmp は毎回1度は"AA"になり、結果 Result は "BB" となる。

ところが Lazarus だと 1回目のtest()呼び出し時には 結果 Result は "BB" となるが 2回目以降 の test()呼び出し時には、結果 Result は "CC"~ になってしまう。
つまり "AA" それ自体が "AA" ではなくなってしまう。

function test: string;
const
  def='AA';
begin
  tmp:=def;

としても、同じように、2回目以降、結果 Result は "CC"~ が結果となる。
(const は interface部に書いても同様の結果。)
つまり const def ='AA' としようとも"AA"自体が書き換えられてしまう。

これを回避するには

tmp:='AA';


ではなく



move('AA',pointer(tmp)^,2);

のように毎回 "AA" を別の所(固定値のアドレスが異なるように配慮し)与える必要があるようだった。

このようにも書ける。

p:=s;
while p&lt;e do

begin
  p^:='A';
  inc(p);
end;


調べたところ単に


tmp:=PChar('AA');

とするだけで期待通りの動作になる。


とりあえず、固定値を定義して、PCharとかpointerでアクセスして値を書き換えるようなコードはすべて注意する必要がある・・・という事。

ということで、私と同じようにハマったらこの記事を思い出してみてください。

以上。

http://bugs.freepascal.org/view.php?id=22534

http://bugs.freepascal.org/view.php?id=10341

ということらしい。

なんだか Pascal の伝統が1つ失われたような気がしないでもない。

p.s.
この記事は、別の私的なブログから改訂しつつ移動しました。

Width = ClientWidth な問題

Lazarus (Windows 8 pro,Lazarus 1.0.10, FPC 2.6.2)
では TForm などの Width と ClientWidth が等しいようです。

仕様とのこと。

今後 Delphi 互換性向上の対策などもあり、ソースをたどると既にそれらしきメソッドなども用意されています。
(対策済みなのかどうなのか。確認してないので各自で確認してください。)

私的には適当にデザインしたり動的にコントロール作成したりして使ってる分には、これといって不都合は今のところありません。

なぜ不都合がないのか不思議なのだけど、それはそれでつじつまが合っているようです。
あまり深くは考えないことにしましょう。

ウィンドウを並べたい場合には、やはり問題が生じ、単に Left + Width の位置に新しいウィンドウを作成して配置しただけでは、ウィンドウの枠が大きく重なってしまいます。


とりあえず。

ウィンドウを横に二つ並べる場合、以下のコードで解決するので書いておきます。

procedure TForm1.Example;
var
  borderfix:= GetSystemMetrics(SM_CXFRAME);
  x, y : integer;
begin
  x:= Left + Width + borderfix;
  y:= Top;
  Form2.SetBounds( x, y, Width, Height);
end;

これできっちりそろいます。(Windows 8)

以上。

一部のヒントを非表示にする

example.pas(1054,24) Hint: Parameter "Target" not used

Lazarus IDEのメッセージウィンドウに、このようなヒントが表示される場合があります。

クラスのプライベートプロパティにメソッドポインタならぬ関数ポインタをもたせて、他のパラメータに応じて、関数を切り替えて使うような場合があるとします。

このような場合、引数を削ってしまうわけにはいかないので、何とかそこだけヒントを無効にしたいところです。

interface
type
  TProc = function (Target: TObject): integer;

implementation

function DefProc( Target: TObject): integer;
begin
   Result:= 0;
end;

function Proc01( Target: TObject): integer;
begin
   Result:= 0;
   if Target is TCompoment then Result:= 1;
end;

procedure Main;
var
  Proc: TProc;
begin
   Proc:= DefProc;

   if Mode=1 then Proc:=Proc01;

  Proc( object);
end;

こんな場合に、DefProc の Target が使われていないとヒントが出ます。

コンパイラオプションからヒントを無効にしてしまうと、他のヒントもごっそり表示されなくなってしまうので、それは避けねばなりません。

{%H-} を Target の頭につければ以後それに関してのヒントのみが表示されなくなります。

function DefProc( {%H-}Target: TObject): integer;

なお、Sender も同様に使われない場合が多々ありますが、Senderに限っては表示されません。
Sender が使われていない旨も表示させることもできますが、デフォルトではプロジェクトオプションで抑制されています。(画像内の右上の項目に注目)
昔は出ていたようです(?)





以上。

プロジェクトオプション(デバッグ情報の生成など)

Delphi のデバッグ情報の生成に相当するのは Lazarus では

  プロジェクトオプション→コンパイラオプション→「GDBのためのデバッグ情報を生成」



「GDBのためのデバッグ情報の生成」のチェックを外すと実行ファイルサイズが 40Mぐらいのだったものが 5M ぐらいになります。
(新規プロジェクト作成時、デフォルトでデバッグ情報の生成がオンになっています)

Delphi だとデバッグ情報を付加してもそこまで大きくはなりませんが、Lazarus は大きめになってしまうようです。(Delphi も TD32デバッグ情報を付加すればもっと大きくなりました)


{$IFOPT D+}
{$ENDIF}

なども Delphi 同様に利用できます。

他に、「モードを構築」というのがコンパイラオプションの所にあって、「情報をより多く表示」にある各種警告文とうの表示の状態や、デバッグ情報の生成などのコンパイラオプションの状態をひとまとめにして管理できます。

リリース用
デバッグ用

などで構築モードを作成しておけば、ちまちま設定を切り替える必要もないので便利です。
なお、構築モードのアクティブ状態を切り替えながらオプション設定を変更しても、それぞれの状態を記憶してくれています。
(最後にOKを押さないと、閉じたときに忘れられてしまうので注意が必要)




こちらはサイズには影響ないようです。(たぶん)



デバッグ情報を表示(-vd) や 全てを表示(-va) 等、右側にある項目はすごい量のメッセージが表示されます。
コンパイル速度もかなり落ち込むので、必要なければオフにしていたほうが良さそうです。
行番号の表示(-v) などは特に問題ありません。

構文モード
Delphiモード(-Mdelphi)にすると @ の扱い方などが変わるようです。
Object Pascal (-Mobjfpc) のままでも、Delphi をやっていた方なら特に問題ないと思います。
新しく作成するときは Delphi モードでは作成しないほうがよろしいかとも思います。
なぜなら、あちこちに点在するコード資産は -Mobjfpc のほうが多いようです。
なので、 @ の扱い方などがコードのファイル単位で変わってしまうと混乱してしまうのではないかと・・・。



コード生成。
おなじみのコンパイラオプションもあります。




コンパイラオプション
http://wiki.lazarus.freepascal.org/IDE_Window:_Compiler_Options/ja

詳細
http://www.freepascal.org/docs-html/user/usersu68.html#x105-1120006.11.4

一覧
http://www.freepascal.org/docs-html/user/usersu68.html#x105-1120006.11.4

けっきょくの所足りない部分は FPCのほうのマニュアルにたどり着くようです。
歴史があるんですね。
そういえば、FPCの存在自体は知っていたような気もします。
ただ Delphi があったから興味がわかなかっただけだったような。

以上。


2013年8月15日木曜日

Laz にゃん

Lazarus と FPC 関連の私的メモなどを投稿するブログ(というよりアーカイブ)。
現時点で私の環境が Windows 8 Pro 64bit のみなので他の環境は今の所対象外です。

・内容は無保証です。
・各自の責任でご利用ください。
・気まぐれでよく編集しなおします。
・誤字脱字がいっぱいあります。
・意味が逆転していることもあります。

ブログの名前にあわせて猫かぶってなるべくかわいく書く方針に決定しました。

以上。