paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-16 19:39:20 +02:00
Code Issues Packages Projects Releases Wiki Activity

* SqlScript committed

Browse Source 
git-svn-id: trunk@11366 -
This commit is contained in:
michael 2008-07-11 14:16:39 +00:00
parent 7edc274432
commit cc0c2d6467
6 changed files with 1581 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -1159,6 +1159,7 @@ packages/fcl-db/src/base/dsparams.inc svneol=native#text/plain
packages/fcl-db/src/base/fields.inc svneol=native#text/plain
packages/fcl-db/src/base/fpmake.inc svneol=native#text/plain
packages/fcl-db/src/base/fpmake.pp svneol=native#text/plain
packages/fcl-db/src/base/sqlscript.pp svneol=native#text/plain
packages/fcl-db/src/codegen/Makefile svneol=native#text/plain
packages/fcl-db/src/codegen/Makefile.fpc svneol=native#text/plain
packages/fcl-db/src/codegen/buildddcg.lpi svneol=native#text/plain
@ -1327,6 +1328,7 @@ packages/fcl-db/tests/testbasics.pas svneol=native#text/plain
packages/fcl-db/tests/testdatasources.pas svneol=native#text/plain
packages/fcl-db/tests/testdbbasics.pas -text
packages/fcl-db/tests/testfieldtypes.pas svneol=native#text/plain
packages/fcl-db/tests/testsqlscript.pas svneol=native#text/plain
packages/fcl-db/tests/toolsunit.pas -text
packages/fcl-fpcunit/Makefile svneol=native#text/plain
packages/fcl-fpcunit/Makefile.fpc svneol=native#text/plain

118
packages/fcl-db/src/base/Makefile
View File

@ -1,5 +1,5 @@
#
# Don't edit, this file is generated by FPCMake Version 2.0.0 [2008/06/15]
# Don't edit, this file is generated by FPCMake Version 2.0.0 [2008/06/23]
#
default: all
MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded avr-embedded armeb-linux armeb-embedded
@ -261,178 +261,178 @@ PACKAGESDIR:=$(wildcard $(FPCDIR) $(FPCDIR)/packages $(FPCDIR)/packages/base $(F
override PACKAGE_NAME=fcl-db
PACKAGEDIR_MAIN:=$(firstword $(subst /Makefile.fpc,,$(strip $(wildcard $(addsuffix /fcl-db/Makefile.fpc,$(PACKAGESDIR))))))
ifeq ($(FULL_TARGET),i386-linux)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),i386-go32v2)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),i386-win32)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),i386-os2)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),i386-freebsd)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),i386-beos)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),i386-haiku)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),i386-netbsd)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),i386-solaris)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),i386-qnx)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),i386-netware)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),i386-openbsd)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),i386-wdosx)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),i386-darwin)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),i386-emx)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),i386-watcom)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),i386-netwlibc)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),i386-wince)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),i386-embedded)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),i386-symbian)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),m68k-linux)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),m68k-freebsd)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),m68k-netbsd)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),m68k-amiga)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),m68k-atari)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),m68k-openbsd)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),m68k-palmos)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),m68k-embedded)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),powerpc-linux)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),powerpc-netbsd)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),powerpc-amiga)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),powerpc-macos)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),powerpc-darwin)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),powerpc-morphos)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),powerpc-embedded)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),sparc-linux)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),sparc-netbsd)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),sparc-solaris)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),sparc-embedded)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),x86_64-linux)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),x86_64-freebsd)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),x86_64-darwin)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),x86_64-win64)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),x86_64-embedded)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),arm-linux)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),arm-palmos)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),arm-darwin)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),arm-wince)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),arm-gba)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),arm-nds)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),arm-embedded)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),arm-symbian)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),powerpc64-linux)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),powerpc64-darwin)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),powerpc64-embedded)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),avr-embedded)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),armeb-linux)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),armeb-embedded)
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
endif
ifeq ($(FULL_TARGET),i386-linux)
override TARGET_RSTS+=dbwhtml dbconst dbcoll

2
packages/fcl-db/src/base/Makefile.fpc
View File

@ -6,7 +6,7 @@
main=fcl-db
[target]
units=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
units=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
rsts=dbwhtml dbconst dbcoll
[require]

662
packages/fcl-db/src/base/sqlscript.pp Normal file
View File

