fastdbcli.pas

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

      result code as described in cli_result_code enum
--------------------------------------------------------------------}
  cli_alter_table: function(session: Integer;
                            const tableName: PChar;
                            nFields: Integer;
                            fields: PCliFieldDescriptor): Integer cdecl;

{********************************************************************
  cli_drop_table
    drop the table
  Parameters:
    session - session descriptor as returned by cli_open
    tableName - name of deleted table
  Returns:
    result code as described in cli_result_code enum
--------------------------------------------------------------------}
  cli_drop_table: function(session: Integer;
                           const tableName: PChar): Integer cdecl;


{********************************************************************
  cli_alter_index
    add or remove column index
  Parameters:
    session - session descriptor as returned by cli_open
    tableName - name of the table
    fieldName - name of field
    newFlags - new flags of the field, if index exists for this field,
               but is not specified in newFlags mask, then it will be
               removed; if index not exists, but is specified in
               newFlags mask, then it will be created.
  Returns:
    result code as described in cli_result_code enum
--------------------------------------------------------------------}
  cli_alter_index: function(session: Integer;
                            const tableName: PChar;
                            const fieldName: PChar;
                            newFlags: Integer): Integer cdecl;

{*********************************************************************
 * cli_free_memory
 *    Free memory allocated by cli_show_tables and cli_describe
 * Parameters:
 *     session - session descriptor returned by cli_open
 *     ptr - pointer to the allocated buffer
 *}
  cli_free_memory: procedure(session: Integer; Memory: Pointer); cdecl;

type
  TCliErrorHandler = procedure(ErrorClassCode: Integer; const Msg: PChar; MsgArg: Integer); cdecl;

{*********************************************************************
 * cli_set_error_handler
 *     Set FastDB erro handler. Handler should be no-return function which perform stack unwind.
 * Parameters:
 *     session   - session descriptor as returned by cli_open
 *     handler   - error handler
 *     UserData  - error handler context: pointer to the user specific data
 *                  which will be passed to thr handler
 * Returns:
 *     previous handler
 *}
function cli_set_error_handler(const session: Integer; NewHandler: TCliErrorHandler; const UserData: Pointer): TCliErrorHandler;

{*********************************************************************
 * cli_get_database_state
 *    Obtain information about current state of the database
 * Parameters:
 *     session - session descriptor returned by cli_open
 *     monitor - pointer to the monitor structure. The folloing fields are set:
 *       n_readers: number of granted shared locks
 *       n_writers: number of granted exclusive locks
 *       n_blocked_reader: number of threads which shared lock request was blocked
 *       n_blocked_writers: number of threads which exclusive lock request was blocked
 *       n_users: number of processes openned the database
 * Returns:
 *     result code as described in cli_result_code enum
 *}
type
  PCliDatabaseMonitor = ^TCliDatabaseMonitor;
  TCliDatabaseMonitor = record
    n_readers          : Integer;
    n_writers          : Integer;
    n_blocked_readers  : Integer;
    n_blocked_writers  : Integer;
    n_users            : Integer;
  end;

var
  cli_get_database_state: function(const session: Integer; Monitor: PCliDatabaseMonitor): Integer; cdecl;

{*********************************************************************
 * cli_set_trace_function
 *    Set trace function which will be used to output FastDB trace messages
 * Parameters:
 *     func - pointer to trace function which receives trace message terminated with new line character
 *}
type
  TCliTraceFunction = procedure(Msg: PChar); cdecl;
var
  cli_set_trace_function: procedure(TraceFunction: TCliTraceFunction); cdecl;


{*********************************************************************
 * cli_prepare_query
 *     Prepare SubSQL query statement.
 * Parameters:
 *     session - session descriptor returned by cli_open
 *     query   - query string with optional parameters. Parameters are specified
 *               as '%T' where T is one or two character code of parameter type using the same notation
 *               as in printf: %d or %i - int, %f - float or double, %ld - int8, %s - string, %p - oid...
 * Returns:
 *     >= 0 - statement descriptor
 *     <  0 - error code as described in cli_result_code enum
 *}
var
  cli_prepare_query : function(session: Integer; query: PChar): Integer; cdecl;

{*********************************************************************
 * cli_execute_query
 *     Execute query previously prepared by cli_prepare_query
 * Parameters:
 *     statement - statement descriptor returned by cli_prepare_query
 *     for_update - not zero if fetched rows will be updated
 *     record_struct - structure to receive selected record fields
 *     ...     - varying list of query parameters
 * Returns:
 *     >= 0 - success, for select statements number of fetched rows is returned
 *     <  0 - error code as described in cli_result_code enum
 *}
var
  cli_execute_query: function(statement: Integer; for_update: Integer; record_struct: Pointer; var_param: array of const): Integer; cdecl;

{*********************************************************************
 * cli_insert_struct
 *     Insert new record represented as C structure
 * Parameters:
 *     session - session descriptor returned by cli_open
 *     table_name - name of the destination table
 *     record_struct - structure specifying value of record fields
 *     oid - pointer to the location to receive OID of created record (may be NULL)
 * Returns:
 *     result code as described in cli_result_code enum
 *}
var
  cli_insert_struct: function(session: Integer; table_name: PChar; record_struct: Pointer; var oid: TCliOid): Integer; cdecl;

implementation

{$IFDEF CLI_DEBUG}

type
  TDebugTrace = class
  private
    FCritSect: TRTLCriticalSection;
  public
    constructor Create;
    destructor Destroy; override;
    procedure DefaultTraceDebugProcedure(Message: string; const BeforeCall: Boolean);
  end;

