diff options
author | marco <marco@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2011-05-27 15:39:26 +0000 |
---|---|---|
committer | marco <marco@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2011-05-27 15:39:26 +0000 |
commit | fb6daf010ff275e5f3628ca8a758d28858886274 (patch) | |
tree | 17db2ec6f423d5cb7fe03b195aee10a2d18514cb | |
parent | 3ecc3cdfdaef222e1627464fbbf507d6b626c705 (diff) | |
download | fpc-fb6daf010ff275e5f3628ca8a758d28858886274.tar.gz |
--- Merging r17165 into '.':
U packages/fcl-web/src/webdata/sqldbwebdata.pp
--- Merging r17166 into '.':
U packages/fcl-web/src/webdata/fpwebdata.pp
--- Merging r17167 into '.':
U packages/fcl-web/src/webdata/extjsjson.pp
--- Merging r17203 into '.':
U packages/fcl-web/src/base/custweb.pp
--- Merging r17204 into '.':
U packages/fcl-web/src/base/custfcgi.pp
--- Merging r17217 into '.':
U packages/fcl-web/src/base/webpage.pp
U packages/fcl-web/src/base/fphtml.pp
--- Merging r17262 into '.':
G packages/fcl-web/src/base/fphtml.pp
--- Merging r17278 into '.':
U packages/fcl-web/src/jsonrpc/fpjsonrpc.pp
--- Merging r17282 into '.':
G packages/fcl-web/src/webdata/fpwebdata.pp
U packages/fcl-web/src/jsonrpc/fpextdirect.pp
--- Merging r17283 into '.':
A packages/fcl-web/examples/combined
A packages/fcl-web/examples/combined/wmusers.lfm
A packages/fcl-web/examples/combined/wmusers.pp
A packages/fcl-web/examples/combined/combined.html
A packages/fcl-web/examples/combined/login.js
A packages/fcl-web/examples/combined/combined.ico
A packages/fcl-web/examples/combined/wmlogin.lfm
A packages/fcl-web/examples/combined/wmlogin.pp
A packages/fcl-web/examples/combined/login.png
A packages/fcl-web/examples/combined/combined.ini
A packages/fcl-web/examples/combined/users.sql
A packages/fcl-web/examples/combined/combined.lpi
A packages/fcl-web/examples/combined/users.html
A packages/fcl-web/examples/combined/wmusers.lrs
A packages/fcl-web/examples/combined/combined.res
A packages/fcl-web/examples/combined/combined.lpr
A packages/fcl-web/examples/combined/users.js
A packages/fcl-web/examples/combined/combined.sql
--- Merging r17322 into '.':
U packages/fcl-web/src/base/fpweb.pp
--- Merging r17329 into '.':
U packages/fcl-web/src/base/fpapache.pp
--- Merging r17373 into '.':
G packages/fcl-web/src/base/custfcgi.pp
--- Merging r17380 into '.':
U packages/fcl-web/src/base/httpdefs.pp
# revisions: 17165,17166,17167,17203,17204,17217,17262,17278,17282,17283,17322,17329,17373,17380
------------------------------------------------------------------------
r17165 | michael | 2011-03-23 09:25:11 +0100 (Wed, 23 Mar 2011) | 1 line
Changed paths:
M /trunk/packages/fcl-web/src/webdata/sqldbwebdata.pp
* OnGetDataset Event
------------------------------------------------------------------------
------------------------------------------------------------------------
r17166 | michael | 2011-03-23 09:25:42 +0100 (Wed, 23 Mar 2011) | 1 line
Changed paths:
M /trunk/packages/fcl-web/src/webdata/fpwebdata.pp
* BeforeDelete/Update/Insert events
------------------------------------------------------------------------
------------------------------------------------------------------------
r17167 | michael | 2011-03-23 09:26:39 +0100 (Wed, 23 Mar 2011) | 1 line
Changed paths:
M /trunk/packages/fcl-web/src/webdata/extjsjson.pp
* AllowRow event
------------------------------------------------------------------------
------------------------------------------------------------------------
r17203 | michael | 2011-03-29 12:53:08 +0200 (Tue, 29 Mar 2011) | 1 line
Changed paths:
M /trunk/packages/fcl-web/src/base/custweb.pp
* Inherited was not called
------------------------------------------------------------------------
------------------------------------------------------------------------
r17204 | michael | 2011-03-29 12:53:45 +0200 (Tue, 29 Mar 2011) | 1 line
Changed paths:
M /trunk/packages/fcl-web/src/base/custfcgi.pp
* Fixed some corner cases in readrecord
------------------------------------------------------------------------
------------------------------------------------------------------------
r17217 | joost | 2011-04-02 10:28:29 +0200 (Sat, 02 Apr 2011) | 7 lines
Changed paths:
M /trunk/packages/fcl-web/src/base/fphtml.pp
M /trunk/packages/fcl-web/src/base/webpage.pp
* Implemented the ability to register default scripts which can be added
to a webpage when needed
* Implemented multi-level Iteration id's
* Fixed possible AV in IsAjaxScript
* Javascriptstacks now have a type: jtOther or jtClientSideEvent
* Implemented TJavaVariables, which are available client-side and server-side
------------------------------------------------------------------------
------------------------------------------------------------------------
r17262 | joost | 2011-04-06 12:15:37 +0200 (Wed, 06 Apr 2011) | 1 line
Changed paths:
M /trunk/packages/fcl-web/src/base/fphtml.pp
* Fixed AV when no owner is set
------------------------------------------------------------------------
------------------------------------------------------------------------
r17278 | michael | 2011-04-10 12:57:59 +0200 (Sun, 10 Apr 2011) | 1 line
Changed paths:
M /trunk/packages/fcl-web/src/jsonrpc/fpjsonrpc.pp
* Fixed compilation with dmwdebug define
------------------------------------------------------------------------
------------------------------------------------------------------------
r17282 | michael | 2011-04-10 19:18:38 +0200 (Sun, 10 Apr 2011) | 1 line
Changed paths:
M /trunk/packages/fcl-web/src/jsonrpc/fpextdirect.pp
M /trunk/packages/fcl-web/src/webdata/fpwebdata.pp
* Published CreateSession property
------------------------------------------------------------------------
------------------------------------------------------------------------
r17283 | michael | 2011-04-10 19:59:36 +0200 (Sun, 10 Apr 2011) | 1 line
Changed paths:
A /trunk/packages/fcl-web/examples/combined
A /trunk/packages/fcl-web/examples/combined/combined.html
A /trunk/packages/fcl-web/examples/combined/combined.ico
A /trunk/packages/fcl-web/examples/combined/combined.ini
A /trunk/packages/fcl-web/examples/combined/combined.lpi
A /trunk/packages/fcl-web/examples/combined/combined.lpr
A /trunk/packages/fcl-web/examples/combined/combined.res
A /trunk/packages/fcl-web/examples/combined/combined.sql
A /trunk/packages/fcl-web/examples/combined/login.js
A /trunk/packages/fcl-web/examples/combined/login.png
A /trunk/packages/fcl-web/examples/combined/users.html
A /trunk/packages/fcl-web/examples/combined/users.js
A /trunk/packages/fcl-web/examples/combined/users.sql
A /trunk/packages/fcl-web/examples/combined/wmlogin.lfm
A /trunk/packages/fcl-web/examples/combined/wmlogin.pp
A /trunk/packages/fcl-web/examples/combined/wmusers.lfm
A /trunk/packages/fcl-web/examples/combined/wmusers.lrs
A /trunk/packages/fcl-web/examples/combined/wmusers.pp
* Added combined example: login using RPC and edit data using FPWebdata
------------------------------------------------------------------------
------------------------------------------------------------------------
r17322 | michael | 2011-04-15 10:13:05 +0200 (Fri, 15 Apr 2011) | 1 line
Changed paths:
M /trunk/packages/fcl-web/src/base/fpweb.pp
* Free Contents of TFPWebAction in Destructor
------------------------------------------------------------------------
------------------------------------------------------------------------
r17329 | michael | 2011-04-16 16:36:19 +0200 (Sat, 16 Apr 2011) | 1 line
Changed paths:
M /trunk/packages/fcl-web/src/base/fpapache.pp
* Fixed compilation of apache modules in Lazarus
------------------------------------------------------------------------
------------------------------------------------------------------------
r17373 | michael | 2011-04-26 16:50:43 +0200 (Tue, 26 Apr 2011) | 1 line
Changed paths:
M /trunk/packages/fcl-web/src/base/custfcgi.pp
* Address must be preserved throughout accept calls
------------------------------------------------------------------------
------------------------------------------------------------------------
r17380 | michael | 2011-04-28 18:48:30 +0200 (Thu, 28 Apr 2011) | 1 line
Changed paths:
M /trunk/packages/fcl-web/src/base/httpdefs.pp
* Assign filename to uploaded file (bug id 18337; Firefox engine allows empty name)
------------------------------------------------------------------------
git-svn-id: http://svn.freepascal.org/svn/fpc/branches/fixes_2_4@17574 3ad0048d-3df7-0310-abae-a5850022a9f2
29 files changed, 1300 insertions, 40 deletions
diff --git a/packages/fcl-web/examples/combined/combined.html b/packages/fcl-web/examples/combined/combined.html new file mode 100644 index 0000000000..377a592a90 --- /dev/null +++ b/packages/fcl-web/examples/combined/combined.html @@ -0,0 +1,20 @@ +<html> +<head> +<title>ExtJS application demo</title> +<link rel="stylesheet" type="text/css" href="/ext/resources/css/ext-all.css"/> +<script src="/ext/adapter/ext/ext-base.js"></script> +<script src="/ext/ext-all-debug.js"></script> +<script src="combined.cgi/Login/API"></script> +<script src="login.js"></script> +<script> +Ext.onReady(function() { + // API is registered under FPWeb by default. + Ext.Direct.addProvider(FPWeb); + fpWeb.login=new fpWeb.LoginForm({}); + fpWeb.login.show(); +}); +</script> +</head> +<body> +</body> +</html>
\ No newline at end of file diff --git a/packages/fcl-web/examples/combined/combined.ico b/packages/fcl-web/examples/combined/combined.ico Binary files differnew file mode 100644 index 0000000000..0341321b5d --- /dev/null +++ b/packages/fcl-web/examples/combined/combined.ico diff --git a/packages/fcl-web/examples/combined/combined.ini b/packages/fcl-web/examples/combined/combined.ini new file mode 100644 index 0000000000..4220bcf27d --- /dev/null +++ b/packages/fcl-web/examples/combined/combined.ini @@ -0,0 +1,4 @@ +[Database] +Path=/home/firebird/combined.fb +UserName=WISASOFT +Password=SysteemD diff --git a/packages/fcl-web/examples/combined/combined.lpi b/packages/fcl-web/examples/combined/combined.lpi new file mode 100644 index 0000000000..beb1bbc61e --- /dev/null +++ b/packages/fcl-web/examples/combined/combined.lpi @@ -0,0 +1,116 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <General> + <Flags> + <SaveOnlyProjectUnits Value="True"/> + <MainUnitHasCreateFormStatements Value="False"/> + <Runnable Value="False"/> + </Flags> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="Combined RPC/Webdata example"/> + <ResourceType Value="res"/> + <UseXPManifest Value="True"/> + <Icon Value="0"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + <LaunchingApplication PathPlusParams="/usr/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/> + </local> + </RunParams> + <RequiredPackages Count="5"> + <Item1> + <PackageName Value="SQLDBLaz"/> + <MinVersion Major="1" Release="1" Valid="True"/> + </Item1> + <Item2> + <PackageName Value="lazwebextra"/> + <MinVersion Minor="9" Valid="True"/> + </Item2> + <Item3> + <PackageName Value="WebLaz"/> + </Item3> + <Item4> + <PackageName Value="LCL"/> + </Item4> + <Item5> + <PackageName Value="FCL"/> + </Item5> + </RequiredPackages> + <Units Count="5"> + <Unit0> + <Filename Value="combined.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="combined"/> + </Unit0> + <Unit1> + <Filename Value="wmlogin.pp"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="SessionManagement"/> + <ResourceBaseClass Value="DataModule"/> + <UnitName Value="wmlogin"/> + </Unit1> + <Unit2> + <Filename Value="wmusers.pp"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="CombinedModule"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="DataModule"/> + <UnitName Value="wmusers"/> + </Unit2> + <Unit3> + <Filename Value="login.js"/> + <IsPartOfProject Value="True"/> + </Unit3> + <Unit4> + <Filename Value="users.js"/> + <IsPartOfProject Value="True"/> + </Unit4> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="10"/> + <Target> + <Filename Value="combined.cgi"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + </SearchPaths> + <Other> + <CompilerMessages> + <UseMsgFile Value="True"/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/packages/fcl-web/examples/combined/combined.lpr b/packages/fcl-web/examples/combined/combined.lpr new file mode 100644 index 0000000000..a1450e60c6 --- /dev/null +++ b/packages/fcl-web/examples/combined/combined.lpr @@ -0,0 +1,15 @@ +program combined; + +{$mode objfpc}{$H+} + +uses + fpCGI, wmusers, httpdefs, websession,wmlogin; + +{$R *.res} + +begin + Application.Title:='Combined RPC/Webdata example'; + Application.Initialize; + Application.Run; +end. + diff --git a/packages/fcl-web/examples/combined/combined.res b/packages/fcl-web/examples/combined/combined.res Binary files differnew file mode 100644 index 0000000000..7c6cf3e4be --- /dev/null +++ b/packages/fcl-web/examples/combined/combined.res diff --git a/packages/fcl-web/examples/combined/combined.sql b/packages/fcl-web/examples/combined/combined.sql new file mode 100644 index 0000000000..e5b4c595aa --- /dev/null +++ b/packages/fcl-web/examples/combined/combined.sql @@ -0,0 +1,11 @@ +CREATE TABLE USERS ( + U_ID BIGINT NOT NULL, + U_LOGIN VARCHAR(40) NOT NULL, + U_NAME VARCHAR(30) NOT NULL, + U_EMAIL VARCHAR(100), + U_PASSWORD VARCHAR(100) NOT NULL, + CONSTRAINT PK_FPCUSERS PRIMARY KEY (U_ID), + CONSTRAINT U_USERNAME UNIQUE (U_LOGIN) +); + +
\ No newline at end of file diff --git a/packages/fcl-web/examples/combined/login.js b/packages/fcl-web/examples/combined/login.js new file mode 100644 index 0000000000..8d78375d30 --- /dev/null +++ b/packages/fcl-web/examples/combined/login.js @@ -0,0 +1,105 @@ +Ext.ns("fpWeb"); +fpWeb.LoginForm = Ext.extend (Ext.Window, { + /* Control references */ + blogin : null, + eusername : null, + epassword : null, + plock : null, + fform : null, + /* Callbacks */ + OnLogin : function (Provider,Response) { + if (!Ext.isEmpty(Response.error)) { + Ext.Msg.show({ + title : 'Login failed', + msg : 'An error occurred during login: '+Response.error.message+'. Please try again.', + icon : Ext.Msg.ERROR, + buttons : Ext.Msg.OK + }); + } else if (Response.result > 0) { + // here code to switch to data editing + window.location='users.html'; +/* + Ext.Msg.show({ + title : 'Login OK', + msg : 'Your username/pasword was accepted. We will now proceed to the editing form', + icon : Ext.Msg.ERROR, + buttons : Ext.Msg.OK + }); +*/ + } else { + Ext.Msg.show({ + title : 'Login failed', + msg : 'Your username/pasword is incorrect. Please try again.', + icon : Ext.Msg.ERROR, + buttons : Ext.Msg.OK + }); + } + }, + loginbuttonclick : function (sender) { + SessionManagement.Login(this.eusername.getValue(), this.epassword.getValue(),this.OnLogin.createDelegate(this)); + }, + focususer : function () { + this.eusername.focus(); + }, + /* Build the actual form */ + constructor : function (config) { + this.eusername = new Ext.form.TextField({ + name:"user", + fieldLabel:"Login", + inputType:"text" + }); + this.epassword = new Ext.form.TextField({ + name:"pass", + fieldLabel:"Password", + inputType:"password" + }); + this.blogin = new Ext.Button({ + text:"Login", + handler : this.loginbuttonclick, + scope : this + }); + this.fform = new Ext.form.FormPanel({ + width: 350, + labelWidth:150, + border:false, + xtype: "form", + buttonAlign: "right", + bodyStyle: "padding: 10px 15px", + defaultType: "textfield", + defaults: {width: 150}, + items: [this.eusername,this.epassword], + buttons:[this.blogin], + keys: {key: Ext.EventObject.ENTER, + handler: function(){ + this.blogin.focus(); + }, + scope: this + } + }); + this.plock = new Ext.Panel({ + border:false, + html:"<img src='login.png' width=114 height=128/>", + width:114, + height:128 + }); + Ext.apply(config, { + title: "Login", + width: 500, + height: 200, + plain: true, + layout: "hbox", + defaultButton: this.eusername, + layoutConfig: { + align : "middle", + pack: "center" + }, + closable: false, + listeners: { + 'show' : { fn: this.focususer.createDelegate(this) } + }, + items: [ this.fform, this.plock ] + }); + fpWeb.LoginForm.superclass.constructor.call(this,config); + } /* constructor*/ +}); + diff --git a/packages/fcl-web/examples/combined/login.png b/packages/fcl-web/examples/combined/login.png Binary files differnew file mode 100644 index 0000000000..e1a2633df2 --- /dev/null +++ b/packages/fcl-web/examples/combined/login.png diff --git a/packages/fcl-web/examples/combined/users.html b/packages/fcl-web/examples/combined/users.html new file mode 100644 index 0000000000..ea47d6f45d --- /dev/null +++ b/packages/fcl-web/examples/combined/users.html @@ -0,0 +1,18 @@ +<html> +<head> +<title>Edit users in database</title> +<link rel="stylesheet" type="text/css" href="/ext/resources/css/ext-all.css"/> +<script src="/ext/adapter/ext/ext-base.js"></script> +<script src="/ext/ext-all-debug.js"></script> +<script src="combined.cgi/Login/API"></script> +<script src="users.js"></script> +<script> +Ext.onReady(function() { + // API is registered under FPWeb by default. + Ext.Direct.addProvider(FPWeb); +}); +</script> +</head> +<body> +</body> +</html>
\ No newline at end of file diff --git a/packages/fcl-web/examples/combined/users.js b/packages/fcl-web/examples/combined/users.js new file mode 100644 index 0000000000..063c2dca6f --- /dev/null +++ b/packages/fcl-web/examples/combined/users.js @@ -0,0 +1,108 @@ +Ext.ns('fpWeb'); + +fpWeb.ShowPage = function () { + var myproxy = new Ext.data.HttpProxy ( { + api : { + read: "combined.cgi/Provider/Users/Read/", + update: "combined.cgi/Provider/Users/Update/", + create: "combined.cgi/Provider/Users/Insert/", + destroy: "combined.cgi/Provider/Users/Delete/" + } + }); + var myreader = new Ext.data.JsonReader ({ + root: "rows", + successProperty : 'success', + idProperty: "U_ID", + messageProperty: 'message', // Must be specified here + fields: ["U_ID","U_LOGIN","U_NAME","U_EMAIL", "U_PASSWORD"] + }); + var mywriter = new Ext.data.JsonWriter({ + encode: true, + writeAllFields: true, + idProperty: "U_ID" + }); + var data = new Ext.data.Store({ + proxy: myproxy, + reader: myreader, + writer: mywriter, + autoSave: false, + idProperty: "U_ID", + }); + // Listen to errors. + data.addListener('exception', function(proxy, type, action, options, res) { + if (type === 'remote') { + Ext.Msg.show({ + title: 'REMOTE EXCEPTION', + msg: res.message, + icon: Ext.MessageBox.ERROR, + buttons: Ext.Msg.OK + }); + } + }); + data.load({ params:{start: 0, limit: 30}}); + var grid = new Ext.grid.EditorGridPanel({ + renderTo: Ext.getBody(), + frame: true, + title: "Known users", + height: 600, + width: 800, + store: data, + columns: [ + {header: 'ID', dataIndex: "U_ID", sortable: true, hidden: true}, + {header: 'Login', dataIndex: "U_LOGIN", sortable: true, editor: new Ext.form.TextField({allowBlank: false})}, + {header: 'Name', dataIndex: "U_NAME", sortable: true, editor: new Ext.form.TextField({allowBlank: false}), width : 200}, + {header: 'Email', dataIndex: "U_EMAIL", sortable: true, editor: new Ext.form.TextField({allowBlank: false}), width : 200}, + {header: 'Password', dataIndex: "U_PASSWORD", sortable: true, editor: new Ext.form.TextField()}, + ], + bbar: new Ext.PagingToolbar({ + pageSize: 30, + store: data, + displayInfo: true + }), + tbar : [{ + text: 'Add', + iconCls: 'icon-add', + handler: function(btn, ev) { + var u = new grid.store.recordType(); + grid.stopEditing(); + grid.store.insert(0, u); + grid.startEditing(0, 1); + }, + scope: grid + }, '-', { + text: 'Delete', + iconCls: 'icon-delete', + handler: function(btn, ev) { + var index = grid.getSelectionModel().getSelectedCell(); + if (!index) { + return false; + } + var rec = grid.store.getAt(index[0]); + grid.store.remove(rec); + }, + scope: grid + }, '-', { + text: 'Save', + iconCls: 'icon-save', + handler: function(btn, ev) { + grid.store.save(); + }, + scope: grid + },'->', { + text: 'Log out', + iconCls: 'logout', + handler: function () { + SessionManagement.Logout(function (provider,response) { + if (response.result=='Bye') { + window.location='combined.html'; + } + }); + } + } + ] + // F.ContentToStream(M); + + }); + grid.show(); +} +Ext.onReady(fpWeb.ShowPage); diff --git a/packages/fcl-web/examples/combined/users.sql b/packages/fcl-web/examples/combined/users.sql new file mode 100644 index 0000000000..daec6fb64d --- /dev/null +++ b/packages/fcl-web/examples/combined/users.sql @@ -0,0 +1,15 @@ +CREATE TABLE USERS ( +U_ID BIGINT Not Null , +U_LOGIN VARCHAR(40) Not Null, +U_NAME VARCHAR(30) Not Null, +U_EMAIL VARCHAR(100), +U_PASSWORD VARCHAR(100) Not Null, +CONSTRAINT PK_FPCUSERS Primary key (U_ID), +CONSTRAINT U_USERNAME Unique key (U_LOGIN) +); + +COMMIT; + +CREATE GENERATOR GEN_USERS; + +COMMIT; diff --git a/packages/fcl-web/examples/combined/wmlogin.lfm b/packages/fcl-web/examples/combined/wmlogin.lfm new file mode 100644 index 0000000000..e41c9d2bc0 --- /dev/null +++ b/packages/fcl-web/examples/combined/wmlogin.lfm @@ -0,0 +1,76 @@ +object SessionManagement: TSessionManagement + OnCreate = DataModuleCreate + OldCreateOrder = False + DispatchOptions = [jdoSearchRegistry, jdoSearchOwner, jdoJSONRPC1, jdoJSONRPC2, jdoNotifications] + APIPath = 'API' + RouterPath = 'router' + Height = 200 + HorizontalOffset = 582 + VerticalOffset = 455 + Width = 295 + object Login: TJSONRPCHandler + OnExecute = LoginExecute + Options = [] + ParamDefs = < + item + Name = 'UserName' + end + item + Name = 'Password' + end> + left = 24 + top = 24 + end + object IBConnection1: TIBConnection + Connected = False + LoginPrompt = False + KeepConnection = False + Transaction = SQLTransaction1 + LogEvents = [] + left = 24 + top = 117 + end + object SQLTransaction1: TSQLTransaction + Active = False + Action = caNone + Database = IBConnection1 + left = 26 + top = 72 + end + object QAuthenticate: TSQLQuery + AutoCalcFields = False + Database = IBConnection1 + Transaction = SQLTransaction1 + ReadOnly = False + SQL.Strings = ( + 'SELECT' + ' U_ID, U_NAME' + 'From' + ' USERS' + 'WHERE' + ' (U_LOGIN = :LOGIN)' + ' AND (U_PASSWORD=:PASSWORD);' + '' + ) + Params = < + item + DataType = ftUnknown + Name = 'LOGIN' + ParamType = ptUnknown + end + item + DataType = ftUnknown + Name = 'PASSWORD' + ParamType = ptUnknown + end> + left = 128 + top = 117 + end + object Logout: TJSONRPCHandler + OnExecute = LogoutExecute + Options = [] + ParamDefs = <> + left = 120 + top = 16 + end +end diff --git a/packages/fcl-web/examples/combined/wmlogin.pp b/packages/fcl-web/examples/combined/wmlogin.pp new file mode 100644 index 0000000000..671dedcd27 --- /dev/null +++ b/packages/fcl-web/examples/combined/wmlogin.pp @@ -0,0 +1,129 @@ +unit wmlogin; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, FileUtil, HTTPDefs, websession, fpHTTP, fpWeb, fpjsonrpc, + fpjson, IBConnection, sqldb, webjsonrpc, fpextdirect, sqldbwebdata; + +type + + { TSessionManagement } + + TSessionManagement = class(TExtDirectModule) + IBConnection1: TIBConnection; + Logout: TJSONRPCHandler; + Login: TJSONRPCHandler; + SessionManagement: TJSONRPCHandler; + QAuthenticate: TSQLQuery; + SQLTransaction1: TSQLTransaction; + procedure DataModuleCreate(Sender: TObject); + procedure LoginExecute(Sender: TObject; const Params: TJSONData; + out Res: TJSONData); + procedure LogoutExecute(Sender: TObject; const Params: TJSONData; + out Res: TJSONData); + private + function AuthenticateUser(AUsername, APassword: String): Integer; + procedure DoOnNewSession(Sender: TObject); + { private declarations } + public + { public declarations } + end; + +var + SessionManagement: TSessionManagement; + +implementation + +uses inifiles; + +{$R *.lfm} + +{ TSessionManagement } + +function TSessionManagement.AuthenticateUser(AUsername,APassword : String) : Integer; + +begin + With QAuthenticate do + begin + ParamByName('Login').AsString:=AUserName; + ParamByName('Password').AsString:=APassword; + Open; + try + if (EOF and BOF) then + Result:=-1 + else + begin + Result:=FieldByName('U_ID').AsInteger; + Session.Variables['UserName']:=FieldByName('U_NAME').AsString; + end; + Session.Variables['UserID']:=IntToStr(Result); + finally + Close; + end; + end; +end; + +procedure TSessionManagement.LoginExecute(Sender: TObject; + const Params: TJSONData; out Res: TJSONData); + +Var + A : TJSONArray ; + AUserName,APassword : String; +begin + A:=Params as TJSONArray; + AUserName:=A.Strings[0]; + APassword:=A.Strings[1]; + Res:=TJSONIntegerNumber.Create(AuthenticateUser(AUsername,APassword)); +end; + +procedure TSessionManagement.LogoutExecute(Sender: TObject; + const Params: TJSONData; out Res: TJSONData); +begin + // To be sure + Session.Variables['UserID']:='-1'; + Session.Terminate; + // A result must always be sent back. + Res:=TJSONString.Create('Bye'); +end; + +procedure TSessionManagement.DoOnNewSession(Sender : TObject); + +begin + // The cookies must all originate from the same path, otherwise the 2 datamodules will use a different session. + (Sender as TFPWebSession).SessionCookiePath:='/'; +end; + +procedure TSessionManagement.DataModuleCreate(Sender: TObject); +Var + FN : String; + Ini : TMemIniFile; + +begin + // The following 2 statements are needed because the 2 properties are (currently) not published. + OnNewSession:=@DoOnNewSession; + CreateSession:=True; + FN:=ChangeFileExt(Paramstr(0),'.ini'); + If FileExists(FN) then + begin + Ini:=TMemIniFile.Create(FN); + try + With IBConnection1 do + begin + DatabaseName:=Ini.ReadString('Database','Path',DatabaseName); + UserName:=Ini.ReadString('Database','UserName',UserName); + Password:=Ini.ReadString('Database','Password',Password); + end; + finally + Ini.Free; + end; + end; + IBConnection1.Connected:=True; +end; + +initialization + RegisterHTTPModule('Login', TSessionManagement); +end. + diff --git a/packages/fcl-web/examples/combined/wmusers.lfm b/packages/fcl-web/examples/combined/wmusers.lfm new file mode 100644 index 0000000000..15f6dcad02 --- /dev/null +++ b/packages/fcl-web/examples/combined/wmusers.lfm @@ -0,0 +1,94 @@ +object CombinedModule: TCombinedModule + OnCreate = DataModuleCreate + OldCreateOrder = False + InputAdaptor = ProviderInputAdaptor + ContentProducer = ProviderFormatter + OnGetContentProducer = DataModuleGetContentProducer + OnGetInputAdaptor = DataModuleGetInputAdaptor + OnNewSession = DataModuleNewSession + Height = 300 + HorizontalOffset = 635 + VerticalOffset = 230 + Width = 400 + object ProviderFormatter: TExtJSJSONDataFormatter + AllowPageSize = False + BeforeDataToJSON = ProviderFormatterBeforeDataToJSON + BeforeUpdate = ProviderFormatterBeforeUpdate + BeforeInsert = ProviderFormatterBeforeInsert + BeforeDelete = ProviderFormatterBeforeDelete + left = 272 + top = 72 + end + object Users: TSQLDBWebDataProvider + SelectSQL.Strings = ( + 'SELECT FIRST :limit SKIP :start U_ID, U_NAME, U_LOGIN, U_PASSWORD, U_EMAIL FROM USERS' + ) + UpdateSQL.Strings = ( + 'UPDATE USERS SET' + ' U_NAME=:U_NAME,' + ' U_LOGIN=:U_LOGIN,' + ' U_EMAIL=:U_EMAIL,' + ' U_PASSWORD=:U_PASSWORD' + 'WHERE' + ' (U_ID=:U_ID)' + ) + DeleteSQL.Strings = ( + 'DELETE FROM USERS WHERE (U_ID=:ID)' + ) + InsertSQL.Strings = ( + 'INSERT INTO USERS' + '(U_ID, U_LOGIN, U_NAME, U_EMAIL, U_PASSWORD)' + 'VALUES' + '(:U_ID, :U_LOGIN, :U_NAME, :U_EMAIL, :U_PASSWORD)' + ) + Connection = IBConnection1 + IDFieldName = 'U_ID' + OnGetNewID = UsersGetNewID + Options = [] + Params = < + item + DataType = ftUnknown + Name = 'limit' + ParamType = ptUnknown + end + item + DataType = ftUnknown + Name = 'start' + ParamType = ptUnknown + end> + left = 32 + top = 72 + end + object IBConnection1: TIBConnection + Connected = False + LoginPrompt = False + KeepConnection = False + Transaction = SQLTransaction1 + LogEvents = [] + left = 32 + top = 16 + end + object QGetID: TSQLQuery + AutoCalcFields = False + Database = IBConnection1 + Transaction = SQLTransaction1 + ReadOnly = False + SQL.Strings = ( + 'SELECT GEN_ID(GEN_USERS,1) AS THEID FROM RDB$DATABASE' + ) + Params = <> + left = 32 + top = 128 + end + object SQLTransaction1: TSQLTransaction + Active = False + Action = caNone + Database = IBConnection1 + left = 144 + top = 16 + end + object ProviderInputAdaptor: TExtJSJSonWebdataInputAdaptor + left = 272 + top = 16 + end +end diff --git a/packages/fcl-web/examples/combined/wmusers.lrs b/packages/fcl-web/examples/combined/wmusers.lrs new file mode 100644 index 0000000000..7d7cb7082d --- /dev/null +++ b/packages/fcl-web/examples/combined/wmusers.lrs @@ -0,0 +1,35 @@ +{ This is an automatically generated lazarus resource file } + +LazarusResources.Add('TCombinedModule','FORMDATA',[ + 'TPF0'#15'TCombinedModule'#14'CombinedModule'#8'OnCreate'#7#16'DataModuleCrea' + +'te'#14'OldCreateOrder'#8#12'InputAdaptor'#7#20'ProviderInputAdaptor'#15'Con' + +'tentProducer'#7#17'ProviderFormatter'#20'OnGetContentProducer'#7#28'DataMod' + +'uleGetContentProducer'#17'OnGetInputAdaptor'#7#25'DataModuleGetInputAdaptor' + +#12'OnNewSession'#7#20'DataModuleNewSession'#6'Height'#3','#1#16'HorizontalO' + +'ffset'#3'{'#2#14'VerticalOffset'#3#230#0#5'Width'#3#144#1#0#23'TExtJSJSONDa' + +'taFormatter'#17'ProviderFormatter'#13'AllowPageSize'#8#16'BeforeDataToJSON' + +#7'!ProviderFormatterBeforeDataToJSON'#12'BeforeUpdate'#7#29'ProviderFormatt' + +'erBeforeUpdate'#12'BeforeInsert'#7#29'ProviderFormatterBeforeInsert'#12'Bef' + +'oreDelete'#7#29'ProviderFormatterBeforeDelete'#4'left'#3#16#1#3'top'#2'H'#0 + +#0#21'TSQLDBWebDataProvider'#5'Users'#17'SelectSQL.Strings'#1#6'USELECT FIRS' + +'T :limit SKIP :start U_ID, U_NAME, U_LOGIN, U_PASSWORD, U_EMAIL FROM USERS' + +#0#17'UpdateSQL.Strings'#1#6#16'UPDATE USERS SET'#6#17' U_NAME=:U_NAME,'#6 + +#19' U_LOGIN=:U_LOGIN,'#6#19' U_EMAIL=:U_EMAIL,'#6#24' U_PASSWORD=:U_PASS' + +'WORD'#6#5'WHERE'#6#14' (U_ID=:U_ID)'#0#17'DeleteSQL.Strings'#1#6'"DELETE F' + +'ROM USERS WHERE (U_ID=:ID)'#0#17'InsertSQL.Strings'#1#6#17'INSERT INTO USER' + +'S'#6',(U_ID, U_LOGIN, U_NAME, U_EMAIL, U_PASSWORD)'#6#6'VALUES'#6'1(:U_ID, ' + +':U_LOGIN, :U_NAME, :U_EMAIL, :U_PASSWORD)'#0#10'Connection'#7#13'IBConnecti' + +'on1'#11'IDFieldName'#6#4'U_ID'#10'OnGetNewID'#7#13'UsersGetNewID'#7'Options' + +#11#0#6'Params'#14#1#8'DataType'#7#9'ftUnknown'#4'Name'#6#5'limit'#9'ParamTy' + +'pe'#7#9'ptUnknown'#0#1#8'DataType'#7#9'ftUnknown'#4'Name'#6#5'start'#9'Para' + +'mType'#7#9'ptUnknown'#0#0#4'left'#2' '#3'top'#2'H'#0#0#13'TIBConnection'#13 + +'IBConnection1'#9'Connected'#8#11'LoginPrompt'#8#14'KeepConnection'#8#11'Tra' + +'nsaction'#7#15'SQLTransaction1'#9'LogEvents'#11#0#4'left'#2' '#3'top'#2#16#0 + +#0#9'TSQLQuery'#6'QGetID'#14'AutoCalcFields'#8#8'Database'#7#13'IBConnection' + +'1'#11'Transaction'#7#15'SQLTransaction1'#8'ReadOnly'#8#11'SQL.Strings'#1#6 + +'6SELECT GEN_ID(GEN_USERS,1) AS THEID FROM RDB$DATABASE'#0#6'Params'#14#0#4 + +'left'#2' '#3'top'#3#128#0#0#0#15'TSQLTransaction'#15'SQLTransaction1'#6'Act' + +'ive'#8#6'Action'#7#6'caNone'#8'Database'#7#13'IBConnection1'#4'left'#3#144#0 + +#3'top'#2#16#0#0#29'TExtJSJSonWebdataInputAdaptor'#20'ProviderInputAdaptor'#4 + +'left'#3#16#1#3'top'#2#16#0#0#0 +]); diff --git a/packages/fcl-web/examples/combined/wmusers.pp b/packages/fcl-web/examples/combined/wmusers.pp new file mode 100644 index 0000000000..752b03af52 --- /dev/null +++ b/packages/fcl-web/examples/combined/wmusers.pp @@ -0,0 +1,145 @@ +unit wmusers; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, FileUtil, LResources, HTTPDefs, websession, fpHTTP, fpWeb, + IBConnection, sqldb, fpwebdata, fpjson, extjsjson, extjsxml, sqldbwebdata; + +type + + { TCombinedModule } + + TCombinedModule = class(TFPWebProviderDataModule) + ProviderFormatter: TExtJSJSONDataFormatter; + ProviderInputAdaptor: TExtJSJSonWebdataInputAdaptor; + IBConnection1: TIBConnection; + Users: TSQLDBWebDataProvider; + QGetID: TSQLQuery; + SQLTransaction1: TSQLTransaction; + procedure DataModuleNewSession(Sender: TObject); + procedure ProviderFormatterBeforeDataToJSON(Sender: TObject; + AObject: TJSONObject); + procedure ProviderFormatterBeforeDelete(Sender: TObject); + procedure ProviderFormatterBeforeInsert(Sender: TObject); + procedure ProviderFormatterBeforeUpdate(Sender: TObject); + procedure UsersGetNewID(Sender: TObject; out AID: String); + procedure DataModuleCreate(Sender: TObject); + procedure DataModuleGetContentProducer(Sender: TObject; + var AContentProducer: TCustomHTTPDataContentProducer); + procedure DataModuleGetInputAdaptor(Sender: TObject; + var AInputAdaptor: TCustomWebdataInputAdaptor); + private + procedure CheckLoggedIn; + { private declarations } + public + { public declarations } + end; + +var + CombinedModule: TCombinedModule; + +implementation + +uses inifiles; + +{ TCombinedModule } + +procedure TCombinedModule.DataModuleGetContentProducer( + Sender: TObject; var AContentProducer: TCustomHTTPDataContentProducer); +begin +end; + +procedure TCombinedModule.DataModuleCreate(Sender: TObject); + +Var + FN : String; + Ini : TMemIniFile; + +begin + // Not yet published. + CreateSession:=True; + FN:=ChangeFileExt(Paramstr(0),'.ini'); + If FileExists(FN) then + begin + Ini:=TMemIniFile.Create(FN); + try + With IBConnection1 do + begin + DatabaseName:=Ini.ReadString('Database','Path',DatabaseName); + UserName:=Ini.ReadString('Database','UserName',UserName); + Password:=Ini.ReadString('Database','Password',Password); + end; + finally + Ini.Free; + end; + end; + IBConnection1.Connected:=True; +end; + +procedure TCombinedModule.UsersGetNewID(Sender: TObject; out + AID: String); +begin + With QGetID Do + begin + Close; + Open; + try + if (EOF and BOF) then + Raise Exception.Create('No ID generated'); + AID:=Fields[0].AsString; + finally + Close; + end; + end; +end; + +procedure TCombinedModule.CheckLoggedIn; + +begin + If StrToIntDef(Session.Variables['UserID'],-1)=-1 then + Raise Exception.Create('You must be logged in to see or modify data'); +end; +procedure TCombinedModule.ProviderFormatterBeforeDataToJSON( + Sender: TObject; AObject: TJSONObject); +begin + CheckLoggedIn; +end; + +procedure TCombinedModule.DataModuleNewSession(Sender: TObject); +begin + // The cookies must all originate from the same path, otherwise the 2 datamodules will use a different session. + (Sender as TFPWebSession).SessionCookiePath:='/'; +end; + +procedure TCombinedModule.ProviderFormatterBeforeDelete( + Sender: TObject); +begin + CheckLoggedIn; +end; + +procedure TCombinedModule.ProviderFormatterBeforeInsert( + Sender: TObject); +begin + CheckLoggedIn; +end; + +procedure TCombinedModule.ProviderFormatterBeforeUpdate( + Sender: TObject); +begin + CheckLoggedIn; +end; + +procedure TCombinedModule.DataModuleGetInputAdaptor(Sender: TObject; + var AInputAdaptor: TCustomWebdataInputAdaptor); +begin +end; + +initialization + {$I wmusers.lrs} + + RegisterHTTPModule('Provider', TCombinedModule); +end. + diff --git a/packages/fcl-web/src/base/custfcgi.pp b/packages/fcl-web/src/base/custfcgi.pp index 9ca3a20d2e..4d65e036bc 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, Sockets, 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; @@ -83,9 +90,13 @@ Type FRequestsAvail : integer; FHandle : THandle; Socket: longint; + FIAddress : TInetSockAddr; + FAddressLength : tsocklen; FAddress: string; + FTimeOut, FPort: integer; function Read_FCGIRecord : PFCGI_Header; + function DataAvailable : Boolean; protected function ProcessRecord(AFCGI_Record: PFCGI_Header; out ARequest: TRequest; out AResponse: TResponse): boolean; virtual; procedure SetupSocket(var IAddress: TInetSockAddr; var AddressLength: tsocklen); virtual; @@ -98,6 +109,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 } @@ -136,6 +148,7 @@ Implementation uses dbugintf; {$endif} + {$undef nosignal} @@ -433,6 +446,7 @@ begin FRequestsAvail:=5; SetLength(FRequestsArray,FRequestsAvail); FHandle := THandle(-1); + FTimeOut:=50; end; destructor TFCgiHandler.Destroy; @@ -539,7 +553,7 @@ begin PFCGI_Header(ResRecord)^:=Header; ReadBuf:=ResRecord+BytesRead; BytesRead:=ReadBytes(ReadBuf,ContentLength); - If (BytesRead=0) then + If (BytesRead=0) and (ContentLength>0) then begin FreeMem(resRecord); Exit // Connection closed gracefully. @@ -547,7 +561,7 @@ begin end; ReadBuf:=ReadBuf+BytesRead; BytesRead:=ReadBytes(ReadBuf,PaddingLength); - If (BytesRead=0) then + If (BytesRead=0) and (PaddingLength>0) then begin FreeMem(resRecord); Exit // Connection closed gracefully. @@ -573,6 +587,11 @@ begin 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); @@ -589,6 +608,36 @@ begin 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 @@ -631,20 +680,18 @@ end; function TFCgiHandler.WaitForRequest(out ARequest: TRequest; out AResponse: TResponse): boolean; var - IAddress : TInetSockAddr; - AddressLength : tsocklen; AFCGI_Record : PFCGI_Header; begin Result := False; if Socket=0 then if Port<>0 then - SetupSocket(IAddress,AddressLength) + SetupSocket(FIAddress,FAddressLength) else Socket:=StdInputHandle; if FHandle=THandle(-1) then begin - FHandle:=fpaccept(Socket,psockaddr(@IAddress),@AddressLength); + FHandle:=fpaccept(Socket,psockaddr(@FIAddress),@FAddressLength); if FHandle=THandle(-1) then begin Terminate; @@ -652,7 +699,14 @@ begin end; end; repeat + 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 Result:=ProcessRecord(AFCGI_Record,ARequest,AResponse); 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/fpapache.pp b/packages/fcl-web/src/base/fpapache.pp index 6a24da2a2e..6bfcd151eb 100644 --- a/packages/fcl-web/src/base/fpapache.pp +++ b/packages/fcl-web/src/base/fpapache.pp @@ -129,6 +129,7 @@ Type procedure ShowException(E: Exception); override; Function ProcessRequest(P : PRequest_Rec) : Integer; virtual; Function AllowRequest(P : PRequest_Rec) : Boolean; virtual; + Procedure SetModuleRecord(Var ModuleRecord : Module); Property HandlerPriority : THandlerPriority Read GetPriority Write SetPriority default hpMiddle; Property BeforeModules : TStrings Read GetBeforeModules Write SetBeforeModules; Property AfterModules : TStrings Read GetAfterModules Write SetAfterModules; @@ -737,6 +738,11 @@ begin result := TApacheHandler(WebHandler).AllowRequest(p); end; +procedure TCustomApacheApplication.SetModuleRecord(var ModuleRecord: Module); +begin + TApacheHandler(WebHandler).SetModuleRecord(ModuleRecord); +end; + Initialization BeginThread(@__dummythread);//crash prevention for simultaneous requests sleep(300); 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/fpweb.pp b/packages/fcl-web/src/base/fpweb.pp index 4a407d7975..ebac7c1256 100644 --- a/packages/fcl-web/src/base/fpweb.pp +++ b/packages/fcl-web/src/base/fpweb.pp @@ -204,6 +204,7 @@ end; destructor TFPWebAction.destroy; begin + FreeandNil(FContents); FreeAndNil(FTemplate); inherited destroy; end; diff --git a/packages/fcl-web/src/base/httpdefs.pp b/packages/fcl-web/src/base/httpdefs.pp index 16e0e78606..e0ff09c05c 100644 --- a/packages/fcl-web/src/base/httpdefs.pp +++ b/packages/fcl-web/src/base/httpdefs.pp @@ -1270,7 +1270,8 @@ begin FI:=TFormItem(L[i]); FI.Process; If (FI.Name='') then - Raise Exception.CreateFmt('Invalid multipart encoding: %s',[FI.Data]); + Fi.Name:='DummyFileItem'+IntToStr(i); + //Raise Exception.CreateFmt('Invalid multipart encoding: %s',[FI.Data]); {$ifdef CGIDEBUG} With FI Do begin 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/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 54ae582886..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; diff --git a/packages/fcl-web/src/webdata/sqldbwebdata.pp b/packages/fcl-web/src/webdata/sqldbwebdata.pp index 81783a9d8f..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; @@ -56,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; @@ -73,6 +75,7 @@ Type Property OnGetNewID; property OnGetParameterType; property OnGetParameterValue; + Property OnGetDataset; Property Options; Property Params; end; @@ -394,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; |