@ -0,0 +1,662 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2008 by the Free Pascal development team
Abstract SQL scripting engine.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
unit sqlscript;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
type
TSQLScriptStatementEvent = procedure(Sender: TObject; Statement: TStrings; var StopExecution: Boolean) of object;
TSQLScriptDirectiveEvent = procedure(Sender: TObject; Directive, Argument: AnsiString; var StopExecution: Boolean) of object;
TSQLScriptExceptionEvent = procedure(Sender: TObject; Statement: TStrings; TheException: Exception; var Continue: boolean) of object;
TSQLSkipMode = (smNone, smIfBranch, smElseBranch, smAll);
{ TCustomSQLScript }
TCustomSQLScript = class(TComponent)
private
FLine: Integer;
FCol: Integer;
FDefines: TStrings;
FOnException: TSQLScriptExceptionEvent;
FSkipMode: TSQLSkipMode;
FIsSkipping: Boolean;
FSkipStackIndex: Integer;
FSkipModeStack: array[0..255] of TSQLSkipMode;
FIsSkippingStack: array[0..255] of Boolean;
FAborted: Boolean;
FUseSetTerm, FUseDefines, FUseCommit,
FCommentsInSQL: Boolean;
FTerminator: AnsiString;
FSQL: TStrings;
FCurrentStatement: TStrings;
FDirectives: TStrings;
FEmitLine: Boolean;
procedure SetDefines(const Value: TStrings);
function FindNextSeparator(sep: array of string): AnsiString;
procedure AddToStatement(value: AnsiString; ForceNewLine : boolean);
procedure SetDirectives(value: TStrings);
procedure SetSQL(value: TStrings);
procedure SQLChange(Sender: TObject);
function GetLine: Integer;
Function ProcessConditional(Directive : String; Param : String) : Boolean; virtual;
function NextStatement: AnsiString;
procedure ProcessStatement;
function Available: Boolean;
procedure InternalStatement (Statement: TStrings; var StopExecution: Boolean);
procedure InternalDirective (Directive, Argument: String; var StopExecution: Boolean);
procedure InternalCommit;
protected
procedure DefaultDirectives; virtual;
procedure ExecuteStatement (Statement: TStrings; var StopExecution: Boolean); virtual; abstract;
procedure ExecuteDirective (Directive, Argument: String; var StopExecution: Boolean); virtual; abstract;
procedure ExecuteCommit; virtual; abstract;
public
constructor Create (AnOwner: TComponent); override;
destructor Destroy; override;
procedure Execute; virtual;
protected
property Aborted: Boolean read FAborted;
property Line: Integer read GetLine;
property CommentsInSQL: Boolean read FCommentsInSQL write FCommentsInSQL;
property UseSetTerm: Boolean read FUseSetTerm write FUseSetTerm;
property UseCommit: Boolean read FUseCommit write FUseCommit;
property UseDefines: Boolean read FUseDefines write FUseDefines;
property Defines : TStrings Read FDefines Write SetDefines;
property Directives: TStrings read FDirectives write SetDirectives;
property Script: TStrings read FSQL write SetSQL; // script to execute
property Terminator: AnsiString read FTerminator write FTerminator;
property OnException : TSQLScriptExceptionEvent read FOnException write FOnException;
end;
{ TEventSQLScript }
TEventSQLScript = class (TCustomSQLScript)
private
FAfterExec: TNotifyEvent;
FBeforeExec: TNotifyEvent;
FOnCommit: TNotifyEvent;
FOnSQLStatement: TSQLScriptStatementEvent;
FOnDirective: TSQLScriptDirectiveEvent;
protected
procedure ExecuteStatement (SQLStatement: TStrings; var StopExecution: Boolean); override;
procedure ExecuteDirective (Directive, Argument: String; var StopExecution: Boolean); override;
procedure ExecuteCommit; override;
public
procedure Execute; override;
property Aborted;
property Line;
published
property Directives;
property Defines;
property Script;
property Terminator;
property CommentsinSQL;
property UseSetTerm;
property UseCommit;
property UseDefines;
property OnException;
property OnSQLStatement: TSQLScriptStatementEvent read FOnSQLStatement write FOnSQLStatement;
property OnDirective: TSQLScriptDirectiveEvent read FOnDirective write FOnDirective;
property OnCommit: TNotifyEvent read FOnCommit write FOnCommit;
property BeforeExecute : TNotifyEvent read FBeforeExec write FBeforeExec;
property AfterExecute : TNotifyEvent read FAfterExec write FAfterExec;
end;
ESQLScript = Class(Exception);
implementation
Resourcestring
SErrIfXXXNestingLimitReached = '#IFDEF nesting limit reached';
SErrInvalidEndif = '#ENDIF without #IFDEF';
SErrInvalidElse = '#ELSE without #IFDEF';
{ ---------------------------------------------------------------------
Auxiliary Functions
---------------------------------------------------------------------}
function StartsWith(S1, S2: AnsiString): Boolean;
var
L1,L2 : Integer;
begin
Result:=False;
L1:=Length(S1);
L2:=Length(S2);
if (L2=0) or (L1<L2) then
Exit;
Result:=(AnsiCompareStr(Copy(s1,1,L2),S2)=0);
Result := Result and ((L2 = L1) or (s1[L2+1] = ' '));
end;
function GetFirstSeparator(S: AnsiString; Sep: array of string): AnsiString;
var
i, C, M: Integer;
begin
M:=length(S) + 1;
Result:='';
for i:=0 to high(Sep) do
begin
C:=Pos(Sep[i],S);
if (C<>0) and (C<M) then
begin
M:=C;
Result:=Sep[i];
end;
end;
end;
Function ConvertWhiteSpace(S : String) : String;
begin
Result:=StringReplace(S,#13,' ',[rfReplaceAll]);
Result:=StringReplace(Result,#10,' ',[rfReplaceAll]);
Result:=Trim(Result);
end;
function DeleteComments(SQL_Text: AnsiString; ATerminator: AnsiString = ';'): AnsiString;
begin
With TCustomSQLScript.Create (Nil) do
try
Terminator:=ATerminator;
Script.Add(SQL_Text);
Script.Add(Terminator);
CommentsInSQL:=False;
Result:=ConvertWhiteSpace(NextStatement);
finally
Free;
end;
end;
{ ---------------------------------------------------------------------
TSQLScript
---------------------------------------------------------------------}
procedure TCustomSQLScript.SQLChange(Sender: TObject);
begin
FLine:=1;
FCol:=1;
end;
procedure TCustomSQLScript.SetDirectives(value: TStrings);
var
i : Integer;
S : AnsiString;
begin
FDirectives.Clear();
if (Value<>Nil) then
begin
for i:=0 to value.Count - 1 do
begin
S:=UpperCase(ConvertWhiteSpace(value[i]));
if Length(S)>0 then
FDirectives.Add(S);
end;
end;
DefaultDirectives;
end;
procedure TCustomSQLScript.SetSQL(value: TStrings);
begin
FSQL.Assign(value);
FLine:=1;
FCol:=1;
end;
function TCustomSQLScript.GetLine: Integer;
begin
Result:=FLine - 1;
end;
procedure TCustomSQLScript.AddToStatement(value: AnsiString; ForceNewLine : Boolean);
begin
With FCurrentStatement do
if ForceNewLine or (Count=0) then
Add(value)
else
Strings[Count-1]:=Strings[Count-1] + value;
end;
function TCustomSQLScript.FindNextSeparator(Sep: array of string): AnsiString;
var
S: AnsiString;
begin
Result:='';
while (FLine<=FSQL.Count) do
begin
S:=FSQL.Strings[FLine-1];
if (FCol>1) then
begin
S:=Copy(S,FCol,length(S));
end;
Result:=GetFirstSeparator(S,Sep);
if (Result='') then
begin
if FEmitLine then
AddToStatement(S,(FCol=1));
FCol:=1;
FLine:=FLine+1;
end
else
begin
if FEmitLine then
AddToStatement(Copy(S,1,Pos(Result,S)-1),(FCol=1));
FCol:=(FCol-1)+Pos(Result,S);
break;
end;
end;
end;
function TCustomSQLScript.Available: Boolean;
var
SCol,
SLine: Integer;
begin
SCol:=FCol;
SLine:=FLine;
try
Result:=Length(Trim(NextStatement()))>0;
Finally
FCol:=SCol;
FLine:=SLine;
end;
end;
procedure TCustomSQLScript.InternalStatement(Statement: TStrings; var StopExecution: Boolean);
var
cont : boolean;
begin
try
ExecuteStatement(Statement, StopExecution);
except
on E : Exception do
begin
cont := false;
if assigned (FOnException) then
FOnException (self, Statement, E, cont);
if not cont then
Raise;
end;
end;
end;
procedure TCustomSQLScript.InternalDirective(Directive, Argument: String; var StopExecution: Boolean);
var
cont : boolean;
l : TStrings;
begin
try
ExecuteDirective(Directive, Argument, StopExecution);
except
on E : Exception do
begin
cont := false;
if assigned (FOnException) then
begin
l := TStringlist.Create;
try
L.Add(Directive);
if Argument <> '' then
L.Add(Argument);
FOnException (self, l, E, cont);
finally
L.Free;
end;
end;
if not cont then
Raise;
end;
end;
end;
procedure TCustomSQLScript.InternalCommit;
var
cont : boolean;
l : TStrings;
begin
try
ExecuteCommit;
except
on E : Exception do
begin
cont := false;
if assigned (FOnException) then
begin
l := TStringlist.Create;
try
L.Add('COMMIT');
FOnException (self, l, E, cont);
finally
L.Free;
end;
end;
if not cont then
Raise;
end;
end;
end;
procedure TCustomSQLScript.ProcessStatement;
Var
S,
Directive : String;
I : longint;
begin
if (FCurrentStatement.Count=0) then
Exit;
S:=DeleteComments(FCurrentStatement.Text, Terminator);
I:=0;
Directive:='';
While (i<FDirectives.Count) and (Directive='') do
begin
If StartsWith(AnsiUpperCase(S), FDirectives[i]) Then
Directive:=FDirectives[i];
Inc(I);
end;
If (Directive<>'') then
begin
S:=Trim(Copy(S,Length(Directive)+1,length(S)));
If (Directive[1]='#') then
begin
if not FUseDefines or not ProcessConditional(Directive,S) then
if Not FIsSkipping then
InternalDirective (Directive, S, FAborted);
end
else If Not FIsSkipping then
begin
if FUseCommit and (Directive = 'COMMIT') then
InternalCommit
else if FUseSetTerm and (Directive = 'SET TERM') then
FTerminator:=S
else
InternalDirective (Directive,S,FAborted)
end
end
else
if (not FIsSkipping) then
InternalStatement(FCurrentStatement,FAborted);
end;
procedure TCustomSQLScript.Execute;
begin
FSkipMode:=smNone;
FIsSkipping:=False;
FSkipStackIndex:=0;
Faborted:=False;
DefaultDirectives;
while not FAborted and Available() do
begin
NextStatement();
ProcessStatement;
end;
end;
function TCustomSQLScript.NextStatement: AnsiString;
var
pnt: AnsiString;
terminator_found: Boolean;
begin
terminator_found:=False;
FCurrentStatement.Clear;
while FLine <= FSQL.Count do
begin
pnt:=FindNextSeparator([FTerminator, '/*', '"', '''']);
if (pnt=FTerminator) then
begin
FCol:=FCol + length(pnt);
terminator_found:=True;
break;
end
else if pnt = '/*' then
begin
if FCommentsInSQL then
AddToStatement(pnt,false)
else
FEmitLine:=False;
FCol:=FCol + length(pnt);
pnt:=FindNextSeparator(['*/']);
if FCommentsInSQL then
AddToStatement(pnt,false)
else
FEmitLine:=True;
FCol:=FCol + length(pnt);
end
else if pnt = '"' then
begin
AddToStatement(pnt,false);
FCol:=FCol + length(pnt);
pnt:=FindNextSeparator(['"']);
AddToStatement(pnt,false);
FCol:=FCol + length(pnt);
end
else if pnt = '''' then
begin
AddToStatement(pnt,False);
FCol:=FCol + length(pnt);
pnt:=FindNextSeparator(['''']);
AddToStatement(pnt,false);
FCol:=FCol + length(pnt);
end;
end;
if not terminator_found then
FCurrentStatement.Clear();
while (FCurrentStatement.Count > 0) and (trim(FCurrentStatement.Strings[0]) = '') do
FCurrentStatement.Delete(0);
Result:=FCurrentStatement.Text;
end;
Constructor TCustomSQLScript.Create (AnOwner: TComponent);
Var
L : TStringList;
begin
inherited;
L:=TStringList.Create;
With L do
begin
Sorted:=True;
Duplicates:=dupIgnore;
end;
FDefines:=L;
FCommentsInSQL:=True;
FTerminator:=';';
L:=TStringList.Create();
L.OnChange:=@SQLChange;
FSQL:=L;
FDirectives:=TStringList.Create();
FCurrentStatement:=TStringList.Create();
FLine:=1;
FCol:=1;
FEmitLine:=True;
FUseCommit := true;
FUseDefines := True;
FUseSetTerm := True;
DefaultDirectives;
end;
destructor TCustomSQLScript.Destroy;
begin
FreeAndNil(FCurrentStatement);
FreeAndNil(FSQL);
FreeAndNil(FDirectives);
FreeAndNil(FDefines);
inherited Destroy;
end;
procedure TCustomSQLScript.SetDefines(const Value: TStrings);
begin
FDefines.Assign(Value);
end;
procedure TCustomSQLScript.DefaultDirectives;
begin
With FDirectives do
begin
if FUseSetTerm then
Add('SET TERM');
if FUseCommit then
Add('COMMIT');
if FUseDefines then
begin
Add('#IFDEF');
Add('#IFNDEF');
Add('#ELSE');
Add('#ENDIF');
Add('#DEFINE');
Add('#UNDEF');
Add('#UNDEFINE');
end;
end;
end;
Function TCustomSQLScript.ProcessConditional(Directive: String; Param : String) : Boolean;
Procedure PushSkipMode;
begin
if FSkipStackIndex=High(FSkipModeStack) then
Raise ESQLScript.Create(SErrIfXXXNestingLimitReached);
FSkipModeStack[FSkipStackIndex]:=FSkipMode;
FIsSkippingStack[FSkipStackIndex]:=FIsSkipping;
Inc(FSkipStackIndex);
end;
Procedure PopSkipMode;
begin
if FSkipStackIndex = 0 then
Raise ESQLScript.Create(SErrInvalidEndif);
Dec(FSkipStackIndex);
FSkipMode := FSkipModeStack[FSkipStackIndex];
FIsSkipping := FIsSkippingStack[FSkipStackIndex];
end;
Var
Index : Integer;
begin
Result:=True;
if (Directive='#DEFINE') then
begin
if not FIsSkipping then
FDefines.Add(Param);
end
else if (Directive='#UNDEF') or (Directive='#UNDEFINE') then
begin
if not FIsSkipping then
begin
Index:=FDefines.IndexOf(Param);
if (Index>=0) then
FDefines.Delete(Index);
end;
end
else if (Directive='#IFDEF') or (Directive='#IFNDEF') then
begin
PushSkipMode;
if FIsSkipping then
begin
FSkipMode:=smAll;
FIsSkipping:=true;
end
else
begin
Index:=FDefines.IndexOf(Param);
if ((Directive='#IFDEF') and (Index<0)) or
((Directive='#IFNDEF') and (Index>=0)) then
begin
FSkipMode:=smIfBranch;
FIsSkipping:=true;
end
else
FSkipMode := smElseBranch;
end;
end
else if (Directive='#ELSE') then
begin
if (FSkipStackIndex=0) then
Raise ESQLScript.Create(SErrInvalidElse);
if (FSkipMode=smIfBranch) then
FIsSkipping:=false
else if (FSkipMode=smElseBranch) then
FIsSkipping:=true;
end
else if (Directive='#ENDIF') then
PopSkipMode
else
Result:=False;
end;
{ TEventSQLScript }
procedure TEventSQLScript.ExecuteStatement(SQLStatement: TStrings;
var StopExecution: Boolean);
begin
if assigned (FOnSQLStatement) then
FOnSQLStatement (self, SQLStatement, StopExecution);
end;
procedure TEventSQLScript.ExecuteDirective(Directive, Argument: String;
var StopExecution: Boolean);
begin
if assigned (FOnDirective) then
FOnDirective (Self, Directive, Argument, StopExecution);
end;
procedure TEventSQLScript.ExecuteCommit;
begin
if assigned (FOnCommit) then
FOnCommit (Self);
end;
procedure TEventSQLScript.Execute;
begin
if assigned (FBeforeExec) then
FBeforeExec (Self);
inherited Execute;
if assigned (FAfterExec) then
FAfterExec (Self);
end;
end.

86
packages/fcl-db/src/sqldb/sqldb.pp
View File

@ -20,7 +20,7 @@ unit sqldb;
interface
uses SysUtils, Classes, DB, bufdataset;
uses SysUtils, Classes, DB, bufdataset, sqlscript;
type TSchemaType = (stNoSchema, stTables, stSysTables, stProcedures, stColumns, stProcedureParams, stIndexes, stPackages);
TConnOption = (sqSupportParams,sqEscapeSlash,sqEscapeRepeat,sqQuoteFieldnames);
@ -359,24 +359,37 @@ type
{ TSQLScript }
TSQLScript = class (Tcomponent)
TSQLScript = class (TCustomSQLscript)
private
FScript : TStrings;
FOnDirective: TSQLScriptDirectiveEvent;
FQuery : TCustomSQLQuery;
FDatabase : TDatabase;
FTransaction : TDBTransaction;
protected
procedure SetScript(const AValue: TStrings);
procedure ExecuteStatement (SQLStatement: TStrings; var StopExecution: Boolean); override;
procedure ExecuteDirective (Directive, Argument: String; var StopExecution: Boolean); override;
procedure ExecuteCommit; override;
Procedure SetDatabase (Value : TDatabase); virtual;
Procedure SetTransaction(Value : TDBTransaction); virtual;
Procedure CheckDatabase;
public
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
procedure Execute; override;
procedure ExecuteScript;
Property Script : TStrings Read FScript Write SetScript;
published
Property DataBase : TDatabase Read FDatabase Write SetDatabase;
Property Transaction : TDBTransaction Read FTransaction Write SetTransaction;
property OnDirective: TSQLScriptDirectiveEvent read FOnDirective write FOnDirective;
property Directives;
property Defines;
property Script;
property Terminator;
property CommentsinSQL;
property UseSetTerm;
property UseCommit;
property UseDefines;
property OnException;
end;
{ TSQLConnector }
@ -1536,9 +1549,29 @@ end;
{ TSQLScript }
procedure TSQLScript.SetScript(const AValue: TStrings);
procedure TSQLScript.ExecuteStatement(SQLStatement: TStrings;
var StopExecution: Boolean);
begin
FScript.assign(AValue);
fquery.SQL.assign(SQLStatement);
fquery.ExecSQL;
end;
procedure TSQLScript.ExecuteDirective(Directive, Argument: String;
var StopExecution: Boolean);
begin
if assigned (FOnDirective) then
FOnDirective (Self, Directive, Argument, StopExecution);
end;
procedure TSQLScript.ExecuteCommit;
begin
if FTransaction is TSQLTransaction then
TSQLTransaction(FTransaction).CommitRetaining
else
begin
FTransaction.Active := false;
FTransaction.Active := true;
end;
end;
procedure TSQLScript.SetDatabase(Value: TDatabase);
@ -1560,49 +1593,28 @@ end;
constructor TSQLScript.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FScript := TStringList.Create;
FQuery := TCustomSQLQuery.Create(nil);
FQuery := TCustomSQLQuery.Create(nil);
end;
destructor TSQLScript.Destroy;
begin
FScript.Free;
FQuery.Free;
inherited Destroy;
end;
procedure TSQLScript.ExecuteScript;
var BufStr : String;
pBufStatStart,
pBufPos : PChar;
Statement : String;
procedure TSQLScript.Execute;
begin
FQuery.DataBase := FDatabase;
FQuery.Transaction := FTransaction;
BufStr := FScript.Text;
pBufPos := @BufStr[1];
repeat
pBufStatStart := pBufPos;
repeat
inc(pBufPos);
until (pBufPos^ = ';') or (pBufPos^ = #0);
SetLength(statement,pbufpos-pBufStatStart);
move(pBufStatStart^,Statement[1],pbufpos-pBufStatStart);
if trim(statement) <> '' then
begin
fquery.SQL.Text := Statement;
fquery.ExecSQL;
inc(pBufPos);
end;
until pBufPos^ = #0;
inherited Execute;
end;
procedure TSQLScript.ExecuteScript;
begin
Execute;
end;
{ Connection definitions }
Var

808
packages/fcl-db/tests/testsqlscript.pas Normal file
View File

@ -0,0 +1,808 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2008 by the Free Pascal development team
FPCUnit SQLScript test.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
unit testcsqlscript;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, testregistry, sqlscript, fpcunit;
type
{ TMyScript }
TMyScript = class (TCustomSQLScript)
private
FExcept: string;
FStatements : TStrings;
FDirectives : TStrings;
FCommits : integer;
protected
procedure ExecuteStatement (SQLStatement: TStrings; var StopExecution: Boolean); override;
procedure ExecuteDirective (Directive, Argument: String; var StopExecution: Boolean); override;
procedure ExecuteCommit; override;
procedure DefaultDirectives; override;
public
constructor create (AnOwner: TComponent); override;
destructor destroy; override;
function StatementsExecuted : string;
function DirectivesExecuted : string;
property DoException : string read FExcept write FExcept;
property Aborted;
property Line;
property Directives;
property Defines;
property Script;
property Terminator;
property CommentsinSQL;
property UseSetTerm;
property UseCommit;
property UseDefines;
property OnException;
end;
{ TTestSQLScript }
TTestSQLScript = class (TTestCase)
private
Script : TMyScript;
exceptionstatement,
exceptionmessage : string;
UseContinue : boolean;
procedure Add (s :string);
procedure AssertStatDir (Statements, Directives : string);
procedure DoExecution;
procedure ExceptionHandler(Sender: TObject; Statement: TStrings; TheException: Exception; var Continue: boolean);
procedure TestDirectiveOnException3;
protected
procedure SetUp; override;
procedure TearDown; override;
published
procedure TestCreateDefaults;
procedure TestTerminator;
procedure TestSetTerm;
procedure TestUseSetTerm;
procedure TestComments;
procedure TestUseComments;
procedure TestCommit;
procedure TestUseCommit;
procedure TestDefine;
procedure TestUndefine;
procedure TestUndef;
procedure TestIfdef1;
procedure TestIfdef2;
procedure TestIfndef1;
procedure TestIfndef2;
procedure TestElse1;
procedure TestElse2;
procedure TestEndif1;
procedure TestEndif2;
procedure TestUseDefines;
procedure TestTermInComment;
procedure TestTermInQuotes1;
procedure TestTermInQuotes2;
procedure TestCommentInComment;
procedure TestCommentInQuotes1;
procedure TestCommentInQuotes2;
procedure TestQuote1InComment;
procedure TestQuote2InComment;
procedure TestQuoteInQuotes1;
procedure TestQuoteInQuotes2;
procedure TestStatementStop;
procedure TestDirectiveStop;
procedure TestStatementExeception;
procedure TestDirectiveException;
procedure TestCommitException;
procedure TestStatementOnExeception1;
procedure TestStatementOnExeception2;
procedure TestDirectiveOnException1;
procedure TestDirectiveOnException2;
procedure TestCommitOnException1;
procedure TestCommitOnException2;
end;
{ TTestEventSQLScript }
TTestEventSQLScript = class (TTestCase)
private
Script : TEventSQLScript;
StopToSend : boolean;
Received : string;
notifycount : integer;
LastSender : TObject;
procedure Notify (Sender : TObject);
procedure NotifyStatement (Sender: TObject; SQL_Statement: TStrings; var StopExecution: Boolean);
procedure NotifyDirective (Sender: TObject; Directive, Argument: AnsiString; var StopExecution: Boolean);
protected
procedure SetUp; override;
procedure TearDown; override;
published
procedure TestStatement;
procedure TestStatementStop;
procedure TestDirective;
procedure TestDirectiveStop;
procedure TestCommit;
procedure TestBeforeExec;
procedure TestAfterExec;
end;
implementation
{ TMyScript }
procedure TMyScript.ExecuteStatement(SQLStatement: TStrings; var StopExecution: Boolean);
var s : string;
r : integer;
begin
if (SQLStatement.count = 1) and (compareText(SQLStatement[0],'END')=0) then
StopExecution := true;
s := '';
for r := 0 to SQLstatement.count-1 do
begin
if s <> '' then
s := s + ' ';
s := s + SQLStatement[r];
end;
FStatements.Add (s);
if DoException <> '' then
raise exception.create(DoException);
end;
procedure TMyScript.ExecuteDirective(Directive, Argument: String; var StopExecution: Boolean);
begin
if Directive = 'STOP' then
StopExecution := true;
if Argument = '' then
FDirectives.Add (Directive)
else
FDirectives.Add (format('%s(%s)', [Directive, Argument]));
if DoException <> '' then
raise exception.create(DoException);
end;
procedure TMyScript.ExecuteCommit;
begin
inc (FCommits);
if DoException <> '' then
raise exception.create(DoException);
end;
procedure TMyScript.DefaultDirectives;
begin
inherited DefaultDirectives;
directives.add ('STOP');
end;
constructor TMyScript.create (AnOwner: TComponent);
begin
inherited create (AnOwner);
FStatements := TStringlist.Create;
FDirectives := TStringlist.Create;
FCommits := 0;
DoException := '';
end;
destructor TMyScript.destroy;
begin
FStatements.Free;
FDirectives.Free;
inherited destroy;
end;
function TMyScript.StatementsExecuted: string;
begin
result := FStatements.Commatext;
end;
function TMyScript.DirectivesExecuted: string;
begin
result := FDirectives.Commatext;
end;
{ TTestSQLScript }
procedure TTestSQLScript.Add(s: string);
begin
Script.Script.Add (s);
end;
procedure TTestSQLScript.AssertStatDir(Statements, Directives: string);
begin
AssertEquals ('Executed Statements', Statements, script.StatementsExecuted);
AssertEquals ('Executed Directives', Directives, script.DirectivesExecuted);
end;
procedure TTestSQLScript.DoExecution;
begin
script.execute;
end;
procedure TTestSQLScript.ExceptionHandler(Sender: TObject; Statement: TStrings;
TheException: Exception; var Continue: boolean);
var r : integer;
s : string;
begin
Continue := UseContinue;
if Statement.count > 0 then
s := Statement[0];
for r := 1 to Statement.count-1 do
s := s + ',' + Statement[r];
exceptionstatement := s;
exceptionmessage := TheException.message;
end;
procedure TTestSQLScript.SetUp;
begin
inherited SetUp;
Script := TMyscript.Create (nil);
end;
procedure TTestSQLScript.TearDown;
begin
Script.Free;
inherited TearDown;
end;
procedure TTestSQLScript.TestCreateDefaults;
begin
with Script do
begin
AssertEquals ('Terminator', ';', Terminator);
AssertTrue ('UseCommit', UseCommit);
AssertTrue ('UseSetTerm', UseSetTerm);
AssertTrue ('UseDefines', UseDefines);
AssertTrue ('CommentsInSQL', CommentsInSQL);
AssertFalse ('Aborted', Aborted);
AssertEquals ('Line', 0, Line);
AssertEquals ('Defines', 0, Defines.count);
AssertEquals ('Directives', 10, Directives.count);
end;
end;
procedure TTestSQLScript.TestTerminator;
begin
script.terminator := '!';
Add('doe!iets!');
Add('anders!');
script.execute;
AssertStatDir('doe,iets,anders', '');
end;
procedure TTestSQLScript.TestSetTerm;
begin
script.UseSetTerm:=true;
Add('SET TERM !;');
script.execute;
AssertEquals ('terminator', '!', script.terminator);
AssertStatDir('', '');
end;
procedure TTestSQLScript.TestUseSetTerm;
begin
script.UseSetTerm:=false;
Script.Directives.Add ('SET TERM');
Add('SET TERM !;');
script.execute;
AssertEquals ('terminator', ';', script.terminator);
AssertStatDir('', '"SET TERM(!)"');
end;
procedure TTestSQLScript.TestComments;
begin
script.CommentsInSQL := true;
Add('/* comment */');
Add('statement;');
script.execute;
AssertStatDir ('"/* comment */ statement"', '');
end;
procedure TTestSQLScript.TestUseComments;
begin
script.CommentsInSQL := false;
Add('/* comment */');
Add('statement;');
script.execute;
AssertStatDir ('statement', '');
end;
procedure TTestSQLScript.TestCommit;
begin
script.UseCommit := true;
Add('commit;');
script.execute;
AssertEquals ('Commits', 1, script.FCommits);
AssertStatDir ('', '');
end;
procedure TTestSQLScript.TestUseCommit;
begin
script.UseCommit := false;
with script.Directives do
Delete(IndexOf('COMMIT'));
Add('commit;');
script.execute;
AssertEquals ('Commits', 0, script.FCommits);
AssertStatDir ('commit', '');
end;
procedure TTestSQLScript.TestDefine;
begin
script.UseDefines := true;
Add ('#define iets;');
script.execute;
AssertStatDir ('', '');
AssertEquals ('Aantal defines', 1, script.defines.count);
AssertEquals ('Juiste define', 'iets', script.Defines[0]);
end;
procedure TTestSQLScript.TestUndefine;
begin
script.UseDefines := true;
script.defines.Add ('iets');
Add ('#undefine iets;');
script.execute;
AssertStatDir ('', '');
AssertEquals ('Aantal defines', 0, script.defines.count);
end;
procedure TTestSQLScript.TestUndef;
begin
script.UseDefines := true;
script.defines.Add ('iets');
Add ('#Undef iets;');
script.execute;
AssertStatDir ('', '');
AssertEquals ('Aantal defines', 0, script.defines.count);
end;
procedure TTestSQLScript.TestIfdef1;
begin
script.UseDefines := true;
script.defines.add ('iets');
Add('#ifdef iets;');
Add('doe iets;');
script.execute;
AssertStatDir('"doe iets"', '');
end;
procedure TTestSQLScript.TestIfdef2;
begin
script.UseDefines := true;
Add('#ifdef iets;');
Add('doe iets;');
script.execute;
AssertStatDir('', '');
end;
procedure TTestSQLScript.TestIfndef1;
begin
script.UseDefines := true;
Add('#ifndef iets;');
Add('doe iets;');
script.execute;
AssertStatDir('"doe iets"', '');
end;
procedure TTestSQLScript.TestIfndef2;
begin
script.UseDefines := true;
script.defines.add ('iets');
Add('#ifndef iets;');
Add('doe iets;');
script.execute;
AssertStatDir('', '');
end;
procedure TTestSQLScript.TestElse1;
begin
script.UseDefines := true;
script.defines.add ('iets');
Add('#ifdef iets;');
Add('doe iets;');
add('#else;');
add('anders;');
script.execute;
AssertStatDir('"doe iets"', '');
end;
procedure TTestSQLScript.TestElse2;
begin
script.UseDefines := true;
script.defines.add ('iets');
Add('#ifndef iets;');
Add('doe iets;');
add('#else;');
add('anders;');
script.execute;
AssertStatDir('anders', '');
end;
procedure TTestSQLScript.TestEndif1;
begin
script.UseDefines := true;
Add('#ifdef iets;');
Add('doe iets;');
add('#endif;');
add('anders;');
script.execute;
AssertStatDir('anders', '');
end;
procedure TTestSQLScript.TestEndif2;
begin
script.UseDefines := true;
Add('#ifndef iets;');
Add('doe iets;');
add('#endif;');
add('anders;');
script.execute;
AssertStatDir('"doe iets",anders', '');
end;
procedure TTestSQLScript.TestUseDefines;
begin
script.UseDefines := false;
Add('#ifndef iets;');
Add('doe iets;');
add('#endif;');
add('anders;');
script.execute;
AssertStatDir('"doe iets",anders', '#IFNDEF(iets),#ENDIF');
end;
procedure TTestSQLScript.TestTermInComment;
begin
script.CommentsInSQL := false;
Add('/* terminator ; */iets;');
script.execute;
AssertStatDir('iets', '');
end;
procedure TTestSQLScript.TestTermInQuotes1;
begin
script.CommentsInSQL := false;
Add('iets '';'';');
script.execute;
AssertStatDir('"iets '';''"', '');
end;
procedure TTestSQLScript.TestTermInQuotes2;
begin
script.CommentsInSQL := false;
Add('iets ";";');
script.execute;
AssertStatDir('"iets "";"""', '');
end;
procedure TTestSQLScript.TestCommentInComment;
begin
script.CommentsInSQL := false;
Add('/* meer /* */iets;');
script.execute;
AssertStatDir('iets', '');
end;
procedure TTestSQLScript.TestCommentInQuotes1;
begin
script.CommentsInSQL := false;
Add('iets ''/* meer */'';');
script.execute;
AssertStatDir('"iets ''/* meer */''"', '');
end;
procedure TTestSQLScript.TestCommentInQuotes2;
begin
script.CommentsInSQL := false;
Add('iets "/* meer */";');
script.execute;
AssertStatDir('"iets ""/* meer */"""', '');
end;
procedure TTestSQLScript.TestQuote1InComment;
begin
script.CommentsInSQL := false;
Add('/* s''morgens */iets;');
script.execute;
AssertStatDir('iets', '');
end;
procedure TTestSQLScript.TestQuote2InComment;
begin
script.CommentsInSQL := false;
Add('/* s"morgens */iets;');
script.execute;
AssertStatDir('iets', '');
end;
procedure TTestSQLScript.TestQuoteInQuotes1;
begin
script.CommentsInSQL := false;
Add('iets ''s"morgens'';');
script.execute;
AssertStatDir('"iets ''s""morgens''"', '');
end;
procedure TTestSQLScript.TestQuoteInQuotes2;
begin
script.CommentsInSQL := false;
Add('iets "s''morgens";');
script.execute;
AssertStatDir('"iets ""s''morgens"""', '');
end;
procedure TTestSQLScript.TestStatementStop;
begin
Add('END;meer;');
script.execute;
AssertStatDir('END', '');
end;
procedure TTestSQLScript.TestDirectiveStop;
begin
Add('Stop;meer;');
script.execute;
AssertStatDir('', 'STOP');
end;
procedure TTestSQLScript.TestStatementExeception;
begin
Add('iets;');
script.DoException:='FOUT';
AssertException (exception, @DoExecution);
AssertStatDir('iets', '');
end;
procedure TTestSQLScript.TestDirectiveException;
begin
Add('iets;');
script.Directives.Add('IETS');
script.DoException := 'FOUT';
AssertException (exception, @DoExecution);
AssertStatDir('', 'IETS');
end;
procedure TTestSQLScript.TestCommitException;
begin
Add ('commit;');
script.DoException := 'FOUT';
AssertException (exception, @DoExecution);
AssertStatDir('', '');
AssertEquals ('Commit count', 1, Script.FCommits);
end;
procedure TTestSQLScript.TestStatementOnExeception1;
begin
UseContinue := true;
script.DoException := 'Fout';
Add ('foutief;');
script.OnException:=@ExceptionHandler;
Script.Execute;
AssertEquals ('exception message', 'Fout', exceptionmessage);
AssertEquals ('exception statement', 'foutief', exceptionstatement);
end;
procedure TTestSQLScript.TestStatementOnExeception2;
begin
UseContinue := false;
script.DoException := 'Fout';
Add ('foutief;');
script.OnException:=@ExceptionHandler;
AssertException (exception, @DoExecution);
AssertEquals ('exception message', 'Fout', exceptionmessage);
AssertEquals ('exception statement', 'foutief', exceptionstatement);
end;
procedure TTestSQLScript.TestDirectiveOnException1;
begin
UseContinue := true;
script.DoException := 'Fout';
Add ('foutief;');
Script.Directives.Add ('FOUTIEF');
script.OnException:=@ExceptionHandler;
Script.Execute;
AssertEquals ('exception message', 'Fout', exceptionmessage);
AssertEquals ('exception statement', 'FOUTIEF', exceptionstatement);
end;
procedure TTestSQLScript.TestDirectiveOnException2;
begin
UseContinue := False;
script.DoException := 'Fout';
Add ('foutief;');
Script.Directives.Add ('FOUTIEF');
script.OnException:=@ExceptionHandler;
AssertException (exception, @DoExecution);
AssertEquals ('exception message', 'Fout', exceptionmessage);
AssertEquals ('exception statement', 'FOUTIEF', exceptionstatement);
end;
procedure TTestSQLScript.TestDirectiveOnException3;
begin
UseContinue := true;
script.DoException := 'Fout';
Add ('foutief probleem;');
Script.Directives.Add ('FOUTIEF');
script.OnException:=@ExceptionHandler;
Script.Execute;
AssertEquals ('exception message', 'Fout', exceptionmessage);
AssertEquals ('exception statement', 'FOUTIEF,probleem', exceptionstatement);
end;
procedure TTestSQLScript.TestCommitOnException1;
begin
UseContinue := true;
script.DoException := 'Fout';
Add ('Commit;');
script.OnException:=@ExceptionHandler;
Script.Execute;
AssertEquals ('exception message', 'Fout', exceptionmessage);
AssertEquals ('exception statement', 'COMMIT', exceptionstatement);
AssertEquals ('commit count', 1, Script.FCommits);
end;
procedure TTestSQLScript.TestCommitOnException2;
begin
UseContinue := false;
script.DoException := 'Fout';
Add ('Commit;');
script.OnException:=@ExceptionHandler;
AssertException (exception, @DoExecution);
AssertEquals ('exception message', 'Fout', exceptionmessage);
AssertEquals ('exception statement', 'COMMIT', exceptionstatement);
AssertEquals ('commit count', 1, Script.FCommits);
end;
{ TTestEventSQLScript }
procedure TTestEventSQLScript.Notify(Sender: TObject);
begin
inc (NotifyCount);
LastSender := Sender;
end;
procedure TTestEventSQLScript.NotifyStatement(Sender: TObject;
SQL_Statement: TStrings; var StopExecution: Boolean);
var r : integer;
s : string;
begin
StopExecution := StopToSend;
if SQL_Statement.count > 0 then
begin
s := SQL_Statement[0];
for r := 1 to SQL_Statement.count-1 do
s := s + ';' + SQL_Statement[r];
if SQL_Statement.count > 1 then
s := '"' + s + '"';
end
else
s := '';
if received <> '' then
received := received + ';' + s
else
received := s;
LastSender := Sender;
end;
procedure TTestEventSQLScript.NotifyDirective(Sender: TObject; Directive,
Argument: AnsiString; var StopExecution: Boolean);
var s : string;
begin
StopExecution := StopToSend;
if Argument = '' then
s := Directive
else
s := format ('%s(%s)', [Directive, Argument]);
if received <> '' then
received := received + ';' + s
else
received := s;
LastSender := Sender;
end;
procedure TTestEventSQLScript.SetUp;
begin
inherited SetUp;
Script := TEventSQLScript.Create (nil);
notifycount := 0;
Received := '';
LastSender := nil;
end;
procedure TTestEventSQLScript.TearDown;
begin
Script.Free;
inherited TearDown;
end;
procedure TTestEventSQLScript.TestStatement;
begin
StopToSend:=false;
Script.OnSQLStatement := @NotifyStatement;
Script.Script.Text := 'stat1;stat2;';
script.execute;
AssertEquals ('Received', 'stat1;stat2', received);
AssertSame ('Sender', script, LastSender);
end;
procedure TTestEventSQLScript.TestStatementStop;
begin
StopToSend:=true;
Script.OnSQLStatement := @NotifyStatement;
Script.Script.Text := 'stat1;stat2;';
script.execute;
AssertEquals ('Received', 'stat1', received);
AssertSame ('Sender', script, LastSender);
end;
procedure TTestEventSQLScript.TestDirective;
begin
StopToSend:=false;
Script.OnSQLStatement := @NotifyStatement;
Script.OnDirective := @NotifyDirective;
script.Directives.Add ('STAT1');
Script.Script.Text := 'stat1 ik;stat2;';
script.execute;
AssertEquals ('Received', 'STAT1(ik);stat2', received);
AssertSame ('Sender', script, LastSender);
end;
procedure TTestEventSQLScript.TestDirectiveStop;
begin
StopToSend:=true;
Script.OnSQLStatement := @NotifyStatement;
Script.OnDirective := @NotifyDirective;
script.Directives.Add ('STAT1');
Script.Script.Text := 'stat1 ik;stat2;';
script.execute;
AssertEquals ('Received', 'STAT1(ik)', received);
AssertSame ('Sender', script, LastSender);
end;
procedure TTestEventSQLScript.TestCommit;
begin
Script.OnCommit := @Notify;
Script.Script.Text := 'iets; commit; anders;';
script.execute;
AssertEquals ('NotifyCount', 1, NotifyCount);
AssertSame ('Sender', script, LastSender);
end;
procedure TTestEventSQLScript.TestBeforeExec;
begin
Script.BeforeExecute := @Notify;
Script.Script.Text := 'update iets; anders iets;';
script.execute;
AssertEquals ('NotifyCount', 1, NotifyCount);
AssertSame ('Sender', script, LastSender);
end;
procedure TTestEventSQLScript.TestAfterExec;
begin
Script.AfterExecute := @Notify;
Script.Script.Text := 'update iets; anders iets; en meer;';
script.execute;
AssertEquals ('NotifyCount', 1, NotifyCount);
AssertSame ('Sender', script, LastSender);
end;
initialization
RegisterTests ([TTestSQLScript, TTestEventSQLScript]);
end.