summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authormarco <marco@3ad0048d-3df7-0310-abae-a5850022a9f2>2011-05-27 15:39:26 +0000
committermarco <marco@3ad0048d-3df7-0310-abae-a5850022a9f2>2011-05-27 15:39:26 +0000
commitfb6daf010ff275e5f3628ca8a758d28858886274 (patch)
tree17db2ec6f423d5cb7fe03b195aee10a2d18514cb
parent3ecc3cdfdaef222e1627464fbbf507d6b626c705 (diff)
downloadfpc-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
-rw-r--r--packages/fcl-web/examples/combined/combined.html20
-rw-r--r--packages/fcl-web/examples/combined/combined.icobin0 -> 137040 bytes
-rw-r--r--packages/fcl-web/examples/combined/combined.ini4
-rw-r--r--packages/fcl-web/examples/combined/combined.lpi116
-rw-r--r--packages/fcl-web/examples/combined/combined.lpr15
-rw-r--r--packages/fcl-web/examples/combined/combined.resbin0 -> 138128 bytes
-rw-r--r--packages/fcl-web/examples/combined/combined.sql11
-rw-r--r--packages/fcl-web/examples/combined/login.js105
-rw-r--r--packages/fcl-web/examples/combined/login.pngbin0 -> 13618 bytes
-rw-r--r--packages/fcl-web/examples/combined/users.html18
-rw-r--r--packages/fcl-web/examples/combined/users.js108
-rw-r--r--packages/fcl-web/examples/combined/users.sql15
-rw-r--r--packages/fcl-web/examples/combined/wmlogin.lfm76
-rw-r--r--packages/fcl-web/examples/combined/wmlogin.pp129
-rw-r--r--packages/fcl-web/examples/combined/wmusers.lfm94
-rw-r--r--packages/fcl-web/examples/combined/wmusers.lrs35
-rw-r--r--packages/fcl-web/examples/combined/wmusers.pp145
-rw-r--r--packages/fcl-web/src/base/custfcgi.pp70
-rw-r--r--packages/fcl-web/src/base/custweb.pp1
-rw-r--r--packages/fcl-web/src/base/fpapache.pp6
-rw-r--r--packages/fcl-web/src/base/fphtml.pp197
-rw-r--r--packages/fcl-web/src/base/fpweb.pp1
-rw-r--r--packages/fcl-web/src/base/httpdefs.pp3
-rw-r--r--packages/fcl-web/src/base/webpage.pp114
-rw-r--r--packages/fcl-web/src/jsonrpc/fpextdirect.pp1
-rw-r--r--packages/fcl-web/src/jsonrpc/fpjsonrpc.pp6
-rw-r--r--packages/fcl-web/src/webdata/extjsjson.pp29
-rw-r--r--packages/fcl-web/src/webdata/fpwebdata.pp16
-rw-r--r--packages/fcl-web/src/webdata/sqldbwebdata.pp5
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
new file mode 100644
index 0000000000..0341321b5d
--- /dev/null
+++ b/packages/fcl-web/examples/combined/combined.ico
Binary files differ
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
new file mode 100644
index 0000000000..7c6cf3e4be
--- /dev/null
+++ b/packages/fcl-web/examples/combined/combined.res
Binary files differ
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
new file mode 100644
index 0000000000..e1a2633df2
--- /dev/null
+++ b/packages/fcl-web/examples/combined/login.png
Binary files differ
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;