jSon_encode like function for Delphi which accepts TDataSet - delphi

I have been tasked with creating a Indy server in Delphi 2007 which communicates with clients and returns json formatted data from Sql based databases. Someone from our office created a prototype using php. And in the prototype they use the jSon_encode function extensively to return the data from tables. I was wondering if there was a similar Delphi function which could accept a TDataSet parameter and return properly formatted json data.
Anyone know of such function?
Update 12/10/2013 - my modification to #user2748835 answer:
function jsonencode(mString: String): String;
begin
result := StringReplace(mString,'''','\''',[rfReplaceAll,rfIgnoreCase]);
result := StringReplace(mString,'\','\\',[rfReplaceAll,rfIgnoreCase]);
result := StringReplace(result,crlf,'\n',[rfReplaceAll,rfIgnoreCase]);
result := StringReplace(result,'"','\"',[rfReplaceAll,rfIgnoreCase]);
result := StringReplace(result,'/','\/',[rfReplaceAll,rfIgnoreCase]);
result := StringReplace(result,'#9','\t',[rfReplaceAll,rfIgnoreCase]);
end;
function jSon_encode(aDataset:TDataset):string;
function fieldToJSON(thisField:TField):string;
begin
try
result := '"'+thisField.fieldName+'":';
case thisField.DataType of
ftInteger,ftSmallint,ftLargeint:
result := result+inttostr(thisField.AsInteger);
ftDateTime:
result := result+'"'+formatdatetime('YYYY-MM-DD HH:NN:SS',thisField.AsDateTime)+'"';
ftCurrency,
ftFloat:
result := result + floattostr(thisField.AsFloat);
ftString :
result := result + '"'+jsonencode(thisField.AsString)+'"';
else
end; // case
result := result + ',';
except
on e: Exception do begin
appendtolog('problem escaping field '+thisfield.fieldname);
end;
end;
end; // of fieldToJSON
function rowToJSON(ds:TDataset):string;
var
fieldIx : integer;
begin
result := '';
for fieldIx := 0 to ds.fieldcount-1 do
result := result + fieldToJSON(ds.Fields[fieldIx]);
// trim comma after last col
result := '{'+copy(result,1,length(result)-1)+'},';
end; // of rowToJSON
begin
result := '';
with aDataset do
begin
if not bof then first;
while not eof do
begin
result := result + rowToJSON(aDataset);
next;
end;
end;
//strip last comma and add
if length(result)>0 then
result := copy(result,1,length(result)-1);
result := '['+result+']';
end; // of DSToJSON

In a TDataset, you can loop through the Fields collection and construct the json output and then in the loop, check the fieldtype and encode the value accordingly.
Something like:
uses db;
function DSToJSON(aDataset:TDataset):string;
function fieldToJSON(thisField:TField):string;
begin
result := '"'+thisField.fieldName+'":';
case thisField.DataType of
ftInteger,
ftSmallint,
ftCurrency,
ftFloat,
ftLargeInt:
result := result+thisField.value+^n^j;
ftString :
result := noSingleQuotes(thisField.value)+^n^j;
else
end; // case
end; // of fieldToJSON
function rowToJSON(ds:TDataset):string;
var
fieldIx : integer;
begin
for fieldIx := 0 to ds.fieldcount-1 do
result := result + fieldToJSON(ds.Fields[fieldIx]);
// trim comma after last col
result := '{'+copy(result,1,length(result)-1)+'},';
end; // of rowToJSON
begin
result := '';
with aDataset do
begin
if not bof then first;
while not eof do
begin
result := result + rowToJSON(aDataset);
next;
end;
end;
//strip last comma and add
if length(result)>0 then
result := copy(result,1,length(result)-1);
result := '['+result+']';
end; // of DSToJSON

We just added a more complete and faster function, in our Open Source repository.
It is part of our mORMot framework, but can be used as a stand-alone unit, not tied to other features.
See in SynVirtualDataSet.pas:
function DataSetToJSON(Data: TDataSet): RawUTF8
See this commit and the associated forum thread.

You can change every row into object and use serializing http://docwiki.embarcadero.com/RADStudio/XE5/en/Serializing_User_Objects

Related

How to use the Filter functions of TClientdatasets for dates?

I have a TClientDataSet in Delphi 7 and I'd like to apply a filter which I type into a simple TEdit, so it looks like this:
CDS.Filter:=Edit1.Text;
CDS.Filtered:=True;
Now I looked at the Helpfile for filtering records
and according to it I should be able to Filter DateTime-Fields as well.
But whenever I write something like this into my Edit:
DAY(EDATUM)=17
and apply the filter I get a "Type Mismatch in Expression"-Exception.
I have tried numerous different formats of the example above.
DATE(DAY(EDATUM))=DATE(DAY(17)) //Doesn't work
DAY(EDATUM)='17' //Doesn't work
DAY(EDATUM)=DAY(17) //Doesn't work
DAY(EDATUM)=DAY(DATE('17.09.2016'))
...
...
the only one that works is
EDATUM='17.09.2016' //Works
But I want to filter on Days months and years seperately and not have them together in a string.
Nothing I found online elsewhere worked either.
Any Idea what I'm doing wrong?
Edatum is a TimeStamp in a Firebird 1.5 Database.
If you want to use a Filter expression instead of an OnFilterRecord handler, it is worthwhile taking a look at the source of the TExprParser class, which is what TClientDataSet uses for textual filters. It is contained in the DBCommon.Pas unit file in your Delphi source. The D7 TExprParser supports the following functions:
function TExprParser.TokenSymbolIsFunc(const S: string) : Boolean;
begin
Result := (CompareText(S, 'UPPER') = 0) or
(CompareText(S, 'LOWER') = 0) or
[...]
(CompareText(S, 'YEAR') = 0) or
(CompareText(S, 'MONTH') = 0) or
(CompareText(S, 'DAY') = 0) or
[...]
end;
Btw, it is worthwhile looking through the rest of TExprParser's source because it reveals things like support for the IN construct found in SQL.
On my (UK) system, dates display in a DBGrid as dd/mm/yyyy. Given that, all of the filter expressions shown below work in D7 without producing an exception and return the expected results:
procedure TForm1.Button1Click(Sender: TObject);
begin
// ADate field of CDS is initialised by
// CDS1.FieldByName('ADate').AsDateTime := Now - random(365);
edFilter.Text := 'ADate = ''10/2/2017'''; // works, date format = dd/mm/yyyy
edFilter.Text := 'Month(ADate) = 2'; // works
edFilter.Text := 'Year(ADate) = 2017'; // works
edFilter.Text := '(Day(ADate) = 10) and (Year(ADate) = 2017)'; // works
CDS1.Filtered := False;
CDS1.Filter := edFilter.Text;
CDS1.Filtered := True;
end;
If you don't get similar results, I'd suggest you start by looking at your regional settings and how dates are displayed in a TDBGrid.
Filter expressions are not particularly efficient compared to the alternative method of filtering, namely to use the OnFilterRecord event.
In the event handler, you can use e.g. DecodeDateTime to decode it into its Year, Month, Day, etc components and apply whatever tests you like to their values. Then set Accept to True or False.
Update I gather from your comment to an answer here
Delphi: check if Record of DataSet is visible or filtered
that the problem you had with this was that the date functions supported by
TExprParser.TokenSymbolIsFunc() are not in your user's language.
You can use the code below to translate the date function names in the filter expression.
See the embedded comments for explanation of how it works
type
TForm1 = class(TForm)
[...]
public
NameLookUp : TStringList;
[...]
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
NameLookUp := TStringList.Create;
// Assume Y, M & C are the local-language names
NameLookUp.Add('Y=Year');
NameLookUp.Add('M=Month');
NameLookUp.Add('D=Day');
[...]
end;
procedure TForm1.Log(const Title, Msg : String);
begin
Memo1.Lines.Add(Title + ' : ' + Msg);
end;
function TForm1.TranslateExpression(const Input : String; ADataSet : TDataSet) : String;
var
SS : TStringStream;
TokenText : String;
LookUpText : String;
Parser : TParser;
CH : Char;
begin
SS := TStringStream.Create(Input);
Parser := TParser.Create(SS);
Result := '';
try
CH := Parser.Token;
// following translates Input by parsing it using TParser from Classes.Pas
while Parser.Token <> #0 do begin
TokenText := Parser.TokenString;
case CH of
toSymbol : begin
// The following will translate TokenText for symbols
// but only if TokenText is not a FieldName of ADataSet
if ADataSet.FindField(TokenText) = Nil then begin
LookUpText := NameLookUp.Values[TokenText];
if LookUpText <> '' then
Result := Result + LookUpText
else
Result := Result + TokenText;
end
else
Result := Result + TokenText;
end;
toString :
// SingleQuotes surrounding TokenText in Input and ones embedded in it
// will have been stripped, so reinstate the surrounding ones and
// double-up the embedded ones
Result := Result + '''' + StringReplace(TokenText, '''', '''''', [rfReplaceAll]) + '''';
else
Result := Result + TokenText;
end; { case }
if Result <> '' then
Result := Result + ' ';
CH := Parser.NextToken;
end;
finally
Parser.Free;
SS.Free;
end;
Log('TransResult', Result);
end;
procedure TForm1.btnSetFilterExprClick(Sender: TObject);
begin
// Following tested with e.g edFilter.Text =
// LastName = 'aaa' and Y(BirthDate) = 2000
UpdateFilter2;
end;
procedure TForm1.UpdateFilter2;
var
T1 : Integer;
begin
CDS1.OnFilterRecord := Nil;
T1 := GetTickCount;
CDS1.DisableControls;
try
CDS1.Filtered := False;
CDS1.Filter := TranslateExpression(edFilter.Text, CDS1);
if CDS1.Filter <> '' then begin
CDS1.Filtered := True;
end;
Log('Filter update time', IntToStr(GetTickCount - T1) + 'ms');
finally
CDS1.EnableControls;
end;
end;

Faster way to split text in Delphi TStringList

I have an app that needs to do heavy text manipulation in a TStringList. Basically i need to split text by a delimiter ; for instance, if i have a singe line with 1000 chars and this delimiter occurs 3 times in this line, then i need to split it in 3 lines. The delimiter can contain more than one char, it can be a tag like '[test]' for example.
I've wrote two functions to do this task with 2 different approaches, but both are slow in big amounts of text (more then 2mbytes usually).
How can i achieve this goal in a faster way ?
Here are both functions, both receive 2 paramaters : 'lines' which is the original tstringlist and 'q' which is the delimiter.
function splitlines(lines : tstringlist; q: string) : integer;
var
s, aux, ant : string;
i,j : integer;
flag : boolean;
m2 : tstringlist;
begin
try
m2 := tstringlist.create;
m2.BeginUpdate;
result := 0;
for i := 0 to lines.count-1 do
begin
s := lines[i];
for j := 1 to length(s) do
begin
flag := lowercase(copy(s,j,length(q))) = lowercase(q);
if flag then
begin
inc(result);
m2.add(aux);
aux := s[j];
end
else
aux := aux + s[j];
end;
m2.add(aux);
aux := '';
end;
m2.EndUpdate;
lines.text := m2.text;
finally
m2.free;
end;
end;
function splitLines2(lines : tstringlist; q: string) : integer;
var
aux, p : string;
i : integer;
flag : boolean;
begin
//maux1 and maux2 are already instanced in the parent class
try
maux2.text := lines.text;
p := '';
i := 0;
flag := false;
maux1.BeginUpdate;
maux2.BeginUpdate;
while (pos(lowercase(q),lowercase(maux2.text)) > 0) and (i < 5000) do
begin
flag := true;
aux := p+copy(maux2.text,1,pos(lowercase(q),lowercase(maux2.text))-1);
maux1.add(aux);
maux2.text := copy(maux2.text,pos(lowercase(q),lowercase(maux2.text)),length(maux2.text));
p := copy(maux2.text,1,1);
maux2.text := copy(maux2.text,2,length(maux2.text));
inc(i);
end;
finally
result := i;
maux1.EndUpdate;
maux2.EndUpdate;
if flag then
begin
maux1.add(p+maux2.text);
lines.text := maux1.text;
end;
end;
end;
I've not tested the speed, but for academic purposes, here's an easy way to split the strings:
myStringList.Text :=
StringReplace(myStringList.Text, myDelimiter, #13#10, [rfReplaceAll]);
// Use [rfReplaceAll, rfIgnoreCase] if you want to ignore case
When you set the Text property of TStringList, it parses on new lines and splits there, so converting to a string, replacing the delimiter with new lines, then assigning it back to the Text property works.
The problems with your code (at least second approach) are
You are constantly using lowecase which is slow if called so many times
If I saw correctly you are copying the whole remaining text back to the original source. This is sure to be extra slow for large strings (eg files)
I have a tokenizer in my library. Its not the fastest or best but it should do (you can get it from Cromis Library, just use the units Cromis.StringUtils and Cromis.Unicode):
type
TTokens = array of ustring;
TTextTokenizer = class
private
FTokens: TTokens;
FDelimiters: array of ustring;
public
constructor Create;
procedure Tokenize(const Text: ustring);
procedure AddDelimiters(const Delimiters: array of ustring);
property Tokens: TTokens read FTokens;
end;
{ TTextTokenizer }
procedure TTextTokenizer.AddDelimiters(const Delimiters: array of ustring);
var
I: Integer;
begin
if Length(Delimiters) > 0 then
begin
SetLength(FDelimiters, Length(Delimiters));
for I := 0 to Length(Delimiters) - 1 do
FDelimiters[I] := Delimiters[I];
end;
end;
constructor TTextTokenizer.Create;
begin
SetLength(FTokens, 0);
SetLength(FDelimiters, 0);
end;
procedure TTextTokenizer.Tokenize(const Text: ustring);
var
I, K: Integer;
Counter: Integer;
NewToken: ustring;
Position: Integer;
CurrToken: ustring;
begin
SetLength(FTokens, 100);
CurrToken := '';
Counter := 0;
for I := 1 to Length(Text) do
begin
CurrToken := CurrToken + Text[I];
for K := 0 to Length(FDelimiters) - 1 do
begin
Position := Pos(FDelimiters[K], CurrToken);
if Position > 0 then
begin
NewToken := Copy(CurrToken, 1, Position - 1);
if NewToken <> '' then
begin
if Counter > Length(FTokens) then
SetLength(FTokens, Length(FTokens) * 2);
FTokens[Counter] := Trim(NewToken);
Inc(Counter)
end;
CurrToken := '';
end;
end;
end;
if CurrToken <> '' then
begin
if Counter > Length(FTokens) then
SetLength(FTokens, Length(FTokens) * 2);
FTokens[Counter] := Trim(CurrToken);
Inc(Counter)
end;
SetLength(FTokens, Counter);
end;
How about just using StrTokens from the JCL library
procedure StrTokens(const S: string; const List: TStrings);
It's open source
http://sourceforge.net/projects/jcl/
As an additional option, you can use regular expressions. Recent versions of Delphi (XE4 and XE5) come with built in regular expression support; older versions can find a free regex library download (zip file) at Regular-Expressions.info.
For the built-in regex support (uses the generic TArray<string>):
var
RegexObj: TRegEx;
SplitArray: TArray<string>;
begin
SplitArray := nil;
try
RegexObj := TRegEx.Create('\[test\]'); // Your sample expression. Replace with q
SplitArray := RegexObj.Split(Lines, 0);
except
on E: ERegularExpressionError do begin
// Syntax error in the regular expression
end;
end;
// Use SplitArray
end;
For using TPerlRegEx in earlier Delphi versions:
var
Regex: TPerlRegEx;
m2: TStringList;
begin
m2 := TStringList.Create;
try
Regex := TPerlRegEx.Create;
try
Regex.RegEx := '\[test\]'; // Using your sample expression - replace with q
Regex.Options := [];
Regex.State := [preNotEmpty];
Regex.Subject := Lines.Text;
Regex.SplitCapture(m2, 0);
finally
Regex.Free;
end;
// Work with m2
finally
m2.Free;
end;
end;
(For those unaware, the \ in the sample expression used are because the [] characters are meaningful in regular expressions and need to be escaped to be used in the regular expression text. Typically, they're not required in the text.)

out parameter and "ShowMessage" function

I have a function declare like this :
function execProc(ProcName,InValues:PChar;out OutValues:PChar):integer; //The "OutValues" is a out parameter.
And I call this function like this:
procedure TForm1.Button6Click(Sender: TObject);
var
v:integer;
s:pchar;
begin
Memo1.Clear;
v := execProc(pchar('PROC_TEST'),pchar('aaa'),s);
showmessage(inttostr(v)); //mark line
Memo1.Lines.Add(strpas(s));
end;
when i delete the mark line(showmessage(inttostr(v))),i will have a correct result display in the Memo1,but if i keep use the showmessage(), the memo1 will dispaly an error string : "Messag" ,Why?
Thanks for any help!
function execProc(ProcName,InValues:PChar;out OutValues:PChar):integer;
var
str: TStrings;
InValue,OutValue: string;
i,j,scount: integer;
begin
Result := -100;
i := 0;
j := 0;
str := TStringList.Create;
try
sCount := ExtractStrings(['|'], [], InValues, str);
with kbmMWClientStoredProc1 do
begin
Close;
Params.Clear;
StoredProcName := StrPas(ProcName);
FieldDefs.Updated := False;
FieldDefs.Update;
for i := 0 to Params.Count - 1 do
begin
if (Params[i].ParamType = ptUnknown) or
(Params[i].ParamType = ptInput) or
(Params[i].ParamType = ptInputOutput) then
begin
inc(j);
InValue := str[j-1];
Params[i].Value := InValue;
end;
end;
try
ExecProc;
for i := 0 to Params.Count - 1 do
begin
if (Params[i].ParamType = ptOutput) or
(Params[i].ParamType = ptInputOutput) then
OutValue := OutValue + '|' + Params[i].AsString;
end;
OutValues := PChar(Copy(OutValue,2,Length(OutValue)-1));
Result := 0;
except
on E:Exception do
begin
if E.Message = 'Connection lost.' then Result := -101;//服务器连接失败
if E.Message = 'Authorization failed.' then Result := -102;//身份验证失败
Writelog(E.Message);
end;
end;
end;
finally
str.Free;
end;
end;
The problem is in the design of your interface and the use of PChar.
OutValues := PChar(Copy(OutValue,2,Length(OutValue)-1));
This is implemented by making an implicit, hidden, local string variable which holds the value
Copy(OutValue,2,Length(OutValue)-1)
When the function returns, that string variable is destroyed and so OutValues points at deallocated memory. Sometimes your program appears to work but that's really just down to chance. Any small change can disturb that, as you have observed.
The problem is easy enough to fix. Simply use string parameters rather than PChar. This will make the code easier to read as well as making it work correctly.
function execProc(ProcName, InValues: string; out OutValues: string): integer;

Is there an way to pass a widestring to a TStringStream?

I have this Delphi function:
function DevuelveResumenEventos(cnnBBDD : TADOConnection;sFecha,sHora,sCtrlPac : string) : TStream;
var
sTextoArmado : string;
stCarga : TStringStream;
begin
with TADOTable.Create(Application.MainForm) do
try
sTextoArmado := '';
Connection := cnnBBDD;
TableName := 'EAPC_EVENTOS';
Filter := 'EAPC_FECHA = '+sFecha+' and EAPC_HORA = '+sHora+' and EAPC_CTRL_PAC = '+sCtrlPac;
Filtered := True;
Open;
while not Eof do
begin
sTextoArmado := sTextoArmado + FormatDateTime('dd-mm-yyyy', FieldValues['EAPC_FECHA_EVENTO'])+
' '+MinutsToStr(FieldValues['EAPC_HORA_EVENTO'])+
' ('+Trim(FieldValues['EAPC_LOGIN_USER'])+
') - '+FieldByName('EAPC_EVENTO').AsString+CRLF+CRLF;
Next;
end;
**stCarga := TStringStream.Create(sTextoArmado);
with TRichEdit.Create(Application.MainForm) do
begin
Parent := Application.MainForm;
Text := sTextoArmado;
Lines.SaveToStream(stCarga);
Free;
end;
finally
Close;
Free;
end;
Result := stCarga;**
end;
The intention is to retrieve a series of RTF formated texts, concatenate them with other texts and return them in a single TStringStream to be displayed in a TRichEdit in a form.
How can I skip the "use the on-the-fly RichEdit" and send the resulting texts as a TStringStream?

Convert a DevExpress TcxFilterOperatorKind to and from a string?

Here is a codesnippet I use to get filtertype operator from a filter in a DevExpress grid:
OperatorKindToStr is used to extract operatorkind from a filter as string and store it in a xml-file.
StrToOperatorKind is used to convert back a string from xml to set an operatorkind in a filter.
const
CUSTFILTER_FILTERITEM = 'FilterItem';
function OperatorKindToStr(const aOperatorKind: TcxFilterOperatorKind): string;
begin
Result := 'foEqual';
case aOperatorKind of
foEqual: Result := 'foEqual';
foNotEqual: Result := 'foNotEqual';
foLess: Result := 'foLess';
foLessEqual: Result := 'foLessEqual';
// Plus a boring list of other constants
end;
function StrToOperatorKind(const aOpKindStr: string): TcxFilterOperatorKind;
begin
Result := foEqual;
if aOpKindStr = 'foNotEqual' then
Result := foNotEqual
else if aOpKindStr = 'foLess' then
Result := foLess
else if aOpKindStr = 'foLessEqual' then
Result := foLessEqual
else if aOpKindStr = 'foGreater' then
Result := foGreater
else if aOpKindStr = 'foGreaterEqual' then
Result := foGreaterEqual
// Plus a boring list of other if-else
end;
procedure UseStrToOperatorKind(const aFilterItem: IXmlDomElement);
begin
if aFilterItem.nodeName = CUSTFILTER_FILTERITEM then
begin // It is an FilterItem
vStr := VarToStr(aFilterItem.getAttribute(CUSTFILTER_COLPROP)); // Get the columnname
vOperatorKind := StrToOperatorKind(aFilterItem.getAttribute(CUSTFILTER_ITEMOPERATOR));
end;
procedure UseOperatorKindToStr(const aFilterItem: TcxCustomFilterCriteriaItem);
var
vStr: String;
begin
if Supports(TcxFilterCriteriaItem(aFilterItem).ItemLink, TcxGridColumn, GridCol) then
vStr := OperatorKindToStr(TcxFilterCriteriaItem(aFilterItem).OperatorKind);
end;
Apparently I want the StrToOperatorKind and OperatorKindToStr to be a bit smarter.
I have tried GetEnumProp method in VCL TypeInfo but it won't work.
So how can I extract the TcxFilterOperatorKind property from a aFilterItem variable to a string and back to a TcxFilterOperatorKind ?
Use the GetEnumName and GetEnumValue duet as Mason pointed out.
And your functions should become much simpler:
function OperatorKindToStr(const aOperatorKind: TcxFilterOperatorKind): string;
begin
Result := GetEnumName(TypeInfo(TcxFilterOperatorKind), Ord(aOperatorKind));
end;
function StrToOperatorKind(const aOpKindStr: string): TcxFilterOperatorKind;
begin
Result := TcxFilterOperatorKind(GetEnumValue(TypeInfo(TcxFilterOperatorKind), aOpKindStr));
end;
GetEnumProp didn't work because it's the wrong function for what you're trying to do. You're close, though. Try GetEnumName and GetEnumValue, which are also in the TypInfo unit.

Resources