mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-12 14:09:17 +02:00
* Added webdata
git-svn-id: trunk@15334 -
This commit is contained in:
parent
ef213e67d6
commit
81648b6fbf
8
.gitattributes
vendored
8
.gitattributes
vendored
@ -2259,6 +2259,14 @@ packages/fcl-web/src/base/httpdefs.pp svneol=native#text/plain
|
|||||||
packages/fcl-web/src/base/webpage.pp svneol=native#text/plain
|
packages/fcl-web/src/base/webpage.pp svneol=native#text/plain
|
||||||
packages/fcl-web/src/base/websession.pp svneol=native#text/plain
|
packages/fcl-web/src/base/websession.pp svneol=native#text/plain
|
||||||
packages/fcl-web/src/base/webutil.pp svneol=native#text/plain
|
packages/fcl-web/src/base/webutil.pp svneol=native#text/plain
|
||||||
|
packages/fcl-web/src/webdata/Makefile svneol=native#text/plain
|
||||||
|
packages/fcl-web/src/webdata/Makefile.fpc svneol=native#text/plain
|
||||||
|
packages/fcl-web/src/webdata/extjsjson.pp svneol=native#text/plain
|
||||||
|
packages/fcl-web/src/webdata/extjsxml.pp svneol=native#text/plain
|
||||||
|
packages/fcl-web/src/webdata/fpextjs.pp svneol=native#text/plain
|
||||||
|
packages/fcl-web/src/webdata/fpwebdata.pp svneol=native#text/plain
|
||||||
|
packages/fcl-web/src/webdata/sqldbwebdata.pp svneol=native#text/plain
|
||||||
|
packages/fcl-web/src/webdata/webdata.txt svneol=native#text/plain
|
||||||
packages/fcl-web/tests/cgigateway.lpi svneol=native#text/plain
|
packages/fcl-web/tests/cgigateway.lpi svneol=native#text/plain
|
||||||
packages/fcl-web/tests/cgigateway.pp svneol=native#text/plain
|
packages/fcl-web/tests/cgigateway.pp svneol=native#text/plain
|
||||||
packages/fcl-web/tests/testcgiapp.lpi svneol=native#text/plain
|
packages/fcl-web/tests/testcgiapp.lpi svneol=native#text/plain
|
||||||
|
2904
packages/fcl-web/src/webdata/Makefile
Normal file
2904
packages/fcl-web/src/webdata/Makefile
Normal file
File diff suppressed because it is too large
Load Diff
26
packages/fcl-web/src/webdata/Makefile.fpc
Normal file
26
packages/fcl-web/src/webdata/Makefile.fpc
Normal file
@ -0,0 +1,26 @@
|
|||||||
|
#
|
||||||
|
# Makefile.fpc for FCL Web components
|
||||||
|
#
|
||||||
|
|
||||||
|
[package]
|
||||||
|
main=fcl-web
|
||||||
|
version=2.5.1
|
||||||
|
|
||||||
|
[target]
|
||||||
|
units=fpwebdata sqldbwebdata fpextjs extjsjson extjsxml
|
||||||
|
|
||||||
|
[require]
|
||||||
|
packages=fcl-base fcl-xml fcl-db fcl-json
|
||||||
|
|
||||||
|
[compiler]
|
||||||
|
options=-S2h
|
||||||
|
|
||||||
|
[install]
|
||||||
|
fpcpackage=y
|
||||||
|
|
||||||
|
[default]
|
||||||
|
fpcdir=../../../..
|
||||||
|
|
||||||
|
|
||||||
|
[rules]
|
||||||
|
.NOTPARALLEL:
|
362
packages/fcl-web/src/webdata/extjsjson.pp
Normal file
362
packages/fcl-web/src/webdata/extjsjson.pp
Normal file
@ -0,0 +1,362 @@
|
|||||||
|
unit extjsjson;
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes, SysUtils, httpdefs, fphttp,fpwebdata, fpextjs, fpjson, db, jsonparser;
|
||||||
|
|
||||||
|
type
|
||||||
|
|
||||||
|
{ TExtJSJSonWebdataInputAdaptor }
|
||||||
|
|
||||||
|
TExtJSJSonWebdataInputAdaptor = CLass(TCustomWebdataInputAdaptor)
|
||||||
|
private
|
||||||
|
FRows : TJSONArray;
|
||||||
|
FCurrentRow : TJSONObject;
|
||||||
|
FIDValue : TJSONData;
|
||||||
|
FRowIndex : integer;
|
||||||
|
function CheckData: Boolean;
|
||||||
|
Public
|
||||||
|
Function GetNextBatch : Boolean; override;
|
||||||
|
Function TryFieldValue(Const AFieldName : String; out AValue : String) : Boolean; override;
|
||||||
|
Destructor destroy; override;
|
||||||
|
end;
|
||||||
|
{ TExtJSJSONDataFormatter }
|
||||||
|
|
||||||
|
TExtJSJSONDataFormatter = Class(TExtJSDataFormatter)
|
||||||
|
private
|
||||||
|
procedure SendSuccess(ResponseContent: TStream; AddIDValue : Boolean = False);
|
||||||
|
protected
|
||||||
|
Function CreateAdaptor(ARequest : TRequest) : TCustomWebdataInputAdaptor; override;
|
||||||
|
Function AddFieldToJSON(O: TJSONObject; AFieldName: String; F: TField): TJSONData;
|
||||||
|
function GetDataContentType: String; override;
|
||||||
|
Function GetJSONMetaData: TJSONObject;
|
||||||
|
function RowToJSON: TJSONObject;
|
||||||
|
procedure DatasetToStream(Stream: TStream); override;
|
||||||
|
Procedure DoExceptionToStream(E : Exception; ResponseContent : TStream); override;
|
||||||
|
Procedure DoInsertRecord(ResponseContent : TStream); override;
|
||||||
|
Procedure DoUpdateRecord(ResponseContent : TStream); override;
|
||||||
|
Procedure DoDeleteRecord(ResponseContent : TStream); override;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
{ $define wmdebug}
|
||||||
|
{$ifdef wmdebug}
|
||||||
|
uses dbugintf;
|
||||||
|
{$endif wmdebug}
|
||||||
|
|
||||||
|
Resourcestring
|
||||||
|
SErrWrongDataFormat = 'Post ROWS data has wrong value type. Expected array or object, got : %s.';
|
||||||
|
SerrNoExceptionMessage = 'No exception to take error message from.';
|
||||||
|
|
||||||
|
Const
|
||||||
|
// Do not localize these strings
|
||||||
|
SDefMetaDataProperty = 'metaData';
|
||||||
|
SDefFieldsProperty = 'fields';
|
||||||
|
SDefFieldProperty = 'field';
|
||||||
|
SDefFieldNameProperty = 'name';
|
||||||
|
SDefDirectionProperty = 'direction';
|
||||||
|
SDefSortInfoProperty = 'sortInfo';
|
||||||
|
SDefAscDesc : Array[Boolean] of string = ('ASC','DESC');
|
||||||
|
|
||||||
|
function TExtJSJSONDataFormatter.GetDataContentType: String;
|
||||||
|
begin
|
||||||
|
Result:='text/html';
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TExtJSJSONDataFormatter.CreateAdaptor(ARequest: TRequest
|
||||||
|
): TCustomWebdataInputAdaptor;
|
||||||
|
begin
|
||||||
|
Result:=TExtJSJSonWebdataInputAdaptor.Create(Self);
|
||||||
|
Result.Request:=ARequest;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TExtJSJSONDataFormatter.AddFieldToJSON(O : TJSONObject; AFieldName : String; F : TField): TJSONData;
|
||||||
|
|
||||||
|
begin
|
||||||
|
Case F.DataType of
|
||||||
|
ftSmallint,
|
||||||
|
ftInteger,
|
||||||
|
ftAutoInc,
|
||||||
|
ftWord:
|
||||||
|
Result:=O.Items[O.Add(AFieldName,F.AsInteger)];
|
||||||
|
ftBoolean:
|
||||||
|
Result:=O.Items[O.Add(AFieldName,F.AsBoolean)];
|
||||||
|
ftLargeint:
|
||||||
|
Result:=O.Items[O.Add(AFieldName,F.AsLargeInt)];
|
||||||
|
else
|
||||||
|
Result:=O.Items[O.Add(AFieldName,F.DisplayText)];
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TExtJSJSONDataFormatter.RowToJSON: TJSONObject;
|
||||||
|
|
||||||
|
Var
|
||||||
|
F : TField;
|
||||||
|
I : Integer;
|
||||||
|
|
||||||
|
|
||||||
|
begin
|
||||||
|
Result:=TJSONObject.Create();
|
||||||
|
For I:=0 to Dataset.Fields.Count-1 do
|
||||||
|
begin
|
||||||
|
F:=Dataset.Fields[I];
|
||||||
|
AddFieldToJSON(Result,F.FieldName,F);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
Function TExtJSJSONDataFormatter.GetJSONMetaData: TJSONObject;
|
||||||
|
|
||||||
|
Var
|
||||||
|
F : TJSONArray;
|
||||||
|
Fi : TField;
|
||||||
|
I : Integer;
|
||||||
|
O : TJSONObject;
|
||||||
|
SF : String;
|
||||||
|
|
||||||
|
begin
|
||||||
|
If (SortField='') then
|
||||||
|
SF:=Dataset.Fields[0].FieldName
|
||||||
|
else
|
||||||
|
SF:=SortField;
|
||||||
|
Result:=TJSonObject.Create;
|
||||||
|
try
|
||||||
|
F:=TJSONArray.Create;
|
||||||
|
Result.add(SDefFieldsProperty,F);
|
||||||
|
For I:=0 to Dataset.Fields.Count-1 do
|
||||||
|
begin
|
||||||
|
Fi:=Dataset.Fields[i];
|
||||||
|
O:=TJSONObject.Create();
|
||||||
|
O.Add(SDefFieldNameProperty,Fi.FieldName);
|
||||||
|
F.Add(O);
|
||||||
|
end;
|
||||||
|
O:=TJSONObject.Create();
|
||||||
|
O.Add(SDefFieldProperty,SF);
|
||||||
|
O.Add(SDefDirectionProperty,SDefAscDesc[SortDescending]);
|
||||||
|
Result.Add(SDefSortInfoProperty,O);
|
||||||
|
except
|
||||||
|
Result.free;
|
||||||
|
Raise;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TExtJSJSONDataFormatter.DatasetToStream(Stream: TStream);
|
||||||
|
|
||||||
|
Var
|
||||||
|
Rows : TJSONArray;
|
||||||
|
Meta,Resp : TJSONObject;
|
||||||
|
L : String;
|
||||||
|
DS : TDataset;
|
||||||
|
i,RCount,ACount : Integer;
|
||||||
|
|
||||||
|
begin
|
||||||
|
Rows:=Nil;
|
||||||
|
Resp:=TJSONObject.Create;
|
||||||
|
try
|
||||||
|
Rows:=TJSONArray.Create();
|
||||||
|
DS:=Dataset;
|
||||||
|
DS.First;
|
||||||
|
RCount:=0;
|
||||||
|
If MetaData then
|
||||||
|
begin
|
||||||
|
Meta:=GetJSONMetaData;
|
||||||
|
Resp.Add(SDefMetaDataProperty,Meta);
|
||||||
|
end;
|
||||||
|
// Go to start
|
||||||
|
ACount:=PageStart;
|
||||||
|
While (Not DS.EOF) and (ACount>0) do
|
||||||
|
begin
|
||||||
|
DS.Next;
|
||||||
|
Dec(ACount);
|
||||||
|
Inc(RCount);
|
||||||
|
end;
|
||||||
|
ACount:=PageSize;
|
||||||
|
While (not DS.EOF) and ((PageSize=0) or (ACount>0)) do
|
||||||
|
begin
|
||||||
|
Inc(RCount);
|
||||||
|
Dec(ACount);
|
||||||
|
Rows.Add(RowToJSON);
|
||||||
|
DS.Next;
|
||||||
|
end;
|
||||||
|
If (PageSize>0) then
|
||||||
|
While (not DS.EOF) do
|
||||||
|
begin
|
||||||
|
Inc(RCount);
|
||||||
|
DS.Next;
|
||||||
|
end;
|
||||||
|
Resp.Add(RowsProperty,Rows);
|
||||||
|
Resp.Add(SuccessProperty,True);
|
||||||
|
If (PageSize>0) then
|
||||||
|
Resp.Add(TotalProperty,RCount);
|
||||||
|
L:=Resp.AsJSON;
|
||||||
|
Stream.WriteBuffer(L[1],Length(L));
|
||||||
|
finally
|
||||||
|
Resp.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TExtJSJSONDataFormatter.DoExceptionToStream(E: Exception;
|
||||||
|
ResponseContent: TStream);
|
||||||
|
|
||||||
|
Var
|
||||||
|
Resp : TJSonObject;
|
||||||
|
L : String;
|
||||||
|
|
||||||
|
begin
|
||||||
|
Resp:=tjsonObject.Create();
|
||||||
|
try
|
||||||
|
Resp.Add(SuccessProperty,False);
|
||||||
|
If Assigned(E) then
|
||||||
|
Resp.Add(MessageProperty,E.Message)
|
||||||
|
else
|
||||||
|
Resp.Add(MessageProperty,SerrNoExceptionMessage);
|
||||||
|
L:=Resp.AsJSON;
|
||||||
|
If Length(L)>0 then
|
||||||
|
ResponseContent.WriteBuffer(L[1],Length(L));
|
||||||
|
finally
|
||||||
|
Resp.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TExtJSJSONDataFormatter.SendSuccess(ResponseContent: TStream; AddIDValue : Boolean = False);
|
||||||
|
|
||||||
|
Var
|
||||||
|
Resp : TJSonObject;
|
||||||
|
L : String;
|
||||||
|
|
||||||
|
begin
|
||||||
|
try
|
||||||
|
Resp:=TJsonObject.Create;
|
||||||
|
Resp.Add(SuccessProperty,True);
|
||||||
|
Resp.Add(Provider.IDFieldName,Provider.IDFieldValue);
|
||||||
|
L:=Resp.AsJSON;
|
||||||
|
ResponseContent.WriteBuffer(L[1],Length(L));
|
||||||
|
finally
|
||||||
|
Resp.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TExtJSJSONDataFormatter.DoInsertRecord(ResponseContent: TStream);
|
||||||
|
|
||||||
|
begin
|
||||||
|
Inherited;
|
||||||
|
SendSuccess(ResponseContent,True);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TExtJSJSONDataFormatter.DoUpdateRecord(ResponseContent: TStream);
|
||||||
|
begin
|
||||||
|
inherited DoUpdateRecord(ResponseContent);
|
||||||
|
SendSuccess(ResponseContent,False);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TExtJSJSONDataFormatter.DoDeleteRecord(ResponseContent: TStream);
|
||||||
|
begin
|
||||||
|
inherited DoDeleteRecord(ResponseContent);
|
||||||
|
SendSuccess(ResponseContent,False);
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TExtJSJSonWebdataInputAdaptor }
|
||||||
|
|
||||||
|
function TExtJSJSonWebdataInputAdaptor.CheckData : Boolean;
|
||||||
|
|
||||||
|
Var
|
||||||
|
D : TJSONData;
|
||||||
|
P : TJSONParser;
|
||||||
|
S : String;
|
||||||
|
|
||||||
|
begin
|
||||||
|
Result:=Assigned(FCurrentRow);
|
||||||
|
If Not (Result) and TryParamValue('rows',S) then
|
||||||
|
begin
|
||||||
|
{$ifdef wmdebug}senddebug('Check data: '+GetParamValue('rows'));{$endif}
|
||||||
|
P:=TJSONParser.Create(S);
|
||||||
|
try
|
||||||
|
D:=P.Parse;
|
||||||
|
{$ifdef wmdebug}senddebug('Classname : '+D.ClassName);{$endif}
|
||||||
|
If D is TJSONArray then
|
||||||
|
begin
|
||||||
|
FRows:=TJSONArray(D);
|
||||||
|
FRowIndex:=0;
|
||||||
|
FCurrentRow:=FRows.Items[0] as TJSONObject;
|
||||||
|
end
|
||||||
|
else If D is TJSONObject then
|
||||||
|
begin
|
||||||
|
FRows:=Nil;
|
||||||
|
FCurrentRow:=TJSONObject(D);
|
||||||
|
end
|
||||||
|
else if D is TJSONInt64Number then
|
||||||
|
FIDValue:=D
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
FreeAndNil(D);
|
||||||
|
Raise EFPHTTPError.CreateFmt(SErrWrongDataFormat,[D.ClassName]);
|
||||||
|
end;
|
||||||
|
Result:=True;
|
||||||
|
finally
|
||||||
|
P.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TExtJSJSonWebdataInputAdaptor.GetNextBatch: Boolean;
|
||||||
|
begin
|
||||||
|
If (FRows=Nil) then
|
||||||
|
Result:=inherited GetNextBatch
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
Result:=FRowindex<FRows.Count-1;
|
||||||
|
Inc(FRowIndex);
|
||||||
|
If Result then
|
||||||
|
FCurrentRow:=FRows.Items[FRowIndex] as TJSONObject
|
||||||
|
else
|
||||||
|
FCurrentRow:=Nil;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TExtJSJSonWebdataInputAdaptor.TryFieldValue(const AFieldName: String;
|
||||||
|
out AValue: String): Boolean;
|
||||||
|
|
||||||
|
Var
|
||||||
|
I : Integer;
|
||||||
|
|
||||||
|
begin
|
||||||
|
Result:=False;
|
||||||
|
if CheckData then
|
||||||
|
begin
|
||||||
|
If Assigned(FIDValue) and (0=CompareText(AFieldName,'ID')) then
|
||||||
|
begin
|
||||||
|
AValue:=FIDValue.AsString;
|
||||||
|
Result:=True;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
I:=FCurrentRow.IndexOfName(AFieldName);
|
||||||
|
Result:=I<>-1;
|
||||||
|
if result then
|
||||||
|
AValue:=FCurrentRow.Items[I].AsString;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TExtJSJSonWebdataInputAdaptor.destroy;
|
||||||
|
begin
|
||||||
|
If Assigned(FRows) then
|
||||||
|
FreeAndNil(FRows)
|
||||||
|
else if assigned(FCurrentRow) then
|
||||||
|
FreeAndNil(FCurrentRow)
|
||||||
|
else if Assigned(FIDValue) then
|
||||||
|
FreeAndNil(FIDValue);
|
||||||
|
inherited destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
initialization
|
||||||
|
WebDataProviderManager.RegisterInputAdaptor('ExtJS - JSON',TExtJSJSONWebdataInputAdaptor);
|
||||||
|
WebDataProviderManager.RegisterDataProducer('ExtJS - JSON',TExtJSJSONDataFormatter);
|
||||||
|
|
||||||
|
finalization
|
||||||
|
WebDataProviderManager.UnRegisterInputAdaptor('ExtJS - JSON');
|
||||||
|
WebDataProviderManager.UnRegisterDataProducer('ExtJS - JSON')
|
||||||
|
end.
|
||||||
|
|
362
packages/fcl-web/src/webdata/extjsxml.pp
Normal file
362
packages/fcl-web/src/webdata/extjsxml.pp
Normal file
@ -0,0 +1,362 @@
|
|||||||
|
unit extjsxml;
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes, SysUtils, httpdefs, fpextjs, dom, xmlread, xmlwrite, fpwebdata, db;
|
||||||
|
|
||||||
|
Type
|
||||||
|
|
||||||
|
{ TExtJSXMLWebdataInputAdaptor }
|
||||||
|
|
||||||
|
TExtJSXMLWebdataInputAdaptor = CLass(TCustomWebdataInputAdaptor)
|
||||||
|
private
|
||||||
|
FDE: String;
|
||||||
|
FRE: String;
|
||||||
|
FREEL: String;
|
||||||
|
FXML : TXMLDocument;
|
||||||
|
FDocRoot : TDOMElement;
|
||||||
|
FRoot : TDOMElement;
|
||||||
|
FCurrentRow : TDOMElement;
|
||||||
|
FIDValue : TDOMElement;
|
||||||
|
function isDocumentStored: boolean;
|
||||||
|
function IsRecordStored: boolean;
|
||||||
|
function isRootStored: boolean;
|
||||||
|
function CheckData: Boolean;
|
||||||
|
protected
|
||||||
|
Public
|
||||||
|
Constructor Create(AOwner : TComponent); override;
|
||||||
|
Destructor destroy; override;
|
||||||
|
Function TryFieldValue(Const AFieldName : String; out AValue : String) : Boolean; override;
|
||||||
|
Property DocumentElement : String Read FDE Write FDE stored isDocumentStored;
|
||||||
|
Property RootElement : String Read FRE Write FRE stored isRootStored;
|
||||||
|
Property RecordElement : String Read FREEL Write FREEL stored IsRecordStored;
|
||||||
|
end;
|
||||||
|
{ TExtJSJSONDataFormatter }
|
||||||
|
|
||||||
|
{ TExtJSXMLDataFormatter }
|
||||||
|
|
||||||
|
TExtJSXMLDataFormatter = Class(TExtJSDataFormatter)
|
||||||
|
private
|
||||||
|
FDP: String;
|
||||||
|
FReP: String;
|
||||||
|
FRP: String;
|
||||||
|
function IsDocumentStored: boolean;
|
||||||
|
function IsRecordStored: boolean;
|
||||||
|
function IsRootStored: boolean;
|
||||||
|
protected
|
||||||
|
Function CreateAdaptor(ARequest : TRequest) : TCustomWebdataInputAdaptor; override;
|
||||||
|
Procedure DoExceptionToStream(E : Exception; ResponseContent : TStream); override;
|
||||||
|
Function GetDataContentType : String; override;
|
||||||
|
function RowToXML(Doc: TXMLDocument): TDOMelement;
|
||||||
|
procedure DatasetToStream(Stream: TStream); override;
|
||||||
|
public
|
||||||
|
Constructor Create(AOwner : TComponent); override;
|
||||||
|
published
|
||||||
|
Property RootProperty : String Read FRP Write FRP Stored IsRootStored;
|
||||||
|
Property RecordProperty : String Read FReP Write FReP Stored IsRecordStored;
|
||||||
|
Property DocumentProperty : String Read FDP Write FDP Stored IsDocumentStored;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
{ $define wmdebug}
|
||||||
|
{$ifdef wmdebug}
|
||||||
|
uses dbugintf;
|
||||||
|
{$endif wmdebug}
|
||||||
|
|
||||||
|
Resourcestring
|
||||||
|
SerrNoExceptionMessage = 'No exception to take error message from.';
|
||||||
|
|
||||||
|
Const
|
||||||
|
// For TExtJSXMLDataFormatter.
|
||||||
|
SDefDocumentProperty = 'xrequest';
|
||||||
|
SDefRecordProperty = 'row';
|
||||||
|
SDefRootProperty = 'dataset';
|
||||||
|
|
||||||
|
// Fpr TExtJSXMLWebdataInputAdaptor
|
||||||
|
SDefRootElement = SDefRootProperty;
|
||||||
|
SDefRecordElement = SDefRecordProperty;
|
||||||
|
SDefDocumentElement = SDefDocumentProperty;
|
||||||
|
|
||||||
|
function TExtJSXMLDataFormatter.IsRootStored: boolean;
|
||||||
|
begin
|
||||||
|
Result:=RootProperty<>SDefRootProperty;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TExtJSXMLDataFormatter.CreateAdaptor(ARequest: TRequest
|
||||||
|
): TCustomWebdataInputAdaptor;
|
||||||
|
|
||||||
|
Var
|
||||||
|
R : TExtJSXMLWebdataInputAdaptor;
|
||||||
|
|
||||||
|
begin
|
||||||
|
R:=TExtJSXMLWebdataInputAdaptor.Create(Self);
|
||||||
|
R.Request:=ARequest;
|
||||||
|
R.DocumentElement:=Self.DocumentProperty;
|
||||||
|
R.RootElement:=Self.RootProperty;
|
||||||
|
R.RecordElement:=Self.RecordProperty;
|
||||||
|
Result:=R;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TExtJSXMLDataFormatter.IsRecordStored: boolean;
|
||||||
|
begin
|
||||||
|
Result:=RecordProperty<>SDefRecordProperty;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TExtJSXMLDataFormatter.IsDocumentStored: boolean;
|
||||||
|
begin
|
||||||
|
Result:=DocumentProperty<>SDefDocumentProperty
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TExtJSXMLDataFormatter.DoExceptionToStream(E: Exception;
|
||||||
|
ResponseContent: TStream);
|
||||||
|
|
||||||
|
Var
|
||||||
|
Xml : TXMLDocument;
|
||||||
|
El,C : TDOMElement;
|
||||||
|
|
||||||
|
begin
|
||||||
|
XML:=TXMLDocument.Create;
|
||||||
|
try
|
||||||
|
El:=XML.CreateElement(RootProperty);
|
||||||
|
XML.AppendChild(El);
|
||||||
|
El[SuccessProperty]:='false';
|
||||||
|
C:=XML.CreateElement(SuccessProperty);
|
||||||
|
C.AppendChild(XML.CreateTextNode('false'));
|
||||||
|
El.AppendChild(c);
|
||||||
|
C:=XML.CreateElement(MessageProperty);
|
||||||
|
El.AppendChild(C);
|
||||||
|
If Assigned(E) then
|
||||||
|
C.AppendChild(XML.CreateTextNode(E.Message))
|
||||||
|
else
|
||||||
|
C.AppendChild(XML.CreateTextNode(SerrNoExceptionMessage));
|
||||||
|
WriteXMLFile(XML,ResponseContent);
|
||||||
|
Finally
|
||||||
|
XML.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TExtJSXMLDataFormatter.GetDataContentType: String;
|
||||||
|
begin
|
||||||
|
Result:='text/xml';
|
||||||
|
end;
|
||||||
|
|
||||||
|
Function TExtJSXMLDataFormatter.RowToXML(Doc : TXMLDocument) : TDOMelement;
|
||||||
|
|
||||||
|
Var
|
||||||
|
E : TDOMElement;
|
||||||
|
F : TField;
|
||||||
|
I : Integer;
|
||||||
|
begin
|
||||||
|
Result:=Doc.CreateElement(RecordProperty);
|
||||||
|
For I:=0 to Dataset.Fields.Count-1 do
|
||||||
|
begin
|
||||||
|
F:=Dataset.Fields[i];
|
||||||
|
E:=Doc.CreateElement(F.FieldName);
|
||||||
|
E.AppendChild(Doc.CreateTextNode(F.DisplayText));
|
||||||
|
Result.AppendChild(E);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TExtJSXMLDataFormatter.DatasetToStream(Stream: TStream);
|
||||||
|
|
||||||
|
Var
|
||||||
|
Xml : TXMLDocument;
|
||||||
|
E,C : TDOMElement;
|
||||||
|
i,RCount,ACount : Integer;
|
||||||
|
DS : TDataset;
|
||||||
|
|
||||||
|
begin
|
||||||
|
RCount:=0;
|
||||||
|
ACount:=0;
|
||||||
|
DS:=Dataset;
|
||||||
|
XML:=TXMLDocument.Create;
|
||||||
|
try
|
||||||
|
E:=XML.CreateElement(RootProperty);
|
||||||
|
XML.AppendChild(E);
|
||||||
|
// Go to start
|
||||||
|
ACount:=PageStart;
|
||||||
|
While (Not DS.EOF) and (ACount>0) do
|
||||||
|
begin
|
||||||
|
DS.Next;
|
||||||
|
Dec(ACount);
|
||||||
|
Inc(RCount);
|
||||||
|
end;
|
||||||
|
ACount:=PageSize;
|
||||||
|
While (not DS.EOF) and ((PageSize=0) or (ACount>0)) do
|
||||||
|
begin
|
||||||
|
Inc(RCount);
|
||||||
|
Dec(ACount);
|
||||||
|
E.AppendChild(RowToXML(XML));
|
||||||
|
DS.Next;
|
||||||
|
end;
|
||||||
|
If (PageSize>0) then
|
||||||
|
While (not DS.EOF) do
|
||||||
|
begin
|
||||||
|
Inc(RCount);
|
||||||
|
DS.Next;
|
||||||
|
end;
|
||||||
|
C:=XML.CreateElement(TotalProperty);
|
||||||
|
C.AppendChild(XML.CreateTextNode(IntToStr(RCount)));
|
||||||
|
E.AppendChild(C);
|
||||||
|
C:=XML.CreateElement(SuccessProperty);
|
||||||
|
C.AppendChild(XML.CreateTextNode('true'));
|
||||||
|
E.AppendChild(C);
|
||||||
|
WriteXMLFile(XML,Stream);
|
||||||
|
|
||||||
|
finally
|
||||||
|
XML.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TExtJSXMLDataFormatter.Create(AOwner: TComponent);
|
||||||
|
begin
|
||||||
|
inherited Create(AOwner);
|
||||||
|
RootProperty:=SDefRootProperty;
|
||||||
|
RecordProperty:=SDefRecordProperty;
|
||||||
|
DocumentProperty:=SDefDocumentProperty
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TExtJSXMLWebdataInputAdaptor }
|
||||||
|
|
||||||
|
|
||||||
|
function TExtJSXMLWebdataInputAdaptor.isDocumentStored: boolean;
|
||||||
|
begin
|
||||||
|
Result:=DocumentElement<>SDefDocumentElement;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TExtJSXMLWebdataInputAdaptor.IsRecordStored: boolean;
|
||||||
|
begin
|
||||||
|
Result:=RecordElement<>SDefRecordElement;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TExtJSXMLWebdataInputAdaptor.isRootStored: boolean;
|
||||||
|
begin
|
||||||
|
Result:=RootElement<>SDefRootElement;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TExtJSXMLWebdataInputAdaptor.CheckData: Boolean;
|
||||||
|
|
||||||
|
Var
|
||||||
|
S : String;
|
||||||
|
T : TStringSTream;
|
||||||
|
E : TDomElement;
|
||||||
|
P : Integer;
|
||||||
|
|
||||||
|
begin
|
||||||
|
{$ifdef wmdebug}senddebug('Check data: '+Request.Content);{$endif}
|
||||||
|
Result:=Assigned(FXML);
|
||||||
|
If Not (Result) then
|
||||||
|
begin
|
||||||
|
S:=Request.ContentType;
|
||||||
|
P:=Pos(';',S);
|
||||||
|
If (P<>0) then
|
||||||
|
S:=Copy(S,1,P-1);
|
||||||
|
{$ifdef wmdebug}senddebug('Check data: '+S);{$endif}
|
||||||
|
Result:=CompareText(S,'application/x-www-form-urlencoded')=0;
|
||||||
|
If not Result then
|
||||||
|
begin
|
||||||
|
T:=TStringStream.Create(Request.Content);
|
||||||
|
try
|
||||||
|
XmlRead.ReadXMLFile(FXML,T);
|
||||||
|
If (DocumentElement<>'') and (FXML.DocumentElement.NodeName=DocumentElement) then
|
||||||
|
begin
|
||||||
|
{$ifdef wmdebug}senddebug('Document element is ExtJS DocumentElement');{$endif}
|
||||||
|
FDocRoot:=FXML.DocumentElement;
|
||||||
|
E:=FDocRoot;
|
||||||
|
end
|
||||||
|
else if (DocumentElement<>'') then
|
||||||
|
begin
|
||||||
|
//FXML.
|
||||||
|
{$ifdef wmdebug}senddebug('Looking for ExtJS Documentelement "'+DocumentElement+'" in XML.DocumentElement');{$endif}
|
||||||
|
FDocRoot:=FXML.DocumentElement.FindNode(DocumentElement) as TDOMElement;
|
||||||
|
E:=FDocRoot;
|
||||||
|
end;
|
||||||
|
{$ifdef wmdebug}senddebug('Looking for DocRoot element "'+RootElement+'" in FDocRoot');{$endif}
|
||||||
|
If Assigned(FDocRoot) then
|
||||||
|
FRoot:=FDocRoot
|
||||||
|
else
|
||||||
|
FRoot:=FXML.FindNode(RootElement) as TDomElement;
|
||||||
|
{$ifdef wmdebug}senddebug('Looking for current record element "'+RecordElement+'" in FRoot');{$endif}
|
||||||
|
If Assigned(FRoot) then
|
||||||
|
begin
|
||||||
|
FCurrentRow:=FRoot.FindNode(RecordElement) as TDomElement;
|
||||||
|
If Not Assigned(FCurrentRow) then
|
||||||
|
FIDValue:=FRoot.FindNode('ID') as TDomElement;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
{$ifdef wmdebug}senddebug('Looking for current record element "'+RecordElement+'" in document');{$endif}
|
||||||
|
FCurrentRow:=FXML.FindNode(RecordElement) as TDomElement;
|
||||||
|
end;
|
||||||
|
If (FCurrentRow=Nil) and (FXML.DocumentElement.NodeName=RecordElement) then
|
||||||
|
begin
|
||||||
|
{$ifdef wmdebug}senddebug('Documentelement is record element "'+RecordElement+'"');{$endif}
|
||||||
|
FCurrentRow:=FXML.DocumentElement;
|
||||||
|
end;
|
||||||
|
{$ifdef wmdebug}senddebug('Have current row: "'+IntToStr(Ord(Assigned(FCurrentRow)))+'"');{$endif}
|
||||||
|
Result:=True;
|
||||||
|
finally
|
||||||
|
T.free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TExtJSXMLWebdataInputAdaptor.TryFieldValue(const AFieldName: String;
|
||||||
|
out AValue: String): Boolean;
|
||||||
|
|
||||||
|
Var
|
||||||
|
I : Integer;
|
||||||
|
E : TDOMElement;
|
||||||
|
N : TDOMNode;
|
||||||
|
|
||||||
|
begin
|
||||||
|
Result:=False;
|
||||||
|
if CheckData then
|
||||||
|
begin
|
||||||
|
If Assigned(FIDValue) and (0=CompareText(AFieldName,'ID')) then
|
||||||
|
begin
|
||||||
|
AValue:=FIDValue.NodeValue;
|
||||||
|
Result:=True;
|
||||||
|
end
|
||||||
|
else if Assigned(FCurrentRow) then
|
||||||
|
begin
|
||||||
|
E:=FCurrentRow.FindNode(AFieldName) as TDomElement;
|
||||||
|
Result:=Assigned(E);
|
||||||
|
if result then
|
||||||
|
begin
|
||||||
|
N:=E.FirstChild;
|
||||||
|
If Assigned(N) then
|
||||||
|
AValue:=N.NodeValue;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TExtJSXMLWebdataInputAdaptor.Create(AOwner: TComponent);
|
||||||
|
begin
|
||||||
|
inherited Create(AOwner);
|
||||||
|
RootElement:=SDefRootElement;
|
||||||
|
RecordElement:=SDefRecordElement;
|
||||||
|
DocumentElement:=SDefDocumentElement;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TExtJSXMLWebdataInputAdaptor.destroy;
|
||||||
|
begin
|
||||||
|
FreeAndNil(FXML);
|
||||||
|
inherited destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
initialization
|
||||||
|
WebDataProviderManager.RegisterInputAdaptor('ExtJS - XML',TExtJSXMLWebdataInputAdaptor);
|
||||||
|
WebDataProviderManager.RegisterDataProducer('ExtJS - XML',TExtJSXMLDataFormatter);
|
||||||
|
|
||||||
|
finalization
|
||||||
|
WebDataProviderManager.UnRegisterInputAdaptor('ExtJS - XML');
|
||||||
|
WebDataProviderManager.UnRegisterDataProducer('ExtJS - XML')
|
||||||
|
end.
|
||||||
|
|
143
packages/fcl-web/src/webdata/fpextjs.pp
Normal file
143
packages/fcl-web/src/webdata/fpextjs.pp
Normal file
@ -0,0 +1,143 @@
|
|||||||
|
unit fpextjs;
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes, SysUtils, fphttp, db, httpdefs, fpwebdata;
|
||||||
|
|
||||||
|
Type
|
||||||
|
|
||||||
|
|
||||||
|
{ TExtJSDataFormatter }
|
||||||
|
|
||||||
|
TExtJSDataFormatter = Class(TCustomHTTPDataContentProducer)
|
||||||
|
private
|
||||||
|
FMP: String;
|
||||||
|
FPLP: String;
|
||||||
|
FPSP: String;
|
||||||
|
FRP: String;
|
||||||
|
FSP: String;
|
||||||
|
FTP: String;
|
||||||
|
function IsMessageStored: boolean;
|
||||||
|
function IsPageLimitStored: boolean;
|
||||||
|
function IsPageStartStored: boolean;
|
||||||
|
function IsRowsStored: boolean;
|
||||||
|
Function IsSuccessStored : Boolean;
|
||||||
|
function IsTotalStored: boolean;
|
||||||
|
Public
|
||||||
|
Constructor Create(AOwner : TComponent); override;
|
||||||
|
Procedure DoReadRecords(Stream : TStream); override;
|
||||||
|
Function ProduceContent : String; override;
|
||||||
|
Property SuccessProperty : String Read FSP Write FSP stored IsSuccessStored;
|
||||||
|
Property PageStartProperty : String Read FPSP Write FPSP stored IsPageStartStored;
|
||||||
|
Property PageLimitProperty : String Read FPLP Write FPLP stored IsPageLimitStored;
|
||||||
|
Property RowsProperty : String Read FRP Write FRP stored IsRowsStored;
|
||||||
|
Property MessageProperty : String Read FMP Write FMP stored IsMessageStored;
|
||||||
|
Property TotalProperty : String Read FTP Write FTP stored IsTotalStored;
|
||||||
|
end;
|
||||||
|
|
||||||
|
Const
|
||||||
|
// Do not localize these constants.
|
||||||
|
DefRowsProperty = 'rows';
|
||||||
|
DefPageLimitProperty = 'limit';
|
||||||
|
DefPageStartProperty = 'start';
|
||||||
|
DefSuccessProperty = 'success';
|
||||||
|
DefMessageProperty = 'message';
|
||||||
|
DefTotalProperty = 'total';
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
Resourcestring
|
||||||
|
SErrNoAdaptor = 'No adaptor available';
|
||||||
|
|
||||||
|
{ TExtJSDataFormatter }
|
||||||
|
|
||||||
|
function TExtJSDataFormatter.IsSuccessStored: Boolean;
|
||||||
|
begin
|
||||||
|
Result:=(SuccessProperty<>DefSuccessProperty);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TExtJSDataFormatter.IsTotalStored: boolean;
|
||||||
|
begin
|
||||||
|
Result:=(TotalProperty<>DefTotalProperty);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TExtJSDataFormatter.IsMessageStored: boolean;
|
||||||
|
begin
|
||||||
|
Result:=(MessageProperty<>DefMessageProperty);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TExtJSDataFormatter.IsPageLimitStored: boolean;
|
||||||
|
begin
|
||||||
|
Result:=(PageLimitProperty<>DefPageLimitProperty);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TExtJSDataFormatter.IsPageStartStored: boolean;
|
||||||
|
begin
|
||||||
|
Result:=(PageStartProperty<>DefPageStartProperty);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TExtJSDataFormatter.IsRowsStored: boolean;
|
||||||
|
begin
|
||||||
|
Result:=(RowsProperty<>DefRowsProperty);
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TExtJSDataFormatter.Create(AOwner: TComponent);
|
||||||
|
begin
|
||||||
|
inherited Create(AOwner);
|
||||||
|
RowsProperty:=DefRowsProperty;
|
||||||
|
PageLimitProperty:=DefPageLimitProperty;
|
||||||
|
PageStartProperty:=DefPageStartProperty;
|
||||||
|
SuccessProperty:=DefSuccessProperty;
|
||||||
|
MessageProperty:=DefMessageProperty;
|
||||||
|
TotalProperty:=DefTotalProperty;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TExtJSDataFormatter.DoReadRecords(Stream: TStream);
|
||||||
|
|
||||||
|
Var
|
||||||
|
I : Integer;
|
||||||
|
L : TStrings;
|
||||||
|
S : String;
|
||||||
|
begin
|
||||||
|
|
||||||
|
If AllowPageSize then
|
||||||
|
begin
|
||||||
|
If Not Assigned(Adaptor) then
|
||||||
|
Raise EFPHTTPError.Create(SErrNoAdaptor);
|
||||||
|
if Adaptor.TryFieldValue(PageStartProperty,S) then
|
||||||
|
begin
|
||||||
|
I:=StrToIntDef(S,-1);
|
||||||
|
If I<>-1 then
|
||||||
|
PageStart:=I;
|
||||||
|
end;
|
||||||
|
if Adaptor.TryFieldValue(PageLimitProperty,S) then
|
||||||
|
begin
|
||||||
|
I:=StrToIntDef(S,-1);
|
||||||
|
If I<>-1 then
|
||||||
|
PageSize:=I;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
Inherited DoReadRecords(Stream);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TExtJSDataFormatter.ProduceContent: String;
|
||||||
|
|
||||||
|
Var
|
||||||
|
S : TStringStream;
|
||||||
|
|
||||||
|
begin
|
||||||
|
S:=TStringStream.Create('');
|
||||||
|
try
|
||||||
|
ContentToStream(S);
|
||||||
|
Result:=S.DataString;
|
||||||
|
finally
|
||||||
|
FreeAndNil(S);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
end.
|
||||||
|
|
1887
packages/fcl-web/src/webdata/fpwebdata.pp
Normal file
1887
packages/fcl-web/src/webdata/fpwebdata.pp
Normal file
File diff suppressed because it is too large
Load Diff
405
packages/fcl-web/src/webdata/sqldbwebdata.pp
Normal file
405
packages/fcl-web/src/webdata/sqldbwebdata.pp
Normal file
@ -0,0 +1,405 @@
|
|||||||
|
unit sqldbwebdata;
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes, SysUtils, fphttp, fpwebdata, DB, SQLDB;
|
||||||
|
|
||||||
|
|
||||||
|
Type
|
||||||
|
{ TCustomSQLDBWebDataProvider }
|
||||||
|
TNewIDEvent = Procedure(Sender : TObject; Out AID : String) of object;
|
||||||
|
TGetParamTypeEvent = Procedure (Sender : TObject; Const ParamName,AValue : String; Var AType : TFieldtype) of object;
|
||||||
|
|
||||||
|
TCustomSQLDBWebDataProvider = Class(TFPCustomWebDataProvider)
|
||||||
|
private
|
||||||
|
FIDFieldName: String;
|
||||||
|
FOnGetNewID: TNewIDEvent;
|
||||||
|
FSQLS : Array[0..3] of TStringList;
|
||||||
|
FConnection: TSQLConnection;
|
||||||
|
FQuery : TSQLQuery;
|
||||||
|
FLastNewID : String;
|
||||||
|
FOnGetParamType : TGetParamTypeEvent;
|
||||||
|
procedure CheckDataset;
|
||||||
|
function GetS(AIndex: integer): TStrings;
|
||||||
|
procedure SetConnection(const AValue: TSQLConnection);
|
||||||
|
procedure SetS(AIndex: integer; const AValue: TStrings);
|
||||||
|
Protected
|
||||||
|
function CreateQuery(AOwner: TComponent; ATransaction: TSQLTransaction; ASQL: Tstrings): TSQLQuery;
|
||||||
|
function GetParamType(P: TParam; const AValue: String): TFieldType; virtual;
|
||||||
|
procedure SetTypedParam(P: TParam; Const AValue: String); virtual;
|
||||||
|
procedure ExecuteSQL(ASQL: TStrings; Msg: String=''; DoNewID : Boolean = False); virtual;
|
||||||
|
procedure ApplySQLParams(AQuery: TSQLQuery; DoNewID : Boolean = False); virtual;
|
||||||
|
Procedure SQLChanged(Sender : TObject); virtual;
|
||||||
|
Procedure DoUpdate; override;
|
||||||
|
Procedure DoDelete; override;
|
||||||
|
Procedure DoInsert; override;
|
||||||
|
Procedure DoApplyParams; override;
|
||||||
|
Function GetDataset : TDataset; override;
|
||||||
|
Function GetNewID : String;
|
||||||
|
Function IDFieldValue : String; override;
|
||||||
|
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
||||||
|
Property SelectSQL : TStrings Index 0 Read GetS Write SetS;
|
||||||
|
Property UpdateSQL : TStrings Index 1 Read GetS Write SetS;
|
||||||
|
Property DeleteSQL : TStrings Index 2 Read GetS Write SetS;
|
||||||
|
Property InsertSQL : TStrings Index 3 Read GetS Write SetS;
|
||||||
|
Property Connection : TSQLConnection Read FConnection Write SetConnection;
|
||||||
|
Property OnGetNewID : TNewIDEvent Read FOnGetNewID Write FOnGetNewID;
|
||||||
|
property OnGetParameterType : TGetParamTypeEvent Read FOnGetParamType Write FOnGetParamType;
|
||||||
|
Public
|
||||||
|
Constructor Create(AOwner : TComponent); override;
|
||||||
|
Destructor Destroy; override;
|
||||||
|
end;
|
||||||
|
|
||||||
|
TSQLDBWebDataProvider = Class(TCustomSQLDBWebDataProvider)
|
||||||
|
Published
|
||||||
|
Property SelectSQL;
|
||||||
|
Property UpdateSQL;
|
||||||
|
Property DeleteSQL;
|
||||||
|
Property InsertSQL;
|
||||||
|
Property Connection;
|
||||||
|
Property IDFieldName;
|
||||||
|
Property OnGetNewID;
|
||||||
|
property OnGetParameterType;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
{ $define wmdebug}
|
||||||
|
|
||||||
|
{$ifdef wmdebug}
|
||||||
|
uses dbugintf;
|
||||||
|
{$endif}
|
||||||
|
|
||||||
|
resourcestring
|
||||||
|
SErrNoSelectSQL = '%s: No select SQL statement provided.';
|
||||||
|
SErrNoUpdateSQL = '%s: No update SQL statement provided.';
|
||||||
|
SErrNoInsertSQL = '%s: No insert SQL statement provided.';
|
||||||
|
SErrNoDeleteSQL = '%s: No delete SQL statement provided.';
|
||||||
|
SErrUpdating = '%s: An error occurred during the update operation: %s';
|
||||||
|
SErrDeleting = '%s: An error occurred during the delete operation: %s';
|
||||||
|
SErrInserting = '%s: An error occurred during the insert operation: %s';
|
||||||
|
SErrNoNewIDEvent = '%s : Cannot generate ID: No OnGetNewID event assigned.';
|
||||||
|
|
||||||
|
{ TCustomSQLDBWebDataProvider }
|
||||||
|
|
||||||
|
function TCustomSQLDBWebDataProvider.GetS(AIndex: integer): TStrings;
|
||||||
|
begin
|
||||||
|
Result:=FSQLS[AIndex];
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomSQLDBWebDataProvider.SetConnection(const AValue: TSQLConnection
|
||||||
|
);
|
||||||
|
begin
|
||||||
|
if (FConnection=AValue) then exit;
|
||||||
|
If Assigned(FConnection) then
|
||||||
|
FConnection.RemoveFreeNotification(Self);
|
||||||
|
FConnection:=AValue;
|
||||||
|
If Assigned(FConnection) then
|
||||||
|
FConnection.FreeNotification(Self);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomSQLDBWebDataProvider.SetS(AIndex: integer;
|
||||||
|
const AValue: TStrings);
|
||||||
|
begin
|
||||||
|
FSQLS[AIndex].Assign(AValue);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomSQLDBWebDataProvider.SQLChanged(Sender: TObject);
|
||||||
|
begin
|
||||||
|
If (Sender=SelectSQL) and Assigned(FQuery) then
|
||||||
|
begin
|
||||||
|
FQuery.Close;
|
||||||
|
FQuery.SQL.Assign(SelectSQL);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomSQLDBWebDataProvider.ExecuteSQL(ASQL : TStrings; Msg : String = ''; DoNewID : Boolean = False);
|
||||||
|
|
||||||
|
Var
|
||||||
|
Q : TSQLQuery;
|
||||||
|
begin
|
||||||
|
{$ifdef wmdebug}SendDebug('Entering TCustomSQLDBWebDataProvider.ExecuteSQL');{$endif}
|
||||||
|
Q:=CreateQuery(Nil,Nil,ASQL);
|
||||||
|
try
|
||||||
|
Q.Transaction.Active:=True;
|
||||||
|
try
|
||||||
|
ApplySQLParams(Q,DoNewID);
|
||||||
|
Q.ExecSQL;
|
||||||
|
(Q.Transaction as TSQLTransaction).Commit;
|
||||||
|
except
|
||||||
|
On E : Exception do
|
||||||
|
begin
|
||||||
|
(Q.Transaction as TSQLTransaction).Rollback;
|
||||||
|
If (Msg<>'') then
|
||||||
|
E.Message:=Format(Msg,[Self.Name,E.Message]);
|
||||||
|
Raise;
|
||||||
|
end;
|
||||||
|
end
|
||||||
|
finally
|
||||||
|
Q.Free;
|
||||||
|
end;
|
||||||
|
{$ifdef wmdebug}SendDebug('Exiting TCustomSQLDBWebDataProvider.ExecuteSQL');{$endif}
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomSQLDBWebDataProvider.DoUpdate;
|
||||||
|
|
||||||
|
begin
|
||||||
|
{$ifdef wmdebug}SendDebug('Entering TCustomSQLDBWebDataProvider.DoUpdate');{$endif}
|
||||||
|
If (Trim(UpdateSQL.Text)='') then
|
||||||
|
Raise EFPHTTPError.CreateFmt(SErrNoUpdateSQL,[Self.Name]);
|
||||||
|
FLastNewID:='';
|
||||||
|
ExecuteSQL(UpdateSQL,SErrUpdating);
|
||||||
|
{$ifdef wmdebug}SendDebug('Exiting TCustomSQLDBWebDataProvider.DoUpdate');{$endif}
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomSQLDBWebDataProvider.DoDelete;
|
||||||
|
begin
|
||||||
|
{$ifdef wmdebug}SendDebug('Entering TCustomSQLDBWebDataProvider.DoDelete');{$endif}
|
||||||
|
If (Trim(DeleteSQL.Text)='') then
|
||||||
|
Raise EFPHTTPError.CreateFmt(SErrNoDeleteSQL,[Self.Name]);
|
||||||
|
FLastNewID:='';
|
||||||
|
ExecuteSQL(DeleteSQL,SErrDeleting);
|
||||||
|
{$ifdef wmdebug}SendDebug('Exiting TCustomSQLDBWebDataProvider.DoDelete');{$endif}
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomSQLDBWebDataProvider.DoInsert;
|
||||||
|
begin
|
||||||
|
{$ifdef wmdebug}SendDebug('Entering TCustomSQLDBWebDataProvider.DoInsert');{$endif}
|
||||||
|
If (Trim(InsertSQL.Text)='') then
|
||||||
|
Raise EFPHTTPError.CreateFmt(SErrNoInsertSQL,[Self.Name]);
|
||||||
|
FLastNewID:='';
|
||||||
|
ExecuteSQL(InsertSQL,SErrInserting,(IDFieldName<>''));
|
||||||
|
{$ifdef wmdebug}SendDebug('Exiting TCustomSQLDBWebDataProvider.DoInsert');{$endif}
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomSQLDBWebDataProvider.Notification(AComponent: TComponent;
|
||||||
|
Operation: TOperation);
|
||||||
|
|
||||||
|
begin
|
||||||
|
If (Operation=opRemove) then
|
||||||
|
begin
|
||||||
|
If (AComponent=FQuery) then
|
||||||
|
FQuery:=Nil
|
||||||
|
else if (AComponent=FConnection) then
|
||||||
|
FConnection:=Nil;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
Function TCustomSQLDBWebDataProvider.CreateQuery(AOwner : TComponent; ATransaction : TSQLTransaction; ASQL : Tstrings) : TSQLQuery;
|
||||||
|
|
||||||
|
begin
|
||||||
|
Result:=TSQLQuery.Create(AOwner);
|
||||||
|
If (AOwner<>Self) then
|
||||||
|
Result.FreeNotification(Self);
|
||||||
|
Result.DataBase:=Connection;
|
||||||
|
If ATransaction=Nil then
|
||||||
|
begin
|
||||||
|
ATransaction:=TSQLTransaction.Create(Result);
|
||||||
|
ATransaction.DataBase:=Connection;
|
||||||
|
end;
|
||||||
|
Result.Transaction:=ATransaction;
|
||||||
|
Result.SQL.Assign(ASQL);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomSQLDBWebDataProvider.CheckDataset;
|
||||||
|
|
||||||
|
begin
|
||||||
|
{$ifdef wmdebug}SendDebug('Entering CheckDataset');{$endif}
|
||||||
|
If (Trim(SelectSQL.Text)='') then
|
||||||
|
Raise EFPHTTPError.CreateFmt(SErrNoSelectSQL,[Self.Name]);
|
||||||
|
If (FQuery=Nil) then
|
||||||
|
FQuery:=CreateQuery(Nil,Nil,SelectSQL)
|
||||||
|
else if not FQuery.Active then
|
||||||
|
FQuery.SQL.Assign(SelectSQL);
|
||||||
|
{$ifdef wmdebug}SendDebug('Exiting CheckDataset');{$endif}
|
||||||
|
end;
|
||||||
|
|
||||||
|
Function TCustomSQLDBWebDataProvider.GetParamType(P : TParam; Const AValue : String) : TFieldType;
|
||||||
|
|
||||||
|
begin
|
||||||
|
Result:=ftunknown;
|
||||||
|
If Assigned(FOnGetParamType) then
|
||||||
|
FOnGetParamType(Self,P.Name,AValue,Result);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomSQLDBWebDataProvider.SetTypedParam(P : TParam; Const AValue : String);
|
||||||
|
|
||||||
|
Var
|
||||||
|
I : Integer;
|
||||||
|
Q : Int64;
|
||||||
|
D : TDateTime;
|
||||||
|
ft : TFieldType;
|
||||||
|
F : Double;
|
||||||
|
B : Boolean;
|
||||||
|
C : Currency;
|
||||||
|
|
||||||
|
begin
|
||||||
|
ft:=GetParamtype(P,AValue);
|
||||||
|
If ft<>ftUnknown then
|
||||||
|
begin
|
||||||
|
try
|
||||||
|
case ft of
|
||||||
|
ftInteger,
|
||||||
|
ftword,
|
||||||
|
ftsmallint : I:=StrToInt(AValue);
|
||||||
|
ftDate : D:=StrToDate(AValue);
|
||||||
|
ftDateTime,
|
||||||
|
ftTimestamp : D:=StrToDateTime(AValue);
|
||||||
|
ftBoolean : B:=StrToBool(AValue);
|
||||||
|
ftTime : D:=StrToTime(AValue);
|
||||||
|
ftLargeint : Q:=StrToInt64(AValue);
|
||||||
|
ftCurrency : C:=StrToCurr(Avalue);
|
||||||
|
else
|
||||||
|
ft:=ftString
|
||||||
|
end
|
||||||
|
except
|
||||||
|
ft:=ftUnknown
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
If (ft=ftUnknown) and (Length(AValue)<30) then
|
||||||
|
begin
|
||||||
|
if TryStrToInt(Avalue,I) then
|
||||||
|
ft:=ftInteger
|
||||||
|
else if TryStrToInt64(Avalue,Q) then
|
||||||
|
ft:=ftInteger
|
||||||
|
else if (Pos(DateSeparator,AValue)<>0) then
|
||||||
|
begin
|
||||||
|
if (Pos(TimeSeparator,AValue)<>0) and TryStrToDateTime(Avalue,D) then
|
||||||
|
ft:=ftDateTime
|
||||||
|
else if TryStrToDate(Avalue,D) then
|
||||||
|
ft:=ftDate
|
||||||
|
end
|
||||||
|
else If (Pos(TimeSeparator,AValue)<>0) and TryStrToTime(Avalue,D) then
|
||||||
|
ft:=ftTime
|
||||||
|
else if (Pos(DecimalSeparator,AValue)<>0) then
|
||||||
|
begin
|
||||||
|
if trystrtofloat(AValue,F) then
|
||||||
|
ft:=ftFloat
|
||||||
|
else if TryStrToCurr(Avalue,C) then
|
||||||
|
ft:=ftCurrency
|
||||||
|
end
|
||||||
|
else if TryStrToBool(Avalue,B) then
|
||||||
|
ft:=ftBoolean
|
||||||
|
end;
|
||||||
|
Case ft of
|
||||||
|
ftInteger,
|
||||||
|
ftword,
|
||||||
|
ftsmallint : P.AsInteger:=I;
|
||||||
|
ftBoolean : P.AsBoolean:=B;
|
||||||
|
ftLargeInt : P.AsLargeInt:=Q;
|
||||||
|
ftDate : P.AsDate:=D;
|
||||||
|
ftDateTime,
|
||||||
|
ftTimestamp : P.AsDateTime:=D;
|
||||||
|
ftTime : P.AsTime:=D;
|
||||||
|
ftFloat,
|
||||||
|
ftBCD,
|
||||||
|
ftFMTBCD : P.AsFloat:=F;
|
||||||
|
ftCurrency : P.AsCurrency:=F;
|
||||||
|
else
|
||||||
|
P.AsString:=AValue;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomSQLDBWebDataProvider.ApplySQLParams(AQuery : TSQLQuery; DoNewID : Boolean = False);
|
||||||
|
|
||||||
|
var
|
||||||
|
I: Integer;
|
||||||
|
P : TParam;
|
||||||
|
S : String;
|
||||||
|
|
||||||
|
begin
|
||||||
|
{$ifdef wmdebug}SendDebug('Entering ApplySQLPArams');{$endif}
|
||||||
|
For I:=0 to AQuery.Params.Count-1 do
|
||||||
|
begin
|
||||||
|
P:=AQuery.Params[i];
|
||||||
|
If (P.Name=IDFieldName) and DoNewID then
|
||||||
|
SetTypedParam(P,GetNewID)
|
||||||
|
else If Adaptor.TryFieldValue(P.Name,S) then
|
||||||
|
SetTypedParam(P,S)
|
||||||
|
else If Adaptor.TryParamValue(P.Name,S) then
|
||||||
|
SetTypedParam(P,S)
|
||||||
|
else
|
||||||
|
P.Clear;
|
||||||
|
end;
|
||||||
|
{$ifdef wmdebug}SendDebug('Exiting ApplySQLPArams');{$endif}
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomSQLDBWebDataProvider.DoApplyParams;
|
||||||
|
|
||||||
|
begin
|
||||||
|
CheckDataset;
|
||||||
|
ApplySQLParams(FQuery);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCustomSQLDBWebDataProvider.GetDataset: TDataset;
|
||||||
|
begin
|
||||||
|
{$ifdef wmdebug}SendDebug('Get dataset: checking dataset');{$endif}
|
||||||
|
CheckDataset;
|
||||||
|
FLastNewID:='';
|
||||||
|
Result:=FQuery;
|
||||||
|
{$ifdef wmdebug}SendDebug('Get dataset: activating transaction');{$endif}
|
||||||
|
If Not FQuery.Transaction.Active then
|
||||||
|
FQuery.Transaction.Active:=True;
|
||||||
|
{$ifdef wmdebug}SendDebug('Get dataset: done');{$endif}
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCustomSQLDBWebDataProvider.GetNewID: String;
|
||||||
|
|
||||||
|
begin
|
||||||
|
If Not Assigned(FOnGetNewID) then
|
||||||
|
Raise EFPHTTPError.CreateFmt(SErrNoNewIDEvent,[Self.Name]);
|
||||||
|
FOnGetNewID(Self,Result);
|
||||||
|
FLastNewID:=Result;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCustomSQLDBWebDataProvider.IDFieldValue: String;
|
||||||
|
|
||||||
|
begin
|
||||||
|
{$ifdef wmdebug}SendDebug('Entering IDFieldValue');{$endif}
|
||||||
|
If (FLastNewID<>'') then
|
||||||
|
Result:=FLastNewID
|
||||||
|
else If (IDFieldName<>'') then
|
||||||
|
begin
|
||||||
|
If not Adaptor.TryParamValue(IDFieldName,Result) then
|
||||||
|
If not Adaptor.TryFieldValue(IDFieldName,Result) then
|
||||||
|
Result:=inherited IDFieldValue;
|
||||||
|
end
|
||||||
|
else
|
||||||
|
Result:=inherited IDFieldValue;
|
||||||
|
{$ifdef wmdebug}SendDebug('Exiting IDFieldValue : '+Result);{$endif}
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TCustomSQLDBWebDataProvider.Create(AOwner: TComponent);
|
||||||
|
|
||||||
|
Var
|
||||||
|
I : Integer;
|
||||||
|
L : TStringList;
|
||||||
|
|
||||||
|
begin
|
||||||
|
inherited Create(AOwner);
|
||||||
|
For I:=0 to 3 do
|
||||||
|
begin
|
||||||
|
L:=TStringList.Create;
|
||||||
|
L.OnChange:=@SQLChanged;
|
||||||
|
FSQLS[i]:=L;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TCustomSQLDBWebDataProvider.Destroy;
|
||||||
|
|
||||||
|
Var
|
||||||
|
I: Integer;
|
||||||
|
|
||||||
|
begin
|
||||||
|
For I:=0 to 3 do
|
||||||
|
FreeAndNil(FSQLS[i]);
|
||||||
|
Connection:=Nil;
|
||||||
|
FreeAndNil(FQuery);
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
||||||
|
|
114
packages/fcl-web/src/webdata/webdata.txt
Normal file
114
packages/fcl-web/src/webdata/webdata.txt
Normal file
@ -0,0 +1,114 @@
|
|||||||
|
FPC WebData architecture
|
||||||
|
========================
|
||||||
|
|
||||||
|
The aim of this set of components is to be able to easily send data
|
||||||
|
to a webapplication, and to handle updates of this data, all in a
|
||||||
|
webserver module.
|
||||||
|
|
||||||
|
The following components are used
|
||||||
|
|
||||||
|
- TFPWebDataProvider
|
||||||
|
The central component, forming a bridge between TDataset and web content.
|
||||||
|
|
||||||
|
- TCustomWebdataInputAdaptor
|
||||||
|
A class that transforms the input of a web request to something that
|
||||||
|
TFPWebDataProvider understands. Example implementations are provided
|
||||||
|
for ExtJS, XML and JSON.
|
||||||
|
|
||||||
|
- TWebdataInputAdaptor
|
||||||
|
A descendent of TCustomWebdataInputAdaptor that allows to select the
|
||||||
|
input format from a list of known formats.
|
||||||
|
|
||||||
|
- TCustomHTTPDataContentProducer
|
||||||
|
This class produces the response for the webapplication. It is an
|
||||||
|
abstract class: descendents need to be made for the various expected
|
||||||
|
outputs. Example implementations are provided for ExtJS, XML and JSON.
|
||||||
|
|
||||||
|
- THTTPDataContentProducer
|
||||||
|
A descendent of TCustomHTTPDataContentProducer that allows to select the
|
||||||
|
output format from a list of known formats.
|
||||||
|
|
||||||
|
- TFPWebProviderDataModule
|
||||||
|
A THTTPSessionDatamodule descendent that can be used to handle data
|
||||||
|
requests from a webclient. It functions as a container for
|
||||||
|
TFPWebDataProvider components, InputAdaptors and Content producers.
|
||||||
|
|
||||||
|
A module is registered in the Lazarus IDE package under File/New.
|
||||||
|
|
||||||
|
Typically, one will do the following
|
||||||
|
- Create a TFPWebProviderDataModule from the IDE.
|
||||||
|
- Drop some dataset components on it, and set them up for use with some
|
||||||
|
datasources
|
||||||
|
- For each dataset, drop a TFPWebDataProvider component on the module,
|
||||||
|
and connect it to the datasource. The name of this component is exposed
|
||||||
|
to the client.
|
||||||
|
- Drop a suitable input adaptor.
|
||||||
|
|
||||||
|
The data can then typically be read through the URL:
|
||||||
|
baseurl/modulename/providername/read
|
||||||
|
Or updated through the URLs
|
||||||
|
baseurl/modulename/providername/update
|
||||||
|
baseurl/modulename/providername/create
|
||||||
|
baseurl/modulename/providername/delete
|
||||||
|
where baseurl is the base URL for the web-application.
|
||||||
|
|
||||||
|
Large applications: factory support
|
||||||
|
For large-scale applications with lots of different datasets, there is
|
||||||
|
support for registering dataproviders in a central factory system:
|
||||||
|
|
||||||
|
The WebDataProviderManager function returns an instance of
|
||||||
|
TFPWebDataProviderManager.
|
||||||
|
|
||||||
|
It must be used to register WebDataProvider names and classes:
|
||||||
|
|
||||||
|
Function RegisterProvider(Const AProviderName : String; AClass : TFPCustomWebDataProviderClass) : TWebDataProviderDef; overload;
|
||||||
|
|
||||||
|
The first form registers a class: an instance of this class will
|
||||||
|
be created by the factory whenever a provider of name AProviderName is
|
||||||
|
requested.
|
||||||
|
|
||||||
|
The TFPWebProviderDataModule class is aware of the WebDataProviderManager
|
||||||
|
factory class, and will look there for a TFPCustomWebDataProvider instance
|
||||||
|
if none is found in the webmodule instance itself and the
|
||||||
|
'UseProviderManager' property is 'True'.
|
||||||
|
|
||||||
|
The WebDataProviderManager factory can also Register a complete datamodule:
|
||||||
|
|
||||||
|
Procedure RegisterDatamodule(Const AClass : TDatamoduleClass);
|
||||||
|
|
||||||
|
This will register all WebDataProvider instances on the datamodule:
|
||||||
|
An instance will be created, all TFPCustomWebDataProvider instances
|
||||||
|
will be registered with their component names.
|
||||||
|
When a provider belonging to such a datamodule is requested, then
|
||||||
|
the module will be created, and the requested TFPCustomWebDataProvider
|
||||||
|
instance is returned.
|
||||||
|
|
||||||
|
A provider instance can be requested with the following factory methods:
|
||||||
|
|
||||||
|
Function GetProvider(Const ADef : TWebDataProviderDef; AOwner : TComponent;out AContainer : TComponent): TFPCustomWebDataProvider;
|
||||||
|
Function GetProvider(Const AProviderName : String; AOwner : TComponent; Out AContainer : TComponent): TFPCustomWebDataProvider;
|
||||||
|
|
||||||
|
The result is the provider instance. All instances are created using a
|
||||||
|
container module: either this is the module class used in RegisterDatamodule
|
||||||
|
or a vanilla TDatamodule class. This instance is returned in AContainer.
|
||||||
|
|
||||||
|
The container must be freed by the caller.
|
||||||
|
|
||||||
|
In practise, this means that one creates a datamodule, drops some
|
||||||
|
TFPWebDataProvider instances on it, and adds the following call
|
||||||
|
to the initialization section of the unit:
|
||||||
|
|
||||||
|
WebDataProviderManager.RegisterDatamodule(TMyDataModule);
|
||||||
|
|
||||||
|
The TFPWebProviderDataModule that handles web requests will then be able
|
||||||
|
to handle requests for the TFPWebDataProvider instances on the datamodule.
|
||||||
|
|
||||||
|
Note that the RegisterDataModule routine will create an instance of the
|
||||||
|
datamodule to get a list of provider components (it uses the component.name
|
||||||
|
property). The WebDataProviderManager's 'registering' property will be set
|
||||||
|
to true: this way one can avoid connecting to a database during registration.
|
||||||
|
|
||||||
|
The WebDataProviderManager also handles the registration of inputadataptors
|
||||||
|
and output contents producers.
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue
Block a user