From cc0c2d6467ab2f0d62ee80fd1f9d52dc54304d25 Mon Sep 17 00:00:00 2001 From: michael Date: Fri, 11 Jul 2008 14:16:39 +0000 Subject: [PATCH] * SqlScript committed git-svn-id: trunk@11366 - --- .gitattributes | 2 + packages/fcl-db/src/base/Makefile | 118 ++-- packages/fcl-db/src/base/Makefile.fpc | 2 +- packages/fcl-db/src/base/sqlscript.pp | 662 +++++++++++++++++++ packages/fcl-db/src/sqldb/sqldb.pp | 86 +-- packages/fcl-db/tests/testsqlscript.pas | 808 ++++++++++++++++++++++++ 6 files changed, 1581 insertions(+), 97 deletions(-) create mode 100644 packages/fcl-db/src/base/sqlscript.pp create mode 100644 packages/fcl-db/tests/testsqlscript.pas diff --git a/.gitattributes b/.gitattributes index 227caa351c..205c9a43da 100644 --- a/.gitattributes +++ b/.gitattributes @@ -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 diff --git a/packages/fcl-db/src/base/Makefile b/packages/fcl-db/src/base/Makefile index 0f96d959ef..882ef5dc51 100644 --- a/packages/fcl-db/src/base/Makefile +++ b/packages/fcl-db/src/base/Makefile @@ -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 diff --git a/packages/fcl-db/src/base/Makefile.fpc b/packages/fcl-db/src/base/Makefile.fpc index 73e9832096..be14f5764b 100644 --- a/packages/fcl-db/src/base/Makefile.fpc +++ b/packages/fcl-db/src/base/Makefile.fpc @@ -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] diff --git a/packages/fcl-db/src/base/sqlscript.pp b/packages/fcl-db/src/base/sqlscript.pp new file mode 100644 index 0000000000..440e7c1669 --- /dev/null +++ b/packages/fcl-db/src/base/sqlscript.pp @@ -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 (L10) and (CNil) 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'') 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. + diff --git a/packages/fcl-db/src/sqldb/sqldb.pp b/packages/fcl-db/src/sqldb/sqldb.pp index e5b6327387..54da2cda05 100644 --- a/packages/fcl-db/src/sqldb/sqldb.pp +++ b/packages/fcl-db/src/sqldb/sqldb.pp @@ -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 diff --git a/packages/fcl-db/tests/testsqlscript.pas b/packages/fcl-db/tests/testsqlscript.pas new file mode 100644 index 0000000000..5e9f4cc95b --- /dev/null +++ b/packages/fcl-db/tests/testsqlscript.pas @@ -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. +