📄 fastdbsession.pas
字号:
{-< FastDbSession.pas >---------------------------------------------*
FastDbSession Version 1.0
(c) 2002 Serge Aleynikov (serge@hq.idt.net)
Main Memory Database Management System
Created: 11/11/2002 Serge Aleynikov (serge@hq.idt.net)
Last update:
12/22/2003 Added AlterTable()
6/4/2003 Added SetTraceFunction()
Changed TFastDbSessionEvent to TDbSessionEvent type
Changed TFastDbErrorHandler to TDbErrorHandler type
5/23/2003 Added GetDatabaseState() method
4/7/2002 Fixed a bug related to inverse references
4/2/2003 Added additional debug logging in CreateTable()
2/4/2002 Added TFastDbSession.Threaded method that controls
multithreaded access to FastDb Session
1/22/2003 Added support for cli_attach and cli_detach
12/24/2002 fixed bug in cli_set_error_handler()
11/20/2002 First release created and tested.
-------------------------------------------------------------------*
Database connectivity component
-------------------------------------------------------------------*}
unit FastDbSession;
{$I FastDbConfig.inc}
interface
uses
SysUtils, Classes, StrUtils, Math, FastDbVar, FastDbCLI,
{$IFDEF LINUX}
Types, Libc
{$ENDIF}
{$IFDEF MSWINDOWS}
Windows
{$ENDIF}
;
const
Identifiers = ['a'..'z', 'A'..'Z', '0'..'9', '_', '#', '$', '.', '"'{, '@', #128..#255}];
PARAM_CHAR = '%';
type
TFastDbSession = class;
TDbSessionEvent = procedure(Sender: TFastDbSession) of Object;
TDbTraceEvent = procedure(Sender: TFastDbSession; Msg: string) of Object;
TDbErrorHandler = procedure(Sender: TFastDbSession; const ErrorClassCode: Integer;
const Msg: string; const MsgArg: Integer) of Object;
PContextEntry = ^TContextEntry;
TContextEntry = record
ThreadID : DWord;
RefCount : Integer;
end;
TFastDbSession = class(TComponent)
private
FLastErrorCode : Integer;
FRollbackOnDisconnect : Boolean;
FUsername : string;
FPassword : string;
FDatabase : string;
FDatabasePath : string;
FHost : string;
FPort : Integer;
FMaxConnectRetries : Integer;
FReconnectTimeout : Integer;
FInitDatabaseSize : Integer;
FInitIndexSize : Integer;
FExtensionQuantum : Integer;
FFileSizeLimit : Integer;
FAutoCommit : Boolean;
FOnChange : TDbSessionEvent;
FBeforeLogOn : TDbSessionEvent;
FAfterLogOn : TDbSessionEvent;
FHandle : Integer;
FThreadID : DWord;
FThreaded : Boolean;
FContextList : TThreadList;
FReplicationSupport : Boolean;
FNodeID : Integer;
FNodeNames : TStrArray;
FOpenAttributes : TCliOpenAttributes;
FTransactionCommitDelay: Integer;
FTraceHandlerThunk : TProcedureOfObjectThunk;
FAssignedErrorHandler : Boolean;
FOldErrorHandler : TCliErrorHandler;
FOnSessionError : TDbErrorHandler;
FOnTraceEvent : TDbTraceEvent;
procedure CheckHandle;
procedure SessionTraceHandler(Msg: PChar); cdecl;
procedure SetConnected(const Value: Boolean);
procedure SetLogonUsername(const Value: string);
procedure SetLogonPassword(const Value: string);
procedure SetDatabase(const Value: string);
procedure SetPort(const Value: Integer);
procedure SetAutoCommit(const Value: Boolean);
function GetConnected: Boolean;
procedure SetDatabasePath(const Value: string);
procedure SetHost(const Value: string);
procedure SetTransactionCommitDelay(const Value: Integer);
procedure SetMaxConnectRetries(const Value: Integer);
procedure SetReconnectTimeout(const Value: Integer);
procedure SetInitDatabaseSize(const Value: Integer);
procedure InternalOpenDatabase(const AConnectLocal: Boolean);
procedure SetOnTraceEvent(const Value: TDbTraceEvent);
protected
procedure Loaded; override;
procedure DoBeforeLogon; virtual;
procedure DoAfterLogon; virtual;
function DumpFields(const Fields: TFieldDescriptors; const LeftOffset: Integer=0): string;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure OpenDatabase(
const AServerHost: string='';
const AServerPort: Integer=0;
const AMaxConnectRetries: Integer=0;
const AReconnectTimeout: Integer=FastDbDefReconnectTimeoutSec);
procedure CreateDatabase(
const ADatabaseName: string='';
const AFilePath: string='';
const AInitDatabaseSize: Integer=FastDbDefaultInitDatabaseSize;
const AOpenAttrs: TCliOpenAttributes=[oaReadWrite];
const AInitIndexSize: Integer=FastDbDefaultInitIndexSize;
const AExtensionQuantum: Integer=FastDbDefaultExtensionQuantum;
const AFileSizeLimit: Integer=0;
const ATransactionCommitDelay: Word=0);
procedure CreateReplicatedDatabase(
const ANodeID: Integer;
const ANodeNames: TStrArray;
const ADatabaseName: string='';
const AFilePath: string='';
const AInitDatabaseSize: Integer=FastDbDefaultInitDatabaseSize;
const AOpenAttrs: TCliOpenAttributes=[oaReadWrite];
const AInitIndexSize: Integer=FastDbDefaultInitIndexSize;
const AExtensionQuantum: Integer=FastDbDefaultExtensionQuantum;
const AFileSizeLimit: Integer=0);
procedure CloseDatabase(const RaiseError: Boolean=True);
procedure Commit(const Flush: Boolean);
procedure Rollback;
procedure ListTables(List: TStringList);
function TableExists(const Table: string): Boolean;
function DescribeTable(const Table: string; var Fields: TFieldDescriptors; RaiseError: Boolean=True): Integer; overload; // returns field count
function DescribeTable(const Table: string; Fields: TFastDbFields; RaiseError: Boolean=True) : Integer; overload; // returns field count
function CreateTable(const Table: string; var Fields: TFieldDescriptors; RefCheck: Boolean=False) : Boolean; overload;
function CreateTable(const Table: string; const Fields: TFastDbFields; RefCheck: Boolean=False) : Boolean; overload;
procedure DropTable(Table: string);
procedure AlterIndex(const Table, Field: string; const NewFlags: TIndexTypes=[]);
function AlterTable(const Table: string; var Fields: TFieldDescriptors) : Boolean; overload;
function AlterTable(const Table: string; const Fields: TFastDbFields) : Boolean; overload;
function ExtractTableDDL(const TableName: string): string;
procedure SaveDDLtoFile(FileName: string);
function GetDatabaseState: TCliDatabaseMonitor; // Obtain database status record
property Handle: Integer read FHandle;
property ThreadID: DWord read FThreadID; // thread which opened the database
function CliCheck(const Code: Integer; Msg: string=''; const RaiseError: Boolean=True): Integer;
function ErrorMessage(ErrorCode: Integer): string;
function ServerVersion: string;
// Threading support
procedure Attach;
procedure Detach(ADetachMode: TDetachModes=[dtPreCommit, dtDestroyContext]);
{$IFDEF GIGABASE}
procedure ClearConnectionPool; // Close all released connection in connection pool
{$ENDIF}
// Replication support properties
property ReplicationSupport: Boolean read FReplicationSupport;
property NodeID: Integer read FNodeID;
published
property OnChange : TDbSessionEvent read FOnChange write FOnChange;
property OnSessionError: TDbErrorHandler read FOnSessionError write FOnSessionError;
property OnTraceEvent: TDbTraceEvent read FOnTraceEvent write SetOnTraceEvent;
property BeforeLogOn: TDbSessionEvent read FBeforeLogOn write FBeforeLogOn;
property AfterLogOn : TDbSessionEvent read FAfterLogOn write FAfterLogOn;
property LogonUsername: string read FUsername write SetLogonUsername;
property LogonPassword: string read FPassword write SetLogonPassword;
property Database: string read FDatabase write SetDatabase;
property Host: string read FHost write SetHost;
property Port: Integer read FPort write SetPort;
property DatabasePath: string read FDatabasePath write SetDatabasePath;
property MaxConnectRetries: Integer read FMaxConnectRetries write SetMaxConnectRetries;
property ReconnectTimeout: Integer read FReconnectTimeout write SetReconnectTimeout;
property InitDatabaseSize: Integer read FInitDatabaseSize write SetInitDatabaseSize;
property InitIndexSize: Integer read FInitIndexSize write FInitIndexSize;
property ExtensionQuantum: Integer read FExtensionQuantum write FExtensionQuantum;
property FileSizeLimit: Integer read FFileSizeLimit write FFileSizeLimit;
property TransactionCommitDelay: Integer read FTransactionCommitDelay write SetTransactionCommitDelay;
property OpenAttributes: TCliOpenAttributes read FOpenAttributes write FOpenAttributes;
property Connected: Boolean read GetConnected write SetConnected;
property RollbackOnDisconnect: Boolean read FRollbackOnDisconnect write FRollbackOnDisconnect;
property AutoCommit: Boolean read FAutoCommit write SetAutoCommit Stored False;
property LastErrorCode: Integer read FLastErrorCode write FLastErrorCode;
property Threaded: Boolean read FThreaded write FThreaded;
end;
ENotImplemented = class(Exception);
procedure FindVariables(const SQL: string; IncludeDuplicates: Boolean; var Vars: TStringList);
function RemoveSQLComment(const ASQL: string): string;
procedure SplitSelect(Select: string;
var BeforeWhere, WhereClause, AfterWhere, WhereWord: string);
function AppName: string;
implementation
//---------------------------------------------------------------------------
function AppName: string;
begin
Result := LowerCase(ExtractFileName(ParamStr(0)));
end;
const
EOL = {$IFDEF MSWINDOWS}#13#10{$ENDIF}{$IFDEF LINUX}#10{$ENDIF};
SMultiThreadedAttach = 'In a multi-threaded application %s() method must be called from a thread different from the one that created the FastDB session!';
var
CNullBuf : array[0..0] of Char = (#0);
//---------------------------------------------------------------------------
procedure FindVariables(const SQL: string; IncludeDuplicates: Boolean; var Vars: TStringList);
var s: string;
i: Integer;
Mode: char;
VarName, EndC: string;
VarPos: Integer;
begin
s := SQL + EOL;
Mode := 'S';
EndC := '';
VarPos := 0;
for i := 1 to Length(s) do
begin
case Mode of
'S' : begin
if s[i] = PARAM_CHAR then
begin
Mode := 'V';
VarName := '';
VarPos := i;
end;
if (S[i] = '''') then
begin
Mode := 'Q';
EndC := '''';
end;
if (S[i] = '/') and (S[i + 1] = '*') then
begin
Mode := 'C';
EndC := '*/';
end;
if (S[i] = '-') and (S[i + 1] ='-') then
begin
Mode := 'C';
EndC := EOL;
end;
end;
'V' : begin
if not (s[i] in ['a'..'z', 'A'..'Z', '0'..'9', '_', '#', '$', #128..#255]) then
begin
VarName := LowerCase(VarName);
if (VarName <> '') and (IncludeDuplicates or (Vars.IndexOf(VarName) < 0)) then
Vars.AddObject(VarName, TObject(VarPos));
Mode := 'S';
end else
VarName := VarName + s[i];
end;
'C' : if (S[i] = EndC[1]) and (S[i + 1] = EndC[2]) then mode := 'S';
'Q' : if (S[i] = EndC[1]) then mode := 'S';
end;
end;
end;
// Remove SQL Comment from a string
function RemoveSQLComment(const ASQL: string): string;
var i, l: Integer;
c1, c2, Mode: char;
begin
Result := '';
l := Length(ASQL);
i := 1;
Mode := 'N';
while i <= l do begin
c1 := ASQL[i];
if c1 = '''' then
begin
if Mode = 'Q' then
Mode := 'N'
else if Mode = 'N' then
Mode := 'Q';
end;
if Mode = 'Q' then Result := Result + c1;
if i < l then c2 := ASQL[i + 1] else c2 := #0;
if Mode = 'N' then
begin
if (c1 = '/') and (c2 = '*') then Mode := '*';
if (c1 = '-') and (c2 = '-') then Mode := '-';
if Mode = 'N' then Result := Result + c1;
end;
if ((Mode = '*') and (c1 = '*') and (c2 = '/')) or
((Mode = '-') and (c1 in [#13, #10])) then
begin
Mode := 'N';
Inc(i);
end;
Inc(i);
end;
Result := Trim(Result);
end;
function RemoveParenthesisAndQuotes(const ASQL: string): string;
var i, pLevel: Integer;
qMode: Boolean;
begin
Result := ASQL;
// Discard text between parnthesis and quotes
pLevel := 0;
qMode := False;
for i := 1 to Length(Result) do
begin
if Result[i] = '(' then Inc(pLevel);
if Result[i] = ')' then Dec(pLevel);
if Result[i] = '''' then qMode := not qMode;
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -