--- 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: branches/fixes_2_4@17574 -

.gitattributes

@@ -1683,6 +1683,23 @@ packages/fcl-res/xml/winpeimagereader.xml svneol=native#text/plain
 packages/fcl-web/Makefile svneol=native#text/plain
 packages/fcl-web/Makefile.fpc svneol=native#text/plain
 packages/fcl-web/Makefile_fpmake.fpc svneol=native#text/plain
+packages/fcl-web/examples/combined/combined.html svneol=native#text/plain
+packages/fcl-web/examples/combined/combined.ico -text
+packages/fcl-web/examples/combined/combined.ini svneol=native#text/plain
+packages/fcl-web/examples/combined/combined.lpi svneol=native#text/plain
+packages/fcl-web/examples/combined/combined.lpr svneol=native#text/plain
+packages/fcl-web/examples/combined/combined.res -text
+packages/fcl-web/examples/combined/combined.sql svneol=native#text/plain
+packages/fcl-web/examples/combined/login.js svneol=native#text/plain
+packages/fcl-web/examples/combined/login.png -text svneol=unset#image/png
+packages/fcl-web/examples/combined/users.html svneol=native#text/plain
+packages/fcl-web/examples/combined/users.js svneol=native#text/plain
+packages/fcl-web/examples/combined/users.sql svneol=native#text/plain
+packages/fcl-web/examples/combined/wmlogin.lfm svneol=native#text/plain
+packages/fcl-web/examples/combined/wmlogin.pp svneol=native#text/plain
+packages/fcl-web/examples/combined/wmusers.lfm svneol=native#text/plain
+packages/fcl-web/examples/combined/wmusers.lrs svneol=native#text/plain
+packages/fcl-web/examples/combined/wmusers.pp svneol=native#text/plain
 packages/fcl-web/examples/jsonrpc/demo1/README.txt svneol=native#text/plain
 packages/fcl-web/examples/jsonrpc/demo1/demo.lpi svneol=native#text/plain
 packages/fcl-web/examples/jsonrpc/demo1/demo.lpr svneol=native#text/plain

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>

packages/fcl-web/examples/combined/combined.ini

@@ -0,0 +1,4 @@
+[Database]
+Path=/home/firebird/combined.fb
+UserName=WISASOFT
+Password=SysteemD

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>

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.
+

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)
+);
+
+  

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*/
+});
+

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>

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);

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;

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

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.
+

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

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
+]);

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.
+

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);

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;

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);

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;
 

packages/fcl-web/src/base/fpweb.pp

@@ -204,6 +204,7 @@ end;
 
 destructor TFPWebAction.destroy;
 begin
+  FreeandNil(FContents);
   FreeAndNil(FTemplate);
   inherited destroy;
 end;

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

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.
 

packages/fcl-web/src/jsonrpc/fpextdirect.pp

@@ -130,6 +130,7 @@ Type
     Property DispatchOptions;
     Property APIPath;
     Property RouterPath;
+    Property CreateSession;
     Property NameSpace;
   end;
 

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}

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

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;
 

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;