fastdbsession.pas

俄国人写的内存数据库的delphi封装

    if ((pLevel > 0) or qMode) and not (Result[i] in ['(', ')', '''']) then
      Result[i] := '_';
  end;
end;

// Find a whole word in a string
function WordPos(const AWord, AString: string): Integer;
var s: string;
    i, p: Integer;
begin
  s := ' ' + LowerCase(AString) + ' ';
  for i := 1 to Length(s) do if not (s[i] in Identifiers) then s[i] := ' ';
  p := Pos(' ' + LowerCase(AWord) + ' ', s);
  Result := p;
end;

// Split the select statement into 3 parts: select_part1 where_part2 order_by_part3
procedure SplitSelect(Select: string;
                      var BeforeWhere, WhereClause, AfterWhere, WhereWord: string);
var p0, p1, p2: Integer;
    ncSelect, ucSelect: string;
begin
  // Remove comments
  ncSelect := RemoveSQLComment(Select);
  // Convert to LowerCase
  ucSelect := LowerCase(ncSelect);
  // Discard text between parnthesis and quotes
  ucSelect := RemoveParenthesisAndQuotes(ucSelect);
  p0 := WordPos('group', ucSelect);
  if p0 > 0 then WhereWord := 'having' else WhereWord := 'where';
  p1 := WordPos(LowerCase(WhereWord), ucSelect);
  p2 := WordPos('order', ucSelect);
  if p2 <= 0 then p2 := WordPos('for', ucSelect);
  if p2 > 0 then
    AfterWhere := Copy(ncSelect, p2, Length(ncSelect))
  else begin
    AfterWhere := '';
    p2 := Length(ncSelect) + 1;
  end;
  if p1 > 0 then
  begin
    BeforeWhere := Copy(ncSelect, 1, p1 - 1);
    WhereClause := Copy(ncSelect, p1 + Length(WhereWord), p2 - p1 - Length(WhereWord));
  end else begin
    BeforeWhere := Copy(ncSelect, 1, p2 - 1);
    WhereClause := '';
  end;
  BeforeWhere := Trim(BeforeWhere);
  WhereClause := Trim(WhereClause);
  AfterWhere  := Trim(AfterWhere);
end;

//---------------------------------------------------------------------------
procedure SessionErrorHandler(ErrorClassCode: Integer;
  const Msg: PChar; MsgArg: Integer; const UserData: Pointer); cdecl;
var
  s : TFastDbSession absolute UserData;
begin
  Assert(s <> nil, 'UserData must be assign TFastDbSession value!');
  if Assigned(s.OnSessionError) then
    s.OnSessionError(s, ErrorClassCode-100, string(Msg), MsgArg);
  // This procedure must raise an error to unwind the stack
  raise EFastDbError.Create(ErrorClassCode-100, string(Msg)+Format(' (%d)', [MsgArg]));
end;

//---------------------------------------------------------------------------
// TFastDbSession
//---------------------------------------------------------------------------
constructor TFastDbSession.Create(AOwner: TComponent);
begin
  inherited;
  FTraceHandlerThunk    := CreateProcedureOfObjectThunk(Self, @TFastDbSession.SessionTraceHandler);

  FRollbackOnDisconnect := True;
  if not (csDesigning in ComponentState) then
    begin
      FDatabase         := ChangeFileExt(ExtractFileName(ParamStr(0)), '');
      FDatabasePath     := ExtractFilePath(ParamStr(0));
    end;
  FHost                 := 'localhost';
  FPort                 := FastDbDefaultDatabasePort;
  FMaxConnectRetries    := 5;
  FInitDatabaseSize     := FastDbDefaultInitDatabaseSize;
  FInitIndexSize        := FastDbDefaultInitIndexSize;
  FExtensionQuantum     := FastDbDefaultExtensionQuantum;
  FFileSizeLimit        := 0;

  {$WARNINGS OFF}
  FReconnectTimeout     := FastDbDefReconnectTimeoutSec;
  {$WARNINGS ON}
  FHandle               := FastDbUnilitializedHandle;

  FAutoCommit             := True;
  FOpenAttributes         := [oaReadWrite];
  FTransactionCommitDelay := 0;

  FContextList := TThreadList.Create;
end;

//---------------------------------------------------------------------------
destructor TFastDbSession.Destroy;
var i : Integer;
begin
  with FContextList.LockList do
  try
    for i:=Count-1 downto 0 do
      Dispose(PContextEntry(Items[i]));
    Clear;
  finally
    FContextList.UnlockList;
    FContextList.Free;
  end;

  if FHandle <> FastDbUnilitializedHandle then
    CloseDatabase(False);
  inherited;
end;

//---------------------------------------------------------------------------
function TFastDbSession.CliCheck(const Code: Integer; Msg: string='';
  const RaiseError: Boolean=True): Integer;
begin
  Result := Code;
  if Code < 0 then
    begin
      FLastErrorCode := Code;
      if RaiseError then
        raise EFastDbError.Create(Code, Msg);
    end;
end;

//---------------------------------------------------------------------------
procedure TFastDbSession.Commit(const Flush: Boolean);
var rc : Integer;
begin
  CheckHandle;
  {$IFDEF CLI_DEBUG}
  if Flush then TraceDebugProcedure(Format('cli_commit(%d)', [FHandle]), True)
           else TraceDebugProcedure(Format('cli_precommit(%d)', [FHandle]), True);
  {$ENDIF}
  if Flush then rc := cli_commit(FHandle)
           else rc := cli_precommit(FHandle);
  {$IFDEF CLI_DEBUG}
  TraceDebugProcedure(Format('%d', [rc]), False);
  {$ENDIF}
  CliCheck(rc, 'cli_commit failed');
end;

//---------------------------------------------------------------------------
procedure TFastDbSession.DoAfterLogon;
begin
  if Assigned(FAfterLogOn) then
    FAfterLogOn(Self);
end;

//---------------------------------------------------------------------------
procedure TFastDbSession.DoBeforeLogon;
begin
  if Assigned(FBeforeLogOn) then
    FBeforeLogOn(Self);
end;

//---------------------------------------------------------------------------
function TFastDbSession.ErrorMessage(ErrorCode: Integer): string;
begin
  Result := CliErrorToStr(ErrorCode);
end;

//---------------------------------------------------------------------------
procedure TFastDbSession.Loaded;
begin
  inherited;
  if FHandle > FastDbUnilitializedHandle then
    begin
      DoAfterLogon;
      if Assigned(FOnChange) then FOnChange(Self);
    end;
end;

//---------------------------------------------------------------------------
procedure TFastDbSession.CloseDatabase(const RaiseError: Boolean=True);
var rc : Integer;
begin
  if FHandle > FastDbUnilitializedHandle then
    try
      if FAssignedErrorHandler then
        try
          cli_set_error_handler(FHandle, FOldErrorHandler, Self);
        finally
          FAssignedErrorHandler := False;
        end;

      {$IFDEF CLI_DEBUG}
      TraceDebugProcedure(Format('cli_close(%d)', [FHandle]), True);
      {$ENDIF}
      rc := cli_close(FHandle);
      {$IFDEF CLI_DEBUG}
      TraceDebugProcedure(Format('%d', [rc]), False);
      {$ENDIF}
      CliCheck(rc, 'cli_close failed', RaiseError);
    finally
      FHandle := FastDbUnilitializedHandle;
    end;
end;

//---------------------------------------------------------------------------
procedure TFastDbSession.InternalOpenDatabase(const AConnectLocal: Boolean);
var n : Integer;
begin
  if FHandle > FastDbUnilitializedHandle then
    begin
      {$IFDEF CLI_DEBUG}
      TraceDebugProcedure(Format('cli_close(%d)', [FHandle]), True);
      n :=
      {$ENDIF}
      cli_close(FHandle);
      {$IFDEF CLI_DEBUG}
      TraceDebugProcedure(Format('%d', [n]), False);
      {$ENDIF}
      FHandle := FastDbUnilitializedHandle;
    end;

  DoBeforeLogon;

  if not AConnectLocal then
    n := cli_open(Format('%s:%d', [FHost, FPort]), FMaxConnectRetries, FReconnectTimeout)
  else
    n := cli_bad_address;

  if n = cli_bad_address then
    if FReplicationSupport then
      n := CliCheck(cli_create_replication_node(
                                     FNodeID,
                                     Length(FNodeNames),
                                     FNodeNames,
                                     FDatabase,
                                     FDatabasePath,
                                     FInitDatabaseSize,
                                     FOpenAttributes,
                                     FInitIndexSize,
                                     FExtensionQuantum,
                                     FFileSizeLimit), 'cli_create_replication_node failed')
    else
      n := CliCheck(cli_create(FDatabase,
                                     FDatabasePath,
                                     FInitDatabaseSize,
                                     FTransactionCommitDelay,
                                     FOpenAttributes,
                                     FInitIndexSize,
                                     FExtensionQuantum,
                                     FFileSizeLimit), 'cli_create failed')
  else if n < 0 then
    raise EFastDbError.Create(FHandle, 'cli_open failed');

  FHandle := n;
  FThreadID := GetCurrentThreadID;

  if {Assigned(FOnSessionError) and } not FAssignedErrorHandler then
    begin
      FOldErrorHandler := cli_set_error_handler(FHandle, @SessionErrorHandler, Self);
      FAssignedErrorHandler := True;
    end;

  // Turn on tracing if it is assigned
  if Assigned(FOnTraceEvent) then
    SetOnTraceEvent(FOnTraceEvent);

  DoAfterLogon;
end;

//---------------------------------------------------------------------------
procedure TFastDbSession.OpenDatabase(const AServerHost: string='';
  const AServerPort: Integer=0; const AMaxConnectRetries: Integer=0;
  const AReconnectTimeout: Integer=FastDbDefReconnectTimeoutSec);
begin
  if FHandle > FastDbUnilitializedHandle then // already connected
    raise EFastDbError.Create(cli_database_already_open)
  else
    begin
      if AServerHost <> ''                                  then FHost              := AServerHost;
      if AServerPort <> 0                                   then FPort              := AServerPort;
      if AMaxConnectRetries <> 0                            then FMaxConnectRetries := AMaxConnectRetries;
      if AReconnectTimeout  <> FastDbDefReconnectTimeoutSec then FReconnectTimeout  := AReconnectTimeout;

      FReplicationSupport := False;

      InternalOpenDatabase(False);
    end;
end;

//---------------------------------------------------------------------------
procedure TFastDbSession.CreateDatabase(const ADatabaseName: string;
  const AFilePath: string;
  const AInitDatabaseSize: Integer;
  const AOpenAttrs: TCliOpenAttributes;
  const AInitIndexSize: Integer;
  const AExtensionQuantum: Integer;
  const AFileSizeLimit: Integer;
  const ATransactionCommitDelay: Word
  );
begin
  if FHandle > FastDbUnilitializedHandle then // already connected
    raise EFastDbError.Create(cli_database_already_open)
  else
    begin
      if ADatabaseName <> ''                                then FDatabase               := ADatabaseName;
      if AFilePath <> ''                                    then FDatabasePath           := AFilePath;
      if AInitDatabaseSize <> FastDbDefaultInitDatabaseSize then FInitDatabaseSize       := AInitDatabaseSize;
      if ATransactionCommitDelay <> 0                       then FTransactionCommitDelay := ATransactionCommitDelay;
      if AOpenAttrs <> [oaReadWrite]                        then FOpenAttributes         := AOpenAttrs;
      if AInitIndexSize <> FastDbDefaultInitIndexSize       then FInitIndexSize          := AInitIndexSize;
      if AExtensionQuantum <> FastDbDefaultExtensionQuantum then FExtensionQuantum       := AExtensionQuantum;
      if AFileSizeLimit <> 0                                then FFileSizeLimit          := AFileSizeLimit;

      FReplicationSupport := False;

      InternalOpenDatabase(True);
    end;
end;

//---------------------------------------------------------------------------
procedure TFastDbSession.CreateReplicatedDatabase(const ANodeID: Integer;
  const ANodeNames: TStrArray;
  const ADatabaseName, AFilePath: string; const AInitDatabaseSize: Integer;
  const AOpenAttrs: TCliOpenAttributes; const AInitIndexSize,
  AExtensionQuantum, AFileSizeLimit: Integer);
begin
  if FHandle > FastDbUnilitializedHandle then // already connected
    raise EFastDbError.Create(cli_database_already_open)
  else
    begin
      if ADatabaseName <> ''                                then FDatabase         := ADatabaseName;
      if AFilePath <> ''                                    then FDatabasePath     := AFilePath;
      if AInitDatabaseSize <> FastDbDefaultInitDatabaseSize then FInitDatabaseSize := AInitDatabaseSize;
      if AOpenAttrs <> [oaReadWrite]                        then FOpenAttributes   := AOpenAttrs;
      if AInitIndexSize <> FastDbDefaultInitIndexSize       then FInitIndexSize    := AInitIndexSize;
      if AExtensionQuantum <> FastDbDefaultExtensionQuantum then FExtensionQuantum := AExtensionQuantum;
      if AFileSizeLimit <> 0                                then FFileSizeLimit    := AFileSizeLimit;