var
  DebugTrace: TDebugTrace;

  constructor TDebugTrace.Create;
  begin
    InitializeCriticalSection(FCritSect);
  end;

  destructor TDebugTrace.Destroy;
  begin
    DeleteCriticalSection(FCritSect);
    inherited;
  end;

  procedure TDebugTrace.DefaultTraceDebugProcedure(Message: string; const BeforeCall: Boolean);
  begin
    EnterCriticalSection(FCritSect);
    try
      {$IFDEF CODESITE_DEBUG}
      if BeforeCall then CodeSite.SendMsg(Format({$IFDEF USE_DEBUG_THREAD_PREFIX}'[%d]: '+{$ENDIF}'%s ',     [{$IFDEF USE_DEBUG_THREAD_PREFIX}GetCurrentThreadID,{$ENDIF} message]))
                    else CodeSite.SendMsg(Format({$IFDEF USE_DEBUG_THREAD_PREFIX}'[%d]: '+{$ENDIF}'  -> %s', [{$IFDEF USE_DEBUG_THREAD_PREFIX}GetCurrentThreadID,{$ENDIF} message]));
      {$ELSE}
      if BeforeCall then writeln(Format({$IFDEF USE_DEBUG_THREAD_PREFIX}'[%d]: '+{$ENDIF}'%s ',     [{$IFDEF USE_DEBUG_THREAD_PREFIX}GetCurrentThreadID,{$ENDIF} message]))
                    else writeln(Format({$IFDEF USE_DEBUG_THREAD_PREFIX}'[%d]: '+{$ENDIF}'  -> %s', [{$IFDEF USE_DEBUG_THREAD_PREFIX}GetCurrentThreadID,{$ENDIF} message]));
      {$ENDIF}
    finally
      LeaveCriticalSection(FCritSect);
    end;
  end;
{$ENDIF}

function OpenAttrToInt(OpenAttr: TCliOpenAttributes): Integer;
var oa : TCliOpenAttribute;
begin
  Result := 0;
  for oa:=Low(TCliOpenAttribute) to High(TCliOpenAttribute) do
    if oa in OpenAttr then
      Result := Result or cli_open_attributes[oa];
end;

var
  __cli_open: function(const server_url     : PChar;
                       max_connect_attempts : Integer;
                       reconnect_timeout_sec: Integer
                       {$IFDEF GIGABASE}
                       ; UserName, Password: PChar;
                       PooledConnection: Integer
                       {$ENDIF}
                       ): Integer cdecl;

  {$IFDEF GIGABASE}
  __cli_create: function(const databasePath     : PChar;
                         transactionCommitDelay : Word;
                         openAttr               : Integer;
                         PoolSize               : SIZE_T
                         )                      : Integer cdecl;
  {$ELSE}
  __cli_create: function(const databaseName     : PChar;
                         const filePath         : PChar;
                         transactionCommitDelay : Word;
                         openAttr               : Integer;
                         initDatabaseSize       : SIZE_T;
                         extensionQuantum       : SIZE_T;
                         initIndexSize          : SIZE_T;
                         fileSizeLimit          : SIZE_T
                         )                      : Integer cdecl;
  {$ENDIF}

  __cli_create_replication_node:
                function(nodeId                 : Integer;
                         nServers               : Integer;
                         nodeNames              : Pointer;  // array of PChar
                         const databaseName     : PChar;
                         const filePath         : PChar;
                         openAttr               : Integer;
                         initDatabaseSize       : SIZE_T;
                         extensionQuantum       : SIZE_T;
                         initIndexSize          : SIZE_T;
                         fileSizeLimit          : SIZE_T
                         )                      : Integer cdecl;
  __cli_set_error_handler: function(const session: Integer; NewHandler: TCliErrorHandler; const UserData: Pointer): TCliErrorHandler; cdecl;

  __cli_detach: function(session: Integer; detach_mode: Integer): Integer; cdecl;

{ ECliError }
constructor EFastDbError.Create(Code: Integer; Msg: string='');
begin
  ErrorCode := Code;
  if Msg <> '' then Msg := '. ' + Msg;
  inherited Create(CliErrorToStr(Code)+Msg);
end;

constructor EFastDbError.Create(Msg: string);
begin
  ErrorCode := -999;
  inherited Create(Msg);
end;

var
  //SaveExit: pointer;
  DLLHandle: THandle = 0;

  procedure DLLExit;
  begin
    //ExitProc := SaveExit;
    if DLLHandle <> 0 then
      try
        FreeLibrary(DLLHandle);
      finally
        DLLHandle := 0;
      end;
  end {DLLExit};

//---------------------------------------------------------------------------
procedure LoadDLL;
  //+++++++++++++++++
  procedure GetAddr(var ProcAddr: Pointer; ProcName: string; AssertCheck: Boolean=True);
  begin
    ProcAddr := GetProcAddress(DLLHandle,PChar({$IFDEF USE_UNDERSCORE_PREFIX}'_'+{$ENDIF}ProcName));
    if AssertCheck then
      Assert(ProcAddr <> nil, Format('%s procedure not found in "%s"!', [ProcName, libname]));
  end;
  //+++++++++++++++++
begin
  if DLLHandle > 0 then
    Exit
  else begin
    try
      DLLHandle := LoadLibrary(libname);
    except
      on e: Exception do
        begin
          DLLHandle := 0;
          raise EFastDbError.Create(cli_error_loading_library, Format('(%s)'#10'%s', [libname, e.message]));
        end;
    end;

    if DLLHandle <= 0 then
      raise EFastDbError.CreateFmt('Library "%s" not found!', [libname])
    else  // library loaded successfully
      try
        //SaveExit := ExitProc;
        GetAddr(@__cli_open                    , 'cli_open');
        GetAddr(@__cli_create                  , 'cli_create');
        GetAddr(@__cli_create_replication_node , 'cli_create_replication_node', False);
        GetAddr(@cli_close                     , 'cli_close');