この発言に対し以下のコメントが寄せられています

#01317　ＴＮ            さん　RE:汎用ロックサーバ

#01341　ＴＮ            さん　RE:汎用ロックサーバ




特定の文字列に対して待ち行列を作って実行を待たせる機能を持った、
アウトプロセスのCOMサーバの例を示します。
テーブルを開いて更新するときや、ファイルに書き込むときに「開けません」
エラーを検出してポーリングを繰り返す必要が無く、トランザクションを複数
同時に受け付けてさばく場合にすっきりしたコードを記述できます。

<サーバの作成>
・プロジェクトの新規作成でオートメーションオブジェクトを作ります。
  (LockServer.exe)
・タイプライブラリエディタでINamedLockというinterfaceをつくり、
　下記メソッドを宣言

  INamedLock = interface(IDispatch)
    procedure Lock(const LockName: WideString); safecall;
    procedure UnLock(const LockName: WideString); safecall;
    procedure Clear; safecall;
  end;

・NamedLock.pasをusesしたアプリを作成。一回実行してレジストリに登録させる。

<クライアントのコーディング>
uses ...., LockServer_TLB;
var
  NamedLock: INamedLock;

  NamedLock := CoCreateNamedLock;
  NamedLock('D:\DataFiles\File1.txt');   // ファイルのロック
  NamedLock('MyDB:Table1');              // テーブルのロック
  try
   //////////////////////// 仕事をする
  finally
    NamedUnLock('MyDB:Table1');              // テーブルの開放
    NamedUnLock('D:\DataFiles\File1.txt');   // ファイルの開放
  end;

注意
・INamedLockを使用しないファイルやテーブルへのアクセスはまったく
　自由なので、ロックし忘れた場合は無効果。
・LockServer.exeを強制ロック解除の仕組みをつけたアプリに仕立てれば便利。
　（GetLockNames、LeaveNamedLockを使えば簡単）
・DCOMでもたぶんそのまま使えるので、複数台のマシンでサーバを構成する場合
　同じ文字列でファイルやテーブルにアクセスするようにしておく。

＜サーバのコード＞--------------------------------------------------------
{
  NamedLock.pas
  Clear method is not implemented.
  NamedLock server の実体
  ! Lockのユーザーはこのファイルをusesしないこと．
  ユーザは LockServer_TLB をusesすること．
  Lock,UnLock    文字列によるロック。大文字小文字は区別しない
  　あとからロックを要求するスレッドは，先取したスレッドが UnLock するまで
  　待たされる．
}

unit NamedLock;

interface

uses
  Windows, SysUtils, Classes, SyncObjs, ComObj, ComServ,
  ActiveX, Forms, LockServer_TLB;

type
  TNamedLock = class(TAutoObject, INamedLock)
  protected
    procedure Lock(const LockName: WideString); safecall;
    procedure UnLock(const LockName: WideString); safecall;
    procedure Clear; safecall;
  end;

  ENamedLockException = class(Exception)
  end;

  TNamedLockEvent = procedure(LockName: string) of object;

  procedure LeaveNamedLock(const LockName: string);
  procedure GetLockNames( St: TStrings );

var
  Names: TStringList;

//--------------------------------------------------------------------------
implementation

const
  NORMALMAXWAITTIME = 60000; //ms  1min

var
  NLock: TCriticalSection;
//  LeaveEvent: TEvent;

procedure EnterNamedLock(const LockName: String);
var
  index: integer;
  S: string;
  Result: boolean;
  WakeupEvent: TEvent;
begin
  S := AnsiUppercase(LockName);
  Result := False;
  WakeupEvent := nil;
  NLock.Enter;
  try
    index := Names.IndexOf(S);
    if index = -1 then begin
      Names.AddObject( S, TList.Create );  // List is a queue of waiting events
      Result := True;
    end else begin
      WakeupEvent := TSimpleEvent.Create;
      TList(Names.Objects[index]).Add( WakeupEvent );
    end;
  finally
    NLock.Leave;
  end;

  if WakeupEvent <> nil then begin
    try
      if WakeupEvent.WaitFor(NORMALMAXWAITTIME) = wrSignaled then begin
        Result := True;
      end;
    finally
      WakeupEvent.Free;
    end;
  end;

  if not Result then begin
    raise ENamedLockException.Create(
          'NamedLock Timeout: '+ AnsiUppercase(LockName) );

  end;
end;

procedure LeaveNamedLock(const LockName: string);
var
  index: integer;
  S: string;
  List: TList;
  WakeupEvent: TEvent;
begin
  WakeupEvent := nil;
  S := AnsiUppercase(LockName);
  NLock.Enter;
  try
    index := Names.IndexOf(S);
    if index <> -1 then begin
      List := TList(Names.Objects[index]);
      if List.Count = 0 then begin
        List.Free;
        Names.Delete( index );
      end else begin
        WakeupEvent := List[0];
        List.Delete(0);
      end;
    end;
  finally
    NLock.Leave;
  end;

  if WakeupEvent <> nil then begin
    WakeupEvent.SetEvent;
  end;
end;

procedure Clear;
begin
end;

procedure GetLockNames( St: TStrings );
begin
  NLock.Enter;
  try
    St.Assign( Names );
  finally
    NLock.Leave;
  end;
end;

{ TNamedLock }
procedure TNamedLock.Clear;
begin
  //Clear;             not implemented yet
end;

procedure TNamedLock.Lock(const LockName: WideString);
begin
  EnterNamedLock(LockName);
end;

procedure TNamedLock.UnLock(const LockName: WideString);
begin
  LeaveNamedLock(LockName);
end;

initialization
  Names := TStringList.Create;
  NLock := TCriticalSection.Create;
  // This application is outprocess NamedLock Server
  CoInitFlags := COINIT_MULTITHREADED;
  TAutoObjectFactory.Create(ComServer, TNamedLock, Class_NamedLock,
    ciMultiInstance, tmFree);

finalization
  NLock.Free;
  Names.Free;

end.
                                                  ＴＮ(CQJ01721)
 


Original document by ＴＮ            氏 ID:(CQJ01721)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。