summaryrefslogtreecommitdiff
path: root/packages/fcl-web/src
diff options
context:
space:
mode:
Diffstat (limited to 'packages/fcl-web/src')
-rw-r--r--packages/fcl-web/src/base/custfcgi.pp330
-rw-r--r--packages/fcl-web/src/base/custweb.pp1
-rw-r--r--packages/fcl-web/src/base/fphtml.pp197
-rw-r--r--packages/fcl-web/src/base/webpage.pp114
-rw-r--r--packages/fcl-web/src/base/websession.pp1
-rw-r--r--packages/fcl-web/src/jsonrpc/fpextdirect.pp1
-rw-r--r--packages/fcl-web/src/jsonrpc/fpjsonrpc.pp6
-rw-r--r--packages/fcl-web/src/webdata/extjsjson.pp29
-rw-r--r--packages/fcl-web/src/webdata/fpwebdata.pp21
-rw-r--r--packages/fcl-web/src/webdata/sqldbwebdata.pp27
10 files changed, 582 insertions, 145 deletions
diff --git a/packages/fcl-web/src/base/custfcgi.pp b/packages/fcl-web/src/base/custfcgi.pp
index 65660994fd..4be71d53f1 100644
--- a/packages/fcl-web/src/base/custfcgi.pp
+++ b/packages/fcl-web/src/base/custfcgi.pp
@@ -21,7 +21,13 @@ unit custfcgi;
Interface
uses
- Classes,SysUtils, httpdefs,custweb, custcgi, fastcgi;
+ Classes,SysUtils, httpdefs,
+{$ifdef unix}
+ BaseUnix, TermIO,
+{$else}
+ winsock2,
+{$endif}
+ Sockets, custweb, custcgi, fastcgi;
Type
{ TFCGIRequest }
@@ -29,7 +35,8 @@ Type
TFCGIRequest = Class;
TFCGIResponse = Class;
- TProtocolOption = (poNoPadding,poStripContentLength, poFailonUnknownRecord );
+ TProtocolOption = (poNoPadding,poStripContentLength, poFailonUnknownRecord,
+ poReuseAddress, poUseSelect );
TProtocolOptions = Set of TProtocolOption;
TUnknownRecordEvent = Procedure (ARequest : TFCGIRequest; AFCGIRecord: PFCGI_Header) Of Object;
@@ -60,9 +67,7 @@ Type
TFCGIResponse = Class(TCGIResponse)
private
- FNoPadding: Boolean;
FPO: TProtoColOptions;
- FStripCL: Boolean;
procedure Write_FCGIRecord(ARecord : PFCGI_Header);
Protected
Procedure DoSendHeaders(Headers : TStrings); override;
@@ -75,6 +80,8 @@ Type
Response : TFCgiResponse;
end;
+ { TFCgiHandler }
+
TFCgiHandler = class(TWebHandler)
Private
FOnUnknownRecord: TUnknownRecordEvent;
@@ -84,10 +91,14 @@ Type
FHandle : THandle;
Socket: longint;
FAddress: string;
+ FTimeOut,
FPort: integer;
function Read_FCGIRecord : PFCGI_Header;
+ function DataAvailable : Boolean;
protected
- function WaitForRequest(out ARequest : TRequest; out AResponse : TResponse) : boolean; override;
+ function ProcessRecord(AFCGI_Record: PFCGI_Header; out ARequest: TRequest; out AResponse: TResponse): boolean; virtual;
+ procedure SetupSocket(var IAddress: TInetSockAddr; var AddressLength: tsocklen); virtual;
+ function WaitForRequest(out ARequest : TRequest; out AResponse : TResponse) : boolean; override;
procedure EndRequest(ARequest : TRequest;AResponse : TResponse); override;
Public
constructor Create(AOwner: TComponent); override;
@@ -96,6 +107,7 @@ Type
property Address: string read FAddress write FAddress;
Property ProtocolOptions : TProtoColOptions Read FPO Write FPO;
Property OnUnknownRecord : TUnknownRecordEvent Read FOnUnknownRecord Write FOnUnknownRecord;
+ Property TimeOut : Integer Read FTimeOut Write FTimeOut;
end;
{ TCustomFCgiApplication }
@@ -126,14 +138,16 @@ ResourceString
SListenFailed = 'Failed to listen to port %d. Socket Error: %d';
SErrReadingSocket = 'Failed to read data from socket. Error: %d';
SErrReadingHeader = 'Failed to read FastCGI header. Read only %d bytes';
+ SErrWritingSocket = 'Failed to write data to socket. Error: %d';
Implementation
-uses
{$ifdef CGIDEBUG}
- dbugintf,
+uses
+ dbugintf;
{$endif}
- Sockets;
+
+
{$undef nosignal}
@@ -315,9 +329,13 @@ begin
P:=PByte(Arecord);
Repeat
BytesWritten := sockets.fpsend(TFCGIRequest(Request).Handle, P, BytesToWrite, NoSignalAttr);
+ If (BytesWritten<0) then
+ begin
+ // TODO : Better checking for closed connection, EINTR
+ Raise HTTPError.CreateFmt(SErrWritingSocket,[BytesWritten]);
+ end;
Inc(P,BytesWritten);
Dec(BytesToWrite,BytesWritten);
-// Assert(BytesWritten=BytesToWrite);
until (BytesToWrite=0) or (BytesWritten=0);
end;
@@ -346,15 +364,18 @@ begin
pl := 8-(cl mod 8);
ARespRecord:=nil;
Getmem(ARespRecord,8+cl+pl);
- FillChar(ARespRecord^,8+cl+pl,0);
- ARespRecord^.header.version:=FCGI_VERSION_1;
- ARespRecord^.header.reqtype:=FCGI_STDOUT;
- ARespRecord^.header.paddingLength:=pl;
- ARespRecord^.header.contentLength:=NtoBE(cl);
- ARespRecord^.header.requestId:=NToBE(TFCGIRequest(Request).RequestID);
- move(str[1],ARespRecord^.ContentData,cl);
- Write_FCGIRecord(PFCGI_Header(ARespRecord));
- Freemem(ARespRecord);
+ try
+ FillChar(ARespRecord^,8+cl+pl,0);
+ ARespRecord^.header.version:=FCGI_VERSION_1;
+ ARespRecord^.header.reqtype:=FCGI_STDOUT;
+ ARespRecord^.header.paddingLength:=pl;
+ ARespRecord^.header.contentLength:=NtoBE(cl);
+ ARespRecord^.header.requestId:=NToBE(TFCGIRequest(Request).RequestID);
+ move(str[1],ARespRecord^.ContentData,cl);
+ Write_FCGIRecord(PFCGI_Header(ARespRecord));
+ finally
+ Freemem(ARespRecord);
+ end;
end;
procedure TFCGIResponse.DoSendContent;
@@ -392,14 +413,17 @@ begin
pl := 8-(cl mod 8);
ARespRecord:=Nil;
Getmem(ARespRecord,8+cl+pl);
- ARespRecord^.header.version:=FCGI_VERSION_1;
- ARespRecord^.header.reqtype:=FCGI_STDOUT;
- ARespRecord^.header.paddingLength:=pl;
- ARespRecord^.header.contentLength:=NtoBE(cl);
- ARespRecord^.header.requestId:=NToBE(TFCGIRequest(Request).RequestID);
- move(Str[BS+1],ARespRecord^.ContentData,cl);
- Write_FCGIRecord(PFCGI_Header(ARespRecord));
- Freemem(ARespRecord);
+ try
+ ARespRecord^.header.version:=FCGI_VERSION_1;
+ ARespRecord^.header.reqtype:=FCGI_STDOUT;
+ ARespRecord^.header.paddingLength:=pl;
+ ARespRecord^.header.contentLength:=NtoBE(cl);
+ ARespRecord^.header.requestId:=NToBE(TFCGIRequest(Request).RequestID);
+ move(Str[BS+1],ARespRecord^.ContentData,cl);
+ Write_FCGIRecord(PFCGI_Header(ARespRecord));
+ finally
+ Freemem(ARespRecord);
+ end;
Inc(BS,cl);
Until (BS=L);
FillChar(EndRequest,SizeOf(FCGI_EndRequestRecord),0);
@@ -420,6 +444,7 @@ begin
FRequestsAvail:=5;
SetLength(FRequestsArray,FRequestsAvail);
FHandle := THandle(-1);
+ FTimeOut:=50;
end;
destructor TFCgiHandler.Destroy;
@@ -452,6 +477,30 @@ begin
end;
function TFCgiHandler.Read_FCGIRecord : PFCGI_Header;
+{ $DEFINE DUMPRECORD}
+{$IFDEF DUMPRECORD}
+ Procedure DumpFCGIRecord (Var Header :FCGI_Header; ContentLength : word; PaddingLength : byte; ResRecord : Pointer);
+
+ Var
+ s : string;
+ I : Integer;
+
+ begin
+ Writeln('Dumping record ', Sizeof(Header),',',Contentlength,',',PaddingLength);
+ For I:=0 to Sizeof(Header)+ContentLength+PaddingLength-1 do
+ begin
+ Write(Format('%:3d ',[PByte(ResRecord)[i]]));
+ If PByte(ResRecord)[i]>30 then
+ S:=S+char(PByte(ResRecord)[i]);
+ if (I mod 16) = 0 then
+ begin
+ writeln(' ',S);
+ S:='';
+ end;
+ end;
+ Writeln(' ',S)
+ end;
+{$ENDIF DUMPRECORD}
function ReadBytes(ReadBuf: Pointer; ByteAmount : Word) : Integer;
@@ -477,12 +526,11 @@ function TFCgiHandler.Read_FCGIRecord : PFCGI_Header;
end;
var Header : FCGI_Header;
- {I,}BytesRead : integer;
+ BytesRead : integer;
ContentLength : word;
PaddingLength : byte;
ResRecord : pointer;
ReadBuf : pointer;
- s : string;
begin
@@ -490,119 +538,183 @@ begin
ResRecord:=Nil;
ReadBuf:=@Header;
BytesRead:=ReadBytes(ReadBuf,Sizeof(Header));
- If (BytesRead<>Sizeof(Header)) then
+ If (BytesRead=0) then
+ Exit // Connection closed gracefully.
+ // TODO : if connection closed gracefully, the request should no longer be handled.
+ // Need to discard request/response
+ else If (BytesRead<>Sizeof(Header)) then
Raise HTTPError.CreateFmt(SErrReadingHeader,[BytesRead]);
ContentLength:=BetoN(Header.contentLength);
PaddingLength:=Header.paddingLength;
Getmem(ResRecord,BytesRead+ContentLength+PaddingLength);
- PFCGI_Header(ResRecord)^:=Header;
- ReadBuf:=ResRecord+BytesRead;
- BytesRead:=ReadBytes(ReadBuf,ContentLength);
- ReadBuf:=ReadBuf+BytesRead;
- BytesRead:=ReadBytes(ReadBuf,PaddingLength);
- Result := ResRecord;
-{
- Writeln('Dumping record ', Sizeof(Header),',',Contentlength,',',PaddingLength);
- For I:=0 to Sizeof(Header)+ContentLength+PaddingLength-1 do
+ try
+ PFCGI_Header(ResRecord)^:=Header;
+ ReadBuf:=ResRecord+BytesRead;
+ BytesRead:=ReadBytes(ReadBuf,ContentLength);
+ If (BytesRead=0) and (ContentLength>0) then
+ begin
+ FreeMem(resRecord);
+ Exit // Connection closed gracefully.
+ // TODO : properly handle connection close
+ end;
+ ReadBuf:=ReadBuf+BytesRead;
+ BytesRead:=ReadBytes(ReadBuf,PaddingLength);
+ If (BytesRead=0) and (PaddingLength>0) then
+ begin
+ FreeMem(resRecord);
+ Exit // Connection closed gracefully.
+ // TODO : properly handle connection close
+ end;
+ Result := ResRecord;
+ except
+ FreeMem(resRecord);
+ Raise;
+ end;
+end;
+
+procedure TFCgiHandler.SetupSocket(var IAddress : TInetSockAddr; Var AddressLength : tsocklen);
+
+begin
+ AddressLength:=Sizeof(IAddress);
+ Socket := fpsocket(AF_INET,SOCK_STREAM,0);
+ if Socket=-1 then
+ raise EFPWebError.CreateFmt(SNoSocket,[socketerror]);
+ IAddress.sin_family:=AF_INET;
+ IAddress.sin_port:=htons(Port);
+ if FAddress<>'' then
+ Iaddress.sin_addr := StrToHostAddr(FAddress)
+ else
+ IAddress.sin_addr.s_addr:=0;
+ {$IFDEF Unix}
+ // remedy socket port locking on Posix platforms
+ If (poReuseAddress in ProtocolOptions) then
+ fpSetSockOpt(Socket, SOL_SOCKET, SO_REUSEADDR, @IAddress, SizeOf(IAddress));
+ {$ENDIF}
+ if fpbind(Socket,@IAddress,AddressLength)=-1 then
+ begin
+ CloseSocket(socket);
+ Socket:=0;
+ Terminate;
+ raise Exception.CreateFmt(SBindFailed,[port,socketerror]);
+ end;
+ if fplisten(Socket,1)=-1 then
begin
- Write(Format('%:3d ',[PByte(ResRecord)[i]]));
- If PByte(ResRecord)[i]>30 then
- S:=S+char(PByte(ResRecord)[i]);
- if (I mod 16) = 0 then
- begin
- writeln(' ',S);
- S:='';
- end;
+ CloseSocket(socket);
+ Socket:=0;
+ Terminate;
+ raise Exception.CreateFmt(SListenFailed,[port,socketerror]);
+ end;
+end;
+
+{$ifdef unix}
+function TFCgiHandler.DataAvailable: Boolean;
+
+var
+ FDS: TFDSet;
+ TimeV: TTimeVal;
+
+begin
+ fpFD_Zero(FDS);
+ fpFD_Set(FHandle, FDS);
+ TimeV.tv_usec := (Timeout mod 1000) * 1000;
+ TimeV.tv_sec := Timeout div 1000;
+ Result := fpSelect(FHandle + 1, @FDS, @FDS, @FDS, @TimeV) > 0;
+end;
+{$else}
+function TFCgiHandler.DataAvailable: Boolean;
+
+var
+ FDS: TFDSet;
+ TimeV: TTimeVal;
+
+begin
+ FD_Zero(FDS);
+ FD_Set(FHandle, FDS);
+ TimeV.tv_usec := (Timeout mod 1000) * 1000;
+ TimeV.tv_sec := Timeout div 1000;
+ Result := Select(FHandle + 1, @FDS, @FDS, @FDS, @TimeV) <> 0;
+end;
+{$endif}
+
+function TFCgiHandler.ProcessRecord(AFCGI_Record : PFCGI_Header; out ARequest: TRequest; out AResponse: TResponse): boolean;
+
+var
+ ARequestID : word;
+ ATempRequest : TFCGIRequest;
+begin
+ Result:=False;
+ ARequestID:=BEtoN(AFCGI_Record^.requestID);
+ if AFCGI_Record^.reqtype = FCGI_BEGIN_REQUEST then
+ begin
+ if ARequestID>FRequestsAvail then
+ begin
+ inc(FRequestsAvail,10);
+ SetLength(FRequestsArray,FRequestsAvail);
+ end;
+ assert(not assigned(FRequestsArray[ARequestID].Request));
+ assert(not assigned(FRequestsArray[ARequestID].Response));
+ ATempRequest:=TFCGIRequest.Create;
+ ATempRequest.RequestID:=ARequestID;
+ ATempRequest.Handle:=FHandle;
+ ATempRequest.ProtocolOptions:=Self.Protocoloptions;
+ ATempRequest.OnUnknownRecord:=Self.OnUnknownRecord;
+ FRequestsArray[ARequestID].Request := ATempRequest;
+ end;
+ if (ARequestID>FRequestsAvail) then
+ begin
+ // TODO : ARequestID can be invalid. What to do ?
+ // in each case not try to access the array with requests.
+ end
+ else if FRequestsArray[ARequestID].Request.ProcessFCGIRecord(AFCGI_Record) then
+ begin
+ ARequest:=FRequestsArray[ARequestID].Request;
+ FRequestsArray[ARequestID].Response := TFCGIResponse.Create(ARequest);
+ FRequestsArray[ARequestID].Response.ProtocolOptions:=Self.ProtocolOptions;
+ AResponse:=FRequestsArray[ARequestID].Response;
+ Result := True;
end;
- Writeln(' ',S)
-}
end;
function TFCgiHandler.WaitForRequest(out ARequest: TRequest; out AResponse: TResponse): boolean;
+
var
IAddress : TInetSockAddr;
AddressLength : tsocklen;
- ARequestID : word;
AFCGI_Record : PFCGI_Header;
- ATempRequest : TFCGIRequest;
begin
Result := False;
- AddressLength:=Sizeof(IAddress);
-
if Socket=0 then
- begin
if Port<>0 then
- begin
- Socket := fpsocket(AF_INET,SOCK_STREAM,0);
- if Socket=-1 then
- raise EFPWebError.CreateFmt(SNoSocket,[socketerror]);
- IAddress.sin_family:=AF_INET;
- IAddress.sin_port:=htons(Port);
- if FAddress<>'' then
- Iaddress.sin_addr := StrToHostAddr(FAddress)
- else
- IAddress.sin_addr.s_addr:=0;
- if fpbind(Socket,@IAddress,AddressLength)=-1 then
- begin
- CloseSocket(socket);
- Socket:=0;
- raise Exception.CreateFmt(SBindFailed,[port,socketerror]);
- end;
- if fplisten(Socket,1)=-1 then
- begin
- CloseSocket(socket);
- Socket:=0;
- raise Exception.CreateFmt(SListenFailed,[port,socketerror]);
- end;
- end
+ SetupSocket(IAddress,AddressLength)
else
Socket:=StdInputHandle;
- end;
-
if FHandle=THandle(-1) then
begin
FHandle:=fpaccept(Socket,psockaddr(@IAddress),@AddressLength);
if FHandle=THandle(-1) then
+ begin
+ Terminate;
raise Exception.CreateFmt(SNoInputHandle,[socketerror]);
+ end;
end;
-
repeat
- AFCGI_Record:=Read_FCGIRecord;
- if assigned(AFCGI_Record) then
+ If (poUseSelect in ProtocolOptions) then
+ begin
+ While Not DataAvailable do
+ If (OnIdle<>Nil) then
+ OnIdle(Self);
+ end;
+ AFCGI_Record:=Read_FCGIRecord;
+
+ if assigned(AFCGI_Record) then
try
- ARequestID:=BEtoN(AFCGI_Record^.requestID);
- if AFCGI_Record^.reqtype = FCGI_BEGIN_REQUEST then
- begin
- if ARequestID>FRequestsAvail then
- begin
- inc(FRequestsAvail,10);
- SetLength(FRequestsArray,FRequestsAvail);
- end;
- assert(not assigned(FRequestsArray[ARequestID].Request));
- assert(not assigned(FRequestsArray[ARequestID].Response));
-
- ATempRequest:=TFCGIRequest.Create;
- ATempRequest.RequestID:=ARequestID;
- ATempRequest.Handle:=FHandle;
- ATempRequest.ProtocolOptions:=Self.Protocoloptions;
- ATempRequest.OnUnknownRecord:=Self.OnUnknownRecord;
- FRequestsArray[ARequestID].Request := ATempRequest;
- end;
- if FRequestsArray[ARequestID].Request.ProcessFCGIRecord(AFCGI_Record) then
- begin
- ARequest:=FRequestsArray[ARequestID].Request;
- FRequestsArray[ARequestID].Response := TFCGIResponse.Create(ARequest);
- FRequestsArray[ARequestID].Response.ProtocolOptions:=Self.ProtocolOptions;
- AResponse:=FRequestsArray[ARequestID].Response;
- Result := True;
- Break;
- end;
+ Result:=ProcessRecord(AFCGI_Record,ARequest,AResponse);
Finally
FreeMem(AFCGI_Record);
AFCGI_Record:=Nil;
end;
- until (1<>1);
+ until Result;
end;
{ TCustomFCgiApplication }
diff --git a/packages/fcl-web/src/base/custweb.pp b/packages/fcl-web/src/base/custweb.pp
index 20b35f60f8..f0820619dd 100644
--- a/packages/fcl-web/src/base/custweb.pp
+++ b/packages/fcl-web/src/base/custweb.pp
@@ -557,6 +557,7 @@ end;
constructor TCustomWebApplication.Create(AOwner: TComponent);
begin
+ Inherited Create(AOwner);
FWebHandler := InitializeWebHandler;
FWebHandler.FOnTerminate:=@DoOnTerminate;
end;
diff --git a/packages/fcl-web/src/base/fphtml.pp b/packages/fcl-web/src/base/fphtml.pp
index 6c5bdb96d5..a6645732c1 100644
--- a/packages/fcl-web/src/base/fphtml.pp
+++ b/packages/fcl-web/src/base/fphtml.pp
@@ -42,15 +42,18 @@ type
TWebController = class;
THTMLContentProducer = class;
+ TJavaType = (jtOther, jtClientSideEvent);
+
TJavaScriptStack = class(TObject)
private
+ FJavaType: TJavaType;
FMessageBoxHandler: TMessageBoxHandler;
FScript: TStrings;
FWebController: TWebController;
protected
function GetWebController: TWebController;
public
- constructor Create(const AWebController: TWebController); virtual;
+ constructor Create(const AWebController: TWebController; const AJavaType: TJavaType); virtual;
destructor Destroy; override;
procedure AddScriptLine(ALine: String); virtual;
procedure MessageBox(AText: String; Buttons: TWebButtons; Loaded: string = ''); virtual;
@@ -61,6 +64,7 @@ type
function ScriptIsEmpty: Boolean; virtual;
function GetScript: String; virtual;
property WebController: TWebController read GetWebController;
+ property JavaType: TJavaType read FJavaType;
end;
{ TContainerStylesheet }
@@ -85,6 +89,35 @@ type
property Items[Index: integer]: TContainerStylesheet read GetItem write SetItem;
end;
+ { TJavaVariable }
+
+ TJavaVariable = class(TCollectionItem)
+ private
+ FBelongsTo: string;
+ FGetValueFunc: string;
+ FID: string;
+ FIDSuffix: string;
+ FName: string;
+ public
+ property BelongsTo: string read FBelongsTo write FBelongsTo;
+ property GetValueFunc: string read FGetValueFunc write FGetValueFunc;
+ property Name: string read FName write FName;
+ property ID: string read FID write FID;
+ property IDSuffix: string read FIDSuffix write FIDSuffix;
+ end;
+
+ { TJavaVariables }
+
+ TJavaVariables = class(TCollection)
+ private
+ function GetItem(Index: integer): TJavaVariable;
+ procedure SetItem(Index: integer; const AValue: TJavaVariable);
+ public
+ function Add: TJavaVariable;
+ property Items[Index: integer]: TJavaVariable read GetItem write SetItem;
+ end;
+
+
{ TWebController }
TWebController = class(TComponent)
@@ -94,9 +127,13 @@ type
FMessageBoxHandler: TMessageBoxHandler;
FScriptName: string;
FScriptStack: TFPObjectList;
+ FIterationIDs: array of string;
+ FJavaVariables: TJavaVariables;
procedure SetBaseURL(const AValue: string);
procedure SetScriptName(const AValue: string);
protected
+ function GetJavaVariables: TJavaVariables;
+ function GetJavaVariablesCount: integer;
function GetScriptFileReferences: TStringList; virtual; abstract;
function GetCurrentJavaScriptStack: TJavaScriptStack; virtual;
function GetStyleSheetReferences: TContainerStylesheets; virtual; abstract;
@@ -107,8 +144,8 @@ type
destructor Destroy; override;
procedure AddScriptFileReference(AScriptFile: String); virtual; abstract;
procedure AddStylesheetReference(Ahref, Amedia: String); virtual; abstract;
- function CreateNewJavascriptStack: TJavaScriptStack; virtual; abstract;
- function InitializeJavaScriptStack: TJavaScriptStack;
+ function CreateNewJavascriptStack(AJavaType: TJavaType): TJavaScriptStack; virtual; abstract;
+ function InitializeJavaScriptStack(AJavaType: TJavaType): TJavaScriptStack;
procedure FreeJavascriptStack; virtual;
function HasJavascriptStack: boolean; virtual; abstract;
function GetUrl(ParamNames, ParamValues, KeepParams: array of string; Action: string = ''): string; virtual; abstract;
@@ -117,12 +154,20 @@ type
procedure CleanupShowRequest; virtual;
procedure CleanupAfterRequest; virtual;
procedure BeforeGenerateHead; virtual;
+ function AddJavaVariable(AName, ABelongsTo, AGetValueFunc, AID, AIDSuffix: string): TJavaVariable;
procedure BindJavascriptCallstackToElement(AComponent: TComponent; AnElement: THtmlCustomElement; AnEvent: string); virtual; abstract;
function MessageBox(AText: String; Buttons: TWebButtons; ALoaded: string = ''): string; virtual;
function DefaultMessageBoxHandler(Sender: TObject; AText: String; Buttons: TWebButtons; ALoaded: string = ''): string; virtual; abstract;
function CreateNewScript: TStringList; virtual; abstract;
function AddrelativeLinkPrefix(AnURL: string): string;
procedure FreeScript(var AScript: TStringList); virtual; abstract;
+ procedure ShowRegisteredScript(ScriptID: integer); virtual; abstract;
+
+ function IncrementIterationLevel: integer; virtual;
+ procedure SetIterationIDSuffix(AIterationLevel: integer; IDSuffix: string); virtual;
+ function GetIterationIDSuffix: string; virtual;
+ procedure DecrementIterationLevel; virtual;
+
property ScriptFileReferences: TStringList read GetScriptFileReferences;
property StyleSheetReferences: TContainerStylesheets read GetStyleSheetReferences;
property Scripts: TFPObjectList read GetScripts;
@@ -190,6 +235,7 @@ type
FDocument: THTMLDocument;
FElement: THTMLCustomElement;
FWriter: THTMLWriter;
+ FIDSuffix: string;
procedure SetDocument(const AValue: THTMLDocument);
procedure SetWriter(const AValue: THTMLWriter);
private
@@ -201,6 +247,8 @@ type
procedure SetParent(const AValue: TComponent);
Protected
function CreateWriter (Doc : THTMLDocument) : THTMLWriter; virtual;
+ function GetIDSuffix: string; virtual;
+ procedure SetIDSuffix(const AValue: string); virtual;
protected
// Methods for streaming
FAcceptChildsAtDesignTime: boolean;
@@ -211,6 +259,7 @@ type
procedure AddEvent(var Events: TEventRecords; AServerEventID: integer; AServerEvent: THandleAjaxEvent; AJavaEventName: string; AcsCallBack: TCSAjaxEvent); virtual;
procedure DoOnEventCS(AnEvent: TEventRecord; AJavascriptStack: TJavaScriptStack; var Handled: boolean); virtual;
procedure SetupEvents(AHtmlElement: THtmlCustomElement); virtual;
+ function GetWebPage: TDataModule;
function GetWebController(const ExceptIfNotAvailable: boolean = true): TWebController;
property ContentProducerList: TFPList read GetContentProducerList;
public
@@ -221,6 +270,7 @@ type
property ParentElement : THTMLCustomElement read FElement write FElement;
property Writer : THTMLWriter read FWriter write SetWriter;
Property HTMLDocument : THTMLDocument read FDocument write SetDocument;
+ Property IDSuffix : string read GetIDSuffix write SetIDSuffix;
public
// for streaming
constructor Create(AOwner: TComponent); override;
@@ -480,6 +530,23 @@ resourcestring
SErrRequestNotHandled = 'Web request was not handled by actions.';
SErrNoContentProduced = 'The content producer "%s" didn''t produce any content.';
+{ TJavaVariables }
+
+function TJavaVariables.GetItem(Index: integer): TJavaVariable;
+begin
+ result := TJavaVariable(Inherited GetItem(Index));
+end;
+
+procedure TJavaVariables.SetItem(Index: integer; const AValue: TJavaVariable);
+begin
+ inherited SetItem(Index, AValue);
+end;
+
+function TJavaVariables.Add: TJavaVariable;
+begin
+ result := inherited Add as TJavaVariable;
+end;
+
{ TcontainerStylesheets }
function TcontainerStylesheets.GetItem(Index: integer): TContainerStylesheet;
@@ -505,10 +572,11 @@ begin
result := FWebController;
end;
-constructor TJavaScriptStack.Create(const AWebController: TWebController);
+constructor TJavaScriptStack.Create(const AWebController: TWebController; const AJavaType: TJavaType);
begin
FWebController := AWebController;
FScript := TStringList.Create;
+ FJavaType := AJavaType;
end;
destructor TJavaScriptStack.Destroy;
@@ -591,6 +659,16 @@ begin
Result:=THTMLContentProducer(ContentProducerList[Index]);
end;
+function THTMLContentProducer.GetIDSuffix: string;
+begin
+ result := FIDSuffix;
+end;
+
+procedure THTMLContentProducer.SetIDSuffix(const AValue: string);
+begin
+ FIDSuffix := AValue;
+end;
+
function THTMLContentProducer.GetContentProducerList: TFPList;
begin
if not assigned(FChilds) then
@@ -679,7 +757,7 @@ begin
wc := GetWebController(false);
if assigned(wc) then
begin
- AJSClass := wc.InitializeJavaScriptStack;
+ AJSClass := wc.InitializeJavaScriptStack(jtClientSideEvent);
try
for i := 0 to high(Events) do
begin
@@ -702,24 +780,44 @@ begin
end;
end;
+function THTMLContentProducer.GetWebPage: TDataModule;
+var
+ aowner: TComponent;
+begin
+ result := nil;
+ aowner := Owner;
+ while assigned(aowner) do
+ begin
+ if aowner.InheritsFrom(TWebPage) then
+ begin
+ result := TWebPage(aowner);
+ break;
+ end;
+ aowner:=aowner.Owner;
+ end;
+end;
+
function THTMLContentProducer.GetWebController(const ExceptIfNotAvailable: boolean): TWebController;
-var i : integer;
+var
+ i : integer;
+ wp: TWebPage;
begin
result := nil;
- if assigned(owner) then
+ wp := TWebPage(GetWebPage);
+ if assigned(wp) then
begin
- if (owner is TWebPage) and TWebPage(owner).HasWebController then
+ if wp.HasWebController then
begin
- result := TWebPage(owner).WebController;
+ result := wp.WebController;
exit;
- end
- else //if (owner is TDataModule) then
+ end;
+ end
+ else if assigned(Owner) then //if (owner is TDataModule) then
+ begin
+ for i := 0 to owner.ComponentCount-1 do if owner.Components[i] is TWebController then
begin
- for i := 0 to owner.ComponentCount-1 do if owner.Components[i] is TWebController then
- begin
- result := TWebController(Owner.Components[i]);
- Exit;
- end;
+ result := TWebController(Owner.Components[i]);
+ Exit;
end;
end;
if ExceptIfNotAvailable then
@@ -1199,7 +1297,7 @@ begin
FSendXMLAnswer:=true;
FResponse:=AResponse;
FWebController := AWebController;
- FJavascriptCallStack:=FWebController.InitializeJavaScriptStack;
+ FJavascriptCallStack:=FWebController.InitializeJavaScriptStack(jtOther);
end;
destructor TAjaxResponse.Destroy;
@@ -1248,6 +1346,21 @@ end;
{ TWebController }
+function TWebController.GetJavaVariables: TJavaVariables;
+begin
+ if not assigned(FJavaVariables) then
+ FJavaVariables := TJavaVariables.Create(TJavaVariable);
+ Result := FJavaVariables;
+end;
+
+function TWebController.GetJavaVariablesCount: integer;
+begin
+ if assigned(FJavaVariables) then
+ result := FJavaVariables.Count
+ else
+ result := 0;
+end;
+
procedure TWebController.SetBaseURL(const AValue: string);
begin
if FBaseURL=AValue then exit;
@@ -1262,7 +1375,10 @@ end;
function TWebController.GetCurrentJavaScriptStack: TJavaScriptStack;
begin
- result := TJavaScriptStack(FScriptStack.Items[FScriptStack.Count-1]);
+ if FScriptStack.Count>0 then
+ result := TJavaScriptStack(FScriptStack.Items[FScriptStack.Count-1])
+ else
+ result := nil;
end;
procedure TWebController.InitializeAjaxRequest;
@@ -1290,6 +1406,16 @@ begin
// do nothing
end;
+function TWebController.AddJavaVariable(AName, ABelongsTo, AGetValueFunc, AID, AIDSuffix: string): TJavaVariable;
+begin
+ result := GetJavaVariables.Add;
+ result.BelongsTo := ABelongsTo;
+ result.GetValueFunc := AGetValueFunc;
+ result.Name := AName;
+ result.IDSuffix := AIDSuffix;
+ result.ID := AID;
+end;
+
function TWebController.MessageBox(AText: String; Buttons: TWebButtons; ALoaded: string = ''): string;
begin
if assigned(MessageBoxHandler) then
@@ -1308,6 +1434,36 @@ begin
result := AnURL;
end;
+function TWebController.IncrementIterationLevel: integer;
+begin
+ result := Length(FIterationIDs)+1;
+ SetLength(FIterationIDs,Result);
+end;
+
+procedure TWebController.SetIterationIDSuffix(AIterationLevel: integer; IDSuffix: string);
+begin
+ FIterationIDs[AIterationLevel-1]:=IDSuffix;
+end;
+
+function TWebController.GetIterationIDSuffix: string;
+var
+ i: integer;
+begin
+ result := '';
+ for i := 0 to length(FIterationIDs)-1 do
+ result := result + '_' + FIterationIDs[i];
+end;
+
+procedure TWebController.DecrementIterationLevel;
+var
+ i: integer;
+begin
+ i := length(FIterationIDs);
+ if i=0 then
+ raise Exception.Create('DecrementIterationLevel can not be called more times then IncrementIterationLevel');
+ SetLength(FIterationIDs,i-1);
+end;
+
function TWebController.GetRequest: TRequest;
begin
if assigned(Owner) and (owner is TWebPage) then
@@ -1329,12 +1485,13 @@ begin
if (Owner is TWebPage) and (TWebPage(Owner).WebController=self) then
TWebPage(Owner).WebController := nil;
FScriptStack.Free;
+ if assigned(FJavaVariables) then FJavaVariables.Free;
inherited Destroy;
end;
-function TWebController.InitializeJavaScriptStack: TJavaScriptStack;
+function TWebController.InitializeJavaScriptStack(AJavaType: TJavaType): TJavaScriptStack;
begin
- result := CreateNewJavascriptStack;
+ result := CreateNewJavascriptStack(AJavaType);
FScriptStack.Add(result);
end;
diff --git a/packages/fcl-web/src/base/webpage.pp b/packages/fcl-web/src/base/webpage.pp
index 21911f1e29..c644c57bf8 100644
--- a/packages/fcl-web/src/base/webpage.pp
+++ b/packages/fcl-web/src/base/webpage.pp
@@ -31,6 +31,13 @@ type
property Designer: IWebPageDesigner read GetDesigner write SetDesigner;
end;
+ IHTMLIterationGroup = interface(IUnknown)
+ ['{95575CB6-7D96-4F72-AF72-D2EAF0BECE71}']
+ procedure SetIDSuffix(const AHTMLContentProducer: THTMLContentProducer);
+ procedure SetAjaxIterationID(AValue: String);
+ end;
+
+
{ TStandardWebController }
TStandardWebController = class(TWebController)
@@ -45,13 +52,14 @@ type
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
- function CreateNewJavascriptStack: TJavaScriptStack; override;
+ function CreateNewJavascriptStack(AJavaType: TJavaType): TJavaScriptStack; override;
function GetUrl(ParamNames, ParamValues, KeepParams: array of string; Action: string = ''): string; override;
procedure BindJavascriptCallstackToElement(AComponent: TComponent; AnElement: THtmlCustomElement; AnEvent: string); override;
procedure AddScriptFileReference(AScriptFile: String); override;
procedure AddStylesheetReference(Ahref, Amedia: String); override;
function DefaultMessageBoxHandler(Sender: TObject; AText: String; Buttons: TWebButtons; ALoaded: string = ''): string; override;
function CreateNewScript: TStringList; override;
+ procedure ShowRegisteredScript(ScriptID: integer); override;
procedure FreeScript(var AScript: TStringList); override;
end;
@@ -114,9 +122,22 @@ type
property BaseURL: string read FBaseURL write FBaseURL;
end;
+ function RegisterScript(AScript: string) : integer;
+
implementation
-uses rtlconsts, typinfo, XMLWrite;
+uses rtlconsts, typinfo, XMLWrite, strutils;
+
+var RegisteredScriptList : TStrings;
+
+function RegisterScript(AScript: string) : integer;
+begin
+ if not Assigned(RegisteredScriptList) then
+ begin
+ RegisteredScriptList := TStringList.Create;
+ end;
+ result := RegisteredScriptList.Add(AScript);
+end;
{ TWebPage }
@@ -184,6 +205,40 @@ var Handled: boolean;
CompName: string;
AComponent: TComponent;
AnAjaxResponse: TAjaxResponse;
+ i: integer;
+ ASuffixID: string;
+ AIterationGroup: IHTMLIterationGroup;
+ AIterComp: TComponent;
+ wc: TWebController;
+ Iterationlevel: integer;
+
+ procedure SetIdSuffixes(AComp: THTMLContentProducer);
+ var
+ i: integer;
+ s: string;
+ begin
+ if assigned(AComp.parent) and (acomp.parent is THTMLContentProducer) then
+ SetIdSuffixes(THTMLContentProducer(AComp.parent));
+ if supports(AComp,IHTMLIterationGroup,AIterationGroup) then
+ begin
+ if assigned(FWebController) then
+ begin
+ iterationlevel := FWebController.IncrementIterationLevel;
+ assert(length(ASuffixID)>0);
+ i := PosEx('_',ASuffixID,2);
+ if i > 0 then
+ s := copy(ASuffixID,2,i-2)
+ else
+ s := copy(ASuffixID,2,length(ASuffixID)-1);
+
+ acomp.IDSuffix := s;
+ AIterationGroup.SetAjaxIterationID(s);
+ FWebController.SetIterationIDSuffix(iterationlevel,s);
+ acomp.ForeachContentProducer(@AIterationGroup.SetIDSuffix,true);
+ ASuffixID := copy(ASuffixID,i,length(ASuffixID)-i+1);
+ end;
+ end;
+ end;
begin
SetRequest(ARequest);
FWebModule := AWebModule;
@@ -203,9 +258,28 @@ begin
begin
CompName := Request.QueryFields.Values['AjaxID'];
if CompName='' then CompName := Request.GetNextPathInfo;
- AComponent := FindComponent(CompName);
+
+ i := pos('$',CompName);
+ AComponent:=self;
+ while (i > 0) and (assigned(AComponent)) do
+ begin
+ AComponent := FindComponent(copy(CompName,1,i-1));
+ CompName := copy(compname,i+1,length(compname)-i);
+ i := pos('$',CompName);
+ end;
+ if assigned(AComponent) then
+ AComponent := AComponent.FindComponent(CompName);
+
if assigned(AComponent) and (AComponent is THTMLContentProducer) then
+ begin
+ // Handle the SuffixID, search for iteration-groups and set their iteration-id-values
+ ASuffixID := ARequest.QueryFields.Values['IterationID'];
+ if ASuffixID<>'' then
+ begin
+ SetIdSuffixes(THTMLContentProducer(AComponent));
+ end;
THTMLContentProducer(AComponent).HandleAjaxRequest(ARequest, AnAjaxResponse);
+ end;
end;
DoAfterAjaxRequest(ARequest, AnAjaxResponse);
except on E: Exception do
@@ -346,8 +420,13 @@ end;
function TWebPage.IsAjaxCall: boolean;
var s : string;
begin
- s := Request.HTTPXRequestedWith;
- result := sametext(s,'XmlHttpRequest');
+ if assigned(request) then
+ begin
+ s := Request.HTTPXRequestedWith;
+ result := sametext(s,'XmlHttpRequest');
+ end
+ else
+ result := false;
end;
{ TStandardWebController }
@@ -378,6 +457,22 @@ begin
GetScripts.Add(result);
end;
+procedure TStandardWebController.ShowRegisteredScript(ScriptID: integer);
+var
+ i: Integer;
+ s: string;
+begin
+ s := '// ' + inttostr(ScriptID);
+ for i := 0 to GetScripts.Count -1 do
+ if tstrings(GetScripts.Items[i]).Strings[0]=s then
+ Exit;
+ with CreateNewScript do
+ begin
+ Append(s);
+ Append(RegisteredScriptList.Strings[ScriptID]);
+ end;
+end;
+
procedure TStandardWebController.FreeScript(var AScript: TStringList);
begin
with GetScripts do
@@ -431,9 +526,9 @@ begin
inherited Destroy;
end;
-function TStandardWebController.CreateNewJavascriptStack: TJavaScriptStack;
+function TStandardWebController.CreateNewJavascriptStack(AJavaType: TJavaType): TJavaScriptStack;
begin
- Result:=TJavaScriptStack.Create(self);
+ Result:=TJavaScriptStack.Create(self, AJavaType);
end;
function TStandardWebController.GetUrl(ParamNames, ParamValues,
@@ -542,5 +637,10 @@ begin
end;
end;
+initialization
+ RegisteredScriptList := nil;
+finalization
+ if assigned(RegisteredScriptList) then
+ RegisteredScriptList.Free;
end.
diff --git a/packages/fcl-web/src/base/websession.pp b/packages/fcl-web/src/base/websession.pp
index e4bb54c2cd..4a607db441 100644
--- a/packages/fcl-web/src/base/websession.pp
+++ b/packages/fcl-web/src/base/websession.pp
@@ -332,6 +332,7 @@ begin
begin
{$ifdef cgidebug}SendDebug('Getting default session');{$endif}
FSession:=GetDefaultSession;
+ FSession.FreeNotification(Self);
end;
Result:=FSession
end;
diff --git a/packages/fcl-web/src/jsonrpc/fpextdirect.pp b/packages/fcl-web/src/jsonrpc/fpextdirect.pp
index 645042ed26..c8fde13c81 100644
--- a/packages/fcl-web/src/jsonrpc/fpextdirect.pp
+++ b/packages/fcl-web/src/jsonrpc/fpextdirect.pp
@@ -130,6 +130,7 @@ Type
Property DispatchOptions;
Property APIPath;
Property RouterPath;
+ Property CreateSession;
Property NameSpace;
end;
diff --git a/packages/fcl-web/src/jsonrpc/fpjsonrpc.pp b/packages/fcl-web/src/jsonrpc/fpjsonrpc.pp
index 8bb8676813..6fe9ba9d50 100644
--- a/packages/fcl-web/src/jsonrpc/fpjsonrpc.pp
+++ b/packages/fcl-web/src/jsonrpc/fpjsonrpc.pp
@@ -357,6 +357,10 @@ resourcestring
implementation
+{$IFDEF WMDEBUG}
+uses dbugintf;
+{$ENDIF}
+
function CreateJSONErrorObject(Const AMessage : String; Const ACode : Integer) : TJSONObject;
begin
@@ -1014,7 +1018,7 @@ Var
begin
Result:=Nil;
- {$ifdef wmdebug}SendDebug(Format('Creating instance for %s',[Self.ProviderName]));{$endif}
+ {$ifdef wmdebug}SendDebug(Format('Creating instance for %s',[Self.HandlerMethodName]));{$endif}
If Assigned(FDataModuleClass) then
begin
{$ifdef wmdebug}SendDebug(Format('Creating datamodule from class %d ',[Ord(Assigned(FDataModuleClass))]));{$endif}
diff --git a/packages/fcl-web/src/webdata/extjsjson.pp b/packages/fcl-web/src/webdata/extjsjson.pp
index 447a223580..01595bdc74 100644
--- a/packages/fcl-web/src/webdata/extjsjson.pp
+++ b/packages/fcl-web/src/webdata/extjsjson.pp
@@ -28,6 +28,8 @@ type
{ TExtJSJSONDataFormatter }
TJSONObjectEvent = Procedure(Sender : TObject; AObject : TJSONObject) of Object;
TJSONExceptionObjectEvent = Procedure(Sender : TObject; E : Exception; AResponse : TJSONObject) of Object;
+ TJSONObjectAllowRowEvent = Procedure(Sender : TObject; Dataset : TDataset; Var Allow : Boolean) of Object;
+ TJSONObjectAllowEvent = Procedure(Sender : TObject; AObject : TJSONObject; Var Allow : Boolean) of Object;
TExtJSJSONDataFormatter = Class(TExtJSDataFormatter)
private
@@ -37,13 +39,18 @@ type
FAfterRowToJSON: TJSONObjectEvent;
FAfterUpdate: TJSONObjectEvent;
FBeforeDataToJSON: TJSONObjectEvent;
+ FBeforeDelete: TNotifyEvent;
+ FBeforeInsert: TNotifyEvent;
FBeforeRowToJSON: TJSONObjectEvent;
+ FBeforeUpdate: TNotifyEvent;
+ FOnAllowRow: TJSONObjectAllowRowEvent;
FOnErrorResponse: TJSONExceptionObjectEvent;
FOnMetaDataToJSON: TJSONObjectEvent;
FBatchResult : TJSONArray;
Function AddIdToBatch : TJSONObject;
procedure SendSuccess(ResponseContent: TStream; AddIDValue : Boolean = False);
protected
+ function AllowRow(ADataset : TDataset) : Boolean; virtual;
Procedure StartBatch(ResponseContent : TStream); override;
Procedure NextBatchItem(ResponseContent : TStream); override;
Procedure EndBatch(ResponseContent : TStream); override;
@@ -77,12 +84,18 @@ type
Property BeforeDataToJSON : TJSONObjectEvent Read FBeforeDataToJSON Write FBeforeDataToJSON;
// Called when an exception is caught and formatted.
Property OnErrorResponse : TJSONExceptionObjectEvent Read FOnErrorResponse Write FOnErrorResponse;
+ // Called to decide whether a record is sent to the client;
+ Property OnAllowRow : TJSONObjectAllowRowEvent Read FOnAllowRow Write FOnAllowRow;
// After a record was succesfully updated
Property AfterUpdate : TJSONObjectEvent Read FAfterUpdate Write FAfterUpdate;
// After a record was succesfully inserted.
Property AfterInsert : TJSONObjectEvent Read FAfterInsert Write FAfterInsert;
// After a record was succesfully inserted.
Property AfterDelete : TJSONObjectEvent Read FAfterDelete Write FAfterDelete;
+ // From TCustomHTTPDataContentProducer
+ Property BeforeUpdate;
+ Property BeforeInsert;
+ Property BeforeDelete;
end;
implementation
@@ -337,9 +350,12 @@ begin
ACount:=PageSize;
While (not DS.EOF) and ((PageSize=0) or (ACount>0)) do
begin
- Inc(RCount);
- Dec(ACount);
- Rows.Add(RowToJSON);
+ If AllowRow(DS) then
+ begin
+ Inc(RCount);
+ Dec(ACount);
+ Rows.Add(RowToJSON);
+ end;
DS.Next;
end;
If (PageSize>0) then
@@ -411,6 +427,13 @@ begin
end;
end;
+function TExtJSJSONDataFormatter.AllowRow(ADataset: TDataset): Boolean;
+begin
+ Result:=True;
+ If Assigned(FOnAllowRow) then
+ FOnAllowRow(Self,Dataset,Result);
+end;
+
procedure TExtJSJSONDataFormatter.StartBatch(ResponseContent: TStream);
begin
If Assigned(FBatchResult) then
diff --git a/packages/fcl-web/src/webdata/fpwebdata.pp b/packages/fcl-web/src/webdata/fpwebdata.pp
index ea47199a9a..68c3591e61 100644
--- a/packages/fcl-web/src/webdata/fpwebdata.pp
+++ b/packages/fcl-web/src/webdata/fpwebdata.pp
@@ -132,6 +132,9 @@ type
TCustomHTTPDataContentProducer = Class(THTTPContentProducer)
Private
FAllowPageSize: Boolean;
+ FBeforeDelete: TNotifyEvent;
+ FBeforeInsert: TNotifyEvent;
+ FBeforeUpdate: TNotifyEvent;
FDataProvider: TFPCustomWebDataProvider;
FMetadata: Boolean;
FOnTranscode: TOnTranscodeEvent;
@@ -159,6 +162,12 @@ type
Procedure DoExceptionToStream(E : Exception; ResponseContent : TStream); virtual; abstract;
procedure Notification(AComponent: TComponent; Operation: TOperation);override;
Property Dataset: TDataset Read GetDataSet;
+ // Before a record is about to be updated
+ Property BeforeUpdate : TNotifyEvent Read FBeforeUpdate Write FBeforeUpdate;
+ // Before a record is about to be inserted
+ Property BeforeInsert : TNotifyEvent Read FBeforeInsert Write FBeforeInsert;
+ // Before a record is about to be deleted
+ Property BeforeDelete : TNotifyEvent Read FBeforeDelete Write FBeforeDelete;
Public
Constructor Create(AOwner : TComponent); override;
Property Adaptor : TCustomWebDataInputAdaptor Read FAdaptor Write SetAdaptor;
@@ -464,6 +473,7 @@ type
TFPWebProviderDataModule = Class(TFPCustomWebProviderDataModule)
Published
+ Property CreateSession;
Property InputAdaptor;
Property ContentProducer;
Property UseProviderManager;
@@ -975,17 +985,23 @@ end;
procedure TCustomHTTPDataContentProducer.DoUpdateRecord(ResponseContent: TStream);
begin
{$ifdef wmdebug}SendDebug('DoUpdateRecord: Updating record');{$endif}
+ If Assigned(FBeforeUpdate) then
+ FBeforeUpdate(Self);
Provider.Update;
{$ifdef wmdebug}SendDebug('DoUpdateRecord: Updated record');{$endif}
end;
procedure TCustomHTTPDataContentProducer.DoInsertRecord(ResponseContent: TStream);
begin
+ If Assigned(FBeforeInsert) then
+ FBeforeInsert(Self);
Provider.Insert;
end;
procedure TCustomHTTPDataContentProducer.DoDeleteRecord(ResponseContent: TStream);
begin
+ If Assigned(FBeforeDelete) then
+ FBeforeDelete(Self);
Provider.Delete;
end;
@@ -1663,6 +1679,7 @@ begin
Exit;
end;
end;
+ P:=Nil;
C:=FindComponent(AProviderName);
{$ifdef wmdebug}SendDebug(Format('Searching provider "%s" 1 : %d ',[AProvidername,Ord(Assigned(C))]));{$endif}
If (C<>Nil) and (C is TFPCustomWebDataProvider) then
@@ -1675,7 +1692,9 @@ begin
begin
{$ifdef wmdebug}SendDebug(Format('Found providerdef "%s" 1 : %d ',[AProvidername,Ord(Assigned(C))]));{$endif}
P:=WebDataProviderManager.GetProvider(ADef,Self,AContainer);
- end;
+ end
+ else
+ P:=Nil;
end;
{$ifdef wmdebug}SendDebug(Format('Searching provider "%s" 2 : %d ',[AProvidername,Ord(Assigned(C))]));{$endif}
Result:=P;
diff --git a/packages/fcl-web/src/webdata/sqldbwebdata.pp b/packages/fcl-web/src/webdata/sqldbwebdata.pp
index 33b1d7f8e1..28b5356045 100644
--- a/packages/fcl-web/src/webdata/sqldbwebdata.pp
+++ b/packages/fcl-web/src/webdata/sqldbwebdata.pp
@@ -17,6 +17,7 @@ Type
TCustomSQLDBWebDataProvider = Class(TFPCustomWebDataProvider)
private
FIDFieldName: String;
+ FONGetDataset: TNotifyEvent;
FOnGetNewID: TNewIDEvent;
FOnGetParamValue: TGetParamValueEvent;
FParams: TParams;
@@ -44,6 +45,7 @@ Type
Procedure DoApplyParams; override;
Function SQLQuery : TSQLQuery;
Function GetDataset : TDataset; override;
+ Function DoGetNewID : String; virtual;
Function GetNewID : String;
Function IDFieldValue : String; override;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
@@ -55,6 +57,7 @@ Type
Property OnGetNewID : TNewIDEvent Read FOnGetNewID Write FOnGetNewID;
property OnGetParameterType : TGetParamTypeEvent Read FOnGetParamType Write FOnGetParamType;
property OnGetParameterValue : TGetParamValueEvent Read FOnGetParamValue Write FOnGetParamValue;
+ Property OnGetDataset : TNotifyEvent Read FONGetDataset Write FOnGetDataset;
Property Params : TParams Read FParams Write SetParams;
Public
Constructor Create(AOwner : TComponent); override;
@@ -72,6 +75,7 @@ Type
Property OnGetNewID;
property OnGetParameterType;
property OnGetParameterValue;
+ Property OnGetDataset;
Property Options;
Property Params;
end;
@@ -273,7 +277,12 @@ Var
begin
ft:=GetParamtype(P,AValue);
- If ft<>ftUnknown then
+ If (AValue='') and (not (ft in [ftString,ftFixedChar,ftWideString,ftFixedWideChar])) then
+ begin
+ P.Clear;
+ exit;
+ end;
+ If (ft<>ftUnknown) then
begin
try
case ft of
@@ -358,7 +367,10 @@ begin
if not B then
begin
If (P.Name=IDFieldName) and DoNewID then
- SetTypedParam(P,GetNewID)
+ begin
+ GetNewID;
+ SetTypedParam(P,FLastNewID)
+ end
else If Adaptor.TryFieldValue(P.Name,S) then
SetTypedParam(P,S)
else If Adaptor.TryParamValue(P.Name,S) then
@@ -385,6 +397,8 @@ end;
function TCustomSQLDBWebDataProvider.GetDataset: TDataset;
begin
{$ifdef wmdebug}SendDebug('Get dataset: checking dataset');{$endif}
+ If Assigned(FonGetDataset) then
+ FOnGetDataset(Self);
CheckDataset;
FLastNewID:='';
Result:=FQuery;
@@ -394,12 +408,17 @@ begin
{$ifdef wmdebug}SendDebug('Get dataset: done');{$endif}
end;
-function TCustomSQLDBWebDataProvider.GetNewID: String;
-
+function TCustomSQLDBWebDataProvider.DoGetNewID: String;
begin
If Not Assigned(FOnGetNewID) then
Raise EFPHTTPError.CreateFmt(SErrNoNewIDEvent,[Self.Name]);
FOnGetNewID(Self,Result);
+end;
+
+function TCustomSQLDBWebDataProvider.GetNewID: String;
+
+begin
+ Result:=DoGetNewID;
FLastNewID:=Result;
end;
View Lorry Controller Status