I'm migrating an old Delphi application (using ZeosDB) to Delphi XE2. I want to use dbExpress as a ZeosDB replacement for database access to Firebird 2.5 or MS-SQL.
There are a lot of sql scripts for creating tables, view and stored procedures I need to run. The Firebird script commands are seperated with ^, MS-SQL script commands with "GO".
How can I run these scripts on the database using a dbexpress connection? ZeosDB provides a TZSqlProcessor, but I can't find any equivalent component for dbExpress.
I do not use DBExpress but as far as I am aware, you can execute (either by Execute or ExecuteDirect) only one SQL command at a time. In other words you cannot put the whole script into the Execute method.
This is not related to different command syntax used by FireBird and MS SQL (^ vs. GO). You have to understand the '^' sign or 'GO' command is not a "TSQL Command"! Both are specific command delimiters used by respective application used to execute commands against the SQL engines. Instead it is difference between "Firebird Manager" (or how it's called) and "SQL Query Profiler" (or "SQL Server Management Studio").
The solution is to use some kind of parser, split the script into a list of single commands, and TSQLConnection.Execute these commands one-by-one.
Something like this pseudocode:
var
DelimiterPos: Integer;
S: String;
Command: String;
begin
S:= ScriptFile; // ScriptFile: String - your whole script
While True Do
begin
DelimiterPos:= Pos('^', ScriptFile);
if DelimiterPos = 0 then DelimiterPos:= Length(S);
Command:= Copy(S, 1, DelimiterPos - 1);
SQLConnection.Execute(Command);
Delete(S, 1, DelimiterPos);
if Lengh(S) = 0 Then Exit;
end;
end;
Please note that the sample above will work correctly only in cases that the '^' sign is not used anywhere in the script but a command separator.
As a sidenote, I am sure there are some already built components that will do that for you (like TZSQLProcessor). I am not aware of any to point you to.
Sidenote 2: I am pretty sure, that you'll have to modify your scripts to be fully compatible with MS SQL. Eventhough Firebird and MS SQL are both SQL servers there is always difference in DML/DDL syntax.
Edit:
If you can "rewrite" the SQL script into the code, you could use Jedi VCL jvStringHolder component. Put each separate command as one item (of type TStrings) in jvStringHolder.
Creating the parser is rather complicated, but not undoable. With the inspiration from SynEdit i made these clases to exactly what you need: Load the script with TSQLScript.ParseScript, then iterate through Command[index: integer] property. The SQLLexer is not full SQL Lexer, but implements keywords separation with respec to comments, brackets, code folding etc. I've also added a special syntax into comments ($ sign in comment block) that helps me put titles into the script.
This is full copy-paste from one of my projects. I'm not giving any more explanation, but I hope you can get the idea and make it running in your project.
unit SQLParser;
interface
type
TTokenKind = (tkUknown, tkEOF, tkComment, tkKeyword, tkIdentifier,
tkCommentParam, tkCommentParamValue, tkCommandEnd, tkCRLF);
TBlockKind = (bkNone, bkLineComment, bkBlockComment);
TSQLLexer = class
private
FBlockKind: TBlockKind;
FParseString: String;
FPosition: PChar;
FTokenKind: TTokenKind;
FTokenPosition: PChar;
function GetToken: String;
procedure Reset;
procedure SetParseString(Value: String);
protected
procedure ReadComment;
procedure ReadCommentParam;
procedure ReadCommentParamValue;
procedure ReadCRLF;
procedure ReadIdentifier;
procedure ReadSpace;
public
constructor Create(ParseString: String);
function NextToken: TTokenKind;
property Position: PChar read FPosition;
property SQLText: String read FParseString write SetParseString;
property Token: String read GetToken;
property TokenKind: TTokenKind read FTokenKind;
property TokenPosition: PChar read FTokenPosition;
end;
implementation
uses SysUtils;
{ TSQLLexer }
constructor TSQLLexer.Create(ParseString: string);
begin
inherited Create;
FParseString:= ParseString;
Reset;
end;
function TSQLLexer.GetToken;
begin
SetString(Result, FTokenPosition, FPosition - FTokenPosition);
end;
function TSQLLexer.NextToken: TTokenKind;
begin
case FBlockKind of
bkLineComment, bkBlockComment: ReadComment;
else
case FPosition^ of
#0: FTokenKind:= tkEOF;
#1..#9, #11, #12, #14..#32:
begin
ReadSpace;
NextToken;
end;
#10, #13: ReadCRLF;
'-':
if PChar(FPosition +1)^ = '-' then
ReadComment
else
Inc(FPosition);
'/':
if PChar(FPosition +1)^ = '*' then
ReadComment
else
Inc(FPosition);
'a'..'z', 'A'..'Z': ReadIdentifier;
';':
begin
FTokenPosition:= FPosition;
Inc(FPosition);
FTokenKind:= tkCommandEnd;
end
else
Inc(FPosition);
end;
end;
Result:= FTokenKind;
end;
procedure TSQLLexer.ReadComment;
begin
FTokenPosition:= FPosition;
if not (FBlockKind in [bkLineComment, bkBlockComment]) then
begin
if FPosition^ = '/' then
FBlockKind:= bkBlockComment
else
FBlockKind:= bkLineComment;
Inc(FPosition, 2);
end;
case FPosition^ of
'$': ReadCommentParam;
':': ReadCommentParamValue;
else
while not CharInSet(FPosition^, [#0, '$']) do
begin
if FBlockKind = bkBlockComment then
begin
if (FPosition^ = '*') And (PChar(FPosition + 1)^ = '/') then
begin
Inc(FPosition, 2);
FBlockKind:= bkNone;
Break;
end;
end
else
begin
if CharInSet(Fposition^, [#10, #13]) then
begin
ReadCRLF;
FBlockKind:= bkNone;
Break;
end;
end;
Inc(FPosition);
end;
FTokenKind:= tkComment;
end;
end;
procedure TSQLLexer.ReadCommentParam;
begin
Inc(FPosition);
ReadIdentifier;
FTokenKind:= tkCommentParam;
end;
procedure TSQLLexer.ReadCommentParamValue;
begin
Inc(FPosition);
ReadSpace;
FTokenPosition:= FPosition;
while not CharInSet(FPosition^, [#0, #10, #13]) do
Inc(FPosition);
FTokenKind:= tkCommentParamValue;
end;
procedure TSQLLexer.ReadCRLF;
begin
while CharInSet(FPosition^, [#10, #13]) do
Inc(FPosition);
FTokenKind:= tkCRLF;
end;
procedure TSQLLexer.ReadIdentifier;
begin
FTokenPosition:= FPosition;
while CharInSet(FPosition^, ['a'..'z', 'A'..'Z', '_']) do
Inc(FPosition);
FTokenKind:= tkIdentifier;
if Token = 'GO' then
FTokenKind:= tkKeyword;
end;
procedure TSQLLexer.ReadSpace;
begin
while CharInSet(FPosition^, [#1..#9, #11, #12, #14..#32]) do
Inc(FPosition);
end;
procedure TSQLLexer.Reset;
begin
FTokenPosition:= PChar(FParseString);
FPosition:= FTokenPosition;
FTokenKind:= tkUknown;
FBlockKind:= bkNone;
end;
procedure TSQLLexer.SetParseString(Value: String);
begin
FParseString:= Value;
Reset;
end;
end.
The parser:
type
TScriptCommand = class
private
FCommandText: String;
public
constructor Create(ACommand: String);
property CommandText: String read FCommandText write FCommandText;
end;
TSQLScript = class
private
FCommands: TStringList;
function GetCount: Integer;
function GetCommandList: TStrings;
function GetCommand(index: Integer): TScriptCommand;
protected
procedure AddCommand(AName: String; ACommand: String);
public
Constructor Create;
Destructor Destroy; override;
procedure ParseScript(Script: TStrings);
property Count: Integer read GetCount;
property CommandList: TStrings read GetCommandList;
property Command[index: integer]: TScriptCommand read GetCommand;
end;
{ TSQLScriptCommand }
constructor TScriptCommand.Create(ACommand: string);
begin
inherited Create;
FCommandText:= ACommand;
end;
{ TSQLSCript }
constructor TSQLScript.Create;
begin
inherited;
FCommands:= TStringList.Create(True);
FCommands.Duplicates:= dupIgnore;
FCommands.Sorted:= False;
end;
destructor TSQLScript.Destroy;
begin
FCommands.Free;
inherited;
end;
procedure TSQLScript.AddCommand(AName, ACommand: String);
var
ScriptCommand: TScriptCommand;
S: String;
begin
if AName = '' then
S:= SUnnamedCommand
else
S:= AName;
ScriptCommand:= TScriptCommand.Create(ACommand);
FCommands.AddObject(S, ScriptCommand);
end;
function TSQLScript.GetCommand(index: Integer): TScriptCommand;
begin
Result:= TScriptCommand(FCommands.Objects[index]);
end;
function TSQLScript.GetCommandList: TStrings;
begin
Result:= FCommands;
end;
function TSQLScript.GetCount: Integer;
begin
Result:= FCommands.Count;
end;
procedure TSQLScript.ParseScript(Script: TStrings);
var
Title: String;
Command: String;
LastParam: String;
LineParser: TSQLLexer;
IsNewLine: Boolean;
LastPos: PChar;
procedure AppendCommand;
var
S: String;
begin
SetString(S, LastPos, LineParser.Position - LastPos);
Command:= Command + S;
LastPos:= LineParser.Position;
end;
procedure FinishCommand;
begin
if Command <> '' then
AddCommand(Title, Command);
Title:= '';
Command:= '';
LastPos:= LineParser.Position;
if LastPos^ = ';' then Inc(LastPos);
end;
begin
LineParser:= TSQLLexer.Create(Script.Text);
try
LastPos:= LineParser.Position;
IsNewLine:= True;
repeat
LineParser.NextToken;
case LineParser.TokenKind of
tkComment: LastPos:= LineParser.Position;
tkCommentParam:
begin
LastParam:= UpperCase(LineParser.Token);
LastPos:= LineParser.Position;
end;
tkCommentParamValue:
if LastParam = 'TITLE' then
begin
Title:= LineParser.Token;
LastParam:= '';
LastPos:= LineParser.Position;
end;
tkKeyword:
if (LineParser.Token = 'GO') and IsNewLine then FinishCommand
else
AppendCommand;
tkEOF:
FinishCommand;
else
AppendCommand;
end;
IsNewLine:= LineParser.TokenKind in [tkCRLF, tkCommandEnd];
until LineParser.TokenKind = tkEOF;
finally
LineParser.Free;
end;
end;
You need to use the TSQLConnection. This is component have a two methods, Execute and ExecuteDirect. The first does not accept parameters, but the second method does.
Using the first method:
procedure TForm1.Button1Click(Sender: TObject);
var
MeuSQL: String;
begin
MeuSQL := 'INSERT INTO YOUR_TABLE ('FIELD1', 'FIELD2') VALUES ('VALUE1', 'VALUE2')';
SQLConnection.ExecuteDirect(MeuSQL);
end;
If you want, you can use a transaction.
Using the second method:
procedure TForm1.Button1Click(Sender: TObject);
var
MySQL: string;
MyParams: TParams;
begin
MySQL := 'INSERT INTO TABLE ("FIELD1", "FIELD2") VALUE (:PARAM1, :PARAM2)';
MyParams.Create;
MyParams.CreateParam(ftString, 'PARAM1', ptInput).Value := 'Seu valor1';
MyParams.CreateParam(ftString, 'PARAM2', ptInput).Value := 'Seu valor2';
SQLConnection1.Execute(MySQL,MyParams, Nil);
end;
I am about 90% sure that you can't, at least not without parsing the individual commands between the GO's, and then serially executing each of them, which as you have already pointed out, is problematic.
(I would be happy to be disproved on the above, and quite interested in seeing the solution...)
If you are simply using the script as initialisation logic (e.g. to create tables, etc), another solution you could consider would be to fire off the scripts in a batch file and executing them via 'Sqlcmd', which could be executed via your delphi app (using ShellExecute), which then waits for it to complete before continuing.
Not as elegant as using a component, but if it is just for initialisation logic it may be a quick, acceptable compromise. I certainly wouldn't consider the above for any processing post-initialisation.
This doesn't appear to be a dbExpress limitation, but a SQL language limitation. I'm not sure about T-SQL, but it seems like the GO is similar to an anonymous block in Oracle PL/SQL. You can put the following PL/SQL code in the TSqlDataSet.CommandText and call ExecSQL to create multiple tables. Maybe T-SQL has a similar way to do this:
begin
execute immediate 'CREATE TABLE suppliers
( supplier_id number(10) not null,
supplier_name varchar2(50) not null,
contact_name varchar2(50)
)';
execute immediate 'CREATE TABLE customers
( customer_id number(10) not null,
customer_name varchar2(50) not null,
address varchar2(50),
city varchar2(50),
state varchar2(25),
zip_code varchar2(10),
CONSTRAINT customers_pk PRIMARY KEY (customer_id)
)';
end;
I don't know how often you need to create those tables, but how about putting all separate SQL create scripts in a table, with sequential/version numbering?
Than you can go through that table and execute 'm one by one.
You'll need to split your scripts once, but after that it's much more maintainable.
Related
This already is reported as RSP-25603: "Exception.RaiseOuterException can cause wrong W1035 warning".
Given the following (demo) function F, I have changed an exception raising statement to now chain exceptions:
--- before
+++ after
## -1,11 +1,11 ##
function F(X: NativeInt): NativeInt;
begin
try
Result := 1 div X;
except
on EDivByZero do
- {ECustom}Exception.Create('...');
+ Exception.RaiseOuterException({ECustom}Exception.Create('...'));
else
raise;
end;
end;
Now, Ctrl-F9 gives the warning W1035:
[dcc32 Warning]: W1035 Return value of function 'F' might be undefined
However, all cases are handled. The compiler fails to recognize Exception.RaiseOuterException as the raise operation it is.
Unfortunately FAcquireInnerException: Boolean is private to the Exception class, not even to be set to True in derived custom classes which I could keep raising directly (raise ECustomException.Create).
Is there any way to make the compiler understand, while keeping the exceptions chained? Otherwise I can think of {$Warn No_RetVal Off}. How else could I work around this warning?
One way I can think of to avoid the warning, without disabling it, is to do the following instead:
function F(X: NativeInt): NativeInt;
begin
try
Result := 1 div X;
except
on E: Exception do
begin
if E is EDivByZero then
Exception.RaiseOuterException({ECustom}Exception.Create('...'));
raise;
end;
end;
end;
UPDATE: Another way, as stated in a comment, would be to simply define a return value that is not actually reached at runtime, eg:
function F(X: NativeInt): NativeInt;
begin
try
Result := 1 div X;
except
on E: EDivByZero do
begin
Exception.RaiseOuterException({ECustom}Exception.Create('...'));
Result := 0; // <-- just to keep the compiler happy
end;
end;
end;
EChainedException solution
(as requested by Max)
Update
I have put out a FR for this at Embarcadero. Please vote if you like this proposed solution. RSP-31679
By using this class, the inner exception is always recorded "as if" you had called Exception.RaiseOuterException. This allows you to use the simple raise statement, this avoids the warning message being issued by the compiler.
Useage
Just derive your custom exceptions from EChainedException instead of Exception, and use raise rather then Exception.RaiseOuterException.
Sourcecode
The relevant code is below. My complete EChainedException is a bit more complicated than this for supporting detection of fatal exceptions and stacktracing etc. If it doesn't compile, let me know what's missing and I'll add the missing part.
unit uChainedException;
interface
uses Sysutils;
{$M+} // ensures RTTI info is present for EChainedException
type
EChainedException = class(Exception)
protected
procedure RaisingException(P: system.sysutils.PExceptionRecord); override;
end;
implementation
uses rtti;
var // rtti pointers for handling the inner exception
vInnerExceptionOffset: NativeInt = -1;
vAcquireInnerExceptionOffset: NativeInt = -1;
vRunningInIDEInitialized: Boolean;
vRunningInIDE: Boolean;
function RunningInIDE:boolean;
begin
if not vRunningInIDEInitialized then
begin
vRunningInIDE:=AnsiSameText(ExtractFileName(ParamStr(0)),'BDS.EXE');
vRunningInIDEInitialized:=True;
end;
Result:=vRunningInIDE;
end;
procedure EChainedException.RaisingException(P: System.sysutils.PExceptionRecord);
var
PBoolean: ^Boolean;
PObject : ^TObject;
begin
if (ExceptObject<>self) and (vAcquireInnerExceptionOffset >=0) then
begin
PBoolean := Pointer(NativeInt(Self)+vAcquireInnerExceptionOffset);
PBoolean^ := PBoolean^ or not RunningInIDE;
end;
inherited;
// in some rare cases (like reraise exception from another thread)
// it may happen that the innerexception points to self
// this is corrected here.
if InnerException=self then
begin
PObject := Pointer(NativeInt(Self)+vInnerExceptionOffset);
PObject^ := nil;
end;
end;
procedure UnprepAutoInnerException;
begin
vInnerExceptionOffset:=-1;
vAcquireInnerExceptionOffset:=-1;
end;
procedure PrepAutoInnerException;
var
lRTTIContext: TRttiContext;
lInnerException:TRttiField;
lAcquireInnerException:TRttiField;
lClass: TRttiInstanceType;
begin
try
lRTTIContext.Create; //Notice vRTTIContext is a record, .Create initializes properties
try
lClass:=lRTTIContext.GetType(Exception) as TRttiInstanceType;
lInnerException:=lClass.GetField('FInnerException');
vInnerExceptionOffset := lInnerException.Offset;
lAcquireInnerException:=lClass.GetField('FAcquireInnerException');
vAcquireInnerExceptionOffset := lAcquireInnerException.Offset;
except
UnprepAutoInnerException;
raise;
end;
finally
lRTTIContext.Free;
end;
end;
initialization
PrepAutoInnerException;
finalization
UnprepAutoInnerException;
end.
Looking at this code I find it could use some modernizing, eg by using class vars instead of globals, and by using inline locale variables.
The entire unit is back from Delphi 6 days and contains many $ifdefs, and left out because it would surpass the answer.
I still wonder why exception chaining is not the default in delphi/rad studio like it is in other languages. Most likely because it would break existing code somehow.
I (also) answer my own question as I will take yet another approach. It provides for the following requirements:
I like to keep the raise statements, as they initially were,
so there won't be any necessary code changes here, and
which also means there won't be newly introduced warnings like W1035 or W1036.
I don't want to rebuild the inner RTL mechanics, however
I want to interfere with the RTL mechanics as little as possible.
I want to be flexible in controlling for chaining exceptions
sometimes forced or by default, on the exception implementation side, as well as
sometimes by argument, on the exception usage side, to extend functionality.
In my solution:
I accept to break through the Exception fields' visibility, FAcquireInnerException specifically.
I rely on RTTI to verify the fields' alignment (in ExceptionFields, according to Exception).
Here I provide a condensed implementation to copy-and-paste:
EException's constructor showcases the use of ExceptionFields:
ExceptionFields(Self).FAcquireInnerException := True;
-- to be used in any Exception-derived exception, and it will trigger the RTL mechanics to set the InnerException while it is raising the exception. Also, EException may serve as a common root for custom exception classes, if desired. Some constructors are reintroduced to be extended with const AcquireInnerException: Boolean = True, to hand-over the control to the caller while providing a default for the desired chaining.
Run ExceptionFields.VerifyFieldAlignments, if you want to verify the alignments of
the ("re-") declared externally accessible fields in ExceptionFields and
their (private) counterparts in Exception.
If it cannot verify this, it will raise an exception. It is run in EException's class constructor. Move it as propriate to you, if you do not use EException, yet want to keep the verification.
(Condensed) implementation:
unit Exceptions;
interface
uses
System.SysUtils;
type
EException = class (Exception)
public
class constructor Create;
constructor Create(const Msg: String; const AcquireInnerException: Boolean = True);
constructor CreateFmt(const Msg: String; const Args: array of const; const AcquireInnerException: Boolean = True); overload;
constructor CreateRes(const Msg: PResStringRec; const AcquireInnerException: Boolean = True);
constructor CreateResFmt(const Msg: PResStringRec; const Args: array of const; const AcquireInnerException: Boolean = True); overload;
end;
type
ExceptionFields = class (TObject)
{$Hints Off} // H2219
strict private
FMessage: String;
FHelpContext: Integer;
FInnerException: Exception;
FStackInfo: Pointer;
{$Hints On}
public
FAcquireInnerException: Boolean;
private
class procedure VerifyFieldAlignments;
end;
implementation
uses
System.Generics.Collections,
System.RTTI,
System.TypInfo;
{ ExceptionFields }
class procedure ExceptionFields.VerifyFieldAlignments;
procedure RaiseTypeNotFound(const ClassName: String);
begin
raise Exception.CreateFmt(
'Typ nicht gefunden: %s',
[ClassName]
);
end;
procedure RaiseFieldNotFound(const ClassName, FieldName: String);
begin
raise Exception.CreateFmt(
'Feld nicht gefunden: %s.%s',
[ClassName, FieldName]
);
end;
procedure RaiseFieldNotAligned(const LeftClassName: String; const LeftField: TPair<String, Integer>; const RightClassName: String; const RightField: TRTTIField);
begin
raise Exception.CreateFmt(
'Feld nicht ausgerichtet: %s.%s+%d (tatsächlich) vs. %s.%s+%d (erwartet)',
[
LeftClassName,
LeftField.Key,
LeftField.Value,
RightClassName,
RightField.Name,
RightField.Offset
]
);
end;
type
TMemberVisibilities = set of TMemberVisibility;
function GetDeclaredFields(const RTTIContext: TRTTIContext; const &Class: TClass; const IncludedVisibilities: TMemberVisibilities = [mvPublic, mvPublished]): TArray<TPair<String, Integer>>;
var
RTTIType: TRTTIType;
RTTIFields: TArray<TRTTIField>;
Index: NativeInt;
RTTIField: TRTTIField;
begin
RTTIType := RTTIContext.GetType(&Class);
if not Assigned(RTTIType) then
RaiseTypeNotFound(&Class.ClassName);
RTTIFields := RTTIType.GetDeclaredFields;
SetLength(Result, Length(RTTIFields));
Index := 0;
for RTTIField in RTTIFields do
if RTTIField.Visibility in IncludedVisibilities then
begin
Result[Index] := TPair<String, Integer>.Create(
RTTIField.Name,
RTTIField.Offset
);
Inc(Index);
end;
SetLength(Result, Index);
end;
const
Left: TClass = ExceptionFields;
Right: TClass = Exception;
var
RTTIContext: TRTTIContext;
DeclaredFields: TArray<TPair<String, Integer>>;
RTTIType: TRTTIType;
DeclaredField: TPair<String, Integer>;
RTTIField: TRTTIField;
begin
RTTIContext := TRTTIContext.Create;
try
DeclaredFields := GetDeclaredFields(RTTIContext, Left);
RTTIType := RTTIContext.GetType(Right);
if not Assigned(RTTIType) then
RaiseTypeNotFound(Right.ClassName);
for DeclaredField in DeclaredFields do
begin
RTTIField := RTTIType.GetField(DeclaredField.Key);
if not Assigned(RTTIField) then
RaiseFieldNotFound(Right.ClassName, DeclaredField.Key);
if DeclaredField.Value <> RTTIField.Offset then
RaiseFieldNotAligned(
Left.ClassName, DeclaredField,
RTTIType.Name, RTTIField
);
end;
finally
RTTIContext.Free;
end;
end;
{ EException }
class constructor EException.Create;
begin
inherited;
ExceptionFields.VerifyFieldAlignments;
end;
constructor EException.Create(const Msg: String;
const AcquireInnerException: Boolean);
begin
inherited Create(Msg);
ExceptionFields(Self).FAcquireInnerException := AcquireInnerException;
end;
constructor EException.CreateFmt(const Msg: String;
const Args: array of const;
const AcquireInnerException: Boolean);
begin
inherited CreateFmt(Msg, Args);
ExceptionFields(Self).FAcquireInnerException := AcquireInnerException;
end;
constructor EException.CreateRes(const Msg: PResStringRec;
const AcquireInnerException: Boolean);
begin
inherited CreateRes(Msg);
ExceptionFields(Self).FAcquireInnerException := AcquireInnerException;
end;
constructor EException.CreateResFmt(const Msg: PResStringRec;
const Args: array of const;
const AcquireInnerException: Boolean);
begin
inherited CreateResFmt(Msg, Args);
ExceptionFields(Self).FAcquireInnerException := AcquireInnerException;
end;
end.
And a demo:
program ExceptionsDemo;
{$AppType Console}
{$R *.res}
uses
System.SysUtils,
Exceptions in 'Exceptions.pas';
type
EDemoException = class (EException)
end;
begin
try
try
try
raise EZeroDivide.Create('Level 3');
except
raise EException.Create('Level 2', False);
end;
except
raise EDemoException.Create('Level 1');
end;
except
on E: Exception do
begin
WriteLn(E.ClassName, ': ', E.Message);
while Assigned(E.InnerException) do
begin
E := E.InnerException;
WriteLn(E.ClassName, ': ', E.Message);
end;
end;
end;
ReadLn;
end.
Output -- the last line is only there on raise EException.Create('Level 2', True):
EDemoException: Level 1
EException: Level 2
EZeroDivide: Level 3
Thank you to all repliers!
I have two procedures that almost identical the only difference is the data type of one of the parameters.
procedure InsertNewStringAnswer(AidQuestion: Integer; AAnswer: String);
and
procedure InsertNewBoolAnswer(AidQuestion: Integer; AAnswer: Boolean);
I need to change the answer type based on the question. Do I have to write two procedures and call them with a third or is there a way I can change the data type of the parameter AAnswer at runtime?
I am editing this to show How I build the solution. In this case I used Variant type. I cannot verify if this is best practice but it works:).
procedure InsertNewAnswer(AidQuestion: Integer; AAnswer: Variant);
var
idNextRecord: string;
isBoolean: Boolean;
StrAAnswer: String;
BoolAAnswer: Boolean;
begin
With Connection.queryMain Do
begin
SQL.Clear;
SQL.Text := 'select count(*) as summe from dbo.Answer';
Open;
end;
idNextRecord := Connection.queryMain.FieldByName('summe').Asstring;
With Connection.queryMain Do
begin
SQL.Clear;
//Here I check if the question has a boolean or string answer.
SQL.Text :=('select isBool from dbo.Questions AS ISBOOL WHERE idQuestion= :SQLAidQuestion;');
ParamByName('SQLAidQuestion').AsInteger := AidQuestion;
Prepare;
Open;
end;
//and write it to a Variable.
isBoolean := Connection.queryMain.FieldByName('isBool').AsBoolean;
Connection.queryMain.SQL.Clear;
//I then use a if statement to change the Variant Type accordingly
if isBoolean = True then
begin
//Note that System.Variants does not have VarToBool so I use a workaround
BoolAAnswer := StrToBool(VarToStr(AAnswer));
AAnswer := BoolAAnswer;
Connection.queryMain.SQL.Text :=
('INSERT INTO Frueherkennung.dbo.Answer' +
'(idAnswer, idQuestion, Answer)VALUES(' + idNextRecord +
', :sqlQuestion, :sqlAAnswer);');
Connection.queryMain.ParamByName('sqlQuestion').AsInteger := AidQuestion;
Connection.queryMain.ParamByName('sqlAAnswer').AsBoolean := AAnswer;
end
else
begin
StrAAnswer := VarToStr(AAnswer);
MessageDlg('iSBool:= False', mtError, [mbok], 0);
AAnswer := StrAAnswer;
Connection.queryMain.SQL.Text :=('INSERT INTO Frueherkennung.dbo.Answer' +
'(idAnswer, idQuestion, Answer)VALUES(' + idNextRecord +
', :sqlQuestion, :sqlAAnswer);');
Connection.queryMain.ParamByName('sqlQuestion').AsInteger := AidQuestion;
Connection.queryMain.ParamByName('sqlAAnswer').Asstring := AAnswer
end;
With Connection.queryMain Do
begin
Prepare;
Execute;
SQL.Clear;
end;
end;
Thank you everyone for your awesome answers.
You can write a single function if the AAnswer argument is of type variant which allows almost anything in it.
You can also keep two procedures but with same name using the overload keyword.
And you can also have a single procedure taking AAnswer as untyped pointer to the storage the caller want to use. Of course at that moment, the question must contain the necessary information to decide if the point point to a boolean or to a string.
This last option is really not recommended. For me the cleanest solution is using overloaded procedures.
Forgot another possibility: use AAnswer of type array of const.
Sounds like a job for Generics.
In XE7 and later, you can do this:
type
TQuestion = class
public
class procedure InsertNewAnswer<T>(AidQuestion: Integer; AAnswer: T);
end;
class procedure TQuestion.InsertNewAnswer<T>(AidQuestion: Integer; AAnswer: T);
begin
case GetTypeKind(T) of
tkString, tkLString, tkUString, tkWString:
InsertNewStringAnswer(AidQuestion, AAnswer);
tkEnumeration:
if GetTypeData(TypeInfo(T))^.BaseType^ = TypeInfo(Boolean) then
InsertNewBoolAnswer(AidQuestion, PBoolean(#AAnswer)^);
...
end;
end;
Prior to XE7, you can do this instead:
type
TQuestion = class
public
class procedure InsertNewAnswer<T>(AidQuestion: Integer; AAnswer: T);
end;
...
uses
..., TypInfo;
class procedure TQuestion.InsertNewAnswer<T>(AidQuestion: Integer; AAnswer: T);
begin
case PTypeInfo(TypeInfo(T)).Kind of
tkString:
InsertNewStringAnswer(AidQuestion, PShortString(#AAnswer)^);
tkLString:
InsertNewStringAnswer(AidQuestion, PAnsiString(#AAnswer)^);
tkUString:
InsertNewStringAnswer(AidQuestion, PUnicodeString(#AAnswer)^);
tkWString:
InsertNewStringAnswer(AidQuestion, PWideString(#AAnswer)^);
tkEnumeration:
if GetTypeData(TypeInfo(T))^.BaseType^ = TypeInfo(Boolean) then
InsertNewBoolAnswer(AidQuestion, PBoolean(#AAnswer)^);
...
end;
end;
Either way, you can then call it like this:
TQuestion.InsertNewAnswer<String>(id, '...');
TQuestion.InsertNewAnswer<Boolean>(id, true);
...
I am using an in-memory TClientDataSet with a TStringField column which contains folders path (Delphi 7).
When I create an index on this column the order is not what I am looking for.
As an example I get :
c:\foo
c:\fôo\a
c:\foo\b
when I would like this order :
c:\foo
c:\foo\b
c:\fôo\a
So I searched a way to use my own compare field function.
Based on this RRUZ answer How to change the implementation (detour) of an externally declared function I tried the following :
type
TClientDataSetHelper = class(DBClient.TClientDataSet);
...
MyCDS : TClientDataSet;
...
// My custom compare field function
function FldCmpHack
(
iFldType : LongWord;
pFld1 : Pointer;
pFld2 : Pointer;
iUnits1 : LongWord;
iUnits2 : LongWord
): Integer; stdcall;
begin
// Just to test
Result := -1;
end;
...
---RRUZ code here---
...
procedure HookDataCompare;
begin
HookProc
(
(MyCDs as TClientDataSetHelper).DSBase.FldCmp, <== do not compile !!!
#FldCmpHack,
FldCmpBackup
);
end;
When I try to compile I get an error (MyCDs as TClientDataSetHelper).DSBase.FldCmp : not enough actual parameters
I do not understand why this does not compile. Could you please help me ?
Is it even possible to "detour" IDSBase.FldCmp in DSIntf.pas ? Am i totally wrong ?
Thank you
EDIT
Finally, thanks to Dsm answer, I transformed the TStringFieldcolumn into a TVarBytesField in order to avoid doubling the buffer. Plus, when a TVarBytesField is indexed the order is based on the bytes value so I get the order I want. For having all child folders after a parent folder and before the next parent folder (c:\foo.new after c:\foo\b), I patched TVarBytesFieldlike this :
TVarBytesField = class(DB.TVarBytesField)
protected
function GetAsString: string; override;
procedure GetText(var Text: string; DisplayText: Boolean); override;
procedure SetAsString(const Value: string); override;
end;
function TVarBytesField.GetAsString: string;
var
vBuffer : PAnsiChar;
vTaille : WORD;
vTexte : PAnsiChar;
vI : WORD;
begin
Result := '';
GetMem(vBuffer, DataSize);
try
if GetData(vBuffer) then
begin
vTaille := PWORD(vBuffer)^;
vTexte := vBuffer + 2;
SetLength(Result, vTaille);
for vI := 1 to vTaille do
begin
if vTexte^ = #2 then
begin
Result[vI] := '\';
end
else
begin
Result[vI] := vTexte^;
end;
Inc(vTexte);
end;
end;
finally
FreeMem(vBuffer);
end;
end;
procedure TVarBytesField.GetText(var Text: string; DisplayText: Boolean);
begin
Text := GetAsString;
end;
procedure TVarBytesField.SetAsString(const Value: string);
var
vBuffer : PAnsiChar;
vTaille : WORD;
vTexte : PAnsiChar;
vI : WORD;
begin
vBuffer := AllocMem(DataSize);
try
vTaille := WORD(Length(Value));
PWORD(vBuffer)^ := vTaille;
vTexte := vBuffer + 2;
for vI := 1 to vTaille do
begin
if Value[vI] = '\' then
begin
vTexte^ := #2
end
else
begin
vTexte^ := Value[vI];
end;
Inc(vTexte);
end;
SetData(vBuffer);
finally
FreeMem(vBuffer);
end;
end;
The message is telling you that FldCmp is a function, and it is expecting you to execute it, but it has not got enough parameters. I am sure that you already realised that and probably already tried to get the address of the function with the # (like you do for FldCmpHack) and found that that does not work.
The reason for that is, I am afraid, that FldCmp is not a normal function. DSBase is actually an interface, which will have been assigned (looking at the source code) by a class factory. What you actually need is the real function itself and for that you need the real object that the class factory creates. And I am sorry, but I can't see any realistic way of doing that.
However, the DSBase field is only created if it has not been assigned, so you could, in theory, create your own IDSBase interface object, which is the way this type of problem is meant to be handled. That is a lot of work, though, unless you know class that the class factory produces and can descend from that.
A sneakier alternative is to override the Translate property and create some sort of hash (perhaps by translating the ASCII codes to their HEX values) so that the database keeps them in the right order
TClientDataSetHelper = class(TClientDataSet)
public
function Translate(Src, Dest: PAnsiChar; ToOem: Boolean): Integer; override;
end;
The code below is from the JSonMarshall project in chapter 7 of Marco Cantu's Delphi 2010 Handbook. The source code is available from here http://cc.embarcadero.com/item/27600. I have made two changes to it:
Add JSon to the implementation Uses clause to get it to compile.
Added the line
theName := 'XXX'; // added by me
to the TDataWithList.Create constructor to assist debugging
I am running the code in Delphi Seattle (without update 1)
The purpose of the project is to demo a custom converter and reverter for the TDataWithList declared type. The custom converter seems to work fine, judging by the result output to Memo1.
However, attempting to run the reverter results in a "Read of address 00000000" AV on the line
sList.Add (Args[I]);
in btnUnmarshalReverterClick. The immediate cause of this is that contrary to what
the author evidently intended, when the above line executes, sList is Nil.
My question is simply why is sList Nil and how to fix this problem?
I have tried, not entirely successfully, to trace through the DBXJSONReflect source
to find out why.
After
Obj := ObjectInstance(FRTTICtx, objType);
in function TJSONUnMarshal.CreateObject, TDataWithList(obj).theName is 'XXX'
as I'd expect and TDataWithList(obj).theLList is an initialized, but empty,
TStringList.
However, by the time the anonymous method in btnUnmarshalReverterClick is called, TDataWithList(Data).theList is Nil.
Update: The reason that TDataWithList(Data).theList (incorrectly, imo) becomes Nil is that it is set to Nil in TJSONPopulationCustomizer.PrePopulate by a call to PrePopulateObjField. So I suppose the question is, why does PrePopulate allow an object's field which has been initialized in its constructor to be overwritten as if it knows better that the object's constructor.
Update2:
There may be an additional problem, in that as far as I can tell, in
TInternalJSONPopulationCustomizer.PrePopulateObjField, the assignment which overwrites TListWithData.theList with Nil, namely
rttiField.SetValue(Data, TValue.Empty);
does not seem to result in the TStringlist destructor being called.
Btw, I get the same error running the project in XE4, which is the earliest version I have which includes JSonUnMarshal.
Code:
type
[...]
TDataWithList = class
private
theName: String;
theList: TStringList;
public
constructor Create (const aName: string); overload;
constructor Create; overload;
function ToString: string; override;
destructor Destroy; override;
end;
[...]
procedure TFormJson.btnMarshalConverterClick(Sender: TObject);
var
theData: TDataWithList;
jMarshal: TJSONMarshal;
jValue: TJSONValue;
begin
theData := TDataWithList.Create('john');
try
jMarshal := TJSONMarshal.Create(
TJSONConverter.Create); // converter is owned
try
jMarshal.RegisterConverter(TDataWithList, 'theList',
function (Data: TObject; Field: string): TListOfStrings
var
I: Integer;
sList: TStringList;
begin
sList := TDataWithList(Data).theList;
SetLength(Result, sList.Count);
for I := 0 to sList.Count - 1 do
Result[I] := sList[I];
end);
jValue := jMarshal.Marshal(theData);
try
Memo1.Lines.Text := jValue.ToString;
finally
jValue.Free;
end;
finally
jMarshal.Free;
end;
finally
theData.Free;
end;
end;
procedure TFormJson.btnUnmarshalReverterClick(Sender: TObject);
var
jUnmarshal: TJSONUnMarshal;
jValue: TJSONValue;
anObject: TObject;
begin
jValue := TJSONObject.ParseJSONValue(
TEncoding.ASCII.GetBytes (Memo1.Lines.Text), 0);
try
jUnmarshal := TJSONUnMarshal.Create;
try
jUnmarshal.RegisterReverter(TDataWithList, 'theList',
procedure (Data: TObject; Field: string; Args: TListOfStrings)
var
I: Integer;
sList: TStringList;
begin
sList := TDataWithList(Data).theList;
for I := 0 to Length(Args) - 1 do
sList.Add (Args[I]);
end);
anObject := jUnmarshal.Unmarshal(jValue);
try
ShowMessage ('Class: ' + anObject.ClassName +
sLineBreak + anObject.ToString);
finally
anObject.Free;
end;
finally
jUnmarshal.Free;
end;
finally
jValue.Free;
end;
end;
function TMyData.ToString: string;
begin
Result := theName + ':' + IntToStr (theValue);
end;
{ TDataWithList }
constructor TDataWithList.Create(const aName: string);
var
I: Integer;
begin
theName := aName;
theList := TStringList.Create;
for I := 0 to 9 do
theList.Add(IntToStr (Random (1000)));
end;
constructor TDataWithList.Create;
begin
// core initialization, used for default construction
theName := 'XXX'; // added by me
theList := TStringList.Create;
end;
destructor TDataWithList.Destroy;
begin
theList.Free;
inherited;
end;
function TDataWithList.ToString: string;
begin
Result := theName + sLineBreak + theList.Text;
end;
rttiField.SetValue(Data, TValue.Empty); simply overrides the field value because as the name implies it's a field, not a property with get / set methods. The destructor of TStringList is not called due to simple pointer assignment.
The solution here is to declare a property:
TDataWithList = class
...
strict private
theList: TStringList;
...
public
property Data: TStringList read ... write SetData
...
end;
TDataWithList.SetData(TStringList aValue);
begin
theList.Assign(aValue);
end;
I have a huge file that I must parse line by line. Speed is of the essence.
Example of a line:
Token-1 Here-is-the-Next-Token Last-Token-on-Line
^ ^
Current Position
Position after GetToken
GetToken is called, returning "Here-is-the-Next-Token" and sets the CurrentPosition to the position of the last character of the token so that it is ready for the next call to GetToken. Tokens are separated by one or more spaces.
Assume the file is already in a StringList in memory. It fits in memory easily, say 200 MB.
I am worried only about the execution time for the parsing. What code will produce the absolute fastest execution in Delphi (Pascal)?
Use PChar incrementing for speed of processing
If some tokens are not needed, only copy token data on demand
Copy PChar to local variable when actually scanning through characters
Keep source data in a single buffer unless you must handle line by line, and even then, consider handling line processing as a separate token in the lexer recognizer
Consider processing a byte array buffer that has come straight from the file, if you definitely know the encoding; if using Delphi 2009, use PAnsiChar instead of PChar, unless of course you know the encoding is UTF16-LE.
If you know that the only whitespace is going to be #32 (ASCII space), or a similarly limited set of characters, there may be some clever bit manipulation hacks that can let you process 4 bytes at a time using Integer scanning. I wouldn't expect big wins here though, and the code will be as clear as mud.
Here's a sample lexer that should be pretty efficient, but it assumes that all source data is in a single string. Reworking it to handle buffers is moderately tricky due to very long tokens.
type
TLexer = class
private
FData: string;
FTokenStart: PChar;
FCurrPos: PChar;
function GetCurrentToken: string;
public
constructor Create(const AData: string);
function GetNextToken: Boolean;
property CurrentToken: string read GetCurrentToken;
end;
{ TLexer }
constructor TLexer.Create(const AData: string);
begin
FData := AData;
FCurrPos := PChar(FData);
end;
function TLexer.GetCurrentToken: string;
begin
SetString(Result, FTokenStart, FCurrPos - FTokenStart);
end;
function TLexer.GetNextToken: Boolean;
var
cp: PChar;
begin
cp := FCurrPos; // copy to local to permit register allocation
// skip whitespace; this test could be converted to an unsigned int
// subtraction and compare for only a single branch
while (cp^ > #0) and (cp^ <= #32) do
Inc(cp);
// using null terminater for end of file
Result := cp^ <> #0;
if Result then
begin
FTokenStart := cp;
Inc(cp);
while cp^ > #32 do
Inc(cp);
end;
FCurrPos := cp;
end;
Here is a lame ass implementation of a very simple lexer. This might give you an idea.
Note the limitations of this example - no buffering involved, no Unicode (this is an excerpt from a Delphi 7 project). You would probably need those in a serious implementation.
{ Implements a simpe lexer class. }
unit Simplelexer;
interface
uses Classes, Sysutils, Types, dialogs;
type
ESimpleLexerFinished = class(Exception) end;
TProcTableProc = procedure of object;
// A very simple lexer that can handle numbers, words, symbols - no comment handling
TSimpleLexer = class(TObject)
private
FLineNo: Integer;
Run: Integer;
fOffset: Integer;
fRunOffset: Integer; // helper for fOffset
fTokenPos: Integer;
pSource: PChar;
fProcTable: array[#0..#255] of TProcTableProc;
fUseSimpleStrings: Boolean;
fIgnoreSpaces: Boolean;
procedure MakeMethodTables;
procedure IdentProc;
procedure NewLineProc;
procedure NullProc;
procedure NumberProc;
procedure SpaceProc;
procedure SymbolProc;
procedure UnknownProc;
public
constructor Create;
destructor Destroy; override;
procedure Feed(const S: string);
procedure Next;
function GetToken: string;
function GetLineNo: Integer;
function GetOffset: Integer;
property IgnoreSpaces: boolean read fIgnoreSpaces write fIgnoreSpaces;
property UseSimpleStrings: boolean read fUseSimpleStrings write fUseSimpleStrings;
end;
implementation
{ TSimpleLexer }
constructor TSimpleLexer.Create;
begin
makeMethodTables;
fUseSimpleStrings := false;
fIgnoreSpaces := false;
end;
destructor TSimpleLexer.Destroy;
begin
inherited;
end;
procedure TSimpleLexer.Feed(const S: string);
begin
Run := 0;
FLineNo := 1;
FOffset := 1;
pSource := PChar(S);
end;
procedure TSimpleLexer.Next;
begin
fTokenPos := Run;
foffset := Run - frunOffset + 1;
fProcTable[pSource[Run]];
end;
function TSimpleLexer.GetToken: string;
begin
SetString(Result, (pSource + fTokenPos), Run - fTokenPos);
end;
function TSimpleLexer.GetLineNo: Integer;
begin
Result := FLineNo;
end;
function TSimpleLexer.GetOffset: Integer;
begin
Result := foffset;
end;
procedure TSimpleLexer.MakeMethodTables;
var
I: Char;
begin
for I := #0 to #255 do
case I of
'#', '&', '}', '{', ':', ',', ']', '[', '*',
'^', ')', '(', ';', '/', '=', '-', '+', '#', '>', '<', '$',
'.', '"', #39:
fProcTable[I] := SymbolProc;
#13, #10: fProcTable[I] := NewLineProc;
'A'..'Z', 'a'..'z', '_': fProcTable[I] := IdentProc;
#0: fProcTable[I] := NullProc;
'0'..'9': fProcTable[I] := NumberProc;
#1..#9, #11, #12, #14..#32: fProcTable[I] := SpaceProc;
else
fProcTable[I] := UnknownProc;
end;
end;
procedure TSimpleLexer.UnknownProc;
begin
inc(run);
end;
procedure TSimpleLexer.SymbolProc;
begin
if fUseSimpleStrings then
begin
if pSource[run] = '"' then
begin
Inc(run);
while pSource[run] <> '"' do
begin
Inc(run);
if pSource[run] = #0 then
begin
NullProc;
end;
end;
end;
Inc(run);
end
else
inc(run);
end;
procedure TSimpleLexer.IdentProc;
begin
while pSource[Run] in ['_', 'A'..'Z', 'a'..'z', '0'..'9'] do
Inc(run);
end;
procedure TSimpleLexer.NumberProc;
begin
while pSource[run] in ['0'..'9'] do
inc(run);
end;
procedure TSimpleLexer.SpaceProc;
begin
while pSource[run] in [#1..#9, #11, #12, #14..#32] do
inc(run);
if fIgnoreSpaces then Next;
end;
procedure TSimpleLexer.NewLineProc;
begin
inc(FLineNo);
inc(run);
case pSource[run - 1] of
#13:
if pSource[run] = #10 then inc(run);
end;
foffset := 1;
fRunOffset := run;
end;
procedure TSimpleLexer.NullProc;
begin
raise ESimpleLexerFinished.Create('');
end;
end.
I made a lexical analyser based on a state engine (DFA). It works with a table and is pretty fast. But there are possible faster options.
It also depends on the language. A simple language can possibly have a smart algorithm.
The table is an array of records each containing 2 chars and 1 integer. For each token the lexer walks through the table, startting at position 0:
state := 0;
result := tkNoToken;
while (result = tkNoToken) do begin
if table[state].c1 > table[state].c2 then
result := table[state].value
else if (table[state].c1 <= c) and (c <= table[state].c2) then begin
c := GetNextChar();
state := table[state].value;
end else
Inc(state);
end;
It is simple and works like a charm.
If speed is of the essence, custom code is the answer. Check out the Windows API that will map your file into memory. You can then just use a pointer to the next character to do your tokens, marching through as required.
This is my code for doing a mapping:
procedure TMyReader.InitialiseMapping(szFilename : string);
var
// nError : DWORD;
bGood : boolean;
begin
bGood := False;
m_hFile := CreateFile(PChar(szFilename), GENERIC_READ, 0, nil, OPEN_EXISTING, 0, 0);
if m_hFile <> INVALID_HANDLE_VALUE then
begin
m_hMap := CreateFileMapping(m_hFile, nil, PAGE_READONLY, 0, 0, nil);
if m_hMap <> 0 then
begin
m_pMemory := MapViewOfFile(m_hMap, FILE_MAP_READ, 0, 0, 0);
if m_pMemory <> nil then
begin
htlArray := Pointer(Integer(m_pMemory) + m_dwDataPosition);
bGood := True;
end
else
begin
// nError := GetLastError;
end;
end;
end;
if not bGood then
raise Exception.Create('Unable to map token file into memory');
end;
I think the biggest bottleneck is always going to be getting the file into memory. Once you have it in memory (obviously not all of it at once, but I would work with buffers if I were you), the actual parsing should be insignificant.
This begs another question - How big?
Give us a clue like # of lines or # or Mb (Gb)?
Then we will know if it fits in memory, needs to be disk based etc.
At first pass I would use my WordList(S: String; AList: TStringlist);
then you can access each token as Alist[n]...
or sort them or whatever.
Speed will always be relative to what you are doing once it is parsed. A lexical parser by far is the fastest method of converting to tokens from a text stream regardless of size. TParser in the classes unit is a great place to start.
Personally its been a while since I needed to write a parser, but another more dated yet tried and true method would be to use LEX/YACC to build a grammar then have it convert the grammar into code you can use to perform your processing. DYacc is a Delphi version...not sure if it still compiles or not, but worth a look if you want to do things old school. The dragon book here would be of big help, if you can find a copy.
Rolling your own is the fastest way for sure. For more on this topic, you could see Synedit's source code which contains lexers (called highlighters in the project's context) for about any language on the market. I suggest you take one of those lexers as a base and modify for your own usage.
The fastest way to write the code would probably be to create a TStringList and assign each line in your text file to the CommaText property. By default, white space is a delimiter, so you will get one StringList item per token.
MyStringList.CommaText := s;
for i := 0 to MyStringList.Count - 1 do
begin
// process each token here
end;
You'll probably get better performance by parsing each line yourself, though.