diff --git a/components/flashfiler/#Readme.txt b/components/flashfiler/#Readme.txt
new file mode 100644
index 000000000..c20291ad2
--- /dev/null
+++ b/components/flashfiler/#Readme.txt
@@ -0,0 +1,35 @@
+TurboPower FlashFiler2 Lazarus port
+Used original version:tpflashfiler_2_13 from SourceForge
+https://sourceforge.net/projects/tpflashfiler/
+
+
+Port infos are in sourcelaz\LazConvertReadMe.txt
+
+Lazaruspackage is in folder packages: lazff2.lpk
+
+Look the image for folderstructre. I zipped only changed files. Other files are located on sourceforge.
+In finalversion will be inclued all and published on github/sourceforge/..
+
+***
+NO MORE BORLAND CODE, It uses now TExprParser from fssql.
+ sourcelaz\lazdbcommon.pas ->since 2016.05.04: (lazcommon.pas and lazconsts.pas)
+ sourcelaz\LazDbComSqlTimSt.pas <--- used in lazdbcommon.pas
+ To disable Delphi units define in ffdefine.inc: (compiles without delphi units)
+ {$DEFINE DONTUSEDELPHIUNIT} //Disables in ffdb.pas the function TffDataSet.dsCreateLookupFilter
+ //if it called then it raises exception!
+**************
+
+FOR EXAMPLES configure server (flashfiler\bin\ffserver.exe) and
+make 2 aliases in [ffserver-Menu > Config > Aliases ... ]
+ Alias: Path:
+ mythicdb yourfolder\flashfiler\examples\mythicdb
+ Tutorial yourfolder\flashfiler\examples
+
+
+THERE IS TEXPRPARSER in:
+ -JVCL JvExprParser.pas
+ -TXQuery QExprYacc.pas with MozillaPublicLicense
+
+Have fun!
+
+Soner A.
\ No newline at end of file
diff --git a/components/flashfiler/examples/LazCustLookup/LazCustLookup.ico b/components/flashfiler/examples/LazCustLookup/LazCustLookup.ico
new file mode 100644
index 000000000..0341321b5
Binary files /dev/null and b/components/flashfiler/examples/LazCustLookup/LazCustLookup.ico differ
diff --git a/components/flashfiler/examples/LazCustLookup/LazCustLookup.lpi b/components/flashfiler/examples/LazCustLookup/LazCustLookup.lpi
new file mode 100644
index 000000000..6a0409795
--- /dev/null
+++ b/components/flashfiler/examples/LazCustLookup/LazCustLookup.lpi
@@ -0,0 +1,88 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/flashfiler/examples/LazCustLookup/LazCustLookup.lpr b/components/flashfiler/examples/LazCustLookup/LazCustLookup.lpr
new file mode 100644
index 000000000..a1804ca20
--- /dev/null
+++ b/components/flashfiler/examples/LazCustLookup/LazCustLookup.lpr
@@ -0,0 +1,21 @@
+program LazCustLookup;
+
+{$mode objfpc}{$H+}
+
+uses
+ {$IFDEF UNIX}{$IFDEF UseCThreads}
+ cthreads,
+ {$ENDIF}{$ENDIF}
+ Interfaces, // this includes the LCL widgetset
+ Forms, LazCustLookupMain, lazff2
+ { you can add units after this };
+
+{$R *.res}
+
+begin
+ RequireDerivedFormResource:=True;
+ Application.Initialize;
+ Application.CreateForm(TForm1, Form1);
+ Application.Run;
+end.
+
diff --git a/components/flashfiler/examples/LazCustLookup/LazCustLookup.res b/components/flashfiler/examples/LazCustLookup/LazCustLookup.res
new file mode 100644
index 000000000..e994dfa65
Binary files /dev/null and b/components/flashfiler/examples/LazCustLookup/LazCustLookup.res differ
diff --git a/components/flashfiler/examples/LazCustLookup/lazcustlookupmain.lfm b/components/flashfiler/examples/LazCustLookup/lazcustlookupmain.lfm
new file mode 100644
index 000000000..37088084a
--- /dev/null
+++ b/components/flashfiler/examples/LazCustLookup/lazcustlookupmain.lfm
@@ -0,0 +1,509 @@
+object Form1: TForm1
+ Left = 315
+ Height = 478
+ Top = 121
+ Width = 604
+ Caption = 'FlashFiler for Lazarus Demo2'
+ ClientHeight = 478
+ ClientWidth = 604
+ OnCreate = FormCreate
+ LCLVersion = '1.6.1.0'
+ object ToolBar1: TToolBar
+ Left = 0
+ Height = 22
+ Top = 0
+ Width = 604
+ AutoSize = True
+ Caption = 'ToolBar1'
+ EdgeBorders = []
+ TabOrder = 0
+ object DBNavigator1: TDBNavigator
+ Left = 1
+ Height = 22
+ Top = 0
+ Width = 241
+ BevelOuter = bvNone
+ ChildSizing.EnlargeHorizontal = crsScaleChilds
+ ChildSizing.EnlargeVertical = crsScaleChilds
+ ChildSizing.ShrinkHorizontal = crsScaleChilds
+ ChildSizing.ShrinkVertical = crsScaleChilds
+ ChildSizing.Layout = cclLeftToRightThenTopToBottom
+ ChildSizing.ControlsPerLine = 100
+ ClientHeight = 22
+ ClientWidth = 241
+ DataSource = DataSource1
+ Options = []
+ TabOrder = 0
+ end
+ object DBLookupComboBox1: TDBLookupComboBox
+ Left = 242
+ Height = 21
+ Top = 0
+ Width = 100
+ DataField = 'Company'
+ DataSource = DataSource1
+ ListFieldIndex = 0
+ LookupCache = False
+ TabOrder = 1
+ end
+ end
+ object DBGrid1: TDBGrid
+ Left = 0
+ Height = 366
+ Top = 22
+ Width = 604
+ Align = alClient
+ Color = clWindow
+ Columns = <>
+ DataSource = DataSource1
+ TabOrder = 1
+ end
+ object Memo1: TMemo
+ Left = 0
+ Height = 90
+ Top = 388
+ Width = 604
+ Align = alBottom
+ Lines.Strings = (
+ 'TDBLookupComboBox shows no Fieldvalues'
+ ''
+ '[Solved for Loookup-Field in TDBGrid'
+ 'Lookup-Fields raises EVariantError-Exception on FreePascal:'
+ 'Try to Change Value of Customer-Field.'
+ '--'
+ 'ffdb'
+ '7929..'
+ 'EVariantError : Invalid variant type cast'
+ '--'
+ ']'
+ )
+ ScrollBars = ssVertical
+ TabOrder = 2
+ end
+ object ffLegacyTransport1: TffLegacyTransport
+ Enabled = True
+ ServerName = 'Local server'
+ left = 366
+ top = 198
+ end
+ object FFRemoteServerEngine1: TFFRemoteServerEngine
+ Transport = ffLegacyTransport1
+ left = 282
+ top = 198
+ end
+ object ffClient1: TffClient
+ Active = True
+ ClientName = 'ffClient1Laz'
+ ServerEngine = FFRemoteServerEngine1
+ left = 448
+ top = 198
+ end
+ object ffSession1: TffSession
+ Active = True
+ ClientName = 'ffClient1Laz'
+ SessionName = 'ffSession1laz'
+ TimeOut = 2000
+ left = 510
+ top = 198
+ end
+ object ffDatabase1: TffDatabase
+ AliasName = 'mythicdb'
+ Connected = True
+ DatabaseName = 'DbLookuplaz'
+ SessionName = 'ffSession1laz'
+ left = 282
+ top = 266
+ end
+ object ffTable1: TffTable
+ DatabaseName = 'DbLookuplaz'
+ FieldDefs = <
+ item
+ Name = 'OrderNo'
+ DataType = ftAutoInc
+ Precision = -1
+ end
+ item
+ Name = 'Status'
+ DataType = ftString
+ Precision = -1
+ Size = 1
+ end
+ item
+ Name = 'CustNo'
+ DataType = ftInteger
+ Precision = -1
+ end
+ item
+ Name = 'SaleDate'
+ DataType = ftDateTime
+ Precision = -1
+ end
+ item
+ Name = 'ShipDate'
+ DataType = ftDateTime
+ Precision = -1
+ end
+ item
+ Name = 'EmpNo'
+ DataType = ftInteger
+ Precision = -1
+ end
+ item
+ Name = 'ShipToContact'
+ DataType = ftString
+ Precision = -1
+ Size = 20
+ end
+ item
+ Name = 'ShipToAddr1'
+ DataType = ftString
+ Precision = -1
+ Size = 30
+ end
+ item
+ Name = 'ShipToAddr2'
+ DataType = ftString
+ Precision = -1
+ Size = 30
+ end
+ item
+ Name = 'ShipToCity'
+ DataType = ftString
+ Precision = -1
+ Size = 15
+ end
+ item
+ Name = 'ShipToState'
+ DataType = ftString
+ Precision = -1
+ Size = 20
+ end
+ item
+ Name = 'ShipToZip'
+ DataType = ftString
+ Precision = -1
+ Size = 10
+ end
+ item
+ Name = 'ShipToCountry'
+ DataType = ftString
+ Precision = -1
+ Size = 20
+ end
+ item
+ Name = 'ShipToPhone'
+ DataType = ftString
+ Precision = -1
+ Size = 15
+ end
+ item
+ Name = 'ShipVIA'
+ DataType = ftString
+ Precision = -1
+ Size = 7
+ end
+ item
+ Name = 'PO'
+ DataType = ftString
+ Precision = -1
+ Size = 15
+ end
+ item
+ Name = 'Terms'
+ DataType = ftString
+ Precision = -1
+ Size = 6
+ end
+ item
+ Name = 'PaymentMethod'
+ DataType = ftString
+ Precision = -1
+ Size = 7
+ end
+ item
+ Name = 'CCNumber'
+ DataType = ftString
+ Precision = -1
+ Size = 16
+ end
+ item
+ Name = 'CCExpMonth'
+ DataType = ftSmallint
+ Precision = -1
+ end
+ item
+ Name = 'CCExpYear'
+ DataType = ftSmallint
+ Precision = -1
+ end
+ item
+ Name = 'ItemsTotal'
+ DataType = ftCurrency
+ Precision = -1
+ end
+ item
+ Name = 'TaxRate'
+ DataType = ftFloat
+ Precision = -1
+ end
+ item
+ Name = 'Freight'
+ DataType = ftCurrency
+ Precision = -1
+ end
+ item
+ Name = 'AmountPaid'
+ DataType = ftCurrency
+ Precision = -1
+ end
+ item
+ Name = 'DistribCenterID'
+ DataType = ftInteger
+ Precision = -1
+ end>
+ FilterOptions = []
+ IndexDefs = <
+ item
+ Name = 'Sequential Access Index'
+ Options = [ixUnique, ixCaseInsensitive, ixExpression]
+ end
+ item
+ Name = 'FF$PRIMARY'
+ Fields = 'OrderNo'
+ Options = [ixUnique]
+ end
+ item
+ Name = 'CustNo'
+ Fields = 'CustNo'
+ Options = []
+ end
+ item
+ Name = 'CustNo_SaleDate'
+ Fields = 'CustNo;SaleDate'
+ Options = [ixCaseInsensitive]
+ end
+ item
+ Name = 'Status'
+ Fields = 'Status'
+ Options = [ixCaseInsensitive]
+ end
+ item
+ Name = 'ByDistribCenter'
+ Fields = 'DistribCenterID'
+ Options = [ixCaseInsensitive]
+ end>
+ IndexName = 'CustNo'
+ SessionName = 'ffSession1laz'
+ TableName = 'orders'
+ left = 366
+ top = 268
+ object ffTable1OrderNo: TAutoIncField
+ FieldKind = fkData
+ FieldName = 'OrderNo'
+ Index = 0
+ LookupCache = False
+ ProviderFlags = [pfInUpdate, pfInWhere]
+ ReadOnly = False
+ Required = False
+ end
+ object ffTable1Status: TStringField
+ FieldKind = fkData
+ FieldName = 'Status'
+ Index = 1
+ LookupCache = False
+ ProviderFlags = [pfInUpdate, pfInWhere]
+ ReadOnly = False
+ Required = False
+ Size = 1
+ end
+ object ffTable1CustNo: TLongintField
+ FieldKind = fkData
+ FieldName = 'CustNo'
+ Index = 2
+ LookupCache = False
+ ProviderFlags = [pfInUpdate, pfInWhere]
+ ReadOnly = False
+ Required = False
+ end
+ object StringField1: TStringField
+ FieldKind = fkLookup
+ FieldName = 'Company'
+ Index = 3
+ KeyFields = 'CustNo'
+ LookupCache = False
+ LookupDataSet = ffTaCustomer
+ LookupKeyFields = 'ID'
+ LookupResultField = 'Company'
+ ProviderFlags = [pfInUpdate, pfInWhere]
+ ReadOnly = False
+ Required = False
+ Size = 30
+ end
+ object ffTable1SaleDate: TDateTimeField
+ FieldKind = fkData
+ FieldName = 'SaleDate'
+ Index = 4
+ LookupCache = False
+ ProviderFlags = [pfInUpdate, pfInWhere]
+ ReadOnly = False
+ Required = False
+ end
+ object ffTable1ShipDate: TDateTimeField
+ FieldKind = fkData
+ FieldName = 'ShipDate'
+ Index = 5
+ LookupCache = False
+ ProviderFlags = [pfInUpdate, pfInWhere]
+ ReadOnly = False
+ Required = False
+ end
+ object ffTable1EmpNo: TLongintField
+ FieldKind = fkData
+ FieldName = 'EmpNo'
+ Index = 6
+ LookupCache = False
+ ProviderFlags = [pfInUpdate, pfInWhere]
+ ReadOnly = False
+ Required = False
+ end
+ object ffTable1ShipToContact: TStringField
+ FieldKind = fkData
+ FieldName = 'ShipToContact'
+ Index = 7
+ LookupCache = False
+ ProviderFlags = [pfInUpdate, pfInWhere]
+ ReadOnly = False
+ Required = False
+ end
+ end
+ object DataSource1: TDataSource
+ DataSet = ffTable1
+ left = 428
+ top = 270
+ end
+ object ffTaCustomer: TffTable
+ DatabaseName = 'DbLookuplaz'
+ FieldDefs = <
+ item
+ Name = 'ID'
+ DataType = ftAutoInc
+ Precision = -1
+ end
+ item
+ Name = 'Company'
+ DataType = ftString
+ Precision = -1
+ Size = 30
+ end
+ item
+ Name = 'Address1'
+ DataType = ftString
+ Precision = -1
+ Size = 30
+ end
+ item
+ Name = 'Address2'
+ DataType = ftString
+ Precision = -1
+ Size = 30
+ end
+ item
+ Name = 'City'
+ DataType = ftString
+ Precision = -1
+ Size = 15
+ end
+ item
+ Name = 'State'
+ DataType = ftString
+ Precision = -1
+ Size = 20
+ end
+ item
+ Name = 'Zip'
+ DataType = ftString
+ Precision = -1
+ Size = 10
+ end
+ item
+ Name = 'Country'
+ DataType = ftString
+ Precision = -1
+ Size = 20
+ end
+ item
+ Name = 'Phone'
+ DataType = ftString
+ Precision = -1
+ Size = 15
+ end
+ item
+ Name = 'FAX'
+ DataType = ftString
+ Precision = -1
+ Size = 15
+ end
+ item
+ Name = 'TaxRate'
+ DataType = ftFloat
+ Precision = -1
+ end
+ item
+ Name = 'Contact'
+ DataType = ftString
+ Precision = -1
+ Size = 20
+ end
+ item
+ Name = 'LastInvoiceDate'
+ DataType = ftDateTime
+ Precision = -1
+ end
+ item
+ Name = 'DeliveryMethod'
+ DataType = ftString
+ Precision = -1
+ Size = 8
+ end>
+ FilterOptions = []
+ IndexDefs = <
+ item
+ Name = 'Sequential Access Index'
+ Options = [ixUnique, ixCaseInsensitive, ixExpression]
+ end
+ item
+ Name = 'Primary'
+ Fields = 'ID'
+ Options = [ixUnique]
+ end
+ item
+ Name = 'Company'
+ Fields = 'Company'
+ Options = [ixCaseInsensitive]
+ end>
+ IndexName = 'Primary'
+ SessionName = 'ffSession1laz'
+ TableName = 'customer'
+ left = 366
+ top = 330
+ object ffTaCustomerID: TAutoIncField
+ FieldKind = fkData
+ FieldName = 'ID'
+ Index = 0
+ LookupCache = False
+ ProviderFlags = [pfInUpdate, pfInWhere]
+ ReadOnly = False
+ Required = False
+ end
+ object ffTaCustomerCompany: TStringField
+ FieldKind = fkData
+ FieldName = 'Company'
+ Index = 1
+ LookupCache = False
+ ProviderFlags = [pfInUpdate, pfInWhere]
+ ReadOnly = False
+ Required = False
+ Size = 30
+ end
+ end
+end
diff --git a/components/flashfiler/examples/LazCustLookup/lazcustlookupmain.pas b/components/flashfiler/examples/LazCustLookup/lazcustlookupmain.pas
new file mode 100644
index 000000000..f5fc95c54
--- /dev/null
+++ b/components/flashfiler/examples/LazCustLookup/lazcustlookupmain.pas
@@ -0,0 +1,64 @@
+unit LazCustLookupMain;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, db, FileUtil, Forms, Controls, Graphics, Dialogs, ComCtrls,
+ DbCtrls, DBGrids, StdCtrls, ffclreng, fflllgcy, ffdb;
+
+type
+
+ { TForm1 }
+
+ TForm1 = class(TForm)
+ DataSource1: TDataSource;
+ DBGrid1: TDBGrid;
+ DBLookupComboBox1: TDBLookupComboBox;
+ DBNavigator1: TDBNavigator;
+ ffClient1: TffClient;
+ ffDatabase1: TffDatabase;
+ ffLegacyTransport1: TffLegacyTransport;
+ FFRemoteServerEngine1: TFFRemoteServerEngine;
+ ffSession1: TffSession;
+ ffTable1: TffTable;
+ ffTable1CustNo: TLongintField;
+ ffTable1EmpNo: TLongintField;
+ ffTable1OrderNo: TAutoIncField;
+ ffTable1SaleDate: TDateTimeField;
+ ffTable1ShipDate: TDateTimeField;
+ ffTable1ShipToContact: TStringField;
+ ffTable1Status: TStringField;
+ ffTaCustomer: TffTable;
+ ffTaCustomerCompany: TStringField;
+ ffTaCustomerID: TAutoIncField;
+ ffTaCustomer_Proxy: TffTableProxy;
+ Memo1: TMemo;
+ StringField1: TStringField;
+ ToolBar1: TToolBar;
+ procedure FormCreate(Sender: TObject);
+ private
+ { private declarations }
+ public
+ { public declarations }
+ end;
+
+var
+ Form1: TForm1;
+
+implementation
+
+{$R *.lfm}
+
+{ TForm1 }
+
+procedure TForm1.FormCreate(Sender: TObject);
+begin
+ //Lazarus Form Designer needs "Create order" function!
+ ffTaCustomer.Active:=true;
+ ffTable1.Active:=true;
+end;
+
+end.
+
diff --git a/components/flashfiler/examples/LazEmbeddedServer/FFSTRAN.CFG b/components/flashfiler/examples/LazEmbeddedServer/FFSTRAN.CFG
new file mode 100644
index 000000000..32354e902
Binary files /dev/null and b/components/flashfiler/examples/LazEmbeddedServer/FFSTRAN.CFG differ
diff --git a/components/flashfiler/examples/LazEmbeddedServer/LazFFEmbedded.ico b/components/flashfiler/examples/LazEmbeddedServer/LazFFEmbedded.ico
new file mode 100644
index 000000000..0341321b5
Binary files /dev/null and b/components/flashfiler/examples/LazEmbeddedServer/LazFFEmbedded.ico differ
diff --git a/components/flashfiler/examples/LazEmbeddedServer/LazFFEmbedded.lpi b/components/flashfiler/examples/LazEmbeddedServer/LazFFEmbedded.lpi
new file mode 100644
index 000000000..f230ebcdf
--- /dev/null
+++ b/components/flashfiler/examples/LazEmbeddedServer/LazFFEmbedded.lpi
@@ -0,0 +1,87 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/flashfiler/examples/LazEmbeddedServer/LazFFEmbedded.lpr b/components/flashfiler/examples/LazEmbeddedServer/LazFFEmbedded.lpr
new file mode 100644
index 000000000..369bfe933
--- /dev/null
+++ b/components/flashfiler/examples/LazEmbeddedServer/LazFFEmbedded.lpr
@@ -0,0 +1,21 @@
+program LazFFEmbedded;
+
+{$mode objfpc}{$H+}
+
+uses
+ {$IFDEF UNIX}{$IFDEF UseCThreads}
+ cthreads,
+ {$ENDIF}{$ENDIF}
+ Interfaces, // this includes the LCL widgetset
+ Forms, LazFFEmbeddedMain, lazff2
+ { you can add units after this };
+
+{$R *.res}
+
+begin
+ RequireDerivedFormResource:=True;
+ Application.Initialize;
+ Application.CreateForm(TForm1, Form1);
+ Application.Run;
+end.
+
diff --git a/components/flashfiler/examples/LazEmbeddedServer/LazFFEmbedded.res b/components/flashfiler/examples/LazEmbeddedServer/LazFFEmbedded.res
new file mode 100644
index 000000000..e994dfa65
Binary files /dev/null and b/components/flashfiler/examples/LazEmbeddedServer/LazFFEmbedded.res differ
diff --git a/components/flashfiler/examples/LazEmbeddedServer/XXSINFO.FF2 b/components/flashfiler/examples/LazEmbeddedServer/XXSINFO.FF2
new file mode 100644
index 000000000..d48aace6d
Binary files /dev/null and b/components/flashfiler/examples/LazEmbeddedServer/XXSINFO.FF2 differ
diff --git a/components/flashfiler/examples/LazEmbeddedServer/_ReadMe.txt b/components/flashfiler/examples/LazEmbeddedServer/_ReadMe.txt
new file mode 100644
index 000000000..049a90f10
--- /dev/null
+++ b/components/flashfiler/examples/LazEmbeddedServer/_ReadMe.txt
@@ -0,0 +1 @@
+FlashFiler-ServerEngine compiles but don't works with fpc so also this example don't works.
\ No newline at end of file
diff --git a/components/flashfiler/examples/LazEmbeddedServer/lazffembeddedmain.lfm b/components/flashfiler/examples/LazEmbeddedServer/lazffembeddedmain.lfm
new file mode 100644
index 000000000..167b6f6d8
--- /dev/null
+++ b/components/flashfiler/examples/LazEmbeddedServer/lazffembeddedmain.lfm
@@ -0,0 +1,89 @@
+object Form1: TForm1
+ Left = 325
+ Height = 398
+ Top = 128
+ Width = 539
+ Caption = 'Form1'
+ ClientHeight = 398
+ ClientWidth = 539
+ OnCreate = FormCreate
+ LCLVersion = '1.6.1.0'
+ object ToolBar1: TToolBar
+ Left = 0
+ Height = 20
+ Top = 0
+ Width = 539
+ AutoSize = True
+ Caption = 'ToolBar1'
+ EdgeBorders = []
+ TabOrder = 0
+ object DBNavigator1: TDBNavigator
+ Left = 1
+ Height = 20
+ Top = 0
+ Width = 200
+ AutoSize = True
+ BevelOuter = bvNone
+ ChildSizing.EnlargeHorizontal = crsScaleChilds
+ ChildSizing.EnlargeVertical = crsScaleChilds
+ ChildSizing.ShrinkHorizontal = crsScaleChilds
+ ChildSizing.ShrinkVertical = crsScaleChilds
+ ChildSizing.Layout = cclLeftToRightThenTopToBottom
+ ChildSizing.ControlsPerLine = 100
+ ClientHeight = 20
+ ClientWidth = 200
+ Options = []
+ TabOrder = 0
+ end
+ end
+ object DBGrid1: TDBGrid
+ Left = 0
+ Height = 378
+ Top = 20
+ Width = 539
+ Align = alClient
+ Color = clWindow
+ Columns = <>
+ DataSource = DataSource1
+ TabOrder = 1
+ end
+ object ffServerEngine1: TffServerEngine
+ NoAutoSaveCfg = True
+ ConfigDir = 'D:\AppDev\TDLite\Comps\flashfiler\bin'
+ left = 88
+ top = 248
+ end
+ object ffClient1: TffClient
+ ClientName = 'FFClient_69729904'
+ ServerEngine = ffServerEngine1
+ left = 154
+ top = 248
+ end
+ object ffSession1: TffSession
+ ClientName = 'FFClient_69729904'
+ SessionName = 'FFSession_69795446'
+ left = 210
+ top = 248
+ end
+ object ffDatabase1: TffDatabase
+ AliasName = 'D:\AppDev\TDLite\Comps\flashfiler\examples\mythicdb\'
+ DatabaseName = 'FFDB_282722134'
+ SessionName = 'FFSession_69795446'
+ left = 266
+ top = 248
+ end
+ object ffTable1: TffTable
+ DatabaseName = 'FFDB_282722134'
+ FieldDefs = <>
+ FilterOptions = []
+ SessionName = 'FFSession_69795446'
+ TableName = 'customer'
+ left = 322
+ top = 248
+ end
+ object DataSource1: TDataSource
+ DataSet = ffTable1
+ left = 372
+ top = 248
+ end
+end
diff --git a/components/flashfiler/examples/LazEmbeddedServer/lazffembeddedmain.pas b/components/flashfiler/examples/LazEmbeddedServer/lazffembeddedmain.pas
new file mode 100644
index 000000000..0f5138264
--- /dev/null
+++ b/components/flashfiler/examples/LazEmbeddedServer/lazffembeddedmain.pas
@@ -0,0 +1,51 @@
+unit LazFFEmbeddedMain;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, db, FileUtil, Forms, Controls, Graphics, Dialogs, ComCtrls,
+ DbCtrls, DBGrids, ffsreng, ffdb;
+
+type
+
+ { TForm1 }
+
+ TForm1 = class(TForm)
+ DataSource1: TDataSource;
+ DBGrid1: TDBGrid;
+ DBNavigator1: TDBNavigator;
+ ffClient1: TffClient;
+ ffDatabase1: TffDatabase;
+ ffServerEngine1: TffServerEngine;
+ ffSession1: TffSession;
+ ffTable1: TffTable;
+ ToolBar1: TToolBar;
+ procedure FormCreate(Sender: TObject);
+ private
+ { private declarations }
+ public
+ { public declarations }
+ end;
+
+var
+ Form1: TForm1;
+
+implementation
+
+{$R *.lfm}
+
+{ TForm1 }
+
+procedure TForm1.FormCreate(Sender: TObject);
+begin
+ //Embeddedserver don't work in classes.pas the function TReader.ReadString
+ //raises "Invalid Value for property" because fpc-classes can't handle some string property
+ //program stops in fflldict.pas procedure TffDataDictionary.ReadFromStream(S : TStream);
+ ffDatabase1.Connected:=true;
+ ffTable1.Active:=true;
+end;
+
+end.
+
diff --git a/components/flashfiler/examples/LazEmbeddedServer_RT/LazFFEmbedded.ico b/components/flashfiler/examples/LazEmbeddedServer_RT/LazFFEmbedded.ico
new file mode 100644
index 000000000..0341321b5
Binary files /dev/null and b/components/flashfiler/examples/LazEmbeddedServer_RT/LazFFEmbedded.ico differ
diff --git a/components/flashfiler/examples/LazEmbeddedServer_RT/LazFFEmbedded.lpi b/components/flashfiler/examples/LazEmbeddedServer_RT/LazFFEmbedded.lpi
new file mode 100644
index 000000000..0a7cbb113
--- /dev/null
+++ b/components/flashfiler/examples/LazEmbeddedServer_RT/LazFFEmbedded.lpi
@@ -0,0 +1,89 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/flashfiler/examples/LazEmbeddedServer_RT/LazFFEmbedded.lpr b/components/flashfiler/examples/LazEmbeddedServer_RT/LazFFEmbedded.lpr
new file mode 100644
index 000000000..369bfe933
--- /dev/null
+++ b/components/flashfiler/examples/LazEmbeddedServer_RT/LazFFEmbedded.lpr
@@ -0,0 +1,21 @@
+program LazFFEmbedded;
+
+{$mode objfpc}{$H+}
+
+uses
+ {$IFDEF UNIX}{$IFDEF UseCThreads}
+ cthreads,
+ {$ENDIF}{$ENDIF}
+ Interfaces, // this includes the LCL widgetset
+ Forms, LazFFEmbeddedMain, lazff2
+ { you can add units after this };
+
+{$R *.res}
+
+begin
+ RequireDerivedFormResource:=True;
+ Application.Initialize;
+ Application.CreateForm(TForm1, Form1);
+ Application.Run;
+end.
+
diff --git a/components/flashfiler/examples/LazEmbeddedServer_RT/LazFFEmbedded.res b/components/flashfiler/examples/LazEmbeddedServer_RT/LazFFEmbedded.res
new file mode 100644
index 000000000..877868cb4
Binary files /dev/null and b/components/flashfiler/examples/LazEmbeddedServer_RT/LazFFEmbedded.res differ
diff --git a/components/flashfiler/examples/LazEmbeddedServer_RT/_ReadMe.txt b/components/flashfiler/examples/LazEmbeddedServer_RT/_ReadMe.txt
new file mode 100644
index 000000000..011f9ced7
--- /dev/null
+++ b/components/flashfiler/examples/LazEmbeddedServer_RT/_ReadMe.txt
@@ -0,0 +1,3 @@
+FlashFiler-ServerEngine compiles but don't works with fpc so also this example don't works.
+
+Copy of LazEmbeddedServer example.
diff --git a/components/flashfiler/examples/LazEmbeddedServer_RT/lazffembeddedmain.lfm b/components/flashfiler/examples/LazEmbeddedServer_RT/lazffembeddedmain.lfm
new file mode 100644
index 000000000..e0895dc37
--- /dev/null
+++ b/components/flashfiler/examples/LazEmbeddedServer_RT/lazffembeddedmain.lfm
@@ -0,0 +1,54 @@
+object Form1: TForm1
+ Left = 325
+ Height = 398
+ Top = 128
+ Width = 539
+ Caption = 'Form1'
+ ClientHeight = 398
+ ClientWidth = 539
+ OnCreate = FormCreate
+ LCLVersion = '1.6.3.0'
+ object ToolBar1: TToolBar
+ Left = 0
+ Height = 20
+ Top = 0
+ Width = 539
+ AutoSize = True
+ Caption = 'ToolBar1'
+ EdgeBorders = []
+ TabOrder = 0
+ object DBNavigator1: TDBNavigator
+ Left = 1
+ Height = 20
+ Top = 0
+ Width = 200
+ AutoSize = True
+ BevelOuter = bvNone
+ ChildSizing.EnlargeHorizontal = crsScaleChilds
+ ChildSizing.EnlargeVertical = crsScaleChilds
+ ChildSizing.ShrinkHorizontal = crsScaleChilds
+ ChildSizing.ShrinkVertical = crsScaleChilds
+ ChildSizing.Layout = cclLeftToRightThenTopToBottom
+ ChildSizing.ControlsPerLine = 100
+ ClientHeight = 20
+ ClientWidth = 200
+ Options = []
+ TabOrder = 0
+ end
+ end
+ object DBGrid1: TDBGrid
+ Left = 0
+ Height = 378
+ Top = 20
+ Width = 539
+ Align = alClient
+ Color = clWindow
+ Columns = <>
+ DataSource = DataSource1
+ TabOrder = 1
+ end
+ object DataSource1: TDataSource
+ left = 372
+ top = 248
+ end
+end
diff --git a/components/flashfiler/examples/LazEmbeddedServer_RT/lazffembeddedmain.pas b/components/flashfiler/examples/LazEmbeddedServer_RT/lazffembeddedmain.pas
new file mode 100644
index 000000000..47b2febc5
--- /dev/null
+++ b/components/flashfiler/examples/LazEmbeddedServer_RT/lazffembeddedmain.pas
@@ -0,0 +1,88 @@
+unit LazFFEmbeddedMain;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, db, FileUtil, Forms, Controls, Graphics, Dialogs, ComCtrls,
+ DbCtrls, DBGrids, ffsreng, ffdb;
+
+type
+
+ { TForm1 }
+
+ TForm1 = class(TForm)
+ DataSource1: TDataSource;
+ DBGrid1: TDBGrid;
+ DBNavigator1: TDBNavigator;
+ ToolBar1: TToolBar;
+ procedure FormCreate(Sender: TObject);
+ private
+ { private declarations }
+ ffClient1: TffClient;
+ ffDatabase1: TffDatabase;
+ ffServerEngine1: TffServerEngine;
+ ffSession1: TffSession;
+ ffTable1: TffTable;
+ public
+ { public declarations }
+ end;
+
+var
+ Form1: TForm1;
+
+implementation
+
+{$R *.lfm}
+
+{ TForm1 }
+
+procedure TForm1.FormCreate(Sender: TObject);
+var ServerFolder, DBFolder :string;
+begin
+ //Change Folders to your install
+ ServerFolder:= 'D:\AppDev\TDLite\Comps\flashfiler\bin\';
+ DBFolder := 'D:\AppDev\TDLite\Comps\flashfiler\examples\mythicdb\';
+
+ ffServerEngine1:= TffServerEngine.Create(self);
+ ffServerEngine1.ConfigDir := ServerFolder;
+ //ffServerEngine1.NoAutoSaveCfg:=true;
+ //ffServerEngine1.CollectGarbage := True;
+ ffServerEngine1.Startup; //error excepts at 3.run in
+ //ffsreng.pas
+ //LIne 6838: Dictionary.ReadFromFile(DataFile, aTI);
+
+ ffClient1:= TffClient.Create(self);
+ ffClient1.ClientName := 'FFClient_69729904';
+ ffClient1.ServerEngine := ffServerEngine1;
+
+ ffSession1:= TffSession.Create(self);
+ ffSession1.ClientName := 'FFClient_69729904';
+ ffSession1.SessionName := 'FFSession_69795446';
+
+ ffDatabase1:= TffDatabase.Create(self);
+ ffDatabase1.AliasName := DBFolder;
+ ffDatabase1.DatabaseName := 'FFDB_282722134'; //-->Starts server if not already started
+
+ ffDatabase1.SessionName := 'FFSession_69795446';
+
+ ffTable1:= TffTable.Create(self);
+ ffTable1.DatabaseName := 'FFDB_282722134';
+ //ffTable1.FieldDefs := <>;
+ ffTable1.FilterOptions := [];
+ ffTable1.SessionName := 'FFSession_69795446';
+ ffTable1.TableName := 'customer';
+
+ DataSource1.DataSet:=ffTable1;
+
+ //ffServerEngine1.Startup;
+ //ffClient1.Active:=true;
+ //ffSession1.Active:=true;
+ ffDatabase1.Connected:=true;
+ ffTable1.Active:=true;
+
+end;
+
+end.
+
diff --git a/components/flashfiler/examples/LazExtCust/excust.dpr b/components/flashfiler/examples/LazExtCust/excust.dpr
new file mode 100644
index 000000000..671308693
--- /dev/null
+++ b/components/flashfiler/examples/LazExtCust/excust.dpr
@@ -0,0 +1,13 @@
+program ExCust;
+
+uses
+ Forms, Interfaces,
+ ExCustu in 'ExCustu.pas', lazff2 {Form1};
+
+{$R *.res}
+
+begin
+ Application.Initialize;
+ Application.CreateForm(TForm1, Form1);
+ Application.Run;
+end.
diff --git a/components/flashfiler/examples/LazExtCust/excust.ico b/components/flashfiler/examples/LazExtCust/excust.ico
new file mode 100644
index 000000000..0341321b5
Binary files /dev/null and b/components/flashfiler/examples/LazExtCust/excust.ico differ
diff --git a/components/flashfiler/examples/LazExtCust/excust.lpi b/components/flashfiler/examples/LazExtCust/excust.lpi
new file mode 100644
index 000000000..4ac9fffe1
--- /dev/null
+++ b/components/flashfiler/examples/LazExtCust/excust.lpi
@@ -0,0 +1,78 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/flashfiler/examples/LazExtCust/excust.res b/components/flashfiler/examples/LazExtCust/excust.res
new file mode 100644
index 000000000..e994dfa65
Binary files /dev/null and b/components/flashfiler/examples/LazExtCust/excust.res differ
diff --git a/components/flashfiler/examples/LazExtCust/excustu.dfm b/components/flashfiler/examples/LazExtCust/excustu.dfm
new file mode 100644
index 000000000..8ce9d54e2
--- /dev/null
+++ b/components/flashfiler/examples/LazExtCust/excustu.dfm
@@ -0,0 +1,144 @@
+object Form1: TForm1
+ Left = 200
+ Top = 108
+ Width = 548
+ Height = 333
+ Caption = 'FlashFiler Example - Customer Data'
+ Font.Color = clWindowText
+ Font.Height = -11
+ Font.Name = 'MS Sans Serif'
+ Font.Style = []
+ Menu = MainMenu1
+ OnShow = FormShow
+ PixelsPerInch = 96
+ TextHeight = 13
+ object CustomerGrid: TDBGrid
+ Left = 0
+ Top = 30
+ Width = 540
+ Height = 257
+ Align = alClient
+ DataSource = CustomerData
+ TabOrder = 0
+ TitleFont.Color = clWindowText
+ TitleFont.Height = -11
+ TitleFont.Name = 'MS Sans Serif'
+ TitleFont.Style = []
+ end
+ object DBNavigator1: TDBNavigator
+ Left = 0
+ Top = 0
+ Width = 540
+ Height = 30
+ DataSource = CustomerData
+ Align = alTop
+ Flat = True
+ TabOrder = 1
+ end
+ object ltMain: TffLegacyTransport
+ Enabled = True
+ Left = 352
+ Top = 88
+ end
+ object ffRSE: TFFRemoteServerEngine
+ Transport = ltMain
+ Left = 320
+ Top = 88
+ end
+ object ffClient: TffClient
+ ClientName = 'ffClient'
+ ServerEngine = ffRSE
+ Left = 320
+ Top = 56
+ end
+ object ffSess: TffSession
+ ClientName = 'ffClient'
+ SessionName = 'ExCust'
+ Left = 352
+ Top = 56
+ end
+ object CustomerTable: TffTable
+ DatabaseName = 'Tutorial'
+ IndexName = 'ByID'
+ SessionName = 'ExCust'
+ TableName = 'ExCust'
+ Timeout = 10000
+ Left = 384
+ Top = 56
+ end
+ object CustomerData: TDataSource
+ DataSet = CustomerTable
+ Left = 416
+ Top = 56
+ end
+ object MainMenu1: TMainMenu
+ Left = 448
+ Top = 56
+ object File1: TMenuItem
+ Caption = '&File'
+ object Open1: TMenuItem
+ Caption = '&Open'
+ OnClick = Open1Click
+ end
+ object Close1: TMenuItem
+ Caption = '&Close'
+ Enabled = False
+ OnClick = Close1Click
+ end
+ object N1: TMenuItem
+ Caption = '-'
+ end
+ object Exit1: TMenuItem
+ Caption = '&Exit'
+ OnClick = Exit1Click
+ end
+ end
+ object Navigate1: TMenuItem
+ Caption = '&Navigate'
+ Enabled = False
+ object First1: TMenuItem
+ Caption = '&First'
+ OnClick = First1Click
+ end
+ object Last1: TMenuItem
+ Caption = '&Last'
+ OnClick = Last1Click
+ end
+ object Next1: TMenuItem
+ Caption = '&Next'
+ OnClick = Next1Click
+ end
+ object Prior1: TMenuItem
+ Caption = '&Prior'
+ OnClick = Prior1Click
+ end
+ end
+ object Edit1: TMenuItem
+ Caption = '&Edit'
+ Enabled = False
+ object Append1: TMenuItem
+ Caption = '&Append'
+ OnClick = Append1Click
+ end
+ object Insert1: TMenuItem
+ Caption = '&Insert'
+ OnClick = Insert1Click
+ end
+ object Post1: TMenuItem
+ Caption = '&Post'
+ OnClick = Post1Click
+ end
+ object Refresh1: TMenuItem
+ Caption = '&Refresh'
+ OnClick = Refresh1Click
+ end
+ object N2: TMenuItem
+ Caption = '-'
+ end
+ object Cancel1: TMenuItem
+ Caption = '&Cancel'
+ OnClick = Cancel1Click
+ end
+ end
+ end
+end
diff --git a/components/flashfiler/examples/LazExtCust/excustu.pas b/components/flashfiler/examples/LazExtCust/excustu.pas
new file mode 100644
index 000000000..1b0de08d2
--- /dev/null
+++ b/components/flashfiler/examples/LazExtCust/excustu.pas
@@ -0,0 +1,172 @@
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+unit ExCustu;
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
+ DBCtrls, ExtCtrls, Menus, Grids, DBGrids, Db, FFDB, FFDBBase, ffllcomm,
+ fflllgcy, ffllcomp, fflleng, ffsrintm, ffclreng, ffllbase;
+
+type
+ TForm1 = class(TForm)
+ ffSess: TffSession;
+ CustomerTable: TffTable;
+ CustomerData: TDataSource;
+ CustomerGrid: TDBGrid;
+ MainMenu1: TMainMenu;
+ File1: TMenuItem;
+ Open1: TMenuItem;
+ Close1: TMenuItem;
+ N1: TMenuItem;
+ Exit1: TMenuItem;
+ Navigate1: TMenuItem;
+ First1: TMenuItem;
+ Last1: TMenuItem;
+ Next1: TMenuItem;
+ Prior1: TMenuItem;
+ Edit1: TMenuItem;
+ Append1: TMenuItem;
+ Post1: TMenuItem;
+ Refresh1: TMenuItem;
+ Insert1: TMenuItem;
+ N2: TMenuItem;
+ Cancel1: TMenuItem;
+ DBNavigator1: TDBNavigator;
+ ffClient: TffClient;
+ ffRSE: TFFRemoteServerEngine;
+ ltMain: TffLegacyTransport;
+ procedure Open1Click(Sender: TObject);
+ procedure Close1Click(Sender: TObject);
+ procedure Exit1Click(Sender: TObject);
+ procedure First1Click(Sender: TObject);
+ procedure Last1Click(Sender: TObject);
+ procedure Next1Click(Sender: TObject);
+ procedure Prior1Click(Sender: TObject);
+ procedure Append1Click(Sender: TObject);
+ procedure Post1Click(Sender: TObject);
+ procedure Refresh1Click(Sender: TObject);
+ procedure Insert1Click(Sender: TObject);
+ procedure Cancel1Click(Sender: TObject);
+ procedure FormShow(Sender: TObject);
+ private
+ { Private declarations }
+ public
+ { Public declarations }
+ end;
+
+var
+ Form1: TForm1;
+
+implementation
+
+const
+ csAlias = 'Tutorial';
+
+{$R *.DFM}
+
+procedure TForm1.Open1Click(Sender: TObject);
+begin
+ CustomerTable.Active := True;
+ Close1.Enabled := True;
+ Navigate1.Enabled := True;
+ Edit1.Enabled := True;
+end;
+
+procedure TForm1.Close1Click(Sender: TObject);
+begin
+ CustomerTable.Active := False;
+ Close1.Enabled := False;
+ Navigate1.Enabled := False;
+ Edit1.Enabled := False;
+end;
+
+procedure TForm1.Exit1Click(Sender: TObject);
+begin
+ Close;
+end;
+
+procedure TForm1.First1Click(Sender: TObject);
+begin
+ CustomerTable.First;
+end;
+
+procedure TForm1.Last1Click(Sender: TObject);
+begin
+ CustomerTable.Last;
+end;
+
+procedure TForm1.Next1Click(Sender: TObject);
+begin
+ CustomerTable.Next;
+end;
+
+procedure TForm1.Prior1Click(Sender: TObject);
+begin
+ CustomerTable.Prior;
+end;
+
+procedure TForm1.Append1Click(Sender: TObject);
+begin
+ CustomerTable.Append;
+end;
+
+procedure TForm1.Post1Click(Sender: TObject);
+begin
+ CustomerTable.Post;
+end;
+
+procedure TForm1.Refresh1Click(Sender: TObject);
+begin
+ CustomerTable.Refresh;
+end;
+
+procedure TForm1.Insert1Click(Sender: TObject);
+begin
+ CustomerTable.Insert;
+end;
+
+procedure TForm1.Cancel1Click(Sender: TObject);
+begin
+ CustomerTable.Cancel;
+end;
+
+procedure TForm1.FormShow(Sender: TObject);
+var
+ aPath : string;
+begin
+ ffSess.Open;
+ if not ffSess.IsAlias(csAlias) then begin
+ aPath := ExtractFilePath(Application.ExeName);
+ if aPath[Length(aPath)] <> '\' then
+ aPath := aPath + '\';
+ { Path should point to the folder containing the Mythic tables. }
+ ffSess.AddAlias(csAlias, aPath + '..', False);
+ end;
+end;
+
+end.
diff --git a/components/flashfiler/examples/LazTffTblIndexNameError/project1.ico b/components/flashfiler/examples/LazTffTblIndexNameError/project1.ico
new file mode 100644
index 000000000..0341321b5
Binary files /dev/null and b/components/flashfiler/examples/LazTffTblIndexNameError/project1.ico differ
diff --git a/components/flashfiler/examples/LazTffTblIndexNameError/project1.lpi b/components/flashfiler/examples/LazTffTblIndexNameError/project1.lpi
new file mode 100644
index 000000000..543991249
--- /dev/null
+++ b/components/flashfiler/examples/LazTffTblIndexNameError/project1.lpi
@@ -0,0 +1,88 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/flashfiler/examples/LazTffTblIndexNameError/project1.lpr b/components/flashfiler/examples/LazTffTblIndexNameError/project1.lpr
new file mode 100644
index 000000000..e9338d792
--- /dev/null
+++ b/components/flashfiler/examples/LazTffTblIndexNameError/project1.lpr
@@ -0,0 +1,21 @@
+program project1;
+
+{$mode objfpc}{$H+}
+
+uses
+ {$IFDEF UNIX}{$IFDEF UseCThreads}
+ cthreads,
+ {$ENDIF}{$ENDIF}
+ Interfaces, // this includes the LCL widgetset
+ Forms, Unit1, lazff2
+ { you can add units after this };
+
+{$R *.res}
+
+begin
+ RequireDerivedFormResource:=True;
+ Application.Initialize;
+ Application.CreateForm(TForm1, Form1);
+ Application.Run;
+end.
+
diff --git a/components/flashfiler/examples/LazTffTblIndexNameError/project1.res b/components/flashfiler/examples/LazTffTblIndexNameError/project1.res
new file mode 100644
index 000000000..e994dfa65
Binary files /dev/null and b/components/flashfiler/examples/LazTffTblIndexNameError/project1.res differ
diff --git a/components/flashfiler/examples/LazTffTblIndexNameError/unit1.lfm b/components/flashfiler/examples/LazTffTblIndexNameError/unit1.lfm
new file mode 100644
index 000000000..f8d914fec
--- /dev/null
+++ b/components/flashfiler/examples/LazTffTblIndexNameError/unit1.lfm
@@ -0,0 +1,164 @@
+object Form1: TForm1
+ Left = 295
+ Height = 310
+ Top = 147
+ Width = 320
+ Caption = 'Form1'
+ ClientHeight = 310
+ ClientWidth = 320
+ OnCreate = FormCreate
+ LCLVersion = '1.6.1.0'
+ object ToolBar1: TToolBar
+ Left = 0
+ Height = 20
+ Top = 0
+ Width = 320
+ AutoSize = True
+ Caption = 'ToolBar1'
+ EdgeBorders = []
+ TabOrder = 0
+ object DBNavigator1: TDBNavigator
+ Left = 1
+ Height = 20
+ Top = 0
+ Width = 200
+ AutoSize = True
+ BevelOuter = bvNone
+ ChildSizing.EnlargeHorizontal = crsScaleChilds
+ ChildSizing.EnlargeVertical = crsScaleChilds
+ ChildSizing.ShrinkHorizontal = crsScaleChilds
+ ChildSizing.ShrinkVertical = crsScaleChilds
+ ChildSizing.Layout = cclLeftToRightThenTopToBottom
+ ChildSizing.ControlsPerLine = 100
+ ClientHeight = 20
+ ClientWidth = 200
+ DataSource = DataSource1
+ Options = []
+ TabOrder = 0
+ end
+ end
+ object DBGrid1: TDBGrid
+ Left = 0
+ Height = 290
+ Top = 20
+ Width = 320
+ Align = alClient
+ Color = clWindow
+ Columns = <>
+ DataSource = DataSource1
+ TabOrder = 1
+ end
+ object ffLegacyTransport1: TffLegacyTransport
+ Enabled = True
+ ServerName = 'Local server'
+ left = 28
+ top = 12
+ end
+ object FFRemoteServerEngine1: TFFRemoteServerEngine
+ Transport = ffLegacyTransport1
+ left = 28
+ top = 70
+ end
+ object ffClient1: TffClient
+ Active = True
+ ClientName = 'ffClient1'
+ ServerEngine = FFRemoteServerEngine1
+ TimeOut = 100
+ left = 28
+ top = 122
+ end
+ object ffSession1: TffSession
+ Active = True
+ ClientName = 'ffClient1'
+ SessionName = 'ffSession1sa'
+ TimeOut = 100
+ left = 26
+ top = 174
+ end
+ object ffDatabase1: TffDatabase
+ AliasName = 'Tutorial'
+ Connected = True
+ DatabaseName = 'ffDbDebug'
+ SessionName = 'ffSession1sa'
+ Timeout = 1000
+ left = 76
+ top = 176
+ end
+ object ffTable1: TffTable
+ DatabaseName = 'ffDbDebug'
+ FieldDefs = <
+ item
+ Name = 'CustomerID'
+ DataType = ftInteger
+ Precision = -1
+ end
+ item
+ Name = 'FirstName'
+ DataType = ftString
+ Precision = -1
+ Size = 25
+ end
+ item
+ Name = 'LastName'
+ DataType = ftString
+ Precision = -1
+ Size = 25
+ end
+ item
+ Name = 'Address'
+ DataType = ftString
+ Precision = -1
+ Size = 25
+ end
+ item
+ Name = 'City'
+ DataType = ftString
+ Precision = -1
+ Size = 25
+ end
+ item
+ Name = 'State'
+ DataType = ftString
+ Precision = -1
+ Size = 25
+ end
+ item
+ Name = 'Zip'
+ DataType = ftString
+ Precision = -1
+ Size = 10
+ end>
+ FilterOptions = []
+ IndexDefs = <
+ item
+ Name = 'Sequential Access Index'
+ Options = [ixUnique, ixCaseInsensitive, ixExpression]
+ end
+ item
+ Name = 'ByID'
+ Fields = 'CustomerID'
+ Options = [ixUnique]
+ end
+ item
+ Name = 'ByName'
+ Fields = 'LastName'
+ Options = [ixCaseInsensitive]
+ end
+ item
+ Name = 'ByState'
+ Fields = 'State'
+ Options = [ixCaseInsensitive]
+ end>
+ IndexName = 'ByID'
+ SessionName = 'ffSession1sa'
+ TableName = 'excust'
+ Timeout = 100
+ left = 32
+ top = 234
+ end
+ object DataSource1: TDataSource
+ DataSet = ffTable1
+ left = 239
+ top = 32
+ end
+end
diff --git a/components/flashfiler/examples/LazTffTblIndexNameError/unit1.pas b/components/flashfiler/examples/LazTffTblIndexNameError/unit1.pas
new file mode 100644
index 000000000..79ee03ab4
--- /dev/null
+++ b/components/flashfiler/examples/LazTffTblIndexNameError/unit1.pas
@@ -0,0 +1,81 @@
+unit Unit1;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, db, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
+ ComCtrls, DbCtrls, DBGrids, fflllgcy, ffsreng, ffclreng, ffdb;
+
+type
+
+ { TForm1 }
+
+ TForm1 = class(TForm)
+ DataSource1: TDataSource;
+ DBGrid1: TDBGrid;
+ DBNavigator1: TDBNavigator;
+ ffClient1: TffClient;
+ ffDatabase1: TffDatabase;
+ ffLegacyTransport1: TffLegacyTransport;
+ FFRemoteServerEngine1: TFFRemoteServerEngine;
+ ffSession1: TffSession;
+ ffTable1: TffTable;
+ ToolBar1: TToolBar;
+ procedure FormCreate(Sender: TObject);
+ private
+ { private declarations }
+ public
+ { public declarations }
+ end;
+
+var
+ Form1: TForm1;
+
+implementation
+
+{$R *.lfm}
+
+{ TForm1 }
+
+procedure TForm1.FormCreate(Sender: TObject);
+begin
+ // 2016.04.25 SOLVED (pred(0)=0 error look at ffdb.TffBaseTable.dsGetIndexInfo;)
+ // if TffTable.IndexName='' then TffTable.Active:=True; causes exception!
+ ffTable1.IndexName:='';//<-- 1.
+ //ffTable1.IndexName:='Sequential Access Index';//test
+ ffTable1.Active:=True; //<-- 2. Exception
+ Caption:='test';
+
+{Result of one Debug session
+ffllbase.pas
+first -->
+ Zeile 6227
+ rwpGate.Lock
+ (rwpGate is TffPadLock)
+then -->
+ Row 6377
+ Called very often (enless? until Timeout?)
+
+ procedure TffPadLock.Lock;
+ begin
+ if IsMultiThread then begin
+ EnterCriticalSection(plCritSect);
+ inc(plCount);
+ end;
+ end;
+
+Forget next lines, they are secundary errors (timeout, while debugging) :
+Current debug run (stop, trace...) i get this error:
+"Timed out waitig for reply"
+
+then ---> ffdtmsq.pas
+ row 195
+ aTail^.dmnNext := aNode;
+ "aTail is nil"
+}
+end;
+
+end.
+
diff --git a/components/flashfiler/examples/Lazffsql/excust.dpr b/components/flashfiler/examples/Lazffsql/excust.dpr
new file mode 100644
index 000000000..671308693
--- /dev/null
+++ b/components/flashfiler/examples/Lazffsql/excust.dpr
@@ -0,0 +1,13 @@
+program ExCust;
+
+uses
+ Forms, Interfaces,
+ ExCustu in 'ExCustu.pas', lazff2 {Form1};
+
+{$R *.res}
+
+begin
+ Application.Initialize;
+ Application.CreateForm(TForm1, Form1);
+ Application.Run;
+end.
diff --git a/components/flashfiler/examples/Lazffsql/excust.ico b/components/flashfiler/examples/Lazffsql/excust.ico
new file mode 100644
index 000000000..0341321b5
Binary files /dev/null and b/components/flashfiler/examples/Lazffsql/excust.ico differ
diff --git a/components/flashfiler/examples/Lazffsql/excust.lpi b/components/flashfiler/examples/Lazffsql/excust.lpi
new file mode 100644
index 000000000..4ee3a250c
--- /dev/null
+++ b/components/flashfiler/examples/Lazffsql/excust.lpi
@@ -0,0 +1,77 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/flashfiler/examples/Lazffsql/excust.res b/components/flashfiler/examples/Lazffsql/excust.res
new file mode 100644
index 000000000..e994dfa65
Binary files /dev/null and b/components/flashfiler/examples/Lazffsql/excust.res differ
diff --git a/components/flashfiler/examples/Lazffsql/excustu.dfm b/components/flashfiler/examples/Lazffsql/excustu.dfm
new file mode 100644
index 000000000..0b0ed8791
--- /dev/null
+++ b/components/flashfiler/examples/Lazffsql/excustu.dfm
@@ -0,0 +1,208 @@
+object Form1: TForm1
+ Left = 224
+ Height = 287
+ Top = 96
+ Width = 540
+ Caption = 'FlashFiler Example - Customer Data'
+ ClientHeight = 268
+ ClientWidth = 540
+ Color = clBtnFace
+ Font.Color = clWindowText
+ Font.Height = -11
+ Font.Name = 'MS Sans Serif'
+ Menu = MainMenu1
+ OnShow = FormShow
+ LCLVersion = '1.6.1.0'
+ object ToolBar1: TToolBar
+ Left = 0
+ Height = 23
+ Top = 0
+ Width = 540
+ AutoSize = True
+ ButtonHeight = 21
+ ButtonWidth = 55
+ Caption = 'ToolBar1'
+ ShowCaptions = True
+ TabOrder = 0
+ object TlBtnRunQuery: TToolButton
+ Left = 1
+ Top = 2
+ Caption = 'RunQuery'
+ ImageIndex = 0
+ OnClick = TlBtnRunQueryClick
+ end
+ object ToolButton2: TToolButton
+ Left = 57
+ Height = 21
+ Top = 2
+ Width = 8
+ Caption = 'ToolButton2'
+ ImageIndex = 1
+ Style = tbsSeparator
+ end
+ object DBNavigator1: TDBNavigator
+ Left = 65
+ Height = 21
+ Top = 2
+ Width = 250
+ BevelOuter = bvNone
+ ChildSizing.EnlargeHorizontal = crsScaleChilds
+ ChildSizing.EnlargeVertical = crsScaleChilds
+ ChildSizing.ShrinkHorizontal = crsScaleChilds
+ ChildSizing.ShrinkVertical = crsScaleChilds
+ ChildSizing.Layout = cclLeftToRightThenTopToBottom
+ ChildSizing.ControlsPerLine = 100
+ ClientHeight = 21
+ ClientWidth = 250
+ DataSource = CustomerData
+ Flat = True
+ Options = []
+ TabOrder = 0
+ end
+ end
+ object CustomerGrid: TDBGrid
+ Left = 0
+ Height = 156
+ Top = 112
+ Width = 540
+ Align = alClient
+ Color = clWindow
+ Columns = <>
+ DataSource = CustomerData
+ TabOrder = 1
+ TitleFont.Color = clWindowText
+ TitleFont.Height = -11
+ TitleFont.Name = 'MS Sans Serif'
+ end
+ object Memo1: TMemo
+ Left = 0
+ Height = 89
+ Top = 23
+ Width = 540
+ Align = alTop
+ Lines.Strings = (
+ 'select * from ExCust where State=''NC'' AND CustomerID<50'
+ )
+ OnKeyDown = Memo1KeyDown
+ TabOrder = 2
+ end
+ object ltMain: TffLegacyTransport
+ Enabled = True
+ ServerName = 'Local server'
+ left = 352
+ top = 88
+ end
+ object ffRSE: TFFRemoteServerEngine
+ Transport = ltMain
+ left = 320
+ top = 88
+ end
+ object ffClient: TffClient
+ ClientName = 'ffClient'
+ ServerEngine = ffRSE
+ left = 320
+ top = 56
+ end
+ object ffSess: TffSession
+ ClientName = 'ffClient'
+ SessionName = 'ExCust'
+ left = 352
+ top = 56
+ end
+ object CustomerTable: TffTable
+ DatabaseName = 'Tutorial'
+ FieldDefs = <>
+ FilterOptions = []
+ IndexName = 'ByID'
+ SessionName = 'ExCust'
+ TableName = 'ExCust'
+ Timeout = 10000
+ left = 420
+ top = 124
+ end
+ object CustomerData: TDataSource
+ DataSet = ffQuery1
+ left = 416
+ top = 56
+ end
+ object MainMenu1: TMainMenu
+ left = 448
+ top = 56
+ object File1: TMenuItem
+ Caption = '&File'
+ object Open1: TMenuItem
+ Caption = '&Open'
+ OnClick = Open1Click
+ end
+ object Close1: TMenuItem
+ Caption = '&Close'
+ Enabled = False
+ OnClick = Close1Click
+ end
+ object N1: TMenuItem
+ Caption = '-'
+ end
+ object Exit1: TMenuItem
+ Caption = '&Exit'
+ OnClick = Exit1Click
+ end
+ end
+ object Navigate1: TMenuItem
+ Caption = '&Navigate'
+ Enabled = False
+ object First1: TMenuItem
+ Caption = '&First'
+ OnClick = First1Click
+ end
+ object Last1: TMenuItem
+ Caption = '&Last'
+ OnClick = Last1Click
+ end
+ object Next1: TMenuItem
+ Caption = '&Next'
+ OnClick = Next1Click
+ end
+ object Prior1: TMenuItem
+ Caption = '&Prior'
+ OnClick = Prior1Click
+ end
+ end
+ object Edit1: TMenuItem
+ Caption = '&Edit'
+ Enabled = False
+ object Append1: TMenuItem
+ Caption = '&Append'
+ OnClick = Append1Click
+ end
+ object Insert1: TMenuItem
+ Caption = '&Insert'
+ OnClick = Insert1Click
+ end
+ object Post1: TMenuItem
+ Caption = '&Post'
+ OnClick = Post1Click
+ end
+ object Refresh1: TMenuItem
+ Caption = '&Refresh'
+ OnClick = Refresh1Click
+ end
+ object N2: TMenuItem
+ Caption = '-'
+ end
+ object Cancel1: TMenuItem
+ Caption = '&Cancel'
+ OnClick = Cancel1Click
+ end
+ end
+ end
+ object ffQuery1: TffQuery
+ DatabaseName = 'Tutorial'
+ FilterOptions = []
+ SessionName = 'ExCust'
+ SQL.Strings = (
+ 'select * from ExCust where State=''NC'' AND CustomerID<50'
+ )
+ left = 382
+ top = 38
+ end
+end
diff --git a/components/flashfiler/examples/Lazffsql/excustu.lrs b/components/flashfiler/examples/Lazffsql/excustu.lrs
new file mode 100644
index 000000000..33ffd082e
--- /dev/null
+++ b/components/flashfiler/examples/Lazffsql/excustu.lrs
@@ -0,0 +1,60 @@
+{ This is an automatically generated lazarus resource file }
+
+LazarusResources.Add('TForm1','FORMDATA',[
+ 'TPF0'#6'TForm1'#5'Form1'#4'Left'#3#224#0#6'Height'#3#31#1#3'Top'#2'`'#5'Widt'
+ +'h'#3#28#2#7'Caption'#6'"FlashFiler Example - Customer Data'#12'ClientHeight'
+ +#3#12#1#11'ClientWidth'#3#28#2#5'Color'#7#9'clBtnFace'#10'Font.Color'#7#12'c'
+ +'lWindowText'#11'Font.Height'#2#245#9'Font.Name'#6#13'MS Sans Serif'#4'Menu'
+ +#7#9'MainMenu1'#6'OnShow'#7#8'FormShow'#10'LCLVersion'#6#7'1.6.1.0'#0#8'TToo'
+ +'lBar'#8'ToolBar1'#4'Left'#2#0#6'Height'#2#23#3'Top'#2#0#5'Width'#3#28#2#8'A'
+ +'utoSize'#9#12'ButtonHeight'#2#21#11'ButtonWidth'#2'7'#7'Caption'#6#8'ToolBa'
+ +'r1'#12'ShowCaptions'#9#8'TabOrder'#2#0#0#11'TToolButton'#13'TlBtnRunQuery'#4
+ +'Left'#2#1#3'Top'#2#2#7'Caption'#6#8'RunQuery'#10'ImageIndex'#2#0#7'OnClick'
+ +#7#18'TlBtnRunQueryClick'#0#0#11'TToolButton'#11'ToolButton2'#4'Left'#2'9'#6
+ +'Height'#2#21#3'Top'#2#2#5'Width'#2#8#7'Caption'#6#11'ToolButton2'#10'ImageI'
+ +'ndex'#2#1#5'Style'#7#12'tbsSeparator'#0#0#12'TDBNavigator'#12'DBNavigator1'
+ +#4'Left'#2'A'#6'Height'#2#21#3'Top'#2#2#5'Width'#3#250#0#10'BevelOuter'#7#6
+ +'bvNone'#29'ChildSizing.EnlargeHorizontal'#7#14'crsScaleChilds'#27'ChildSizi'
+ +'ng.EnlargeVertical'#7#14'crsScaleChilds'#28'ChildSizing.ShrinkHorizontal'#7
+ +#14'crsScaleChilds'#26'ChildSizing.ShrinkVertical'#7#14'crsScaleChilds'#18'C'
+ +'hildSizing.Layout'#7#29'cclLeftToRightThenTopToBottom'#27'ChildSizing.Contr'
+ +'olsPerLine'#2'd'#12'ClientHeight'#2#21#11'ClientWidth'#3#250#0#10'DataSourc'
+ +'e'#7#12'CustomerData'#4'Flat'#9#7'Options'#11#0#8'TabOrder'#2#0#0#0#0#7'TDB'
+ +'Grid'#12'CustomerGrid'#4'Left'#2#0#6'Height'#3#156#0#3'Top'#2'p'#5'Width'#3
+ +#28#2#5'Align'#7#8'alClient'#5'Color'#7#8'clWindow'#7'Columns'#14#0#10'DataS'
+ +'ource'#7#12'CustomerData'#8'TabOrder'#2#1#15'TitleFont.Color'#7#12'clWindow'
+ +'Text'#16'TitleFont.Height'#2#245#14'TitleFont.Name'#6#13'MS Sans Serif'#0#0
+ +#5'TMemo'#5'Memo1'#4'Left'#2#0#6'Height'#2'Y'#3'Top'#2#23#5'Width'#3#28#2#5
+ +'Align'#7#5'alTop'#13'Lines.Strings'#1#6'8select * from ExCust where State='
+ +'''NC'' AND CustomerID<50'#0#9'OnKeyDown'#7#12'Memo1KeyDown'#8'TabOrder'#2#2
+ +#0#0#18'TffLegacyTransport'#6'ltMain'#7'Enabled'#9#10'ServerName'#6#12'Local'
+ +' server'#4'left'#3'`'#1#3'top'#2'X'#0#0#21'TFFRemoteServerEngine'#5'ffRSE'#9
+ +'Transport'#7#6'ltMain'#4'left'#3'@'#1#3'top'#2'X'#0#0#9'TffClient'#8'ffClie'
+ +'nt'#10'ClientName'#6#8'ffClient'#12'ServerEngine'#7#5'ffRSE'#4'left'#3'@'#1
+ +#3'top'#2'8'#0#0#10'TffSession'#6'ffSess'#10'ClientName'#6#8'ffClient'#11'Se'
+ +'ssionName'#6#6'ExCust'#4'left'#3'`'#1#3'top'#2'8'#0#0#8'TffTable'#13'Custom'
+ +'erTable'#12'DatabaseName'#6#8'Tutorial'#9'FieldDefs'#14#0#13'FilterOptions'
+ +#11#0#9'IndexName'#6#4'ByID'#11'SessionName'#6#6'ExCust'#9'TableName'#6#6'Ex'
+ +'Cust'#7'Timeout'#3#16''''#4'left'#3#164#1#3'top'#2'|'#0#0#11'TDataSource'#12
+ +'CustomerData'#7'DataSet'#7#8'ffQuery1'#4'left'#3#160#1#3'top'#2'8'#0#0#9'TM'
+ +'ainMenu'#9'MainMenu1'#4'left'#3#192#1#3'top'#2'8'#0#9'TMenuItem'#5'File1'#7
+ +'Caption'#6#5'&File'#0#9'TMenuItem'#5'Open1'#7'Caption'#6#5'&Open'#7'OnClick'
+ +#7#10'Open1Click'#0#0#9'TMenuItem'#6'Close1'#7'Caption'#6#6'&Close'#7'Enable'
+ +'d'#8#7'OnClick'#7#11'Close1Click'#0#0#9'TMenuItem'#2'N1'#7'Caption'#6#1'-'#0
+ +#0#9'TMenuItem'#5'Exit1'#7'Caption'#6#5'&Exit'#7'OnClick'#7#10'Exit1Click'#0
+ +#0#0#9'TMenuItem'#9'Navigate1'#7'Caption'#6#9'&Navigate'#7'Enabled'#8#0#9'TM'
+ +'enuItem'#6'First1'#7'Caption'#6#6'&First'#7'OnClick'#7#11'First1Click'#0#0#9
+ +'TMenuItem'#5'Last1'#7'Caption'#6#5'&Last'#7'OnClick'#7#10'Last1Click'#0#0#9
+ +'TMenuItem'#5'Next1'#7'Caption'#6#5'&Next'#7'OnClick'#7#10'Next1Click'#0#0#9
+ +'TMenuItem'#6'Prior1'#7'Caption'#6#6'&Prior'#7'OnClick'#7#11'Prior1Click'#0#0
+ +#0#9'TMenuItem'#5'Edit1'#7'Caption'#6#5'&Edit'#7'Enabled'#8#0#9'TMenuItem'#7
+ +'Append1'#7'Caption'#6#7'&Append'#7'OnClick'#7#12'Append1Click'#0#0#9'TMenuI'
+ +'tem'#7'Insert1'#7'Caption'#6#7'&Insert'#7'OnClick'#7#12'Insert1Click'#0#0#9
+ +'TMenuItem'#5'Post1'#7'Caption'#6#5'&Post'#7'OnClick'#7#10'Post1Click'#0#0#9
+ +'TMenuItem'#8'Refresh1'#7'Caption'#6#8'&Refresh'#7'OnClick'#7#13'Refresh1Cli'
+ +'ck'#0#0#9'TMenuItem'#2'N2'#7'Caption'#6#1'-'#0#0#9'TMenuItem'#7'Cancel1'#7
+ +'Caption'#6#7'&Cancel'#7'OnClick'#7#12'Cancel1Click'#0#0#0#0#8'TffQuery'#8'f'
+ +'fQuery1'#12'DatabaseName'#6#8'Tutorial'#13'FilterOptions'#11#0#11'SessionNa'
+ +'me'#6#6'ExCust'#11'SQL.Strings'#1#6'8select * from ExCust where State=''NC'
+ +''' AND CustomerID<50'#0#4'left'#3'~'#1#3'top'#2'&'#0#0#0
+]);
diff --git a/components/flashfiler/examples/Lazffsql/excustu.pas b/components/flashfiler/examples/Lazffsql/excustu.pas
new file mode 100644
index 000000000..134656d96
--- /dev/null
+++ b/components/flashfiler/examples/Lazffsql/excustu.pas
@@ -0,0 +1,194 @@
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+unit ExCustu;
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
+ DBCtrls, ExtCtrls, Menus, Grids, DBGrids, Db, FFDB, FFDBBase, ffllcomm,
+ fflllgcy, ffllcomp, fflleng, ffsrintm, ffclreng, ffllbase, StdCtrls, ToolWin,
+ ComCtrls;
+
+type
+ TForm1 = class(TForm)
+ ffSess: TffSession;
+ CustomerTable: TffTable;
+ CustomerData: TDataSource;
+ CustomerGrid: TDBGrid;
+ MainMenu1: TMainMenu;
+ File1: TMenuItem;
+ Open1: TMenuItem;
+ Close1: TMenuItem;
+ N1: TMenuItem;
+ Exit1: TMenuItem;
+ Navigate1: TMenuItem;
+ First1: TMenuItem;
+ Last1: TMenuItem;
+ Next1: TMenuItem;
+ Prior1: TMenuItem;
+ Edit1: TMenuItem;
+ Append1: TMenuItem;
+ Post1: TMenuItem;
+ Refresh1: TMenuItem;
+ Insert1: TMenuItem;
+ N2: TMenuItem;
+ Cancel1: TMenuItem;
+ DBNavigator1: TDBNavigator;
+ ffClient: TffClient;
+ ffRSE: TFFRemoteServerEngine;
+ ltMain: TffLegacyTransport;
+ ToolBar1: TToolBar;
+ Memo1: TMemo;
+ ffQuery1: TffQuery;
+ TlBtnRunQuery: TToolButton;
+ ToolButton2: TToolButton;
+ procedure Open1Click(Sender: TObject);
+ procedure Close1Click(Sender: TObject);
+ procedure Exit1Click(Sender: TObject);
+ procedure First1Click(Sender: TObject);
+ procedure Last1Click(Sender: TObject);
+ procedure Next1Click(Sender: TObject);
+ procedure Prior1Click(Sender: TObject);
+ procedure Append1Click(Sender: TObject);
+ procedure Post1Click(Sender: TObject);
+ procedure Refresh1Click(Sender: TObject);
+ procedure Insert1Click(Sender: TObject);
+ procedure Cancel1Click(Sender: TObject);
+ procedure FormShow(Sender: TObject);
+ procedure TlBtnRunQueryClick(Sender: TObject);
+ procedure Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
+ private
+ { Private declarations }
+ public
+ { Public declarations }
+ end;
+
+var
+ Form1: TForm1;
+
+implementation
+
+const
+ csAlias = 'Tutorial';
+
+{$R *.DFM}
+
+procedure TForm1.Open1Click(Sender: TObject);
+begin
+ ffQuery1.Open; //soner: CustomerTable.Active := True;
+ Close1.Enabled := True;
+ Navigate1.Enabled := True;
+ Edit1.Enabled := True;
+end;
+
+procedure TForm1.Close1Click(Sender: TObject);
+begin
+ ffQuery1.Close; //soner: CustomerTable.Active := False;
+ Close1.Enabled := False;
+ Navigate1.Enabled := False;
+ Edit1.Enabled := False;
+end;
+
+procedure TForm1.Exit1Click(Sender: TObject);
+begin
+ Close;
+end;
+
+procedure TForm1.First1Click(Sender: TObject);
+begin
+ CustomerTable.First;
+end;
+
+procedure TForm1.Last1Click(Sender: TObject);
+begin
+ CustomerTable.Last;
+end;
+
+
+procedure TForm1.Next1Click(Sender: TObject);
+begin
+ CustomerTable.Next;
+end;
+
+procedure TForm1.Prior1Click(Sender: TObject);
+begin
+ CustomerTable.Prior;
+end;
+
+procedure TForm1.Append1Click(Sender: TObject);
+begin
+ CustomerTable.Append;
+end;
+
+procedure TForm1.Post1Click(Sender: TObject);
+begin
+ CustomerTable.Post;
+end;
+
+procedure TForm1.Refresh1Click(Sender: TObject);
+begin
+ CustomerTable.Refresh;
+end;
+
+procedure TForm1.Insert1Click(Sender: TObject);
+begin
+ CustomerTable.Insert;
+end;
+
+procedure TForm1.Cancel1Click(Sender: TObject);
+begin
+ CustomerTable.Cancel;
+end;
+
+procedure TForm1.FormShow(Sender: TObject);
+var
+ aPath : string;
+begin
+ ffSess.Open;
+ if not ffSess.IsAlias(csAlias) then begin
+ aPath := ExtractFilePath(Application.ExeName);
+ if aPath[Length(aPath)] <> '\' then
+ aPath := aPath + '\';
+ { Path should point to the folder containing the Mythic tables. }
+ ffSess.AddAlias(csAlias, aPath + '..', False);
+ end;
+end;
+
+procedure TForm1.TlBtnRunQueryClick(Sender: TObject);
+begin
+ //soner
+ ffQuery1.SQL.Text:=Memo1.Lines.Text;
+ ffQuery1.Open;
+end;
+
+procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word;
+ Shift: TShiftState);
+begin
+ if (key=VK_RETURN)and(ssCtrl in Shift) then TlBtnRunQuery.Click;
+end;
+
+end.
diff --git a/components/flashfiler/packages/lazff2.lpk b/components/flashfiler/packages/lazff2.lpk
new file mode 100644
index 000000000..4074cd782
--- /dev/null
+++ b/components/flashfiler/packages/lazff2.lpk
@@ -0,0 +1,69 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/flashfiler/packages/lazff2.pas b/components/flashfiler/packages/lazff2.pas
new file mode 100644
index 000000000..cf5c7a7af
--- /dev/null
+++ b/components/flashfiler/packages/lazff2.pas
@@ -0,0 +1,22 @@
+{ This file was automatically created by Lazarus. Do not edit!
+ This source is only used to compile and install the package.
+ }
+
+unit lazff2;
+
+interface
+
+uses
+ ffclreg, ffclfldg, ffabout, ffclexps, ffllgrid, ffclsqle, ffllexcp,
+ LazarusPackageIntf;
+
+implementation
+
+procedure Register;
+begin
+ RegisterUnit('ffclreg', @ffclreg.Register);
+end;
+
+initialization
+ RegisterPackage('lazff2', @Register);
+end.
diff --git a/components/flashfiler/sourcelaz/#NotUsedMore/lazffdelphi1.pas b/components/flashfiler/sourcelaz/#NotUsedMore/lazffdelphi1.pas
new file mode 100644
index 000000000..cf8cc89d6
--- /dev/null
+++ b/components/flashfiler/sourcelaz/#NotUsedMore/lazffdelphi1.pas
@@ -0,0 +1,2075 @@
+{ Only ffdb.pas uses this unit.
+ ffdb is using only this classes or types:
+ TFilterExpr
+ PExprNode
+ TExprParser
+
+ !!! CODE TAKEN FROM DELPHI7 - BORLAND CODE !!!
+}
+
+{ *************************************************************************** }
+{ }
+{ Kylix and Delphi Cross-Platform Visual Component Library }
+{ }
+{ Copyright (c) 1995, 2001 Borland Software Corporation }
+{ }
+{ *************************************************************************** }
+
+{$I ffdefine.inc}
+
+//Original called in Delphi: DbCommon.pas
+// called only from ffdb.pas
+unit lazffdelphi1;
+
+{$T-,H+,X+,R-}
+
+interface
+
+{$IFDEF MSWINDOWS}
+uses Windows, Variants, Classes, DB, {$ifdef fpc}lazffdelphi2{$else}SqlTimSt{$endif};
+{$ENDIF}
+{$IFDEF LINUX}
+uses Libc, Variants, Classes, DB, {$ifdef fpc}lazffdelphi2{$else}SqlTimSt{$endif};
+{$ENDIF}
+
+type
+ TCANOperator = (
+ coNOTDEFINED, { }
+ coISBLANK, { coUnary; is operand blank. }
+ coNOTBLANK, { coUnary; is operand not blank. }
+ coEQ, { coBinary, coCompare; equal. }
+ coNE, { coBinary; NOT equal. }
+ coGT, { coBinary; greater than. }
+ coLT, { coBinary; less than. }
+ coGE, { coBinary; greater or equal. }
+ coLE, { coBinary; less or equal. }
+ coNOT, { coUnary; NOT }
+ coAND, { coBinary; AND }
+ coOR, { coBinary; OR }
+ coTUPLE2, { coUnary; Entire record is operand. }
+ coFIELD2, { coUnary; operand is field }
+ coCONST2, { coUnary; operand is constant }
+ coMINUS, { coUnary; minus. }
+ coADD, { coBinary; addition. }
+ coSUB, { coBinary; subtraction. }
+ coMUL, { coBinary; multiplication. }
+ coDIV, { coBinary; division. }
+ coMOD, { coBinary; modulo division. }
+ coREM, { coBinary; remainder of division. }
+ coSUM, { coBinary, accumulate sum of. }
+ coCOUNT, { coBinary, accumulate count of. }
+ coMIN, { coBinary, find minimum of. }
+ coMAX, { coBinary, find maximum of. }
+ coAVG, { coBinary, find average of. }
+ coCONT, { coBinary; provides a link between two }
+ coUDF2, { coBinary; invokes a User defined fn }
+ coCONTINUE2, { coUnary; Stops evaluating records }
+ coLIKE, { coCompare, extended binary compare }
+ coIN, { coBinary field in list of values }
+ coLIST2, { List of constant values of same type }
+ coUPPER, { coUnary: upper case }
+ coLOWER, { coUnary: lower case }
+ coFUNC2, { coFunc: Function }
+ coLISTELEM2, { coListElem: List Element }
+ coASSIGN { coBinary: Field assignment }
+ );
+
+ NODEClass = ( { Node Class }
+ nodeNULL, { Null node }
+ nodeUNARY, { Node is a unary }
+ nodeBINARY, { Node is a binary }
+ nodeCOMPARE, { Node is a compare }
+ nodeFIELD, { Node is a field }
+ nodeCONST, { Node is a constant }
+ nodeTUPLE, { Node is a record }
+ nodeCONTINUE, { Node is a continue node }
+ nodeUDF, { Node is a UDF node }
+ nodeLIST, { Node is a LIST node }
+ nodeFUNC, { Node is a Function node }
+ nodeLISTELEM { Node is a List Element node }
+ );
+
+{Soner: Don't used in FlashFiler or in interface part
+const
+ CANEXPRSIZE = 10; // SizeOf(CANExpr)
+ CANHDRSIZE = 8; // SizeOf(CANHdr)
+ CANEXPRVERSION = 2;
+}
+
+type
+ TExprData = array of Byte;
+ TFieldMap = array[TFieldType] of Byte;
+
+{ TFilterExpr }
+
+type
+
+ TParserOption = (poExtSyntax, poAggregate, poDefaultExpr, poUseOrigNames,
+ poFieldNameGiven, poFieldDepend);
+ TParserOptions = set of TParserOption;
+
+ TExprNodeKind = (enField, enConst, enOperator, enFunc);
+ TExprScopeKind = (skField, skAgg, skConst);
+
+ PExprNode = ^TExprNode;
+ TExprNode = record
+ FNext: PExprNode;
+ FKind: TExprNodeKind;
+ FPartial: Boolean;
+ FOperator: TCANOperator;
+ FData: Variant;
+ FLeft: PExprNode;
+ FRight: PExprNode;
+ FDataType: TFieldType;
+ FDataSize: Integer;
+ FArgs: TList;
+ FScopeKind: TExprScopeKind;
+ end;
+
+ TFilterExpr = class
+ private
+ FDataSet: TDataSet;
+ FFieldMap: TFieldMap;
+ FOptions: TFilterOptions;
+ FParserOptions: TParserOptions;
+ FNodes: PExprNode;
+ FExprBuffer: TExprData;
+ FExprBufSize: Integer;
+ FExprNodeSize: Integer;
+ FExprDataSize: Integer;
+ FFieldName: string;
+ FDependentFields: TBits;
+ function FieldFromNode(Node: PExprNode): TField;
+ function GetExprData(Pos, Size: Integer): PChar;
+ function PutConstBCD(const Value: Variant; Decimals: Integer): Integer;
+ function PutConstFMTBCD(const Value: Variant; Decimals: Integer): Integer;
+ function PutConstBool(const Value: Variant): Integer;
+ function PutConstDate(const Value: Variant): Integer;
+ function PutConstDateTime(const Value: Variant): Integer;
+ function PutConstSQLTimeStamp(const Value: Variant): Integer;
+ function PutConstFloat(const Value: Variant): Integer;
+ function PutConstInt(DataType: TFieldType; const Value: Variant): Integer;
+ function PutConstNode(DataType: TFieldType; Data: PChar;
+ Size: Integer): Integer;
+ function PutConstStr(const Value: string): Integer;
+ function PutConstTime(const Value: Variant): Integer;
+ function PutData(Data: PChar; Size: Integer): Integer;
+ function PutExprNode(Node: PExprNode; ParentOp: TCANOperator): Integer;
+ function PutFieldNode(Field: TField; Node: PExprNode): Integer;
+ function PutNode(NodeType: NodeClass; OpType: TCANOperator;
+ OpCount: Integer): Integer;
+ procedure SetNodeOp(Node, Index, Data: Integer);
+ function PutConstant(Node: PExprNode): Integer;
+ function GetFieldByName(Name: string) : TField;
+ public
+ constructor Create(DataSet: TDataSet; Options: TFilterOptions;
+ ParseOptions: TParserOptions; const FieldName: string; DepFields: TBits;
+ FieldMap: TFieldMap);
+ destructor Destroy; override;
+ function NewCompareNode(Field: TField; Operator: TCANOperator;
+ const Value: Variant): PExprNode;
+ function NewNode(Kind: TExprNodeKind; Operator: TCANOperator;
+ const Data: Variant; Left, Right: PExprNode): PExprNode;
+ function GetFilterData(Root: PExprNode): TExprData;
+ property DataSet: TDataSet write FDataSet;
+ end;
+
+{ TExprParser }
+
+ TExprToken = (etEnd, etSymbol, etName, etLiteral, etLParen, etRParen,
+ etEQ, etNE, etGE, etLE, etGT, etLT, etADD, etSUB, etMUL, etDIV,
+ etComma, etLIKE, etISNULL, etISNOTNULL, etIN);
+
+ TExprParser = class
+ private
+ FDecimalSeparator: Char;
+ FFilter: TFilterExpr;
+ FFieldMap: TFieldMap;
+ FText: string;
+ FSourcePtr: PChar;
+ FTokenPtr: PChar;
+ FTokenString: string;
+ FStrTrue: string;
+ FStrFalse: string;
+ FToken: TExprToken;
+ FPrevToken: TExprToken;
+ FFilterData: TExprData;
+ FNumericLit: Boolean;
+ FDataSize: Integer;
+ FParserOptions: TParserOptions;
+ FFieldName: string;
+ FDataSet: TDataSet;
+ FDependentFields: TBits;
+ procedure NextToken;
+ function NextTokenIsLParen : Boolean;
+ function ParseExpr: PExprNode;
+ function ParseExpr2: PExprNode;
+ function ParseExpr3: PExprNode;
+ function ParseExpr4: PExprNode;
+ function ParseExpr5: PExprNode;
+ function ParseExpr6: PExprNode;
+ function ParseExpr7: PExprNode;
+ function TokenName: string;
+ function TokenSymbolIs(const S: string): Boolean;
+ function TokenSymbolIsFunc(const S: string) : Boolean;
+ procedure GetFuncResultInfo(Node: PExprNode);
+ procedure TypeCheckArithOp(Node: PExprNode);
+ procedure GetScopeKind(Root, Left, Right : PExprNode);
+ public
+ constructor Create(DataSet: TDataSet; const Text: string;
+ Options: TFilterOptions; ParserOptions: TParserOptions;
+ const FieldName: string; DepFields: TBits; FieldMap: TFieldMap);
+ destructor Destroy; override;
+ procedure SetExprParams(const Text: string; Options: TFilterOptions;
+ ParserOptions: TParserOptions; const FieldName: string);
+ property FilterData: TExprData read FFilterData;
+ property DataSize: Integer read FDataSize;
+ end;
+
+{ Field Origin parser }
+{Soner: Don't used in FlashFiler or in interface part
+type
+ TFieldInfo = record
+ DatabaseName: string;
+ TableName: string;
+ OriginalFieldName: string;
+ end;
+
+function GetFieldInfo(const Origin: string; var FieldInfo: TFieldInfo): Boolean;
+}
+{ SQL Parser }
+ {Soner: Don't used in FlashFiler or in interface part
+type
+ TSQLToken = (stUnknown, stTableName, stFieldName, stAscending, stDescending, stSelect,
+ stFrom, stWhere, stGroupBy, stHaving, stUnion, stPlan, stOrderBy, stForUpdate,
+ stEnd, stPredicate, stValue, stIsNull, stIsNotNull, stLike, stAnd, stOr,
+ stNumber, stAllFields, stComment, stDistinct);
+const
+ SQLSections = [stSelect, stFrom, stWhere, stGroupBy, stHaving, stUnion,
+ stPlan, stOrderBy, stForUpdate];
+
+
+function NextSQLToken(var p: PChar; out Token: string; CurSection: TSQLToken): TSQLToken;
+function GetIndexForOrderBy(const SQL: string; DataSet: TDataSet): TIndexDef;
+function GetTableNameFromSQL(const SQL: string): string;
+function GetTableNameFromQuery(const SQL: string): string;
+function AddParamSQLForDetail(Params: TParams; SQL: string; Native: Boolean; QuoteChar: string = ''): string;
+function IsMultiTableQuery(const SQL: string): Boolean;
+}
+implementation
+
+uses SysUtils, dbconst, FMTBcd;
+
+//soner this was in interface part .............
+const
+ CANEXPRSIZE = 10; { SizeOf(CANExpr) }
+ CANHDRSIZE = 8; { SizeOf(CANHdr) }
+ CANEXPRVERSION = 2;
+
+type
+ TFieldInfo = record
+ DatabaseName: string;
+ TableName: string;
+ OriginalFieldName: string;
+ end;
+
+ TSQLToken = (stUnknown, stTableName, stFieldName, stAscending, stDescending, stSelect,
+ stFrom, stWhere, stGroupBy, stHaving, stUnion, stPlan, stOrderBy, stForUpdate,
+ stEnd, stPredicate, stValue, stIsNull, stIsNotNull, stLike, stAnd, stOr,
+ stNumber, stAllFields, stComment, stDistinct);
+const
+ SQLSections = [stSelect, stFrom, stWhere, stGroupBy, stHaving, stUnion,
+ stPlan, stOrderBy, stForUpdate];
+// .................... end of soner this was in interface part .............
+
+//FROM Delphi/DBConsts.pas ================================
+resourcestring
+SExprTermination = 'Filterausdruck fehlerhaft abgeschlossen';
+SExprNameError = 'Nicht begrenzter Feldname';
+SExprStringError = 'Nicht begrenzte String-Konstante';
+SExprInvalidChar = 'Ungültiges Zeichen in Filterausdruck: ''%s''';
+SExprNoLParen = '''('' erwartet, aber %s vorgefunden';
+SExprNoRParen = ''')'' erwartet, jedoch %s vorgefunden';
+SExprNoRParenOrComma = ''')'' oder '','' erwartet, jedoch %s vorgefunden';
+SExprExpected = 'Ausdruck erwartet, jedoch %s vorgefunden';
+SExprBadField = 'Feld ''%s'' kann nicht in einem Filterausdruck verwendet werden';
+SExprBadNullTest = 'NULL ist nur mit ''='' und ''<>'' erlaubt';
+SExprRangeError = 'Konstante außerhalb des zulässigen Wertebereichs';
+SExprNotBoolean = 'Feld ''%s'' ist kein boolescher Typ';
+SExprIncorrect = 'Ungültiger Filterausdruck';
+SExprNothing = 'leer';
+SExprTypeMis = 'Fehlende Typübereinstimmung im Ausdruck';
+SExprBadScope = 'Die Operation kann keine Zusammenfassungswerte mit Datensatzwerten mischen';
+SExprNoArith = 'Arithmetische Filterausdrücke werden nicht unterstützt';
+SExprNotAgg = 'Der Ausdruck ist kein Aggregat-Ausdruck';
+SExprBadConst = 'Die Konstante ist nicht vom richtigen Typ %s';
+SExprNoAggFilter = 'In Filtern sind keine Aggregationsausdrücke erlaubt';
+SExprEmptyInList = 'Die IN-Liste darf nicht leer bleiben';
+SExprNoAggOnCalcs = 'Feld ''%s'' ist nicht der korrekte Typ eines berechneten Feldes für eine Aggregierung; verwenden Sie internalcalc';
+SInvalidKeywordUse = 'Ungültige Verwendung eines Schlüsselworts';
+STextFalse = 'Falsch';
+STextTrue = 'Wahr';
+//END FROM DBConsts.pas ================================
+
+{ SQL Parser }
+
+function NextSQLToken(var p: PChar; out Token: string; CurSection: TSQLToken): TSQLToken;
+var
+ DotStart: Boolean;
+
+ function NextTokenIs(Value: string; var Str: string): Boolean;
+ var
+ Tmp: PChar;
+ S: string;
+ begin
+ Tmp := p;
+ NextSQLToken(Tmp, S, CurSection);
+ Result := AnsiCompareText(Value, S) = 0;
+ if Result then
+ begin
+ Str := Str + ' ' + S;
+ p := Tmp;
+ end;
+ end;
+
+ function GetSQLToken(var Str: string): TSQLToken;
+ var
+ l: PChar;
+ s: string;
+ begin
+ if Length(Str) = 0 then
+ Result := stEnd else
+ if (Str = '*') and (CurSection = stSelect) then
+ Result := stAllFields else
+ if DotStart then
+ Result := stFieldName else
+ if (AnsiCompareText('DISTINCT', Str) = 0) and (CurSection = stSelect) then
+ Result := stDistinct else
+ if (AnsiCompareText('ASC', Str) = 0) or (AnsiCompareText('ASCENDING', Str) = 0)then
+ Result := stAscending else
+ if (AnsiCompareText('DESC', Str) = 0) or (AnsiCompareText('DESCENDING', Str) = 0)then
+ Result := stDescending else
+ if AnsiCompareText('SELECT', Str) = 0 then
+ Result := stSelect else
+ if AnsiCompareText('AND', Str) = 0 then
+ Result := stAnd else
+ if AnsiCompareText('OR', Str) = 0 then
+ Result := stOr else
+ if AnsiCompareText('LIKE', Str) = 0 then
+ Result := stLike else
+ if (AnsiCompareText('IS', Str) = 0) then
+ begin
+ if NextTokenIs('NULL', Str) then
+ Result := stIsNull else
+ begin
+ l := p;
+ s := Str;
+ if NextTokenIs('NOT', Str) and NextTokenIs('NULL', Str) then
+ Result := stIsNotNull else
+ begin
+ p := l;
+ Str := s;
+ Result := stValue;
+ end;
+ end;
+ end else
+ if AnsiCompareText('FROM', Str) = 0 then
+ Result := stFrom else
+ if AnsiCompareText('WHERE', Str) = 0 then
+ Result := stWhere else
+ if (AnsiCompareText('GROUP', Str) = 0) and NextTokenIs('BY', Str) then
+ Result := stGroupBy else
+ if AnsiCompareText('HAVING', Str) = 0 then
+ Result := stHaving else
+ if AnsiCompareText('UNION', Str) = 0 then
+ Result := stUnion else
+ if AnsiCompareText('PLAN', Str) = 0 then
+ Result := stPlan else
+ if (AnsiCompareText('FOR', Str) = 0) and NextTokenIs('UPDATE', Str) then
+ Result := stForUpdate else
+ if (AnsiCompareText('ORDER', Str) = 0) and NextTokenIs('BY', Str) then
+ Result := stOrderBy else
+ if AnsiCompareText('NULL', Str) = 0 then
+ Result := stValue else
+ if CurSection = stFrom then
+ Result := stTableName else
+ Result := stFieldName;
+ end;
+
+var
+ TokenStart: PChar;
+
+ procedure StartToken;
+ begin
+ if not Assigned(TokenStart) then
+ TokenStart := p;
+ end;
+
+var
+ Literal: Char;
+ Mark: PChar;
+begin
+ TokenStart := nil;
+ DotStart := False;
+ while True do
+ begin
+ case p^ of
+ '"','''','`':
+ begin
+ StartToken;
+ Literal := p^;
+ Mark := p;
+ repeat Inc(p) until (p^ in [Literal,#0]);
+ if p^ = #0 then
+ begin
+ p := Mark;
+ Inc(p);
+ end else
+ begin
+ Inc(p);
+ SetString(Token, TokenStart, p - TokenStart);
+ Mark := PChar(Token);
+ Token := AnsiExtractQuotedStr(Mark, Literal);
+ if DotStart then
+ Result := stFieldName else
+ if p^ = '.' then
+ Result := stTableName else
+ Result := stValue;
+ Exit;
+ end;
+ end;
+ '/':
+ begin
+ StartToken;
+ Inc(p);
+ if p^ in ['/','*'] then
+ begin
+ if p^ = '*' then
+ begin
+ repeat Inc(p) until (p = #0) or ((p^ = '*') and (p[1] = '/'));
+ end else
+ while not (p^ in [#0, #10, #13]) do Inc(p);
+ SetString(Token, TokenStart, p - TokenStart);
+ Result := stComment;
+ Exit;
+ end;
+ end;
+ ' ', #10, #13, ',', '(':
+ begin
+ if Assigned(TokenStart) then
+ begin
+ SetString(Token, TokenStart, p - TokenStart);
+ Result := GetSQLToken(Token);
+ Exit;
+ end else
+ while (p^ in [' ', #10, #13, ',', '(']) do Inc(p);
+ end;
+ '.':
+ begin
+ if Assigned(TokenStart) then
+ begin
+ SetString(Token, TokenStart, p - TokenStart);
+ Result := stTableName;
+ Exit;
+ end else
+ begin
+ DotStart := True;
+ Inc(p);
+ end;
+ end;
+ '=','<','>':
+ begin
+ if not Assigned(TokenStart) then
+ begin
+ TokenStart := p;
+ while p^ in ['=','<','>'] do Inc(p);
+ SetString(Token, TokenStart, p - TokenStart);
+ Result := stPredicate;
+ Exit;
+ end;
+ Inc(p);
+ end;
+ '0'..'9':
+ begin
+ if not Assigned(TokenStart) then
+ begin
+ TokenStart := p;
+ while p^ in ['0'..'9','.'] do Inc(p);
+ SetString(Token, TokenStart, p - TokenStart);
+ Result := stNumber;
+ Exit;
+ end else
+ Inc(p);
+ end;
+ #0:
+ begin
+ if Assigned(TokenStart) then
+ begin
+ SetString(Token, TokenStart, p - TokenStart);
+ Result := GetSQLToken(Token);
+ Exit;
+ end else
+ begin
+ Result := stEnd;
+ Token := '';
+ Exit;
+ end;
+ end;
+ else
+ StartToken;
+ Inc(p);
+ end;
+ end;
+end;
+
+function AddParamSQLForDetail(Params: TParams; SQL: string; Native: Boolean; QuoteChar: string = ''): string;
+const
+ SWhere = ' where '; { do not localize }
+ SAnd = ' and '; { do not localize }
+
+ function GenerateParamSQL: string;
+ var
+ I: Integer;
+ ParamName: string;
+ begin
+ for I := 0 to Params.Count -1 do
+ begin
+ if QuoteChar = '"' then
+ ParamName := '"' + StringReplace(Params[I].Name, '"', '""', [rfReplaceAll] ) + '"'
+ else
+ ParamName := QuoteChar + Params[I].Name +QuoteChar;
+ if I > 0 then Result := Result + SAnd;
+ if Native then
+ Result := Result + format('%s = ?', [ParamName])
+ else
+ Result := Result + format('%s = :%s', [ParamName, ParamName]);
+ end;
+ if pos(SWhere, LowerCase(Result)) > 0 then
+ Result := SAnd + Result
+ else
+ Result := SWhere + Result;
+ end;
+
+ function AddWhereClause: string;
+ var
+ Start: PChar;
+ Rest, FName: string;
+ SQLToken, CurSection: TSQLToken;
+ begin
+ Start := PChar(SQL);
+ CurSection := stUnknown;
+ repeat
+ SQLToken := NextSQLToken(Start, FName, CurSection);
+ until SQLToken in [stFrom, stEnd];
+ if SQLToken = stFrom then
+ NextSQLToken(Start, FName, CurSection);
+ Rest := string(Start);
+ if Rest = '' then
+ Result := SQL + ' ' + GenerateParamSQL
+ else
+ Result := Copy(SQL, 1, pos(Rest, SQL)) + ' ' + GenerateParamSQL + Rest;
+ end;
+
+begin
+ Result := SQL;
+ if (Params.Count > 0) then
+ Result := AddWhereClause;
+end;
+
+
+function GetTableNameFromSQL(const SQL: string): string;
+var
+ Start: PChar;
+ Token: string;
+ SQLToken, CurSection: TSQLToken;
+begin
+ Result := '';
+ Start := PChar(SQL);
+ CurSection := stUnknown;
+ repeat
+ SQLToken := NextSQLToken(Start, Token, CurSection);
+ if SQLToken in SQLSections then CurSection := SQLToken;
+ until SQLToken in [stEnd, stFrom];
+ if SQLToken = stFrom then
+ begin
+ repeat
+ SQLToken := NextSQLToken(Start, Token, CurSection);
+ if SQLToken in SQLSections then
+ CurSection := SQLToken else
+ // stValue is returned if TableNames contain quote chars.
+ if (SQLToken = stTableName) or (SQLToken = stValue) then
+ begin
+ Result := Token;
+ while (Start[0] = '.') and not (SQLToken in [stEnd]) do
+ begin
+ SQLToken := NextSqlToken(Start, Token, CurSection);
+ Result := Result + '.' + Token;
+ end;
+ Exit;
+ end;
+ until (CurSection <> stFrom) or (SQLToken in [stEnd, stTableName]);
+ end;
+end;
+
+// SQL might be a direct tablename;
+function GetTableNameFromQuery(const SQL: string): string;
+begin
+ if pos( 'select', lowercase(SQL) ) < 1 then
+ Result := SQL
+ else
+ Result := GetTableNameFromSQL(SQL);
+end;
+
+function IsMultiTableQuery(const SQL: string): Boolean;
+const
+ SInnerJoin = 'inner join '; { do not localize }
+ SOuterJoin = 'outer join '; { do not localize }
+var
+ Start: PChar;
+ SResult, Token: string;
+ SQLToken, CurSection: TSQLToken;
+begin
+ SResult := '';
+ Start := PChar(SQL);
+ CurSection := stUnknown;
+ Result := True;
+ repeat
+ SQLToken := NextSQLToken(Start, Token, CurSection);
+ if SQLToken in SQLSections then CurSection := SQLToken;
+ until SQLToken in [stEnd, stFrom];
+ if SQLToken = stFrom then
+ begin
+ repeat
+ SQLToken := NextSQLToken(Start, Token, CurSection);
+ if SQLToken in SQLSections then
+ CurSection := SQLToken else
+ // stValue is returned if TableNames contain quote chars.
+ if (SQLToken = stTableName) or (SQLToken = stValue) then
+ begin
+ SResult := Token;
+ while (Start[0] = '.') and not (SQLToken in [stEnd]) do
+ begin
+ SQLToken := NextSqlToken(Start, Token, CurSection);
+ SResult := SResult + '.' + Token;
+ end;
+ if (Start[0] = ',') or (Start[1] = ',') then
+ exit;
+ NextSqlToken(Start, Token, CurSection);
+ if Assigned(AnsiStrPos(Start, PChar(SInnerJoin))) or
+ Assigned(AnsiStrPos(Start, PChar(SOuterJoin))) then
+ Exit;
+ SQLToken := NextSqlToken(Start, Token, CurSection);
+ if SQLToken = stTableName then
+ Exit;
+ Result := False;
+ Exit;
+ end;
+ until (CurSection <> stFrom) or (SQLToken in [stEnd, stTableName]);
+ end;
+end;
+
+function GetIndexForOrderBy(const SQL: string; DataSet: TDataSet): TIndexDef;
+
+ function AddField(const Fields, NewField: string): string;
+ begin
+ Result := Fields;
+ if Fields <> '' then
+ Result := Fields + ';' + NewField else
+ Result := NewField;
+ end;
+
+var
+ Start: PChar;
+ Token, LastField, SaveField: string;
+ SQLToken, CurSection: TSQLToken;
+ FieldIndex: Integer;
+begin
+ Result := nil;
+ Start := PChar(SQL);
+ CurSection := stUnknown;
+ repeat
+ SQLToken := NextSQLToken(Start, Token, CurSection);
+ if SQLToken in SQLSections then CurSection := SQLToken;
+ until SQLToken in [stEnd, stOrderBy];
+ if SQLToken = stOrderBy then
+ begin
+ Result := TIndexDef.Create(nil);
+ try
+ LastField := '';
+ repeat
+ SQLToken := NextSQLToken(Start, Token, CurSection);
+ if SQLToken in SQLSections then
+ CurSection := SQLToken else
+ case SQLToken of
+ stTableName: ;
+ stFieldName:
+ begin
+ LastField := Token;
+ { Verify that we parsed a valid field name, not something like "UPPER(Foo)" }
+ if not Assigned(Dataset.FindField(LastField)) then continue;
+ Result.Fields := AddField(Result.Fields, LastField);
+ SaveField := LastField;
+ end;
+ stAscending: ;
+ stDescending:
+ Result.DescFields := AddField(Result.DescFields, SaveField);
+ stNumber:
+ begin
+ FieldIndex := StrToInt(Token);
+ if DataSet.FieldCount >= FieldIndex then
+ LastField := DataSet.Fields[FieldIndex - 1].FieldName else
+ if DataSet.FieldDefs.Count >= FieldIndex then
+ LastField := DataSet.FieldDefs[FieldIndex - 1].Name
+ else
+ { DB2 specific syntax "FETCH FIRST n ROWS ONLY" is blocked here,
+ so commenting out the following line }
+ //SysUtils.Abort;
+ continue;
+ Result.Fields := AddField(Result.Fields, LastField);
+ end;
+ end;
+ until (CurSection <> stOrderBy) or (SQLToken = stEnd);
+ finally
+ if Result.Fields = '' then
+ begin
+ Result.Free;
+ Result := nil;
+ end;
+ end;
+ end;
+end;
+
+function GetFieldInfo(const Origin: string; var FieldInfo: TFieldInfo): Boolean;
+var
+ Current: PChar;
+ Values: array[0..4] of string;
+ I: Integer;
+
+ function GetPChar(const S: string): PChar;
+ begin
+ if S <> '' then Result := PChar(Pointer(S)) else Result := '';
+ end;
+
+ procedure Split(const S: string);
+ begin
+ Current := PChar(Pointer(S));
+ end;
+
+ function NextItem: string;
+ var
+ C: PChar;
+ I: PChar;
+ Terminator: Char;
+ Ident: array[0..1023] of Char;
+ begin
+ Result := '';
+ C := Current;
+ I := Ident;
+ while C^ in ['.',' ',#0] do
+ if C^ = #0 then Exit else Inc(C);
+ Terminator := '.';
+ if C^ = '"' then
+ begin
+ Terminator := '"';
+ Inc(C);
+ end;
+ while not (C^ in [Terminator, #0]) do
+ begin
+ if C^ in LeadBytes then
+ begin
+ I^ := C^;
+ Inc(C);
+ Inc(I);
+ end
+ else if C^ = '\' then
+ begin
+ Inc(C);
+ if C^ in LeadBytes then
+ begin
+ I^ := C^;
+ Inc(C);
+ Inc(I);
+ end;
+ if C^ = #0 then Dec(C);
+ end;
+ I^ := C^;
+ Inc(C);
+ Inc(I);
+ end;
+ SetString(Result, Ident, I - Ident);
+ if (Terminator = '"') and (C^ <> #0) then Inc(C);
+ Current := C;
+ end;
+
+ function PopValue: PChar;
+ begin
+ if I >= 0 then
+ begin
+ Result := GetPChar(Values[I]);
+ Dec(I);
+ end else Result := '';
+ end;
+
+begin
+ Result := False;
+ if (Origin = '') then Exit;
+ Split(Origin);
+ I := -1;
+ repeat
+ Inc(I);
+ Values[I] := NextItem;
+ until (Values[I] = '') or (I = High(Values));
+ if I = High(Values) then Exit;
+ Dec(I);
+ FieldInfo.OriginalFieldName := StrPas(PopValue);
+ FieldInfo.TableName := StrPas(PopValue);
+ FieldInfo.DatabaseName := StrPas(PopValue);
+ Result := (FieldInfo.OriginalFieldName <> '') and (FieldInfo.TableName <> '');
+end;
+
+const
+ StringFieldTypes = [ftString, ftFixedChar, ftWideString, ftGuid];
+ BlobFieldTypes = [ftBlob, ftMemo, ftGraphic, ftFmtMemo, ftParadoxOle, ftDBaseOle,
+ ftTypedBinary, ftOraBlob, ftOraClob];
+
+function IsNumeric(DataType: TFieldType): Boolean;
+begin
+ Result := DataType in [ftSmallint, ftInteger, ftWord, ftFloat, ftCurrency,
+ ftBCD, ftAutoInc, ftLargeint, ftFMTBcd];
+end;
+
+function IsTemporal(DataType: TFieldType): Boolean;
+begin
+ Result := DataType in [ftDate, ftTime, ftDateTime, ftTimeStamp];
+end;
+
+{ TFilterExpr }
+
+constructor TFilterExpr.Create(DataSet: TDataSet; Options: TFilterOptions;
+ ParseOptions: TParserOptions; const FieldName: string; DepFields: TBits;
+ FieldMap: TFieldMap);
+begin
+ FFieldMap := FieldMap;
+ FDataSet := DataSet;
+ FOptions := Options;
+ FFieldName := FieldName;
+ FParserOptions := ParseOptions;
+ FDependentFields := DepFields;
+end;
+
+destructor TFilterExpr.Destroy;
+var
+ Node: PExprNode;
+begin
+ SetLength(FExprBuffer, 0);
+ while FNodes <> nil do
+ begin
+ Node := FNodes;
+ FNodes := Node^.FNext;
+ if (Node^.FKind = enFunc) and (Node^.FArgs <> nil) then
+ Node^.FArgs.Free;
+ Dispose(Node);
+ end;
+end;
+
+function TFilterExpr.FieldFromNode(Node: PExprNode): TField;
+begin
+ Result := GetFieldByName(Node^.FData);
+ if not (Result.FieldKind in [fkData, fkInternalCalc]) then
+ DatabaseErrorFmt(SExprBadField, [Result.FieldName]);
+end;
+
+function TFilterExpr.GetExprData(Pos, Size: Integer): PChar;
+begin
+ SetLength(FExprBuffer, FExprBufSize + Size);
+ Move(FExprBuffer[Pos], FExprBuffer[Pos + Size], FExprBufSize - Pos);
+ Inc(FExprBufSize, Size);
+ Result := PChar(FExprBuffer) + Pos;
+end;
+
+function TFilterExpr.GetFilterData(Root: PExprNode): TExprData;
+begin
+ FExprBufSize := CANExprSize;
+ SetLength(FExprBuffer, FExprBufSize);
+ PutExprNode(Root, coNOTDEFINED);
+ PWord(@FExprBuffer[0])^ := CANEXPRVERSION; { iVer }
+ PWord(@FExprBuffer[2])^ := FExprBufSize; { iTotalSize }
+ PWord(@FExprBuffer[4])^ := $FFFF; { iNodes }
+ PWord(@FExprBuffer[6])^ := CANEXPRSIZE; { iNodeStart }
+ PWord(@FExprBuffer[8])^ := FExprNodeSize + CANEXPRSIZE; { iLiteralStart }
+ Result := FExprBuffer;
+end;
+
+function TFilterExpr.NewCompareNode(Field: TField; Operator: TCANOperator;
+ const Value: Variant): PExprNode;
+var
+ ConstExpr: PExprNode;
+begin
+ ConstExpr := NewNode(enConst, coNOTDEFINED, Value, nil, nil);
+ ConstExpr^.FDataType := Field.DataType;
+ ConstExpr^.FDataSize := Field.Size;
+ Result := NewNode(enOperator, Operator, Unassigned,
+ NewNode(enField, coNOTDEFINED, Field.FieldName, nil, nil), ConstExpr);
+end;
+
+function TFilterExpr.NewNode(Kind: TExprNodeKind; Operator: TCANOperator;
+ const Data: Variant; Left, Right: PExprNode): PExprNode;
+var
+ Field : TField;
+begin
+ New(Result);
+ with Result^ do
+ begin
+ FNext := FNodes;
+ FKind := Kind;
+ FPartial := False;
+ FOperator := Operator;
+ FData := Data;
+ FLeft := Left;
+ FRight := Right;
+ end;
+ FNodes := Result;
+ if Kind = enField then
+ begin
+ Field := GetFieldByName(Data);
+ if Field = nil then
+ DatabaseErrorFmt(SFieldNotFound, [Data]);
+ Result^.FDataType := Field.DataType;
+ Result^.FDataSize := Field.Size;
+ end;
+end;
+
+function TFilterExpr.PutConstBCD(const Value: Variant;
+ Decimals: Integer): Integer;
+var
+ C: Currency;
+ BCD: TBcd;
+begin
+ if VarType(Value) = varString then
+ C := StrToCurr(string(TVarData(Value).VString)) else
+ C := Value;
+ CurrToBCD(C, BCD, 32, Decimals);
+ Result := PutConstNode(ftBCD, @BCD, 18);
+end;
+
+function TFilterExpr.PutConstFMTBCD(const Value: Variant;
+ Decimals: Integer): Integer;
+var
+ BCD: TBcd;
+begin
+ if VarType(Value) = varString then
+ BCD := StrToBcd(string(TVarData(Value).VString)) else
+ BCD := VarToBcd(Value);
+ Result := PutConstNode(ftBCD, @BCD, 18);
+end;
+
+function TFilterExpr.PutConstBool(const Value: Variant): Integer;
+var
+ B: WordBool;
+begin
+ B := Value;
+ Result := PutConstNode(ftBoolean, @B, SizeOf(WordBool));
+end;
+
+function TFilterExpr.PutConstDate(const Value: Variant): Integer;
+var
+ DateTime: TDateTime;
+ TimeStamp: TTimeStamp;
+begin
+ if VarType(Value) = varString then
+ DateTime := StrToDate(string(TVarData(Value).VString)) else
+ DateTime := VarToDateTime(Value);
+ TimeStamp := DateTimeToTimeStamp(DateTime);
+ Result := PutConstNode(ftDate, @TimeStamp.Date, 4);
+end;
+
+function TFilterExpr.PutConstDateTime(const Value: Variant): Integer;
+var
+ DateTime: TDateTime;
+ DateData: Double;
+begin
+ if VarType(Value) = varString then
+ DateTime := StrToDateTime(string(TVarData(Value).VString)) else
+ DateTime := VarToDateTime(Value);
+ DateData := TimeStampToMSecs(DateTimeToTimeStamp(DateTime));
+ Result := PutConstNode(ftDateTime, @DateData, 8);
+end;
+
+function TFilterExpr.PutConstSQLTimeStamp(const Value: Variant): Integer;
+var
+ TimeStamp: TSQLTimeStamp;
+begin
+ if VarType(Value) = varString then
+ TimeStamp := StrToSQLTimeStamp(string(TVarData(Value).VString)) else
+ TimeStamp := VarToSQLTimeStamp(Value);
+ Result := PutConstNode(ftTimeStamp, @TimeStamp, 16);
+end;
+
+function TFilterExpr.PutConstFloat(const Value: Variant): Integer;
+var
+ F: Double;
+begin
+ if VarType(Value) = varString then
+ F := StrToFloat(string(TVarData(Value).VString)) else
+ F := Value;
+ Result := PutConstNode(ftFloat, @F, SizeOf(Double));
+end;
+
+function TFilterExpr.PutConstInt(DataType: TFieldType;
+ const Value: Variant): Integer;
+var
+ I, Size: Integer;
+begin
+ if VarType(Value) = varString then
+ I := StrToInt(string(TVarData(Value).VString)) else
+ I := Value;
+ Size := 2;
+ case DataType of
+ ftSmallint:
+ if (I < -32768) or (I > 32767) then DatabaseError(SExprRangeError);
+ ftWord:
+ if (I < 0) or (I > 65535) then DatabaseError(SExprRangeError);
+ else
+ Size := 4;
+ end;
+ Result := PutConstNode(DataType, @I, Size);
+end;
+
+function TFilterExpr.PutConstNode(DataType: TFieldType; Data: PChar;
+ Size: Integer): Integer;
+begin
+ Result := PutNode(nodeCONST, coCONST2, 3);
+ SetNodeOp(Result, 0, FFieldMap[DataType]);
+ SetNodeOp(Result, 1, Size);
+ SetNodeOp(Result, 2, PutData(Data, Size));
+end;
+
+function TFilterExpr.PutConstStr(const Value: string): Integer;
+var
+ Str: string;
+ Buffer: array[0..255] of Char;
+begin
+ if Length(Value) >= SizeOf(Buffer) then
+ Str := Copy(Value, 1, SizeOf(Buffer) - 1) else
+ Str := Value;
+ FDataSet.Translate(PChar(Str), Buffer, True);
+ Result := PutConstNode(ftString, Buffer, Length(Str) + 1);
+end;
+
+function TFilterExpr.PutConstTime(const Value: Variant): Integer;
+var
+ DateTime: TDateTime;
+ TimeStamp: TTimeStamp;
+begin
+ if VarType(Value) = varString then
+ DateTime := StrToTime(string(TVarData(Value).VString)) else
+ DateTime := VarToDateTime(Value);
+ TimeStamp := DateTimeToTimeStamp(DateTime);
+ Result := PutConstNode(ftTime, @TimeStamp.Time, 4);
+end;
+
+function TFilterExpr.PutData(Data: PChar; Size: Integer): Integer;
+begin
+ Move(Data^, GetExprData(FExprBufSize, Size)^, Size);
+ Result := FExprDataSize;
+ Inc(FExprDataSize, Size);
+end;
+
+function TFilterExpr.PutConstant(Node: PExprNode): Integer;
+begin
+ Result := 0;
+ case Node^.FDataType of
+ ftSmallInt, ftInteger, ftWord, ftAutoInc:
+ Result := PutConstInt(Node^.FDataType, Node^.FData);
+ ftFloat, ftCurrency:
+ Result := PutConstFloat(Node^.FData);
+ ftString, ftWideString, ftFixedChar, ftGuid:
+ {$ifdef fpc}
+ if VarIsArray(Node^.FData) then //soner solves : "Invalid Variant Type Cast":
+ Result := PutConstStr(Node^.FData[0])
+ else
+ {$endif}
+ Result := PutConstStr(Node^.FData);
+ ftDate:
+ Result := PutConstDate(Node^.FData);
+ ftTime:
+ Result := PutConstTime(Node^.FData);
+ ftDateTime:
+ Result := PutConstDateTime(Node^.FData);
+ ftTimeStamp:
+ Result := PutConstSQLTimeStamp(Node^.FData);
+ ftBoolean:
+ Result := PutConstBool(Node^.FData);
+ ftBCD:
+ Result := PutConstBCD(Node^.FData, Node^.FDataSize);
+ ftFMTBcd:
+ Result := PutConstFMTBCD(Node^.FData, Node^.FDataSize);
+ else
+ DatabaseErrorFmt(SExprBadConst, [Node^.FData]);
+ end;
+end;
+
+function TFilterExpr.PutExprNode(Node: PExprNode; ParentOp: TCANOperator): Integer;
+const
+ ReverseOperator: array[coEQ..coLE] of TCANOperator = (coEQ, coNE, coLT,
+ coGT, coLE, coGE);
+ BoolFalse: WordBool = False;
+var
+ Field: TField;
+ Left, Right, Temp : PExprNode;
+ LeftPos, RightPos, ListElem, PrevListElem, I: Integer;
+ Operator: TCANOperator;
+ CaseInsensitive, PartialLength, L: Integer;
+ S: string;
+begin
+ Result := 0;
+ case Node^.FKind of
+ enField:
+ begin
+ Field := FieldFromNode(Node);
+ if (ParentOp in [coOR, coNOT, coAND, coNOTDEFINED]) and
+ (Field.DataType = ftBoolean) then
+ begin
+ Result := PutNode(nodeBINARY, coNE, 2);
+ SetNodeOp(Result, 0, PutFieldNode(Field, Node));
+ SetNodeOp(Result, 1, PutConstNode(ftBoolean, @BoolFalse, SizeOf(WordBool)));
+ end
+ else
+ Result := PutFieldNode(Field, Node);
+ end;
+ enConst:
+ Result := PutConstant(Node);
+ enOperator:
+ case Node^.FOperator of
+ coIN:
+ begin
+ Result := PutNode(nodeBINARY, coIN, 2);
+ SetNodeOp(Result, 0, PutExprNode(Node^.FLeft,Node^.FOperator));
+ ListElem := PutNode(nodeLISTELEM, coLISTELEM2, 2);
+ SetNodeOp(Result, 1, ListElem);
+ PrevListElem := ListElem;
+ for I := 0 to Node^.FArgs.Count - 1 do
+ begin
+ LeftPos := PutExprNode(Node^.FArgs.Items[I],Node^.FOperator);
+ if I = 0 then
+ begin
+ SetNodeOp(PrevListElem, 0, LeftPos);
+ SetNodeOp(PrevListElem, 1, 0);
+ end
+ else
+ begin
+ ListElem := PutNode(nodeLISTELEM, coLISTELEM2, 2);
+ SetNodeOp(ListElem, 0, LeftPos);
+ SetNodeOp(ListElem, 1, 0);
+ SetNodeOp(PrevListElem, 1, ListElem);
+ PrevListElem := ListElem;
+ end;
+ end;
+ end;
+ coNOT,
+ coISBLANK,
+ coNOTBLANK:
+ begin
+ Result := PutNode(nodeUNARY, Node^.FOperator, 1);
+ SetNodeOp(Result, 0, PutExprNode(Node^.FLeft,Node^.FOperator));
+ end;
+ coEQ..coLE,
+ coAND,coOR,
+ coADD..coDIV,
+ coLIKE,
+ coASSIGN:
+ begin
+ Operator := Node^.FOperator;
+ Left := Node^.FLeft;
+ Right := Node^.FRight;
+ if (Operator in [coEQ..coLE]) and (Right^.FKind = enField) and
+ (Left^.FKind <> enField) then
+ begin
+ Temp := Left;
+ Left := Right;
+ Right := Temp;
+ Operator := ReverseOperator[Operator];
+ end;
+
+ Result := 0;
+ if (Left^.FKind = enField) and (Right^.FKind = enConst)
+ and ((Node^.FOperator = coEQ) or (Node^.FOperator = coNE)
+ or (Node^.FOperator = coLIKE)) then
+ begin
+ if VarIsNull(Right^.FData) then
+ begin
+ case Node^.FOperator of
+ coEQ: Operator := coISBLANK;
+ coNE: Operator := coNOTBLANK;
+ else
+ DatabaseError(SExprBadNullTest);
+ end;
+ Result := PutNode(nodeUNARY, Operator, 1);
+ SetNodeOp(Result, 0, PutExprNode(Left,Node^.FOperator));
+ end
+ else if (Right^.FDataType in StringFieldTypes) then
+ begin
+ {$ifdef fpc}
+ if VarIsArray(Right^.FData) then //soner solves : "Invalid Variant Type Cast":
+ s:=Right^.FData[0]
+ else
+ {$endif}
+ S := Right^.FData; //soner this dont work, i get "Invalid Variant Type Cast": VarToStr(Right^.FData)
+ L := Length(S);
+ if L <> 0 then
+ begin
+ CaseInsensitive := 0;
+ PartialLength := 0;
+ if foCaseInsensitive in FOptions then CaseInsensitive := 1;
+ if Node^.FPartial then PartialLength := L else
+ if not (foNoPartialCompare in FOptions) and (L > 1) and
+ (S[L] = '*') then
+ begin
+ Delete(S, L, 1);
+ PartialLength := L - 1;
+ end;
+ if (CaseInsensitive <> 0) or (PartialLength <> 0) then
+ begin
+ Result := PutNode(nodeCOMPARE, Operator, 4);
+ SetNodeOp(Result, 0, CaseInsensitive);
+ SetNodeOp(Result, 1, PartialLength);
+ SetNodeOp(Result, 2, PutExprNode(Left,Node^.FOperator));
+ SetNodeOp(Result, 3, PutConstStr(S));
+ end;
+ end;
+ end;
+ end;
+
+ if Result = 0 then
+ begin
+ if (Operator = coISBLANK) or (Operator = coNOTBLANK) then
+ begin
+ Result := PutNode(nodeUNARY, Operator, 1);
+ LeftPos := PutExprNode(Left,Node^.FOperator);
+ SetNodeOp(Result, 0, LeftPos);
+ end else
+ begin
+ Result := PutNode(nodeBINARY, Operator, 2);
+ LeftPos := PutExprNode(Left,Node^.FOperator);
+ RightPos := PutExprNode(Right,Node^.FOperator);
+ SetNodeOp(Result, 0, LeftPos);
+ SetNodeOp(Result, 1, RightPos);
+ end;
+ end;
+ end;
+ end;
+ enFunc:
+ begin
+ Result := PutNode(nodeFUNC, coFUNC2, 2);
+ SetNodeOp(Result, 0, PutData(PChar(string(Node^.FData)),
+ Length(string(Node^.FData)) + 1));
+ if Node^.FArgs <> nil then
+ begin
+ ListElem := PutNode(nodeLISTELEM, coLISTELEM2, 2);
+ SetNodeOp(Result, 1, ListElem);
+ PrevListElem := ListElem;
+ for I := 0 to Node^.FArgs.Count - 1 do
+ begin
+ LeftPos := PutExprNode(Node^.FArgs.Items[I],Node^.FOperator);
+ if I = 0 then
+ begin
+ SetNodeOp(PrevListElem, 0, LeftPos);
+ SetNodeOp(PrevListElem, 1, 0);
+ end
+ else
+ begin
+ ListElem := PutNode(nodeLISTELEM, coLISTELEM2, 2);
+ SetNodeOp(ListElem, 0, LeftPos);
+ SetNodeOp(ListElem, 1, 0);
+ SetNodeOp(PrevListElem, 1, ListElem);
+ PrevListElem := ListElem;
+ end;
+ end;
+ end else
+ SetNodeOp(Result, 1, 0);
+ end;
+ end;
+end;
+
+
+function TFilterExpr.PutFieldNode(Field: TField; Node: PExprNode): Integer;
+var
+ Buffer: array[0..255] of Char;
+begin
+ if poFieldNameGiven in FParserOptions then
+ FDataSet.Translate(PChar(Field.FieldName), Buffer, True)
+ else
+ FDataSet.Translate(PChar(string(Node^.FData)), Buffer, True);
+ Result := PutNode(nodeFIELD, coFIELD2, 2);
+ SetNodeOp(Result, 0, Field.FieldNo);
+ SetNodeOp(Result, 1, PutData(Buffer, StrLen(Buffer) + 1));
+end;
+
+function TFilterExpr.PutNode(NodeType: NodeClass; OpType: TCANOperator;
+ OpCount: Integer): Integer;
+var
+ Size: Integer;
+ Data: PChar;
+begin
+ Size := CANHDRSIZE + OpCount * SizeOf(Word);
+ Data := GetExprData(CANEXPRSIZE + FExprNodeSize, Size);
+ PInteger(@Data[0])^ := Integer(NodeType); { CANHdr.nodeClass }
+ PInteger(@Data[4])^ := Integer(OpType); { CANHdr.coOp }
+ Result := FExprNodeSize;
+ Inc(FExprNodeSize, Size);
+end;
+
+procedure TFilterExpr.SetNodeOp(Node, Index, Data: Integer);
+begin
+ PWordArray(PChar(FExprBuffer) + (CANEXPRSIZE + Node +
+ CANHDRSIZE))^[Index] := Data;
+end;
+
+function TFilterExpr.GetFieldByName(Name: string) : TField;
+var
+ I: Integer;
+ F: TField;
+ FieldInfo: TFieldInfo;
+begin
+ Result := nil;
+ if poFieldNameGiven in FParserOptions then
+ Result := FDataSet.FieldByName(FFieldName)
+ else if poUseOrigNames in FParserOptions then
+ begin
+ for I := 0 to FDataset.FieldCount - 1 do
+ begin
+ F := FDataSet.Fields[I];
+ if GetFieldInfo(F.Origin, FieldInfo) and
+ (AnsiCompareStr(Name, FieldInfo.OriginalFieldName) = 0) then
+ begin
+ Result := F;
+ Exit;
+ end;
+ end;
+ end;
+ if Result = nil then
+ Result := FDataSet.FieldByName(Name);
+ if (Result <> nil) and (Result.FieldKind = fkCalculated) and (poAggregate in FParserOptions) then
+ DatabaseErrorFmt(SExprNoAggOnCalcs, [Result.FieldName]);
+ if (poFieldDepend in FParserOptions) and (Result <> nil) and
+ (FDependentFields <> nil) then
+ FDependentFields[Result.FieldNo-1] := True;
+end;
+
+constructor TExprParser.Create(DataSet: TDataSet; const Text: string;
+ Options: TFilterOptions; ParserOptions: TParserOptions; const FieldName: string;
+ DepFields: TBits; FieldMap: TFieldMap);
+begin
+ FDecimalSeparator := DecimalSeparator;
+ FFieldMap := FieldMap;
+ FStrTrue := STextTrue;
+ FStrFalse := STextFalse;
+ FDataSet := DataSet;
+ FDependentFields := DepFields;
+ FFilter := TFilterExpr.Create(DataSet, Options, ParserOptions, FieldName,
+ DepFields, FieldMap);
+ if Text <> '' then
+ SetExprParams(Text, Options, ParserOptions, FieldName);
+end;
+
+destructor TExprParser.Destroy;
+begin
+ FFilter.Free;
+end;
+
+procedure TExprParser.SetExprParams(const Text: string; Options: TFilterOptions;
+ ParserOptions: TParserOptions; const FieldName: string);
+var
+ Root, DefField: PExprNode;
+begin
+ FParserOptions := ParserOptions;
+ if FFilter <> nil then
+ FFilter.Free;
+ FFilter := TFilterExpr.Create(FDataSet, Options, ParserOptions, FieldName,
+ FDependentFields, FFieldMap);
+ FText := Text;
+ FSourcePtr := PChar(Text);
+ FFieldName := FieldName;
+ NextToken;
+ Root := ParseExpr;
+ if FToken <> etEnd then DatabaseError(SExprTermination);
+ if (poAggregate in FParserOptions) and (Root^.FScopeKind <> skAgg) then
+ DatabaseError(SExprNotAgg);
+ if (not (poAggregate in FParserOptions)) and (Root^.FScopeKind = skAgg) then
+ DatabaseError(SExprNoAggFilter);
+ if poDefaultExpr in ParserOptions then
+ begin
+ DefField := FFilter.NewNode(enField, coNOTDEFINED, FFieldName, nil, nil);
+ if (IsTemporal(DefField^.FDataType) and (Root^.FDataType in StringFieldTypes)) or
+ ((DefField^.FDataType = ftBoolean ) and (Root^.FDataType in StringFieldTypes)) then
+ Root^.FDataType := DefField^.FDataType;
+
+ if not ((IsTemporal(DefField^.FDataType) and IsTemporal(Root^.FDataType))
+ or (IsNumeric(DefField^.FDataType) and IsNumeric(Root^.FDataType))
+ or ((DefField^.FDataType in StringFieldTypes) and (Root^.FDataType in StringFieldTypes))
+ or ((DefField^.FDataType = ftBoolean) and (Root^.FDataType = ftBoolean))) then
+ DatabaseError(SExprTypeMis);
+ Root := FFilter.NewNode(enOperator, coASSIGN, Unassigned, Root, DefField);
+ end;
+
+ if not (poAggregate in FParserOptions) and not(poDefaultExpr in ParserOptions)
+ and (Root^.FDataType <> ftBoolean ) then
+ DatabaseError(SExprIncorrect);
+
+ FFilterData := FFilter.GetFilterData(Root);
+ FDataSize := FFilter.FExprBufSize;
+end;
+
+function TExprParser.NextTokenIsLParen : Boolean;
+var
+ P : PChar;
+begin
+ P := FSourcePtr;
+ while (P^ <> #0) and (P^ <= ' ') do Inc(P);
+ Result := P^ = '(';
+end;
+
+function EndOfLiteral(var P : PChar): Boolean;
+var
+ FName: String;
+ PTemp: PChar;
+begin
+ Inc(P);
+ Result := P^ <> '''';
+ if Result then
+ begin // now, look for 'John's Horse'
+ if AnsiStrScan(P, '''') <> Nil then // found another '
+ begin
+ PTemp := P; // don't advance P
+ while PTemp[0] in [ ' ', ')' ] do Inc(PTemp);
+ if NextSQLToken(PTemp, FName, stValue) in [stFieldName, stUnknown] then
+ begin // 'John's Horse' case: not really end of literal
+ Result := False;
+ Dec(P);
+ end;
+ end;
+ end;
+end;
+
+procedure TExprParser.NextToken;
+type
+ ASet = Set of Char;
+var
+ P, TokenStart: PChar;
+ L: Integer;
+ StrBuf: array[0..255] of Char;
+
+ function IsKatakana(const Chr: Byte): Boolean;
+ begin
+{$IFDEF MSWINDOWS}
+ Result := (SysLocale.PriLangID = LANG_JAPANESE) and (Chr in [$A1..$DF]);
+{$ENDIF}
+{$IFDEF LINUX}
+ Result := False;
+{$ENDIF}
+ end;
+
+ procedure Skip(TheSet: ASet);
+ begin
+ while TRUE do
+ begin
+ if P^ in LeadBytes then
+ Inc(P, 2)
+ else if (P^ in TheSet) or IsKatakana(Byte(P^)) then
+ Inc(P)
+ else
+ Exit;
+ end;
+ end;
+
+begin
+ FPrevToken := FToken;
+ FTokenString := '';
+ P := FSourcePtr;
+ while (P^ <> #0) and (P^ <= ' ') do Inc(P);
+ if (P^ <> #0) and (P^ = '/') and (P[1] <> #0) and (P[1] = '*')then
+ begin
+ P := P + 2;
+ while (P^ <> #0) and (P^ <> '*') do Inc(P);
+ if (P^ = '*') and (P[1] <> #0) and (P[1] = '/') then
+ P := P + 2
+ else
+ DatabaseErrorFmt(SExprInvalidChar, [P^]);
+ end;
+ while (P^ <> #0) and (P^ <= ' ') do Inc(P);
+ FTokenPtr := P;
+ case P^ of
+ 'A'..'Z', 'a'..'z', '_', #$81..#$fe:
+ begin
+ TokenStart := P;
+ if not SysLocale.FarEast then
+ begin
+ Inc(P);
+ while P^ in ['A'..'Z', 'a'..'z', '0'..'9', '_', '.', '[', ']'] do Inc(P);
+ end
+ else
+ Skip(['A'..'Z', 'a'..'z', '0'..'9', '_', '.', '[', ']']);
+ SetString(FTokenString, TokenStart, P - TokenStart);
+ FToken := etSymbol;
+ if CompareText(FTokenString, 'LIKE') = 0 then { do not localize }
+ FToken := etLIKE
+ else if CompareText(FTokenString, 'IN') = 0 then { do not localize }
+ FToken := etIN
+ else if CompareText(FTokenString, 'IS') = 0 then { do not localize }
+ begin
+ while (P^ <> #0) and (P^ <= ' ') do Inc(P);
+ TokenStart := P;
+ Skip(['A'..'Z', 'a'..'z']);
+ SetString(FTokenString, TokenStart, P - TokenStart);
+ if CompareText(FTokenString, 'NOT')= 0 then { do not localize }
+ begin
+ while (P^ <> #0) and (P^ <= ' ') do Inc(P);
+ TokenStart := P;
+ Skip(['A'..'Z', 'a'..'z']);
+ SetString(FTokenString, TokenStart, P - TokenStart);
+ if CompareText(FTokenString, 'NULL') = 0 then
+ FToken := etISNOTNULL
+ else
+ DatabaseError(SInvalidKeywordUse);
+ end
+ else if CompareText (FTokenString, 'NULL') = 0 then { do not localize }
+ begin
+ FToken := etISNULL;
+ end
+ else
+ DatabaseError(SInvalidKeywordUse);
+ end;
+ end;
+ '[':
+ begin
+ Inc(P);
+ TokenStart := P;
+ P := AnsiStrScan(P, ']');
+ if P = nil then DatabaseError(SExprNameError);
+ SetString(FTokenString, TokenStart, P - TokenStart);
+ FToken := etName;
+ Inc(P);
+ end;
+ '''':
+ begin
+ Inc(P);
+ L := 0;
+ while True do
+ begin
+ if P^ = #0 then DatabaseError(SExprStringError);
+ if P^ = '''' then
+ if EndOfLiteral(P) then
+ Break;
+ if L < SizeOf(StrBuf) then
+ begin
+ StrBuf[L] := P^;
+ Inc(L);
+ end;
+ Inc(P);
+ end;
+ SetString(FTokenString, StrBuf, L);
+ FToken := etLiteral;
+ FNumericLit := False;
+ end;
+ '-', '0'..'9':
+ begin
+ if (FPrevToken <> etLiteral) and (FPrevToken <> etName) and
+ (FPrevToken <> etSymbol)and (FPrevToken <> etRParen) then
+ begin
+ TokenStart := P;
+ Inc(P);
+ while (P^ in ['0'..'9', FDecimalSeparator, 'e', 'E', '+', '-']) do
+ Inc(P);
+ if ((P-1)^ = ',') and (FDecimalSeparator = ',') and (P^ = ' ') then
+ Dec(P);
+ SetString(FTokenString, TokenStart, P - TokenStart);
+ FToken := etLiteral;
+ FNumericLit := True;
+ end
+ else
+ begin
+ FToken := etSUB;
+ Inc(P);
+ end;
+ end;
+ '(':
+ begin
+ Inc(P);
+ FToken := etLParen;
+ end;
+ ')':
+ begin
+ Inc(P);
+ FToken := etRParen;
+ end;
+ '<':
+ begin
+ Inc(P);
+ case P^ of
+ '=':
+ begin
+ Inc(P);
+ FToken := etLE;
+ end;
+ '>':
+ begin
+ Inc(P);
+ FToken := etNE;
+ end;
+ else
+ FToken := etLT;
+ end;
+ end;
+ '=':
+ begin
+ Inc(P);
+ FToken := etEQ;
+ end;
+ '>':
+ begin
+ Inc(P);
+ if P^ = '=' then
+ begin
+ Inc(P);
+ FToken := etGE;
+ end else
+ FToken := etGT;
+ end;
+ '+':
+ begin
+ Inc(P);
+ FToken := etADD;
+ end;
+ '*':
+ begin
+ Inc(P);
+ FToken := etMUL;
+ end;
+ '/':
+ begin
+ Inc(P);
+ FToken := etDIV;
+ end;
+ ',':
+ begin
+ Inc(P);
+ FToken := etComma;
+ end;
+ #0:
+ FToken := etEnd;
+ else
+ DatabaseErrorFmt(SExprInvalidChar, [P^]);
+ end;
+ FSourcePtr := P;
+end;
+
+function TExprParser.ParseExpr: PExprNode;
+begin
+ Result := ParseExpr2;
+ while TokenSymbolIs('OR') do
+ begin
+ NextToken;
+ Result := FFilter.NewNode(enOperator, coOR, Unassigned,
+ Result, ParseExpr2);
+ GetScopeKind(Result, Result^.FLeft, Result^.FRight);
+ Result^.FDataType := ftBoolean;
+ end;
+end;
+
+function TExprParser.ParseExpr2: PExprNode;
+begin
+ Result := ParseExpr3;
+ while TokenSymbolIs('AND') do
+ begin
+ NextToken;
+ Result := FFilter.NewNode(enOperator, coAND, Unassigned,
+ Result, ParseExpr3);
+ GetScopeKind(Result, Result^.FLeft, Result^.FRight);
+ Result^.FDataType := ftBoolean;
+ end;
+end;
+
+function TExprParser.ParseExpr3: PExprNode;
+begin
+ if TokenSymbolIs('NOT') then
+ begin
+ NextToken;
+ Result := FFilter.NewNode(enOperator, coNOT, Unassigned,
+ ParseExpr4, nil);
+ Result^.FDataType := ftBoolean;
+ end else
+ Result := ParseExpr4;
+ GetScopeKind(Result, Result^.FLeft, Result^.FRight);
+end;
+
+
+function TExprParser.ParseExpr4: PExprNode;
+const
+ Operators: array[etEQ..etLT] of TCANOperator = (
+ coEQ, coNE, coGE, coLE, coGT, coLT);
+var
+ Operator: TCANOperator;
+ Left, Right: PExprNode;
+begin
+ Result := ParseExpr5;
+ if (FToken in [etEQ..etLT]) or (FToken = etLIKE)
+ or (FToken = etISNULL) or (FToken = etISNOTNULL)
+ or (FToken = etIN) then
+ begin
+ case FToken of
+ etEQ..etLT:
+ Operator := Operators[FToken];
+ etLIKE:
+ Operator := coLIKE;
+ etISNULL:
+ Operator := coISBLANK;
+ etISNOTNULL:
+ Operator := coNOTBLANK;
+ etIN:
+ Operator := coIN;
+ else
+ Operator := coNOTDEFINED;
+ end;
+ NextToken;
+ Left := Result;
+ if Operator = coIN then
+ begin
+ if FToken <> etLParen then
+ DatabaseErrorFmt(SExprNoLParen, [TokenName]);
+ NextToken;
+ Result := FFilter.NewNode(enOperator, coIN, Unassigned,
+ Left, nil);
+ Result.FDataType := ftBoolean;
+ if FToken <> etRParen then
+ begin
+ Result.FArgs := TList.Create;
+ repeat
+ Right := ParseExpr;
+ if IsTemporal(Left.FDataType) then
+ Right.FDataType := Left.FDataType;
+ Result.FArgs.Add(Right);
+ if (FToken <> etComma) and (FToken <> etRParen) then
+ DatabaseErrorFmt(SExprNoRParenOrComma, [TokenName]);
+ if FToken = etComma then NextToken;
+ until (FToken = etRParen) or (FToken = etEnd);
+ if FToken <> etRParen then
+ DatabaseErrorFmt(SExprNoRParen, [TokenName]);
+ NextToken;
+ end else
+ DatabaseError(SExprEmptyInList);
+ end else
+ begin
+ if (Operator <> coISBLANK) and (Operator <> coNOTBLANK) then
+ Right := ParseExpr5
+ else
+ Right := nil;
+ Result := FFilter.NewNode(enOperator, Operator, Unassigned,
+ Left, Right);
+ if Right <> nil then
+ begin
+ if (Left^.FKind = enField) and (Right^.FKind = enConst) then
+ begin
+ Right^.FDataType := Left^.FDataType;
+ Right^.FDataSize := Left^.FDataSize;
+ end
+ else if (Right^.FKind = enField) and (Left^.FKind = enConst) then
+ begin
+ Left^.FDataType := Right^.FDataType;
+ Left^.FDataSize := Right^.FDataSize;
+ end;
+ end;
+ if (Left^.FDataType in BlobFieldTypes) and (Operator = coLIKE) then
+ begin
+ if Right^.FKind = enConst then Right^.FDataType := ftString;
+ end
+ else if (Operator <> coISBLANK) and (Operator <> coNOTBLANK)
+ and ((Left^.FDataType in (BlobFieldTypes + [ftBytes])) or
+ ((Right <> nil) and (Right^.FDataType in (BlobFieldTypes + [ftBytes])))) then
+ DatabaseError(SExprTypeMis);
+ Result.FDataType := ftBoolean;
+ if Right <> nil then
+ begin
+ if IsTemporal(Left.FDataType) and (Right.FDataType in StringFieldTypes) then
+ Right.FDataType := Left.FDataType
+ else if IsTemporal(Right.FDataType) and (Left.FDataType in StringFieldTypes) then
+ Left.FDataType := Right.FDataType;
+ end;
+ GetScopeKind(Result, Left, Right);
+ end;
+ end;
+end;
+
+function TExprParser.ParseExpr5: PExprNode;
+const
+ Operators: array[etADD..etDIV] of TCANOperator = (
+ coADD, coSUB, coMUL, coDIV);
+var
+ Operator: TCANOperator;
+ Left, Right: PExprNode;
+begin
+ Result := ParseExpr6;
+ while FToken in [etADD, etSUB] do
+ begin
+ if not (poExtSyntax in FParserOptions) then
+ DatabaseError(SExprNoArith);
+ Operator := Operators[FToken];
+ Left := Result;
+ NextToken;
+ Right := ParseExpr6;
+ Result := FFilter.NewNode(enOperator, Operator, Unassigned, Left, Right);
+ TypeCheckArithOp(Result);
+ GetScopeKind(Result, Left, Right);
+ end;
+end;
+
+function TExprParser.ParseExpr6: PExprNode;
+const
+ Operators: array[etADD..etDIV] of TCANOperator = (
+ coADD, coSUB, coMUL, coDIV);
+var
+ Operator: TCANOperator;
+ Left, Right: PExprNode;
+begin
+ Result := ParseExpr7;
+ while FToken in [etMUL, etDIV] do
+ begin
+ if not (poExtSyntax in FParserOptions) then
+ DatabaseError(SExprNoArith);
+ Operator := Operators[FToken];
+ Left := Result;
+ NextToken;
+ Right := ParseExpr7;
+ Result := FFilter.NewNode(enOperator, Operator, Unassigned, Left, Right);
+ TypeCheckArithOp(Result);
+ GetScopeKind(Result, Left, Right);
+ end;
+end;
+
+
+function TExprParser.ParseExpr7: PExprNode;
+var
+ FuncName: string;
+begin
+ case FToken of
+ etSymbol:
+ if (poExtSyntax in FParserOptions)
+ and NextTokenIsLParen and TokenSymbolIsFunc(FTokenString) then
+ begin
+ Funcname := FTokenString;
+ NextToken;
+ if FToken <> etLParen then
+ DatabaseErrorFmt(SExprNoLParen, [TokenName]);
+ NextToken;
+ if (CompareText(FuncName,'count') = 0) and (FToken = etMUL) then
+ begin
+ FuncName := 'COUNT(*)';
+ NextToken;
+ end;
+ Result := FFilter.NewNode(enFunc, coNOTDEFINED, FuncName,
+ nil, nil);
+ if FToken <> etRParen then
+ begin
+ Result.FArgs := TList.Create;
+ repeat
+ Result.FArgs.Add(ParseExpr);
+ if (FToken <> etComma) and (FToken <> etRParen) then
+ DatabaseErrorFmt(SExprNoRParenOrComma, [TokenName]);
+ if FToken = etComma then NextToken;
+ until (FToken = etRParen) or (FToken = etEnd);
+ end else
+ Result.FArgs := nil;
+
+ GetFuncResultInfo(Result);
+ end
+ else if TokenSymbolIs('NULL') then
+ begin
+ Result := FFilter.NewNode(enConst, coNOTDEFINED, Variants.Null, nil, nil);
+ Result.FScopeKind := skConst;
+ end
+ else if TokenSymbolIs(FStrTrue) then
+ begin
+ Result := FFilter.NewNode(enConst, coNOTDEFINED, 1, nil, nil);
+ Result.FScopeKind := skConst;
+ end
+ else if TokenSymbolIs(FStrFalse) then
+ begin
+ Result := FFilter.NewNode(enConst, coNOTDEFINED, 0, nil, nil);
+ Result.FScopeKind := skConst;
+ end
+ else
+ begin
+ Result := FFilter.NewNode(enField, coNOTDEFINED, FTokenString, nil, nil);
+ Result.FScopeKind := skField;
+ end;
+ etName:
+ begin
+ Result := FFilter.NewNode(enField, coNOTDEFINED, FTokenString, nil, nil);
+ Result.FScopeKind := skField;
+ end;
+ etLiteral:
+ begin
+ Result := FFilter.NewNode(enConst, coNOTDEFINED, FTokenString, nil, nil);
+ if FNumericLit then Result^.FDataType := ftFloat else
+ Result^.FDataType := ftString;
+ Result.FScopeKind := skConst;
+ end;
+ etLParen:
+ begin
+ NextToken;
+ Result := ParseExpr;
+ if FToken <> etRParen then DatabaseErrorFmt(SExprNoRParen, [TokenName]);
+ end;
+ else
+ DatabaseErrorFmt(SExprExpected, [TokenName]);
+ Result := nil;
+ end;
+ NextToken;
+end;
+
+procedure TExprParser.GetScopeKind(Root, Left, Right : PExprNode);
+begin
+ if (Left = nil) and (Right = nil) then Exit;
+ if Right = nil then
+ begin
+ Root.FScopeKind := Left.FScopeKind;
+ Exit;
+ end;
+ if ((Left^.FScopeKind = skField) and (Right^.FScopeKind = skAgg))
+ or ((Left^.FScopeKind = skAgg) and (Right^.FScopeKind = skField)) then
+ DatabaseError(SExprBadScope);
+ if (Left^.FScopeKind = skConst) and (Right^.FScopeKind = skConst) then
+ Root^.FScopeKind := skConst
+ else if (Left^.FScopeKind = skAgg) or (Right^.FScopeKind = skAgg) then
+ Root^.FScopeKind := skAgg
+ else if (Left^.FScopeKind = skField) or (Right^.FScopeKind = skField) then
+ Root^.FScopeKind := skField;
+end;
+
+procedure TExprParser.GetFuncResultInfo(Node : PExprNode);
+begin
+ Node^.FDataType := ftString;
+ if (CompareText(Node^.FData, 'COUNT(*)') <> 0 )
+ and (CompareText(Node^.FData,'GETDATE') <> 0 )
+ and ( (Node^.FArgs = nil ) or ( Node^.FArgs.Count = 0) ) then
+ DatabaseError(SExprTypeMis);
+
+ if (Node^.FArgs <> nil) and (Node^.FArgs.Count > 0) then
+ Node^.FScopeKind := PExprNode(Node^.FArgs.Items[0])^.FScopeKind;
+ if (CompareText(Node^.FData , 'SUM') = 0) or
+ (CompareText(Node^.FData , 'AVG') = 0) then
+ begin
+ Node^.FDataType := ftFloat;
+ Node^.FScopeKind := skAgg;
+ end
+ else if (CompareText(Node^.FData , 'MIN') = 0) or
+ (CompareText(Node^.FData , 'MAX') = 0) then
+ begin
+ Node^.FDataType := PExprNode(Node^.FArgs.Items[0])^.FDataType;
+ Node^.FScopeKind := skAgg;
+ end
+ else if (CompareText(Node^.FData , 'COUNT') = 0) or
+ (CompareText(Node^.FData , 'COUNT(*)') = 0) then
+ begin
+ Node^.FDataType := ftInteger;
+ Node^.FScopeKind := skAgg;
+ end
+ else if (CompareText(Node^.FData , 'YEAR') = 0) or
+ (CompareText(Node^.FData , 'MONTH') = 0) or
+ (CompareText(Node^.FData , 'DAY') = 0) or
+ (CompareText(Node^.FData , 'HOUR') = 0) or
+ (CompareText(Node^.FData , 'MINUTE') = 0) or
+ (CompareText(Node^.FData , 'SECOND') = 0 ) then
+ begin
+ Node^.FDataType := ftInteger;
+ Node^.FScopeKind := PExprNode(Node^.FArgs.Items[0])^.FScopeKind;
+ end
+ else if CompareText(Node^.FData , 'GETDATE') = 0 then
+ begin
+ Node^.FDataType := ftDateTime;
+ Node^.FScopeKind := skConst;
+ end
+ else if CompareText(Node^.FData , 'DATE') = 0 then
+ begin
+ Node^.FDataType := ftDate;
+ Node^.FScopeKind := PExprNode(Node^.FArgs.Items[0])^.FScopeKind;
+ end
+ else if CompareText(Node^.FData , 'TIME') = 0 then
+ begin
+ Node^.FDataType := ftTime;
+ Node^.FScopeKind := PExprNode(Node^.FArgs.Items[0])^.FScopeKind;
+ end;
+end;
+
+function TExprParser.TokenName: string;
+begin
+ if FSourcePtr = FTokenPtr then Result := SExprNothing else
+ begin
+ SetString(Result, FTokenPtr, FSourcePtr - FTokenPtr);
+ Result := '''' + Result + '''';
+ end;
+end;
+
+function TExprParser.TokenSymbolIs(const S: string): Boolean;
+begin
+ Result := (FToken = etSymbol) and (CompareText(FTokenString, S) = 0);
+end;
+
+
+function TExprParser.TokenSymbolIsFunc(const S: string) : Boolean;
+begin
+ Result := (CompareText(S, 'UPPER') = 0) or
+ (CompareText(S, 'LOWER') = 0) or
+ (CompareText(S, 'SUBSTRING') = 0) or
+ (CompareText(S, 'TRIM') = 0) or
+ (CompareText(S, 'TRIMLEFT') = 0) or
+ (CompareText(S, 'TRIMRIGHT') = 0) or
+ (CompareText(S, 'YEAR') = 0) or
+ (CompareText(S, 'MONTH') = 0) or
+ (CompareText(S, 'DAY') = 0) or
+ (CompareText(S, 'HOUR') = 0) or
+ (CompareText(S, 'MINUTE') = 0) or
+ (CompareText(S, 'SECOND') = 0) or
+ (CompareText(S, 'GETDATE') = 0) or
+ (CompareText(S, 'DATE') = 0) or
+ (CompareText(S, 'TIME') = 0) or
+ (CompareText(S, 'SUM') = 0) or
+ (CompareText(S, 'MIN') = 0) or
+ (CompareText(S, 'MAX') = 0) or
+ (CompareText(S, 'AVG') = 0) or
+ (CompareText(S, 'COUNT') = 0);
+
+end;
+
+procedure TExprParser.TypeCheckArithOp(Node: PExprNode);
+begin
+ with Node^ do
+ begin
+ if IsNumeric(FLeft.FDataType) and IsNumeric(FRight.FDataType) then
+ FDataType := ftFloat
+ else if (FLeft.FDataType in StringFieldTypes) and
+ (FRight.FDataType in StringFieldTypes) and (FOperator = coADD) then
+ FDataType := ftString
+ else if IsTemporal(FLeft.FDataType) and IsNumeric(FRight.FDataType) and
+ (FOperator = coADD) then
+ FDataType := ftDateTime
+ else if IsTemporal(FLeft.FDataType) and IsNumeric(FRight.FDataType) and
+ (FOperator = coSUB) then
+ FDataType := FLeft.FDataType
+ else if IsTemporal(FLeft.FDataType) and IsTemporal(FRight.FDataType) and
+ (FOperator = coSUB) then
+ FDataType := ftFloat
+ else if (FLeft.FDataType in StringFieldTypes) and IsTemporal(FRight.FDataType) and
+ (FOperator = coSUB) then
+ begin
+ FLeft.FDataType := FRight.FDataType;
+ FDataType := ftFloat;
+ end
+ else if ( FLeft.FDataType in StringFieldTypes) and IsNumeric(FRight.FDataType )and
+ (FLeft.FKind = enConst) then
+ FLeft.FDataType := ftDateTime
+ else
+ DatabaseError(SExprTypeMis);
+ end;
+end;
+
+end.
diff --git a/components/flashfiler/sourcelaz/#NotUsedMore/lazffdelphi2.pas b/components/flashfiler/sourcelaz/#NotUsedMore/lazffdelphi2.pas
new file mode 100644
index 000000000..66a60c4d0
--- /dev/null
+++ b/components/flashfiler/sourcelaz/#NotUsedMore/lazffdelphi2.pas
@@ -0,0 +1,620 @@
+{ Only unit lazffdelphi1.pas is using this unit.
+
+ !!! CODE TAKEN FROM DELPHI7 - BORLAND CODE !!!
+}
+
+{ *************************************************************************** }
+{ }
+{ Kylix and Delphi Cross-Platform Visual Component Library }
+{ }
+{ Copyright (c) 1995, 2001 Borland Software Corporation }
+{ }
+{ *************************************************************************** }
+
+{$I ffdefine.inc}
+
+ //Originalname: unit SqlTimSt;
+ //called only from lazffdelphi1
+unit lazffdelphi2;
+
+// need to implement CastOLE, dispatch and stream (from Eddie?)
+
+interface
+
+uses Variants;
+
+type
+
+{ TSQLTimeStamp }
+ PSQLTimeStamp = ^TSQLTimeStamp;
+ TSQLTimeStamp = packed record
+ Year: SmallInt;
+ Month: Word;
+ Day: Word;
+ Hour: Word;
+ Minute: Word;
+ Second: Word;
+ Fractions: LongWord;
+ end;
+
+ function StrToSQLTimeStamp(const S: string): TSQLTimeStamp;
+ function VarToSQLTimeStamp(const aValue: Variant): TSQLTimeStamp;
+
+implementation
+
+uses
+ {VarUtils, }SysUtils, DateUtils, SysConst, TypInfo, Classes, {$IFDEF MSWINDOWS}Windows{$ENDIF}{$IFDEF LINUX}Types, Libc{$ENDIF};
+
+resourcestring
+ //FROM DBConsts.pas ================================
+ SCouldNotParseTimeStamp = 'Could not parse time stamp.';
+ SInvalidSqlTimeStamp = 'Invalied sql time stamp.';
+ //END FROM DBConsts.pas ================================
+
+
+const
+ NullSQLTimeStamp: TSQLTimeStamp = (Year: 0; Month: 0; Day: 0; Hour: 0; Minute: 0; Second: 0; Fractions: 0); //soner this was in implementation part
+
+ IncrementAmount: array[Boolean] of Integer = (1, -1);
+
+type
+{ TSQLTimeStampVariantType }
+ TSQLTimeStampVariantType = class(TPublishableVariantType)
+ protected
+ function GetInstance(const V: TVarData): TObject; override;
+ public
+ procedure Clear(var V: TVarData); override;
+ procedure Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); override;
+ procedure Cast(var Dest: TVarData; const Source: TVarData); override;
+ procedure CastTo(var Dest: TVarData; const Source: TVarData; const AVarType: TVarType); override;
+ procedure BinaryOp(var Left: TVarData; const Right: TVarData; const Operator: TVarOp); override;
+ procedure Compare(const Left, Right: TVarData; var Relationship: TVarCompareResult); override;
+ end;
+
+var
+
+{ SQLTimeStamp that the complex variant points to }
+
+ SQLTimeStampVariantType: TSQLTimeStampVariantType = nil;
+
+type
+
+{ TSQLTimeStampData }
+
+ TSQLTimeStampData = class(TPersistent)
+ private
+ FDateTime: TSQLTimeStamp;
+ function GetAsDateTime: TDateTime;
+ function GetAsString: string;
+ procedure SetAsString(const Value: string);
+ procedure SetAsDateTime(const Value: TDateTime);
+ procedure AdjustMonths(Reverse: Boolean);
+ procedure AdjustDays(Reverse: Boolean);
+ procedure AdjustHours(Reverse: Boolean);
+ procedure AdjustMinutes(Reverse: Boolean);
+ procedure AdjustSeconds(Reverse: Boolean);
+ function DaysInMonth: Integer;
+ function GetIsBlank: Boolean;
+ procedure SetDay(const Value: Word);
+ procedure SetFractions(const Value: LongWord);
+ procedure SetHour(const Value: Word);
+ procedure SetMinute(const Value: Word);
+ procedure SetMonth(const Value: Word);
+ procedure SetSecond(const Value: Word);
+ procedure SetYear(const Value: SmallInt);
+ protected
+ procedure AdjustDate(Reverse: Boolean);
+ property IsBlank: Boolean read GetIsBlank;
+ public
+ // the many ways to create
+ constructor Create(const AValue: SmallInt); overload;
+ constructor Create(const AValue: Integer); overload;
+ constructor Create(const AValue: TDateTime); overload;
+ constructor Create(const AText: string); overload;
+ constructor Create(const ASQLTimeStamp: TSQLTimeStamp); overload;
+ constructor Create(const ASource: TSQLTimeStampData); overload;
+
+ // access to the private bits
+ property DateTime: TSQLTimeStamp read FDateTime write FDateTime;
+
+ // non-destructive operations
+ // check this one!
+ function Compare(const Value: TSQLTimeStampData): TVarCompareResult;
+
+ // destructive operations
+ procedure DoAdd(const ADateTime: TSQLTimeStampData); overload;
+ procedure DoSubtract(const ADateTime: TSQLTimeStampData); overload;
+ // property access
+ published
+ // conversion
+ property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime;
+ property AsString: string read GetAsString write SetAsString;
+ property Day: Word read FDateTime.Day write SetDay;
+ property Fractions: LongWord read FDateTime.Fractions write SetFractions;
+ property Hour: Word read FDateTime.Hour write SetHour;
+ property Minute: Word read FDateTime.Minute write SetMinute;
+ property Month: Word read FDateTime.Month write SetMonth;
+ property Second: Word read FDateTime.Second write SetSecond;
+ property Year: SmallInt read FDateTime.Year write SetYear;
+ end;
+
+
+{ Helper record that helps crack open TSQLTimeStampObject }
+
+ TSQLTimeStampVarData = packed record
+ VType: TVarType;
+ Reserved1, Reserved2, Reserved3: Word;
+ VDateTime: TSQLTimeStampData;
+ Reserved4: DWord;
+ end;
+
+
+function IsSQLTimeStampBlank(const TimeStamp: TSQLTimeStamp): Boolean;
+begin
+ Result := (TimeStamp.Year = 0) and
+ (TimeStamp.Month = 0) and
+ (TimeStamp.Day = 0) and
+ (TimeStamp.Hour = 0) and
+ (TimeStamp.Minute = 0) and
+ (TimeStamp.Second = 0) and
+ (TimeStamp.Fractions = 0);
+end;
+
+
+// soner helper functions from bottom ------------------------------------
+// I moved only used functions from bottom to here and deleted unused
+function SQLTimeStampToDateTime(const DateTime: TSQLTimeStamp): TDateTime;
+begin
+ if IsSQLTimeStampBlank(DateTime) then
+ Result := 0
+ else with DateTime do
+ begin
+ Result := EncodeDate(Year, Month, Day);
+ if Result >= 0 then
+ Result := Result + EncodeTime(Hour, Minute, Second, Fractions)
+ else
+ Result := Result - EncodeTime(Hour, Minute, Second, Fractions);
+ end;
+end;
+
+function DateTimeToSQLTimeStamp(const DateTime: TDateTime): TSQLTimeStamp;
+var
+ FFractions, FYear: Word;
+begin
+ with Result do
+ begin
+ DecodeDate(DateTime, FYear, Month, Day);
+ Year := FYear;
+ DecodeTime(DateTime, Hour, Minute, Second, FFractions);
+ Fractions := FFractions;
+ end;
+end;
+
+function SQLTimeStampToStr(const Format: string;
+ DateTime: TSQLTimeStamp): string;
+var
+ FTimeStamp: TDateTime;
+begin
+ FTimeStamp := SqlTimeStampToDateTime(DateTime);
+ DateTimeToString(Result, Format, FTimeStamp);
+end;
+
+function IsSqlTimeStampValid(const ts: TSQLTimeStamp): Boolean;
+begin
+ if (ts.Month > 12) or (ts.Day > DaysInAMonth(ts.Year, ts.Month)) or
+ (ts.Hour > 23) or (ts.Minute > 59) or (ts.Second > 59) then
+ Result := False
+ else
+ Result := True;
+end;
+
+
+function TryStrToSQLTimeStamp(const S: string; var TimeStamp: TSQLTimeStamp): Boolean;
+var
+ DT: TDateTime;
+begin
+ Result := TryStrToDateTime(S, DT);
+ if Result then
+ begin
+ TimeStamp := DateTimeToSQLTimeStamp(DT);
+ Result := IsSqlTimeStampValid(TimeStamp);
+ end;
+ if not Result then
+ TimeStamp := NullSQLTimeStamp;
+end;
+
+procedure CheckSqlTimeStamp(const ASQLTimeStamp: TSQLTimeStamp);
+begin // only check if not an empty timestamp
+ if ASQLTimeStamp.Year + ASQLTimeStamp.Month + ASQLTimeStamp.day +
+ ASQLTimeStamp.Hour + ASQLTimeStamp.Minute + ASQLTimeStamp.Second > 0 then
+ begin
+ if ASQLTimeStamp.Year + ASQLTimeStamp.Month + ASQLTimeStamp.Day > 0 then
+ if (ASQLTimeStamp.Year = 0) or (ASQLTimeStamp.Month = 0) or
+ (ASQLTimeStamp.Day =0) or (ASQLTimeStamp.Month > 31) or (ASQLTimeStamp.Day >
+ DaysInAMonth(ASQLTimeStamp.Year,ASQLTimeStamp.Month)) then
+ raise EConvertError.Create(SInvalidSQLTimeStamp);
+ if ASQLTimeStamp.Hour + ASQLTimeStamp.Minute + ASQLTimeStamp.Second > 0 then
+ if (ASQLTimeStamp.Hour > 23) or (ASQLTimeStamp.Second > 59) or
+ (ASQLTimeStamp.Minute > 59) then
+ raise EConvertError.Create(SInvalidSQLTimeStamp);
+ end;
+end;
+// ------soner helper functions from bottom--------------------------------
+
+
+{ TSQLTimeStampData }
+
+function TSQLTimeStampData.GetIsBlank: Boolean;
+begin
+ Result := IsSQLTimeStampBlank(FDateTime);
+end;
+
+// Adjust for Month > 12 or < 1
+procedure TSQLTimeStampData.AdjustMonths(Reverse: Boolean);
+const
+ AdjustAmt: array[Boolean] of Integer = (-12, 12);
+begin
+ while (FDateTime.Month < 1) or(FDateTime.Month > 12) do
+ begin
+ Inc(FDateTime.Year, IncrementAmount[Reverse]);
+ Inc(FDateTime.Month, AdjustAmt[Reverse]);
+ end;
+end;
+
+// Adjust for Days > 28/30/31 or < 1
+procedure TSQLTimeStampData.AdjustDays(Reverse: Boolean);
+var
+ Days: Integer;
+begin
+ Days := DaysInMonth;
+ while (FDateTime.Day < 1) or (FDateTime.Day > Days) do
+ begin
+ Inc(FDateTime.Month, IncrementAmount[Reverse]);
+ if Reverse then
+ Dec(FDateTime.Day, Days)
+ else
+ Inc(FDateTime.Day, Days);
+ AdjustMonths(Reverse);
+ Days := DaysInMonth;
+ end;
+end;
+
+// Adjust for Hours over 23 or less than 0
+procedure TSQLTimeStampData.AdjustHours(Reverse: Boolean);
+const
+ AdjustAmt: array[Boolean] of Integer = (-24, 24);
+begin
+ while (FDateTime.Hour > 23) or (Integer(FDateTime.Hour) < 0) do
+ begin
+ Inc(FDateTime.Day, IncrementAmount[Reverse]);
+ Inc(FDateTime.Hour, AdjustAmt[Reverse]);
+ AdjustDays(Reverse);
+ end;
+end;
+
+// Adjust Minutes for Hours over 59 or less than 0
+procedure TSQLTimeStampData.AdjustMinutes(Reverse: Boolean);
+const
+ AdjustAmt: array[Boolean] of Integer = (-60, 60);
+begin
+ while (FDateTime.Minute > 59) or (Integer(FDateTime.Minute) < 0) do
+ begin
+ Inc(FDateTime.Hour, IncrementAmount[Reverse]);
+ Inc(FDateTime.Minute, AdjustAmt[Reverse]);
+ AdjustHours(Reverse);
+ end;
+end;
+
+// Adjust Seconds for Hours over 59 or less than 0
+procedure TSQLTimeStampData.AdjustSeconds(Reverse: Boolean);
+const
+ AdjustAmt: array[Boolean] of Integer = (-60, 60);
+begin
+ while (FDateTime.Second > 59) or (Integer(FDateTime.Second) < 0) do
+ begin
+ Inc(FDateTime.Minute, IncrementAmount[Reverse]);
+ Inc(FDateTime.Second, AdjustAmt[Reverse]);
+ AdjustMinutes(Reverse);
+ end;
+end;
+
+procedure TSQLTimeStampData.AdjustDate(Reverse: Boolean);
+begin
+ if Reverse then
+ begin
+ AdjustSeconds(Reverse);
+ AdjustMinutes(Reverse);
+ AdjustHours(Reverse);
+ AdjustDays(Reverse);
+ AdjustMonths(Reverse);
+ end else
+ begin
+ AdjustMonths(Reverse);
+ AdjustDays(Reverse);
+ AdjustHours(Reverse);
+ AdjustMinutes(Reverse);
+ AdjustSeconds(Reverse);
+ end;
+end;
+
+function TSQLTimeStampData.DaysInMonth: Integer;
+begin
+ Result := DaysInAMonth(DateTime.Year, DateTime.Month);
+end;
+
+procedure TSQLTimeStampData.DoSubtract(const ADateTime: TSQLTimeStampData);
+begin
+ Dec(FDateTime.Year, ADateTime.Year);
+ Dec(FDateTime.Hour, ADateTime.Month);
+ Dec(FDateTime.Day, ADateTime.Day);
+ Dec(FDateTime.Hour, ADateTime.Hour);
+ Dec(FDateTime.Minute, ADateTime.Minute);
+ Dec(FDateTime.Second, ADateTime.Second);
+ Dec(FDateTime.Fractions, ADateTime.Fractions);
+ AdjustDate(True);
+end;
+
+procedure TSQLTimeStampData.DoAdd(const ADateTime: TSQLTimeStampData);
+begin
+ if not IsBlank then
+ begin
+ Inc(FDateTime.Year, ADateTime.Year);
+ Inc(FDateTime.Hour, ADateTime.Month);
+ Inc(FDateTime.Day, ADateTime.Day);
+ Inc(FDateTime.Hour, ADateTime.Hour);
+ Inc(FDateTime.Minute, ADateTime.Minute);
+ Inc(FDateTime.Second, ADateTime.Second);
+ Inc(FDateTime.Fractions, ADateTime.Fractions);
+ AdjustDate(False);;
+ end;
+end;
+
+function TSQLTimeStampData.Compare(const Value: TSQLTimeStampData): TVarCompareResult;
+var
+ Status: Integer;
+begin
+ Status := FDateTime.Year - Value.Year;
+ if Status = 0 then
+ Status := FDateTime.Month - Value.Month;
+ if Status = 0 then
+ Status := FDateTime.Day - Value.Day;
+ if Status = 0 then
+ Status := FDateTime.Hour - Value.Hour;
+ if Status = 0 then
+ Status := FDateTime.Hour - Value.Hour;
+ if Status = 0 then
+ Status := FDateTime.Minute - Value.Minute;
+ if Status = 0 then
+ Status := FDateTime.Second - Value.Second;
+ if Status = 0 then
+ Status := FDateTime.Fractions - Value.Fractions;
+ if Status = 0 then
+ Result := crEqual
+ else
+ if Status > 0 then
+ Result := crGreaterThan
+ else
+ Result := crLessThan;
+end;
+
+function TSQLTimeStampData.GetAsString: string;
+begin
+ Result := SQLTimeStampToStr('', FDateTime);
+end;
+
+function TSQLTimeStampData.GetAsDateTime: TDateTime;
+begin
+ Result := SQLTimeStampToDateTime(FDateTime);
+end;
+
+procedure TSQLTimeStampData.SetAsString(const Value: string);
+begin
+ FDateTime := StrToSQLTimeStamp(Value);
+end;
+
+procedure TSQLTimeStampData.SetAsDateTime(const Value: TDateTime);
+begin
+ FDateTime := DateTimeToSQLTimeStamp(Value);
+end;
+
+constructor TSQLTimeStampData.Create(const AValue: Integer);
+begin
+ inherited Create;
+ FDateTime := NullSQLTimeStamp;
+ FDateTime.Day := AValue;
+end;
+
+constructor TSQLTimeStampData.Create(const AValue: SmallInt);
+begin
+ inherited Create;
+ FDateTime := NullSQLTimeStamp;
+ FDateTime.Day := AValue;
+end;
+
+constructor TSQLTimeStampData.Create(const AValue: TDateTime);
+begin
+ inherited Create;
+ FDateTime := DateTimeToSqlTimeStamp(AValue);
+end;
+
+constructor TSQLTimeStampData.Create(const AText: string);
+var
+ ts: TSQLTimeStamp;
+begin
+ ts := StrToSQLTimeStamp(AText);
+ inherited Create;
+ FDateTime := ts;
+end;
+
+constructor TSQLTimeStampData.Create(const ASQLTimeStamp: TSQLTimeStamp);
+begin
+ CheckSqlTimeStamp( ASQLTimeStamp );
+ inherited Create;
+ move(ASQLTimeStamp, FDateTime, sizeof(TSQLTimeStamp));
+end;
+
+constructor TSQLTimeStampData.Create(const ASource: TSQLTimeStampData);
+begin
+ Create(aSource.DateTime);
+end;
+
+procedure TSQLTimeStampData.SetDay(const Value: Word);
+begin
+ Assert((Value >= 1) and (Value <= DaysInAMonth(Year, Month)));
+ FDateTime.Day := Value;
+end;
+
+procedure TSQLTimeStampData.SetFractions(const Value: LongWord);
+begin
+ FDateTime.Fractions := Value;
+end;
+
+procedure TSQLTimeStampData.SetHour(const Value: Word);
+begin
+ Assert(Value <= 23); // no need to check for > 0 on Word
+ FDateTime.Hour := Value;
+end;
+
+procedure TSQLTimeStampData.SetMinute(const Value: Word);
+begin
+ Assert(Value <= 59); // no need to check for > 0 on Word
+ FDateTime.Minute := Value;
+end;
+
+procedure TSQLTimeStampData.SetMonth(const Value: Word);
+begin
+ Assert((Value >= 1) and (Value <= 12));
+ FDateTime.Month := Value;
+end;
+
+procedure TSQLTimeStampData.SetSecond(const Value: Word);
+begin
+ Assert(Value <= 59); // no need to check for > 0 on Word
+ FDateTime.Second := Value;
+end;
+
+procedure TSQLTimeStampData.SetYear(const Value: SmallInt);
+begin
+ FDateTime.Year := Value;
+end;
+
+{ TSQLTimeStampVariantType }
+
+procedure TSQLTimeStampVariantType.Clear(var V: TVarData);
+begin
+ V.VType := varEmpty;
+ FreeAndNil(TSQLTimeStampVarData(V).VDateTime);
+end;
+
+procedure TSQLTimeStampVariantType.Cast(var Dest: TVarData;
+ const Source: TVarData);
+var
+ LSource, LTemp: TVarData;
+begin
+ VarDataInit(LSource);
+ try
+ VarDataCopyNoInd(LSource, Source);
+ if VarDataIsStr(LSource) then
+ TSQLTimeStampVarData(Dest).VDateTime := TSQLTimeStampData.Create(VarDataToStr(LSource))
+ else
+ begin
+ VarDataInit(LTemp);
+ try
+ VarDataCastTo(LTemp, LSource, varDate);
+ TSQLTimeStampVarData(Dest).VDateTime := TSQLTimeStampData.Create(LTemp.VDate);
+ finally
+ VarDataClear(LTemp);
+ end;
+ end;
+ Dest.VType := VarType;
+ finally
+ VarDataClear(LSource);
+ end;
+end;
+
+procedure TSQLTimeStampVariantType.CastTo(var Dest: TVarData;
+ const Source: TVarData; const AVarType: TVarType);
+var
+ LTemp: TVarData;
+begin
+ if Source.VType = VarType then
+ case AVarType of
+ varOleStr:
+ VarDataFromOleStr(Dest, TSQLTimeStampVarData(Source).VDateTime.AsString);
+ varString:
+ VarDataFromStr(Dest, TSQLTimeStampVarData(Source).VDateTime.AsString);
+ else
+ VarDataInit(LTemp);
+ try
+ LTemp.VType := varDate;
+ LTemp.VDate := TSQLTimeStampVarData(Source).VDateTime.AsDateTime;
+ VarDataCastTo(Dest, LTemp, AVarType);
+ finally
+ VarDataClear(LTemp);
+ end;
+ end
+ else
+ inherited;
+end;
+
+procedure TSQLTimeStampVariantType.Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean);
+begin
+ if Indirect and VarDataIsByRef(Source) then
+ VarDataCopyNoInd(Dest, Source)
+ else
+ with TSQLTimeStampVarData(Dest) do
+ begin
+ VType := VarType;
+ VDateTime := TSQLTimeStampData.Create(TSQLTimeStampVarData(Source).VDateTime);
+ end;
+end;
+
+function TSQLTimeStampVariantType.GetInstance(const V: TVarData): TObject;
+begin
+ Result := TSQLTimeStampVarData(V).VDateTime;
+end;
+
+procedure TSQLTimeStampVariantType.BinaryOp(var Left: TVarData; const Right: TVarData; const Operator: TVarOp);
+begin
+ case Operator of
+ opAdd:
+ TSQLTimeStampVarData(Left).VDateTime.DoAdd(TSQLTimeStampVarData(Right).VDateTime);
+ opSubtract:
+ TSQLTimeStampVarData(Left).VDateTime.DoSubtract(TSQLTimeStampVarData(Right).VDateTime);
+ else
+ RaiseInvalidOp;
+ end;
+end;
+
+procedure TSQLTimeStampVariantType.Compare(const Left, Right: TVarData; var Relationship: TVarCompareResult);
+begin
+ Relationship := TSQLTimeStampVarData(Left).VDateTime.Compare(TSQLTimeStampVarData(Right).VDateTime);
+end;
+
+function VarToSQLTimeStamp(const aValue: Variant): TSQLTimeStamp;
+begin
+ if TVarData(aValue).VType in [varNULL, varEMPTY] then
+ Result := NullSqlTimeStamp
+ else if (TVarData(aValue).VType = varString) then
+ Result := TSQLTimeStampData.Create(String(aValue)).FDateTime
+ else if (TVarData(aValue).VType = varOleStr) then
+ Result := TSQLTimeStampData.Create(String(aValue)).FDateTime
+ else if (TVarData(aValue).VType = varDouble) or (TVarData(aValue).VType = varDate) then
+ Result := DateTimeToSqlTimeStamp(TDateTime(aValue))
+ else if (TVarData(aValue).VType = SQLTimeStampVariantType.VarType) then
+ Result := TSQLTimeStampVarData(aValue).VDateTime.DateTime
+ else
+ Raise EVariantError.Create(SInvalidVarCast)
+end;
+
+function StrToSQLTimeStamp(const S: string): TSQLTimeStamp;
+begin
+ if not TryStrToSqlTimeStamp(S, Result) then
+ raise EConvertError.Create(SCouldNotParseTimeStamp);
+end;
+
+initialization
+ SQLTimeStampVariantType := TSQLTimeStampVariantType.Create;
+finalization
+ FreeAndNil(SQLTimeStampVariantType);
+end.
diff --git a/components/flashfiler/sourcelaz/#NotUsedMore/lazvclfuncs.pas b/components/flashfiler/sourcelaz/#NotUsedMore/lazvclfuncs.pas
new file mode 100644
index 000000000..aae7fcac0
--- /dev/null
+++ b/components/flashfiler/sourcelaz/#NotUsedMore/lazvclfuncs.pas
@@ -0,0 +1,67 @@
+// doesn't used more!
+// ALL CODE TAKEN FROM DELPHI7 - BORLAND CODE !!!!!!
+// use for lazarus lclintf.pas
+{
+
+}
+unit LazVCLFuncs;
+
+{$I ffdefine.inc}
+
+interface
+
+uses
+ Classes, SysUtils, Windows;
+
+function AllocateHWnd(Method: TWndMethod): HWND;
+procedure DeallocateHWnd(Wnd: HWND);
+implementation
+
+var
+ UtilWindowClass: TWndClass = (
+ style: 0;
+ lpfnWndProc: @DefWindowProc;
+ cbClsExtra: 0;
+ cbWndExtra: 0;
+ hInstance: 0;
+ hIcon: 0;
+ hCursor: 0;
+ hbrBackground: 0;
+ lpszMenuName: nil;
+ lpszClassName: 'TPUtilWindow');
+
+function AllocateHWnd(Method: TWndMethod): HWND;
+var
+ TempClass: TWndClass;
+ ClassRegistered: Boolean;
+begin
+ UtilWindowClass.hInstance := HInstance;
+{.$IFDEF PIC}
+ UtilWindowClass.lpfnWndProc := @DefWindowProc;
+{.$ENDIF}
+ ClassRegistered := GetClassInfo(HInstance, UtilWindowClass.lpszClassName, TempClass);
+//beep
+ if not ClassRegistered or (@TempClass.lpfnWndProc <> @DefWindowProc) then
+ begin
+ if ClassRegistered then
+ Windows.UnregisterClass(UtilWindowClass.lpszClassName, HInstance);
+ Windows.RegisterClass(UtilWindowClass);
+ end;
+ Result := CreateWindowEx(WS_EX_TOOLWINDOW, UtilWindowClass.lpszClassName,
+ '', WS_POPUP {+ 0}, 0, 0, 0, 0, 0, 0, HInstance, nil);
+ if Assigned(Method) then
+ SetWindowLong(Result, GWL_WNDPROC, Longint(MakeObjectInstance(Method)));
+end;
+
+procedure DeallocateHWnd(Wnd: HWND);
+var
+ Instance: Pointer;
+begin
+ Instance := Pointer(GetWindowLong(Wnd, GWL_WNDPROC));
+ DestroyWindow(Wnd);
+ if Instance <> @DefWindowProc then FreeObjectInstance(Instance);
+end;
+
+
+end.
+
diff --git a/components/flashfiler/sourcelaz/LazConvertReadMe.txt b/components/flashfiler/sourcelaz/LazConvertReadMe.txt
new file mode 100644
index 000000000..304db1d81
--- /dev/null
+++ b/components/flashfiler/sourcelaz/LazConvertReadMe.txt
@@ -0,0 +1,125 @@
+== TurboPower FlashFiler2Lazarus Port========
+Ported from: Soner A.
+State: Client and Server compiles without error.
+ Client Engine working
+ ServerEngine has error.(Use from compiled one from delphi)
+
+Search in Source for "fpc" or "soner" to look changes.
+
+**********
+I substitute LazDbCommon.pas with lazcommon.pas!
+
+NO MORE BORLAND CODE, It uses now TExprParser from fssql.
+ USED UNITS WITH BORLAND CODE:
+ LazDbCommon.pas for TExprParser used by ffdb.pas
+ LazDbComSqlTimSt.pas used only by LazDbCommon.pas (original name from Delphi is: SqlTimSt.pas)
+
+ NEW_24.04.2016 you can compile now without delphi unit. It was used only in one "useless" function!
+ Define in ffdefine.inc:
+ {$DEFINE DONTUSEDELPHIUNIT} //Disables in ffdb.pas the function TffDataSet.dsCreateLookupFilter
+ //if it called then it raises exception!
+***********
+
+== TODO ====
+1. It must be tested more. I am new to FlashFiler. I did not used it until yesterday.
+2. Some component, property editors and experts for formular desgin must be ported.
+3. You should convert pred(variable) to variable-1 because of pred(word=0) error!
+ they used it excessive (1144x!)
+
+== Substituted classes ========
+This classes/types/procedures aren't exist in Lazarus/Freepascal, I changed them:
+unit Original from ff2 New for Lazarus-port
+-------- ---------------- --------------------
+ffclcoln IDesigner TIDesigner;
+ IDesignerSelections TComponent; //IDesignerSelections dont exist on laz
+ TDesignerSelections TComponent;
+ FDesigner.SetSelections(SelList); FDesigner.SelectOnlyThisComponent(SelList); //soner es gibt ken setselections
+for others search for fpc in sourcelaz-folder.
+
+== BUGS/ISSUES ========
+FIRST: I ported very fast, the "real" code for db is good ported but i had problems
+with the compents editors and experts because i don't know anything about that for lazarus.
+
+1.[SOLVED, I USED IT FALSE]
+it works but still error on start of programm, am I using it false? Why working Delphi examples with lazarus seamless and mine don't?]
+MAY BE WRONG, test it again, i can play with original example in lazarus without problems
+
+2.[SOLVED, I USED IT FALSE]
+Design Editor: If you put TffDataBase and set Property DatabaseName to any value i.e. "mydatabase",
+than "mydatabase" should be local alias and it should be shown at TffTable.DatabaseName. But it doesn't.
+I think the problem can be:
+ in ffdb.pas
+ -FieldDefList, FieldDefList.IndexOf(FullName); //class, function
+ or in designeditors ffclreg, ffclreng..
+
+3. [SOLVED, I USED IT FALSE]
+If you make with delphi example app (like in examples order) and import it to lazarus than it works, but if you make it with lazarus then it doesnot work.
+
+
+4. [SOLVED -> all definied in ffclreg.dcr, delphi support images from base class but lazarus didn't:
+ TffLegacyTransport is in ffclreg.dcr as baseclass: TFFBASETRANSPORT]
+ I could not found some components images for the component palette:
+ TffServerEngine
+ TffServerCommandHandler
+ TffLegacyTransport
+ TffEventlog
+ (all other has it in ffclreg.dcr)
+
+5. [SOLVED] fpc makes pred(word=0) = 0 but delphi -1. (Look at ffdb.pas TffBaseTable.dsGetIndexInfo;)
+
+6. [SOLVED]
+ You must set TffTable.IndexName to Valid else Lazarus will freeze!
+ An don't set TffTable.IndexName to "Sequential Access Index", Lazarus will be crash!
+ I appears also on runtime of application
+
+7. In fpc doesn't exists TWriter.Flushbuffer, so I made in ffclreng.pas hackclass TBinaryObjectWriterHack
+
+8.
+EmbeddedSErver (TffServerEngine) don't works, because in fpc-classes TReader.ReadString can't read some string-types.
+Unicode failure? Look examples\LazEmbeddedServer
+
+
+== Fast notices during converting/porting to lazarus ========
+0. -------------------------
+I replaced ffdb.ReSizePersistentFields; FieldDefList with Fielddefs because fpc doesn't has FieldDefList
+
+1. -------------------------
+ffclcoln.pas ist parameter editor. i removed this from package because it is not converted to laz and removed from uses of ffclreg,
+
+SelectComponentList()
+//IDesignerSelections dont exist on laz
+FDesigner.SetSelections(SelList); dont exist on laz
+
+2. -------------------------
+These Component editors or experts aren't converted and aren't used in lpk.
+ffclver.pas -version.property editor useles for programm dont converted
+ffclexpt.pas -FlashFiler: TFFEngineManager Expert
+
+
+3. -------------------------
+ffclreg.pas
+Some Property editors and conditions (see below) disabled.
+procedure TffServerEngineProperty.GetValueList(List: TStrings);
+...
+ if (Cmpnt is TffBaseServerEngine) and
+ {$ifndef fpc} Designer.IsComponentLinkable(Cmpnt) and {$endif} //Soner don't exits on lazarus
+
+{$ifndef fpc} //soner ParamEditor not converted
+{ TffCollectionProperty }
+
+ {register the experts}
+ {$ifndef fpc} //Soner: I don't know how to do with lazarus
+ RegisterCustomModule(TffBaseEngineManager, TCustomModule);
+ RegisterLibraryExpert(TffEngineManagerWizard.Create);
+ {$endif}
+
+{$ifndef fpc} //don't converted
+{$endif}
+
+4. -------------------------
+added some code from delphi look: lazsqltimst.pas, lazdbcommon.pas, (lazvclfuncs.pas, lazdbconsts.pas)
+
+5. -------------------------
+Flashfiler typen
+fftWideChar
+fftWideString
\ No newline at end of file
diff --git a/components/flashfiler/sourcelaz/Rebuild210/FFRebuild210.dpr b/components/flashfiler/sourcelaz/Rebuild210/FFRebuild210.dpr
new file mode 100644
index 000000000..b1565295d
--- /dev/null
+++ b/components/flashfiler/sourcelaz/Rebuild210/FFRebuild210.dpr
@@ -0,0 +1,46 @@
+{*********************************************************}
+{* Project source file *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+program FFRebuild210;
+
+uses
+ Forms,
+ umain in 'umain.pas' {frmMain},
+ uConfig in 'uConfig.pas',
+ dmMain in 'dmMain.pas' {dmRebuild: TDataModule};
+
+{$R *.RES}
+
+begin
+ Application.Initialize;
+ Application.CreateForm(TfrmMain, frmMain);
+ Application.Run;
+end.
diff --git a/components/flashfiler/sourcelaz/Rebuild210/FFRebuild210.res b/components/flashfiler/sourcelaz/Rebuild210/FFRebuild210.res
new file mode 100644
index 000000000..194f2fb21
Binary files /dev/null and b/components/flashfiler/sourcelaz/Rebuild210/FFRebuild210.res differ
diff --git a/components/flashfiler/sourcelaz/Rebuild210/dmMain.dfm b/components/flashfiler/sourcelaz/Rebuild210/dmMain.dfm
new file mode 100644
index 000000000..c3bf199dd
Binary files /dev/null and b/components/flashfiler/sourcelaz/Rebuild210/dmMain.dfm differ
diff --git a/components/flashfiler/sourcelaz/Rebuild210/dmMain.pas b/components/flashfiler/sourcelaz/Rebuild210/dmMain.pas
new file mode 100644
index 000000000..523e1d401
--- /dev/null
+++ b/components/flashfiler/sourcelaz/Rebuild210/dmMain.pas
@@ -0,0 +1,144 @@
+{*********************************************************}
+{* FlashFiler: Data module for FFRebuild210 *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit dmMain;
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
+ ffdb, ffdbbase, ffllbase, ffllcomp, fflleng, ffsrintm, ffsreng;
+
+type
+ TdmRebuild = class(TDataModule)
+ ServerEngine: TffServerEngine;
+ Client: TffClient;
+ Session: TffSession;
+ DB: TffDatabase;
+ private
+ { Private declarations }
+ function GetActive : Boolean;
+ function GetDatabase : TffDatabase;
+ function GetPath : string;
+ function GetServerDatabase : TffSrDatabase;
+
+ procedure SetActive(const Value : Boolean);
+ procedure SetPath(const Value : string);
+ public
+ { Public declarations }
+ procedure GetTables(TableList : TStringList);
+ { Returns a string list containing one entry per table in the
+ database path. The string portion contains the name of the table.
+ The object portion contains an inactive TffTable tied to the
+ session, database, and table names. }
+
+ property Active : Boolean
+ read GetActive
+ write SetActive;
+
+ property Database : TffDatabase
+ read GetDatabase;
+
+ property Path : string
+ read GetPath
+ write SetPath;
+
+ property ServerDatabase : TffSrDatabase
+ read GetServerDatabase;
+ end;
+
+var
+ dmRebuild: TdmRebuild;
+
+implementation
+
+{$R *.DFM}
+
+{====================================================================}
+function TdmRebuild.GetActive : Boolean;
+begin
+ Result := DB.Connected;
+end;
+{--------}
+function TdmRebuild.GetDatabase : TffDatabase;
+begin
+ Result := DB;
+end;
+{--------}
+function TdmRebuild.GetPath : string;
+begin
+ Result := DB.AliasName;
+end;
+{--------}
+function TdmRebuild.GetServerDatabase : TffSrDatabase;
+begin
+ Result := TffSrDatabase(dmRebuild.Database.DatabaseID);
+end;
+{--------}
+procedure TdmRebuild.GetTables(TableList : TStringList);
+var
+ Inx : Integer;
+ Table : TffTable;
+begin
+ if DB.AliasName = '' then
+ ShowMessage('Source directory not specified')
+ else begin
+ DB.Connected := True;
+ TableList.Clear;
+ DB.GetTableNames(TableList);
+ for Inx := 0 to Pred(TableList.Count) do begin
+ Table := TffTable.Create(nil);
+ with Table do begin
+ SessionName := Self.Session.SessionName;
+ DatabaseName := DB.DatabaseName;
+ TableName := TableList[Inx];
+ TableList.Objects[Inx] := Table;
+ end;
+ end; { for }
+ end;
+
+end;
+{--------}
+procedure TdmRebuild.SetActive(const Value : Boolean);
+begin
+ DB.Connected := Value;
+end;
+{--------}
+procedure TdmRebuild.SetPath(const Value : string);
+begin
+ if Value <> DB.AliasName then begin
+ DB.Connected := False;
+ DB.AliasName := Value;
+ end;
+end;
+{====================================================================}
+
+end.
diff --git a/components/flashfiler/sourcelaz/Rebuild210/ffrebuild210.ini b/components/flashfiler/sourcelaz/Rebuild210/ffrebuild210.ini
new file mode 100644
index 000000000..c35c3745b
--- /dev/null
+++ b/components/flashfiler/sourcelaz/Rebuild210/ffrebuild210.ini
@@ -0,0 +1,5 @@
+[Config]
+AutoRun=0
+AllowChangeDirectory=1
+InitialDirectory=c:\
+
diff --git a/components/flashfiler/sourcelaz/Rebuild210/ffrebuild210.rc b/components/flashfiler/sourcelaz/Rebuild210/ffrebuild210.rc
new file mode 100644
index 000000000..487a6e87a
--- /dev/null
+++ b/components/flashfiler/sourcelaz/Rebuild210/ffrebuild210.rc
@@ -0,0 +1,60 @@
+/*********************************************************
+ * Main program icon resource *
+ *********************************************************/
+
+/* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** */
+
+#define VERSIONINFO_1 1
+
+VERSIONINFO_1 VERSIONINFO
+FILEVERSION 2, 1, 3, 0
+PRODUCTVERSION 2, 1, 3, 0
+FILEOS VOS__WINDOWS32
+FILETYPE VFT_APP
+{
+ BLOCK "StringFileInfo"
+ {
+ BLOCK "040904E4"
+ {
+ VALUE "CompanyName", "TurboPower Software Company\000\000"
+ VALUE "FileDescription", "FlashFiler FFRebuild Utility\000"
+ VALUE "FileVersion", "2.1.3.0\000"
+ VALUE "InternalName", "FFREBUILD210\000"
+ VALUE "LegalCopyright", "Copyright (c) TurboPower Software Co. 1996-2002\000\000"
+ VALUE "OriginalFilename", "FFREBUILD210.EXE\000"
+ VALUE "ProductName", "FlashFiler (Delphi Edition)\000"
+ VALUE "ProductVersion", "2.1.3.0\000"
+ }
+
+ }
+
+ BLOCK "VarFileInfo"
+ {
+ VALUE "Translation", 0x409, 1252
+ }
+
+}
+
diff --git a/components/flashfiler/sourcelaz/Rebuild210/uConfig.pas b/components/flashfiler/sourcelaz/Rebuild210/uConfig.pas
new file mode 100644
index 000000000..35fc76b5e
--- /dev/null
+++ b/components/flashfiler/sourcelaz/Rebuild210/uConfig.pas
@@ -0,0 +1,184 @@
+{*********************************************************}
+{* FlashFiler: Config interface for FFRebuild210 *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit uConfig;
+
+interface
+
+uses
+ IniFiles;
+
+type
+ TFallbackConfig = class
+ protected
+
+ FIni : TINIFile;
+
+ procedure IniCreate;
+ procedure IniFree;
+
+ function GetAllowChangeDir : Boolean;
+ function GetAutoRun : Boolean;
+ function GetInitialDir : string;
+ function GetOutputDir : string;
+
+ procedure SetAllowChangeDir(const Value : Boolean);
+ procedure SetAutoRun(const Value : Boolean);
+ procedure SetInitialDir(const Value : string);
+ procedure SetOutputDir(const Value : string);
+
+ public
+
+ property AllowChangeDir : Boolean
+ read GetAllowChangeDir
+ write SetAllowChangeDir;
+
+ property AutoRun : Boolean
+ read GetAutoRun
+ write SetAutoRun;
+
+ property InitialDir : string
+ read GetInitialDir
+ write SetInitialDir;
+
+ property OutputDir : string
+ read GetOutputDir
+ write SetOutputDir;
+
+ end;
+
+implementation
+
+uses
+ Forms,
+ SysUtils;
+
+const
+ csAllowChangeDir = 'AllowChangeDirectory';
+ csAutoRun = 'AutoRun';
+ csIniName = 'FFRebuild210.ini';
+ csInitialDir = 'InitialDirectory';
+ csOutputDir = 'OutputDirectory';
+ csSection = 'Config';
+
+{====================================================================}
+function TFallbackConfig.GetAllowChangeDir : Boolean;
+begin
+ IniCreate;
+ try
+ Result := FIni.ReadBool(csSection, csAllowChangeDir, False);
+ finally
+ IniFree;
+ end;
+end;
+{--------}
+function TFallbackConfig.GetAutoRun : Boolean;
+begin
+ IniCreate;
+ try
+ Result := FIni.ReadBool(csSection, csAutoRun, False);
+ finally
+ IniFree;
+ end;
+end;
+{--------}
+function TFallbackConfig.GetInitialDir : string;
+begin
+ IniCreate;
+ try
+ Result := FIni.ReadString(csSection, csInitialDir, '');
+ finally
+ IniFree;
+ end;
+end;
+{--------}
+function TFallbackConfig.GetOutputDir : string;
+begin
+ IniCreate;
+ try
+ Result := FIni.ReadString(csSection, csOutputDir, '');
+ finally
+ IniFree;
+ end;
+end;
+{--------}
+procedure TFallbackConfig.IniCreate;
+begin
+ FIni := TIniFile.Create(ChangeFileExt(Application.ExeName, '.INI'));
+end;
+{--------}
+procedure TFallbackConfig.IniFree;
+begin
+ FIni.Free;
+end;
+{--------}
+procedure TFallbackConfig.SetAllowChangeDir(const Value : Boolean);
+begin
+ IniCreate;
+ try
+ FIni.WriteBool(csSection, csAllowChangeDir, Value);
+ finally
+ IniFree;
+ end;
+end;
+{--------}
+procedure TFallbackConfig.SetAutoRun(const Value : Boolean);
+begin
+ IniCreate;
+ try
+ FIni.WriteBool(csSection, csAutoRun, Value);
+ finally
+ IniFree;
+ end;
+end;
+{--------}
+procedure TFallbackConfig.SetInitialDir(const Value : string);
+begin
+ IniCreate;
+ try
+ FIni.WriteString(csSection, csInitialDir, Value);
+ finally
+ IniFree;
+ end;
+end;
+{--------}
+procedure TFallbackConfig.SetOutputDir(const Value : string);
+begin
+ IniCreate;
+ try
+ FIni.WriteString(csSection, csOutputDir, Value);
+ finally
+ IniFree;
+ end;
+end;
+{====================================================================}
+
+end.
diff --git a/components/flashfiler/sourcelaz/Rebuild210/umain.dfm b/components/flashfiler/sourcelaz/Rebuild210/umain.dfm
new file mode 100644
index 000000000..3e74e2721
Binary files /dev/null and b/components/flashfiler/sourcelaz/Rebuild210/umain.dfm differ
diff --git a/components/flashfiler/sourcelaz/Rebuild210/umain.pas b/components/flashfiler/sourcelaz/Rebuild210/umain.pas
new file mode 100644
index 000000000..851d15dc1
--- /dev/null
+++ b/components/flashfiler/sourcelaz/Rebuild210/umain.pas
@@ -0,0 +1,291 @@
+{*********************************************************}
+{* FlashFiler: Main form for FFRebuild210 *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit umain;
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
+ StdCtrls, ComCtrls, ExtCtrls;
+
+type
+ TRebuildState = (stIdle, stRunning);
+
+ TfrmMain = class(TForm)
+ pnlTop: TPanel;
+ lvTables: TListView;
+ pnlBottom: TPanel;
+ prgCurrentFile: TProgressBar;
+ prgAllFiles: TProgressBar;
+ lblPrgFile: TLabel;
+ lblPrgAllFiles: TLabel;
+ lblInitialDir: TLabel;
+ efInitialDir: TEdit;
+ pbRebuild: TButton;
+ pbClose: TButton;
+ procedure FormShow(Sender: TObject);
+ procedure pbCloseClick(Sender: TObject);
+ procedure FormClose(Sender: TObject; var Action: TCloseAction);
+ procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
+ procedure pbRebuildClick(Sender: TObject);
+ procedure efInitialDirChange(Sender: TObject);
+ procedure FormActivate(Sender: TObject);
+ private
+ { Private declarations }
+
+ { Configuration items }
+ FAllowChangeDir : Boolean;
+ FAutoRun : Boolean;
+ FInitialDir : string;
+ FOutputDir : string;
+
+ { Status variables }
+ FFirstTime : Boolean;
+ FState : TRebuildState;
+ FValidConfig : Boolean;
+
+ procedure ClearTables;
+ procedure GetTables;
+ procedure SetCtrlStates;
+
+ public
+ { Public declarations }
+ end;
+
+var
+ frmMain: TfrmMain;
+
+implementation
+
+uses
+ FileCtrl,
+ ffDB,
+ ffllBase,
+ ffclreng,
+ ffSrEng,
+ uConfig, dmMain;
+
+{$R *.DFM}
+
+const
+ csIdle = '...';
+ csRebuilding = 'Rebuilding...';
+ csRebuilt = 'Rebuilt successfully';
+
+procedure TfrmMain.FormShow(Sender: TObject);
+var
+ Config : TFallBackConfig;
+begin
+ FFirstTime := True;
+ FState := stIdle;
+ FValidConfig := True;
+ lblPrgFile.Caption := '';
+ lblPrgAllFiles.Caption := '';
+ dmRebuild := TdmRebuild.Create(nil);
+ Config := TFallBackConfig.Create;
+ try
+ FAllowChangeDir := Config.AllowChangeDir;
+ FAutoRun := Config.AutoRun;
+ FInitialDir := Config.InitialDir;
+ FOutputDir := Config.OutputDir;
+
+ { Check requirements }
+ if (FAutoRun or
+ (not FAllowChangeDir)) and
+ (FInitialDir = '') then begin
+ FValidConfig := False;
+ ShowMessage('Initial directory must be specified in configuration file.');
+ end;
+
+ if (FInitialDir <> '') and
+ (not DirectoryExists(FInitialDir)) then begin
+ FValidConfig := False;
+ ShowMessage('Directory ' + FInitialDir + ' does not exist.');
+ end;
+
+ efInitialDir.Text := FInitialDir;
+ { This line forces the list of tables to be loaded. }
+
+ finally
+ Config.Free;
+ end;
+end;
+
+procedure TfrmMain.pbCloseClick(Sender: TObject);
+begin
+ Close;
+end;
+
+procedure TfrmMain.SetCtrlStates;
+var
+ Running : Boolean;
+begin
+ Running := (FState = stRunning);
+ efInitialDir.Enabled := FValidConfig and FAllowChangeDir and (not Running);
+
+ pbRebuild.Enabled := FValidConfig and (not Running) and DirectoryExists(efInitialDir.Text);
+ pbClose.Enabled := not Running;
+end;
+
+procedure TfrmMain.GetTables;
+var
+ Inx : Integer;
+ Tables : TStringList;
+ Item : TListItem;
+begin
+ ClearTables;
+
+ Tables := TStringList.Create;
+ try
+ dmRebuild.Path := efInitialDir.Text;
+ dmRebuild.GetTables(Tables);
+
+ { Put 1 entry per table into the list view. }
+ for Inx := 0 to Pred(Tables.Count) do begin
+ Item := lvTables.Items.Add;
+ Item.Caption := Tables[Inx];
+ Item.Data := Tables.Objects[Inx];
+ Item.SubItems.Add(TffTable(Tables.Objects[Inx]).FFVersion);
+ Item.SubItems.Add(csIdle);
+ end;
+ finally
+ Tables.Free;
+ { We don't have to free the table objects because they are already
+ attached to the items in list view. }
+ end;
+end;
+
+procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
+begin
+ ClearTables;
+ dmRebuild.Free;
+end;
+
+procedure TfrmMain.ClearTables;
+var
+ Inx : Integer;
+begin
+ for Inx := Pred(lvTables.Items.Count) downto 0 do
+ TffTable(lvTables.Items[Inx].Data).Free;
+ lvTables.Items.Clear;
+end;
+
+procedure TfrmMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
+begin
+ CanClose := (FState = stIdle);
+end;
+
+type
+ SrDBCracker = class(TffSrDatabase);
+
+procedure TfrmMain.pbRebuildClick(Sender: TObject);
+var
+ Done : Boolean;
+ Count,
+ Inx : Integer;
+ Item : TListItem;
+ ServerDB : TffSrDatabase;
+ TaskID : Longint;
+ TaskStatus : TffRebuildStatus;
+begin
+ FState := stRunning;
+ try
+ SetCtrlStates;
+ { Init progress bars }
+ prgAllFiles.Max := lvTables.Items.Count;
+ prgAllFiles.Min := 0;
+ prgAllFiles.Position := 0;
+ prgCurrentFile.Min := 0;
+ prgCurrentFile.Max := 100;
+ prgCurrentFile.Position := 0;
+
+ { Force pack to open source table as 2_11. }
+ ServerDB := dmRebuild.ServerDatabase;
+ SrDBCracker(ServerDB).dbSetPackSrcTableVersion(FFVersionNumber);
+ { Assumes current version is > 2_1000. }
+
+ { Force database to create new tables as 2_10. }
+ SrDBCracker(ServerDB).dbSetNewTableVersion(FFVersion2_10);
+
+ Count := lvTables.Items.Count;
+ for Inx := 0 to Pred(Count) do begin
+ Item := lvTables.Items[Inx];
+ Item.SubItems[1] := csRebuilding;
+
+ lblPrgFile.Caption := Item.Caption;
+ lblPrgAllFiles.Caption := Format('%d of %d', [Inx + 1, Count]);
+
+ { Pack the table. }
+ TffTable(Item.Data).PackTable(TaskID);
+ { Wait until the pack is done. }
+ Done := False;
+ while not Done do begin
+ dmRebuild.Session.GetTaskStatus(TaskID, Done, TaskStatus);
+ { Update individual file progress bar }
+ prgCurrentFile.Position := TaskStatus.rsPercentDone;
+ Sleep(100);
+ Application.ProcessMessages;
+ end;
+
+ { Update all files progress bar }
+ prgAllFiles.Position := prgAllFiles.Position + 1;
+
+ Item.SubItems[0] := TffTable(Item.Data).FFVersion;
+ Item.SubItems[1] := csRebuilt;
+ end;
+ lblPrgFile.Caption := '';
+ lblPrgAllFiles.Caption := '';
+ finally
+ FState := stIdle;
+ SetCtrlStates;
+ end;
+end;
+
+procedure TfrmMain.efInitialDirChange(Sender: TObject);
+begin
+ SetCtrlStates;
+ if DirectoryExists(efInitialDir.Text) then
+ GetTables
+ else
+ ClearTables;
+end;
+
+procedure TfrmMain.FormActivate(Sender: TObject);
+begin
+ SetCtrlStates;
+ if FValidConfig and FFirstTime and FAutoRun then begin
+ FFirstTime := False;
+ pbRebuildClick(nil);
+ end;
+end;
+
+end.
diff --git a/components/flashfiler/sourcelaz/Verify/FFChain.pas b/components/flashfiler/sourcelaz/Verify/FFChain.pas
new file mode 100644
index 000000000..94e4a0be1
--- /dev/null
+++ b/components/flashfiler/sourcelaz/Verify/FFChain.pas
@@ -0,0 +1,744 @@
+{*********************************************************}
+{* FlashFiler: Chain manager *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+{ TODO::
+ - Implement adding of block
+ - Implement review of chains
+}
+
+unit FFChain;
+
+interface
+
+uses
+ Classes,
+ FFLLBase;
+
+type
+ TffChainMgr = class; { forward declaration }
+ TffChainItem = class; { forward declaration }
+
+ TffRefMode = (rmNext, rmPrev, rmBoth);
+
+ TffChain = class
+ protected
+ FOwner : TffChainMgr;
+ public
+ PrevChain : TffChain;
+ NextChain : TffChain;
+ HeadItem : TffChainItem;
+ TailItem : TffChainItem;
+
+ constructor Create(Owner : TffChainMgr);
+ destructor Destroy; override;
+
+ procedure AppendItem(NewItem : TffChainItem);
+ { Append the specified item to the chain. }
+
+ function FindItem(const ThisBlock : TffWord32) : TffChainItem;
+ { Find an item with the given block number. }
+
+ function FindItemPointingTo(const ThisBlock : TffWord32;
+ const Mode : TffRefMode) : TffChainItem;
+ { Find an item pointing to the specified block number. }
+
+ procedure InsertHead(NewHead : TffChainItem);
+ { Insert a new head item into the chain. }
+
+ procedure RemoveItem(Item : TffChainItem);
+ { Remove the specified item from the chain. }
+
+ end;
+
+ TffChainItem = class
+ protected
+ FOwner : TffChain;
+ public
+ NextItem,
+ PrevItem : TffChainItem;
+ ThisBlock : TffWord32;
+ NextBlock : TffWord32;
+ PrevBlock : TffWord32;
+
+ constructor Create(Owner : TffChain);
+ destructor Destroy; override;
+ end;
+
+ TffLinkCallback = procedure(const Block1Num, Block2Num : TffWord32) of object;
+ { Called when two blocks are linked together. }
+
+ TffMoveCallback = procedure(const BlockMoved, PrevBlock : TffWord32) of object;
+ { Called when an orphan is moved to the end of the chain. }
+
+ TffChainMgr = class
+ protected
+ FPopulated : Boolean;
+ OrphanChain : TffChain;
+ HeadChain : TffChain;
+ TailChain : TffChain;
+
+ procedure AppendChain(NewChain : TffChain);
+ function GetHasOrphans : Boolean;
+ function GetHasValidChain : Boolean;
+ function GetLastBlockNumber : TffWord32;
+ function GetLastNextBlockNumber : TffWord32;
+ procedure RemoveReference(const BlockNum : TffWord32;
+ Item : TffChainItem;
+ const AdjustChain : Boolean);
+
+ public
+ constructor Create;
+ destructor Destroy; override;
+ procedure AddBlock(const ThisBlock, NextBlock, PrevBlock : TffWord32);
+
+ procedure Clear;
+ { Removes the current chains from the chain manager. }
+
+ function Describe : TStringList;
+ { Returns a string list describing the chains. }
+
+ function FindItem(const BlockNum : TffWord32;
+ var PrevBlock, NextBlock : TffWord32) : Boolean;
+ { Use this method to determine if a block is listed in the chain manager.
+ If it is not listed, this function returns False. Otherwise, this
+ function returns True. It fills PrevBlock with the block number of
+ the previous block in the chain (or ffc_W32NoValue if there is no
+ previous block) and fills NextBlock with the block number of the next
+ block (or ffc_W32NoValue for no next block). }
+
+ procedure Fixup;
+ { If there is only 1 block in the orphan chain & no blocks in other chains
+ then we have the case where there is only 1 free block or 1 data block
+ in the table. Move the orphan to its own chain. }
+
+ procedure LinkChains(CallBack : TffLinkCallback);
+ { Use this method to have the chain manager link together all of its
+ chains. Does not affect the orphan chain. }
+
+ procedure MoveOrphansToTail(Callback : TffMoveCallBack);
+ { Use this method to have the chain manager append all of the orphans
+ in the orphan chain to the last chain. }
+
+ function Referenced(const BlockNum : TffWord32;
+ const RemoveRef : Boolean;
+ var ReferencingBlockNum : TffWord32) : Boolean;
+ { Returns True if the specified BlockNum is referenced as a Prev or Next
+ block in the chain manager. If it is referenced then this function
+ returns True and places the block number of the referencing block in
+ the ReferencingBlockNum param. If the RemoveRef parameter is set to True
+ then the reference to the block number in the chain manager is set to
+ the value ffc_W32NoValue. }
+
+ property HasOrphans : Boolean
+ read GetHasOrphans;
+
+ property HasValidChain : Boolean
+ read GetHasValidChain;
+
+ property LastBlockNumber : TffWord32
+ read GetLastBlockNumber;
+ { Returns the block number of the last block. }
+
+ property LastBlockNextBlockNumber : TffWord32
+ read GetLastNextBlockNumber;
+ { Returns the next block number of the last block in the chain. }
+
+ property Populated : Boolean
+ read FPopulated write FPopulated;
+ { Returns True if the chain manager has been fully populated with data. }
+
+ end;
+
+implementation
+
+uses
+ SysUtils;
+
+{===TffChainMgr======================================================}
+constructor TffChainMgr.Create;
+begin
+ inherited;
+ FPopulated := False;
+end;
+{--------}
+destructor TffChainMgr.Destroy;
+begin
+ Clear;
+ inherited;
+end;
+{--------}
+procedure TffChainMgr.AddBlock(const ThisBlock, NextBlock, PrevBlock : TffWord32);
+var
+ Item,
+ OrphanItem : TffChainItem;
+ Chain,
+ NewChain : TffChain;
+begin
+ { Create an item for the block. }
+ Item := TffChainItem.Create(nil);
+ Item.ThisBlock := ThisBlock;
+ Item.NextBlock := NextBlock;
+ Item.PrevBlock := PrevBlock;
+
+ { Step 1: Does this block point to an orphan? If so then grab the orphan.
+ We may be able to move the new block and the orphan to an existing chain
+ or at least start a new chain.}
+ OrphanItem := nil;
+ if OrphanChain <> nil then begin
+ OrphanItem := OrphanChain.FindItem(NextBlock);
+ { If found an orphan then remove it from the orphan chain. }
+ if Assigned(OrphanItem) then
+ OrphanChain.RemoveItem(OrphanItem);
+ end; { if }
+
+ { Step 2: If this block didn't point to an orphan, see if an orphan points
+ to this block. }
+ if (OrphanItem = nil) and (OrphanChain <> nil) then begin
+ OrphanItem := OrphanChain.FindItemPointingTo(ThisBlock, rmNext);
+ if Assigned(OrphanItem) then begin
+ { Remove the orphan from the orphan chain. }
+ OrphanChain.RemoveItem(OrphanItem);
+
+ { Start a new chain. }
+ NewChain := TffChain.Create(Self);
+ AppendChain(NewChain);
+
+ { Add the orphan to the new chain. }
+ NewChain.AppendItem(OrphanItem);
+
+ { Add the new chain item to the new chain. }
+ NewChain.AppendItem(Item);
+
+ Exit;
+ end; { if }
+ end; { if }
+
+ { Step 3 : If the block does not point to an orphan, does it point to the
+ head of an existing chain? If so then add it to the beginning of that
+ chain. }
+ if OrphanItem = nil then begin
+ Chain := HeadChain;
+ while Assigned(Chain) and (Chain.HeadItem.ThisBlock <> NextBlock) do
+ Chain := Chain.NextChain;
+ if Assigned(Chain) then begin
+ Chain.InsertHead(Item);
+ Exit;
+ end; { if }
+ end;
+
+ { Step 4 : If the block does not point to a head of an existing chain, does
+ the tail of an existing chain point to the block? If so then add it to the
+ end of that chain. Bring along an orphan if one was pulled in Step 1. }
+ Chain := HeadChain;
+ while Assigned(Chain) and (Chain.TailItem.NextBlock <> ThisBlock) do
+ Chain := Chain.NextChain;
+
+ if Assigned(Chain) then begin
+ Chain.AppendItem(Item);
+ if Assigned(OrphanItem) then
+ Chain.AppendItem(OrphanItem);
+ end
+ else begin
+ { There are no chains where a tail points to this block. If found an
+ associated orphan in Step 1 then start a new chain. Otherwise, add this
+ block to the list of orphans. }
+ if Assigned(OrphanItem) then begin
+ { Start a new chain. }
+ NewChain := TffChain.Create(Self);
+ AppendChain(NewChain);
+
+ { Add the new chain item to the new chain. }
+ NewChain.AppendItem(Item);
+
+ { Add the orphan to the new chain. }
+ NewChain.AppendItem(OrphanItem);
+ end
+ else begin
+ if OrphanChain = nil then
+ OrphanChain := TffChain.Create(Self);
+ OrphanChain.AppendItem(Item);
+ end; { if..else }
+ end;
+end;
+{--------}
+procedure TffChainMgr.AppendChain(NewChain : TffChain);
+begin
+ if TailChain = nil then begin
+ HeadChain := NewChain;
+ TailChain := HeadChain;
+ end
+ else begin
+ { Point the last chain to the new chain, and vice versa. }
+ TailChain.NextChain := NewChain;
+ NewChain.PrevChain := TailChain;
+ TailChain := NewChain;
+ end;
+end;
+{--------}
+procedure TffChainMgr.Clear;
+var
+ Chain,
+ NextChain : TffChain;
+begin
+ OrphanChain.Free;
+ OrphanChain := nil;
+
+ Chain := HeadChain;
+ while Chain <> nil do begin
+ NextChain := Chain.NextChain;
+ Chain.Free;
+ Chain := NextChain;
+ end; { while }
+ HeadChain := nil;
+ TailChain := nil;
+end;
+{--------}
+function TffChainMgr.Describe : TStringList;
+var
+ Chain : TffChain;
+ Item : TffChainItem;
+ Inx,
+ Count : Integer;
+begin
+ Result := TStringList.Create;
+ try
+ { Orphaned blocks }
+ if (OrphanChain <> nil) and (OrphanChain.HeadItem <> nil) then begin
+ Result.Add('Orphaned blocks:');
+ Item := OrphanChain.HeadItem;
+ while Item <> nil do begin
+ Result.Add(Format('Block: %d, next block: %d, prev block: %d',
+ [Item.ThisBlock, Item.NextBlock, Item.PrevBlock]));
+ Item := Item.NextItem;
+ end; { while }
+ end
+ else
+ Result.Add('No orphaned blocks');
+
+ { Other blocks. First, count the number of chains. }
+ Count := 0;
+ Chain := HeadChain;
+ while Chain <> nil do begin
+ inc(Count);
+ Chain := Chain.NextChain;
+ end; { while }
+
+ { Now step through the chains. }
+ Result.Add('');
+ if Count = 0 then
+ Result.Add('No chains')
+ else begin
+ Chain := HeadChain;
+ Inx := 0;
+ while Chain <> nil do begin
+ inc(Inx);
+ Result.Add(Format('Chain %d of %d', [Inx, Count]));
+ { Display information about the first block & the last block in the
+ chain. }
+ Item := Chain.HeadItem;
+ if (Item <> nil) then begin
+ if (Chain.HeadItem = Chain.TailItem) then begin
+ Result.Add(Format('There is 1 block in this chain, block: %d, ' +
+ 'next block: %d, prev Block: %d',
+ [Item.ThisBlock, Item.NextBlock, Item.PrevBlock]));
+ end
+ else begin
+ Result.Add(Format('Head, block: %d, next block: %d, prev block: %d',
+ [Item.ThisBlock, Item.NextBlock, Item.PrevBlock]));
+ Item := Chain.TailItem;
+ Result.Add(Format('Tail, block: %d, next block: %d, prev block: %d',
+ [Item.ThisBlock, Item.NextBlock, Item.PrevBlock]));
+ end;
+ end; { if }
+
+ Chain := Chain.NextChain;
+ end; { while }
+ end;
+
+ except
+ Result.Free;
+ raise;
+ end;
+end;
+{--------}
+function TffChainMgr.FindItem(const BlockNum : TffWord32;
+ var PrevBlock, NextBlock : TffWord32) : Boolean;
+var
+ Item : TffChainItem;
+ Chain : TffChain;
+begin
+ Result := False;
+ PrevBlock := ffc_W32NoValue;
+ NextBlock := ffc_W32NoValue;
+
+ { Look in the orphans first. }
+ Item := OrphanChain.FindItem(BlockNum);
+ if Item = nil then begin
+ { Not an orphan. Look in the other chains. }
+ Chain := HeadChain;
+ while (Chain <> nil) do begin
+ Item := Chain.FindItem(BlockNum);
+ if Item <> nil then begin
+ Result := True;
+ PrevBlock := Item.PrevBlock;
+ NextBlock := Item.NextBlock;
+ Break;
+ end; { if }
+ Chain := Chain.NextChain;
+ end;
+ end
+ else
+ Result := True;
+end;
+{--------}
+procedure TffChainMgr.Fixup;
+var
+ Item : TffChainItem;
+ Chain : TffChain;
+begin
+ { If the orphan chain contains only 1 block & there are no other chains
+ being managed then we have a valid chain with one block. Move the block
+ from the orphan chain to a new chain. }
+ if Assigned(OrphanChain) and
+ Assigned(OrphanChain.HeadItem) and
+ (OrphanChain.HeadItem = OrphanChain.TailItem) and
+ (HeadChain = nil) then begin
+
+ Item := OrphanChain.HeadItem;
+ OrphanChain.RemoveItem(Item);
+
+ Chain := TffChain.Create(Self);
+ AppendChain(Chain);
+ Chain.AppendItem(Item);
+ end; { if }
+end;
+{--------}
+function TffChainMgr.GetHasOrphans : Boolean;
+begin
+ Result := (OrphanChain <> nil) and (OrphanChain.HeadItem <> nil);
+end;
+{--------}
+function TffChainMgr.GetHasValidChain : Boolean;
+begin
+ { The chain is valid if the following conditions are met:
+ There are no orphans
+ - AND either of the following -
+ 1. There are no data blocks
+ - OR -
+ 2. There is only 1 chain in the chain manager.
+ }
+ Result := (not GetHasOrphans) and
+ (
+ (HeadChain = nil) or
+
+ ((HeadChain.HeadItem <> nil) and
+ (HeadChain = TailChain)
+ )
+ );
+end;
+{--------}
+function TffChainMgr.GetLastBlockNumber : TffWord32;
+begin
+ if Assigned(TailChain) and
+ Assigned(TailChain.TailItem) then
+ Result := TailChain.TailItem.ThisBlock
+ else
+ Result := ffc_W32NoValue;
+end;
+{--------}
+function TffChainMgr.GetLastNextBlockNumber : TffWord32;
+begin
+ if Assigned(TailChain) and
+ Assigned(TailChain.TailItem) then
+ Result := TailChain.TailItem.NextBlock
+ else
+ Result := ffc_W32NoValue;
+end;
+{--------}
+function TffChainMgr.Referenced(const BlockNum : TffWord32;
+ const RemoveRef : Boolean;
+ var ReferencingBlockNum : TffWord32) : Boolean;
+var
+ Item : TffChainItem;
+ Chain : TffChain;
+begin
+ Result := False;
+ ReferencingBlockNum := ffc_W32NoValue;
+
+ { Search the orphan chain. }
+ if OrphanChain <> nil then begin
+ Item := OrphanChain.FindItemPointingTo(BlockNum, rmBoth);
+ if Item <> nil then begin
+ Result := True;
+ ReferencingBlockNum := Item.ThisBlock;
+ if RemoveRef then
+ RemoveReference(BlockNum, Item, False);
+ end; { if }
+ end; { if }
+
+ if not Result then begin
+ Chain := HeadChain;
+ while Chain <> nil do begin
+ Item := Chain.FindItemPointingTo(BlockNum, rmBoth);
+ if Item <> nil then begin
+ Result := True;
+ ReferencingBlockNum := Item.ThisBlock;
+ if RemoveRef then
+ RemoveReference(BlockNum, Item, True);
+ Break;
+ end
+ else
+ Chain := Chain.NextChain;
+ end; { while }
+ end; { if..else }
+end;
+{--------}
+procedure TffChainMgr.LinkChains(CallBack : TffLinkCallback);
+var
+ NextChain,
+ Chain : TffChain;
+ Block1Num,
+ Block2Num : TffWord32;
+begin
+ if HeadChain <> nil then begin
+ Chain := HeadChain.NextChain;
+ while Chain <> nil do begin
+ NextChain := Chain.NextChain;
+ Block1Num := HeadChain.TailItem.ThisBlock;
+ Block2Num := Chain.HeadItem.ThisBlock;
+
+ { Connect the last item in the head chain to the first item in the current
+ chain. }
+ HeadChain.TailItem.NextItem := Chain.HeadItem;
+ HeadChain.TailItem.NextBlock := Chain.HeadItem.ThisBlock;
+
+ { Point the first item in the current chain back to the head chain's tail
+ item. }
+ Chain.HeadItem.PrevItem := HeadChain.TailItem;
+ Chain.HeadItem.PrevBlock := HeadChain.TailItem.ThisBlock;
+
+ { Update the head chain's tail item. }
+ HeadChain.TailItem := Chain.TailItem;
+
+ if Assigned(CallBack) then
+ CallBack(Block1Num, Block2Num);
+
+ { Remove all associations the current chain has with its items. }
+ Chain.HeadItem := nil;
+ Chain.TailItem := nil;
+
+ { Free the chain. }
+ Chain.Free;
+
+ { Move to the next chain. }
+ Chain := NextChain;
+ end;
+
+ { There should be no more chains after the head chain. }
+ HeadChain.NextChain := nil;
+ TailChain := HeadChain;
+ end; { if }
+end;
+{--------}
+procedure TffChainMgr.MoveOrphansToTail(Callback : TffMoveCallBack);
+var
+ BlockNum, PrevBlock : TffWord32;
+ NextItem,
+ Item : TffChainItem;
+begin
+ Item := OrphanChain.TailItem;
+ while Item <> nil do begin
+ NextItem := Item.NextItem;
+ BlockNum := Item.ThisBlock;
+ PrevBlock := TailChain.TailItem.ThisBlock;
+ OrphanChain.RemoveItem(Item);
+ TailChain.AppendItem(Item);
+ if Assigned(Callback) then
+ Callback(BlockNum, PrevBlock);
+ Item := NextItem;
+ end; { while }
+end;
+{--------}
+procedure TffChainMgr.RemoveReference(const BlockNum : TffWord32;
+ Item : TffChainItem;
+ const AdjustChain : Boolean);
+begin
+ if Item.PrevBlock = BlockNum then begin
+ if AdjustChain and (Item.PrevItem <> nil) then begin
+ Assert(false, 'Unhandled case. Please report to FlashFiler team.');
+ end;
+ Item.PrevBlock := ffc_W32NoValue;
+ end
+ else begin
+ if AdjustChain and (Item.NextItem <> nil) then begin
+ Assert(false, 'Unhandled case. Please report to FlashFiler team.');
+ end;
+ Item.NextBlock := ffc_W32NoValue;
+ end;
+end;
+{====================================================================}
+
+{===TffChain=========================================================}
+constructor TffChain.Create(Owner : TffChainMgr);
+begin
+ inherited Create;
+ FOwner := Owner;
+end;
+{--------}
+destructor TffChain.Destroy;
+var
+ Item,
+ NextItem : TffChainItem;
+begin
+ inherited;
+ Item := HeadItem;
+ while Item <> nil do begin
+ NextItem := Item.NextItem;
+ Item.Free;
+ Item := NextItem;
+ end; { while }
+end;
+{--------}
+procedure TffChain.AppendItem(NewItem : TffChainItem);
+begin
+ { If no tail then this chain is empty. }
+ if TailItem = nil then begin
+ HeadItem := NewItem;
+ TailItem := NewItem;
+ end
+ else begin
+ { Otherwise, append the item to the tail. }
+ TailItem.NextItem := NewItem;
+ NewItem.PrevItem := TailItem;
+ TailItem := NewItem;
+ end;
+ NewItem.FOwner := Self;
+end;
+{--------}
+function TffChain.FindItem(const ThisBlock : TffWord32) : TffChainItem;
+begin
+ Result := HeadItem;
+ while (Result <> nil) and (Result.ThisBlock <> ThisBlock) do
+ Result := Result.NextItem;
+end;
+{--------}
+function TffChain.FindItemPointingTo(const ThisBlock : TffWord32;
+ const Mode : TffRefMode) : TffChainItem;
+begin
+ Result := HeadItem;
+ case Mode of
+ rmNext :
+ while (Result <> nil) and (Result.NextBlock <> ThisBlock) do
+ Result := Result.NextItem;
+ rmPrev :
+ while (Result <> nil) and (Result.PrevBlock <> ThisBlock) do
+ Result := Result.NextItem;
+ rmBoth :
+ while (Result <> nil) and (Result.NextBlock <> ThisBlock) and
+ (Result.PrevBlock <> ThisBlock) do
+ Result := Result.NextItem;
+ end; { case }
+end;
+{--------}
+procedure TffChain.InsertHead(NewHead : TffChainItem);
+begin
+ if HeadItem = nil then begin
+ HeadItem := NewHead;
+ TailItem := NewHead;
+ end
+ else begin
+ { Point the head to the new head, and vice versa. }
+ HeadItem.PrevItem := NewHead;
+ NewHead.NextItem := HeadItem;
+ HeadItem := NewHead;
+ end;
+end;
+{--------}
+procedure TffChain.RemoveItem(Item : TffChainItem);
+var
+ CurItem : TffChainItem;
+begin
+ { If this is the head item then the next item is the new head. }
+ if Item = HeadItem then begin
+ HeadItem := Item.NextItem;
+ { If there is a new head then set its prevItem to nil. }
+ if Assigned(HeadItem) then
+ HeadItem.PrevItem := nil
+ else
+ { Otherwise the chain is empty so set the tail to nil. }
+ TailItem := nil;
+ end
+ { If this is not the head but it is the tail then the previous item is the
+ new tail. }
+ else if Item = TailItem then begin
+ TailItem := Item.PrevItem;
+ { If there is a new tail then set its NextItem to nil. }
+ if Assigned(TailItem) then
+ TailItem.NextItem := nil
+ else
+ { Otherwise the chain is empty so set the head to nil. }
+ HeadItem := nil;
+ end
+ else begin
+ { This item is somewhere between the head & tail. Scan for it. }
+ CurItem := HeadItem;
+ while CurItem <> Item do
+ CurItem := CurItem.NextItem;
+ if Assigned(CurItem) then begin
+ { Point the previous item to the next item. }
+ CurItem.PrevItem.NextItem := CurItem.NextItem;
+ { Point the next item to the previous item. }
+ CurItem.NextItem.PrevItem := CurItem.PrevItem;
+ end; { if }
+ end;
+
+ { Nil out the item's pointers. }
+ Item.NextItem := nil;
+ Item.PrevItem := nil;
+ Item.FOwner := nil;
+end;
+{====================================================================}
+
+{===TffChainItem=====================================================}
+constructor TffChainItem.Create(Owner : TffChain);
+begin
+ inherited Create;
+ FOwner := Owner;
+end;
+{--------}
+destructor TffChainItem.Destroy;
+begin
+ inherited;
+ { TODO }
+end;
+{====================================================================}
+
+end.
diff --git a/components/flashfiler/sourcelaz/Verify/FFVerify.dpr b/components/flashfiler/sourcelaz/Verify/FFVerify.dpr
new file mode 100644
index 000000000..abce5fbd7
--- /dev/null
+++ b/components/flashfiler/sourcelaz/Verify/FFVerify.dpr
@@ -0,0 +1,47 @@
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+program FFVerify;
+
+uses
+ Forms,
+ frMain in 'frMain.pas' {frmMain},
+ ffrepair in 'ffrepair.pas',
+ ffv2file in 'ffv2file.pas',
+ ffFileInt in 'ffFileInt.pas',
+ ffrepcnst in 'ffrepcnst.pas',
+ frmBlock in 'frmBlock.pas' {frmBlockNum},
+ FFChain in 'FFChain.pas',
+ frmOptions in 'frmOptions.pas' {frmOptionsConfig};
+
+{$R *.res}
+
+begin
+ Application.Initialize;
+ Application.Title := 'FlashFiler Table Repair';
+ Application.CreateForm(TfrmMain, frmMain);
+ Application.CreateForm(TfrmOptionsConfig, frmOptionsConfig);
+ Application.Run;
+end.
diff --git a/components/flashfiler/sourcelaz/Verify/FFVerify.res b/components/flashfiler/sourcelaz/Verify/FFVerify.res
new file mode 100644
index 000000000..55f874204
Binary files /dev/null and b/components/flashfiler/sourcelaz/Verify/FFVerify.res differ
diff --git a/components/flashfiler/sourcelaz/Verify/ffFileInt.pas b/components/flashfiler/sourcelaz/Verify/ffFileInt.pas
new file mode 100644
index 000000000..d94da99dd
--- /dev/null
+++ b/components/flashfiler/sourcelaz/Verify/ffFileInt.pas
@@ -0,0 +1,1527 @@
+{*********************************************************}
+{* FlashFiler: FF 2 file interface definition *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffFileInt;
+
+interface
+
+uses
+ Dialogs,
+ Classes,
+ FFLLBase,
+ FFSrBase,
+ FFTBDict;
+
+type
+ TffBlockType = (btUnknown, btFileHeader, btIndexHeader, btData,
+ btIndex, btBLOB, btStream, btFree);
+
+{===Interface declarations===========================================}
+
+ ICommonBlock = interface; { forward declaration }
+ TffFileInterface = class; { forward declaration }
+ TffGeneralFileInfo = class; { forward declaration }
+
+ { Event declarations }
+
+ TffGetInfoEvent = procedure(var Info : TffGeneralFileInfo) of object;
+ { This event is raised by a block when it needs to
+ obtain information about the file containing the block. }
+
+ TffReportErrorEvent = procedure(Block : ICommonBlock;
+ const ErrCode : Integer;
+ const ErrorStr : string) of object;
+ { This event is raised when an error is encountered during verification
+ of a block. It may be raised during both verification & repair. ErrCode
+ is the type of error encountered (see unit FFREPCNST for specific error
+ codes) and ErrorStr is an informative string describing the error. }
+
+ TffReportFixEvent = procedure(Block : ICommonBlock;
+ const ErrCode : Integer;
+ const RepairStr : string) of object;
+ { This event is raised when an error in a block is repaired. ErrCode is
+ the type of error encountered (see unit FFREPCNST for specific error
+ codes) and RepairStr is an informative string describing how the
+ error was fixed. }
+
+ TffReportRebuildProgressEvent = procedure(FileInterface : TffFileInterface;
+ Position, Maximum : Integer) of object;
+ { This event should be raised by the file interface while it is packing
+ or reindexing the table. }
+
+ ICommonBlock = interface
+ ['{D23CBB0D-375D-4125-9FE6-E543B651B665}']
+ { Common interface to a file block. Other interfaces specific to block
+ types are defined below. }
+
+ procedure BeginUpdate;
+ { Call this method prior to updating a file block. }
+ procedure EndUpdate;
+ { Call this method to commit changes to a file block. }
+
+ function GetBlockNum : TffWord32;
+ function GetBlockType : TffBlockType;
+ function GetLSN : TffWord32;
+ function GetNextBlock : TffWord32;
+ function GetOnGetInfo : TffGetInfoEvent;
+ function GetOnReportError : TffReportErrorEvent;
+ function GetOnReportFix : TffReportFixEvent;
+ function GetRawData : PffBlock;
+ function GetSignature : Longint;
+ function GetThisBlock : TffWord32;
+
+ { Property access }
+ function GetPropertyCell(const Row, Column : Integer) : string;
+ function GetPropertyColCaption(const Index : Integer) : string;
+ function GetPropertyColCount : Integer;
+ function GetPropertyColWidth(const Index : Integer) : Integer;
+ function GetPropertyRowCount : Integer;
+
+ { Data access }
+ function GetDataCell(const Row, Column : Integer) : string;
+ function GetDataColCaption(const Index : Integer) : string;
+ function GetDataColCount : Integer;
+ function GetDataColWidth(const Index : Integer) : Integer;
+ function GetDataRowCount : Integer;
+
+ function MapBlockTypeToStr(const BlockType : TffBlockType) : string;
+ function MapFlagsToStr(const Flags : Byte) : string;
+ function MapSigToStr(const Signature : Longint) : string;
+
+ procedure SetLSN(const Value : TffWord32);
+ procedure SetNextBlock(const Value : TffWord32);
+ procedure SetOnGetInfo(Value : TffGetInfoEvent);
+ procedure SetOnReportError(Value : TffReportErrorEvent);
+ procedure SetOnReportFix(Value : TffReportFixEvent);
+ procedure SetSignature(const Value : Longint);
+ procedure SetThisBlock(const Value : TffWord32);
+
+ procedure Repair;
+ { Call this method to have a block verify itself & repair any flaws it
+ can repair on its own. }
+
+ procedure Verify;
+ { Call this method to have a block verify itself. }
+
+ { Properties }
+ property BlockNum : TffWord32
+ read GetBlockNum;
+
+ property BlockType : TffBlockType
+ read GetBlockType;
+
+ property LSN : TffWord32
+ read GetLSN write SetLSN;
+
+ property NextBlock : TffWord32
+ read GetNextBlock write SetNextBlock;
+
+ property OnGetInfo : TffGetInfoEvent
+ read GetOnGetInfo write SetOnGetInfo;
+ { This event is raised when a block needs to obtain information about its
+ parent file. }
+
+ property OnReportError : TffReportErrorEvent
+ read GetOnReportError write SetOnReportError;
+ { This event is raised when an error is detected in the block. It may
+ be raised during both verification & repair. }
+
+ property OnReportFix : TffReportFixEvent
+ read GetOnReportFix write SetOnReportFix;
+ { This event is raised when an error is fixed. It is raised only during
+ the repair of a file. }
+
+ property RawData : PffBlock
+ read GetRawData;
+
+ property Signature : Longint
+ read GetSignature write SetSignature;
+
+ property ThisBlock : TffWord32
+ read GetThisBlock write SetThisBlock;
+
+ { Property access }
+ property PropertyCell[const Row, Column : Integer] : string
+ read GetPropertyCell;
+ { Returns the contents of the specified cell in the property view for
+ this block. The Row and Column values are zero-based. }
+
+ property PropertyColCaption[const Index : Integer] : string
+ read GetPropertyColCaption;
+ { Returns the suggested caption for the specified column. The Index
+ parameter is zero-based. }
+
+ property PropertyColCount : Integer
+ read GetPropertyColCount;
+ { The number of columns in the property view for this block. }
+
+ property PropertyColWidth[const Index : Integer] : Integer
+ read GetPropertyColWidth;
+ { Returns the suggested width for the specified column. The Index
+ parameter is zero-based. }
+
+ property PropertyRowCount : Integer
+ read GetPropertyRowCount;
+ { The number of property rows in the view for this block. }
+
+ { Data access }
+ property DataCell[const Row, Column : Integer] : string
+ read GetDataCell;
+ { Returns the contents of the specified cell in the data view for this
+ block. The Row and Column values are zero-based. }
+
+ property DataColCaption[const Index : Integer] : string
+ read GetDataColCaption;
+ { Returns the suggested caption for the specified column. The Index
+ parameter is zero-based. }
+
+ property DataColCount : Integer
+ read GetDataColCount;
+ { The number of columns in the data view for this block. }
+
+ property DataColWidth[const Index : Integer] : Integer
+ read GetDataColWidth;
+ { Returns the suggested width for the specified column. The Index
+ parameter is zero-based. }
+
+ property DataRowCount : Integer
+ read GetDataRowCount;
+ { The number of data rows in the view for this block. }
+
+ end;
+
+ IFileHeaderBlock = interface(ICommonBlock)
+ ['{51157301-A9FA-4CBB-90A7-8FA30E8C17B9}']
+ function GetAvailBlocks : Longint;
+ function GetBLOBCount : TffWord32;
+ function GetBlockSize : Longint;
+ function GetDataDictBlockNum : TffWord32;
+ function GetDeletedBLOBHead : TffInt64;
+ function GetDeletedBLOBTail : TffInt64;
+ function GetDeletedRecordCount : Longint;
+ function GetEncrypted : Longint;
+ function GetEstimatedUsedBlocks : TffWord32;
+ function GetFFVersion : Longint;
+ function GetFieldCount : Longint;
+ function GetFirstDataBlock : TffWord32;
+ function GetFirstDeletedRecord : TffInt64;
+ function GetFirstFreeBlock : TffWord32;
+ function GetHasSequentialIndex : Longint;
+ function GetIndexCount : Longint;
+ function GetIndexHeaderBlockNum : TffWord32;
+ function GetLastAutoIncValue : TffWord32;
+ function GetLastDataBlock : TffWord32;
+ function GetLog2BlockSize : TffWord32;
+ function GetRecLenPlusTrailer : Longint;
+ function GetRecordCount : Longint;
+ function GetRecordLength : Longint;
+ function GetRecordsPerBlock : Longint;
+ function GetUsedBlocks : TffWord32;
+
+ procedure SetFirstDataBlock(const Value : TffWord32);
+ procedure SetFirstFreeBlock(const Value : TffWord32);
+ procedure SetHasSequentialIndex(const Value : Longint);
+ procedure SetLastDataBlock(const Value : TffWord32);
+ procedure SetLog2BlockSize(const Value : TffWord32);
+ procedure SetUsedBlocks(const Value : TffWord32);
+
+ property AvailBlocks : Longint
+ read GetAvailBlocks;
+ { The number of free blocks in the file. }
+
+ property BLOBCount : TffWord32
+ read GetBLOBCount;
+ { The number of BLOBs in the table. }
+
+ property BlockSize : Longint
+ read GetBlockSize;
+ { Size of blocks in bytes (e.g., 4k, 8k, 16k, 32k, 64k) }
+
+ property DataDictBlockNum : TffWord32
+ read GetDataDictBlockNum;
+ { The block number of the data dictionary. If there is no data
+ dictionary then this property returns the value zero. }
+
+ property DeletedBLOBHead : TffInt64
+ read GetDeletedBLOBHead;
+ { The file-relative offset of the first segment in the deleted BLOB
+ chain. }
+
+ property DeletedBLOBTail : TffInt64
+ read GetDeletedBLOBTail;
+ { The file-relative offset of the last segment in the deleted BLOB
+ chain. }
+
+ property DeletedRecordCount : Longint
+ read GetDeletedRecordCount;
+ { The number of deleted records in the table. }
+
+ property Encrypted : Longint
+ read GetEncrypted;
+ { 0 = not encrypted, 1 = encrypted }
+
+ property EstimatedUsedBlocks : TffWord32
+ read GetEstimatedUsedBlocks;
+ { For cases where the UsedBlocks counter is invalid, use this property
+ to estimate the number of used blocks in the file. }
+
+ property FFVersion : Longint
+ read GetFFVersion;
+ { The version of FlashFiler with which this table was created. }
+
+ property FieldCount : Longint
+ read GetFieldCount;
+ { The number of fields in a record. }
+
+ property FirstDataBlock : TffWord32
+ read GetFirstDataBlock write SetFirstDataBlock;
+ { The first data block in the chain of data blocks. }
+
+ property FirstDeletedRecord : TffInt64
+ read GetFirstDeletedRecord;
+ { The offset of the first record in the deleted record chain. }
+
+ property FirstFreeBlock : TffWord32
+ read GetFirstFreeBlock write SetFirstFreeBlock;
+ { The block number of the first free block in the deleted block chain. }
+
+ property HasSequentialIndex : Longint
+ read GetHasSequentialIndex write SetHasSequentialIndex;
+ { Identifies whether the table has a sequential index. A value of zero
+ means the table does not have a sequential index. A value of 1
+ means the table does have a sequential index. }
+
+ property IndexCount : Longint
+ read GetIndexCount;
+ { The number of indexes in the table. }
+
+ property IndexHeaderBlockNum : TffWord32
+ read GetIndexHeaderBlockNum;
+ { The block number of the index header. }
+
+ property LastAutoIncValue : TffWord32
+ read GetLastAutoIncValue;
+ { The last autoincrement value assigned to a record in the table. }
+
+ property LastDataBlock : TffWord32
+ read GetLastDataBlock write SetLastDataBlock;
+ { The last data block in the chain of data blocks. }
+
+ property Log2BlockSize : TffWord32
+ read GetLog2BlockSize write SetLog2BlockSize;
+ { log base 2 of BlockSize (e.g., 12, 13, 14, 15, or 16) }
+
+ property RecordCount : Longint
+ read GetRecordCount;
+ { The number of records in the table. }
+
+ property RecordLength : Longint
+ read GetRecordLength;
+ { The length of the record in bytes. }
+
+ property RecordLengthPlusTrailer : Longint
+ read GetRecLenPlusTrailer;
+ { The length of the record plus the deletion link. }
+
+ property RecordsPerBlock : Longint
+ read GetRecordsPerBlock;
+ { The number of records per data block. }
+
+ property UsedBlocks : TffWord32
+ read GetUsedBlocks write SetUsedBlocks;
+ { The number of blocks in the file. }
+
+ end;
+
+ TffGeneralFileInfo = class
+ protected
+ { The following vars identify the BLOB fields in a record. }
+ FBLOBFldCount : Integer;
+ { The number of BLOB fields found. }
+ FBLOBFlds : array[0..1023] of Integer;
+ { Contains field number (zero-based) of each BLOB field. }
+ FBLOBFldName : array[0..1023] of string;
+ { Contains field description for each BLOB field. Each element of the
+ array has a one-to-one correspondence with the same element in the
+ BLOBFlds array. }
+
+ { The following vars identify key fields for error reporting purposes. }
+ FKeyFldCount : Integer;
+ { The number of key fields found. }
+ FKeyFlds : array[0..127] of Integer;
+ { Contains field number (zero-based) of each key field used to uniquely
+ identify a record. }
+ FKeyFldName : array[0..127] of string;
+ { Contains field description for each key field used to uniquely identify
+ a record. Each element of the array has a one-to-one correspondence with
+ the same element in the KeyFlds array. }
+ FUniqueIndexName : string;
+ { Name of the unique index used for the key fields. }
+
+ FBlockSize : Longint;
+ FDict : TffServerDataDict;
+ FLog2BlockSize : TffWord32;
+ FRecLenPlusTrailer : Longint;
+ FRecordCount : Longint;
+ FRecordsPerBlock : Longint;
+
+ procedure CalcKeyFields; virtual;
+ function GetBLOBFields(const Inx : Integer) : Integer;
+ function GetBLOBFieldNames(const Inx : Integer) : string;
+ function GetKeyFields(const Inx : Integer) : Integer;
+ function GetKeyFieldNames(const Inx : Integer) : string;
+ procedure IdentBLOBFields; virtual;
+
+ public
+ { Methods }
+ constructor Create(Dict : TffServerDataDict;
+ FileHeaderBlock : IFileHeaderBlock); virtual;
+ destructor Destroy; override;
+
+ function KeyFieldValues(RecPtr : PffByteArray) : string; virtual;
+
+ { Properties }
+ property BLOBFieldCount : Integer
+ read FBLOBFldCount;
+ { The number of BLOB fields in a record. }
+ property BLOBFields[const Inx : Integer] : Integer
+ read GetBLOBFields;
+ { Array of BLOB field numbers. Returns an integer that is a zero-based
+ index into the dictionary's list of fields. }
+ property BLOBFieldNames[const Inx : Integer] : string
+ read GetBLOBFieldNames;
+ { Array of BLOB field names. The elements of this array have a one-to-one
+ correspondence with the BLOBFields array. }
+ property BlockSize : Longint
+ read FBlockSize;
+ { The size in bytes of the file's blocks. }
+ property Dict : TffServerDataDict
+ read FDict;
+ { The data dictionary associated with the table. }
+ property KeyFieldCount : Integer
+ read FKeyFldCount;
+ { Returns the number of fields used to uniquely identify a record in
+ the table. }
+ property KeyFields[const Inx : Integer] : Integer
+ read GetKeyFields;
+ { Array of key field numbers. Returns an integer that is a zero-based
+ index into the dictionary's list of fields. }
+ property KeyFieldNames[const Inx : Integer] : string
+ read GetKeyFieldNames;
+ { Array of key field names. The elements of this array have a one-to-one
+ correspondence with the KeyFields array. }
+ property Log2BlockSize : TffWord32
+ read FLog2BlockSize;
+ { Calculated value representative of the file's block size. }
+ property RecLenPlusTrailer : Longint
+ read FRecLenPlusTrailer;
+ { Record length plus # of trailing bytes for null field flags. }
+ property RecordCount : Longint
+ read FRecordCount;
+ { The # of records in the file. }
+ property RecordsPerBlock : Longint
+ read FRecordsPerBlock;
+ { The maximum # of records per block. }
+ property UniqueIndexName : string
+ read FUniqueIndexName;
+ { Returns the name of the unique index used to identify records in the
+ table. }
+ end;
+
+ IDataBlock = interface(ICommonBlock)
+ ['{7580BD14-3A18-40D9-8091-390D0150DF25}']
+ function GetRecCount : Longint;
+ function GetRecLen : Longint;
+ function GetNextDataBlock : TffWord32;
+ function GetPrevDataBlock : TffWord32;
+
+ procedure SetNextDataBlock(const Value : TffWord32);
+ procedure SetPrevDataBlock(const Value : TffWord32);
+ procedure SetRecCount(const Value : Longint);
+ procedure SetRecLen(const Value : Longint);
+
+ property RecordCount : Longint
+ read GetRecCount write SetRecCount;
+ { The maximum number of records in the block. }
+ property RecordLen : Longint
+ read GetRecLen write SetRecLen;
+ { The length of each record. }
+ property NextDataBlock : TffWord32
+ read GetNextDataBlock write SetNextDataBlock;
+ { The block # of the next data block. }
+ property PrevDataBlock : TffWord32
+ read GetPrevDataBlock write SetPrevDataBlock;
+ { The block # of the previous data block. }
+ end;
+
+ IIndexBlock = interface(ICommonBlock)
+ ['{88433E3F-F4AD-445C-841A-A409751E38FE}']
+ function GetIndexBlockType : Byte;
+ function GetIsLeafPage : Boolean;
+ function GetNodeLevel : Byte;
+ function GetKeysAreRefs : Boolean;
+ function GetIndexNum : Word;
+ function GetKeyLength : Word;
+ function GetKeyCount : Longint;
+ function GetMaxKeyCount : Longint;
+ function GetPrevPageRef : TffWord32;
+
+ property IndexBlockType : Byte
+ read GetIndexBlockType;
+ { The type of index block. Header blocks have value 0, B-Tree pages
+ have value 1. }
+ property IsLeafPage : Boolean
+ read GetIsLeafPage;
+ { Returns False if this is an internal B-Tree page or True if this is
+ a leaf B-Tree page. }
+ property NodeLevel : Byte
+ read GetNodeLevel;
+ { Returns the node level. Leaves have value 1, increments. }
+ property KeysAreRefs : Boolean
+ read GetKeysAreRefs;
+ { Returns the value True if the keys in the index are record reference
+ numbers. }
+ property IndexNum : Word
+ read GetIndexNum;
+ { The index number with which the index page is associated. }
+ property KeyLength : Word
+ read GetKeyLength;
+ { The length of each key. }
+ property KeyCount : Longint
+ read GetKeyCount;
+ { The number of keys currently in the page. }
+ property MaxKeyCount : Longint
+ read GetMaxKeyCount;
+ { The maximum number of keys that may be placed within the page. }
+ property PrevPageRef : TffWord32
+ read GetPrevPageRef;
+ { Block number of the previous page. }
+ end;
+
+ IIndexHeaderBlock = interface(IIndexBlock)
+ ['{B5B7D142-BB11-4325-8E2E-D4E3621A2FE3}']
+ end;
+
+ IBLOBBlock = interface(ICommonBlock)
+ ['{D4D5737F-3295-47FC-A6BF-A5B00AE5F905}']
+ end;
+
+ IStreamBlock = interface(ICommonBlock)
+ ['{648433B7-604C-49BC-87D0-338582B1B238}']
+ function GetNextStrmBlock : TffWord32;
+ function GetOwningStream : Longint;
+ function GetStreamLength : Longint;
+ function GetStreamType : Longint;
+
+ property NextStreamBlock : TffWord32
+ read GetNextStrmBlock;
+ { Block number of the next stream block in the chain or ffc_W32NoValue. }
+
+ property OwningStream : Longint
+ read GetOwningStream;
+ { Block number of the first block of the stream. }
+
+ property StreamLength : Longint
+ read GetStreamLength;
+ { Returns the length of the stream. This value is filled only for the
+ first stream block. }
+
+ property StreamType : Longint
+ read GetStreamType;
+ { For dictionary blocks, this will contain the value of constant
+ ffc_SigDictStream. If it is a user-defined stream, it will contain
+ some user-defined value. }
+
+ end;
+
+{===Class declarations===============================================}
+
+ TffFileBlock = class; { forward declaration }
+ TffFileInterface = class
+ { This abstract class defines the interface to a FlashFiler table. This
+ interface is used by TffRepair to open a table & retrieve blocks from
+ the table.
+
+ In the initialization section, specific instances of this class must use
+ the Register method to indicate their availability for specific FF table
+ versions. The Unregister method must be called during finalization to
+ deregister availability.
+ }
+ protected
+ FStartFFVersion : Longint;
+ FEndFFVersion : Longint;
+ FID : string;
+ FOutputVersion : Longint;
+ { When a table is packed, the FF version that is to be assigned to the
+ table. }
+ FRebuildProgress : TffReportRebuildProgressEvent;
+
+ function GetDictBlockCount : Longint; virtual; abstract;
+ function GetDictBlocks(const Inx : Longint) : IStreamBlock; virtual; abstract;
+ function GetOnReportError : TffReportErrorEvent; virtual; abstract;
+ function GetOnReportFix : TffReportFixEvent; virtual; abstract;
+
+ procedure SetOnReportError(Value : TffReportErrorEvent); virtual; abstract;
+ procedure SetOnReportFix(Value : TffReportFixEvent); virtual; abstract;
+ procedure SetOutputVersion(const Value : Longint); virtual; abstract;
+
+ public
+
+ { ========= Registration methods ========= }
+ class procedure Register(const ID : string); virtual;
+ { Creates an instance of this object and adds it to the list of
+ registered file interfaces. }
+
+ class procedure Unregister;
+ { Removes all instances of this class type from the list of
+ registered file interfaces. }
+
+ class function FindInterface(const FileName : string) : TffFileInterface;
+ { Searchs the list of registered file interface for a file interface that
+ handles the specified FlashFiler table. }
+
+ procedure Initialize; virtual;
+ { This method is called after the object is instantiated via the
+ Register class method. }
+
+ function Handles(const FileName : string) : Boolean; virtual;
+ { This function is called by the FindInterface class function. This
+ function must determine whether the file interface handles the specified
+ FlashFiler table. The default implementation compares the file's version
+ against the value of the StartVersion and EndVersion properties. }
+
+ { ========= Functionality methods ========= }
+ procedure Close; virtual; abstract;
+ { Close the currently opened file. }
+
+ function GetBlock(const BlockNumber : Longint) : ICommonBlock; virtual; abstract;
+ { Returns a specific block from the file. }
+
+ function GetFileHeaderBlock : IFileHeaderBlock; virtual; abstract;
+ { Returns the file header block. }
+
+ function GetFileInfo : TffGeneralFileInfo; virtual; abstract;
+ { Returns general file information that is made available to blocks. }
+
+ function GetIndexHeaderBlock : IIndexHeaderBlock; virtual; abstract;
+ { Returns the index header block. }
+
+ procedure Open(const Filename : string); virtual; abstract;
+ { Open a file for analysis. }
+
+ procedure Pack; virtual; abstract;
+
+ { Properties }
+ property DictBlockCount : Longint
+ read GetDictBlockCount;
+ { Returns the number of data dictionary blocks. }
+
+ property DictBlocks[const Inx : Longint] : IStreamBlock
+ read GetDictBlocks;
+ { Returns the specified data dictionary block. }
+
+ property EndFFVersion : Longint
+ read FEndFFVersion;
+ { The final version of FF this interface supports. }
+
+ property ID : string
+ read FID;
+
+ property OnRebuildProgress : TffReportRebuildProgressEvent
+ read FRebuildProgress write FRebuildProgress;
+ { Event handler used to report progress of reindex or pack. }
+
+ property OnReportError : TffReportErrorEvent
+ read GetOnReportError write SetOnReportError;
+ { This event is raised when an error is detected in the block. It may
+ be raised during both verification & repair. }
+
+ property OnReportFix : TffReportFixEvent
+ read GetOnReportFix write SetOnReportFix;
+ { This event is raised when an error is fixed. It is raised only during
+ the repair of a file. }
+
+ property OutputVersion : Longint
+ read FOutputVersion write SetOutputVersion;
+ { The FF version to be assigned to a table when the table is packed.
+ Defaults to the current FF version. }
+
+ property StartFFVersion : Longint
+ read FStartFFVersion;
+ { The first version of FF this interface supports. }
+
+ end;
+
+ TffFileBlock = class(TInterfacedObject, ICommonBlock)
+ { Base class representing a file block. Classes implementing an interface
+ supporting a specific type of block should inherit from this class &
+ the appropriate interface. }
+ protected
+
+ FBlock : PffBlock;
+ FBlockNum : TffWord32;
+ FBufMgr : TffBufferManager;
+ FFileInfo : PffFileInfo;
+ FOnGetInfo : TffGetInfoEvent;
+ FOnReportError : TffReportErrorEvent;
+ FOnReportFix : TffReportFixEvent;
+ FRelMethod : TffReleaseMethod;
+ FTI : PffTransInfo;
+
+ procedure DoReportError(const ErrCode : Integer;
+ args : array of const); virtual;
+ procedure DoReportFix(const ErrCode: Integer;
+ args : array of const); virtual;
+ function GetBlockNum : TffWord32;
+ function GetBlockType : TffBlockType; virtual;
+ function GetLSN : TffWord32; virtual;
+ function GetNextBlock : TffWord32; virtual;
+ function GetOnGetInfo : TffGetInfoEvent; virtual;
+ function GetOnReportError : TffReportErrorEvent; virtual;
+ function GetOnReportFix : TffReportFixEvent; virtual;
+ function GetRawData : PffBlock; virtual;
+ function GetSignature : Longint; virtual;
+ function GetThisBlock : TffWord32; virtual;
+
+ { Property access }
+ function GetPropertyCell(const Row, Column : Integer) : string; virtual;
+ function GetPropertyColCaption(const Index : Integer) : string; virtual;
+ function GetPropertyColCount : Integer; virtual;
+ function GetPropertyColWidth(const Index : Integer) : Integer; virtual;
+ function GetPropertyRowCount : Integer; virtual;
+
+ { Data access }
+ function GetDataCell(const Row, Column : Integer) : string; virtual;
+ function GetDataColCaption(const Index : Integer) : string; virtual;
+ function GetDataColCount : Integer; virtual;
+ function GetDataColWidth(const Index : Integer) : Integer; virtual;
+ function GetDataRowCount : Integer; virtual;
+
+ procedure SetLSN(const Value : TffWord32); virtual;
+ procedure SetNextBlock(const Value : TffWord32); virtual;
+ procedure SetOnGetInfo(Value : TffGetInfoEvent); virtual;
+ procedure SetOnReportError(Value : TffReportErrorEvent); virtual;
+ procedure SetOnReportFix(Value : TffReportFixEvent); virtual;
+ procedure SetSignature(const Value : Longint); virtual;
+ procedure SetThisBlock(const Value : TffWord32); virtual;
+
+ procedure VerifyRepair(const Repair : Boolean); virtual;
+ { This method is used by both Verify & Repair. It carries out the actual
+ verification &, if specified, repairing of problems. }
+ public
+
+ constructor Create(BufMgr : TffBufferManager;
+ FileInfo : PffFileInfo;
+ TI : PffTransInfo;
+ const BlockNum : TffWord32); virtual;
+ destructor Destroy; override;
+
+ procedure BeginUpdate; virtual;
+ { Call this method prior to updating a file block. }
+ procedure EndUpdate; virtual;
+ { Call this method to commit changes to a file block. }
+
+ function MapBlockTypeToStr(const BlockType : TffBlockType) : string; virtual;
+ { Use this to retrieve a text string representing the block type. }
+
+ function MapFlagsToStr(const Flags : Byte) : string;
+ { Use this to retrieve a text string representing the flags for an
+ index. }
+
+ function MapSigToStr(const Signature : Longint) : string; virtual;
+ { Use this to retrieve a text string representing the signature. }
+
+ procedure Repair; virtual;
+ { Call this method to have a block verify itself & repair any flaws it
+ can repair on its own. }
+
+ procedure Verify; virtual;
+ { Call this method to have a block verify itself. }
+
+ { Properties }
+ property BlockNum : TffWord32
+ read GetBlockNum;
+
+ property BlockType : TffBlockType
+ read GetBlockType;
+
+ property LSN : TffWord32
+ read GetLSN write SetLSN;
+
+ property NextBlock : TffWord32
+ read GetNextBlock write SetNextBlock;
+
+ property OnGetInfo : TffGetInfoEvent
+ read GetOnGetInfo write SetOnGetInfo;
+ { This event is raised by a TffFileBlock instance when it needs to
+ obtain information about the file containing the block. The parent file
+ interface must supply a handler for this event. }
+
+ property OnReportError : TffReportErrorEvent
+ read GetOnReportError write SetOnReportError;
+ { This event is raised when an error is detected in the block. It may
+ be raised during both verification & repair. }
+
+ property OnReportFix : TffReportFixEvent
+ read GetOnReportFix write SetOnReportFix;
+ { This event is raised when an error is fixed. It is raised only during
+ the repair of a file. }
+
+ property RawData : PffBlock
+ read GetRawData;
+
+ property Signature : Longint
+ read GetSignature write SetSignature;
+
+ property ThisBlock : TffWord32
+ read GetThisBlock write SetThisBlock;
+ end;
+
+{ Utility functions }
+function BooleanValue(const TrueStr, FalseStr : string;
+ const Value : Boolean) : string;
+function FlagStr(const Flag : Byte; const ZeroStr, OneStr : string) : string;
+function ByteToHex(const B : byte) : string;
+procedure GenerateHexLines(Buf : pointer; BufLen : TffMemSize;
+ Strings: TStrings);
+function Int64ToStr(const Value : TffInt64) : string;
+function LongintToChars(const L : Longint) : string;
+function LongintToHex(const L : Longint) : string;
+function Mirror(const Value : string) : string;
+function VersionToStr(const Version : Longint) : string;
+function YesNoValue(const Value : Longint) : string;
+
+const
+ ciFileBlockColumns = 2;
+ ciFileBlockRows = 5;
+
+implementation
+
+uses
+ FFRepCnst,
+ FFUtil,
+ SysUtils;
+
+var
+ _FileInterfaces : TffPointerList;
+
+{===Utility functions================================================}
+function BooleanValue(const TrueStr, FalseStr : string;
+ const Value : Boolean) : string;
+begin
+ if Value then
+ Result := TrueStr
+ else
+ Result := FalseStr;
+end;
+{--------}
+function FlagStr(const Flag : Byte; const ZeroStr, OneStr : string) : string;
+begin
+ if Flag = 0 then
+ Result := ZeroStr
+ else
+ Result := OneStr;
+ Result := Result + '(' + IntToStr(Flag) + ')';
+end;
+{--------}
+function ByteToHex(const B : byte) : string;
+const
+ HexChars : array [0..15] of AnsiChar = '0123456789abcdef';
+begin
+ Result := HexChars[B shr 4] + HexChars[B and $F];
+end;
+{--------}
+procedure GenerateHexLines(Buf : pointer; BufLen : TffMemSize;
+ Strings : TStrings);
+const
+ HexPos : array [0..15] of byte =
+ (1, 3, 5, 7, 10, 12, 14, 16, 19, 21, 23, 25, 28, 30, 32, 34);
+ HexChar : array [0..15] of char = '0123456789ABCDEF';
+var
+ B : PffByteArray absolute Buf;
+ ThisWidth,
+ i, j : integer;
+ Line : string[56];
+ Work : byte;
+begin
+ Strings.Clear;
+ if (BufLen = 0) or (Buf = nil) then
+ Exit
+ else begin
+ for i := 0 to ((BufLen-1) shr 4) do begin
+ FillChar(Line, 56, ' ');
+ Line[0] := #55;
+ Line[38] := '['; Line[55] := ']';
+ if (BufLen >= 16) then
+ ThisWidth := 16
+ else
+ ThisWidth := BufLen;
+ for j := 0 to Pred(ThisWidth) do begin
+ Work := B^[(i shl 4) + j];
+ Line[HexPos[j]] := HexChar[Work shr 4];
+ Line[HexPos[j]+1] := HexChar[Work and $F];
+ if (Work < 32) then
+ Work := ord('.');
+ Line[39+j] := char(Work);
+ end;
+ Strings.Add(Line);
+ dec(BufLen, ThisWidth);
+ end;
+ end;
+end;
+{--------}
+function Int64ToStr(const Value : TffInt64) : string;
+begin
+ Result := IntToStr(Value.iHigh) + ':' + IntToStr(Value.iLow);
+end;
+{--------}
+function LongintToChars(const L : Longint) : string;
+var
+ Inx : Integer;
+ Val : Integer;
+begin
+ Result := Char(L shr 24) +
+ Char((L shr 16) and $FF) +
+ Char((L shr 8) and $FF) +
+ Char(L and $FF);
+
+ { Convert values 0 - 9 to corresponding digits. }
+ for Inx := 1 to 4 do begin
+ Val := Ord(Result[Inx]);
+ if Val < 10 then
+ Result[Inx] := Char(Val + 48);
+ end;
+end;
+{--------}
+function LongintToHex(const L : Longint) : string;
+begin
+ Result := ByteToHex(L shr 24) +
+ ByteToHex((L shr 16) and $FF) +
+ ByteToHex((L shr 8) and $FF) +
+ ByteToHex(L and $FF);
+end;
+{--------}
+function Mirror(const Value : string) : string;
+var
+ Inx : Integer;
+ Len : Integer;
+begin
+ Len := Length(Value);
+ SetLength(Result, Len);
+ for Inx := 1 to Len do
+ Result[Len - Pred(Inx)] := Value[Inx];
+end;
+{--------}
+function VersionToStr(const Version : Longint) : string;
+begin
+ Result := Format('%5.4f', [Version / 10000.0]);
+end;
+{--------}
+function YesNoValue(const Value : Longint) : string;
+begin
+ if Value = 0 then
+ Result := 'No (0)'
+ else
+ Result := 'Yes (' + IntToStr(Value) + ')';
+end;
+{====================================================================}
+
+{===TffGeneralFileInfo===============================================}
+constructor TffGeneralFileInfo.Create(Dict : TffServerDataDict;
+ FileHeaderBlock : IFileHeaderBlock);
+begin
+ inherited Create;
+
+ FDict := TffServerDataDict.Create(Dict.BlockSize);
+ FDict.Assign(Dict);
+
+ FBlockSize := FileHeaderBlock.BlockSize;
+ FLog2BlockSize := FileHeaderBlock.Log2BlockSize;
+ FRecLenPlusTrailer := FileHeaderBlock.RecordLengthPlusTrailer;
+ FRecordCount := FileHeaderBlock.RecordCount;
+ FRecordsPerBlock := FileHeaderBlock.RecordsPerBlock;
+
+ IdentBLOBFields;
+ CalcKeyFields;
+end;
+{--------}
+destructor TffGeneralFileInfo.Destroy;
+begin
+ FDict.Free;
+ inherited;
+end;
+{--------}
+procedure TffGeneralFileInfo.CalcKeyFields;
+var
+ Inx : Integer;
+ IndexDesc : PffIndexDescriptor;
+begin
+ if FKeyFldCount = 0 then begin
+ { Determine which fields will be used to uniquely identify each
+ record.
+
+ Strategy: Find the first unique index. If that is found, use its fields
+ to identify the record. If one is not found then use first 4 fields. }
+
+ FillChar(FKeyFlds, SizeOf(FKeyFlds), 0);
+ FKeyFldCount := 0;
+ IndexDesc := nil;
+ for Inx := 1 to Pred(FDict.IndexCount) do begin
+ { Skip Sequential Access Index. }
+ if not FDict.IndexAllowDups[Inx] then begin
+ IndexDesc := FDict.IndexDescriptor[Inx];
+ Break;
+ end; { if }
+ end; { for }
+
+ if Assigned(IndexDesc) then begin
+ { Records will be identified using a unique index. }
+ FUniqueIndexName := IndexDesc^.idName;
+ for Inx := 0 to Pred(IndexDesc^.idCount) do begin
+ FKeyFlds[Inx] := IndexDesc^.idFields[Inx];
+ FKeyFldName[Inx] := FDict.FieldName[FKeyFlds[Inx]];
+ end; { for }
+ FKeyFldCount := IndexDesc^.idCount;
+ end
+ else begin
+ FKeyFldCount := FFMinI(4, FDict.FieldCount);
+ FUniqueIndexName := 'No unique index. Records identified using fields 1 ' +
+ 'through ' + IntToStr(FKeyFldCount) + ' of the table.';
+ for Inx := 0 to Pred(FKeyFldCount) do begin
+ FKeyFlds[Inx] := Inx;
+ FKeyFldName[Inx] := FDict.FieldDesc[Inx];
+ end; { for }
+ end; { if..else }
+ end; { if }
+end;
+{--------}
+function TffGeneralFileInfo.GetBLOBFields(const Inx : Integer) : Integer;
+begin
+ Result := FBLOBFlds[Inx];
+end;
+{--------}
+function TffGeneralFileInfo.GetBLOBFieldNames(const Inx : Integer) : string;
+begin
+ Result := FBLOBFldName[Inx];
+end;
+{--------}
+function TffGeneralFileInfo.GetKeyFields(const Inx : Integer) : Integer;
+begin
+ Result := FKeyFlds[Inx];
+end;
+{--------}
+function TffGeneralFileInfo.GetKeyFieldNames(const Inx : Integer) : string;
+begin
+ Result := FKeyFldName[Inx];
+end;
+{--------}
+procedure TffGeneralFileInfo.IdentBLOBFields;
+var
+ Inx : Integer;
+begin
+ FillChar(FBLOBFlds, SizeOf(FBLOBFlds), 0);
+ FBLOBFldCount := 0;
+ for Inx := 0 to Pred(FDict.FieldCount) do begin
+ if FDict.FieldType[Inx] in [fftBLOB..fftBLOBTypedBin] then begin
+ FBLOBFlds[FBLOBFldCount] := Inx;
+ FBLOBFldName[FBLOBFldCount] := FDict.FieldName[Inx];
+ inc(FBLOBFldCount);
+ end; { if }
+ end; { for }
+end;
+{--------}
+function TffGeneralFileInfo.KeyFieldValues(RecPtr : PffByteArray) : string;
+var
+ Inx : Integer;
+ FieldValue : TffVCheckValue;
+ IsNull : Boolean;
+begin
+ Result := '';
+ for Inx := 0 to Pred(FKeyFldCount) do begin
+ if Result <> '' then
+ Result := Result + '; ';
+ FillChar(FieldValue, SizeOf(FieldValue), 0);
+ FDict.GetRecordField(FKeyFlds[Inx], RecPtr, IsNull, @FieldValue);
+ if IsNull then
+ Result := Result + Format('%s: %s',
+ [FKeyFldName[Inx], ''])
+ else
+ Result := Result + Format('%s: %s',
+ [FKeyFldName[Inx],
+ FFVCheckValToString
+ (FieldValue,
+ FDict.FieldType[FKeyFlds[Inx]])
+ ]);
+ end; { for }
+end;
+{====================================================================}
+
+{===TffFileInterface=================================================}
+function TffFileInterface.Handles(const FileName : string) : Boolean;
+var
+ CharsRead : Integer;
+ FileVersion : Longint;
+ Stream : TFileStream;
+ Block : TffBlock;
+ FileHeader : PffBlockHeaderFile;
+begin
+ Result := False;
+ Stream := TFileStream.Create(FileName, fmOpenRead);
+ try
+ { Read the file header. }
+ CharsRead := Stream.Read(Block, 4096);
+ if CharsRead = 4096 then begin
+ FileHeader := PffBlockHeaderFile(@Block);
+ if FileHeader^.bhfSignature = ffc_SigHeaderBlock then begin
+ { Check the version. }
+ FileVersion := FileHeader^.bhfFFVersion;
+ Result := (FileVersion >= StartFFVersion) and (FileVersion <= EndFFVersion);
+ end;
+ end
+ else
+ raise Exception.CreateFmt('"%s" is not a FlashFiler table.', [FileName]);
+ finally
+ Stream.Free;
+ end;
+end;
+{--------}
+class procedure TffFileInterface.Register(const ID : string);
+var
+ FileInterface: TffFileInterface;
+begin
+ FileInterface := Create;
+ try
+ FileInterface.Initialize;
+ _FileInterfaces.Append(FileInterface);
+ except
+ FileInterface.Free;
+ end;
+ FileInterface.FID := ID;
+end;
+{--------}
+class procedure TffFileInterface.Unregister;
+var
+ wInx : Integer;
+begin
+ if _FileInterfaces = nil then
+ Exit;
+ { Free every instance of this class. }
+ for wInx := Pred(_FileInterfaces.Count) downto 0 do
+ with TffFileInterface(_FileInterfaces.Pointers[wInx]) do
+ if (ClassType = Self) then begin
+ Free;
+ _FileInterfaces.RemoveAt(wInx);
+ end;
+end;
+{--------}
+class function TffFileInterface.FindInterface(const FileName : string) : TffFileInterface;
+var
+ wInx : Integer;
+begin
+ Result := nil;
+ for wInx := 0 to Pred(_FileInterfaces.Count) do
+ with TffFileInterface(_FileInterfaces.Pointers[wInx]) do
+ if Handles(FileName) then begin
+ Result := _FileInterfaces.Pointers[wInx];
+ Break;
+ end;
+end;
+{--------}
+procedure TffFileInterface.Initialize;
+begin
+ { Descendant classes may override this method for custom initialization. }
+end;
+{====================================================================}
+
+{===TffFileBlock=====================================================}
+constructor TffFileBlock.Create(BufMgr : TffBufferManager;
+ FileInfo : PffFileInfo;
+ TI : PffTransInfo;
+ const BlockNum : TffWord32);
+begin
+ inherited Create;
+ FBufMgr := BufMgr;
+ FBlock := FBufMgr.GetBlock(FileInfo, BlockNum, TI, ffc_ReadOnly, FRelMethod);
+ FFileInfo := FileInfo;
+ FTI := TI;
+ FBlockNum := BlockNum;
+end;
+{--------}
+destructor TffFileBlock.Destroy;
+begin
+ try
+ if Assigned(FRelMethod) and Assigned(FBlock) then
+ FRelMethod(FBlock);
+ finally
+ inherited;
+ end;
+end;
+{--------}
+procedure TffFileBlock.BeginUpdate;
+begin
+ { Do nothing }
+end;
+{--------}
+procedure TffFileBlock.EndUpdate;
+begin
+ { Do nothing }
+end;
+{--------}
+procedure TffFileBlock.DoReportError(const ErrCode : Integer;
+ args : array of const);
+begin
+ if Assigned(FOnReportError) then
+ FOnReportError(Self, ErrCode,
+ Format(rcErrStr[ErrCode], args));
+end;
+{--------}
+procedure TffFileBlock.DoReportFix(const ErrCode : Integer;
+ args : array of const);
+begin
+ if Assigned(FOnReportError) then
+ FOnReportFix(Self, ErrCode,
+ Format(rcFixStr[ErrCode], args));
+end;
+{--------}
+function TffFileBlock.GetBlockNum : TffWord32;
+begin
+ Result := FBlockNum;
+end;
+{--------}
+function TffFileBlock.GetBlockType : TffBlockType;
+begin
+ case PffBlockCommonHeader(FBlock)^.bchSignature of
+ ffc_SigHeaderBlock : Result := btFileHeader;
+ ffc_SigDataBlock : Result := btData;
+ ffc_SigIndexBlock :
+ begin
+ if PffBlockHeaderIndex(FBlock)^.bhiBlockType = 0 then
+ Result := btIndexHeader
+ else
+ Result := btIndex;
+ end;
+ ffc_SigBLOBBlock : Result := btBLOB;
+ ffc_SigStreamBlock : Result := btStream;
+ ffc_SigFreeBlock : Result := btFree;
+ else
+ Result := btUnknown;
+ end; { case }
+end;
+{--------}
+function TffFileBlock.GetDataCell(const Row, Column : Integer) : string;
+begin
+ Result := '';
+end;
+{--------}
+function TffFileBlock.GetDataColCaption(const Index : Integer) : string;
+begin
+ Result := '';
+end;
+{--------}
+function TffFileBlock.GetDataColCount : Integer;
+begin
+ Result := 0;
+end;
+{--------}
+function TffFileBlock.GetDataColWidth(const Index : Integer) : Integer;
+begin
+ Result := 0;
+end;
+{--------}
+function TffFileBlock.GetDataRowCount : Integer;
+begin
+ Result := 0;
+end;
+{--------}
+function TffFileBlock.GetLSN : TffWord32;
+begin
+ Result := PffBlockCommonHeader(FBlock)^.bchLSN;
+end;
+{--------}
+function TffFileBlock.GetNextBlock : TffWord32;
+begin
+ Result := PffBlockCommonHeader(FBlock)^.bchNextBlock;
+end;
+{--------}
+function TffFileBlock.GetOnGetInfo : TffGetInfoEvent;
+begin
+ Result := FOnGetInfo;
+end;
+{--------}
+function TffFileBlock.GetOnReportError : TffReportErrorEvent;
+begin
+ Result := FOnReportError;
+end;
+{--------}
+function TffFileBlock.GetOnReportFix : TffReportFixEvent;
+begin
+ Result := FOnReportFix;
+end;
+{--------}
+function TffFileBlock.GetRawData : PffBlock;
+begin
+ Result := FBlock;
+end;
+{--------}
+function TffFileBlock.GetSignature : Longint;
+begin
+ Result := PffBlockCommonHeader(FBlock)^.bchSignature;
+end;
+{--------}
+function TffFileBlock.GetThisBlock : TffWord32;
+begin
+ Result := PffBlockCommonHeader(FBlock)^.bchThisBlock;
+end;
+{--------}
+function TffFileBlock.GetPropertyCell(const Row, Column : Integer) : string;
+begin
+ if Column > Pred(ciFileBlockColumns) then
+ raise Exception.CreateFmt
+ ('Cannot ask for cell in column %d when there are only %d columns in the view',
+ [Column, ciFileBlockColumns]);
+
+ case Row of
+ 0 : if Column = 0 then
+ Result := 'Block type'
+ else
+ Result := MapBlockTypeToStr(GetBlockType);
+ 1 : if Column = 0 then
+ Result := 'Signature'
+ else
+ Result := MapSigToStr(GetSignature);
+ 2 : if Column = 0 then
+ Result := 'This block'
+ else
+ Result := IntToStr(GetThisBlock);
+ 3 : if Column = 0 then
+ Result := 'Next block'
+ else
+ Result := IntToStr(GetNextBlock);
+ 4 : if Column = 0 then
+ Result := 'LSN'
+ else
+ Result := IntToStr(GetLSN);
+ else
+ raise Exception.CreateFmt
+ ('Cannot ask for cell in row %d when there are only %d rows in the view',
+ [Row, ciFileBlockRows]);
+ end; { case }
+end;
+{--------}
+function TffFileBlock.GetPropertyColCaption(const Index : Integer) : string;
+begin
+ case Index of
+ 0 : Result := 'Property';
+ 1 : Result := 'Value';
+ else
+ raise Exception.CreateFmt
+ ('Cannot ask for caption %d when there are only %d columns in the view',
+ [Index, ciFileBlockColumns]);
+ end; { case }
+end;
+{--------}
+function TffFileBlock.GetPropertyColCount : Integer;
+begin
+ Result := ciFileBlockColumns;
+end;
+{--------}
+function TffFileBlock.GetPropertyColWidth(const Index : Integer) : Integer;
+begin
+ case Index of
+ 0 : Result := 150;
+ 1 : Result := 150;
+ else
+ raise Exception.CreateFmt
+ ('Cannot ask for width %d when there are only %d columns in the view',
+ [Index, ciFileBlockColumns]);
+ end; { case }
+end;
+{--------}
+function TffFileBlock.GetPropertyRowCount : Integer;
+begin
+ Result := ciFileBlockRows;
+end;
+{--------}
+function TffFileBlock.MapBlockTypeToStr(const BlockType : TffBlockType) : string;
+begin
+ case BlockType of
+ btUnknown : Result := 'Unknown';
+ btFileHeader : Result := 'File header';
+ btIndexHeader : Result := 'Index header';
+ btData : Result := 'Data';
+ btIndex : Result := 'Index';
+ btBLOB : Result := 'BLOB';
+ btStream : Result := 'Stream';
+ btFree : Result := 'Free';
+ end; { case }
+end;
+{--------}
+function TffFileBlock.MapFlagsToStr(const Flags : Byte) : string;
+var
+ FlagSet : Boolean;
+begin
+ FlagSet := False;
+ Result := IntToStr(Flags);
+ if Flags > 0 then begin
+ Result := Result + ' [';
+ if (Flags and ffc_InxFlagAllowDups) <> 0 then begin
+ Result := Result + ' Allow dups';
+ FlagSet := True;
+ end;
+
+ if (Flags and ffc_InxFlagKeysAreRefs) <> 0 then begin
+ if FlagSet then
+ Result := Result + ', ';
+ Result := Result + 'Keys are refs'
+ end; { if }
+ Result := Result + ']';
+ end; { if }
+end;
+{--------}
+function TffFileBlock.MapSigToStr(const Signature : Longint) : string;
+begin
+ Result := Mirror(LongintToChars(Signature)) + ' (' +
+ LongintToHex(Signature) + ')';
+end;
+{--------}
+procedure TffFileBlock.Repair;
+begin
+ try
+ VerifyRepair(True);
+ except
+ on E:Exception do
+ ShowMessage(E.Message);
+ end;
+end;
+{--------}
+procedure TffFileBlock.SetLSN(const Value : TffWord32);
+begin
+ PffBlockCommonHeader(FBlock)^.bchLSN := Value;
+end;
+{--------}
+procedure TffFileBlock.SetNextBlock(const Value : TffWord32);
+begin
+ PffBlockCommonHeader(FBlock)^.bchNextBlock := Value;
+end;
+{--------}
+procedure TffFileBlock.SetOnGetInfo(Value : TffGetInfoEvent);
+begin
+ FOnGetInfo := Value;
+end;
+{--------}
+procedure TffFileBlock.SetOnReportError(Value : TffReportErrorEvent);
+begin
+ FOnReportError := Value;
+end;
+{--------}
+procedure TffFileBlock.SetOnReportFix(Value : TffReportFixEvent);
+begin
+ FOnReportFix := Value;
+end;
+{--------}
+procedure TffFileBlock.SetSignature(const Value : Longint);
+begin
+ PffBlockCommonHeader(FBlock)^.bchSignature := Value;
+end;
+{--------}
+procedure TffFileBlock.SetThisBlock(const Value : TffWord32);
+begin
+ PffBlockCommonHeader(FBlock)^.bchThisBlock := Value;
+end;
+{--------}
+procedure TffFileBlock.Verify;
+begin
+ VerifyRepair(False);
+end;
+{--------}
+procedure TffFileBlock.VerifyRepair(const Repair : Boolean);
+var
+ Block : PffBlock;
+ RelMethod : TffReleaseMethod;
+ Modified : Boolean;
+begin
+ Modified := False;
+ try
+ { Verify the block type. }
+ if BlockType = btUnknown then begin
+ DoReportError(rciUnknownBlockType,
+ [PffBlockCommonHeader(FBlock)^.bchSignature]);
+ if Repair then begin
+ BeginUpdate;
+ Modified := True;
+ { Mark this as a free block. }
+ PffBlockCommonHeader(FBlock)^.bchSignature := ffc_SigFreeBlock;
+ DoReportFix(rciUnknownBlockType,
+ [BlockNum]);
+ end;
+ end;
+
+ { Can't do much with the LSN. }
+
+ { Verify the next block is a valid block. }
+ if NextBlock <> ffc_W32NoValue then
+ try
+ Block := FBufMgr.GetBlock(FFileInfo, NextBlock, FTI, ffc_ReadOnly,
+ RelMethod);
+ RelMethod(Block);
+ except
+ DoReportError(rciInvalidBlockRefNext, [NextBlock]);
+ end;
+
+ { Verify ThisBlock matches this block number. }
+ if ThisBlock <> FBlockNum then begin
+ DoReportError(rciInvalidThisBlock, [FBlockNum, ThisBlock]);
+ if Repair then begin
+ BeginUpdate;
+ Modified := True;
+ ThisBlock := FBlockNum;
+ DoReportFix(rciInvalidThisBlock, [FBlockNum]);
+ end;
+ end;
+ finally
+ if Modified then
+ EndUpdate;
+ end;
+end;
+{====================================================================}
+
+
+initialization
+ _FileInterfaces := TffPointerList.Create;
+
+finalization
+
+ _FileInterfaces.Free;
+ { Assumption: Units registering comparator classes will also unregister
+ them. }
+ _FileInterfaces := nil;
+
+end.
diff --git a/components/flashfiler/sourcelaz/Verify/ffrepair.pas b/components/flashfiler/sourcelaz/Verify/ffrepair.pas
new file mode 100644
index 000000000..df6a44499
--- /dev/null
+++ b/components/flashfiler/sourcelaz/Verify/ffrepair.pas
@@ -0,0 +1,1065 @@
+{*********************************************************}
+{* FlashFiler: Table verification & repair component *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffrepair;
+
+ { TODO:: Have to handle multi-file tables. }
+
+ { Current limitation:
+ Block 0 must have a valid signature, ThisBlock = 0, and NextBlock must
+ be equal to ffc_W32NoValue. }
+
+interface
+
+uses
+ Classes,
+ FFChain,
+ FFLLBase,
+ FFFileInt,
+ FFRepCnst;
+
+const
+ ciErrorLimit = 10000;
+ { The default error limit for verification. Once this many errors has been
+ found, the verification process will stop. The repair process is not
+ subject to this limit. }
+
+type
+ TffRepairEngine = class; { forward declaration }
+ { Use this component to verify & repair FlashFiler tables.
+
+ This class will look for a registered instance of TffFileInterface
+ corresponding to the FF version of the table being verified/repaired.
+
+ Description of use:
+ 1. Decide what is to be verified and/or repaired. The items that may
+ be verified are declared in the TffRepairItem enum.
+ By default, all items are verified. To change the items to be
+ verified, use the Items property of the TffRepair class.
+
+ 2. If verifying, decide how many errors may be encountered before the
+ verification process stops. By default, the verification process
+ will stop after 100 errors have been encountered. To change this
+ value, use the ErrorLimit property. To have verification process
+ the entire table regardless of the number of errors, set the
+ ErrorLimit property to the value zero.
+
+ 3. Decide whether the table is to be verified or verified & repaired.
+ Verification tells you whether the table contains any structural or
+ content errors. Repair performs a verification and attempts to
+ correct the errors. See the Repair Procedures section below to
+ determine how errors are corrected.
+
+ If the table is to be verified but not repaired, call the
+ Verify method.
+
+ If the table is to be verified & repaired, call the Repair method.
+
+ Even though the Verify method was previously called, the Repair
+ method will once again Verify the entire table.
+
+ 4. TODO:: verify/repair progress
+
+ 5. TODO:: verify/repair error reporting
+
+ REPAIR PROCEDURES
+
+ TODO::
+
+ }
+
+ TffRepairState =
+ (rmIdle, { Not doing anything }
+ rmAcquireInfo, { Acquiring information from repair engine }
+ rmVerify, { Verifying/Checking }
+ rmRepair { Repairing identified problem }
+ );
+
+ TffRepairItem =
+ (riNone,
+ riFileHeader, { Check the file header }
+ riBlockScan, { Verify block headers }
+ riCheckDictionary, { Check the dictionary }
+ riBlockChains, { Verify the free & data block chains }
+ riDeletedBLOBChain, { Verify deleted blob segment chain }
+ riReindex, { Rebuilding an index }
+ riPack { Packing the table }
+ );
+
+ TffRepairItems = set of TffRepairItem;
+
+ TffRepairProgressEvent =
+ { Event raised so that parent application may check progress. }
+ procedure(Repairer : TffRepairEngine;
+ State : TffRepairState;
+ Item : TffRepairItem;
+ const ActionStr : string;
+ const Position, Maximum : Integer) of object;
+
+ TffRepairEngine = class(TObject)
+ { Use this component to verify & repair FlashFiler tables. }
+ protected
+ FAbort : Boolean;
+ FChainMgrData,
+ FChainMgrFree : TffChainMgr;
+ FCompleted : TNotifyEvent;
+ FCurrentItem : TffRepairItem;
+ { The current item being verified or repaired. }
+ FErrorCodes : TList;
+ FErrorLimit : Integer;
+ FErrors : TStringList;
+ FFileInterface: TffFileInterface;
+ FFixCodes : TList;
+ FFixes : TStringList;
+ FHighestAction : TffRepairAction;
+ { Based upon the errors reported by the file interface, the most serious
+ action that must be taken to repair the table. }
+ FInfo : TffGeneralFileInfo;
+ FItems : TffRepairItems;
+ FOnProgress : TffRepairProgressEvent;
+ FOnReportError : TffReportErrorEvent;
+ FOnReportFix : TffReportFixEvent;
+ FOutputVersion : Longint;
+ FState : TffRepairState;
+ FUnknownBlocks : TList;
+ FUsedBlocksValid : Boolean;
+
+ procedure CheckLastBlock;
+ procedure ClearChainMgrs;
+ procedure ClearErrors;
+ procedure ClearFileInterface;
+
+ procedure DoReportError(Block : ICommonBlock;
+ const ErrCode : Integer;
+ args : array of const);
+
+ procedure DoReportFix(Block : ICommonBlock;
+ const ErrCode : Integer;
+ args : array of const);
+
+ procedure FixUnknownBlock(const BlockNum : TffWord32;
+ FileHeaderBlock : IFileHeaderBlock);
+
+ function GetDictBlock(const Inx : Longint) : IStreamBlock;
+ function GetDictBlockCount : Longint;
+ function GetErrorCodes(const Inx : Integer) : Integer;
+ function GetErrorCount : Integer;
+ function GetErrors(const Inx : Integer) : string;
+ function GetFixCodes(const Inx : Integer) : Integer;
+ function GetFixCount : Integer;
+ function GetFixes(const Inx : Integer) : string;
+
+ procedure GetInfo(var Info : TffGeneralFileInfo);
+
+ procedure HandleRebuildProgress(FileInterface : TffFileInterface;
+ Position, Maximum : Integer);
+
+ procedure HandleReportError(Block : ICommonBlock;
+ const ErrCode : Integer;
+ const ErrorStr : string);
+
+ procedure HandleReportFix(Block : ICommonBlock;
+ const ErrCode : Integer;
+ const RepairStr : string);
+
+ procedure LinkDataCallback(const Block1Num, Block2Num : TffWord32);
+
+ function MapItemToActionStr(const Item : TffRepairItem;
+ const State : TffRepairState) : string;
+
+ procedure MoveDataOrphanCallback(const BlockMoved, PrevBlock : TffWord32);
+ procedure PopulateChainMgrs;
+ procedure ReportProgress(const Position, Maximum : Integer);
+
+ procedure SetErrorLimit(const Value : Integer);
+ procedure SetItems(const Value : TffRepairItems);
+ procedure VerifyRepair;
+ { This method is called by both the Verify & Repair methods. This
+ method centralizes the logic for verifying & repairing the file. }
+
+ public
+ procedure Close;
+ { Closes the currently open file. }
+
+ function GetBlock(const BlockNumber : Longint) : ICommonBlock;
+ { Returns the specified block. }
+
+ function GetFileHeaderBlock : IFileHeaderBlock;
+ { Returns the file header block for the open file. }
+
+ function GetIndexHeaderBlock : IIndexHeaderBlock;
+ { Returns the index header block for the open file. }
+
+ function GetFreeChainDetails : TStringList;
+ { Returns a string list containing information about the chain of free
+ blocks. }
+
+ function GetDataChainDetails : TStringList;
+ { Returns a string list containing information about the chain of data
+ blocks. }
+
+ procedure Open(const FileName : string);
+ { Open a file. }
+
+ procedure Repair;
+ { This method will verify &, if one or more errors are encountered,
+ repair the currently open table. }
+
+ procedure Verify;
+ { This method will verify the structure & content of the currently open
+ table. }
+
+ { Properties }
+
+ property Aborted : Boolean
+ read FAbort;
+ { Returns True if the previous verify was aborted. }
+
+ property DictBlockCount : Integer
+ read GetDictBlockCount;
+ { Returns the number of data dictionary blocks in the file. }
+
+ property DictBlocks[const Inx : Longint] : IStreamBlock
+ read GetDictBlock;
+ { Returns the specified data dictionary block. }
+
+ property ErrorCodes[const Inx : Integer] : Integer
+ read GetErrorCodes;
+ { Use this property to access the error code associated with each flaw
+ found in the file. There is a one-to-one correspondence between the
+ elements in this property & the elements in the Errors property. }
+
+ property ErrorCount : Integer
+ read GetErrorCount;
+ { Use this property to determine the number of errors encountered during
+ a verify or repair process. }
+
+ property Errors[const Inx : Integer] : string
+ read GetErrors;
+ { Use this property to access the descriptive message associated with
+ each error. There is a one-to-one correspondence between the
+ elements in this property & the elements in the ErrorCodes property. }
+
+ property FixCodes[const Inx : Integer] : Integer
+ read GetFixCodes;
+ { Use this property to access the error code associated with each fix
+ made to the file. There is a one-to-one correspondence between the
+ elements in this property & the elements in the Fixes property. }
+
+ property FixCount : Integer
+ read GetFixCount;
+ { Returns the number of errors fixed by a repair operation. }
+
+ property Fixes[const Inx : Integer] : string
+ read GetFixes;
+ { Use this property to access the descriptive message associated with
+ each fix made to the file. Note there is not a one-to-one correspondence
+ between the Fixes and the Errors. There is a one-to-one correspondence
+ between the elements in this property & the elements in the FixCodes
+ property. }
+
+ property OutputVersion : Longint
+ read FOutputVersion write FOutputVersion;
+ { The FF version to be assigned to the table when the table is packed.
+ Defaults to the current FF version. }
+
+ property State : TffRepairState
+ read FState;
+ { Returns the current state of the repair engine. }
+
+ published
+ constructor Create;
+ destructor Destroy; override;
+
+ property ErrorLimit : Integer
+ read FErrorLimit write SetErrorLimit default ciErrorLimit;
+ { Use this property to have the verification process stop after a certain
+ number of errors have been reached. To have the verification process
+ analyze the entire table regardless of the number of errors, set this
+ property to the value zero. Note that this value is ignored by the
+ repair process. The default value is 10. }
+
+ property Items : TffRepairItems
+ read FItems write SetItems;
+ { Use this property to control the items that are analyzed & repaired.
+ By default, all items are analyzed & repaired. }
+
+ property OnComplete : TNotifyEvent
+ read FCompleted write FCompleted;
+ { This event is raised when a repair run has completed. }
+
+ property OnProgress : TffRepairProgressEvent
+ read FOnProgress write FOnProgress;
+ { This event is raised as a repair run progresses. }
+
+ property OnReportError : TffReportErrorEvent
+ read FOnReportError write FOnReportError;
+ { This event is raised when an error is detected in a block. This
+ event will be raised during both verification & repair. }
+
+ property OnReportFix : TffReportFixEvent
+ read FOnReportFix write FOnReportFix;
+ { This event is raised when an error is fixed. It is raised only during
+ the repair of a file. }
+
+ end;
+
+implementation
+
+uses
+ FFSrBase,
+ SysUtils;
+
+const
+ csIdle = ' only when the repair engine is idle.';
+
+{===TffRepair========================================================}
+constructor TffRepairEngine.Create;
+var
+ Item : TffRepairItem;
+begin
+ inherited;
+ FErrorLimit := ciErrorLimit;
+ FErrorCodes := TList.Create;
+ FErrors := TStringList.Create;
+ FFixCodes := TList.Create;
+ FFixes := TStringList.Create;
+ FOutputVersion := FFVersionNumber;
+ FUnknownBlocks := TList.Create;
+ for Item := Low(TffRepairItem) to High(TffRepairItem) do
+ Include(FItems, Item);
+end;
+{--------}
+destructor TffRepairEngine.Destroy;
+begin
+ ClearChainMgrs;
+ FErrorCodes.Free;
+ FErrors.Free;
+ FFixCodes.Free;
+ FFixes.Free;
+ FUnknownBlocks.Free;
+ ClearFileInterface;
+ inherited;
+end;
+{--------}
+procedure TffRepairEngine.ClearChainMgrs;
+begin
+ FChainMgrData.Free;
+ FChainMgrData := nil;
+ FChainMgrFree.Free;
+ FChainMgrFree := nil;
+end;
+{--------}
+procedure TffRepairEngine.ClearErrors;
+begin
+ FAbort := False;
+ FErrorCodes.Clear;
+ FErrors.Clear;
+ FFixCodes.Clear;
+ FFixes.Clear;
+ FHighestAction := raDecide;
+ FUnknownBlocks.Clear;
+end;
+{--------}
+procedure TffRepairEngine.ClearFileInterface;
+begin
+ if FFileInterface <> nil then begin
+ FInfo.Free;
+ FFileInterface.Close;
+ FFileInterface := nil;
+ end;
+end;
+{--------}
+procedure TffRepairEngine.Close;
+begin
+ if FState = rmIdle then
+ ClearFileInterface
+ else
+ raise Exception.Create('The Close method can be called' + csIdle);
+end;
+{--------}
+procedure TffRepairEngine.DoReportError(Block : ICommonBlock;
+ const ErrCode : Integer;
+ args : array of const);
+begin
+ HandleReportError(Block, ErrCode,
+ Format(rcErrStr[ErrCode], args));
+end;
+{--------}
+procedure TffRepairEngine.DoReportFix(Block : ICommonBlock;
+ const ErrCode : Integer;
+ args : array of const);
+begin
+ HandleReportFix(Block, ErrCode,
+ Format(rcFixStr[ErrCode], args));
+end;
+{--------}
+procedure TffRepairEngine.FixUnknownBlock(const BlockNum : TffWord32;
+ FileHeaderBlock : IFileHeaderBlock);
+var
+ PotentialFirstBlock,
+ PotentialLastBlock,
+ RefBlock : TffWord32;
+ Block : ICommonBlock;
+ DataBlock : IDataBlock;
+begin
+ PotentialFirstBlock := ffc_W32NoValue;
+ PotentialLastBlock := ffc_W32NoValue;
+
+ { Make sure this block is not referenced in the data chain. We assume
+ that since it is an unknown block then it will not be a member of
+ the data chain. }
+ if FChainMgrData.Referenced(BlockNum, True, RefBlock) then begin
+ DataBlock := FFileinterface.GetBlock(RefBlock) as IDataBlock;
+ DataBlock.BeginUpdate;
+ try
+ if DataBlock.PrevDataBlock = BlockNum then begin
+ PotentialFirstBlock := DataBlock.BlockNum;
+ DataBlock.PrevDataBlock := ffc_W32NoValue
+ end
+ else begin
+ PotentialLastBlock := DataBlock.BlockNum;
+ DataBlock.NextDataBlock := ffc_W32noValue;
+ end; { if..else }
+ finally
+ DataBlock.EndUpdate;
+ DataBlock := nil;
+ end;
+ end;
+
+ { Is the block referenced in the free block chain? }
+ if not FChainMgrFree.Referenced(BlockNum, False, RefBlock) then begin
+ { It is not referenced. Get the first free block. }
+ RefBlock := FileHeaderBlock.FirstFreeBlock;
+ { Does the first free block already point to this block? }
+ if RefBlock <> BlockNum then begin
+ { No. Have the unknown block point to the block listed as the
+ first free block. }
+ Block := FFileInterface.GetBlock(BlockNum);
+ Block.BeginUpdate;
+ try
+ Block.NextBlock := FileHeaderBlock.FirstFreeBlock;
+ finally
+ Block.EndUpdate;
+ Block := nil;
+ end;
+ { Set the first free block to be the unknown block. }
+ FileHeaderBlock.BeginUpdate;
+ try
+ FileHeaderBlock.FirstFreeBlock := BlockNum;
+ finally
+ FileHeaderBlock.EndUpdate;
+ end;
+ end
+ else begin
+ { Yes, it is already pointed to by the file header. Add the
+ unknown block to the free block chain manager. }
+ Block := FFileInterface.GetBlock(BlockNum);
+ FChainMgrFree.AddBlock(BlockNum, Block.NextBlock, ffc_W32NoValue);
+ Block := nil;
+ end; { if..else }
+ end;
+
+ { Is the block referenced in the file header? }
+ if FileHeaderBlock.FirstDataBlock = BlockNum then begin
+ { Update the file header with the first data block. }
+ if PotentialFirstBlock <> ffc_W32NoValue then begin
+ FileHeaderBlock.BeginUpdate;
+ try
+ FileHeaderBlock.FirstDataBlock := PotentialFirstBlock;
+ finally
+ FileHeaderBlock.EndUpdate;
+ end;
+ end
+ else begin
+ { This will be handled later when the data chain is reviewed. }
+ end; { if..else }
+ end;
+
+ if FileHeaderBlock.LastDataBlock = BlockNum then begin
+ { Update the file header with the last data block. }
+ if PotentialLastBlock <> ffc_W32NoValue then begin
+ FileHeaderBlock.BeginUpdate;
+ try
+ FileHeaderBlock.LastDataBlock := PotentialLastBlock;
+ finally
+ FileHeaderBlock.EndUpdate;
+ end;
+ end
+ else begin
+ { This will be handled later when the data chain is reviewed. }
+ end; { if..else }
+ end;
+
+end;
+{--------}
+function TffRepairEngine.GetDictBlock(const Inx : Longint) : IStreamBlock;
+begin
+ { TODO:: Verify state of repair engine }
+ Result := FFileInterface.DictBlocks[Inx];
+end;
+{--------}
+function TffRepairEngine.GetDictBlockCount : Longint;
+begin
+ { TODO:: Verify state of repair engine }
+ Result := FFileInterface.DictBlockCount;
+end;
+{--------}
+function TffRepairEngine.GetErrorCodes(const Inx : Integer) : Integer;
+begin
+ { TODO:: Verify state of repair engine }
+ Result := Integer(FErrorCodes[Inx]);
+end;
+{--------}
+function TffRepairEngine.GetErrorCount : Integer;
+begin
+ { TODO:: Verify state of repair engine }
+ Result := FErrors.Count;
+end;
+{--------}
+function TffRepairEngine.GetErrors(const Inx : Integer) : string;
+begin
+ { TODO:: Verify state of repair engine }
+ Result := FErrors[Inx];
+end;
+{--------}
+function TffRepairEngine.GetFixCodes(const Inx : Integer) : Integer;
+begin
+ { TODO:: Verify state of repair engine }
+ Result := Integer(FFixCodes[Inx]);
+end;
+{--------}
+function TffRepairEngine.GetFixCount : Integer;
+begin
+ { TODO:: Verify state of repair engine }
+ Result := FFixes.Count;
+end;
+{--------}
+function TffRepairEngine.GetFixes(const Inx : Integer) : string;
+begin
+ { TODO:: Verify state of repair engine }
+ Result := FFixes[Inx];
+end;
+{--------}
+function TffRepairEngine.GetBlock(const BlockNumber : Longint) : ICommonBlock;
+begin
+ { TODO:: Verify state of repair engine }
+ Result := FFileInterface.GetBlock(BlockNumber);
+ if Result <> nil then
+ Result.OnGetInfo := GetInfo;
+end;
+{--------}
+function TffRepairEngine.GetFileHeaderBlock : IFileHeaderBlock;
+begin
+ { TODO:: Verify state of repair engine }
+ Result := FFileInterface.GetFileHeaderBlock;
+ if Result <> nil then
+ Result.OnGetInfo := GetInfo;
+end;
+{--------}
+function TffRepairEngine.GetFreeChainDetails : TStringList;
+begin
+ PopulateChainMgrs;
+ Result := FChainMgrFree.Describe;
+end;
+{--------}
+function TffRepairEngine.GetIndexHeaderBlock : IIndexHeaderBlock;
+begin
+ { TODO:: Verify state of repair engine }
+ Result := FFileInterface.GetIndexHeaderBlock;
+ if Result <> nil then
+ Result.OnGetInfo := GetInfo;
+end;
+{--------}
+procedure TffRepairEngine.GetInfo(var Info : TffGeneralFileInfo);
+begin
+ Info := FInfo;
+end;
+{--------}
+function TffRepairEngine.GetDataChainDetails : TStringList;
+begin
+ PopulateChainMgrs;
+ Result := FChainMgrData.Describe;
+end;
+{--------}
+procedure TffRepairEngine.HandleRebuildProgress(FileInterface : TffFileInterface;
+ Position, Maximum : Integer);
+begin
+ ReportProgress(Position, Maximum);
+end;
+{--------}
+procedure TffRepairEngine.HandleReportError(Block : ICommonBlock;
+ const ErrCode : Integer;
+ const ErrorStr : string);
+begin
+ if Block = nil then
+ FErrors.Add(Format('Code %d: %s', [ErrCode, ErrorStr]))
+ else
+ FErrors.Add(Format('Block %d, code %d: %s',
+ [Block.BlockNum, ErrCode, ErrorStr]));
+ FErrorCodes.Add(Pointer(Errcode));
+ { Record the most severe action that must be taken to repair this file. }
+ if rcAction[ErrCode] > FHighestAction then
+ FHighestAction := rcAction[ErrCode];
+
+ { Detect errors that must be handled at this level. }
+ if ErrCode = rciInvalidUsedBlocks then
+ { Indicate that the used blocks field in the file header is invalid. }
+ FUsedBlocksValid := False
+ else if ErrCode = rciUnknownBlockType then
+ { The block type is not valid. When repairing, it will be switched to a
+ free block. However, we must make sure it is not in the chain of used
+ data blocks & is not referenced as the first or last data block in the
+ file header. }
+ FUnknownBlocks.Add(Pointer(Block.BlockNum));
+
+ if Assigned(FOnReportError) then
+ FOnReportError(Block, ErrCode, ErrorStr);
+
+ { Have we reached the error limit? }
+ if (State = rmVerify) and (FErrors.Count = FErrorLimit) then
+ FAbort := True;
+end;
+{--------}
+procedure TffRepairEngine.HandleReportFix(Block : ICommonBlock;
+ const ErrCode : Integer;
+ const RepairStr : string);
+begin
+ if Block = nil then
+ FErrors.Add(Format('Code %d: %s', [ErrCode, RepairStr]))
+ else
+ FFixes.Add(Format('Block %d (%d): %s',
+ [Block.BlockNum, ErrCode, RepairStr]));
+ FFixCodes.Add(Pointer(Errcode));
+ if ErrCode = rciInvalidUsedBlocks then
+ FUsedBlocksValid := True;
+ if Assigned(FOnReportFix) then
+ FOnReportFix(Block, ErrCode, RepairStr);
+end;
+{--------}
+procedure TffRepairEngine.LinkDataCallback(const Block1Num, Block2Num : TffWord32);
+var
+ Block1, Block2 : IDataBlock;
+begin
+ Block1 := FFileInterface.GetBlock(Block1Num) as IDataBlock;
+ Block2 := FFileInterface.GetBlock(Block2Num) as IDataBlock;
+
+ Block1.BeginUpdate;
+ try
+ Block1.NextDataBlock := Block2Num;
+ finally
+ Block1.EndUpdate;
+ Block1 := nil;
+ end;
+
+ Block2.BeginUpdate;
+ try
+ Block2.PrevDataBlock := Block1Num;
+ finally
+ Block2.EndUpdate;
+ Block2 := nil;
+ end;
+end;
+{--------}
+function TffRepairEngine.MapItemToActionStr(const Item : TffRepairItem;
+ const State : TffRepairState): string;
+begin
+ if State = rmVerify then
+ case Item of
+ riFileHeader : Result := 'Verifying file header';
+ riBlockScan : Result := 'Scanning blocks';
+ riCheckDictionary : Result := 'Verifying dictionary';
+ riBlockChains : Result := 'Verifying block chains';
+ riDeletedBLOBChain : Result := 'Verifying deleted BLOB chain';
+ end
+ else if State = rmRepair then
+ case Item of
+ riFileHeader : Result := 'Repairing file header';
+ riBlockScan : Result := 'Repairing blocks';
+ riCheckDictionary : Result := 'Repairing dictionary';
+ riBlockChains : Result := 'Repairing block chains';
+ riDeletedBLOBChain : Result := 'Repairing deleted BLOB chain';
+ riReindex : Result := 'Reindexing';
+ riPack : Result := 'Packing';
+ end
+end;
+{--------}
+procedure TffRepairEngine.MoveDataOrphanCallback(const BlockMoved, PrevBlock : TffWord32);
+var
+ MovedBlock, PreviousDataBlock : IDataBlock;
+begin
+ MovedBlock := FFileInterface.GetBlock(BlockMoved) as IDataBlock;
+ PreviousDataBlock := FFileInterface.GetBlock(PrevBlock) as IDataBlock;
+ MovedBlock.BeginUpdate;
+ try
+ MovedBlock.PrevDataBlock := PrevBlock;
+ MovedBlock.NextDataBlock := ffc_W32NoValue;
+ finally
+ MovedBlock.EndUpdate;
+ MovedBlock := nil;
+ end;
+
+ PreviousDataBlock.BeginUpdate;
+ try
+ PreviousDataBlock.NextDataBlock := BlockMoved;
+ finally
+ PreviousDataBlock.EndUpdate;
+ PreviousDataBlock := nil;
+ end;
+end;
+{--------}
+procedure TffRepairEngine.Open(const FileName :string);
+begin
+ if FileExists(FileName) then begin
+ ClearFileInterface;
+ FFileInterface := TffFileInterface.FindInterface(FileName);
+ if FFileInterface = nil then
+ raise Exception.Create('Could not find an interface to handle this file.')
+ else begin
+ FFileInterface.Open(FileName);
+ FFileInterface.OnReportError := HandleReportError;
+ FFileInterface.OnReportFix := HandleReportFix;
+ FInfo := FFileInterface.GetFileInfo;
+ ClearChainMgrs;
+ FChainMgrData := TffChainMgr.Create;
+ FChainMgrFree := TffChainMgr.Create;
+ end;
+ end
+ else
+ raise Exception.Create('File ' + FileName + ' does not exist.');
+end;
+{--------}
+procedure TffRepairEngine.PopulateChainMgrs;
+var
+ FileHeaderBlock : IFileHeaderBlock;
+ Block : ICommonBlock;
+ DataBlock : IDataBlock;
+ Inx,
+ MaxBlocks : TffWord32;
+begin
+ { TODO:: File must be open. }
+
+ { If the chain managers have not been populated then scan through the
+ blocks. }
+ if not FChainMgrData.Populated then begin
+ FileHeaderBlock := GetFileHeaderBlock;
+ if FUsedBlocksValid then
+ MaxBlocks := FileHeaderBlock.UsedBlocks
+ else
+ MaxBlocks := FileHeaderBlock.EstimatedUsedBlocks;
+ for Inx := 1 to Pred(MaxBlocks) do begin
+ Block := FFileInterface.GetBlock(Inx);
+ { If this is a data block or free block then add information to the
+ appropriate chain manager. }
+ if Block.BlockType = btData then begin
+ DataBlock := (Block as IDataBlock);
+ FChainMgrData.AddBlock(Block.BlockNum,
+ DataBlock.NextDataBlock,
+ DataBlock.PrevDataBlock)
+ end
+ else if Block.BlockType = btFree then
+ FChainMgrFree.AddBlock(Block.BlockNum,
+ Block.NextBlock,
+ ffc_W32NoValue);
+ Block := nil;
+ end; { for }
+ FChainMgrFree.Fixup;
+ FChainMgrData.Fixup;
+ FChainMgrFree.Populated := True;
+ FChainMgrData.Populated := True;
+ end; { if }
+end;
+{--------}
+procedure TffRepairEngine.Repair;
+begin
+ if FState <> rmIdle then
+ raise Exception.Create('The Repair method can be called' + csIdle);
+ FState := rmRepair;
+ VerifyRepair;
+end;
+{--------}
+procedure TffRepairEngine.ReportProgress(const Position, Maximum : Integer);
+var
+ ActionStr : string;
+begin
+ if Assigned(FOnProgress) then begin
+ ActionStr := MapItemToActionStr(FCurrentItem, FState);
+ FOnProgress(Self, FState, FCurrentItem, ActionStr, Position, Maximum);
+ end;
+end;
+{--------}
+procedure TffRepairEngine.SetErrorLimit(const Value : Integer);
+begin
+ if FState = rmIdle then
+ FErrorLimit := Value
+ else
+ raise Exception.Create('ErrorLimit can be set' + csIdle);
+end;
+{--------}
+procedure TffRepairEngine.SetItems(const Value : TffRepairItems);
+begin
+ if FState = rmIdle then
+ FItems := Value
+ else
+ raise Exception.Create('RepairItems can be set' + csIdle);
+end;
+{--------}
+procedure TffRepairEngine.Verify;
+begin
+ if FState <> rmIdle then
+ raise Exception.Create('The Verify method can be called' + csIdle);
+
+ FState := rmVerify;
+ VerifyRepair;
+end;
+{--------}
+procedure TffrepairEngine.CheckLastBlock;
+var
+ Block : ICommonBlock;
+ DataBlock : IDataBlock;
+begin
+ { The last block's NextBlock reference should be ffc_W32NoValue. }
+ if (FChainMgrData.LastBlockNumber <> ffc_W32NoValue) and
+ (FChainMgrData.LastBlockNextBlockNumber <> ffc_W32NoValue) then begin
+ { Get the last data block. }
+ Block := FFileInterface.GetBlock(FChainMgrData.LastBlockNumber);
+ try
+ Block.BeginUpdate;
+ try
+ DataBlock := (Block as IDataBlock);
+ DataBlock.NextDataBlock := ffc_W32NoValue;
+ DoReportFix(Block, rciInvalidBlockRefNext, [ffc_W32NoValue]);
+ finally
+ Block.EndUpdate;
+ end;
+ finally
+ Block := nil;
+ end;
+ end; { if }
+end;
+{--------}
+procedure TffRepairEngine.VerifyRepair;
+var
+ FileHeaderBlock : IFileHeaderBlock;
+ Block : ICommonBlock;
+ DataBlock : IDataBlock;
+ Inx,
+ BlockNum,
+ MaxBlocks : TffWord32;
+begin
+ FChainMgrData.Clear;
+ FChainMgrFree.Clear;
+ ClearErrors;
+ try
+ { Init vars }
+ FInfo.Free;
+ FInfo := FFileInterface.GetFileInfo;
+ FUsedBlocksValid := True;
+ FileHeaderBlock := GetFileHeaderBlock;
+
+ { Verify the file header. }
+ if riFileHeader in FItems then begin
+ FCurrentItem := riFileHeader;
+ ReportProgress(25, 100);
+ FileHeaderBlock.OnGetInfo := GetInfo;
+ if FState = rmVerify then
+ FileHeaderBlock.Verify
+ else
+ FileHeaderBlock.Repair;
+ ReportProgress(100, 100);
+ end;
+
+ if FAbort then
+ Exit;
+
+ { Scan through the blocks. }
+ if (riBlockScan in FItems) then begin
+ FCurrentItem := riBlockScan;
+ if FUsedBlocksValid then
+ MaxBlocks := FileHeaderBlock.UsedBlocks
+ else
+ MaxBlocks := FileHeaderBlock.EstimatedUsedBlocks;
+ ReportProgress(0, MaxBlocks);
+ for Inx := 1 to Pred(MaxBlocks) do begin
+ Block := FFileInterface.GetBlock(Inx);
+ try
+ { If this is a data block or free block then add information to the
+ appropriate chain manager. }
+ if Block.BlockType = btData then begin
+ DataBlock := Block as IDataBlock;
+ try
+ FChainMgrData.AddBlock(Block.BlockNum,
+ DataBlock.NextDataBlock,
+ DataBlock.PrevDataBlock);
+ finally
+ DataBlock := nil;
+ end;
+ end
+ else if Block.BlockType = btFree then
+ FChainMgrFree.AddBlock(Block.BlockNum,
+ Block.NextBlock,
+ ffc_W32NoValue);
+ Block.OnGetInfo := GetInfo;
+ if FState = rmVerify then
+ Block.Verify
+ else
+ Block.Repair;
+ finally
+ Block := nil;
+ end;
+ ReportProgress(Inx, MaxBlocks + TffWord32(FUnknownBlocks.Count));
+ if FAbort then
+ Exit;
+ end; { for }
+
+ { Check for the case where there is only 1 data block or 1 free block
+ in the table. }
+ FChainMgrFree.Fixup;
+ FChainMgrData.Fixup;
+ FChainMgrFree.Populated := True;
+ FChainMgrData.Populated := True;
+
+ { Are we repairing and, if so, were any unknown blocks encountered? }
+ if FState = rmRepair then begin
+ { Yes. Roll through the blocks. By this point we assume they have been
+ marked as free blocks. }
+ if FUnknownBlocks.Count > 0 then
+ { Note: The previous line was added because Inx is TffWord32 and
+ Pred(FUnknownBlocks.Count) = -1 which translates to the max value
+ of TffWord32 }
+ for Inx := Pred(FUnknownBlocks.Count) downto 0 do begin
+ BlockNum := TffWord32(FUnknownBlocks[Inx]);
+ FixUnknownBlock(BlockNum, FileHeaderBlock);
+ FUnknownBlocks.Delete(Inx);
+ ReportProgress(MaxBlocks + Inx,
+ MaxBlocks + TffWord32(FUnknownBlocks.Count));
+ end; { for }
+ end; { if }
+ end;
+
+ if FAbort then
+ Exit;
+
+ if riCheckDictionary in FItems then begin
+ FCurrentItem := riCheckDictionary;
+ { TODO }
+ end;
+
+ if FAbort then
+ Exit;
+
+ if FAbort then
+ Exit;
+
+ if riBlockChains in FItems then begin
+ FCurrentItem := riBlockChains;
+ { Verify the data block chain first. }
+ { Are the used data blocks split across multiple chains? }
+ if not FChainMgrData.HasValidChain then begin
+ DoReportError(nil, rciSplitUsedDataBlocks, []);
+ if FState = rmRepair then begin
+ FChainMgrData.LinkChains(LinkDataCallback);
+ DoReportFix(nil, rciSplitUsedDataBlocks, []);
+ end;
+ end; { if }
+ ReportProgress(20, 100);
+
+ { Are there any orphaned blocks? }
+ if FChainMgrData.HasOrphans then begin
+ DoReportError(nil, rciOrphanedUsedDataBlocks, []);
+ if FState = rmRepair then begin
+ { Add each orphan to the end of the data chain. }
+ FChainMgrData.MoveOrphansToTail(MoveDataOrphanCallback);
+ DoReportFix(nil, rciOrphanedUsedDataBlocks, []);
+ end;
+ end; { if }
+ ReportProgress(40, 100);
+
+ if FState = rmRepair then begin
+ CheckLastBlock;
+ { Note: The code for CheckLastBlock was put into its own procedure
+ in order to force the block to go out of scope & be freed prior
+ to the table being packed. }
+
+ { Verify the LastDataBlock property of the file header block. Get what
+ should be the last data block from the chain manager. }
+ if (FileHeaderBlock.LastDataBlock <> FChainMgrData.LastBlockNumber) then begin
+ FileHeaderBlock.BeginUpdate;
+ try
+ FileHeaderBlock.LastDataBlock := FChainMgrData.LastBlockNumber;
+ DoReportFix(FileHeaderBlock, rciInvalidBlockRefLastData,
+ [FileHeaderBlock.LastDataBlock]);
+ finally
+ FileHeaderBlock.EndUpdate;
+ end;
+ end; { if }
+ end;
+
+
+ { Check the free block chain. }
+ { TODO }
+
+ { Verify the FirstDataBlock property of the file header block. }
+ { TODO }
+
+ ReportProgress(100, 100);
+ end;
+
+ if FAbort then
+ Exit;
+
+ if riDeletedBLOBChain in FItems then begin
+ FCurrentItem := riDeletedBLOBChain;
+ { TODO }
+ end;
+
+ if FAbort then
+ Exit;
+
+ { Any high-level repairs necessary? }
+ if (FState = rmRepair) and (FHighestAction = raPack) then begin
+ { Deref the file header block so that it will be fully freed when the file
+ is closed for a reindex or pack. }
+ FileHeaderBlock := nil;
+ FFileInterface.OnRebuildProgress := HandleRebuildProgress;
+ FFileInterface.OutputVersion := FOutputVersion;
+ FCurrentItem := riPack;
+ FFileInterface.Pack;
+ end; { if }
+ finally
+ FState := rmIdle;
+ if Assigned(FCompleted) then
+ FCompleted(Self);
+ end;
+end;
+{====================================================================}
+
+end.
diff --git a/components/flashfiler/sourcelaz/Verify/ffrepcnst.pas b/components/flashfiler/sourcelaz/Verify/ffrepcnst.pas
new file mode 100644
index 000000000..ad237ee07
--- /dev/null
+++ b/components/flashfiler/sourcelaz/Verify/ffrepcnst.pas
@@ -0,0 +1,257 @@
+{*********************************************************}
+{* FlashFiler: FF 2 file repair constants *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffrepcnst;
+
+interface
+
+type
+ TffRepairAction = (raDecide, raSelfRepair, raPack, raUnsalvageable);
+ { This enumerated type represents the different types of repair actions
+ that may be taken. Values:
+
+ raDecide - The parent repair logic must decide what action to take based
+ upon the current context. For example, if the data dictionary block
+ reported that it had an unknown block type then the repair logic could
+ decide the table is unsalvageable. But if it were an index or data
+ block that did not know its block type then the repair logic could
+ decide the table needed to be reindexed or restructured.
+
+ raSelfRepair - Allow the block to repair itself.
+
+ raPack - Restructure the table.
+
+ raUnsalvageable - The data is so badly damaged that nothing can be
+ done with the table.
+
+ }
+
+const
+
+ { Verify error codes. }
+ rciUnknownBlockType = 1;
+ rciInvalidBlockRefNext = 2;
+ rciInvalidBlockRefDict = 3;
+ rciInvalidThisBlock = 4;
+ rciInvalidBlockSize = 5;
+ rciNoDictBlock = 6;
+ rciInvalidInt64 = 7;
+ rciNoDataBlockForRecs = 8;
+ rciInvalidBlockRefFirstData = 9;
+ rciInvalidBlockRefFirstFree = 10;
+ rciInvalidSeqIndexFlag = 11;
+ rciInvalidBlockRefIndexHead = 12;
+ rciNoLastDataBlockForRecs = 13;
+ rciInvalidBlockRefLastData = 14;
+ rciInvalidLog2BlockSize = 15;
+ rciInvalidUsedBlocks = 16;
+ rciInxHeaderInvalidRowCount = 17;
+ rciInxHeaderInvalidKeyLen = 18;
+ rciInxHeaderInvalidKeyCount = 19;
+ rciInxHeaderNoRootPage = 20;
+ rciInxHeaderInvalidRootPage = 21;
+ rciInxHeaderNoRefsFlag = 22;
+ rciInxHeaderNoDupsFlag = 23;
+ rciInvalidInxPrefPageRef = 24;
+ rciInxInvalidBlockRef = 25;
+ rciInvalidLeafKeyBlockRef = 26;
+ rciInvalidLeafKeyRefNum = 27;
+ rciInvalidIntrnalKeyBlockRef = 28;
+ rciInvalidIntrnalKeyRefNum = 29;
+ rciInvalidDataBlockRecCount = 30;
+ rciInvalidDataBlockRecLen = 31;
+ rciInvalidNextDataBlock = 32;
+ rciInvalidPrevDataBlock = 33;
+ rciBLOBDeleted = 34;
+ rciBLOBContentBlockSignature = 35;
+ rciBLOBContentSegSignature = 36;
+ rciBLOBInvalidRefNr = 37;
+ rciBLOBInvalidLookupRefNr = 38;
+ rciBLOBInvalidContentRefNr = 39;
+ rciBLOBHeaderSignature = 40;
+ rciPackFailure = 41;
+ rciOrphanedUsedDataBlocks = 42;
+ rciSplitUsedDataBlocks = 43;
+
+ rciNumErrCodes = 43;
+
+ { Verify error strings per error. }
+ rcErrStr : array[1..rciNumErrCodes] of string =
+ (
+{1} 'Unknown block type: %d.',
+{2} 'Invalid block reference, Next Block points to block %d.',
+{3} 'Invalid block reference, DataDict points to block %d.',
+{4} 'Invalid internal block number. Should be %d but is set to %d.',
+{5} 'Invalid block size: %d.',
+{6} 'File header DataDictBlockNum does not point to a data dictionary.',
+{7} 'Invalid %s, value: %d:%d.',
+{8} 'Record count is %d but FirstDataBlock does not point to a data block.',
+{9} 'Invalid block reference, FirstDataBlock points to non-data block %d.',
+{10} 'Invalid block reference, FirstFreeBlock points to active block %d.',
+{11} 'Invalid sequential access index flag in file header, value: %d.',
+{12} 'Invalid block reference, IndexHeaderBlockNum points to non-index block %d.',
+{13} 'Record count is %d but LastDataBlock does not point to a data block.',
+{14} 'Invalid block reference, LastDataBlock points to non-data block %d',
+{15} 'Invalid Log2 block size. For block size %d, expected %d but actual value is %d.',
+{16} 'Invalid Used Blocks count. Calculated as %d but actual value is %d.',
+{17} 'Index header contains %d rows but there are %d indices in the dictionary.',
+{18} 'Index header row %d specifies key length of %d but dictionary specifies key length of %d',
+{19} 'Index header row %d specifies the index contains %d keys but there are %d records in the table.',
+{20} 'No root page specified for row %d of index header',
+{21} 'Root page reference in row %d of index header does not point to an index block',
+{22} 'Row 0 of index header does not have "keys are reference numbers" flag set',
+{23} 'Dictionary indicates index %d allows duplicate keys but the row %d in the index header does not have this flag set',
+{24} 'Index block previous page reference points to non-index block %d',
+{25} 'Key %d of leaf index block %d (index %d) references block %d',
+{26} 'Key %d of leaf index block %d (index %d) points to data block %d but that block is not a data block. The refNum for that key is %d:%d. %s',
+{27} 'Key %d of leaf index block %d (index %d) points to data block %d. The RefNum (%d:%d) is invalid for that data block.',
+{28} 'Key %d of internal index block %d (index %d) points to index block %d but that block is not an index block. The refNum for that key is %d:%d. %s',
+{29} 'Key %d of internal index block %d (index %d) points to data block %d. The RefNum (%d:%d) is invalid for that data block.',
+{30} 'Header of data block %d says record count is %d but it is listed as %d records per block in the file header',
+{31} 'Header of data block %d says record length is %d but it is listed as %d in the data dictionary',
+{32} 'Header of data block %d points to next data block %d but that block is not a data block',
+{33} 'Header of data block %d points to previous data block %d but that block is not a data block',
+{34} 'The BLOB is marked as deleted (BLOB field "%s", BLOB refnum %d:%d, key fields: %s, record %d of data block %d)',
+{35} 'A content block has an invalid signature (BLOB field "%s", BLOB refnum %d:%d, key fields: [%s], record %d of data block %d)',
+{36} 'A content segment has an invalid signature (BLOB field "%s", BLOB refnum %d:%d, key fields: [%s], record %d of data block %d)',
+{37} 'Invalid BLOB reference number (BLOB field "%s", BLOB refnum %d:%d, key fields: [%s], record %d (base 0) of data block %d)',
+{38} 'Invalid BLOB lookup segment reference number (BLOB field "%s", BLOB refnum %d:%d, key fields: [%s], record %d (base 0) of data block %d)',
+{39} 'Invalid BLOB content segment reference number (BLOB field "%s", BLOB refnum %d:%d, key fields: [%s], record %d (base 0) of data block %d)',
+{40} 'Invalid BLOB header signature (BLOB field "%s", BLOB refnum %d:%d, key fields: [%s], record %d (base 0) of data block %d)',
+{41} 'Could not pack table: %s',
+{42} 'There are data blocks that are not part of the used data block chain',
+{43} 'There are breaks in the chain of used data blocks'
+ );
+
+ { Recommended actions per error. }
+ rcAction : array[1..rciNumErrCodes] of TffRepairAction =
+ (
+ raSelfRepair, {rciUnknownBlockType}
+ raDecide, {rciInvalidBlockRefNext}
+ raDecide, {rciInvalidBlockRefDict}
+ raSelfRepair, {rciInvalidThisBlock}
+ raDecide, {rciInvalidBlockSize}
+ raDecide, {rciNoDictBlock}
+ raPack, {rciInvalidInt64}
+ raPack, {rciNoDataBlockForRecs}
+ raPack, {rciInvalidBlockRefFirstData}
+ raPack, {rciInvalidBlockRefFirstFree}
+ raSelfRepair, {rciInvalidSeqIndexFlag}
+ raPack, {rciInvalidBlockRefIndexHead}
+ raPack, {rciNoLastDataBlockForRecs}
+ raPack, {rciInvalidBlockRefLastData}
+ raSelfRepair, {rciInvalidLog2BlockSize}
+ raSelfRepair, {rciInvalidUsedBlocks}
+ raPack, {rciInxHeaderInvalidRowCount}
+ raPack, {rciInxHeaderInvalidKeyLen}
+ raPack, {rciInxHeaderInvalidKeyCount}
+ raPack, {rciInxHeaderNoRootPage}
+ raPack, {rciInxHeaderInvalidRootPage}
+ raPack, {rciInxHeaderNoRefsFlag}
+ raPack, {rciInxHeaderNoDupsFlag}
+ raPack, {rciInvalidInxPrefPageRef}
+ raPack, {rciInxInvalidPageRef}
+ raPack, {rciInvalidLeafKeyBlockRef}
+ raPack, {rciInvalidLeafKeyRefNum}
+ raPack, {rciInalidIntrnalKeyBlockRef}
+ raPack, {rciInvalidIntrnalKeyRefNum}
+ raSelfRepair, {rciInvalidDataBlockRecCount}
+ raSelfRepair, {rciInvalidDataBlockRecLen}
+ raPack, {rciInvalidNextDataBlock}
+ raPack, {rciInvalidPrevDataBlock}
+ raPack, {rciBLOBDeleted}
+ raPack, {rciBLOBContentBlockSignature}
+ raPack, {rciBLOBContentSegSignature}
+ raPack, {rciBLOBInvalidRefNr}
+ raPack, {rciBLOBInvalidLookupRefNr}
+ raPack, {rciBLOBInvalidContentRefNr}
+ raPack, {rciBLOBHeaderSignature}
+ raUnsalvageable, {rciPackFailure}
+ raSelfRepair, {rciOrphanedUsedDataBlocks}
+ raSelfRepair {rciSplitUsedDataBlocks}
+ );
+
+ { How the problem was repaired. Specify values only for those problems that
+ can be self-repaired. }
+
+ csBLOBRefSetToNull = 'BLOB reference set to null (field "%s", key fields: [%s], record %d of data block %d).';
+
+ rcFixStr : array[1..rciNumErrCodes] of string =
+ (
+ 'Block %d marked as a free block', {rciUnknownBlockType}
+ 'NextBlock set to value %d.', {rciInvalidBlockRefNext}
+ '', {rciInvalidBlockRefDict}
+ 'ThisBlock set to value %d.', {rciInvalidThisBlock}
+ '', {rciInvalidBlockSize}
+ '', {rciNoDictBlock}
+ '', {rciInvalidInt64}
+ '', {rciNoDataBlockForRecs}
+ '', {rciInvalidBlockRefFirstData}
+ '', {rciInvalidBlockRefFirstFree}
+ 'Sequential index flag set to value %d.', {rciInvalidSeqIndexFlag}
+ '', {rciInvalidBlockRefIndexHead}
+ '', {rciNoLastDataBlockForRecs}
+ 'Last Data Block set to value %d.', {rciInvalidBlockRefLastData}
+ 'Log 2 block size set to value %d.', {rciInvalidLog2BlockSize}
+ 'Used block count set to value %d.', {rciInvalidUsedBlocks}
+ '', {rciInxHeaderInvalidRowCount}
+ '', {rciInxHeaderInvalidKeyLen}
+ '', {rciInxHeaderInvalidKeyCount}
+ '', {rciInxHeaderNoRootPage}
+ '', {rciInxHeaderInvalidRootPage}
+ '', {rciInxHeaderNoRefsFlag}
+ '', {rciInxHeaderNoDupsFlag}
+ '', {rciInvalidInxPrefPageRef}
+ '', {rciInxInvalidPageRef}
+ '', {rciInvalidLeafKeyBlockRef}
+ '', {rciInvalidLeafKeyRefNum}
+ '', {rciInvalidIntrnalKeyBlockRef}
+ '', {rciInvalidIntrnalKeyRefNum}
+ 'Record count in data block %d set to %d.', {rciInvalidDataBlockRecCount}
+ 'Record length in data block %d set to %d.', {rciInvalidDataBlockRecLen}
+ '', {rciInvalidNextDataBlock}
+ '', {rciInvalidPrevDataBlock}
+ csBLOBRefSetToNull, {rciBLOBDeleted}
+ csBLOBRefSetToNull, {rciBLOBContentBlockSignature}
+ csBLOBRefSetToNull, {rciBLOBContentSegSignature}
+ csBLOBRefSetToNull, {rciBLOBInvalidRefNr}
+ csBLOBRefSetToNull, {rciBLOBInvalidLookupRefNr}
+ csBLOBRefSetToNull, {rciBLOBInvalidContentRefNr}
+ csBLOBRefSetToNull, {rciBLOBHeaderSignature}
+ '', {rciPackFailure}
+ 'Orphaned data blocks added to used block chain.', {rciOrphanedUsedDataBlocks}
+ 'Used data block chain repaired.' {rciSplitUsedDataBlocks}
+ );
+
+
+implementation
+
+end.
diff --git a/components/flashfiler/sourcelaz/Verify/ffv2file.pas b/components/flashfiler/sourcelaz/Verify/ffv2file.pas
new file mode 100644
index 000000000..3b4f806f9
--- /dev/null
+++ b/components/flashfiler/sourcelaz/Verify/ffv2file.pas
@@ -0,0 +1,2360 @@
+{*********************************************************}
+{* FlashFiler: FF 2 file & block interface classes *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffv2file;
+
+interface
+
+uses
+ Classes,
+ FFFileInt,
+ FFLLBase,
+ FFSrBase,
+ FFTbDict;
+
+type
+ Tffv2FileInterface = class(TffFileInterface)
+ { Implements the interface for FF 2.xx tables. }
+ protected
+ FBufMgr : TffBufferManager;
+ { Buffer manager used to manage file blocks. }
+ FDict : TffServerDataDict;
+ { Server data dictionary. }
+ FDictBlocks : TInterfaceList;
+ { List of data dictionary blocks. }
+ FFileInfo : PffFileInfo;
+ { Structure used to store information about file being verified. }
+ FFileHeaderBlock : IFileHeaderBlock;
+ FIndexHeaderBlock : IIndexHeaderBlock;
+ FOnReportError : TffReportErrorEvent;
+ FOnReportFix : TffReportFixEvent;
+
+ FTI : PffTransInfo;
+ { Fake transaction information. }
+
+ procedure CloseCurrentFile;
+ { If a file is open, this method closes the file. }
+
+ function GetDictBlockCount : Integer; override;
+ function GetDictBlocks(const Inx : Longint) : IStreamBlock; override;
+ function GetOnReportError : TffReportErrorEvent; override;
+ function GetOnReportFix : TffReportFixEvent; override;
+
+ procedure SetOnReportError(Value : TffReportErrorEvent); override;
+ procedure SetOnReportFix(Value : TffReportFixEvent); override;
+ procedure SetOutputVersion(const Value : Longint); override;
+
+ public
+ destructor Destroy; override;
+
+ procedure Initialize; override;
+
+ procedure Close; override;
+ { Close the currently opened file. }
+
+ function GetBlock(const BlockNumber : Longint) : ICommonBlock; override;
+ { Returns a specific block from the file. }
+
+ function GetFileHeaderBlock : IFileHeaderBlock; override;
+ { Returns the file header block. }
+
+ function GetFileInfo : TffGeneralFileInfo; override;
+ { Returns general file information that is made available to blocks. }
+
+ function GetIndexHeaderBlock : IIndexHeaderBlock; override;
+ { Returns the index header block. }
+
+ procedure Open(const Filename : string); override;
+ { Open a file for analysis. }
+
+ procedure Pack; override;
+
+ end;
+
+ Tffv2FileBlock = class(TffFileBlock)
+ protected
+ FIsModified : Boolean;
+ { Set to True when BeginUpdate is called.
+ Set to False when EndUpdate is called. }
+ public
+ constructor Create(BufMgr : TffBufferManager;
+ FileInfo : PffFileInfo;
+ TI : PffTransInfo;
+ const BlockNum : TffWord32); override;
+
+ procedure BeginUpdate; override;
+ procedure EndUpdate; override;
+ end;
+
+ TffFileHeaderBlock = class(Tffv2FileBlock, IFileHeaderBlock)
+ protected
+ function GetAvailBlocks : Longint; virtual;
+ function GetBLOBCount : TffWord32; virtual;
+ function GetBlockSize : Longint; virtual;
+ function GetDataDictBlockNum : TffWord32; virtual;
+ function GetDeletedBLOBHead : TffInt64; virtual;
+ function GetDeletedBLOBTail : TffInt64; virtual;
+ function GetDeletedRecordCount : Longint; virtual;
+ function GetEncrypted : Longint; virtual;
+ function GetEstimatedUsedBlocks : TffWord32; virtual;
+ function GetFFVersion : Longint; virtual;
+ function GetFieldCount : Longint; virtual;
+ function GetFirstDataBlock : TffWord32; virtual;
+ function GetFirstDeletedRecord : TffInt64; virtual;
+ function GetFirstFreeBlock : TffWord32; virtual;
+ function GetHasSequentialIndex : Longint; virtual;
+ function GetIndexCount : Longint; virtual;
+ function GetIndexHeaderBlockNum : TffWord32; virtual;
+ function GetLastAutoIncValue : TffWord32; virtual;
+ function GetLastDataBlock : TffWord32; virtual;
+ function GetLog2BlockSize : TffWord32; virtual;
+ function GetRecLenPlusTrailer : Longint; virtual;
+ function GetRecordCount : Longint; virtual;
+ function GetRecordLength : Longint; virtual;
+ function GetRecordsPerBlock : Longint; virtual;
+ function GetUsedBlocks : TffWord32; virtual;
+ function GetPropertyCell(const Row, Column : Integer) : string; override;
+ function GetPropertyRowCount : Integer; override;
+
+ procedure SetFirstDataBlock(const Value : TffWord32); virtual;
+ procedure SetFirstFreeBlock(const Value : TffWord32); virtual;
+ procedure SetHasSequentialIndex(const Value : Longint); virtual;
+ procedure SetLastDataBlock(const Value : TffWord32); virtual;
+ procedure SetLog2BlockSize(const Value : TffWord32); virtual;
+ procedure SetUsedBlocks(const Value : TffWord32); virtual;
+
+ procedure VerifyRepair(const Repair : Boolean); override;
+ { This method is used by both Verify & Repair. It carries out the actual
+ verification &, if specified, repairing of problems. }
+ public
+
+ { Properties }
+ property AvailBlocks : Longint
+ read GetAvailBlocks;
+ { The number of free blocks in the file. }
+
+ property BLOBCount : TffWord32
+ read GetBLOBCount;
+ { The number of BLOBs in the table. }
+
+ property BlockSize : Longint
+ read GetBlockSize;
+ { Size of blocks in bytes (e.g., 4k, 8k, 16k, 32k, 64k) }
+
+ property DataDictBlockNum : TffWord32
+ read GetDataDictBlockNum;
+ { The block number of the data dictionary. If there is no data
+ dictionary then this property returns the value zero. }
+
+ property DeletedBLOBHead : TffInt64
+ read GetDeletedBLOBHead;
+ { The file-relative offset of the first segment in the deleted BLOB
+ chain. }
+
+ property DeletedBLOBTail : TffInt64
+ read GetDeletedBLOBTail;
+ { The file-relative offset of the last segment in the deleted BLOB
+ chain. }
+
+ property DeletedRecordCount : Longint
+ read GetDeletedRecordCount;
+ { The number of deleted records in the table. }
+
+ property Encrypted : Longint
+ read GetEncrypted;
+ { 0 = not encrypted, 1 = encrypted }
+
+ property EstimatedUsedBlocks : TffWord32
+ read GetEstimatedUsedBlocks;
+ { For cases where the UsedBlocks counter is invalid, use this property
+ to estimate the number of used blocks in the file. This only works
+ in cases where the BlockSize is valid. }
+
+ property FFVersion : Longint
+ read GetFFVersion;
+ { The version of FlashFiler with which this table was created. }
+
+ property FieldCount : Longint
+ read GetFieldCount;
+ { The number of fields in a record. }
+
+ property FirstDataBlock : TffWord32
+ read GetFirstDataBlock write SetFirstDataBlock;
+ { The first data block in the chain of data blocks. }
+
+ property FirstDeletedRecord : TffInt64
+ read GetFirstDeletedRecord;
+ { The offset of the first record in the deleted record chain. }
+
+ property FirstFreeBlock : TffWord32
+ read GetFirstFreeBlock;
+ { The block number of the first free block in the deleted block chain. }
+
+ property HasSequentialIndex : Longint
+ read GetHasSequentialIndex write SetHasSequentialIndex;
+ { Identifies whether the table has a sequential index. A value of zero
+ means the table does not have a sequential index. A value of 1
+ means the table does have a sequential index. }
+
+ property IndexCount : Longint
+ read GetIndexCount;
+ { The number of indexes in the table. }
+
+ property IndexHeaderBlockNum : TffWord32
+ read GetIndexHeaderBlockNum;
+ { The block number of the index header. }
+
+ property LastAutoIncValue : TffWord32
+ read GetLastAutoIncValue;
+ { The last autoincrement value assigned to a record in the table. }
+
+ property LastDataBlock : TffWord32
+ read GetLastDataBlock write SetLastDataBlock;
+ { The last data block in the chain of data blocks. }
+
+ property Log2BlockSize : TffWord32
+ read GetLog2BlockSize write SetLog2BlockSize;
+ { log base 2 of BlockSize (e.g., 12, 13, 14, 15, or 16) }
+
+ property RecordCount : Longint
+ read GetRecordCount;
+ { The number of records in the table. }
+
+ property RecordLength : Longint
+ read GetRecordLength;
+ { The length of the record in bytes. }
+
+ property RecordLengthPlusTrailer : Longint
+ read GetRecLenPlusTrailer;
+ { The length of the record plus the deletion link. }
+
+ property RecordsPerBlock : Longint
+ read GetRecordsPerBlock;
+ { The number of records per data block. }
+
+ property UsedBlocks : TffWord32
+ read GetUsedBlocks write SetUsedBlocks;
+ { The number of blocks in the file. }
+
+ end;
+
+ TffIndexBlock = class(Tffv2FileBlock, IIndexBlock)
+ protected
+ function GetIndexBlockType : Byte; virtual;
+ function GetIsLeafPage : Boolean; virtual;
+ function GetNodeLevel : Byte; virtual;
+ function GetKeysAreRefs : Boolean; virtual;
+ function GetIndexNum : Word; virtual;
+ function GetKeyLength : Word; virtual;
+ function GetKeyCount : Longint; virtual;
+ function GetMaxKeyCount : Longint; virtual;
+ function GetPrevPageRef : TffWord32; virtual;
+ function GetPropertyCell(const Row, Column : Integer) : string; override;
+ function GetPropertyRowCount : Integer; override;
+
+ procedure VerifyRepair(const Repair : Boolean); override;
+ { This method is used by both Verify & Repair. It carries out the actual
+ verification &, if specified, repairing of problems. }
+ public
+ property IndexBlockType : Byte
+ read GetIndexBlockType;
+ { The type of index block. Header blocks have value 0, B-Tree pages
+ have value 1. }
+ property IsLeafPage : Boolean
+ read GetIsLeafPage;
+ { Returns False if this is an internal B-Tree page or True if this is
+ a leaf B-Tree page. }
+ property NodeLevel : Byte
+ read GetNodeLevel;
+ { Returns the node level. Leaves have value 1, increments. }
+ property KeysAreRefs : Boolean
+ read GetKeysAreRefs;
+ { Returns the value True if the keys in the index are record reference
+ numbers. }
+ property IndexNum : Word
+ read GetIndexNum;
+ { The index number with which the index page is associated. }
+ property KeyLength : Word
+ read GetKeyLength;
+ { The length of each key. }
+ property KeyCount : Longint
+ read GetKeyCount;
+ { The number of keys currently in the page. }
+ property MaxKeyCount : Longint
+ read GetMaxKeyCount;
+ { The maximum number of keys that may be placed within the page. }
+ property PrevPageRef : TffWord32
+ read GetPrevPageRef;
+ { Block number of the previous page. }
+ end;
+
+ TffIndexHeaderBlock = class(TffIndexBlock, IIndexBlock, IIndexHeaderBlock)
+ protected
+ FDataColumns : Integer;
+ FIndexHead : PffIndexHeader;
+ procedure VerifyRepair(const Repair : Boolean); override;
+ { This method is used by both Verify & Repair. It carries out the actual
+ verification &, if specified, repairing of problems. }
+ public
+ constructor Create(BufMgr : TffBufferManager;
+ FileInfo : PffFileInfo;
+ TI : PffTransInfo;
+ const BlockNum : TffWord32); override;
+
+ { Data access }
+ function GetDataCell(const Row, Column : Integer) : string; override;
+ function GetDataColCaption(const Index : Integer) : string; override;
+ function GetDataColCount : Integer; override;
+ function GetDataColWidth(const Index : Integer) : Integer; override;
+ function GetDataRowCount : Integer; override;
+ end;
+
+ TffDataBlock = class(Tffv2FileBlock, IDataBlock)
+ protected
+
+ FNumDataColumns : Integer;
+ { The number of columns calculated for the data view. }
+
+ function GetNextDataBlock : TffWord32; virtual;
+ function GetPrevDataBlock : TffWord32; virtual;
+ function GetRecCount : Longint; virtual;
+ function GetRecLen : Longint; virtual;
+
+ function IsEmptyLookupEntry(Entry : PffBLOBLookupEntry) : Boolean; virtual;
+
+ { Property access }
+ function GetPropertyCell(const Row, Column : Integer) : string; override;
+ function GetPropertyRowCount : Integer; override;
+
+ { Data access }
+ function GetDataCell(const Row, Column : Integer) : string; override;
+ function GetDataColCaption(const Index : Integer) : string; override;
+ function GetDataColCount : Integer; override;
+ function GetDataColWidth(const Index : Integer) : Integer; override;
+ function GetDataRowCount : Integer; override;
+
+ procedure SetNextDataBlock(const Value : TffWord32); virtual;
+ procedure SetPrevDataBlock(const Value : TffWord32); virtual;
+ procedure SetRecCount(const Value : Longint); virtual;
+ procedure SetRecLen(const Value : Longint); virtual;
+
+ procedure VerifyBLOB(const BLOBNr : TffInt64;
+ var ErrCode : Integer); virtual;
+ public
+ procedure VerifyRepair(const Repair : Boolean); override;
+
+ property RecordCount : Longint
+ read GetRecCount write SetRecCount;
+ { The maximum number of records in the block. }
+ property RecordLen : Longint
+ read GetRecLen write SetRecLen;
+ { The length of each record. }
+ property NextDataBlock : TffWord32
+ read GetNextDataBlock write SetNextDataBlock;
+ { The block # of the next data block. }
+ property PrevDataBlock : TffWord32
+ read GetPrevDataBlock write SetPrevDataBlock;
+ { The block # of the previous data block. }
+ end;
+
+ TffBLOBBlock = class(Tffv2FileBlock, IBLOBBlock)
+ protected
+ public
+ procedure VerifyRepair(const Repair : Boolean); override;
+ end;
+
+ TffStreamBlock = class(Tffv2FileBlock, IStreamBlock)
+ protected
+ function GetNextStrmBlock : TffWord32; virtual;
+ function GetStreamType : Longint; virtual;
+ function GetStreamLength : Longint; virtual;
+ function GetOwningStream : Longint; virtual;
+ function GetPropertyCell(const Row, Column : Integer) : string; override;
+ function GetPropertyRowCount : Integer; override;
+ public
+ procedure VerifyRepair(const Repair : Boolean); override;
+ end;
+
+implementation
+
+uses
+ FFDbBase,
+ FFFile,
+ FFRepCnst,
+ FFSrBDE,
+ FFSrBLOB,
+ FFSrEng,
+ FFTbData,
+ FFTbIndx,
+ FFUtil,
+ SysUtils,
+ Windows;
+
+const
+ FFStartVersion : Longint = 20000; {2.00.00}
+ FFEndVersion : Longint = 29999; {2.99.99, all FF 2 versions }
+
+ ciDataBlockRows = 4;
+ ciFileHeaderRows = 24;
+ ciIndexBlockRows = 9;
+ ciIndexHeaderDataColumns = 6;
+ ciStreamRows = 4;
+
+ csAlias = 'FFVerify';
+
+{ The following constants were copied from the implementation section of unit
+ FFTBBLOB. }
+const
+ ffc_FileBLOB = -1;
+ ffc_BLOBLink = -2;
+
+{ The following types were copied from the implementation section of unit
+ FFTBINDX. }
+
+type
+ PRef = ^TRef;
+ TRef = TffInt64;
+ PPageNum = ^TpageNum;
+ TPageNum = TffWord32;
+
+const
+ SizeOfRef = sizeof(TRef);
+ SizeOfPageNum = sizeof(TPageNum);
+
+type
+ PRefBlock = ^TRefBlock;
+ TRefBlock = array [0..($FFFFFFF div SizeOfRef)-1] of TRef;
+
+ PPageNumBlock = ^TPageNumBlock;
+ TPageNumBlock = array [0..($FFFFFFF div SizeOfPageNum)-1] of TPageNum;
+
+
+{===TffFileInterface=================================================}
+destructor Tffv2FileInterface.Destroy;
+begin
+ { If a file is open then close it. }
+ CloseCurrentFile;
+
+ FTI^.tirTrans.Free;
+ FFFreeMem(FTI, SizeOf(TffTransInfo));
+
+ if Assigned(FBufMgr) then
+ FBufMgr.free;
+
+ FDictBlocks.Free;
+
+ inherited;
+end;
+{--------}
+procedure Tffv2FileInterface.Initialize;
+begin
+ inherited;
+ FBufMgr := TffBufferManager.Create(GetCurrentDir, 1);
+ FBufMgr.MaxRAM := 20;
+ fileProcsInitialize;
+ FFGetMem(FTI, SizeOf(TffTransInfo));
+ FOutputVersion := FFVersionNumber;
+ FTI^.tirLockMgr := nil;
+ FTI^.tirTrans := TffSrTransaction.Create(1000, False, False);
+
+ FEndFFVersion := FFEndVersion;
+ FStartFFVersion := FFStartVersion;
+
+ FDictBlocks := TInterfaceList.Create;
+end;
+{--------}
+procedure Tffv2FileInterface.Close;
+begin
+ CloseCurrentFile;
+end;
+{--------}
+procedure Tffv2FileInterface.CloseCurrentFile;
+var
+ Inx : Integer;
+begin
+ if Assigned(FDict) then begin
+ FDict.Free;
+ FDict := nil;
+ end;
+
+ if FFileHeaderBlock <> nil then
+ FFileHeaderBlock := nil;
+ { No need to free since it will be autofreed. }
+
+ if FIndexHeaderBlock <> nil then
+ FIndexHeaderBlock := nil;
+
+ { Free the list of dictionary blocks. }
+ for Inx := Pred(FDictBlocks.Count) downto 0 do
+ FDictBlocks.Delete(Inx);
+
+ if FFileInfo <> nil then begin
+ { Close the file. }
+ FBufMgr.RemoveFile(FFileInfo);
+ FFCloseFilePrim(FFileInfo);
+ FFFreeFileInfo(FFileInfo);
+ FFileInfo := nil;
+ end;
+
+end;
+{--------}
+function Tffv2FileInterface.GetBlock(const BlockNumber : Longint) : ICommonBlock;
+var
+ Block : ICommonBlock;
+begin
+ Block := TffFileBlock.Create(FBufMgr, FFileInfo, FTI, BlockNumber);
+ case Block.BlockType of
+ btUnknown : Result := Tffv2FileBlock.Create(FBufMgr, FFileInfo, FTI, BlockNumber);
+ btFileHeader : Result := TffFileHeaderBlock.Create(FBufMgr, FFileInfo, FTI, BlockNumber);
+ btIndexHeader : Result := TffIndexHeaderBlock.Create(FBufMgr, FFileInfo, FTI, BlockNumber);
+ btData : Result := TffDataBlock.Create(FBufMgr, FFileInfo, FTI, BlockNumber);
+ btIndex : Result := TffIndexBlock.Create(FBufMgr, FFileInfo, FTI, BlockNumber);
+ btBLOB : Result := TffBLOBBlock.Create(FBufMgr, FFileInfo, FTI, BlockNumber);
+ btStream : Result := TffStreamBlock.Create(FBufMgr, FFileInfo, FTI, BlockNumber);
+ btFree : Result := Block;
+ end; { case }
+ Result.OnReportError := FOnReportError;
+ Result.OnReportFix := FOnReportFix;
+end;
+{--------}
+function Tffv2FileInterface.GetDictBlockCount : Longint;
+begin
+ Result := FDictBlocks.Count;
+end;
+{--------}
+function Tffv2FileInterface.GetDictBlocks(const Inx : Longint) : IStreamBlock;
+begin
+ Result := IStreamBlock(FDictBlocks[Inx]);
+ Result.OnReportError := FOnReportError;
+ Result.OnReportFix := FOnReportFix;
+end;
+{--------}
+function Tffv2FileInterface.GetFileHeaderBlock : IFileHeaderBlock;
+begin
+ Result := FFileHeaderBlock;
+ if Result <> nil then begin
+ Result.OnReportError := FOnReportError;
+ Result.OnReportFix := FOnReportFix;
+ end;
+end;
+{--------}
+function Tffv2FileInterface.GetFileInfo : TffGeneralFileInfo;
+begin
+ { TODO:: File must be opened. }
+ Result := TffGeneralFileInfo.Create(FDict, FFileHeaderBlock);
+end;
+{--------}
+function Tffv2FileInterface.GetIndexHeaderBlock : IIndexHeaderBlock;
+begin
+ Result := FIndexHeaderBlock;
+ if Result <> nil then begin
+ Result.OnReportError := FOnReportError;
+ Result.OnReportFix := FOnReportFix;
+ end;
+end;
+{--------}
+function Tffv2FileInterface.GetOnReportError : TffReportErrorEvent;
+begin
+ Result := FOnReportError;
+end;
+{--------}
+function Tffv2FileInterface.GetOnReportFix : TffReportFixEvent;
+begin
+ Result := FOnReportFix;
+end;
+{--------}
+procedure Tffv2FileInterface.Open(const Filename : string);
+var
+ FileBlock : PffBlock;
+ Block : ICommonBlock;
+ DictBlock : IStreamBlock;
+ FileVersion : Longint;
+ RelMethod : TffReleaseMethod;
+begin
+ CloseCurrentFile;
+
+ { Set up the info for the file. }
+ FFileInfo := FFAllocFileInfo(FileName, ffc_extForData, FBufMgr);
+
+ { Open the file. }
+ FFOpenFile(FFileInfo, omReadWrite, smExclusive, False, False);
+
+ { Read the header record to see if this is a FF data file supported by this
+ interface. First, add the file to the buffer manager. }
+ FileBlock := FBufMgr.AddFile(FFileInfo, FTI, False, RelMethod);
+ try
+ { Get the header block. }
+ FFileHeaderBlock := TffFileHeaderBlock.Create(FBufMgr, FFileInfo, FTI, 0);
+ try
+ if ICommonBlock(FFileHeaderBlock).BlockType <> btFileHeader then
+ raise Exception.CreateFmt('"%s" is not a FlashFiler table.', [FileName])
+ else begin
+ { Get the version. }
+ FileVersion := FFileHeaderBlock.FFVersion;
+ { Does this interface handle the version? }
+ if (FileVersion < FFStartVersion) or (FileVersion > FFEndVersion) then
+ raise Exception.CreateFmt
+ ('Table "%s" was created with version %s ' +
+ 'of FlashFiler but this interface only supports versions ' +
+ '%s through %s',
+ [FileName, VersionToStr(FileVersion),
+ VersionToStr(FFStartVersion),
+ VersionToStr(FFEndVersion)]);
+
+ { Get the data dictionary blocks. }
+ Block := GetBlock(FFileHeaderBlock.DataDictBlockNum);
+ if Supports(Block, IStreamBlock, DictBlock) then
+ FDictBlocks.Add(DictBlock)
+ else
+ raise Exception.CreateFmt('Block %d is not a dictionary block as expected.',
+ [FFileHeaderBlock.DataDictBlockNum]);
+ while DictBlock.NextBlock <> ffc_W32NoValue do begin
+ Block := GetBlock(DictBlock.NextBlock);
+ if Supports(Block, IStreamBlock, DictBlock) then
+ FDictBlocks.Add(DictBlock)
+ else
+ raise Exception.CreateFmt('Block %d is not a dictionary block as expected.',
+ [DictBlock.NextBlock]);
+ end; { while }
+
+ { Get the index header block. }
+ FIndexHeaderBlock := TffIndexHeaderBlock.Create
+ (FBufMgr, FFileInfo, FTI,
+ FFileHeaderBlock.IndexHeaderBlockNum);
+
+ { Read the dictionary. }
+ FDict := TffServerDataDict.Create(4096);
+ FDict.ReadFromFile(FFileInfo, FTI);
+ end; { if }
+ except
+ CloseCurrentFile;
+ raise;
+ end;
+ finally
+ RelMethod(FileBlock);
+ end;
+end;
+{--------}
+type
+ SrDBCracker = class(TffSrDatabase);
+{--------}
+procedure Tffv2FileInterface.Pack;
+const
+ ciTimeout = 10000;
+var
+ FileName,
+ FileDir : string;
+ Engine : TffServerEngine;
+ RebuildID,
+ MaxPos : Integer;
+ ClientID : TffClientID;
+ SessionID : TffSessionID;
+ DatabaseID : TffDatabaseID;
+ Result : TffResult;
+ PwdHash : TffWord32;
+ TableName : string;
+ IsPresent : Boolean;
+ Status : TffRebuildStatus;
+ E : EffDatabaseError;
+begin
+ { Get location & name of table. }
+ FileName := FFileInfo^.fiName^;
+ FileDir := ExtractFilePath(FileName);
+ TableName := ChangeFileExt(ExtractFileName(FileName), '');
+
+ { Close the file. }
+ CloseCurrentFile;
+
+ { Future:: Backup location specified? }
+
+ { Init client, session, database IDs. }
+ ClientID := ffc_W32NoValue;
+ SessionID := ffc_W32NoValue;
+ DatabaseID := ffc_W32NoValue;
+
+ { Pack the table via a temporary embedded server engine. }
+ Engine := TffServerEngine.Create(nil);
+ try
+ try
+ { Initialize. }
+ Engine.Startup;
+ Engine.IsReadOnly := True;
+ Engine.MaxRAM := 50;
+
+ { Obtain a client connection. }
+ Result := Engine.ClientAdd(ClientID, '', '', ciTimeout, PwdHash);
+ if Result <> DBIERR_NONE then
+ raise Exception.CreateFmt('Pack error: Could not add client, error code %d',
+ [Result]);
+
+ { Open a session. }
+ Result := Engine.SessionAdd(ClientID, ciTimeout, SessionID);
+ if Result <> DBIERR_NONE then
+ raise Exception.CreateFmt('Pack error: Could not add session, error code %d',
+ [Result]);
+
+ { Add an alias for the current directory. }
+ Result := Engine.DatabaseAddAlias(csAlias, FileDir, False, ClientID);
+ if Result <> DBIERR_NONE then
+ raise Exception.CreateFmt('Pack error: Could not add alias, error code %d',
+ [Result]);
+
+ { Open a database. }
+ Result := Engine.DatabaseOpen(ClientID, csAlias, omReadWrite, smShared,
+ ciTimeout, DatabaseID);
+ if Result <> DBIERR_NONE then
+ raise Exception.CreateFmt('Pack error: Could not add session, error code %d',
+ [Result]);
+
+ { Set the output version for the new table. }
+ SrDBCracker(DatabaseID).dbSetNewTableVersion(FOutputVersion);
+
+ { Calculate Max position for progress. }
+ MaxPos := 100;
+
+ { Start the pack. This is asynchronous so wait for the pack to finish. }
+ Engine.IsReadOnly := False;
+ Result := Engine.TablePack(DatabaseID, TableName, RebuildID);
+ if Result <> DBIERR_NONE then
+ raise Exception.CreateFmt('Pack error: Could not initiate pack, ' +
+ 'error code %d', [Result]);
+
+ repeat
+ Sleep(100);
+ Result := Engine.RebuildGetStatus(RebuildID, ClientID, IsPresent, Status);
+ if Assigned(FRebuildProgress) then
+ FRebuildProgress(Self, Status.rsPercentDone, MaxPos);
+ until (Result = DBIERR_OBJNOTFOUND) or Status.rsFinished;
+
+ if (Status.rsErrorCode <> DBIERR_NONE) and
+ Assigned(FOnReportError) then begin
+ E := EffDatabaseError.CreateViaCode(Status.rsErrorCode, False);
+ try
+ FOnReportError(nil, rciPackFailure,
+ Format(rcErrStr[rciPackFailure],
+ [E.Message]));
+ finally
+ E.Free;
+ end;
+ end; { if }
+ except
+ on E:Exception do begin
+ FOnReportError(nil, rciPackFailure,
+ Format(rcErrStr[rciPackFailure],
+ [E.Message]));
+ end;
+ end;
+ finally
+ if DatabaseID <> ffc_W32NoValue then
+ Engine.DatabaseClose(DatabaseID);
+
+ if SessionID <> ffc_W32NoValue then
+ Engine.SessionRemove(ClientID, SessionID);
+
+ if ClientID <> ffc_W32NoValue then
+ Engine.ClientRemove(ClientID);
+
+ Engine.Free;
+
+ { Re-open the file. }
+ Open(FileName);
+ end;
+
+end;
+{--------}
+procedure Tffv2FileInterface.SetOnReportError(Value : TffReportErrorEvent);
+begin
+ FOnReportError := Value;
+end;
+{--------}
+procedure Tffv2FileInterface.SetOnReportFix(Value : TffReportFixEvent);
+begin
+ FOnReportFix := Value;
+end;
+{--------}
+procedure Tffv2FileInterface.SetOutputVersion(const Value : Longint);
+begin
+ { Validate the version. }
+ if (Value >= ffVersion2_10) and (Value <= ffVersionNumber) then
+ FOutputVersion := Value
+ else
+ raise Exception.Create(Format('The output version must be >= %d and <= %d',
+ [ffVersion2_10, ffVersionNumber]));
+end;
+{====================================================================}
+
+{===Tffv2FileBlock===================================================}
+constructor Tffv2FileBlock.Create(BufMgr : TffBufferManager;
+ FileInfo : PffFileInfo;
+ TI : PffTransInfo;
+ const BlockNum : TffWord32);
+begin
+ inherited;
+ FIsModified := False;
+end;
+{--------}
+procedure Tffv2FileBlock.BeginUpdate;
+begin
+ if not FIsModified then begin
+ { We need to change the block. Release the read-only copy & grab a modifiable
+ copy. }
+ FRelMethod(FBlock);
+ FBufMgr.StartTransaction(FTI.tirTrans, False, '');
+ FBlock := FBufMgr.GetBlock(FFileInfo, FBlockNum, FTI, ffc_MarkDirty,
+ FRelMethod);
+ FIsModified := True;
+ end;
+end;
+{--------}
+procedure Tffv2FileBlock.EndUpdate;
+begin
+ { Release the dirty copy, commit the change, & get a read-only copy. }
+ FRelMethod(FBlock);
+ FBufMgr.CommitTransaction(FTI.tirTrans);
+ FBlock := FBufMgr.GetBlock(FFileInfo, FBlockNum, FTI, ffc_ReadOnly,
+ FRelMethod);
+ FIsModified := False;
+end;
+{====================================================================}
+
+{===TffFileHeaderBlock===============================================}
+function TffFileHeaderBlock.GetAvailBlocks : Longint;
+begin
+ Result := PffBlockHeaderFile(FBlock)^.bhfAvailBlocks;
+end;
+{--------}
+function TffFileHeaderBlock.GetBLOBCount : TffWord32;
+begin
+ Result := PffBlockHeaderFile(FBlock)^.bhfBLOBCount;
+end;
+{--------}
+function TffFileHeaderBlock.GetBlockSize : Longint;
+begin
+ Result := PffBlockHeaderFile(FBlock)^.bhfBlockSize;
+end;
+{--------}
+function TffFileHeaderBlock.GetDataDictBlockNum : TffWord32;
+begin
+ Result := PffBlockHeaderFile(FBlock)^.bhfDataDict;
+end;
+{--------}
+function TffFileHeaderBlock.GetDeletedBLOBHead : TffInt64;
+begin
+ Result := PffBlockHeaderFile(FBlock)^.bhfDelBLOBHead;
+end;
+{--------}
+function TffFileHeaderBlock.GetDeletedBLOBTail : TffInt64;
+begin
+ Result := PffBlockHeaderFile(FBlock)^.bhfDelBLOBTail;
+end;
+{--------}
+function TffFileHeaderBlock.GetDeletedRecordCount : Longint;
+begin
+ Result := PffBlockHeaderFile(FBlock)^.bhfDelRecCount;
+end;
+{--------}
+function TffFileHeaderBlock.GetEncrypted : Longint;
+begin
+ Result := PffBlockHeaderFile(FBlock)^.bhfEncrypted;
+end;
+{--------}
+function TffFileHeaderBlock.GetEstimatedUsedBlocks : TffWord32;
+var
+ CalcInt64Value : TffInt64;
+begin
+ ffI64DivInt(FFGetFileSize(FFileInfo), BlockSize, CalcInt64Value);
+ Result := CalcInt64Value.iLow;
+end;
+{--------}
+function TffFileHeaderBlock.GetFFVersion : Longint;
+begin
+ Result := PffBlockHeaderFile(FBlock)^.bhfFFVersion;
+end;
+{--------}
+function TffFileHeaderBlock.GetFieldCount : Longint;
+begin
+ Result := PffBlockHeaderFile(FBlock)^.bhfFieldCount;
+end;
+{--------}
+function TffFileHeaderBlock.GetFirstDataBlock : TffWord32;
+begin
+ Result := PffBlockHeaderFile(FBlock)^.bhf1stDataBlock;
+end;
+{--------}
+function TffFileHeaderBlock.GetFirstDeletedRecord : TffInt64;
+begin
+ Result := PffBlockHeaderFile(FBlock)^.bhf1stDelRec;
+end;
+{--------}
+function TffFileHeaderBlock.GetFirstFreeBlock : TffWord32;
+begin
+ Result := PffBlockHeaderFile(FBlock)^.bhf1stFreeBlock;
+end;
+{--------}
+function TffFileHeaderBlock.GetHasSequentialIndex : Longint;
+begin
+ Result := PffBlockHeaderFile(FBlock)^.bhfHasSeqIndex;
+end;
+{--------}
+function TffFileHeaderBlock.GetIndexCount : Longint;
+begin
+ Result := PffBlockHeaderFile(FBlock)^.bhfIndexCount;
+end;
+{--------}
+function TffFileHeaderBlock.GetIndexHeaderBlockNum : TffWord32;
+begin
+ Result := PffBlockHeaderFile(FBlock)^.bhfIndexHeader;
+end;
+{--------}
+function TffFileHeaderBlock.GetLastAutoIncValue : TffWord32;
+begin
+ Result := PffBlockHeaderFile(FBlock)^.bhfAutoIncValue;
+end;
+{--------}
+function TffFileHeaderBlock.GetLastDataBlock : TffWord32;
+begin
+ Result := PffBlockHeaderFile(FBlock)^.bhfLastDataBlock;
+end;
+{--------}
+function TffFileHeaderBlock.GetLog2BlockSize : TffWord32;
+begin
+ Result := PffBlockHeaderFile(FBlock)^.bhfLog2BlockSize;
+end;
+{--------}
+function TffFileHeaderBlock.GetRecLenPlusTrailer : Longint;
+begin
+ Result := PffBlockHeaderFile(FBlock)^.bhfRecLenPlusTrailer;
+end;
+{--------}
+function TffFileHeaderBlock.GetRecordCount : Longint;
+begin
+ Result := PffBlockHeaderFile(FBlock)^.bhfRecordCount;
+end;
+{--------}
+function TffFileHeaderBlock.GetRecordLength : Longint;
+begin
+ Result := PffBlockHeaderFile(FBlock)^.bhfRecordLength;
+end;
+{--------}
+function TffFileHeaderBlock.GetRecordsPerBlock : Longint;
+begin
+ Result := PffBlockHeaderFile(FBlock)^.bhfRecsPerBlock;
+end;
+{--------}
+function TffFileHeaderBlock.GetUsedBlocks : TffWord32;
+begin
+ Result := PffBlockHeaderFile(FBlock)^.bhfUsedBlocks;
+end;
+{--------}
+function TffFileHeaderBlock.GetPropertyCell(const Row, Column : Integer) : string;
+begin
+ if Column > Pred(ciFileBlockColumns) then
+ raise Exception.CreateFmt
+ ('Cannot ask for cell in column %d when there are only %d columns in the view',
+ [Column, ciFileBlockColumns]);
+
+ { Does this cell come from the common block view? }
+ if Row < ciFileBlockRows then
+ Result := inherited GetPropertyCell(Row, Column)
+ else
+ case Row of
+ 5 : if Column = 0 then
+ Result := 'Block size'
+ else
+ Result := IntToStr(GetBlockSize);
+ 6 : if Column = 0 then
+ Result := 'Encrypted?'
+ else
+ Result := YesNoValue(GetEncrypted);
+ 7 : if Column = 0 then
+ Result := 'Log 2 block size'
+ else
+ Result := IntToStr(GetLog2BlockSize);
+ 8 : if Column = 0 then
+ Result := 'Used blocks'
+ else
+ Result := IntToStr(GetUsedBlocks);
+ 9 : if Column = 0 then
+ Result := 'Available blocks'
+ else
+ Result := IntToStr(GetAvailBlocks);
+ 10: if Column = 0 then
+ Result := '1st free block'
+ else
+ Result := IntToStr(GetFirstFreeBlock);
+ 11: if Column = 0 then
+ Result := 'Record count'
+ else
+ Result := IntToStr(GetRecordCount);
+ 12: if Column = 0 then
+ Result := 'Deleted record count'
+ else
+ Result := IntToStr(GetDeletedRecordCount);
+ 13: if Column = 0 then
+ Result := '1st deleted record'
+ else
+ Result := Int64ToStr(GetFirstDeletedRecord);
+ 14: if Column = 0 then
+ Result := 'Record length'
+ else
+ Result := IntToStr(GetRecordLength);
+ 15: if Column = 0 then
+ Result := 'Record length plus trailer'
+ else
+ Result := IntToStr(GetRecLenPlusTrailer);
+ 16: if Column = 0 then
+ Result := 'Records per block'
+ else
+ Result := IntToStr(GetRecordsPerBlock);
+ 17: if Column = 0 then
+ Result := '1st data block'
+ else
+ Result := IntToStr(GetFirstDataBlock);
+ 18: if Column = 0 then
+ Result := 'Last data block'
+ else
+ Result := IntToStr(GetLastDataBlock);
+ 19: if Column = 0 then
+ Result := 'BLOB count'
+ else
+ Result := IntToStr(GetBLOBCount);
+ 20: if Column = 0 then
+ Result := 'Deleted BLOB head'
+ else
+ Result := Int64ToStr(GetDeletedBLOBHead);
+ 21: if Column = 0 then
+ Result := 'Deleted BLOB tail'
+ else
+ Result := Int64ToStr(GetDeletedBLOBTail);
+ 22: if Column = 0 then
+ Result := 'Last autoinc value'
+ else
+ Result := IntToStr(GetLastAutoIncValue);
+ 23: if Column = 0 then
+ Result := 'Index count'
+ else
+ Result := IntToStr(GetIndexCount);
+ 24: if Column = 0 then
+ Result := 'Sequential index?'
+ else
+ Result := YesNoValue(GetHasSequentialIndex);
+ 25: if Column = 0 then
+ Result := 'Index header block number'
+ else
+ Result := IntToStr(GetIndexHeaderBlockNum);
+ 26: if Column = 0 then
+ Result := 'Field count'
+ else
+ Result := IntToStr(GetFieldCount);
+ 27: if Column = 0 then
+ Result := 'Data dictionary block number'
+ else
+ Result := IntToStr(GetDataDictBlockNum);
+ 28: if Column = 0 then
+ Result := 'FF version'
+ else
+ Result := VersionToStr(GetFFVersion);
+ else
+ raise Exception.CreateFmt
+ ('Cannot ask for cell in row %d when there are only %d rows in the view',
+ [Row, ciFileBlockRows + ciFileHeaderRows]);
+ end; { case }
+end;
+{--------}
+function TffFileHeaderBlock.GetPropertyRowCount : Integer;
+begin
+ Result := ciFileBlockRows + ciFileHeaderRows;
+end;
+{--------}
+procedure TffFileHeaderBlock.SetFirstDataBlock(const Value : TffWord32);
+begin
+ PffBlockHeaderFile(FBlock)^.bhf1stDataBlock := Value;
+end;
+{--------}
+procedure TffFileHeaderBlock.SetFirstFreeBlock(const Value : TffWord32);
+begin
+ PffBlockHeaderFile(FBlock)^.bhf1stFreeBlock := Value;
+end;
+{--------}
+procedure TffFileHeaderBlock.SetHasSequentialIndex(const Value : Longint);
+begin
+ PffBlockHeaderFile(FBlock)^.bhfHasSeqIndex := Value;
+end;
+{--------}
+procedure TffFileHeaderBlock.SetLastDataBlock(const Value : TffWord32);
+begin
+ PFfBlockHeaderFile(FBlock)^.bhfLastDataBlock := Value;
+end;
+{--------}
+procedure TffFileHeaderBlock.SetLog2BlockSize(const Value : TffWord32);
+begin
+ PFfBlockHeaderFile(FBlock)^.bhfLog2BlockSize := Value;
+end;
+{--------}
+procedure TffFileHeaderBlock.SetUsedBlocks(const Value : TffWord32);
+begin
+ PFfBlockHeaderFile(FBlock)^.bhfUsedBlocks := Value;
+end;
+{--------}
+procedure TffFileHeaderBlock.VerifyRepair(const Repair : Boolean);
+var
+ Block : PffBlock;
+ RelMethod : TffReleaseMethod;
+ BlockSizeValid : Boolean;
+ Log2BlockSizeValid : Boolean;
+ CalcValue : TffWord32;
+ Modified : Boolean;
+begin
+ inherited;
+ Modified := False;
+ Log2BlockSizeValid := False;
+ try
+
+ { TODO: AvailBlocks will be checked by repair logic once the number of deleted
+ blocks has been determined. }
+
+ { BLOBCount is not verified at this time. }
+
+ { Verify block size is one of the accepted values. }
+ BlockSizeValid := ((BlockSize = 4096) or
+ (BlockSize = 8192) or
+ (BlockSize = 16384) or
+ (BlockSize = 32768) or
+ (BlockSize = 65536));
+ if not BlockSizeValid then
+ DoReportError(rciInvalidBlockSize, [BlockSize]);
+ { Future: Implement logic that tests for block size, perhaps by looking for
+ valid signatures at specific block boundaries, & self repairs
+ block size. }
+
+ { Verify log2 block size. }
+ if BlockSizeValid then begin
+ CalcValue := FFCalcLog2BlockSize(BlockSize);
+ Log2BlockSizeValid := (Log2BlockSize = CalcValue);
+ if not Log2BlockSizeValid then begin
+ DoReportError(rciInvalidLog2BlockSize,
+ [BlockSize, CalcValue, Log2BlockSize]);
+ if Repair then begin
+ BeginUpdate;
+ Modified := True;
+ Log2BlockSize := CalcValue;
+ DoReportFix(rciInvalidLog2BlockSize, [CalcValue]);
+ end; { if }
+ end; { if }
+ end; { if }
+
+ { Verify the reference to the data dictionary block. }
+ if DataDictBlockNum <> ffc_W32NoValue then
+ try
+ Block := FBufMgr.GetBlock(FFileInfo, DataDictBlockNum, FTI, ffc_ReadOnly,
+ RelMethod);
+ try
+ { Is it a stream block? }
+ if (PffBlockHeaderStream(Block)^.bhsSignature <> ffc_SigStreamBlock) or
+ (PffBlockHeaderStream(Block)^.bhsStreamType <> ffc_SigDictStream) then
+ DoReportError(rciInvalidBlockRefDict, [DataDictBlockNum]);
+ finally
+ RelMethod(Block);
+ end;
+ except
+ DoReportError(rciInvalidBlockRefDict, [DataDictBlockNum]);
+ end
+ else
+ DoReportError(rciNoDictBlock, [DataDictBlockNum]);
+
+ { Is the deleted BLOB head valid?
+ Future: Determine if it is a BLOB segment. }
+ if (DeletedBLOBHead.iLow <> ffc_W32NoValue) and
+ Log2BlockSizeValid and
+ (not FFVerifyBLOBNr(DeletedBLOBHead, Log2BlockSize)) then
+ DoReportError(rciInvalidInt64, ['Deleted BLOB head', DeletedBLOBHead.iHigh,
+ DeletedBLOBHead.iLow]);
+
+ { Is the deleted BLOB tail valid?
+ Future: Determine if it is a BLOB segment. }
+ if (DeletedBLOBTail.iLow <> ffc_W32NoValue) and
+ Log2BlockSizeValid and
+ (not FFVerifyBLOBNr(DeletedBLOBTail, Log2BlockSize)) then
+ DoReportError(rciInvalidInt64, ['Deleted BLOB tail', DeletedBLOBTail.iHigh,
+ DeletedBLOBTail.iLow]);
+
+
+ { Future: Verify deleted record count. }
+
+ { Future: Verify encrypted flag. }
+
+ { Future: Verify FF version. }
+
+ { Future: Verify field count. }
+
+ { Is FirstDataBlock valid? }
+ if FirstDataBlock <> ffc_W32NoValue then
+ try
+ Block := FBufMgr.GetBlock(FFileInfo, FirstDataBlock, FTI, ffc_ReadOnly,
+ RelMethod);
+ try
+ { Is it a data block? }
+ if (PffBlockHeaderData(Block)^.bhdsignature <> ffc_SigDataBlock) then
+ DoReportError(rciInvalidBlockRefFirstData, [FirstDataBlock]);
+ finally
+ RelMethod(Block);
+ end;
+ except
+ DoReportError(rciInvalidBlockRefFirstData, [FirstDataBlock]);
+ end
+ else if RecordCount > 0 then
+ DoReportError(rciNoDataBlockForRecs, [RecordCount]);
+
+ { Verify ref to 1st deleted record.
+ Future: Determine if it really is a deleted record. }
+ if (DeletedRecordCount = 0) then begin
+ if FirstDeletedRecord.iLow <> ffc_W32NoValue then
+ DoReportError(rciInvalidInt64, ['First Deleted Record',
+ FirstDeletedRecord.iHigh,
+ FirstDeletedRecord.iLow]);
+ end
+ else if Log2BlockSizeValid and
+ (not FFVerifyRefNr(FirstDeletedRecord, Log2BlockSize,
+ RecordLengthPlusTrailer)) then
+ DoReportError(rciInvalidInt64, ['First Deleted Record',
+ FirstDeletedRecord.iHigh,
+ FirstDeletedRecord.iLow]);
+
+ { Verify ref to first free block. }
+ if FirstFreeBlock <> ffc_W32NoValue then
+ try
+ Block := FBufMgr.GetBlock(FFileInfo, FirstFreeBlock, FTI, ffc_ReadOnly,
+ RelMethod);
+ try
+ { Is it a free block? }
+ if (PffBlockCommonHeader(Block)^.bchsignature <> ffc_SigFreeBlock) then
+ DoReportError(rciInvalidBlockRefFirstFree, [FirstFreeBlock]);
+ finally
+ RelMethod(Block);
+ end;
+ except
+ DoReportError(rciInvalidBlockRefFirstFree, [FirstFreeBlock]);
+ end;
+
+ { For FF 2.x, each table should have a sequential index. }
+ if HasSequentialIndex <> 1 then begin
+ DoReportError(rciInvalidSeqIndexFlag, [HasSequentialIndex]);
+ if Repair then begin
+ BeginUpdate;
+ Modified := True;
+ HasSequentialIndex := 1;
+ DoReportFix(rciInvalidSeqIndexFlag, [1]);
+ end; { if }
+ end; { if }
+
+ { Future: Does the index count match the dictionary. }
+
+ { Verify ref to index header. }
+ if IndexHeaderBlockNum <> ffc_W32NoValue then
+ try
+ Block := FBufMgr.GetBlock(FFileInfo, IndexHeaderBlockNum, FTI,
+ ffc_ReadOnly, RelMethod);
+ try
+ { Is it an index block & is its block type set to zero indicating
+ a header block? }
+ if (PffBlockHeaderIndex(Block)^.bhisignature <> ffc_SigIndexBlock) or
+ (PffBlockHeaderIndex(Block)^.bhiBlockType <> 0) then
+ DoReportError(rciInvalidBlockRefIndexHead, [IndexHeaderBlockNum]);
+ finally
+ RelMethod(Block);
+ end;
+ except
+ DoReportError(rciInvalidBlockRefIndexHead, [IndexHeaderBlockNum]);
+ end;
+
+ { Future: Verify last autoinc value. }
+
+ { Verify ref to last data block. }
+ if LastDataBlock <> ffc_W32NoValue then
+ try
+ Block := FBufMgr.GetBlock(FFileInfo, LastDataBlock, FTI, ffc_ReadOnly,
+ RelMethod);
+ try
+ { Is it a data block? }
+ if (PffBlockHeaderData(Block)^.bhdsignature <> ffc_SigDataBlock) then
+ DoReportError(rciInvalidBlockRefLastData, [LastDataBlock]);
+ finally
+ RelMethod(Block);
+ end;
+ except
+ DoReportError(rciInvalidBlockRefLastData, [LastDataBlock]);
+ end
+ else if RecordCount > 0 then
+ DoReportError(rciNoLastDataBlockForRecs, [RecordCount]);
+
+ { Future: Verify record length plus trailer. }
+
+ { Future: Verify record count. }
+
+ { Future: Verify record length. }
+ { TODO:: Can now get this information from the data dictionary. ]
+
+ { Future: Verify records per block. }
+
+ { Verify that used blocks matches the size of the file. }
+ if BlockSizeValid then begin
+ CalcValue := EstimatedUsedBlocks;
+ if CalcValue <> UsedBlocks then begin
+ DoReportError(rciInvalidUsedBlocks, [CalcValue, UsedBlocks]);
+ if Repair then begin
+ BeginUpdate;
+ Modified := True;
+ UsedBlocks := CalcValue;
+ DoReportFix(rciInvalidUsedBlocks, [CalcValue]);
+ end; { if }
+ end; { if }
+ end; { if }
+ finally
+ if Modified then
+ EndUpdate;
+ end;
+end;
+{====================================================================}
+
+{====================================================================}
+function TffStreamBlock.GetNextStrmBlock : TffWord32;
+begin
+ Result := PffBlockHeaderStream(FBlock)^.bhsNextStrmBlock;
+end;
+{--------}
+function TffStreamBlock.GetStreamType : Longint;
+begin
+ Result := PffBlockHeaderStream(FBlock)^.bhsStreamType;
+end;
+{--------}
+function TffStreamBlock.GetStreamLength : Longint;
+begin
+ Result := PffBlockHeaderStream(FBlock)^.bhsStreamLength;
+end;
+{--------}
+function TffStreamBlock.GetOwningStream : Longint;
+begin
+ Result := PffBlockHeaderStream(FBlock)^.bhsOwningStream;
+end;
+{--------}
+function TffStreamBlock.GetPropertyCell(const Row, Column : Integer) : string;
+begin
+ if Column > Pred(ciFileBlockColumns) then
+ raise Exception.CreateFmt
+ ('Cannot ask for cell in column %d when there are only %d columns in the view',
+ [Column, ciFileBlockColumns]);
+
+ { Does this cell come from the common block view? }
+ if Row < ciFileBlockRows then
+ Result := inherited GetPropertyCell(Row, Column)
+ else
+ case Row of
+ 5 : if Column = 0 then
+ Result := 'Next stream block'
+ else
+ Result := IntToStr(GetNextStrmBlock);
+ 6 : if Column = 0 then
+ Result := 'Stream type'
+ else
+ Result := MapSigToStr(GetStreamType);
+ 7 : if Column = 0 then
+ Result := 'Stream length'
+ else
+ Result := IntToStr(GetStreamLength);
+ 8 : if Column = 0 then
+ Result := 'Owning stream'
+ else
+ Result := IntToStr(GetOwningStream);
+ else
+ raise Exception.CreateFmt
+ ('Cannot ask for cell in row %d when there are only %d rows in the view',
+ [Row, ciFileBlockRows + ciStreamRows]);
+ end; { case }
+end;
+{--------}
+function TffStreamBlock.GetPropertyRowCount : Integer;
+begin
+ Result := ciFileBlockRows + ciStreamRows;
+end;
+{====================================================================}
+
+{===TffIndexBlock====================================================}
+function TffIndexBlock.GetIndexBlockType : Byte;
+begin
+ Result := PffBlockHeaderIndex(FBlock)^.bhiBlockType;
+end;
+{--------}
+function TffIndexBlock.GetIsLeafPage : Boolean;
+begin
+ Result := PffBlockHeaderIndex(FBlock)^.bhiIsLeafPage;
+end;
+{--------}
+function TffIndexBlock.GetNodeLevel : Byte;
+begin
+ Result := PffBlockHeaderIndex(FBlock)^.bhiNodeLevel;
+end;
+{--------}
+function TffIndexBlock.GetKeysAreRefs : Boolean;
+begin
+ Result := PffBlockHeaderIndex(FBlock)^.bhiKeysAreRefs;
+end;
+{--------}
+function TffIndexBlock.GetIndexNum : Word;
+begin
+ Result := PffBlockHeaderIndex(FBlock)^.bhiIndexNum;
+end;
+{--------}
+function TffIndexBlock.GetKeyLength : Word;
+begin
+ Result := PffBlockHeaderIndex(FBlock)^.bhiKeyLength;
+end;
+{--------}
+function TffIndexBlock.GetKeyCount : Longint;
+begin
+ Result := PffBlockHeaderIndex(FBlock)^.bhiKeyCount;
+end;
+{--------}
+function TffIndexBlock.GetMaxKeyCount : Longint;
+begin
+ Result := PffBlockHeaderIndex(FBlock)^.bhiMaxKeyCount;
+end;
+{--------}
+function TffIndexBlock.GetPrevPageRef : TffWord32;
+begin
+ Result := PffBlockHeaderIndex(FBlock)^.bhiPrevPageRef;
+end;
+{--------}
+function TffIndexBlock.GetPropertyCell(const Row, Column : Integer) : string;
+begin
+ if Column > Pred(ciFileBlockColumns) then
+ raise Exception.CreateFmt
+ ('Cannot ask for cell in column %d when there are only %d columns in the view',
+ [Column, ciFileBlockColumns]);
+
+ { Does this cell come from the common block view? }
+ if Row < ciFileBlockRows then
+ Result := inherited GetPropertyCell(Row, Column)
+ else
+ case Row of
+ 5 : if Column = 0 then
+ Result := 'Index block type'
+ else
+ Result := FlagStr(GetIndexBlockType, 'Header', 'B-Tree page');
+ 6 : if Column = 0 then
+ Result := 'Is leaf page'
+ else
+ Result := BooleanValue('Yes', 'No', GetIsLeafPage);
+ 7 : if Column = 0 then
+ Result := 'Node level'
+ else
+ Result := IntToStr(GetNodeLevel);
+ 8 : if Column = 0 then
+ Result := 'Keys are refs'
+ else
+ Result := BooleanValue('Yes', 'No', GetKeysAreRefs);
+ 9 : if Column = 0 then
+ Result := 'Index number'
+ else
+ Result := IntToStr(GetIndexNum);
+ 10: if Column = 0 then
+ Result := 'Key length'
+ else
+ Result := IntToStr(GetKeyLength);
+ 11: if Column = 0 then
+ Result := 'Key count'
+ else
+ Result := IntToStr(GetKeyCount);
+ 12: if Column = 0 then
+ Result := 'Max key count'
+ else
+ Result := IntToStr(GetMaxKeyCount);
+ 13: if Column = 0 then
+ Result := 'Previous page reference'
+ else
+ Result := IntToStr(GetPrevPageRef);
+ else
+ raise Exception.CreateFmt
+ ('Cannot ask for cell in row %d when there are only %d rows in the view',
+ [Row, ciFileBlockRows + ciIndexBlockRows]);
+ end; { case }
+end;
+{--------}
+function TffIndexBlock.GetPropertyRowCount : Integer;
+begin
+ Result := ciFileBlockRows + ciIndexBlockRows;
+end;
+{--------}
+procedure TffIndexBlock.VerifyRepair(const Repair : Boolean);
+var
+ Inx : Integer;
+ InxBlockNum,
+ DataBlockNum : TffWord32;
+ RefNum, TempI64 : TffInt64;
+ PageNumBlock : PPageNumBlock;
+ Modified : Boolean;
+ Block : PffBlock;
+ RelMethod : TffReleaseMethod;
+ DataRefBlock : PRefBlock;
+ ValidStr : string;
+ Info : TffGeneralFileInfo;
+begin
+ inherited;
+ Modified := False;
+ try
+
+ { Get the previous page & verify it is an index block. }
+ if PrevPageRef <> ffc_W32NoValue then
+ try
+ Block := FBufMgr.GetBlock(FFileInfo, PrevPageRef, FTI, ffc_ReadOnly,
+ RelMethod);
+ try
+ if PffBlockHeaderIndex(Block)^.bhiSignature <> ffc_SigIndexBlock then
+ DoReportError(rciInvalidInxPrefPageRef, [PrevPageRef]);
+ finally
+ RelMethod(Block);
+ end;
+ except
+ DoReportError(rciInvalidInxPrefPageRef, [PrevPageRef]);
+ end;
+
+ { Get the general file info. }
+ if Assigned(FOnGetInfo) then
+ FOnGetInfo(Info)
+ else
+ raise Exception.Create('File interface must provide OnGetInfo handler.');
+
+ { Is this a leaf page? }
+ if IsLeafPage then begin
+ { Yes. Verify that all reference numbers point to data pages & to
+ valid records. }
+ DataRefBlock := PRefBlock(@FBlock^[ffc_BlockHeaderSizeIndex]);
+
+ { Loop through the existing keys. }
+ for Inx := 0 to pred(KeyCount) do begin
+ { Get the block number. }
+ RefNum := DataRefBlock^[Inx];
+ ffShiftI64R(RefNum, FFileInfo^.fiLog2BlockSize, TempI64);
+ DataBlockNum := TempI64.iLow;
+
+ { Load the page. Is it a data block? }
+ try
+ Block := FBufMgr.GetBlock(FFileInfo, DataBlockNum, FTI, ffc_ReadOnly,
+ RelMethod);
+ try
+ if PffBlockHeaderData(Block)^.bhdSignature <> ffc_SigDataBlock then begin
+ { It is not a data block. Determine the validity of the key's
+ ref number. If it is valid then it will point to the
+ start of a record given the block size & record length. }
+ if FFVerifyRefNr(RefNum, Info.Log2BlockSize,
+ Info.RecLenPlusTrailer) then
+ ValidStr := 'The RefNum is valid.'
+ else
+ ValidStr := 'The RefNum is invalid.';
+ DoReportError(rciInvalidLeafKeyBlockRef,
+ [Inx, BlockNum, IndexNum, DataBlockNum,
+ RefNum.iHigh, RefNum.iLow, ValidStr]);
+ end
+ else begin
+ { It is a data block. Verify the key in the index page points
+ to a valid record. }
+ if not FFVerifyRefNr(RefNum, Info.Log2BlockSize,
+ Info.RecLenPlusTrailer) then
+ DoReportError(rciInvalidLeafKeyRefNum,
+ [Inx, BlockNum, IndexNum, DataBlockNum,
+ RefNum.iHigh, RefNum.iLow]);
+ end; { if..else }
+ finally
+ RelMethod(Block);
+ end;
+ except
+ ValidStr := 'The RefNum validity is undetermined.';
+ DoReportError(rciInvalidLeafKeyBlockRef,
+ [Inx, BlockNum, IndexNum, DataBlockNum,
+ RefNum.iHigh, RefNum.iLow, ValidStr]);
+ end;
+ end; { for }
+ end
+ else begin
+ { This is an internal page. Verify the following:
+ 1. The referenced parent page actually exists and is an index block.
+ 2. Each referenced subpage actually exists and is an index block.
+
+ First, get a handle on the page numbers and reference numbers.
+ Page numbers point to an index page (used if the key searched for is
+ less than the key at this spot).
+ Reference numbers point to a data page (use if we have found the key
+ we are searching for in the node page). }
+ PageNumBlock := PPageNumBlock(@FBlock^[ffc_BlockHeaderSizeIndex]);
+ DataRefBlock := PRefBlock(@FBlock^[ffc_BlockHeaderSizeIndex +
+ (MaxKeyCount * SizeOfPageNum)]);
+
+ { Now loop through the existing keys. }
+ for Inx := 0 to pred(KeyCount) do begin
+ { Get the index block number. }
+ InxBlockNum := PageNumBlock^[Inx];
+ RefNum := DataRefBlock^[Inx];
+ try
+ { Load the referenced index block. Is it an index page? }
+ Block := FBufMgr.GetBlock(FFileInfo, InxBlockNum, FTI, ffc_ReadOnly,
+ RelMethod);
+ try
+ if PffBlockHeaderIndex(Block)^.bhiSignature <> ffc_SigIndexBlock then begin
+ { No, it is not an index page. Determine the validity of the
+ reference number. It is valid if it points to the start of a
+ record given the block size & record length. }
+ if FFVerifyRefNr(RefNum, Info.Log2BlockSize,
+ Info.RecLenPlusTrailer) then
+ ValidStr := 'The RefNum is valid.'
+ else
+ ValidStr := 'The RefNum is invalid.';
+ DoReportError(rciInvalidIntrnalKeyBlockRef,
+ [Inx, BlockNum, IndexNum, InxBlockNum,
+ RefNum.iHigh, RefNum.iLow, ValidStr]);
+ end
+ else begin
+ { Yes, the target page is an index page. Now verify this key points
+ to a valid record. }
+ if not FFVerifyRefNr(RefNum, Info.Log2BlockSize,
+ Info.RecLenPlusTrailer) then
+ DoReportError(rciInvalidIntrnalKeyRefNum,
+ [Inx, BlockNum, IndexNum, InxBlockNum,
+ RefNum.iHigh, RefNum.iLow]);
+ end; { if }
+ finally
+ RelMethod(Block);
+ end;
+ except
+ ValidStr := 'The RefNum validity is undetermined.';
+ DoReportError(rciInvalidIntrnalKeyBlockRef,
+ [Inx, BlockNum, IndexNum, InxBlockNum,
+ RefNum.iHigh, RefNum.iLow, ValidStr]);
+ end;
+ end; { for }
+ end; { if..else }
+ finally
+ if Modified then
+ EndUpdate;
+ end;
+end;
+{====================================================================}
+
+{===TffIndexHeaderBlock==============================================}
+constructor TffIndexHeaderBlock.Create(BufMgr : TffBufferManager;
+ FileInfo : PffFileInfo;
+ TI : PffTransInfo;
+ const BlockNum : TffWord32);
+begin
+ inherited;
+ FDataColumns := -1;
+ FIndexHead := PffIndexHeader(@FBlock^[ffc_BlockHeaderSizeIndex]);
+end;
+{--------}
+function TffIndexHeaderBlock.GetDataCell(const Row, Column : Integer) : string;
+begin
+ if Column > Pred(ciIndexBlockRows) then
+ raise Exception.CreateFmt
+ ('Cannot ask for cell in column %d when there are only %d columns in the view',
+ [Column, ciFileBlockColumns]);
+
+ case Column of
+ 0 : Result := IntToStr(Row + 1);
+ 1 : Result := IntToStr(FIndexHead^.bihIndexKeyLen[Row]);
+ 2 : Result := IntToStr(FIndexHead^.bihIndexKeyCount[Row]);
+ 3 : Result := IntToStr(FIndexHead^.bihIndexRoot[Row]);
+ 4 : Result := IntToStr(FIndexHead^.bihIndexPageCount[Row]);
+ 5 : Result := MapFlagsToStr(FIndexHead^.bihIndexFlags[Row]);
+ else
+ raise Exception.CreateFmt
+ ('Cannot ask for cell in row %d when there are only %d rows in the view',
+ [Row, ffcl_MaxIndexes]);
+ end; { case }
+end;
+{--------}
+function TffIndexHeaderBlock.GetDataColCaption(const Index : Integer) : string;
+begin
+ case Index of
+ 0 : Result := 'Index';
+ 1 : Result := 'Key length';
+ 2 : Result := '# keys';
+ 3 : Result := 'Root page';
+ 4 : Result := '# pages';
+ 5 : Result := 'Flags';
+ else
+ raise Exception.CreateFmt
+ ('Cannot ask for caption %d when there are only %d columns in the view',
+ [Index, ciIndexHeaderDataColumns]);
+ end; { case }
+end;
+{--------}
+function TffIndexHeaderBlock.GetDataColCount : Integer;
+begin
+ Result := ciIndexHeaderDataColumns;
+end;
+{--------}
+function TffIndexHeaderBlock.GetDataColWidth(const Index : Integer) : Integer;
+begin
+ case Index of
+ 0 : Result := 50;
+ 1 : Result := 65;
+ 2 : Result := 65;
+ 3 : Result := 75;
+ 4 : Result := 65;
+ 5 : Result := 90;
+ else
+ raise Exception.CreateFmt
+ ('Cannot ask for width %d when there are only %d columns in the view',
+ [Index, ciIndexHeaderDataColumns]);
+ end; { case }
+end;
+{--------}
+function TffIndexHeaderBlock.GetDataRowCount : Integer;
+var
+ Inx : Integer;
+begin
+ if FDataColumns < 0 then begin
+ FDataColumns := 0;
+ for Inx := 0 to Pred(ffcl_MaxIndexes) do
+ if FIndexHead^.bihIndexKeyLen[Inx] > 0 then
+ inc(FDataColumns)
+ else
+ Break;
+ end; { if }
+ Result := FDataColumns;
+ { Future: Obtain # of indices from dictionary or file header block. }
+end;
+{--------}
+procedure TffIndexHeaderBlock.VerifyRepair(const Repair : Boolean);
+var
+ Block : PffBlock;
+ Modified : Boolean;
+ Row,
+ Rows : Integer;
+ Info : TffGeneralFileInfo;
+ RelMethod : TffReleaseMethod;
+begin
+ { Verify an OnGetInfo handler has been specified. }
+ if Assigned(FOnGetInfo) then
+ FOnGetInfo(Info)
+ else
+ raise Exception.Create('File interface must provide OnGetInfo handler.');
+
+ Modified := False;
+ try
+ { Get the # of rows in the header. The # of rows should equal the # of
+ indices defined in the dictionary. }
+ Rows := GetDataRowCount;
+ if Rows <> Info.Dict.IndexCount then
+ DoReportError(rciInxHeaderInvalidRowCount,
+ [Rows, Info.Dict.IndexCount])
+ else begin
+ { Walk through each row. }
+ for Row := 0 to Pred(Rows) do begin
+ { Verify the index key length. }
+ if FIndexHead^.bihIndexKeyLen[Row] <> Info.Dict.IndexKeyLength[Row] then
+ DoReportError(rciInxHeaderInvalidKeyLen,
+ [Row, FIndexHead^.bihIndexKeyLen[Row],
+ Info.Dict.IndexKeyLength[Row]]);
+
+ { Verify the index key count matches the number of records in the
+ table.
+ Future: This test would change if there were ever a type of index
+ that filtered out keys. }
+ if FIndexHead^.bihIndexKeyCount[Row] <> Info.RecordCount then
+ DoReportError(rciInxHeaderInvalidKeyCount,
+ [Row, FIndexHead^.bihIndexKeyCount[Row],
+ Info.RecordCount]);
+
+ { There are no records in the table. Verify the index map does not
+ point to an index page. }
+ if (Info.RecordCount = 0) then begin
+ if FIndexHead^.bihIndexRoot[Row] <> ffc_W32NoValue then
+ DoReportError(rciInxHeaderInvalidRootPage,
+ [Row, FIndexHead^.bihIndexRoot[Row]]);
+ end
+ else if (FIndexHead^.bihIndexRoot[Row] <> ffc_W32NoValue) then
+ { There are records. Verify the index root page is really an index
+ block. }
+ try
+ Block := FBufMgr.GetBlock(FFileInfo, FIndexHead^.bihIndexRoot[Row],
+ FTI, ffc_ReadOnly, RelMethod);
+ try
+ { Is it an index block? }
+ if (PffBlockHeaderIndex(Block)^.bhisignature <> ffc_SigIndexBlock) then
+ DoReportError(rciInxHeaderInvalidRootPage,
+ [Row, FIndexHead^.bihIndexRoot[Row]]);
+ finally
+ RelMethod(Block);
+ end;
+ except
+ DoReportError(rciInxHeaderInvalidRootPage, [FIndexHead^.bihIndexRoot[Row]]);
+ end
+ else
+ DoReportError(rciInxHeaderNoRootPage, [Row]);
+
+ { Future: Verify index page count. }
+
+ { Verify index flags. If this is the first row then it should indicate
+ that keys are refs. }
+ if (Row = 0) then
+ if (FIndexHead^.bihIndexFlags[Row] and ffc_InxFlagKeysAreRefs) <>
+ ffc_InxFlagKeysAreRefs then
+ DoReportError(rciInxHeaderNoRefsFlag, []);
+
+ if Info.Dict.IndexDescriptor[Row].idDups then
+ if (FIndexHead^.bihIndexFlags[Row] and ffc_InxFlagAllowDups) <>
+ ffc_InxFlagAllowDups then
+ DoReportError(rciInxHeaderNoDupsFlag, [Row, Row]);
+
+
+ end; { for }
+ end;
+ finally
+ if Modified then
+ EndUpdate;
+ end;
+end;
+{====================================================================}
+
+{===TffDataBlock=====================================================}
+function TffDataBlock.GetDataCell(const Row, Column : Integer) : string;
+var
+ FieldValue : TffVCheckValue;
+ IsNull : Boolean;
+ Info : TffGeneralFileInfo;
+ RecPtrDel,
+ RecPtrData : PffByteArray;
+ Offset : Integer;
+begin
+ if Row > Pred(GetRecCount) then
+ raise Exception.CreateFmt
+ ('Cannot ask for cell in row %d when there are only %d records in the view',
+ [Row, GetRecCount]);
+
+ { Get the general file info. }
+ if Assigned(FOnGetInfo) then
+ FOnGetInfo(Info)
+ else
+ raise Exception.Create('File interface must provide OnGetInfo handler.');
+
+ if Column < FNumDataColumns then begin
+ Result := '-';
+ FillChar(FieldValue, SizeOf(FieldValue), 0);
+ { Position two pointers to the beginning of the record. The first points
+ to the deleted flag. The second points to the start of the record. }
+ Offset := ffc_BlockHeaderSizeData + (Info.RecLenPlusTrailer * Row);
+ RecPtrDel := @FBlock[Offset];
+ RecPtrData := @FBlock[Offset + 1];
+
+ { Is the record deleted? }
+ if Column = 0 then
+ Result := IntToStr(Row)
+ else if PByte(RecPtrDel)^ = $FF then begin
+ if Column = 1 then
+ Result := 'Y';
+ end
+ else if Column > 1 then begin
+ Info.Dict.GetRecordField(Column - 2, RecPtrData, IsNull, @FieldValue);
+ if IsNull then
+ Result := ''
+ else
+ Result := FFVCheckValToString(FieldValue,
+ Info.Dict.FieldType[Column - 2]);
+ end; { if..else }
+ end
+ else
+ raise Exception.CreateFmt
+ ('Cannot ask for cell in column %d when there are only %d columns in the view',
+ [Column, FNumDataColumns]);
+end;
+{--------}
+function TffDataBlock.GetDataColCaption(const Index : Integer) : string;
+var
+ Info : TffGeneralFileInfo;
+begin
+ if Index < FNumDataColumns then begin
+ { Get the general file info. }
+ if Assigned(FOnGetInfo) then
+ FOnGetInfo(Info)
+ else
+ raise Exception.Create('File interface must provide OnGetInfo handler.');
+ if Index = 0 then
+ Result := 'Slot'
+ else if Index = 1 then
+ Result := 'Deleted?'
+ else
+ Result := Info.Dict.FieldName[Index - 2];
+ end
+ else
+ raise Exception.CreateFmt
+ ('Cannot ask for caption %d when there are only %d columns in the view',
+ [Index, ciIndexHeaderDataColumns]);
+end;
+{--------}
+function TffDataBlock.GetDataColCount : Integer;
+var
+ Info : TffGeneralFileInfo;
+begin
+ { Get the general file info. }
+ if Assigned(FOnGetInfo) then
+ FOnGetInfo(Info)
+ else
+ raise Exception.Create('File interface must provide OnGetInfo handler.');
+ Result := Info.Dict.FieldCount + 2;
+ { The first extra column is the slot # of the record (base 0) & the second
+ extra column used to indicate whether the record is deleted. }
+ FNumDataColumns := Result;
+end;
+{--------}
+function TffDataBlock.GetDataColWidth(const Index : Integer) : Integer;
+begin
+ if Index < FNumDataColumns then begin
+ if Index = 1 then
+ Result := 70
+ else
+ Result := 50
+ end
+ else
+ raise Exception.CreateFmt
+ ('Cannot ask for width %d when there are only %d columns in the view',
+ [Index, FNumDataColumns]);
+end;
+{--------}
+function TffDataBlock.GetDataRowCount : Integer;
+begin
+ Result := GetRecCount;
+end;
+{--------}
+function TffDataBlock.GetNextDataBlock : TffWord32;
+begin
+ Result := PffBlockHeaderData(FBlock)^.bhdNextDataBlock;
+end;
+{--------}
+function TffDataBlock.GetPrevDataBlock : TffWord32;
+begin
+ Result := PffBlockHeaderData(FBlock)^.bhdPrevDataBlock;
+end;
+{--------}
+function TffDataBlock.GetPropertyCell(const Row, Column : Integer) : string;
+begin
+ if Column > Pred(ciFileBlockColumns) then
+ raise Exception.CreateFmt
+ ('Cannot ask for cell in column %d when there are only %d columns in the view',
+ [Column, ciFileBlockColumns]);
+
+ { Does this cell come from the common block view? }
+ if Row < ciFileBlockRows then
+ Result := inherited GetPropertyCell(Row, Column)
+ else
+ case Row of
+ 5 : if Column = 0 then
+ Result := 'Record count'
+ else
+ Result := IntToStr(GetRecCount);
+ 6 : if Column = 0 then
+ Result := 'Record length'
+ else
+ Result := IntToStr(GetRecLen);
+ 7 : if Column = 0 then
+ Result := 'Next data block'
+ else
+ Result := IntToStr(GetNextDatablock);
+ 8 : if Column = 0 then
+ Result := 'Previous data block'
+ else
+ Result := IntToStr(GetPrevDataBlock);
+ else
+ raise Exception.CreateFmt
+ ('Cannot ask for cell in row %d when there are only %d rows in the view',
+ [Row, ciFileBlockRows + ciDataBlockRows]);
+ end; { case }
+end;
+{--------}
+function TffDataBlock.GetPropertyRowCount : Integer;
+begin
+ Result := ciFileBlockRows + ciDataBlockRows;
+end;
+{--------}
+function TffDataBlock.GetRecCount : Longint;
+begin
+ Result := PffBlockHeaderData(FBlock)^.bhdRecCount;
+end;
+{--------}
+function TffDataBlock.GetRecLen : Longint;
+begin
+ Result := PffBlockHeaderData(FBlock)^.bhdRecLength;
+end;
+{--------}
+{ The following code was copied from unit FFTBBLOB. }
+function TffDataBlock.IsEmptyLookupEntry(Entry : PffBLOBLookupEntry) : Boolean;
+const
+ ciEmptyVal1 = 808464432;
+ { This is because the lookup segments are fillchar'd with 'O' instead of 0.
+ We have to check all 3 fields in the lookup entry for this value so that
+ we avoid a case where the value is valid. }
+ ciEmptyVal2 = 1179010630;
+ { Another value that indicates an empty lookup entry. }
+begin
+ Result := ((Entry^.bleSegmentOffset.iLow = ciEmptyVal1) and
+ (Entry^.bleSegmentOffset.iHigh = ciEmptyVal1) and
+ (Entry^.bleContentLength = ciEmptyVal1)) or
+ ((Entry^.bleSegmentOffset.iLow = ciEmptyVal2) and
+ (Entry^.bleSegmentOffset.iHigh = ciEmptyVal2) and
+ (Entry^.bleContentLength = ciEmptyVal2));
+end;
+{--------}
+procedure TffDataBlock.SetNextDataBlock(const Value : TffWord32);
+begin
+ PffBlockHeaderData(FBlock)^.bhdNextDataBlock := Value;
+end;
+{--------}
+procedure TffDataBlock.SetPrevDataBlock(const Value : TffWord32);
+begin
+ PffBlockHeaderData(FBlock)^.bhdPrevDataBlock := Value;
+end;
+{--------}
+procedure TffDataBlock.SetRecCount(const Value : Longint);
+begin
+ PffBlockHeaderData(FBlock)^.bhdRecCount := Value;
+end;
+{--------}
+procedure TffDataBlock.SetRecLen(const Value : Longint);
+begin
+ PffBlockHeaderData(FBlock)^.bhdRecLength := Value;
+end;
+{--------}
+procedure TffDataBlock.VerifyBLOB(const BLOBNr : TffInt64;
+ var ErrCode : Integer);
+var
+ BLOBBlock : PffBlock;
+ BLOBBlockHdr : PffBlockHeaderBLOB absolute BLOBBlock;
+ BLOBBlockNum : TffWord32;
+ BLOBHeader : PffBLOBHeader;
+ EntryCount : Integer;
+ LookupBlock, ContentBlock : TffWord32;
+ LookupEntry : PffBLOBLookupEntry;
+ ContentEntry : PffBLOBSegmentHeader;
+ LookupSegBlk, ContentSegBlk : PffBlock;
+ LookupSegPtr : PffBLOBSegmentHeader;
+ NextSeg : TffInt64;
+ OffsetInBlock, ContentOffsetInBlock : TffWord32;
+ aLkpRelMethod,
+ aContRelMethod,
+ aHdRelMethod : TffReleaseMethod;
+ ByteCount,
+ CurByteCount : Longint;
+begin
+ ErrCode := 0;
+ CurByteCount := 0;
+ LookupSegBlk := nil;
+
+ { Read and verify the BLOB header block for this BLOB number. }
+ try
+ BLOBBlock := ReadVfyBlobBlock2(FFileInfo,
+ FTI,
+ ffc_ReadOnly,
+ BLOBNr,
+ BLOBBlockNum,
+ OffsetInBlock,
+ aHdRelMethod);
+ except
+ ErrCode := rciBLOBInvalidRefNr;
+ Exit;
+ end;
+
+ BLOBHeader := @BLOBBlock^[OffsetInBlock];
+
+ { Verify the BLOB has not been deleted. }
+ if (BLOBHeader^.bbhSignature = ffc_SigBLOBSegDeleted) then begin
+ ErrCode := rciBLOBDeleted;
+ Exit;
+ end
+ else if (BLOBHeader^.bbhSignature <> ffc_SigBLOBSegHeader) then begin
+ { The BLOB header has an invalid signature. }
+ ErrCode := rciBLOBHeaderSignature;
+ Exit;
+ end
+ else if BLOBHeader^.bbh1stLookupSeg.iLow = ffc_W32NoValue then
+ { The BLOB has been truncated to length zero. This is a valid situation &
+ there is nothing else to do. }
+ Exit
+ else if (BLOBHeader^.bbhSegCount = ffc_FileBLOB) or
+ (BLOBHeader^.bbhSegCount = ffc_BLOBLink) then
+ { This is a file BLOB or a BLOB link. There is nothing else to do so
+ exit the routine. }
+ Exit;
+
+ ByteCount := BLOBHeader^.bbhBLOBLength;
+ try
+ { Get the lookup segment block and set up offset for 1st lookup entry. }
+ try
+ LookupSegBlk := ReadVfyBlobBlock2(FFileInfo, FTI, ffc_ReadOnly,
+ BLOBHeader^.bbh1stLookupSeg,
+ LookupBlock, OffsetInBlock,
+ aLkpRelMethod);
+ except
+ ErrCode := rciBLOBInvalidLookupRefNr;
+ Exit;
+ end;
+ LookupSegPtr := @LookupSegBlk^[OffsetInBlock];
+ OffsetInBlock := OffsetInBlock + sizeof(TffBLOBSegmentHeader);
+
+ EntryCount := 0;
+ while True do begin
+ inc(EntryCount);
+ LookupEntry := @LookupSegBlk^[OffsetInBlock];
+ { If there are no more lookup entries then verification has finished. }
+ if (CurByteCount >= ByteCount) or
+ IsEmptyLookupEntry(LookupEntry) then
+ Exit;
+
+ inc(CurByteCount, LookupEntry^.bleContentLength);
+
+ { Verify the segment is valid. }
+ ContentSegBlk := nil;
+ aContRelMethod := nil;
+ try
+ ContentSegBlk := ReadVfyBlobBlock2(FFileInfo, FTI, ffc_ReadOnly,
+ LookupEntry^.bleSegmentOffset,
+ ContentBlock, ContentOffsetInBlock,
+ aContRelMethod);
+ except
+ ErrCode := rciBLOBInvalidContentRefNr;
+ Exit;
+ end;
+
+ try
+ ContentEntry := @ContentSegBlk^[ContentOffsetInBlock];
+ if PffBlockHeaderBLOB(ContentSegBlk)^.bhbSignature <> ffc_SigBLOBBlock then begin
+ ErrCode := rciBLOBContentBlockSignature;
+ Exit;
+ end
+ else if ContentEntry^.bshSignature <> ffc_SigBLOBSegContent then begin
+ ErrCode := rciBLOBContentSegSignature;
+ Exit;
+ end
+ else begin
+ { See if we're at the end of the lookup segment. }
+ if (LookupSegPtr^.bshSegmentLen <
+ (sizeof(TffBLOBSegmentHeader) +
+ (succ(EntryCount) * sizeof(TffBLOBLookupEntry)))) then begin
+ NextSeg := LookupSegPtr^.bshNextSegment;
+ if NextSeg.iLow <> ffc_W32NoValue then begin
+ aLkpRelMethod(LookupSegBlk);
+ try
+ LookupSegBlk := ReadVfyBlobBlock2(FFileInfo, FTI, ffc_ReadOnly,
+ NextSeg,
+ LookupBlock, OffsetInBlock,
+ aLkpRelMethod);
+ except
+ ErrCode := rciBLOBInvalidLookupRefNr;
+ Exit;
+ end;
+ LookupSegPtr := @LookupSegBlk^[OffsetInBlock];
+ OffsetInBlock := OffsetInBlock + sizeof(TffBLOBSegmentHeader);
+ EntryCount := 0;
+ end
+ else
+ break;
+ end else
+ OffsetInBlock := OffsetInBlock + sizeof(TffBLOBLookupEntry);
+ end;
+ finally
+ if Assigned(aContRelMethod) then
+ aContRelMethod(ContentSegBlk);
+ end;
+ end; {while}
+ finally
+ if assigned(LookupSegBlk) then
+ aLkpRelMethod(LookupSegBlk);
+ aHdRelMethod(BLOBBlock);
+ end;
+end;
+{--------}
+procedure TffDataBlock.VerifyRepair(const Repair : Boolean);
+var
+ BLOBInx,
+ Inx : Integer;
+ IsNull,
+ Modified : Boolean;
+ Block : PffBlock;
+ RelMethod : TffReleaseMethod;
+ Info : TffGeneralFileInfo;
+ RecPtrDel,
+ RecPtrData : PffByteArray;
+ Offset : Longint;
+ BLOBNr : TffInt64;
+ ErrCode : Integer;
+begin
+ inherited;
+ Modified := False;
+ try
+ { Get the general file info. }
+ if Assigned(FOnGetInfo) then
+ FOnGetInfo(Info)
+ else
+ raise Exception.Create('File interface must provide OnGetInfo handler.');
+
+ { Does the record count match the file header? }
+ if RecordCount <> Info.RecordsPerBlock then begin
+ DoReportError(rciInvalidDataBlockRecCount,
+ [BlockNum, RecordCount, Info.RecordsPerBlock]);
+ if Repair then begin
+ BeginUpdate;
+ Modified := True;
+ RecordCount := Info.RecordCount;
+ DoReportFix(rciInvalidDataBlockRecCount, [BlockNum, RecordCount]);
+ end;
+ end;
+
+ { Does the record length match? }
+ if RecordLen <> Info.Dict.RecordLength then begin
+ DoReportError(rciInvalidDataBlockRecLen,
+ [BlockNum, RecordLen, Info.Dict.RecordLength]);
+ if Repair then begin
+ BeginUpdate;
+ Modified := True;
+ RecordLen := Info.Dict.RecordLength;
+ DoReportFix(rciInvalidDataBlockRecLen, [BlockNum, RecordLen]);
+ end;
+ end;
+
+ { Verify the next data block is really a data block. }
+ if NextDataBlock <> ffc_W32NoValue then begin
+ try
+ Block := FBufMgr.GetBlock(FFileInfo, NextDataBlock, FTI, ffc_ReadOnly,
+ RelMethod);
+ try
+ if PffBlockHeaderData(Block)^.bhdSignature <> ffc_SigDataBlock then
+ DoReportError(rciInvalidNextDataBlock, [BlockNum, NextDataBlock]);
+ finally
+ RelMethod(Block);
+ end;
+ except
+ DoReportError(rciInvalidNextDataBlock, [BlockNum, NextDataBlock]);
+ end;
+ end; { if }
+
+ { Verify the previous data block is really a data block. }
+ if PrevDataBlock <> ffc_W32NoValue then begin
+ try
+ Block := FBufMgr.GetBlock(FFileInfo, PrevDataBlock, FTI, ffc_ReadOnly,
+ RelMethod);
+ try
+ if PffBlockHeaderData(Block)^.bhdSignature <> ffc_SigDataBlock then
+ DoReportError(rciInvalidPrevDataBlock, [BlockNum, PrevDataBlock]);
+ finally
+ RelMethod(Block);
+ end;
+ except
+ DoReportError(rciInvalidPrevDataBlock, [BlockNum, PrevDataBlock]);
+ end;
+ end; { if }
+
+ { If this table has BLOB fields & there is only 1 file then verify the
+ BLOBs. }
+ { Future: Handle BLOBs that are in a separate file. }
+ if Info.Dict.HasBLOBFields and (Info.Dict.FileCount = 1) then begin
+ { Loop through the records in the block. If the record is not deleted
+ then check its BLOB references.
+ If verifying then suggested repair method is to pack.
+ However, when repairing, any invalid BLOB references will be nulled.
+ Packing the table then removes the invalid BLOBs from the table. }
+ Offset := ffc_BlockHeaderSizeData;
+ for Inx := 0 to Pred(RecordCount) do begin
+ RecPtrDel := @FBlock[Offset];
+ RecPtrData := @FBlock[Offset + 1];
+ { Note: Adding +1 to offset skips the leading deleted flag. }
+ { Has the record been deleted? }
+ if PByte(RecPtrDel)^ <> $FF then begin
+ { No. Check each BLOB field. }
+ for BLOBInx := 0 to Pred(Info.BLOBFieldCount) do begin
+ Info.Dict.GetRecordField(Info.BLOBFields[BLOBInx],
+ RecPtrData, IsNull, @BLOBNr);
+ if not IsNull then begin
+ { If have a BLOB reference then verify the BLOB. }
+ VerifyBLOB(BLOBNr, ErrCode);
+ { If there is an error then report it. }
+ if ErrCode <> 0 then begin
+ DoReportError(ErrCode,
+ [Info.BLOBFieldNames[BLOBInx],
+ BLOBNr.iHigh, BLOBNr.iLow,
+ Info.KeyFieldValues(RecPtrData),
+ Inx, BlockNum]);
+ { If repairing then null out the BLOB reference. }
+ if Repair then begin
+ BeginUpdate;
+ Modified := True;
+ RecPtrData := @FBlock[Offset + 1];
+ Info.Dict.SetRecordFieldNull(Info.BLOBFields[BLOBInx],
+ RecPtrData, True);
+ DoReportFix(ErrCode, [Info.BLOBFieldNames[BLOBInx],
+ Info.KeyFieldValues(RecPtrData),
+ Inx, BlockNum]);
+ end;
+ end;
+ end; { if }
+ end; { for }
+ end; { if }
+ { Move to next record. }
+ inc(Offset, Info.RecLenPlusTrailer);
+ end; { for }
+ end; { if }
+
+ finally
+ if Modified then
+ EndUpdate;
+ end;
+end;
+{====================================================================}
+
+{===TffBLOBBlock=====================================================}
+procedure TffBLOBBlock.VerifyRepair(const Repair : Boolean);
+begin
+ inherited;
+end;
+{====================================================================}
+
+{===TffStreamBlock===================================================}
+procedure TffStreamBlock.VerifyRepair(const Repair : Boolean);
+begin
+ inherited;
+end;
+{====================================================================}
+initialization
+
+ Tffv2FileInterface.Register('FlashFiler 2 repair interface');
+
+finalization
+
+ Tffv2FileInterface.Unregister;
+
+end.
+
diff --git a/components/flashfiler/sourcelaz/Verify/frMain.dfm b/components/flashfiler/sourcelaz/Verify/frMain.dfm
new file mode 100644
index 000000000..f43d0d227
Binary files /dev/null and b/components/flashfiler/sourcelaz/Verify/frMain.dfm differ
diff --git a/components/flashfiler/sourcelaz/Verify/frMain.pas b/components/flashfiler/sourcelaz/Verify/frMain.pas
new file mode 100644
index 000000000..ebc8896b1
--- /dev/null
+++ b/components/flashfiler/sourcelaz/Verify/frMain.pas
@@ -0,0 +1,858 @@
+{*********************************************************}
+{* FlashFiler: Main form for verification utility *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit frMain;
+
+interface
+
+uses
+ Windows, Messages, SysUtils,
+ {$IFDEF DCC6OrLater}
+ Variants,
+ {$ENDIF}
+ Classes, Graphics, Controls, Forms,
+ Dialogs, Menus, ExtCtrls, ComCtrls, FFRepair, FFFileInt, StdCtrls;
+
+{ TODO::
+
+ Tasks listed by order of development:
+
+ - UI: view individual blocks within the file
+ - display index block data
+ - display data block data
+
+ - test index verify/repair
+
+ - file interface needs property to identify if a file is currently opened.
+ - backup of existing file to another directory
+ - incorporate chain gang for verification of deleted block chain
+ - verify/repair data block
+ - unknown block type error should result in need to restructure
+ - verify/repair stream block
+ - BLOB verify/repair
+ - display file size
+ - allow max ram of repair engine to be adjusted
+ - display max ram being used while verify/repair in progress
+ - duration of verification & repair
+
+ FUTURE development tasks:
+
+ - handle multi-file tables
+ - BLOB stats
+ - View block map of file
+}
+
+type
+ TfrmMain = class(TForm)
+ pnlTop: TPanel;
+ mnuMain: TMainMenu;
+ mnuFile: TMenuItem;
+ mnuFileOpen: TMenuItem;
+ mnuFileClose: TMenuItem;
+ mnuFileSep1: TMenuItem;
+ mnuFileExit: TMenuItem;
+ mnuFileSep2: TMenuItem;
+ mnuFileVerify: TMenuItem;
+ mnuFileRepair: TMenuItem;
+ tvMain: TTreeView;
+ Splitter: TSplitter;
+ dlgOpen: TOpenDialog;
+ Notebook: TPageControl;
+ pgProps: TTabSheet;
+ lvProps: TListView;
+ pgData: TTabSheet;
+ lvData: TListView;
+ pgStatus: TTabSheet;
+ pnlStatusBottom: TPanel;
+ progressBar: TProgressBar;
+ memStatus: TMemo;
+ lblStatus: TLabel;
+ pgRawData: TTabSheet;
+ lvRawData: TListView;
+ mnuFileSep3: TMenuItem;
+ mnuFileViewBlock: TMenuItem;
+ mnuChain: TMenuItem;
+ mnuChainViewData: TMenuItem;
+ mnuChainViewFree: TMenuItem;
+ pgReadMe: TTabSheet;
+ memReadMe: TMemo;
+ mnuOptions: TMenuItem;
+ procedure FormShow(Sender: TObject);
+ procedure mnuFileOpenClick(Sender: TObject);
+ procedure FormClose(Sender: TObject; var Action: TCloseAction);
+ procedure mnuFileExitClick(Sender: TObject);
+ procedure tvMainClick(Sender: TObject);
+ procedure mnuFileCloseClick(Sender: TObject);
+ procedure tvMainGetSelectedIndex(Sender: TObject; Node: TTreeNode);
+ procedure mnuFileVerifyClick(Sender: TObject);
+ procedure mnuFileRepairClick(Sender: TObject);
+ procedure NotebookChange(Sender: TObject);
+ procedure mnuFileViewBlockClick(Sender: TObject);
+ procedure FormCreate(Sender: TObject);
+ procedure FormDestroy(Sender: TObject);
+ procedure mnuChainViewDataClick(Sender: TObject);
+ procedure mnuChainViewFreeClick(Sender: TObject);
+ procedure mnuOptionsClick(Sender: TObject);
+ private
+ { Private declarations }
+ FBlockNumToNodeMap : TStringList;
+ FCurNode : TTreeNode;
+ FDataBlocksNode : TTreeNode;
+ FFileHeaderBlock : IFileHeaderBlock;
+ FFileName : string;
+ FIndexBlocksNode : TTreeNode;
+ FLastItem : TffRepairItem;
+ FOtherBlocksNode : TTreeNode;
+ FOutputVersion : Longint;
+ FRepair : TffRepairEngine;
+ FState : TffRepairState;
+ FViewedBlocks : TInterfaceList;
+
+ procedure ClearAll;
+ procedure ClearData;
+ procedure ClearProps;
+ procedure ClearRawData;
+ procedure ClearRepair;
+ procedure ClearStatus;
+ procedure ClearTreeView;
+ procedure ClearUI;
+ procedure DisplayData(const Block : ICommonBlock);
+ procedure DisplayProps(const Block : ICommonBlock);
+ procedure DisplayRawData(const Block : ICommonBlock);
+ procedure LoadUI;
+ procedure OnComplete(Sender : TObject);
+ procedure OnProgress(Repairer : TffRepairEngine;
+ State : TffRepairState;
+ Item : TffRepairItem;
+ const ActionStr : string;
+ const Position, Maximum : Integer);
+ procedure OnReportError(Block : ICommonBlock;
+ const ErrCode : Integer;
+ const ErrorStr : string);
+ procedure OnReportFix(Block : ICommonBlock;
+ const ErrCode : Integer;
+ const RepairStr : string);
+ procedure PositionToNode(Node : TTreeNode);
+ procedure ReleaseBlocksAndNodes;
+ procedure SetCtrlStates;
+ procedure Status(const Msg : string; args : array of const);
+ procedure VerifyRepair;
+ public
+ { Public declarations }
+ end;
+
+var
+ frmMain: TfrmMain;
+
+implementation
+
+{$R *.dfm}
+
+uses
+ frmBlock,
+ FFLLBase,
+ FFSrBase,
+ FFRepCnst, frmOptions;
+
+const
+ csBlock = 'Block %d';
+ csDataBlocks = 'Data blocks';
+ csDataDict = 'Data dictionary';
+ csFileHeader = 'File header';
+ csIndexBlocks = 'Index blocks';
+ csIndexHeader = 'Index header';
+ csOtherBlocks = 'Other blocks';
+ csStatusSep = '============================================================';
+
+function Singular(const Value : Integer;
+ const Singular, Plural : string) : string;
+begin
+ Result := IntToStr(Value) + ' ';
+ if Value = 1 then
+ Result := Result + Singular
+ else
+ Result := Result + Plural;
+end;
+
+procedure TfrmMain.FormShow(Sender: TObject);
+begin
+ ClearTreeView;
+ NoteBook.ActivePage := pgReadMe;
+// NoteBook.ActivePage := pgProps;
+ SetCtrlStates;
+end;
+
+procedure TfrmMain.ClearAll;
+begin
+ ClearRepair;
+ ClearTreeView;
+ ClearProps;
+ ClearData;
+ ClearRawData;
+ ClearStatus;
+end;
+
+procedure TfrmMain.ClearData;
+begin
+ lvData.Columns.Clear;
+ lvData.Items.Clear;
+end;
+
+procedure TfrmMain.ClearProps;
+begin
+ lvProps.Columns.Clear;
+ lvProps.Items.Clear;
+end;
+
+procedure TfrmMain.ClearRawData;
+begin
+ lvRawData.Columns.Clear;
+ lvRawData.Items.Clear;
+end;
+
+procedure TfrmMain.ClearUI;
+begin
+ ClearTreeView;
+ ClearProps;
+ ClearData;
+ ClearRawData;
+ { Note: This method does not clear the status page. }
+end;
+
+procedure TfrmMain.ReleaseBlocksAndNodes;
+begin
+ FFileHeaderBlock := nil;
+ FDataBlocksNode := nil;
+ FIndexBlocksNode := nil;
+ FOtherBlocksNode := nil;
+ FViewedBlocks.Clear;
+end;
+
+procedure TfrmMain.ClearRepair;
+begin
+ if FRepair <> nil then begin
+ ReleaseBlocksAndNodes;
+ FRepair.Free;
+ FRepair := nil;
+ end;
+end;
+
+procedure TfrmMain.ClearStatus;
+begin
+ memStatus.Clear;
+ FLastItem := riNone;
+end;
+
+procedure TfrmMain.ClearTreeView;
+begin
+ FCurNode := nil;
+ tvMain.Items.Clear;
+ tvMain.Items.Add(nil, '');
+end;
+
+procedure TfrmMain.DisplayData(const Block : ICommonBlock);
+var
+ Col, ColCount, Row : Integer;
+ Column : TListColumn;
+ Item : TListItem;
+begin
+ ClearData;
+ ColCount := Block.DataColCount;
+ for Col := 0 to Pred(ColCount) do begin
+ Column := lvData.Columns.Add;
+ Column.Caption := Block.DataColCaption[Col];
+ Column.Width := Block.DataColWidth[Col];
+ end;
+
+ for Row := 0 to Pred(Block.DataRowCount) do begin
+ Item := lvData.Items.Add;
+ for Col := 0 to Pred(ColCount) do begin
+ if Col = 0 then
+ Item.Caption := Block.DataCell[Row, Col]
+ else
+ Item.SubItems.Add(Block.DataCell[Row, Col]);
+ end; { for }
+ end; { for }
+end;
+
+procedure TfrmMain.DisplayProps(const Block : ICommonBlock);
+var
+ Col, ColCount, Row : Integer;
+ Column : TListColumn;
+ Item : TListItem;
+begin
+ ClearProps;
+ ColCount := Block.PropertyColCount;
+ for Col := 0 to Pred(ColCount) do begin
+ Column := lvProps.Columns.Add;
+ Column.Caption := Block.PropertyColCaption[Col];
+ Column.Width := Block.PropertyColWidth[Col];
+ end;
+
+ for Row := 0 to Pred(Block.PropertyRowCount) do begin
+ Item := lvProps.Items.Add;
+ for Col := 0 to Pred(ColCount) do begin
+ if Col = 0 then
+ Item.Caption := Block.PropertyCell[Row, Col]
+ else
+ Item.SubItems.Add(Block.PropertyCell[Row, Col]);
+ end; { for }
+ end; { for }
+end;
+
+procedure TfrmMain.DisplayRawData(const Block : ICommonBlock);
+var
+ Row : Integer;
+ Column : TListColumn;
+ Item : TListItem;
+ RawData : PffBlock;
+ Strings : TStringList;
+begin
+ ClearRawData;
+ RawData := Block.RawData;
+ Strings := TStringList.Create;
+ try
+ { Format the raw data. }
+ GenerateHexLines(RawData, FFileHeaderBlock.BlockSize, Strings);
+
+ { Set up the columns. }
+ Column := lvRawData.Columns.Add;
+ Column.Caption := 'Offset';
+ Column.Width := 70;
+
+ Column := lvRawData.Columns.Add;
+ Column.Caption := 'Bytes';
+ Column.Width := 475;
+
+ for Row := 0 to Pred(Strings.Count) do begin
+ Item := lvRawData.Items.Add;
+ Item.Caption := LongintToHex(Row * 16);
+ Item.SubItems.Add(Strings[Row]);
+ end;
+
+ finally
+ Strings.Free;
+ end;
+end;
+
+procedure TfrmMain.LoadUI;
+var
+ DictRootNode,
+ FileHeaderNode,
+ RootNode : TTreeNode;
+ Inx : Integer;
+ DictBlock : IStreamBlock;
+ IndexHeaderBlock : IIndexHeaderBlock;
+begin
+ { Set up the tree view. Display a root node identifying the file. Add
+ child nodes that provide access to the header block, dictionary blocks,
+ & index header. }
+ tvMain.Items.Clear;
+ RootNode := tvMain.Items.Add(nil, ExtractFileName(FFileName));
+ FFileHeaderBlock := FRepair.GetFileHeaderBlock;
+ FileHeaderNode := tvMain.Items.AddChildObject(RootNode, csFileHeader,
+ Pointer(FFileHeaderBlock));
+
+ DictRootNode := tvMain.Items.AddChild(RootNode, csDataDict);
+
+ for Inx := 0 to Pred(FRepair.DictBlockCount) do begin
+ DictBlock := FRepair.DictBlocks[Inx];
+ tvMain.Items.AddChildObject(DictRootNode,
+ Format(csBlock,
+ [DictBlock.BlockNum]),
+ Pointer(DictBlock));
+ FViewedBlocks.Add(DictBlock);
+ end;
+
+
+ { Create a node for the index header. }
+ IndexHeaderBlock := FRepair.GetIndexHeaderBlock;
+ tvMain.Items.AddChildObject(RootNode, csIndexHeader,
+ Pointer(IndexHeaderBlock));
+ FViewedBlocks.Add(IndexHeaderBlock);
+
+ { Create nodes for viewed data, index, & other blocks. }
+ FDataBlocksNode := tvMain.Items.AddChild(RootNode, csDataBlocks);
+ FIndexBlocksNode := tvMain.Items.AddChild(RootNode, csIndexBlocks);
+ FOtherBlocksNode := tvMain.Items.AddChild(RootNode, csOtherBlocks);
+
+ { By default, select the file header node & display its information. }
+ RootNode.Expand(True);
+ PositionToNode(FileHeaderNode);
+end;
+
+procedure TfrmMain.mnuFileOpenClick(Sender: TObject);
+begin
+ if dlgOpen.Execute then begin
+ FFileName := dlgOpen.FileName;
+ ClearAll;
+ FRepair := TffRepairEngine.Create;
+ FRepair.Open(FFileName);
+ LoadUI;
+ end;
+end;
+
+procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
+begin
+ ClearRepair;
+end;
+
+procedure TfrmMain.mnuFileExitClick(Sender: TObject);
+begin
+ Close;
+end;
+
+procedure TfrmMain.tvMainClick(Sender: TObject);
+var
+ Node : TTreeNode;
+begin
+ Node := tvMain.Selected;
+ if (Node <> nil) and (Node <> FCurNode) then begin
+ { Set up the list view columns. Raw data will be displayed when the user
+ views that page. }
+ ClearRawData;
+ if Node.Data <> nil then begin
+ DisplayProps(ICommonBlock(Node.Data));
+ DisplayData(ICommonBlock(Node.Data));
+ if Notebook.ActivePage = pgRawData then
+ DisplayRawData(ICommonBlock(Node.Data))
+ else if (FState = rmIdle) and (NoteBook.ActivePage = pgStatus) then
+ { If state is idle (i.e., we did not just finish repairing) &
+ on the status page then switch to the props page. }
+ NoteBook.ActivePage := pgProps;
+ end
+ else begin
+ ClearProps;
+ ClearData;
+ end;
+ FCurNode := Node;
+ end
+ else if (Node <> nil) and (FState = rmIdle) and
+ (Notebook.ActivePage = pgStatus) then
+ { If user clicked on the current node & the status page is displayed then
+ flip over to the properties page. }
+ NoteBook.ActivePage := pgProps;
+end;
+
+procedure TfrmMain.mnuFileCloseClick(Sender: TObject);
+begin
+ if FRepair <> nil then
+ ClearAll;
+end;
+
+procedure TfrmMain.tvMainGetSelectedIndex(Sender: TObject;
+ Node: TTreeNode);
+begin
+ tvMainClick(Sender);
+end;
+
+procedure TfrmMain.OnComplete(Sender : TObject);
+var
+ Action, HighestAction : TffRepairAction;
+ Inx : Integer;
+ SelfRepairing : Boolean;
+ AbortMsg,
+ Recommendation,
+ StatusMsg,
+ RepairedErrSummary,
+ Summary : string;
+begin
+ progressBar.Position := 0;
+ Status(csStatusSep, []);
+
+ { Determine the highest repair action. }
+ SelfRepairing := False;
+ HighestAction := raDecide;
+ for Inx := 0 to Pred(FRepair.ErrorCount) do begin
+ Action := rcAction[FRepair.ErrorCodes[Inx]];
+ if Action = raSelfRepair then
+ SelfRepairing := True;
+ if Action > HighestAction then
+ HighestAction := Action;
+ end; { for }
+
+ if FState = rmVerify then begin
+ lblStatus.Caption := 'Verification complete.';
+ if FRepair.ErrorCount = 0 then
+ StatusMsg := 'Verification complete. No errors were found.'
+ else begin
+ StatusMsg := Format('Verification complete. Found %s.',
+ [Singular(FRepair.ErrorCount, 'error', 'errors')]);
+ if FRepair.Aborted then
+ AbortMsg := 'The error limit was reached. There may be additional errors.';
+
+ { Build a summary/recommended course of action. }
+ case HighestAction of
+ raSelfRepair :
+ begin
+ Summary := 'All errors can be successfully repaired without ' +
+ 'packing the file.';
+ Recommendation := 'Allow this utility to repair the file.';
+ end;
+ raDecide, raPack :
+ begin
+ if SelfRepairing then begin
+ Summary := 'Some of the errors can be manually repaired ' +
+ 'but other errors require the file to be packed.';
+ Recommendation := 'Allow this utility to repair and restructure ' +
+ 'the file.';
+ end
+ else begin
+ Summary := 'The errors in the file require the file to be ' +
+ 'packed.';
+ Recommendation := 'Allow this utility to pack the file.';
+ end;
+ end;
+ raUnsalvageable :
+ begin
+ Summary := 'The file and its data cannot be salvaged.';
+ Recommendation := 'Restore this file from the last known good backup.';
+ end;
+ end; { case }
+
+ if FRepair.Aborted then
+ StatusMsg := StatusMsg + #13#10#13#10 + AbortMsg;
+
+ StatusMsg := StatusMsg + #13#10#13#10 + Summary + #13#10#13#10 +
+ Recommendation;
+ end; { if }
+ end
+ else begin
+ lblStatus.Caption := 'Repair complete.';
+ if FRepair.ErrorCount = 0 then
+ StatusMsg := 'Repair complete. No errors were found.'
+ else begin
+ { Generate a summary count for found & repaired errors. }
+ RepairedErrSummary := Format('Found %s and repaired %s.',
+ [Singular(FRepair.ErrorCount, 'error', 'errors'),
+ Singular(FRepair.FixCount, 'error', 'errors')]);
+
+ { Did a pack or reindex fail? }
+ if HighestAction = raUnsalvageable then
+ StatusMsg := 'Repair did not complete successfully. ' +
+ RepairedErrSummary
+ else begin
+ { No, the repair was entirely successful. Indicate if table was packed
+ or reindex. }
+ if HighestAction = raPack then
+ RepairedErrSummary := RepairedErrSummary +
+ ' The table was packed.';
+
+ StatusMsg := 'Repair complete. ' + RepairedErrSummary;
+ end; { if..else }
+ end; { if..else }
+ end;
+ Status(StatusMsg, []);
+ Status(csStatusSep, []);
+ ShowMessage(StatusMsg);
+end;
+
+procedure TfrmMain.OnProgress(Repairer : TffRepairEngine;
+ State : TffRepairState;
+ Item : TffRepairItem;
+ const ActionStr : string;
+ const Position, Maximum : Integer);
+begin
+ ProgressBar.Min := 1;
+ ProgressBar.Max := Maximum;
+ ProgressBar.Position := Position;
+ lblStatus.Caption := ActionStr;
+ if Item <> FLastItem then begin
+ Status(ActionStr, []);
+ FLastItem := Item;
+ end;
+ Application.ProcessMessages;
+end;
+
+procedure TfrmMain.OnReportError(Block : ICommonBlock;
+ const ErrCode : Integer;
+ const ErrorStr : string);
+begin
+ if Block = nil then
+ Status('Error %d: %s', [ErrCode, ErrorStr])
+ else
+ Status('Block %d (%d): %s', [Block.BlockNum, ErrCode, ErrorStr]);
+end;
+
+procedure TfrmMain.OnReportFix(Block : ICommonBlock;
+ const ErrCode : Integer;
+ const RepairStr : string);
+begin
+ if Block = nil then
+ Status('..Fix, code %d: %s', [ErrCode, RepairStr])
+ else
+ Status('..Block %d (%d): %s', [Block.BlockNum, ErrCode, RepairStr]);
+end;
+
+procedure TfrmMain.Status(const Msg : string; args : array of const);
+begin
+ memStatus.Lines.Add(Format(Msg, args));
+ Application.ProcessMessages;
+end;
+
+procedure TfrmMain.mnuFileVerifyClick(Sender: TObject);
+begin
+ if FState = rmIdle then begin
+ FState := rmVerify;
+ try
+ VerifyRepair;
+ finally
+ Application.ProcessMessages;
+ FState := rmIdle;
+ end;
+ end
+ else
+ ShowMessage('Verify can be performed only when this utility is Idle.');
+end;
+
+procedure TfrmMain.SetCtrlStates;
+var
+ Opened : Boolean;
+begin
+ Opened := (FRepair <> nil);
+ mnuFileClose.Enabled := Opened;
+ mnuFileVerify.Enabled := Opened;
+ mnuFileRepair.Enabled := Opened;
+ mnuChainViewData.Enabled := Opened;
+ mnuChainViewFree.Enabled := Opened;
+ mnuFileViewBlock.Enabled := Opened;
+end;
+
+procedure TfrmMain.mnuFileRepairClick(Sender: TObject);
+begin
+ if FState = rmIdle then begin
+ FState := rmRepair;
+ try
+ ReleaseBlocksAndNodes;
+ ClearUI;
+ Application.ProcessMessages;
+ VerifyRepair;
+ finally
+ LoadUI;
+ Application.ProcessMessages;
+ FState := rmIdle;
+ end;
+ end
+ else
+ ShowMessage('Repair can be performed only when this utility is Idle.');
+end;
+
+procedure TfrmMain.VerifyRepair;
+var
+ SavCursor : TCursor;
+begin
+ if FRepair <> nil then begin
+ Notebook.ActivePage := pgStatus;
+ SavCursor := Screen.Cursor;
+ Screen.Cursor := crHourGlass;
+ try
+ ClearStatus;
+ FRepair.OnComplete := OnComplete;
+ FRepair.OnProgress := OnProgress;
+ FRepair.OnReportError := OnReportError;
+ FRepair.OnReportFix := OnReportFix;
+ if FState = rmVerify then
+ FRepair.Verify
+ else begin
+ FRepair.OutputVersion := FOutputVersion;
+ FRepair.Repair;
+ end;
+ finally
+ Screen.Cursor := SavCursor;
+ end;
+ end; { if }
+end;
+
+procedure TfrmMain.NotebookChange(Sender: TObject);
+var
+ Node : TTreeNode;
+begin
+ if (Notebook.ActivePage = pgRawData) and (lvRawData.Items.Count = 0) then begin
+ Node := tvMain.Selected;
+ if (Node <> nil) and (Node.Data <> nil) then
+ DisplayRawData(ICommonBlock(Node.Data));
+ end;
+end;
+
+procedure TfrmMain.mnuFileViewBlockClick(Sender: TObject);
+var
+ BlockNumber : TffWord32;
+ Block : ICommonBlock;
+ Inx : Integer;
+ Node : TTreeNode;
+begin
+ { Have the user enter the block number. }
+ if Assigned(FFileHeaderBlock) then
+ with TfrmBlockNum.Create(nil) do
+ try
+ MaxBlockNum := Pred(FFileHeaderBlock.UsedBlocks);
+ ShowModal;
+ BlockNumber := BlockNum;
+ { If a block number was specified, see if it is the same as
+ an existing node or if a new node must be added. }
+ if BlockNumber <> ffc_W32NoValue then begin
+ (* { TODO:: If this is a preloaded block then go to the appropriate tree node. }
+ if BlockNumber = xxx then
+ else if BlockNumber = xxx then
+ else if BlockNumber = xxx then
+ else if BlockNumber = xxx then
+ else if BlockNumber = xxx then*)
+
+ { Determine if this is already available via an existing node in the
+ tree. }
+ Inx := FBlockNumToNodeMap.IndexOf(IntToStr(BlockNumber));
+ if Inx > -1 then begin
+
+ end
+ else begin
+ { The block has not been viewed. Load the block & put it into the
+ tree view. }
+ Block := FRepair.GetBlock(BlockNumber);
+ FViewedBlocks.Add(Block);
+ if Block.Signature = ffc_SigDataBlock then begin
+ { Add this under the data blocks node. }
+ Node := tvMain.Items.AddChildObject(FDataBlocksNode,
+ Format(csBlock,
+ [Block.BlockNum]),
+ Pointer(Block));
+ end
+ else if Block.Signature = ffc_SigIndexBlock then begin
+ { Add this under the index blocks node. }
+ Node := tvMain.Items.AddChildObject(FIndexBlocksNode,
+ Format(csBlock,
+ [Block.BlockNum]),
+ Pointer(Block));
+ end
+ else begin
+ { Add this under the other blocks node. }
+ Node := tvMain.Items.AddChildObject(FOtherBlocksNode,
+ Format(csBlock,
+ [Block.BlockNum]),
+ Pointer(Block));
+ end; { if..else }
+ { Add this block to the blocknumber-to-node map. }
+ FBlockNumToNodeMap.AddObject(IntToStr(BlockNumber), Node);
+
+ { Position the tree view to the node. }
+ PositionToNode(Node);
+ end;
+ end;
+ finally
+ Free;
+ end;
+end;
+
+procedure TfrmMain.PositionToNode(Node : TTreeNode);
+begin
+ tvMain.Selected := Node;
+{$IFDEF DCC6OrLater}
+ tvMain.Select(Node);
+{$ELSE}
+ tvMain.Selected := Node;
+{$ENDIF}
+ Node.Focused := True;
+ Node.Selected := True;
+ FCurNode := Node;
+ SetCtrlStates;
+end;
+
+procedure TfrmMain.FormCreate(Sender: TObject);
+begin
+ FBlockNumToNodeMap := TStringList.Create;
+ with TffVerifyOptions.Create do
+ try
+ FOutputVersion := OutputVersion;
+ finally
+ Free;
+ end;
+ FViewedBlocks := TInterfaceList.Create;
+end;
+
+procedure TfrmMain.FormDestroy(Sender: TObject);
+begin
+ FViewedBlocks.Free;
+ FBlockNumToNodeMap.Free;
+end;
+
+procedure TfrmMain.mnuChainViewDataClick(Sender: TObject);
+var
+ SavCursor : TCursor;
+begin
+ if FRepair <> nil then begin
+ Notebook.ActivePage := pgStatus;
+ SavCursor := Screen.Cursor;
+ Screen.Cursor := crHourGlass;
+ FState := rmAcquireInfo;
+ try
+ ClearStatus;
+ memStatus.Text := FRepair.GetDataChainDetails.Text;
+ finally
+ FState := rmIdle;
+ Screen.Cursor := SavCursor;
+ end;
+ end;
+end;
+
+procedure TfrmMain.mnuChainViewFreeClick(Sender: TObject);
+var
+ SavCursor : TCursor;
+begin
+ if FRepair <> nil then begin
+ Notebook.ActivePage := pgStatus;
+ SavCursor := Screen.Cursor;
+ Screen.Cursor := crHourGlass;
+ FState := rmAcquireInfo;
+ try
+ ClearStatus;
+ memStatus.Text := FRepair.GetFreeChainDetails.Text;
+ finally
+ FState := rmIdle;
+ Screen.Cursor := SavCursor;
+ end;
+ end;
+end;
+
+procedure TfrmMain.mnuOptionsClick(Sender: TObject);
+var
+ Options : TfrmOptionsConfig;
+begin
+ Options := TfrmOptionsConfig.Create(nil);
+ try
+ Options.ShowModal;
+ if Options.ModalResult = mrOK then
+ FOutputVersion := Options.OutputVersion;
+ finally
+ Options.Free;
+ end;
+end;
+
+end.
+
diff --git a/components/flashfiler/sourcelaz/Verify/frmBlock.dfm b/components/flashfiler/sourcelaz/Verify/frmBlock.dfm
new file mode 100644
index 000000000..951aa1c49
Binary files /dev/null and b/components/flashfiler/sourcelaz/Verify/frmBlock.dfm differ
diff --git a/components/flashfiler/sourcelaz/Verify/frmBlock.pas b/components/flashfiler/sourcelaz/Verify/frmBlock.pas
new file mode 100644
index 000000000..9ac93759c
--- /dev/null
+++ b/components/flashfiler/sourcelaz/Verify/frmBlock.pas
@@ -0,0 +1,119 @@
+{*********************************************************}
+{* FlashFiler: Input form for block to be viewed *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit frmBlock;
+
+interface
+
+uses
+ {$IFDEF DCC6OrLater}
+ Variants,
+ {$ENDIF}
+ Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
+ Dialogs, StdCtrls, FFLLBase;
+
+type
+ TfrmBlockNum = class(TForm)
+ edtBlockNum: TEdit;
+ pbOK: TButton;
+ pbCancel: TButton;
+ lblBlockNum: TLabel;
+ lblValidRange: TLabel;
+ procedure FormShow(Sender: TObject);
+ procedure edtBlockNumKeyPress(Sender: TObject; var Key: Char);
+ procedure pbOKClick(Sender: TObject);
+ procedure pbCancelClick(Sender: TObject);
+ procedure edtBlockNumChange(Sender: TObject);
+ private
+ { Private declarations }
+ FBlockNum : TffWord32;
+ FMaxBlockNum : TffWord32;
+ public
+ { Public declarations }
+ procedure SetCtrlStates;
+
+ property BlockNum : TffWord32 read FBlockNum write FBlockNum;
+ property MaxBlockNum : TffWord32 read FMaxBlockNum write FMaxBlockNum;
+ end;
+
+var
+ frmBlockNum: TfrmBlockNum;
+
+implementation
+
+{$R *.dfm}
+
+procedure TfrmBlockNum.FormShow(Sender: TObject);
+begin
+ FBlockNum := ffc_W32NoValue;
+ edtBlockNum.SetFocus;
+ lblValidRange.Caption := Format('Valid range is 0 to %d', [FMaxBlockNum]);
+ SetCtrlStates;
+end;
+
+procedure TfrmBlockNum.edtBlockNumKeyPress(Sender: TObject; var Key: Char);
+begin
+ if (Key <> Char(8)) and ((Key < '0') or (Key > '9')) then begin
+ Key := Char(0);
+ Beep;
+ end;
+end;
+
+procedure TfrmBlockNum.pbOKClick(Sender: TObject);
+begin
+ FBlockNum := StrToInt(edtBlockNum.Text);
+ Close;
+end;
+
+procedure TfrmBlockNum.pbCancelClick(Sender: TObject);
+begin
+ Close;
+end;
+
+procedure TfrmBlockNum.SetCtrlStates;
+var
+ BlockNum : TffWord32;
+begin
+ if edtBlockNum.Text <> '' then begin
+ BlockNum := StrToInt(edtBlockNum.Text);
+ pbOK.Enabled := (edtBlockNum.Text <> '') and
+ (BlockNum <= FMaxBlockNum);
+ end
+ else
+ pbOK.Enabled := False;
+end;
+
+procedure TfrmBlockNum.edtBlockNumChange(Sender: TObject);
+begin
+ SetCtrlStates;
+end;
+
+end.
diff --git a/components/flashfiler/sourcelaz/Verify/frmOptions.dfm b/components/flashfiler/sourcelaz/Verify/frmOptions.dfm
new file mode 100644
index 000000000..68252c780
Binary files /dev/null and b/components/flashfiler/sourcelaz/Verify/frmOptions.dfm differ
diff --git a/components/flashfiler/sourcelaz/Verify/frmOptions.pas b/components/flashfiler/sourcelaz/Verify/frmOptions.pas
new file mode 100644
index 000000000..a01268064
--- /dev/null
+++ b/components/flashfiler/sourcelaz/Verify/frmOptions.pas
@@ -0,0 +1,198 @@
+{*********************************************************}
+{* FlashFiler: Options configuration *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit frmOptions;
+
+interface
+
+uses
+ {$IFDEF DCC6OrLater}
+ Variants,
+ {$ENDIF}
+ Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
+ Dialogs, StdCtrls, ExtCtrls;
+
+type
+ TffVerifyOptions = class
+ protected
+ FOutputVersion : Longint;
+ procedure Load;
+ public
+ constructor Create;
+ procedure Save;
+
+ property OutputVersion : Longint
+ read FOutputVersion write FOutputVersion;
+ end;
+
+ TfrmOptionsConfig = class(TForm)
+ pnlBottom: TPanel;
+ pbOK: TButton;
+ pbCancel: TButton;
+ pnlClient: TPanel;
+ lblVersion: TLabel;
+ efVersion: TEdit;
+ lblValidRange: TLabel;
+ procedure pbOKClick(Sender: TObject);
+ procedure FormShow(Sender: TObject);
+ procedure efVersionKeyPress(Sender: TObject; var Key: Char);
+ procedure efVersionChange(Sender: TObject);
+ private
+ { Private declarations }
+ FOptions : TffVerifyOptions;
+
+ function GetOutputVersion : Longint;
+ procedure SetCtrlStates;
+ function ValidVersion : Boolean;
+ public
+ { Public declarations }
+ property OutputVersion : Longint
+ read GetOutputVersion;
+ end;
+
+var
+ frmOptionsConfig: TfrmOptionsConfig;
+
+implementation
+
+uses
+ ffllbase,
+ IniFiles;
+
+{$R *.dfm}
+
+const
+ cIniFile = 'FFVerify.ini';
+ cSect = 'Options';
+ cVersion = 'OutputVersion';
+
+{===TffVerifyOptions=================================================}
+constructor TffVerifyOptions.Create;
+begin
+ inherited;
+ Load;
+end;
+{--------}
+procedure TffVerifyOptions.Load;
+begin
+ with TIniFile.Create(cIniFile) do
+ try
+ FOutputVersion := ReadInteger(cSect, cVersion, ffVersionNumber);
+ finally
+ Free;
+ end;
+end;
+{--------}
+procedure TffVerifyOptions.Save;
+begin
+ with TIniFile.Create(cIniFile) do
+ try
+ WriteInteger(cSect, cVersion, FOutputVersion);
+ finally
+ Free;
+ end;
+end;
+{====================================================================}
+
+procedure TfrmOptionsConfig.pbOKClick(Sender: TObject);
+begin
+ ModalResult := mrOK;
+ FOptions.OutputVersion := GetOutputVersion;
+ FOptions.Save;
+ FOptions.Free;
+end;
+
+procedure TfrmOptionsConfig.FormShow(Sender: TObject);
+begin
+ { Read the options from the INI file. }
+ FOptions := TffVerifyOptions.Create;
+ efVersion.Text := IntToStr(FOptions.OutputVersion);
+ lblValidRange.Caption := Format('Valid range: %d to %d',
+ [ffVersion2_10, ffVersionNumber]);
+ SetCtrlStates;
+ efVersion.SetFocus;
+end;
+
+function TfrmOptionsConfig.GetOutputVersion : Longint;
+var
+ TmpStr,
+ VerStr : string;
+ TmpLen,
+ SrcInx,
+ TgtInx : Integer;
+begin
+ { Strip out all decimal points. }
+ TmpStr := efVersion.Text;
+ TmpLen := Length(TmpStr);
+ SetLength(VerStr, TmpLen);
+ TgtInx := 1;
+ for SrcInx := 1 to TmpLen do
+ if TmpStr[SrcInx] in ['0'..'9'] then begin
+ VerStr[TgtInx] := TmpStr[SrcInx];
+ inc(TgtInx);
+ end;
+ SetLength(VerStr, Pred(TgtInx));
+ Result := StrToInt(VerStr);
+end;
+
+function TfrmOptionsConfig.ValidVersion : Boolean;
+var
+ Version : Longint;
+begin
+ try
+ Version := GetOutputVersion;
+ { The version # is valid if it an integer between 21000 and the current
+ FF version. }
+ Result := (Version >= ffVersion2_10) and (Version <= ffVersionNumber);
+ except
+ Result := False;
+ end;
+end;
+
+procedure TfrmOptionsConfig.efVersionKeyPress(Sender: TObject; var Key: Char);
+begin
+ if not (Key in [#8, '0'..'9', '.']) then begin
+ Beep;
+ Key := #0;
+ end;
+end;
+
+procedure TfrmOptionsConfig.SetCtrlStates;
+begin
+ pbOK.Enabled := ValidVersion;
+end;
+
+procedure TfrmOptionsConfig.efVersionChange(Sender: TObject);
+begin
+ SetCtrlStates;
+end;
+
+end.
diff --git a/components/flashfiler/sourcelaz/Verify/readme.txt b/components/flashfiler/sourcelaz/Verify/readme.txt
new file mode 100644
index 000000000..e32564811
--- /dev/null
+++ b/components/flashfiler/sourcelaz/Verify/readme.txt
@@ -0,0 +1,9 @@
+README: FFVerify
+
+The FFVerify utility may be used to verify and repair FlashFiler 2
+tables.
+
+FFVerify was never officially released with FlashFiler 2 and should be
+considered alpha quality.
+
+FFVerify compiles with Delphi 5 and higher.
diff --git a/components/flashfiler/sourcelaz/bde2ff/bde2ff.dpr b/components/flashfiler/sourcelaz/bde2ff/bde2ff.dpr
new file mode 100644
index 000000000..418f97bc7
--- /dev/null
+++ b/components/flashfiler/sourcelaz/bde2ff/bde2ff.dpr
@@ -0,0 +1,54 @@
+{*********************************************************}
+{* Project source file *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+program Bde2ff;
+
+{$I ffdefine.inc}
+
+uses
+ {$IFDEF USETeDEBUG}
+ TeDebug,
+ {$ENDIF}
+ ffllbase,
+ ffllprot,
+ SysUtils,
+ Forms,
+ fmmain in 'fmmain.pas' {frmMain},
+ dgimpdo in 'dgimpdo.pas' {dlgImportProgress};
+
+{$R *.RES}
+
+begin
+ Application.Initialize;
+ Application.HelpFile := 'BDE2FF.DPR';
+ Application.CreateForm(TfrmMain, frmMain);
+ Application.CreateForm(TdlgImportProgress, dlgImportProgress);
+ Application.Run;
+end.
+
diff --git a/components/flashfiler/sourcelaz/bde2ff/bde2ff.rc b/components/flashfiler/sourcelaz/bde2ff/bde2ff.rc
new file mode 100644
index 000000000..047b239b8
--- /dev/null
+++ b/components/flashfiler/sourcelaz/bde2ff/bde2ff.rc
@@ -0,0 +1,60 @@
+/*********************************************************
+ * Main program icon resource *
+ *********************************************************/
+
+/* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** */
+
+#define VERSIONINFO_1 1
+
+VERSIONINFO_1 VERSIONINFO
+FILEVERSION 2, 1, 3, 0
+PRODUCTVERSION 2, 1, 3, 0
+FILEOS VOS__WINDOWS32
+FILETYPE VFT_APP
+{
+ BLOCK "StringFileInfo"
+ {
+ BLOCK "040904E4"
+ {
+ VALUE "CompanyName", "TurboPower Software Company\000\000"
+ VALUE "FileDescription", "FlashFiler BDE2FF\000"
+ VALUE "FileVersion", "2.1.3.0\000"
+ VALUE "InternalName", "BDE2FF\000"
+ VALUE "LegalCopyright", "Copyright (c) TurboPower Software Co. 1996-2002\000\000"
+ VALUE "OriginalFilename", "BDE2FF.EXE\000"
+ VALUE "ProductName", "FlashFiler (Delphi Edition)\000"
+ VALUE "ProductVersion", "2.1.3.0\000"
+ }
+
+ }
+
+ BLOCK "VarFileInfo"
+ {
+ VALUE "Translation", 0x409, 1252
+ }
+
+}
+
diff --git a/components/flashfiler/sourcelaz/bde2ff/bde2ff.res b/components/flashfiler/sourcelaz/bde2ff/bde2ff.res
new file mode 100644
index 000000000..c262f353e
Binary files /dev/null and b/components/flashfiler/sourcelaz/bde2ff/bde2ff.res differ
diff --git a/components/flashfiler/sourcelaz/bde2ff/dgimpdo.dfm b/components/flashfiler/sourcelaz/bde2ff/dgimpdo.dfm
new file mode 100644
index 000000000..920e2ec73
Binary files /dev/null and b/components/flashfiler/sourcelaz/bde2ff/dgimpdo.dfm differ
diff --git a/components/flashfiler/sourcelaz/bde2ff/dgimpdo.pas b/components/flashfiler/sourcelaz/bde2ff/dgimpdo.pas
new file mode 100644
index 000000000..87a981ec8
--- /dev/null
+++ b/components/flashfiler/sourcelaz/bde2ff/dgimpdo.pas
@@ -0,0 +1,575 @@
+{*********************************************************}
+{* Progress meter for import operations *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit dgimpdo;
+
+interface
+
+uses
+ Windows,
+ SysUtils,
+ Dialogs,
+ Classes,
+ DBTables,
+ Graphics,
+ Forms,
+ Controls,
+ StdCtrls,
+ DB,
+ Buttons,
+ ExtCtrls,
+ Gauges,
+ dbconsts,
+ bde,
+ bdeconst,
+ ffllbase,
+ ffsrbde,
+ ffdb,
+ ffdbbase;
+
+type
+ TdlgImportProgress = class(TForm)
+ Bevel1: TBevel;
+ lblProgress: TLabel;
+ btnCancel: TBitBtn;
+ Label1: TLabel;
+ Label2: TLabel;
+ edtImportFilename: TEdit;
+ edtTablename: TEdit;
+ guaProgress: TGauge;
+ procedure btnCancelClick(Sender: TObject);
+ private
+ public
+ Terminated : Boolean;
+
+ procedure ShowProgress(aImportFilename, aTableName : string);
+ procedure UpdateProgress(aNumRead, aTotalRecs : Longint);
+ end;
+
+procedure ConvertBDEDataType(aDataType : TFieldType;
+ aSize : LongInt;
+ var aFFType : TffFieldType;
+ var aFFSize : LongInt;
+ var aFFDecPl : Integer);
+
+function DoImport(aSourceTable : TTable; { Table to copy from }
+ aSourceFields : TStringList; { List of field #'s to copy }
+ aDestTable : TffTable; { Table to copy to }
+ aBlockInserts : SmallInt; { Transaction batch size }
+ var aNumTransferred : LongInt): Boolean; { Number of records copied }
+
+var
+ dlgImportProgress : TdlgImportProgress;
+
+implementation
+
+{$R *.DFM}
+
+uses
+ ffclintf,
+ fmmain;
+
+procedure ConvertBDEDataType(aDataType : TFieldType;
+ aSize : LongInt;
+ var aFFType : TffFieldType;
+ var aFFSize : LongInt;
+ var aFFDecPl : Integer);
+begin
+ aFFSize := aSize;
+ aFFDecPl := 0;
+ case aDatatype of
+ {$IFDEF DCC4OrLater}
+ ftFixedChar,
+ {$ENDIF}
+ ftString :
+{Begin !!.01}
+ if aSize <= 255 then begin
+{Begin !!.11}
+ if frmMain.chkUseANSIFields.Checked then begin
+ if frmMain.chkUseZeroTerminatedStrings.Checked then
+ aFFType := fftNullAnsiStr
+ else
+ aFFType := fftShortAnsiStr
+ end
+ else begin
+ if frmMain.chkUseZeroTerminatedStrings.Checked then
+ aFFType := fftNullString
+ else
+ aFFType := fftShortString;
+ end
+{End !!.11}
+ end
+ else begin
+ if frmMain.chkUseANSIFields.Checked then
+ aFFType := fftNullAnsiStr
+ else
+ aFFType := fftNullString;
+ end;
+{End !!.01}
+ ftSmallint:
+ aFFType := fftInt16;
+ ftInteger:
+ aFFType := fftInt32;
+ ftWord:
+ aFFType := fftWord16;
+ ftBoolean:
+ aFFType := fftBoolean;
+ ftFloat:
+ aFFType := fftDouble;
+ ftCurrency:
+ aFFType := fftCurrency;
+ ftBCD:
+ aFFType := fftDouble;
+ ftDate:
+{Begin !!.11}
+ if frmMain.chkUseSysToolsDates.Checked then
+ aFFType := fftStDate
+ else
+ aFFType := fftDateTime;
+{End !!.11}
+ ftTime:
+{Begin !!.11}
+ if frmMain.chkUseSysToolsTimes.Checked then
+ aFFType := fftStTime
+ else
+ aFFType := fftDateTime;
+{End !!.11}
+ ftDateTime:
+ aFFType := fftDateTime;
+ ftBytes,
+ ftVarBytes:
+ aFFType := fftByteArray;
+ ftBlob:
+ aFFType := fftBLOB;
+ ftMemo:
+ aFFType := fftBLOBMemo;
+ ftGraphic:
+ aFFType := fftBLOBGraphic;
+ ftAutoInc:
+ aFFType := fftAutoInc;
+ ftFmtMemo:
+ aFFType := fftBLOBFmtMemo;
+ ftParadoxOle,
+ ftDBaseOle:
+ aFFType := fftBLOBOleObj;
+ ftTypedBinary:
+ aFFType := fftBLOBTypedBin;
+ end;
+end;
+
+function DoImport(aSourceTable : TTable;
+ aSourceFields : TStringList;
+ aDestTable : TffTable;
+ aBlockInserts : SmallInt;
+ var aNumTransferred : LongInt) : Boolean;
+
+resourcestring
+ SInvalidFieldKind = 'Invalid Field Conversion %s <- %s';
+var
+ FieldNo : Integer;
+ DestFieldNo : Integer;
+ TotalRecs : Longint;
+ DoThisOne : Boolean;
+ DoExplicitTrans : Boolean;
+ InTransaction : Boolean;
+ MaxAutoInc : Integer;
+ TempStr : string; {!!.01}
+
+ procedure CopyField(aDestField, aSourceField : TField);
+ var
+ Buffer : Pointer;
+ Stream : TMemoryStream;
+ begin
+{Begin !!.11}
+ if aSourceField.IsNull then begin
+ if frmMain.chkEmptyStrings.Checked and
+ (aSourceField.Datatype = ftString) then
+ aDestField.AsString := ''
+ else
+ aDestField.Clear;
+ end
+ else
+{End !!.11}
+ case aSourceField.Datatype of
+ ftBoolean:
+ case aDestField.Datatype of
+ ftBoolean:
+ aDestField.AsBoolean := aSourceField.AsBoolean;
+ else
+ DatabaseErrorFmt(SInvalidFieldKind, [aDestField.DisplayName,
+ aSourceField.DisplayName]);
+ end;
+ ftString:
+ case aDestField.Datatype of
+ ftString:
+ begin
+{Begin !!.11}
+ if frmMain.chkClearEmptyStrings.Checked then begin
+ TempStr := aSourceField.AsString;
+ if TempStr = '' then
+ aDestField.Clear
+ else
+ aDestField.AsString := TempStr;
+ end
+ else
+ aDestField.AsString := aSourceField.AsString;
+{End !!.11}
+{Begin !!.01}
+ if frmMain.chkOEMAnsi.Checked and
+ (Length(aDestField.AsString) > 0) then begin
+ SetLength(TempStr, Length(aDestField.AsString));
+ tempStr := aDestField.AsString;
+ OEMToCharBuff(PChar(tempStr), PChar(tempStr), Length(aDestField.AsString));
+ aDestField.AsString := tempStr;
+ end;
+{End !!.01}
+ end;
+ else
+ DatabaseErrorFmt(SInvalidFieldKind, [aDestField.DisplayName,
+ aSourceField.DisplayName]);
+ end;
+ ftAutoInc,
+ ftSmallint,
+ ftInteger,
+ ftWord:
+ case aDestField.Datatype of
+ ftSmallInt,
+ ftInteger,
+ ftAutoInc,
+ ftWord:
+ begin
+ aDestField.AsInteger := aSourceField.AsInteger;
+ if (aDestField.Datatype = ftAutoInc) and
+ (aDestField.AsInteger > MaxAutoInc) then
+ MaxAutoInc := aDestField.AsInteger;
+ end;
+ else
+ DatabaseErrorFmt(SInvalidFieldKind, [aDestField.DisplayName,
+ aSourceField.DisplayName]);
+ end;
+ ftBCD,
+ ftFloat,
+ ftCurrency:
+ case aDestField.Datatype of
+ ftFloat,
+ ftCurrency:
+ aDestField.AsFloat := aSourceField.AsFloat;
+ else
+ DatabaseErrorFmt(SInvalidFieldKind, [aDestField.DisplayName,
+ aSourceField.DisplayName]);
+ end;
+ ftDate:
+ case aDestField.Datatype of
+ ftDate,
+ ftDateTime:
+ aDestField.AsDateTime := aSourceField.AsDateTime;
+ else
+ DatabaseErrorFmt(SInvalidFieldKind, [aDestField.DisplayName,
+ aSourceField.DisplayName]);
+ end;
+ ftTime:
+ case aDestField.Datatype of
+ ftTime,
+ ftDateTime:
+ aDestField.AsDateTime := aSourceField.AsDateTime;
+ else
+ DatabaseErrorFmt(SInvalidFieldKind, [aDestField.DisplayName,
+ aSourceField.DisplayName]);
+ end;
+ ftDateTime:
+ case aDestField.Datatype of
+ ftDate,
+ ftTime,
+ ftDateTime:
+ aDestField.AsDateTime := aSourceField.AsDateTime;
+ else
+ DatabaseErrorFmt(SInvalidFieldKind, [aDestField.DisplayName,
+ aSourceField.DisplayName]);
+ end;
+ ftBytes,
+ ftVarBytes:
+ begin
+ GetMem(Buffer, aDestField.DataSize);
+ try
+ case aDestField.Datatype of
+ ftBytes,
+ ftVarBytes:
+ if aSourceField.GetData(Buffer) then
+ aDestField.SetData(Buffer)
+ else
+ aDestField.SetData(nil);
+ ftFmtMemo,
+ ftParadoxOle,
+ ftDBaseOle,
+ ftTypedBinary,
+ ftMemo,
+ ftGraphic,
+ ftBlob:
+ if not aSourceField.GetData(Buffer) then
+ aDestField.SetData(nil)
+ else begin
+ Stream := TMemoryStream.Create;
+ try
+ Stream.Write(Buffer^, aSourceField.DataSize);
+ TBLOBField(aDestField).LoadFromStream(Stream);
+ finally
+ Stream.Free;
+ end;
+ end;
+ else
+ DatabaseErrorFmt(SInvalidFieldKind, [aDestField.DisplayName,
+ aSourceField.DisplayName]);
+ end;
+ finally
+ FreeMem(Buffer, aDestField.DataSize);
+ end;
+ end;
+ ftFmtMemo,
+ ftParadoxOle,
+ ftDBaseOle,
+ ftTypedBinary,
+ ftMemo,
+ ftGraphic,
+ ftBlob:
+ begin
+ case aDestField.Datatype of
+ ftFmtMemo,
+ ftParadoxOle,
+ ftDBaseOle,
+ ftTypedBinary,
+ ftMemo,
+ ftGraphic,
+ ftBlob:
+ begin
+ Stream := TMemoryStream.Create;
+ try
+ TBLOBField(aSourceField).SaveToStream(Stream);
+ TBLOBField(aDestField).LoadFromStream(Stream);
+ finally
+ Stream.Free;
+ end;
+ end;
+ else
+ DatabaseErrorFmt(SInvalidFieldKind, [aDestField.DisplayName,
+ aSourceField.DisplayName]);
+ end;
+ end;
+ ftUnknown:
+ DatabaseErrorFmt(SInvalidFieldKind, [aDestField.DisplayName,
+ aSourceField.DisplayName]);
+ end;
+ end;
+
+begin
+ Result := False;
+ with dlgImportProgress do begin
+ Terminated := False;
+ ShowProgress(aSourceTable.TableName, aDestTable.TableName);
+ try
+
+ { If we only have one insert per transaction, then let the server
+ do implicit transactions; it'll be faster }
+ if aBlockInserts = 0 then aBlockInserts := 1;
+ DoExplicitTrans := (aBlockInserts > 1);
+
+ aSourceTable.Open;
+ try
+ TotalRecs := aSourceTable.RecordCount;
+ aNumTransferred := 0;
+
+ aDestTable.Open;
+ if (DoExplicitTrans) then {!!.05}
+ DoExplicitTrans := (not aDestTable.Dictionary.HasBLOBFields);{!!.05}
+ try
+ MaxAutoInc := 0;
+ InTransaction := False;
+ try
+ while not aSourceTable.EOF do begin
+// UpdateProgress(aNumTransferred + 1, TotalRecs); {Deleted !!.01}
+
+ { Blocks inserts within a transaction }
+ if DoExplicitTrans and not InTransaction then begin
+ frmMain.dbDest.StartTransaction;
+ InTransaction := True;
+ end;
+
+ aDestTable.Insert;
+
+ { Copy fields one at a time }
+ for FieldNo := 0 to aSourceTable.FieldCount - 1 do begin
+
+ { Do only selected fields }
+ DoThisOne := not Assigned(aSourceFields);
+ if not DoThisOne then begin
+ DoThisOne := aSourceFields.IndexOf(ANSIUppercase(aSourceTable.Fields[FieldNo].FieldName)) <> -1;
+ end;
+
+ if DoThisOne then begin
+
+ { Fields might be in order, avoid expensive FieldByName }
+ if (FieldNo < aDestTable.FieldCount) and
+ (FFCmpShStrUC(aSourceTable.Fields[FieldNo].FieldName,
+ aDestTable.Fields[FieldNo].FieldName,
+ 255) = 0) then
+ DestFieldNo := FieldNo
+ else begin
+ try
+ DestFieldNo := aDestTable.FieldByName(aSourceTable.Fields[FieldNo].FieldName).FieldNo - 1;
+ except
+ DestFieldNo := -1;
+ end;
+ end;
+
+ if DestFieldNo <> -1 then
+ try
+{Begin !!.11}
+// aDestTable.Fields[DestFieldNo].Assign(aSourceTable.Fields[FieldNo]);
+{Begin !!.01}
+// if frmMain.chkOEMAnsi.Checked and
+// (aDestTable.Fields[DestFieldNo].Datatype = ftString) and
+// (Length(aDestTable.Fields[DestFieldNo].AsString) > 0) then begin
+// SetLength(TempStr, Length(aDestTable.Fields[DestFieldNo].AsString));
+// tempStr := aDestTable.Fields[DestFieldNo].AsString;
+// OEMToCharBuff(PChar(tempStr), PChar(tempStr), Length(aDestTable.Fields[DestFieldNo].AsString));
+// aDestTable.Fields[DestFieldNo].AsString := tempStr;
+// end;
+{End !!.01}
+ CopyField(aDestTable.Fields[DestFieldNo], aSourceTable.Fields[FieldNo]);
+{End !!.11}
+ if (aDestTable.Fields[DestFieldNo].Datatype = ftAutoInc) and
+ (aDestTable.Fields[DestFieldNo].AsInteger > MaxAutoInc) then
+ MaxAutoInc := aDestTable.Fields[DestFieldNo].AsInteger;
+ except
+ on E:EDatabaseError do begin
+ CopyField(aDestTable.Fields[DestFieldNo], aSourceTable.Fields[FieldNo]);
+ end;
+ else
+ raise;
+ end;
+ end;
+ end;
+
+ aDestTable.Post;
+ Inc(aNumTransferred); { Increment after successfully posting }
+
+ { See if it's time to commit the transaction }
+{Begin !!.01}
+ if InTransaction then begin
+ if ((aNumTransferred mod aBlockInserts) = 0) then begin
+ aDestTable.Database.Commit;
+ UpdateProgress(aNumTransferred, TotalRecs);
+ InTransaction := False;
+ end
+ end
+ else
+ UpdateProgress(aNumTransferred + 1, TotalRecs);
+{End !!.01}
+
+ { Check for user termination }
+ if Terminated then begin
+ if InTransaction then
+ aDestTable.Database.Rollback;
+ Exit;
+ end;
+
+ aSourceTable.Next;
+ end;
+
+ {update the maximum autoinc value for the dest table}
+ aDestTable.SetTableAutoIncValue(MaxAutoInc);
+ { Residual inserts need to be posted? }
+ if InTransaction then begin {!!.01}
+ aDestTable.Database.Commit;
+ UpdateProgress(aNumTransferred + 1, TotalRecs); {!!.01}
+ end; {!!.01}
+ except
+ if InTransaction then
+ aDestTable.Database.Rollback;
+ raise;
+ end;
+ finally
+ aDestTable.Close;
+ end;
+ finally
+ aSourceTable.Close;
+ end;
+ finally
+ Hide;
+ end;
+ Result := not Terminated;
+ end;
+end;
+
+procedure TdlgImportProgress.ShowProgress(aImportFilename, aTableName : string);
+begin
+ edtImportFilename.Text := aImportFilename;
+ edtTablename.Text := aTableName;
+ lblProgress.Hide;
+ guaProgress.Progress := 0;
+ inherited Show;
+ Application.ProcessMessages;
+end;
+
+procedure TdlgImportProgress.UpdateProgress(aNumRead, aTotalRecs: LongInt);
+var
+ Dividend : LongInt;
+ Divisor : LongInt;
+resourcestring
+ SProgressStatus = 'Processing record %d of %d';
+begin
+ with lblProgress do begin
+ Caption := Format(SProgressStatus, [aNumRead, aTotalRecs]);
+ Show;
+ Application.ProcessMessages;
+ end;
+
+ { Calculate % completed }
+ if (aNumRead >= $1000000) then begin
+ Dividend := (aNumRead shr 7) * 100;
+ Divisor := aTotalRecs shr 7;
+ end
+ else begin
+ Dividend := aNumRead * 100;
+ Divisor := aTotalRecs;
+ end;
+
+ if Divisor <> 0 then
+ guaProgress.Progress := Dividend div Divisor;
+end;
+
+procedure TdlgImportProgress.btnCancelClick(Sender: TObject);
+resourcestring
+ SAbortMsg = 'Abort transferring data?';
+begin
+ Terminated := MessageDlg(SAbortMsg, mtConfirmation, [mbYes, mbNo], 0) = mrYes;
+end;
+
+end.
diff --git a/components/flashfiler/sourcelaz/bde2ff/fmmain.dfm b/components/flashfiler/sourcelaz/bde2ff/fmmain.dfm
new file mode 100644
index 000000000..e3f5f03f8
Binary files /dev/null and b/components/flashfiler/sourcelaz/bde2ff/fmmain.dfm differ
diff --git a/components/flashfiler/sourcelaz/bde2ff/fmmain.pas b/components/flashfiler/sourcelaz/bde2ff/fmmain.pas
new file mode 100644
index 000000000..494ff6f8d
--- /dev/null
+++ b/components/flashfiler/sourcelaz/bde2ff/fmmain.pas
@@ -0,0 +1,830 @@
+{*********************************************************}
+{* Main file *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+{Rewritten !!.11}
+
+unit fmmain;
+
+interface
+
+uses
+ Windows,
+ SysUtils,
+ Classes,
+ Graphics,
+ Controls,
+ Forms,
+ Dialogs,
+ DB,
+ DBTables,
+ StdCtrls,
+ ExtCtrls,
+ Buttons,
+ Menus,
+ ffclimex,
+ ffllbase,
+ fflldict,
+ ffllprot,
+ ffclintf,
+ dgimpdo,
+ ffdb,
+ ffdbbase,
+ ComCtrls;
+
+type
+ TfrmMain = class(TForm)
+ tblSource: TTable;
+ btnTransfer: TBitBtn;
+ btnExit: TBitBtn;
+ imgCheck: TImage;
+ btnHelp: TBitBtn;
+ mnuMain: TMainMenu;
+ mnuOperations: TMenuItem;
+ mnuHelp: TMenuItem;
+ mnuHelpContents: TMenuItem;
+ mnuAbout: TMenuItem;
+ tblDest: TffTable;
+ dbDest: TffDatabase;
+ mnuExit: TMenuItem;
+ N1: TMenuItem;
+ mnuTransferActiveTable: TMenuItem;
+ pgTransfer: TPageControl;
+ tabSource: TTabSheet;
+ tabOptions: TTabSheet;
+ Label1: TLabel;
+ Label2: TLabel;
+ Label4: TLabel;
+ lstBDETables: TListBox;
+ lstBDEFields: TListBox;
+ tabTarget: TTabSheet;
+ Label3: TLabel;
+ Label5: TLabel;
+ edtFFTableName: TEdit;
+ lstFFTables: TListBox;
+ cmbBDEAliases: TComboBox;
+ cmbFFAliases: TComboBox;
+ grpStringHandling: TGroupBox;
+ chkClearEmptyStrings: TCheckBox;
+ chkEmptyStrings: TCheckBox;
+ chkOEMAnsi: TCheckBox;
+ chkUseANSIFields: TCheckBox;
+ chkUseZeroTerminatedStrings: TCheckBox;
+ grpMisc: TGroupBox;
+ chkSchemaOnly: TCheckBox;
+ chkUseSysToolsDates: TCheckBox;
+ chkUseSysToolsTimes: TCheckBox;
+ grpExistingData: TRadioGroup;
+ procedure btnTransferClick(Sender: TObject);
+ procedure FormCreate(Sender: TObject);
+ procedure btnExitClick(Sender: TObject);
+ procedure lstBDEFieldsDrawItem(Control: TWinControl; Index: Integer;
+ Rect: TRect; State: TOwnerDrawState);
+ procedure lstBDEFieldsDblClick(Sender: TObject);
+ procedure btnHelpClick(Sender: TObject);
+ procedure edtBDEAliasNameChange(Sender: TObject);
+ procedure edtBDEAliasNameExit(Sender: TObject);
+ procedure edtBDEAliasNameKeyPress(Sender: TObject; var Key: Char);
+ procedure edtBDETableNameChange(Sender: TObject);
+ procedure edtBDETableNameExit(Sender: TObject);
+ procedure edtBDETableNameKeyPress(Sender: TObject; var Key: Char);
+ procedure edtFFTableNameChange(Sender: TObject);
+ procedure edtFFTableNameExit(Sender: TObject);
+ procedure edtFFTableNameKeyPress(Sender: TObject; var Key: Char);
+ procedure lstFFTablesDblClick(Sender: TObject);
+ procedure mnuAboutClick(Sender: TObject);
+ procedure cmbBDEAliasesChange(Sender: TObject);
+ procedure lstBDETablesClick(Sender: TObject);
+ procedure FormShow(Sender: TObject);
+ procedure cmbFFAliasesChange(Sender: TObject);
+ procedure chkClearEmptyStringsClick(Sender: TObject);
+ procedure chkEmptyStringsClick(Sender: TObject);
+ protected
+ BDETablesLoaded: Boolean;
+ BDETableInited: Boolean;
+ FFTablesLoaded: Boolean;
+ FFTableInited: Boolean;
+ Aborted: Boolean;
+ IsSQLServer: Boolean;
+ procedure ConvertTable(const BDETableName, FFTableName : TffTableName);
+ procedure CreateNewTable(const BDETableName, FFTableName: TffTableName);
+ procedure InitBDETable;
+ function InitCommsEngine: Boolean;
+ procedure InitFFTable;
+ procedure LoadAliases;
+ procedure LoadBDETables;
+ procedure LoadFFTables;
+ end;
+
+var
+ frmMain: TfrmMain;
+
+implementation
+
+{$R *.DFM}
+
+uses
+ FFAbout;
+
+const
+ FG_UNSELECTED = 0;
+ FG_SELECTED = 1;
+ FG_UNAVAILABLE = 2;
+
+ csSQLServer = 'SQL Server';
+
+procedure TfrmMain.CreateNewTable(const BDETableName, FFTableName: TffTableName);
+var
+ Dict: TffDataDictionary;
+ I: Integer;
+ IdxName: string;
+ FFType: TffFieldType;
+ FFSize: Longint;
+ FFDecPl: Integer;
+ FldArray: TffFieldList;
+ IHelpers: TffFieldIHList;
+ NFields: Integer;
+
+ procedure ParseFieldNames(aFieldNames: TffShStr);
+ var
+ DoFieldNums: Boolean;
+ FieldEntry: TffShStr;
+ FieldNo: Integer;
+ begin
+ DoFieldNums := False; {!!.03 - Start}
+ if aFieldNames[1] in ['0'..'9'] then begin
+ FieldNo := 2;
+ while True do begin
+ if aFieldNames[FieldNo] = ';' then begin
+ DoFieldNums := True;
+ Break;
+ end
+ else if aFieldNames[FieldNo] in ['0'..'9'] then
+ Inc(FieldNo)
+ else begin
+ DoFieldNums := False;
+ Break;
+ end;
+ end;
+ end; {!!.03 - End}
+ NFields := 0;
+ repeat
+ FFShStrSplit(aFieldNames, ';', FieldEntry, aFieldNames);
+ if DoFieldNums then
+ FldArray[NFields] := StrToInt(FieldEntry) - 1
+ else begin
+ FieldNo := Dict.GetFieldFromName(FieldEntry);
+ if FieldNo = -1 then
+ raise Exception.Create('Invalid field in index');
+ FldArray[NFields] := FieldNo;
+ end;
+ Inc(NFields);
+ if aFieldNames <> '' then {!!.02}
+ IHelpers[NFields] := ''; {!!.02}
+ until aFieldNames = '';
+ end;
+
+ function DetermineBlockSize: LongInt;
+ var
+ FFType: TffFieldType;
+ FFSize: Longint;
+ FFDecPl: Integer;
+ BlockSize: LongInt;
+ i: Integer;
+ begin
+ { Build size from source table structure }
+ with tblSource do begin
+ {Management size}
+ BlockSize := 32 + 1;
+ { Get the fields }
+ FieldDefs.Update;
+
+ if lstBDETables.SelCount > 1 then begin
+ for I := 0 to Pred(FieldDefs.Count) do begin
+ with FieldDefs[I] do begin
+ ConvertBDEDataType(DataType, Size, FFType, FFSize, FFDecPl);
+ BlockSize := BlockSize + FFSize;
+ end; { if }
+ end;
+ end
+ else begin
+ { Calculate using only the fields selected in the fields list. }
+ with lstBDEFields do
+ for I := 0 to Items.Count - 1 do
+ if (LongInt(Items.Objects[I]) and FG_SELECTED) <> 0 then
+ with FieldDefs[I] do begin
+ ConvertBDEDataType(DataType, Size, FFType, FFSize, FFDecPl);
+ BlockSize := BlockSize + FFSize;
+ end; { if }
+ end; { if }
+ end; { with }
+ { Determine the first multiple of 4096 larger then BlockSize }
+ Result := (BlockSize div 4096 + 1) * 4096;
+ end;
+
+begin
+ Dict := TffDataDictionary.Create(DetermineBlockSize);
+ try
+
+ { Initialize the FieldArray }
+ for I := 0 to pred(ffcl_MaxIndexFlds) do begin
+ FldArray[I] := 0;
+ IHelpers[I] := '';
+ end;
+
+ { Build dictionary from source table structure }
+ with tblSource do begin
+ { Point to the source table. }
+ TableName := BDETableName;
+ ReadOnly := True;
+
+ { Get the fields }
+ FieldDefs.Update;
+
+ { Obtain the field definitions. }
+ if lstBDETables.SelCount > 1 then begin
+ { Convert all fields. }
+ for I := 0 to Pred(FieldDefs.Count) do begin
+ with FieldDefs[I] do begin
+ ConvertBDEDataType(DataType, Size, FFType, FFSize, FFDecPl);
+ Dict.AddField(Name,
+ '', { description }
+ FFType,
+ FFSize,
+ FFDecPl,
+ Required,
+ nil);
+ end; { with }
+ end; { for }
+ end
+ else begin
+ { Convert only the fields selected in the fields list. }
+ with lstBDEFields do
+ for I := 0 to Items.Count - 1 do
+ if (LongInt(Items.Objects[I]) and FG_SELECTED) <> 0 then
+ with FieldDefs[I] do begin
+ ConvertBDEDataType(DataType, Size, FFType, FFSize, FFDecPl);
+ Dict.AddField(Name,
+ '', { description }
+ FFType,
+ FFSize,
+ FFDecPl,
+ Required,
+ nil);
+ end; { with }
+ end; { if }
+
+ { Obtain the indices. }
+ IndexDefs.Update;
+ for I := 0 to IndexDefs.Count - 1 do begin
+ with IndexDefs[I] do {!!.10}
+ if not (ixExpression in Options) then begin {!!.10}
+ ParseFieldNames(Fields);
+ IdxName := Name;
+ if IdxName = '' then
+ if ixPrimary in Options then
+ IdxName := 'FF$PRIMARY'
+ else
+ IdxName := 'FF$INDEX' + IntToStr(I + 1);
+ Dict.AddIndex(IdxName, { index name }
+ '', { description }
+ 0, { file no }
+ NFields, { field count }
+ FldArray, { field list }
+ IHelpers, { index helper list }
+ not (ixUnique in Options), { allow dups }
+ not (ixDescending in Options), { ascending }
+ ixCaseInsensitive in Options); { case insensitive }
+ end; { if } {!!.10}
+ end;
+
+ { Create the actual table }
+ Check(dbDest.CreateTable(False, FFTableName, Dict))
+ end;
+ finally
+ Dict.Free;
+ end;
+end;
+
+procedure TfrmMain.InitBDETable;
+var
+ I: Integer;
+ Flag: LongInt;
+begin
+ if lstBDETables.SelCount > 1 then begin
+ lstBDEFields.Clear;
+ lstBDEFields.Items.Add('');
+ lstBDEFields.Enabled := False;
+ lstBDEFields.Color := clBtnFace;
+ end
+ else begin
+ lstBDEFields.Color := clWindow;
+ lstBDEFields.Enabled := True;
+ with tblSource do begin
+ DatabaseName := cmbBDEAliases.Text;
+ { Find the selected table. }
+ for I := 0 to Pred(lstBDETables.Items.Count) do
+ if lstBDETables.Selected[I] then begin
+ TableName := lstBDETables.Items[I];
+ break;
+ end; { if }
+ FieldDefs.Update;
+ lstBDEFields.Clear;
+ for I := 0 to FieldDefs.Count - 1 do begin
+ Flag := FG_SELECTED;
+ lstBDEFields.Items.AddObject(FieldDefs[I].Name, Pointer(Flag));
+ end; { for }
+ end; { with }
+ end;
+ BDETableInited := True;
+end;
+
+function TfrmMain.InitCommsEngine: Boolean;
+begin
+ cmbBDEAliases.Clear;
+ cmbFFAliases.Clear;
+ Result := True;
+ try
+ FFDB.Session.Open;
+ LoadAliases;
+ except
+ on E: Exception do begin
+ MessageDlg(E.Message, mtError, [mbOk], 0);
+ Result := False;
+ end;
+ end;
+end;
+
+procedure TfrmMain.InitFFTable;
+begin
+ with tblDest do begin
+ if Active then Close;
+ TableName := edtFFTableName.Text;
+ end;
+ FFTableInited := True;
+end;
+
+procedure TfrmMain.LoadAliases;
+var
+ Aliases: TStringList;
+ I: Integer;
+begin
+ { Segregate the FlashFiler and native BDE aliases }
+ Aliases := TStringList.Create;
+ try
+ DBTables.Session.GetAliasNames(Aliases);
+ with Aliases do begin
+ for I := 0 to Count - 1 do
+ cmbBDEAliases.Items.Add(Strings[I]);
+ cmbBDEAliases.ItemIndex := 0;
+ LoadBDETables;
+ end;
+ Aliases.Clear;
+ FFDB.Session.GetAliasNames(Aliases);
+ with Aliases do begin
+ for I := 0 to Count - 1 do
+ cmbFFAliases.Items.Add(Strings[I]);
+ cmbFFAliases.ItemIndex := -1;
+ end;
+ finally
+ Aliases.Free;
+ end;
+end;
+
+procedure TfrmMain.LoadBDETables;
+begin
+ if cmbBDEAliases.Text <> '' then begin
+ try {!!.13}
+ DBTables.Session.GetTableNames(cmbBDEAliases.Text, '', True, False,
+ lstBDETables.Items);
+ except {!!.13}
+ { ignore all bde exceptions } {!!.13}
+ end; {!!.13}
+ BDETablesLoaded := True;
+ end;
+end;
+
+procedure TfrmMain.LoadFFTables;
+var
+ FFTables: TStringList;
+ I: Integer;
+ TableName: string;
+begin
+ if cmbFFAliases.Text <> '' then begin
+ dbDest.Connected := False;
+ dbDest.AliasName := cmbFFAliases.Text;
+ dbDest.DatabaseName := 'FF2_' + cmbFFAliases.Text;
+ dbDest.Connected := True;
+
+ lstFFTables.Clear;
+ FFTables := TStringList.Create;
+ try
+ FFDB.Session.GetTableNames(cmbFFAliases.Text, '', True, False, FFTables);
+ with FFTables do
+ for I := 0 to Count - 1 do begin
+ TableName := Copy(Strings[I], 1, Pos('.', Strings[I]) - 1);
+ lstFFTables.Items.Add(TableName);
+ end;
+ finally
+ FFTables.Free;
+ end;
+ FFTablesLoaded := True;
+ end;
+end;
+
+procedure TfrmMain.FormCreate(Sender: TObject);
+begin
+ IsSQLServer := False;
+ if FileExists(ExtractFilePath(ParamStr(0)) + 'BDE2FF.HLP') then
+ Application.HelpFile := ExtractFilePath(ParamStr(0)) + 'BDE2FF.HLP'
+ else
+ Application.HelpFile := ExtractFilePath(ParamStr(0)) + '..\DOC\BDE2FF.HLP';
+ InitCommsEngine;
+end;
+
+procedure TfrmMain.lstBDEFieldsDblClick(Sender: TObject);
+begin
+ with (Sender as TListBox) do
+ if (LongInt(Items.Objects[ItemIndex]) and FG_UNAVAILABLE) <> 0 then
+ MessageBeep(0)
+ else begin
+ Items.Objects[ItemIndex] := Pointer((LongInt(Items.Objects[ItemIndex]) + 1) mod 2);
+ Invalidate;
+ end;
+end;
+
+procedure TfrmMain.lstBDEFieldsDrawItem(Control: TWinControl; Index: Integer;
+ Rect: TRect; State: TOwnerDrawState);
+begin
+ with (Control as TListBox) do begin
+ with Canvas do begin
+ Font.Assign(Font);
+
+ if (odSelected) in State then begin
+ Font.Color := clWindowText;
+ Brush.Color := (Control as TListBox).Color;
+ end;
+
+ FillRect(Rect);
+
+ if (LongInt(Items.Objects[Index]) and FG_SELECTED) <> 0 then
+ with imgCheck.Picture.Bitmap do
+ BrushCopy(Bounds(Rect.Left + 2, Rect.Top + 4, Width, Height),
+ imgCheck.Picture.Bitmap, Bounds(0, 0, Width, Height),
+ TransparentColor);
+
+ if (LongInt(Items.Objects[Index]) and FG_UNAVAILABLE) <> 0 then
+ Font.Color := clRed;
+
+ { Draw the item text }
+ TextOut(Rect.Left + imgCheck.Picture.Bitmap.Width + 4, Rect.Top, Items[Index]);
+ end;
+ end;
+end;
+
+procedure TfrmMain.ConvertTable(const BDETableName, FFTableName : TffTableName);
+var
+ I: Integer;
+ Msg,
+ BDETableNameFinal : string;
+ NewTable,
+ MultTables : Boolean;
+ NumTransferred: LongInt;
+ SourceFields: TStringList;
+ ZMsg: array[0..255] of Char;
+begin
+
+ MultTables := (lstBDETables.SelCount > 1);
+
+ { Init vars }
+ Aborted := False;
+ NewTable := False;
+ NumTransferred := 0;
+ tblDest.TableName := FFTableName;
+
+
+ { If the user selected a table in a SQL Server database then strip the
+ leading database name from the table name. }
+ BDETableNameFinal := BDETableName;
+ if IsSQLServer and (Pos('.', BDETableNameFinal) > 0) then begin
+ I := 1;
+ while BDETableNameFinal[I] <> '.' do
+ inc(I);
+ Delete(BDETableNameFinal, 1, I);
+ end; { if }
+ tblSource.TableName := BDETableNameFinal;
+ tblSource.FieldDefs.Update;
+
+ try
+ { Check for schema only import }
+ if chkSchemaOnly.Checked then begin
+ if (not tblDest.Exists) then begin
+ Msg := 'Create new table ' + FFTableName + ' from schema only?';
+ NewTable := True;
+ end
+ else
+ Msg := 'Replace table ' + FFTableName + ' from schema only?';
+
+ { If multiple tables being converted or user approves, recreate the
+ table. }
+ if MultTables or
+ (MessageDlg(Msg, mtConfirmation, [mbYes, mbNo], 0) = mrYes) then begin
+ if not NewTable then
+ tblDest.DeleteTable;
+ CreateNewTable(BDETableName, FFTableName);
+ end
+ else
+ Aborted := True;
+ end
+ else begin
+ { Data only or data & schema. }
+ case grpExistingData.ItemIndex of
+ 0 : { Keep existing structure & data }
+ if not tblDest.Exists then begin
+ if MultTables or
+ (MessageDlg('Create new table ' + edtFFTableName.Text + '?',
+ mtConfirmation, [mbYes, mbNo], 0) = mrYes) then begin
+ CreateNewTable(BDETableName, FFTableName);
+ NewTable := True;
+ end; { if }
+ end;
+ 1 : { Keep existing structure, replace data }
+ if tblDest.Exists then
+ { Empty the table. }
+ tblDest.EmptyTable
+ else begin
+ CreateNewTable(BDETableName, FFTableName);
+ NewTable := True;
+ end;
+ 2 : { Replace structure & data }
+ if MultTables or
+ (not tblDest.Exists) or
+ (MessageDlg('Replace table ' + edtFFTableName.Text + '?',
+ mtConfirmation, [mbYes, mbNo], 0) = mrYes) then begin
+ if tblDest.Exists then
+ tblDest.DeleteTable;
+ CreateNewTable(BDETableName, FFTableName);
+ NewTable := True;
+ end
+ else
+ Exit;
+ end; { case }
+
+ { Begin the transfer process }
+ Self.Enabled := False;
+ try
+ try
+ SourceFields := TStringList.Create;
+ try
+
+ { If more than one table has been selected then convert all
+ fields otherwise convert only those selected in the fields list. }
+ if (lstBDETables.SelCount > 1) then begin
+ for I := 0 to Pred(tblSource.FieldDefs.Count) do
+ SourceFields.Add(ANSIUppercase(tblSource.fieldDefs[I].Name));
+ end
+ else begin
+ with lstBDEFields do
+ for I := 0 to Items.Count - 1 do
+ if (LongInt(Items.Objects[I]) and FG_SELECTED) <> 0 then
+ SourceFields.Add(ANSIUppercase(Items[I]));
+ end; { if }
+
+ Aborted := not DoImport(tblSource, SourceFields,
+ tblDest, 100, NumTransferred);
+ finally
+ SourceFields.Free;
+ end;
+ except
+ Aborted := True;
+ raise;
+ end;
+
+ finally
+ { If we've aborted and we created a new table, get rid of it }
+ if Aborted then begin
+ if NewTable then begin
+ tblDest.DeleteTable;
+ NewTable := False;
+ end;
+ end;
+
+ Application.ProcessMessages;
+ Self.Enabled := True;
+ end;
+ end;
+ finally
+ end;
+
+ if not Aborted then begin
+ if NewTable then LoadFFTables;
+ MessageBeep(0);
+ StrPCopy(ZMsg, 'Transfer Completed. ' + #13#13 +
+ Format('%d records transferred.', [NumTransferred]));
+ if lstBDETables.SelCount = 1 then
+ Application.MessageBox(ZMsg, 'BDE Transfer to FlashFiler',
+ MB_ICONINFORMATION or MB_OK);
+ end;
+ if not Aborted then ModalResult := mrOK;
+end;
+
+procedure TfrmMain.btnTransferClick(Sender: TObject);
+var
+ FFTableName : TffTableName;
+ Inx : Integer;
+begin
+
+ { Check Requirements }
+ if (lstBDETables.SelCount = 0) then begin
+ ShowMessage('Please select one or more BDE tables for conversion.');
+ Exit;
+ end;
+
+ if cmbFFAliases.ItemIndex = -1 then begin
+ ShowMessage('Please specify a target FlashFiler database.');
+ Exit;
+ end;
+
+ if (lstBDETables.SelCount = 1) and (edtFFTableName.Text = '') then begin
+ ShowMessage('Please specify a destination FlashFiler table.');
+ Exit;
+ end;
+
+ if tblDest.Active then
+ tblDest.Close;
+
+ tblDest.DatabaseName := 'FF2_' + cmbFFAliases.Text;
+
+ for Inx := 0 to Pred(lstBDETables.Items.Count) do begin
+ if lstBDETables.Selected[Inx] then begin
+ if lstBDETables.SelCount > 1 then
+ FFTableName := ChangeFileExt(lstBDETables.Items[Inx], '')
+ else
+ FFTableName := edtFFTableName.Text;
+ ConvertTable(lstBDETables.Items[Inx], FFTableName)
+ end;
+ end; { for }
+
+end;
+
+procedure TfrmMain.btnExitClick(Sender: TObject);
+begin
+ Close;
+end;
+
+procedure TfrmMain.btnHelpClick(Sender: TObject);
+begin
+ Application.HelpCommand(HELP_CONTENTS, 0);
+end;
+
+procedure TfrmMain.edtBDEAliasNameChange(Sender: TObject);
+begin
+ BDETablesLoaded := False;
+ BDETableInited := False;
+end;
+
+procedure TfrmMain.edtBDEAliasNameExit(Sender: TObject);
+begin
+ if not BDETablesLoaded then LoadBDETables;
+end;
+
+procedure TfrmMain.edtBDEAliasNameKeyPress(Sender: TObject; var Key: Char);
+begin
+ if (Key = #13) then begin
+ if not BDETablesLoaded then
+ LoadBDETables;
+ Key := #0;
+ end;
+end;
+
+procedure TfrmMain.edtBDETableNameChange(Sender: TObject);
+begin
+ BDETableInited := False;
+end;
+
+procedure TfrmMain.edtBDETableNameExit(Sender: TObject);
+begin
+ if not BDETableInited then InitBDETable;
+end;
+
+procedure TfrmMain.edtBDETableNameKeyPress(Sender: TObject; var Key: Char);
+begin
+ if (Key = #13) then begin
+ if not BDETableInited then InitBDETable;
+ Key := #0;
+ end;
+end;
+
+procedure TfrmMain.edtFFTableNameChange(Sender: TObject);
+begin
+ FFTableInited := False;
+end;
+
+procedure TfrmMain.edtFFTableNameExit(Sender: TObject);
+begin
+ if not FFTableInited then InitFFTable;
+end;
+
+procedure TfrmMain.edtFFTableNameKeyPress(Sender: TObject; var Key: Char);
+begin
+ if (Key = #13) then begin
+ if not FFTableInited then InitFFTable;
+ Key := #0;
+ end;
+end;
+
+procedure TfrmMain.lstFFTablesDblClick(Sender: TObject);
+begin
+ with lstFFTables do
+ if ItemIndex <> -1 then begin
+ edtFFTableName.Text := Items[ItemIndex];
+ InitFFTable;
+ end;
+end;
+
+procedure TfrmMain.mnuAboutClick(Sender: TObject);
+var
+ AboutBox: TFFAboutBox;
+begin
+ AboutBox := TFFAboutBox.Create(Application);
+ try
+ AboutBox.Caption := 'About FlashFiler Utility';
+ AboutBox.ProgramName.Caption := 'FlashFiler BDE2FF Converter';
+ AboutBox.ShowModal;
+ finally
+ AboutBox.Free;
+ end;
+end;
+
+procedure TfrmMain.cmbBDEAliasesChange(Sender: TObject);
+begin
+ IsSQLServer := (DBTables.Session.GetAliasDriverName(cmbBDEAliases.Text) = csSQLServer);
+ LoadBDETables;
+end;
+
+procedure TfrmMain.lstBDETablesClick(Sender: TObject);
+var
+ Inx : Integer;
+begin
+ InitBDETable;
+ InitFFTable;
+ if (lstBDETables.SelCount = 1) then begin
+ for Inx := 0 to Pred(lstBDETables.Items.Count) do
+ if lstBDETables.Selected[Inx] then begin
+ edtFFTableName.Text := ChangeFileExt(lstBDETables.Items[Inx], '');
+ Break;
+ end;
+ end;
+end;
+
+procedure TfrmMain.FormShow(Sender: TObject);
+begin
+ pgTransfer.ActivePage := tabSource;
+end;
+
+procedure TfrmMain.cmbFFAliasesChange(Sender: TObject);
+begin
+ FFTablesLoaded := False;
+ FFTableInited := False;
+ LoadFFTables;
+end;
+
+procedure TfrmMain.chkClearEmptyStringsClick(Sender: TObject);
+begin
+ chkEmptyStrings.Checked := not chkClearEmptyStrings.Checked;
+end;
+
+procedure TfrmMain.chkEmptyStringsClick(Sender: TObject);
+begin
+ chkClearEmptyStrings.Checked := not chkEmptyStrings.Checked;
+end;
+
+end.
+
diff --git a/components/flashfiler/sourcelaz/beta/beta.dpr b/components/flashfiler/sourcelaz/beta/beta.dpr
new file mode 100644
index 000000000..062380d91
--- /dev/null
+++ b/components/flashfiler/sourcelaz/beta/beta.dpr
@@ -0,0 +1,48 @@
+{*********************************************************}
+{* Project source file *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+
+program BETA;
+
+uses
+ {$IFDEF USETeDEBUG}
+ TeDebug,
+ {$ENDIF}
+ Forms,
+ fmMain in 'fmMain.pas' {frmMain};
+
+{$R *.RES}
+
+begin
+ Application.Initialize;
+ Application.HelpFile := 'BETA.HLP';
+ Application.CreateForm(TfrmMain, frmMain);
+ Application.Run;
+end.
+
diff --git a/components/flashfiler/sourcelaz/beta/beta.rc b/components/flashfiler/sourcelaz/beta/beta.rc
new file mode 100644
index 000000000..94c2adfbc
--- /dev/null
+++ b/components/flashfiler/sourcelaz/beta/beta.rc
@@ -0,0 +1,61 @@
+/*********************************************************
+ * Main program icon resource *
+ *********************************************************/
+
+/* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** */
+
+
+#define VERSIONINFO_1 1
+
+VERSIONINFO_1 VERSIONINFO
+FILEVERSION 2, 1, 3, 0
+PRODUCTVERSION 2, 1, 3, 0
+FILEOS VOS__WINDOWS32
+FILETYPE VFT_APP
+{
+ BLOCK "StringFileInfo"
+ {
+ BLOCK "040904E4"
+ {
+ VALUE "CompanyName", "TurboPower Software Company\000\000"
+ VALUE "FileDescription", "FlashFiler BETA\000"
+ VALUE "FileVersion", "2.1.3.0\000"
+ VALUE "InternalName", "BETA\000"
+ VALUE "LegalCopyright", "Copyright (c) TurboPower Software Co. 1996-2002\000\000"
+ VALUE "OriginalFilename", "BETA.EXE\000"
+ VALUE "ProductName", "FlashFiler (Delphi Edition)\000"
+ VALUE "ProductVersion", "2.1.3.0\000"
+ }
+
+ }
+
+ BLOCK "VarFileInfo"
+ {
+ VALUE "Translation", 0x409, 1252
+ }
+
+}
+
diff --git a/components/flashfiler/sourcelaz/beta/beta.res b/components/flashfiler/sourcelaz/beta/beta.res
new file mode 100644
index 000000000..ba81f04fe
Binary files /dev/null and b/components/flashfiler/sourcelaz/beta/beta.res differ
diff --git a/components/flashfiler/sourcelaz/beta/fmmain.dfm b/components/flashfiler/sourcelaz/beta/fmmain.dfm
new file mode 100644
index 000000000..6771b7231
Binary files /dev/null and b/components/flashfiler/sourcelaz/beta/fmmain.dfm differ
diff --git a/components/flashfiler/sourcelaz/beta/fmmain.pas b/components/flashfiler/sourcelaz/beta/fmmain.pas
new file mode 100644
index 000000000..89418c4d6
--- /dev/null
+++ b/components/flashfiler/sourcelaz/beta/fmmain.pas
@@ -0,0 +1,434 @@
+{*********************************************************}
+{* Main file *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+
+unit fmMain;
+
+interface
+
+uses
+ Windows,
+ BDE,
+ Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
+ DB, DBTables, StdCtrls, FileCtrl, ExtCtrls, Buttons, IniFiles;
+
+type
+ TfrmMain = class(TForm)
+ tblSource: TTable;
+ tblDest: TTable;
+ batBatchMove: TBatchMove;
+ grpSource: TGroupBox;
+ Label1: TLabel;
+ Label2: TLabel;
+ lstAliases: TListBox;
+ edtAliasName: TEdit;
+ edtTableName: TEdit;
+ lstTables: TListBox;
+ grpDestination: TGroupBox;
+ Label3: TLabel;
+ Label6: TLabel;
+ lblDirectory: TLabel;
+ edtOutputFilename: TEdit;
+ lstFields: TListBox;
+ Label4: TLabel;
+ lstFiles: TFileListBox;
+ lstDirectories: TDirectoryListBox;
+ cboFilter: TFilterComboBox;
+ cboDrives: TDriveComboBox;
+ Label5: TLabel;
+ Label7: TLabel;
+ imgCheck: TImage;
+ chkSchemaOnly: TCheckBox;
+ Button1: TButton;
+ btnClose: TButton;
+ btnHelp: TButton;
+ procedure btnExportClick(Sender: TObject);
+ procedure FormCreate(Sender: TObject);
+ procedure lstAliasesDblClick(Sender: TObject);
+ procedure lstTablesDblClick(Sender: TObject);
+ procedure lstFieldsDrawItem(Control: TWinControl; Index: Integer;
+ Rect: TRect; State: TOwnerDrawState);
+ procedure lstFieldsDblClick(Sender: TObject);
+ procedure btnHelpClick(Sender: TObject);
+ procedure edtAliasNameChange(Sender: TObject);
+ procedure edtAliasNameExit(Sender: TObject);
+ procedure edtAliasNameKeyPress(Sender: TObject; var Key: Char);
+ procedure edtTableNameChange(Sender: TObject);
+ procedure edtTableNameExit(Sender: TObject);
+ procedure edtTableNameKeyPress(Sender: TObject; var Key: Char);
+ procedure chkSchemaOnlyClick(Sender: TObject);
+ procedure btnCloseClick(Sender: TObject);
+ private
+ public
+ TablesLoaded: Boolean;
+ TableInited: Boolean;
+ procedure AdjustSchemaFile(aTable: TTable; aFilename: TFilename);
+ procedure InitTable;
+ procedure LoadTables;
+ end;
+
+var
+ frmMain: TfrmMain;
+
+implementation
+
+{$R *.DFM}
+
+const
+ FG_UNSELECTED = 0;
+ FG_SELECTED = 1;
+ FG_UNAVAILABLE = 2;
+
+ BlobTypes = [ftBlob, ftMemo, ftGraphic, ftFmtMemo, ftParadoxOle, ftDBaseOle, ftTypedBinary];
+
+procedure TfrmMain.AdjustSchemaFile(aTable: TTable; aFilename: TFilename);
+var
+ F: Integer;
+ FldNo: Integer;
+ I: Integer;
+ SchemaFile: TIniFile;
+ SectionName: string;
+ Ext: string[10];
+ Entry: string;
+ DateFormat: FMTDate;
+ TimeFormat: FMTTime;
+ EntryID,
+ Mask,
+ DateMask,
+ TimeMask: string[40];
+begin
+
+ { Extract the date format from the BDE }
+ DbiGetDateFormat(DateFormat);
+ with DateFormat do begin
+ case iDateMode of
+ 0: DateMask := 'M' + szDateSeparator + 'D' + szDateSeparator + 'Y';
+ 1: DateMask := 'D' + szDateSeparator + 'M' + szDateSeparator + 'Y';
+ 2: DateMask := 'Y' + szDateSeparator + 'M' + szDateSeparator + 'D';
+ end;
+ end;
+
+ { Extract the time format from the BDE }
+ DbiGetTimeFormat(TimeFormat);
+ with TimeFormat do begin
+ TimeMask := 'h' + cTimeSeparator + 'm';
+ if bSeconds then
+ TimeMask := TimeMask + cTimeSeparator + 's';
+ if bTwelveHour then
+ TimeMask := TimeMask + ' t';
+ end;
+
+ SchemaFile := TIniFile.Create(aFilename);
+ try
+ SectionName := ExtractFileName(aFilename);
+ Ext := ExtractFileExt(SectionName);
+ if Ext <> '' then
+ Delete(SectionName, Pos(Ext, SectionName), Length(Ext));
+
+ { Change the filetype }
+ SchemaFile.WriteString(SectionName, 'FILETYPE', 'ASCII');
+
+ { Loop through fields, making adjustments }
+ FldNo := 0;
+ with aTable.FieldDefs do
+ for F := 0 to Count - 1 do
+ if (LongInt(lstFields.Items.Objects[F]) and FG_SELECTED) <> 0 then
+ with Items[F] do begin
+ Inc(FldNo);
+
+ { Get the current schema file entry for this field }
+ EntryID := 'Field' + IntToStr(FldNo);
+ Entry := SchemaFile.ReadString(SectionName, EntryID, '');
+
+ { Add masks for date/time fields }
+ case Datatype of
+ ftDate, ftTime, ftDateTime:
+ begin
+ Mask := '';
+ case DataType of
+ ftDate: Mask := DateMask;
+ ftTime: Mask := TimeMask;
+ ftDateTime: Mask := DateMask + ' ' + TimeMask;
+ end;
+
+ if Mask <> '' then begin
+
+ { Append a local mask to it }
+ if Pos(',', Mask) <> 0 then Mask := '"' + Mask + '"';
+ Entry := Entry + ',' + Mask;
+
+ { Rewrite the modified entry back to the schema file }
+ SchemaFile.WriteString(SectionName, EntryID, Entry);
+ end;
+ end;
+
+ ftInteger:
+ begin
+ I := Pos('LONG INTEGER', ANSIUppercase(Entry));
+ System.Delete(Entry, I, 12);
+ System.Insert('LongInt', Entry, I);
+ SchemaFile.WriteString(SectionName, EntryID, Entry);
+ end;
+
+ ftAutoInc:
+ begin
+ I := Pos('LONG INTEGER', ANSIUppercase(Entry));
+ System.Delete(Entry, I, 12);
+ System.Insert('AutoInc', Entry, I);
+ SchemaFile.WriteString(SectionName, EntryID, Entry);
+ end;
+ end;
+ end;
+ finally
+ SchemaFile.Free;
+ end;
+end;
+
+procedure TfrmMain.InitTable;
+var
+ I: Integer;
+ Flag: LongInt;
+begin
+ with tblSource do begin
+ DatabaseName := edtAliasName.Text;
+ TableName := edtTableName.Text;
+ FieldDefs.Update;
+ lstFields.Clear;
+ for I := 0 to FieldDefs.Count - 1 do begin
+ Flag := FG_SELECTED;
+ if (FieldDefs[I].DataType in BlobTypes) then
+ Flag := FG_UNAVAILABLE;
+ lstFields.Items.AddObject(FieldDefs[I].Name, Pointer(Flag));
+ end;
+ end;
+ edtOutputFilename.Text := ChangeFileExt(ExtractFileName(edtTableName.Text), '.ASC');
+ TableInited := True;
+end;
+
+procedure TfrmMain.LoadTables;
+begin
+ if edtAliasName.Text <> '' then begin
+ Session.GetTableNames(edtAliasName.Text, '', True, False, lstTables.Items);
+ TablesLoaded:= True;
+ end;
+end;
+
+procedure TfrmMain.FormCreate(Sender: TObject);
+begin
+ Application.HelpFile := ExtractFilePath(ParamStr(0)) + 'BETA.HLP';
+ Session.GetAliasNames(lstAliases.Items);
+end;
+
+procedure TfrmMain.lstAliasesDblClick(Sender: TObject);
+begin
+ edtTableName.Text := '';
+ with lstAliases do
+ if ItemIndex <> -1 then begin
+ edtAliasName.Text := Items[ItemIndex];
+ LoadTables;
+ end;
+end;
+
+procedure TfrmMain.lstTablesDblClick(Sender: TObject);
+begin
+ with lstTables do
+ if ItemIndex <> - 1 then begin
+ edtTableName.Text := Items[ItemIndex];
+ InitTable;
+ end;
+end;
+
+procedure TfrmMain.lstFieldsDblClick(Sender: TObject);
+begin
+ with lstFields do
+ if (LongInt(Items.Objects[ItemIndex]) and FG_UNAVAILABLE) <> 0 then
+ MessageBeep(0)
+ else begin
+ Items.Objects[ItemIndex] := Pointer((LongInt(Items.Objects[ItemIndex]) + 1) mod 2);
+ Invalidate;
+ end;
+end;
+
+procedure TfrmMain.lstFieldsDrawItem(Control: TWinControl; Index: Integer;
+ Rect: TRect; State: TOwnerDrawState);
+begin
+ with (Control as TListBox) do begin
+ with Canvas do begin
+ Font.Assign(Font);
+
+ if (odSelected) in State then begin
+ Font.Color := clWindowText;
+ Brush.Color := (Control as TListBox).Color;
+ end;
+
+ FillRect(Rect);
+
+ if (LongInt(Items.Objects[Index]) and FG_SELECTED) <> 0 then
+ with imgCheck.Picture.Bitmap do
+ BrushCopy(Bounds(Rect.Left + 2, Rect.Top + 4, Width, Height),
+ imgCheck.Picture.Bitmap, Bounds(0, 0, Width, Height),
+ TransparentColor);
+
+ if (LongInt(Items.Objects[Index]) and FG_UNAVAILABLE) <> 0 then
+ Font.Color := clRed;
+
+ { Draw the item text }
+ TextOut(Rect.Left + imgCheck.Picture.Bitmap.Width + 4, Rect.Top, Items[Index]);
+ end;
+ end;
+end;
+
+procedure TfrmMain.btnExportClick(Sender: TObject);
+var
+ I: Integer;
+ ValidFields: TStringList;
+ SchemaFilePath: string;
+ DestPath: string;
+ DestName: string;
+ CheckFile: string;
+begin
+ if (Pos('*', edtOutputFilename.Text) <> 0) or
+ (Pos('?', edtOutputFilename.Text) <> 0) or
+ (edtOutputFilename.Text = '') then
+ raise Exception.Create('Invalid output filename');
+
+ DestPath := ExtractFilePath(edtOutputFilename.Text);
+ if DestPath = '' then
+ DestPath := lblDirectory.Caption;
+ if Copy(DestPath, Length(DestPath), 1) <> '\' then
+ DestPath := DestPath + '\';
+
+ if chkSchemaOnly.Checked then begin
+ batBatchMove.RecordCount := 1;
+ DestName := ChangeFileExt(ExtractFilename(edtOutputFilename.Text), '.$$$');
+ end
+ else
+ DestName := ExtractFilename(edtOutputFilename.Text);
+
+ CheckFile := DestPath + ExtractFilename(edtOutputFilename.Text);
+ if FileExists(CheckFile) then
+ if MessageDlg('Replace ' + CheckFile + '?', mtWarning, [mbYes, mbNo], 0) <> mrYes then
+ Exit;
+
+ batBatchMove.Mappings.Clear;
+
+ with tblSource do begin
+ DatabaseName := edtAliasName.Text;
+ TableName := edtTableName.Text;
+
+ { Build the BatchMove mapping for the valid fields }
+ ValidFields := TStringList.Create;
+ try
+ with lstFields do
+ for I := 0 to Items.Count - 1 do
+ if (LongInt(Items.Objects[I]) and FG_SELECTED) <> 0 then
+ ValidFields.Add(Items[I]);
+ batBatchMove.Mappings.Assign(ValidFields);
+ finally
+ ValidFields.Free;
+ end;
+ end;
+
+ with tblDest do begin
+ DatabaseName := DestPath;
+ TableName := DestName;
+ SchemaFilePath := ChangeFileExt(DatabaseName + TableName, '.SCH');
+ DeleteFile(SchemaFilePath);
+ end;
+
+ Screen.Cursor := crHourglass;
+ try
+ batBatchMove.Execute;
+ AdjustSchemaFile(tblSource, SchemaFilePath);
+ finally
+ Screen.Cursor := crDefault;
+ if chkSchemaOnly.Checked then
+ DeleteFile(ChangeFileExt(SchemaFilePath, '.$$$'));
+ end;
+
+ MessageBeep(0);
+ Application.MessageBox('Export Completed', 'BDE Export', MB_OK);
+end;
+
+procedure TfrmMain.btnHelpClick(Sender: TObject);
+begin
+ Application.HelpCommand(HELP_FINDER, 0);
+end;
+
+procedure TfrmMain.edtAliasNameChange(Sender: TObject);
+begin
+ TablesLoaded := False;
+ TableInited := False;
+end;
+
+procedure TfrmMain.edtAliasNameExit(Sender: TObject);
+begin
+ if not TablesLoaded then LoadTables;
+end;
+
+procedure TfrmMain.edtAliasNameKeyPress(Sender: TObject; var Key: Char);
+begin
+ if (Key = #13) then begin
+ if not TablesLoaded then
+ LoadTables;
+ Key := #0;
+ end;
+end;
+
+procedure TfrmMain.edtTableNameChange(Sender: TObject);
+begin
+ TableInited := False;
+end;
+
+procedure TfrmMain.edtTableNameExit(Sender: TObject);
+begin
+ if not TableInited then InitTable;
+end;
+
+procedure TfrmMain.edtTableNameKeyPress(Sender: TObject; var Key: Char);
+begin
+ if (Key = #13) then begin
+ if not TableInited then InitTable;
+ Key := #0;
+ end;
+end;
+
+procedure TfrmMain.chkSchemaOnlyClick(Sender: TObject);
+begin
+ if chkSchemaOnly.Checked and (edtOutputFilename.Text <> '') then
+ edtOutputFilename.Text := ChangeFileExt(edtOutputFilename.Text, '.SCH');
+end;
+
+procedure TfrmMain.btnCloseClick(Sender: TObject);
+begin
+ Close;
+end;
+
+end.
+
diff --git a/components/flashfiler/sourcelaz/cocobase.pas b/components/flashfiler/sourcelaz/cocobase.pas
new file mode 100644
index 000000000..8ea38995d
--- /dev/null
+++ b/components/flashfiler/sourcelaz/cocobase.pas
@@ -0,0 +1,898 @@
+unit CocoBase;
+{Base components for Coco/R for Delphi grammars for use with version 1.1}
+
+interface
+
+{$I FFDEFINE.INC}
+
+uses
+ Classes, SysUtils;
+
+const
+ setsize = 16; { sets are stored in 16 bits }
+
+ { Standard Error Types }
+ etSyntax = 0;
+ etSymantic = 1;
+
+ chCR = #13;
+ chLF = #10;
+ chEOL = chCR + chLF; { End of line characters for Microsoft Windows }
+ chLineSeparator = chCR;
+
+type
+ ECocoBookmark = class(Exception);
+ TCocoStatusType = (cstInvalid, cstBeginParse, cstEndParse, cstLineNum, cstString);
+ TCocoError = class(TObject)
+ private
+ FErrorCode : integer;
+ FCol : integer;
+ FLine : integer;
+ FData : string;
+ FErrorType : integer;
+ public
+ property ErrorType : integer read FErrorType write FErrorType;
+ property ErrorCode : integer read FErrorCode write FErrorCode;
+ property Line : integer read FLine write FLine;
+ property Col : integer read FCol write FCol;
+ property Data : string read FData write FData;
+ end; {TCocoError}
+
+ TCommentItem = class(TObject)
+ private
+ fComment: string;
+ fLine: integer;
+ fColumn: integer;
+ public
+ property Comment : string read fComment write fComment;
+ property Line : integer read fLine write fLine;
+ property Column : integer read fColumn write fColumn;
+ end; {TCommentItem}
+
+ TCommentList = class(TObject)
+ private
+ fList : TList;
+
+ function FixComment(const S : string) : string;
+ function GetComments(Idx: integer): string;
+ procedure SetComments(Idx: integer; const Value: string);
+ function GetCount: integer;
+ function GetText: string;
+ function GetColumn(Idx: integer): integer;
+ function GetLine(Idx: integer): integer;
+ procedure SetColumn(Idx: integer; const Value: integer);
+ procedure SetLine(Idx: integer; const Value: integer);
+ public
+ constructor Create;
+ destructor Destroy; override;
+
+ procedure Clear;
+ procedure Add(const S : string; const aLine : integer; const aColumn : integer);
+ property Comments[Idx : integer] : string read GetComments write SetComments; default;
+ property Line[Idx : integer] : integer read GetLine write SetLine;
+ property Column[Idx : integer] : integer read GetColumn write SetColumn;
+ property Count : integer read GetCount;
+ property Text : string read GetText;
+ end; {TCommentList}
+
+ TSymbolPosition = class(TObject)
+ private
+ fLine : integer;
+ fCol : integer;
+ fLen : integer;
+ fPos : integer;
+ public
+ procedure Clear;
+ procedure Assign(Source : TSymbolPosition);
+
+ property Line : integer read fLine write fLine; {line of symbol}
+ property Col : integer read fCol write fCol; {column of symbol}
+ property Len : integer read fLen write fLen; {length of symbol}
+ property Pos : integer read fPos write fPos; {file position of symbol}
+ end; {TSymbolPosition}
+
+ TGenListType = (glNever, glAlways, glOnError);
+
+ TBitSet = set of 0..15;
+ PStartTable = ^TStartTable;
+ TStartTable = array[0..255] of integer;
+ TCharSet = set of char;
+
+ TAfterGenListEvent = procedure(Sender : TObject;
+ var PrintErrorCount : boolean) of object;
+ TAfterGrammarGetEvent = procedure(Sender : TObject;
+ var CurrentInputSymbol : integer) of object;
+ TCommentEvent = procedure(Sender : TObject; CommentList : TCommentList) of object;
+ TCustomErrorEvent = function(Sender : TObject; const ErrorCode : longint;
+ const Data : string) : string of object;
+ TErrorEvent = procedure(Sender : TObject; Error : TCocoError) of object;
+ TErrorProc = procedure(ErrorCode : integer; Symbol : TSymbolPosition;
+ Data : string; ErrorType : integer) of object;
+ TFailureEvent = procedure(Sender : TObject; NumErrors : integer) of object;
+ TGetCH = function(pos : longint) : char of object;
+ TStatusUpdateProc = procedure(Sender : TObject;
+ const StatusType : TCocoStatusType;
+ const Status : string;
+ const LineNum : integer) of object;
+
+ TCocoRScanner = class(TObject)
+ private
+ FbpCurrToken : integer; {position of current token)}
+ FBufferPosition : integer; {current position in buf }
+ FContextLen : integer; {length of appendix (CONTEXT phrase)}
+ FCurrentCh : TGetCH; {procedural variable to get current input character}
+ FCurrentSymbol : TSymbolPosition; {position of the current symbol in the source stream}
+ FCurrInputCh : char; {current input character}
+ FCurrLine : integer; {current input line (may be higher than line)}
+ FLastInputCh : char; {the last input character that was read}
+ FNextSymbol : TSymbolPosition; {position of the next symbol in the source stream}
+ FNumEOLInComment : integer; {number of _EOLs in a comment}
+ FOnStatusUpdate : TStatusUpdateProc;
+ FScannerError : TErrorProc;
+ FSourceLen : integer; {source file size}
+ FSrcStream : TMemoryStream; {source memory stream}
+ FStartOfLine : integer;
+
+ function GetNStr(Symbol : TSymbolPosition; ChProc : TGetCh) : string;
+ function ExtractBookmarkChar(var aBookmark: string): char;
+ protected
+ FStartState : TStartTable; {start state for every character}
+
+ function Bookmark : string; virtual;
+ procedure GotoBookmark(aBookmark : string); virtual;
+
+ function CapChAt(pos : longint) : char;
+ procedure Get(var sym : integer); virtual; abstract;
+ procedure NextCh; virtual; abstract;
+
+ function GetStartState : PStartTable;
+ procedure SetStartState(aStartTable : PStartTable);
+
+ property bpCurrToken : integer read fbpCurrToken write fbpCurrToken;
+ property BufferPosition : integer read fBufferPosition write fBufferPosition;
+ property ContextLen : integer read fContextLen write fContextLen;
+ property CurrentCh : TGetCh read fCurrentCh write fCurrentCh;
+ property CurrentSymbol : TSymbolPosition read fCurrentSymbol write fCurrentSymbol;
+ property CurrInputCh : char read fCurrInputCh write fCurrInputCh;
+ property CurrLine : integer read fCurrLine write fCurrLine;
+ property LastInputCh : char read fLastInputCh write fLastInputCh;
+ property NextSymbol : TSymbolPosition read fNextSymbol write fNextSymbol;
+ property NumEOLInComment : integer read fNumEOLInComment write fNumEOLInComment;
+ property OnStatusUpdate : TStatusUpdateProc read FOnStatusUpdate write FOnStatusUpdate;
+ property ScannerError : TErrorProc read FScannerError write FScannerError;
+ property SourceLen : integer read fSourceLen write fSourceLen;
+ property SrcStream : TMemoryStream read fSrcStream write fSrcStream;
+ property StartOfLine : integer read fStartOfLine write fStartOfLine;
+ property StartState : PStartTable read GetStartState write SetStartState;
+ public
+ constructor Create;
+ destructor Destroy; override;
+
+ function CharAt(pos : longint) : char;
+ function GetName(Symbol : TSymbolPosition) : string; // Retrieves name of symbol of length len at position pos in source file
+ function GetString(Symbol : TSymbolPosition) : string; // Retrieves exact string of max length len from position pos in source file
+ procedure _Reset;
+ end; {TCocoRScanner}
+
+ TCocoRGrammar = class(TComponent)
+ private
+ fAfterGet: TAfterGrammarGetEvent;
+ FAfterGenList : TAfterGenListEvent;
+ FAfterParse : TNotifyEvent;
+ FBeforeGenList : TNotifyEvent;
+ FBeforeParse : TNotifyEvent;
+ fClearSourceStream : boolean;
+ FErrDist : integer; // number of symbols recognized since last error
+ FErrorList : TList;
+ fGenListWhen : TGenListType;
+ FListStream : TMemoryStream;
+ FOnCustomError : TCustomErrorEvent;
+ FOnError : TErrorEvent;
+ FOnFailure : TFailureEvent;
+ FOnStatusUpdate : TStatusUpdateProc;
+ FOnSuccess : TNotifyEvent;
+ FScanner : TCocoRScanner;
+ FSourceFileName : string;
+ fExtra : integer;
+
+ function GetSourceStream : TMemoryStream;
+ function GetSuccessful : boolean;
+ procedure SetOnStatusUpdate(const Value : TStatusUpdateProc);
+ procedure SetSourceStream(const Value : TMemoryStream);
+ function GetLineCount: integer;
+ function GetCharacterCount: integer;
+ protected
+ fCurrentInputSymbol : integer; // current input symbol
+
+ function Bookmark : string; virtual;
+ procedure GotoBookmark(aBookmark : string); virtual;
+
+ procedure ClearErrors;
+ function ErrorStr(const ErrorCode : integer; const Data : string) : string; virtual; abstract;
+ procedure Expect(n : integer);
+ procedure GenerateListing;
+ procedure Get; virtual; abstract;
+ procedure PrintErr(line : string; ErrorCode, col : integer;
+ Data : string);
+ procedure StoreError(nr : integer; Symbol : TSymbolPosition;
+ Data : string; ErrorType : integer);
+
+ procedure DoAfterParse; virtual;
+ procedure DoBeforeParse; virtual;
+
+ property ClearSourceStream : boolean read fClearSourceStream write fClearSourceStream default true;
+ property CurrentInputSymbol : integer read fCurrentInputSymbol write fCurrentInputSymbol;
+ property ErrDist : integer read fErrDist write fErrDist; // number of symbols recognized since last error
+ property ErrorList : TList read FErrorList write FErrorList;
+ property Extra : integer read fExtra write fExtra;
+ property GenListWhen : TGenListType read fGenListWhen write fGenListWhen default glOnError;
+ property ListStream : TMemoryStream read FListStream write FListStream;
+ property SourceFileName : string read FSourceFileName write FSourceFileName;
+ property SourceStream : TMemoryStream read GetSourceStream write SetSourceStream;
+ property Successful : boolean read GetSuccessful;
+
+ {Events}
+ property AfterParse : TNotifyEvent read fAfterParse write fAfterParse;
+ property AfterGenList : TAfterGenListEvent read fAfterGenList write fAfterGenList;
+ property AfterGet : TAfterGrammarGetEvent read fAfterGet write fAfterGet;
+ property BeforeGenList : TNotifyEvent read fBeforeGenList write fBeforeGenList;
+ property BeforeParse : TNotifyEvent read fBeforeParse write fBeforeParse;
+ property OnCustomError : TCustomErrorEvent read FOnCustomError write FOnCustomError;
+ property OnError : TErrorEvent read fOnError write fOnError;
+ property OnFailure : TFailureEvent read FOnFailure write FOnFailure;
+ property OnStatusUpdate : TStatusUpdateProc read FOnStatusUpdate write SetOnStatusUpdate;
+ property OnSuccess : TNotifyEvent read FOnSuccess write FOnSuccess;
+ public
+ constructor Create(AOwner : TComponent); override;
+ destructor Destroy; override;
+
+ procedure GetLine(var pos : Integer; var line : string;
+ var eof : boolean);
+ function LexName : string;
+ function LexString : string;
+ function LookAheadName : string;
+ function LookAheadString : string;
+ procedure _StreamLine(s : string);
+ procedure _StreamLn(s : string);
+ procedure SemError(const errNo : integer; const Data : string);
+ procedure SynError(const errNo : integer);
+
+ property Scanner : TCocoRScanner read fScanner write fScanner;
+ property LineCount : integer read GetLineCount;
+ property CharacterCount : integer read GetCharacterCount;
+ end; {TCocoRGrammar}
+
+const
+ _EF = #0;
+ _TAB = #09;
+ _CR = #13;
+ _LF = #10;
+ _EL = _CR;
+ _EOF = #26; {MS-DOS eof}
+ LineEnds : TCharSet = [_CR, _LF, _EF];
+ { not only for errors but also for not finished states of scanner analysis }
+ minErrDist = 2; { minimal distance (good tokens) between two errors }
+
+function PadL(S : string; ch : char; L : integer) : string;
+function StrTok(
+ var Text : string;
+ const ch : char) : string;
+
+implementation
+
+const
+ INVALID_CHAR = 'Invalid Coco/R for Delphi bookmark character';
+ INVALID_INTEGER = 'Invalid Coco/R for Delphi bookmark integer';
+ BOOKMARK_STR_SEPARATOR = ' ';
+
+function PadL(S : string; ch : char; L : integer) : string;
+var
+ i : integer;
+begin
+ for i := 1 to L - (Length(s)) do
+ s := ch + s;
+ Result := s;
+end; {PadL}
+
+function StrTok(
+ var Text : string;
+ const ch : char) : string;
+var
+ apos : integer;
+begin
+ apos := Pos(ch, Text);
+ if (apos > 0) then
+ begin
+ Result := Copy(Text, 1, apos - 1);
+ Delete(Text, 1, apos);
+ end
+ else
+ begin
+ Result := Text;
+ Text := '';
+ end;
+end; {StrTok}
+
+{ TSymbolPosition }
+
+procedure TSymbolPosition.Assign(Source: TSymbolPosition);
+begin
+ fLine := Source.fLine;
+ fCol := Source.fCol;
+ fLen := Source.fLen;
+ fPos := Source.fPos;
+end; {Assign}
+
+procedure TSymbolPosition.Clear;
+begin
+ fLen := 0;
+ fPos := 0;
+ fLine := 0;
+ fCol := 0;
+end; { Clear }
+
+{ TCocoRScanner }
+
+function TCocoRScanner.Bookmark: string;
+begin
+ Result := IntToStr(bpCurrToken) + BOOKMARK_STR_SEPARATOR
+ + IntToStr(BufferPosition) + BOOKMARK_STR_SEPARATOR
+ + IntToStr(ContextLen) + BOOKMARK_STR_SEPARATOR
+ + IntToStr(CurrLine) + BOOKMARK_STR_SEPARATOR
+ + IntToStr(NumEOLInComment) + BOOKMARK_STR_SEPARATOR
+ + IntToStr(StartOfLine) + BOOKMARK_STR_SEPARATOR
+ + IntToStr(CurrentSymbol.Line) + BOOKMARK_STR_SEPARATOR
+ + IntToStr(CurrentSymbol.Col) + BOOKMARK_STR_SEPARATOR
+ + IntToStr(CurrentSymbol.Len) + BOOKMARK_STR_SEPARATOR
+ + IntToStr(CurrentSymbol.Pos) + BOOKMARK_STR_SEPARATOR
+ + IntToStr(NextSymbol.Line) + BOOKMARK_STR_SEPARATOR
+ + IntToStr(NextSymbol.Col) + BOOKMARK_STR_SEPARATOR
+ + IntToStr(NextSymbol.Len) + BOOKMARK_STR_SEPARATOR
+ + IntToStr(NextSymbol.Pos) + BOOKMARK_STR_SEPARATOR
+ + CurrInputCh
+ + LastInputCh
+end; {Bookmark}
+
+function TCocoRScanner.ExtractBookmarkChar(var aBookmark : string) : char;
+begin
+ if length(aBookmark) > 0 then
+ Result := aBookmark[1]
+ else
+ Raise ECocoBookmark.Create(INVALID_CHAR);
+end; {ExtractBookmarkChar}
+
+procedure TCocoRScanner.GotoBookmark(aBookmark: string);
+var
+ BookmarkToken : string;
+begin
+ try
+ BookmarkToken := StrTok(aBookmark, BOOKMARK_STR_SEPARATOR);
+ bpCurrToken := StrToInt(BookmarkToken);
+ BookmarkToken := StrTok(aBookmark, BOOKMARK_STR_SEPARATOR);
+ BufferPosition := StrToInt(BookmarkToken);
+ BookmarkToken := StrTok(aBookmark, BOOKMARK_STR_SEPARATOR);
+ ContextLen := StrToInt(BookmarkToken);
+ BookmarkToken := StrTok(aBookmark, BOOKMARK_STR_SEPARATOR);
+ CurrLine := StrToInt(BookmarkToken);
+ BookmarkToken := StrTok(aBookmark, BOOKMARK_STR_SEPARATOR);
+ NumEOLInComment := StrToInt(BookmarkToken);
+ BookmarkToken := StrTok(aBookmark, BOOKMARK_STR_SEPARATOR);
+ StartOfLine := StrToInt(BookmarkToken);
+ BookmarkToken := StrTok(aBookmark, BOOKMARK_STR_SEPARATOR);
+ CurrentSymbol.Line := StrToInt(BookmarkToken);
+ BookmarkToken := StrTok(aBookmark, BOOKMARK_STR_SEPARATOR);
+ CurrentSymbol.Col := StrToInt(BookmarkToken);
+ BookmarkToken := StrTok(aBookmark, BOOKMARK_STR_SEPARATOR);
+ CurrentSymbol.Len := StrToInt(BookmarkToken);
+ BookmarkToken := StrTok(aBookmark, BOOKMARK_STR_SEPARATOR);
+ CurrentSymbol.Pos := StrToInt(BookmarkToken);
+ BookmarkToken := StrTok(aBookmark, BOOKMARK_STR_SEPARATOR);
+ NextSymbol.Line := StrToInt(BookmarkToken);
+ BookmarkToken := StrTok(aBookmark, BOOKMARK_STR_SEPARATOR);
+ NextSymbol.Col := StrToInt(BookmarkToken);
+ BookmarkToken := StrTok(aBookmark, BOOKMARK_STR_SEPARATOR);
+ NextSymbol.Len := StrToInt(BookmarkToken);
+ BookmarkToken := StrTok(aBookmark, BOOKMARK_STR_SEPARATOR);
+ NextSymbol.Pos := StrToInt(BookmarkToken);
+ CurrInputCh := ExtractBookmarkChar(aBookmark);
+ LastInputCh := ExtractBookmarkChar(aBookmark);
+ except
+ on EConvertError do
+ Raise ECocoBookmark.Create(INVALID_INTEGER);
+ else
+ Raise;
+ end;
+end; {GotoBookmark}
+
+constructor TCocoRScanner.Create;
+begin
+ inherited;
+ fSrcStream := TMemoryStream.Create;
+ CurrentSymbol := TSymbolPosition.Create;
+ NextSymbol := TSymbolPosition.Create;
+end; {Create}
+
+destructor TCocoRScanner.Destroy;
+begin
+ fSrcStream.Free;
+ fSrcStream := NIL;
+ CurrentSymbol.Free;
+ CurrentSymbol := NIL;
+ NextSymbol.Free;
+ NextSymbol := NIL;
+ inherited;
+end; {Destroy}
+
+function TCocoRScanner.CapChAt(pos : longint) : char;
+begin
+ Result := UpCase(CharAt(pos));
+end; {CapCharAt}
+
+function TCocoRScanner.CharAt(pos : longint) : char;
+var
+ ch : char;
+begin
+ if pos >= SourceLen then
+ begin
+ Result := _EF;
+ exit;
+ end;
+ SrcStream.Seek(pos, soFromBeginning);
+ SrcStream.ReadBuffer(Ch, 1);
+ if ch <> _EOF then
+ Result := ch
+ else
+ Result := _EF
+end; {CharAt}
+
+function TCocoRScanner.GetNStr(Symbol : TSymbolPosition; ChProc : TGetCh) : string;
+var
+ i : integer;
+ p : longint;
+begin
+ SetLength(Result, Symbol.Len);
+ p := Symbol.Pos;
+ i := 1;
+ while i <= Symbol.Len do
+ begin
+ Result[i] := ChProc(p);
+ inc(i);
+ inc(p)
+ end;
+end; {GetNStr}
+
+function TCocoRScanner.GetName(Symbol : TSymbolPosition) : string;
+begin
+ Result := GetNStr(Symbol, CurrentCh);
+end; {GetName}
+
+function TCocoRScanner.GetStartState : PStartTable;
+begin
+ Result := @fStartState;
+end; {GetStartState}
+
+procedure TCocoRScanner.SetStartState(aStartTable : PStartTable);
+begin
+ fStartState := aStartTable^;
+end; {SetStartState}
+
+function TCocoRScanner.GetString(Symbol : TSymbolPosition) : string;
+begin
+ Result := GetNStr(Symbol, CharAt);
+end; {GetString}
+
+procedure TCocoRScanner._Reset;
+var
+ len : longint;
+begin
+ { Make sure that the stream has the _EF character at the end. }
+ CurrInputCh := _EF;
+ SrcStream.Seek(0, soFromEnd);
+ SrcStream.WriteBuffer(CurrInputCh, 1);
+ SrcStream.Seek(0, soFromBeginning);
+
+ LastInputCh := _EF;
+ len := SrcStream.Size;
+ SourceLen := len;
+ CurrLine := 1;
+ StartOfLine := -2;
+ BufferPosition := -1;
+ CurrentSymbol.Clear;
+ NextSymbol.Clear;
+ NumEOLInComment := 0;
+ ContextLen := 0;
+ NextCh;
+end; {_Reset}
+
+{ TCocoRGrammar }
+
+procedure TCocoRGrammar.ClearErrors;
+var
+ i : integer;
+begin
+ for i := 0 to fErrorList.Count - 1 do
+ TCocoError(fErrorList[i]).Free;
+ fErrorList.Clear;
+end; {ClearErrors}
+
+constructor TCocoRGrammar.Create(AOwner : TComponent);
+begin
+ inherited;
+ FGenListWhen := glOnError;
+ fClearSourceStream := true;
+ fListStream := TMemoryStream.Create;
+ fErrorList := TList.Create;
+end; {Create}
+
+destructor TCocoRGrammar.Destroy;
+begin
+ fListStream.Clear;
+ fListStream.Free;
+ ClearErrors;
+ fErrorList.Free;
+ inherited;
+end; {Destroy}
+
+procedure TCocoRGrammar.Expect(n : integer);
+begin
+ if CurrentInputSymbol = n then
+ Get
+ else
+ SynError(n);
+end; {Expect}
+
+procedure TCocoRGrammar.GenerateListing;
+ { Generate a source listing with error messages }
+var
+ i : integer;
+ eof : boolean;
+ lnr, errC : integer;
+ srcPos : longint;
+ line : string;
+ PrintErrorCount : boolean;
+begin
+ if Assigned(BeforeGenList) then
+ BeforeGenList(Self);
+ srcPos := 0;
+ GetLine(srcPos, line, eof);
+ lnr := 1;
+ errC := 0;
+ while not eof do
+ begin
+ _StreamLine(PadL(IntToStr(lnr), ' ', 5) + ' ' + line);
+ for i := 0 to ErrorList.Count - 1 do
+ begin
+ if TCocoError(ErrorList[i]).Line = lnr then
+ begin
+ PrintErr(line, TCocoError(ErrorList[i]).ErrorCode,
+ TCocoError(ErrorList[i]).Col,
+ TCocoError(ErrorList[i]).Data);
+ inc(errC);
+ end;
+ end;
+ GetLine(srcPos, line, eof);
+ inc(lnr);
+ end;
+ // Now take care of the last line.
+ for i := 0 to ErrorList.Count - 1 do
+ begin
+ if TCocoError(ErrorList[i]).Line = lnr then
+ begin
+ PrintErr(line, TCocoError(ErrorList[i]).ErrorCode,
+ TCocoError(ErrorList[i]).Col,
+ TCocoError(ErrorList[i]).Data);
+ inc(errC);
+ end;
+ end;
+ PrintErrorCount := true;
+ if Assigned(AfterGenList) then
+ AfterGenList(Self, PrintErrorCount);
+ if PrintErrorCount then
+ begin
+ _StreamLine('');
+ _StreamLn(PadL(IntToStr(errC), ' ', 5) + ' error');
+ if errC <> 1 then
+ _StreamLine('s');
+ end;
+end; {GenerateListing}
+
+procedure TCocoRGrammar.GetLine(var pos : longint;
+ var line : string;
+ var eof : boolean);
+ { Read a source line. Return empty line if eof }
+var
+ ch : char;
+ i : integer;
+begin
+ i := 1;
+ eof := false;
+ ch := Scanner.CharAt(pos);
+ inc(pos);
+ while not (ch in LineEnds) do
+ begin
+ SetLength(line, length(Line) + 1);
+ line[i] := ch;
+ inc(i);
+ ch := Scanner.CharAt(pos);
+ inc(pos);
+ end;
+ SetLength(line, i - 1);
+ eof := (i = 1) and (ch = _EF);
+ if ch = _CR then
+ begin { check for MsDos end of lines }
+ ch := Scanner.CharAt(pos);
+ if ch = _LF then
+ begin
+ inc(pos);
+ Extra := 0;
+ end;
+ end;
+end; {GetLine}
+
+function TCocoRGrammar.GetSourceStream : TMemoryStream;
+begin
+ Result := Scanner.SrcStream;
+end; {GetSourceStream}
+
+function TCocoRGrammar.GetSuccessful : boolean;
+begin
+ Result := ErrorList.Count = 0;
+end; {GetSuccessful}
+
+function TCocoRGrammar.LexName : string;
+begin
+ Result := Scanner.GetName(Scanner.CurrentSymbol)
+end; {LexName}
+
+function TCocoRGrammar.LexString : string;
+begin
+ Result := Scanner.GetString(Scanner.CurrentSymbol)
+end; {LexString}
+
+function TCocoRGrammar.LookAheadName : string;
+begin
+ Result := Scanner.GetName(Scanner.NextSymbol)
+end; {LookAheadName}
+
+function TCocoRGrammar.LookAheadString : string;
+begin
+ Result := Scanner.GetString(Scanner.NextSymbol)
+end; {LookAheadString}
+
+procedure TCocoRGrammar.PrintErr(line : string; ErrorCode : integer; col : integer; Data : string);
+ { Print an error message }
+
+ procedure DrawErrorPointer;
+ var
+ i : integer;
+ begin
+ _StreamLn('***** ');
+ i := 0;
+ while i < col + Extra - 2 do
+ begin
+ if ((length(Line) > 0) and (length(Line) < i)) and (line[i] = _TAB) then
+ _StreamLn(_TAB)
+ else
+ _StreamLn(' ');
+ inc(i)
+ end;
+ _StreamLn('^ ')
+ end; {DrawErrorPointer}
+
+begin {PrintErr}
+ DrawErrorPointer;
+ _StreamLn(ErrorStr(ErrorCode, Data));
+ _StreamLine('')
+end; {PrintErr}
+
+procedure TCocoRGrammar.SemError(const errNo : integer; const Data : string);
+begin
+ if errDist >= minErrDist then
+ Scanner.ScannerError(errNo, Scanner.CurrentSymbol, Data, etSymantic);
+ errDist := 0;
+end; {SemError}
+
+procedure TCocoRGrammar._StreamLn(s : string);
+begin
+ if length(s) > 0 then
+ ListStream.WriteBuffer(s[1], length(s));
+end; {_StreamLn}
+
+procedure TCocoRGrammar._StreamLine(s : string);
+begin
+ s := s + chEOL;
+ _StreamLn(s);
+end; {_StreamLine}
+
+procedure TCocoRGrammar.SynError(const errNo : integer);
+begin
+ if errDist >= minErrDist then
+ Scanner.ScannerError(errNo, Scanner.NextSymbol, '', etSyntax);
+ errDist := 0;
+end; {SynError}
+
+procedure TCocoRGrammar.SetOnStatusUpdate(const Value : TStatusUpdateProc);
+begin
+ FOnStatusUpdate := Value;
+ Scanner.OnStatusUpdate := Value;
+end; {SetOnStatusUpdate}
+
+procedure TCocoRGrammar.SetSourceStream(const Value : TMemoryStream);
+begin
+ Scanner.SrcStream := Value;
+end; {SetSourceStream}
+
+procedure TCocoRGrammar.StoreError(nr : integer; Symbol : TSymbolPosition;
+ Data : string; ErrorType : integer);
+ { Store an error message for later printing }
+var
+ Error : TCocoError;
+begin
+ Error := TCocoError.Create;
+ Error.ErrorCode := nr;
+ if Assigned(Symbol) then
+ begin
+ Error.Line := Symbol.Line;
+ Error.Col := Symbol.Col;
+ end
+ else
+ begin
+ Error.Line := 0;
+ Error.Col := 0;
+ end;
+ Error.Data := Data;
+ Error.ErrorType := ErrorType;
+ ErrorList.Add(Error);
+ if Assigned(OnError) then
+ OnError(self, Error);
+end; {StoreError}
+
+function TCocoRGrammar.GetLineCount: integer;
+begin
+ Result := Scanner.CurrLine;
+end; {GetLineCount}
+
+function TCocoRGrammar.GetCharacterCount: integer;
+begin
+ Result := Scanner.BufferPosition;
+end; {GetCharacterCount}
+
+procedure TCocoRGrammar.DoBeforeParse;
+begin
+ if Assigned(fBeforeParse) then
+ fBeforeParse(Self);
+ if Assigned(fOnStatusUpdate) then
+ fOnStatusUpdate(Self, cstBeginParse, '', -1);
+end; {DoBeforeParse}
+
+procedure TCocoRGrammar.DoAfterParse;
+begin
+ if Assigned(fOnStatusUpdate) then
+ fOnStatusUpdate(Self, cstEndParse, '', -1);
+ if Assigned(fAfterParse) then
+ fAfterParse(Self);
+end; {DoAfterParse}
+
+function TCocoRGrammar.Bookmark: string;
+begin
+ Result :=
+ IntToStr(fCurrentInputSymbol) + BOOKMARK_STR_SEPARATOR
+ + Scanner.Bookmark;
+end; {Bookmark}
+
+procedure TCocoRGrammar.GotoBookmark(aBookmark: string);
+var
+ BookmarkToken : string;
+begin
+ try
+ BookmarkToken := StrTok(aBookmark, BOOKMARK_STR_SEPARATOR);
+ fCurrentInputSymbol := StrToInt(BookmarkToken);
+ Scanner.GotoBookmark(aBookmark);
+ except
+ on EConvertError do
+ Raise ECocoBookmark.Create(INVALID_INTEGER);
+ else
+ Raise;
+ end;
+end; {GotoBookmark}
+
+{ TCommentList }
+
+procedure TCommentList.Add(const S : string; const aLine : integer;
+ const aColumn : integer);
+var
+ CommentItem : TCommentItem;
+begin
+ CommentItem := TCommentItem.Create;
+ try
+ CommentItem.Comment := FixComment(S);
+ CommentItem.Line := aLine;
+ CommentItem.Column := aColumn;
+ fList.Add(CommentItem);
+ except
+ CommentItem.Free;
+ end;
+end; {Add}
+
+procedure TCommentList.Clear;
+var
+ i : integer;
+begin
+ for i := 0 to fList.Count - 1 do
+ TCommentItem(fList[i]).Free;
+ fList.Clear;
+end; {Clear}
+
+constructor TCommentList.Create;
+begin
+ fList := TList.Create;
+end; {Create}
+
+destructor TCommentList.Destroy;
+begin
+ Clear;
+ if Assigned(fList) then
+ begin
+ fList.Free;
+ fList := NIL;
+ end;
+ inherited;
+end; {Destroy}
+
+function TCommentList.FixComment(const S: string): string;
+begin
+ Result := S;
+ while (length(Result) > 0) AND (Result[length(Result)] < #32) do
+ Delete(Result,Length(Result),1);
+end; {FixComment}
+
+function TCommentList.GetColumn(Idx: integer): integer;
+begin
+ Result := TCommentItem(fList[Idx]).Column;
+end; {GetColumn}
+
+function TCommentList.GetComments(Idx: integer): string;
+begin
+ Result := TCommentItem(fList[Idx]).Comment;
+end; {GetComments}
+
+function TCommentList.GetCount: integer;
+begin
+ Result := fList.Count;
+end; {GetCount}
+
+function TCommentList.GetLine(Idx: integer): integer;
+begin
+ Result := TCommentItem(fList[Idx]).Line;
+end; {GetLine}
+
+function TCommentList.GetText: string;
+var
+ i : integer;
+begin
+ Result := '';
+ for i := 0 to Count - 1 do
+ begin
+ Result := Result + Comments[i];
+ if i < Count - 1 then
+ Result := Result + chEOL;
+ end;
+end; {GetText}
+
+procedure TCommentList.SetColumn(Idx: integer; const Value: integer);
+begin
+ TCommentItem(fList[Idx]).Column := Value;
+end; {SetColumn}
+
+procedure TCommentList.SetComments(Idx: integer; const Value: string);
+begin
+ TCommentItem(fList[Idx]).Comment := Value;
+end; {SetComments}
+
+procedure TCommentList.SetLine(Idx: integer; const Value: integer);
+begin
+ TCommentItem(fList[Idx]).Line := Value;
+end; {SetLine}
+
+end.
+
diff --git a/components/flashfiler/sourcelaz/convert/ff1dataa.res b/components/flashfiler/sourcelaz/convert/ff1dataa.res
new file mode 100644
index 000000000..55f874204
Binary files /dev/null and b/components/flashfiler/sourcelaz/convert/ff1dataa.res differ
diff --git a/components/flashfiler/sourcelaz/convert/ff1intfc.dpr b/components/flashfiler/sourcelaz/convert/ff1intfc.dpr
new file mode 100644
index 000000000..ada5b3774
--- /dev/null
+++ b/components/flashfiler/sourcelaz/convert/ff1intfc.dpr
@@ -0,0 +1,59 @@
+{*********************************************************}
+{* FlashFiler: Interface to the FlashFiler 1 DLL that is *}
+{* used in the conversion utility to converte FlashFiler *}
+{* 1.5x tables to 2.x *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+library FF1Intfc;
+
+uses
+ SysUtils,
+ Classes,
+ uFF1Data;
+
+{$R *.RES}
+
+exports
+ FF1DirOpen,
+ FF1IsFileBLOB,
+ FF1TableOpen,
+ FF1TableClose,
+ FF1TableDataDictionary,
+ FF1TableFirst,
+ FF1TableNext,
+ FF1TableFieldValue,
+ FF1TableEOF,
+ FF1TableRecordCount,
+ FF1GetMem,
+ FF1FreeMem,
+ FF1ReallocMem,
+ FF1GetAutoInc;
+
+begin
+
+end.
diff --git a/components/flashfiler/sourcelaz/convert/ff1intfc.rc b/components/flashfiler/sourcelaz/convert/ff1intfc.rc
new file mode 100644
index 000000000..fed719a8d
--- /dev/null
+++ b/components/flashfiler/sourcelaz/convert/ff1intfc.rc
@@ -0,0 +1,60 @@
+/*********************************************************
+ * Main program icon resource *
+ *********************************************************/
+
+/* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** */
+
+#define VERSIONINFO_1 1
+
+VERSIONINFO_1 VERSIONINFO
+FILEVERSION 2, 1, 3, 0
+PRODUCTVERSION 2, 1, 3, 0
+FILEOS VOS__WINDOWS32
+FILETYPE VFT_APP
+{
+ BLOCK "StringFileInfo"
+ {
+ BLOCK "040904E4"
+ {
+ VALUE "CompanyName", "TurboPower Software Company\000\000"
+ VALUE "FileDescription", "FlashFiler 1 Conversion Interface\000"
+ VALUE "FileVersion", "2.1.3.0\000"
+ VALUE "InternalName", "FF1INTFC\000"
+ VALUE "LegalCopyright", "Copyright (c) TurboPower Software Co. 1996-2002\000\000"
+ VALUE "OriginalFilename", "FF1INTFC.DLL\000"
+ VALUE "ProductName", "FlashFiler (Delphi Edition)\000"
+ VALUE "ProductVersion", "2.1.3.0\000"
+ }
+
+ }
+
+ BLOCK "VarFileInfo"
+ {
+ VALUE "Translation", 0x409, 1252
+ }
+
+}
+
diff --git a/components/flashfiler/sourcelaz/convert/ff1intfc.res b/components/flashfiler/sourcelaz/convert/ff1intfc.res
new file mode 100644
index 000000000..052b7fb5c
Binary files /dev/null and b/components/flashfiler/sourcelaz/convert/ff1intfc.res differ
diff --git a/components/flashfiler/sourcelaz/convert/ffcnvrt.dpr b/components/flashfiler/sourcelaz/convert/ffcnvrt.dpr
new file mode 100644
index 000000000..5b7f132ba
--- /dev/null
+++ b/components/flashfiler/sourcelaz/convert/ffcnvrt.dpr
@@ -0,0 +1,49 @@
+{*********************************************************}
+{* FlashFiler: GUI FF1->FF2 conversion utility *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+program FFCnvrt;
+
+uses
+ FFMemMgr in 'FFMemMgr.pas',
+ {$IFDEF USETeDEBUG}
+ TeDebug,
+ {$ENDIF}
+ Forms,
+ uFF2Cnv in 'uFF2Cnv.pas' {frmFF2Conv},
+ uFFNet in 'uFFNet.pas' {frmFFransport};
+
+{$R *.RES}
+
+begin
+ Application.Initialize;
+ Application.HelpFile := 'ffcnvrt.hlp';
+ Application.CreateForm(TfrmFF2Conv, frmFF2Conv);
+ Application.Run;
+end.
+
diff --git a/components/flashfiler/sourcelaz/convert/ffcnvrt.rc b/components/flashfiler/sourcelaz/convert/ffcnvrt.rc
new file mode 100644
index 000000000..5633fd556
--- /dev/null
+++ b/components/flashfiler/sourcelaz/convert/ffcnvrt.rc
@@ -0,0 +1,60 @@
+/*********************************************************
+ * Main program icon resource *
+ *********************************************************/
+
+/* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** */
+
+#define VERSIONINFO_1 1
+
+VERSIONINFO_1 VERSIONINFO
+FILEVERSION 2, 1, 3, 0
+PRODUCTVERSION 2, 1, 3, 0
+FILEOS VOS__WINDOWS32
+FILETYPE VFT_APP
+{
+ BLOCK "StringFileInfo"
+ {
+ BLOCK "040904E4"
+ {
+ VALUE "CompanyName", "TurboPower Software Company\000\000"
+ VALUE "FileDescription", "FlashFiler 2 Converter\000"
+ VALUE "FileVersion", "2.1.3.0\000"
+ VALUE "InternalName", "FFCNVRT\000"
+ VALUE "LegalCopyright", "Copyright (c) TurboPower Software Co. 1996-2002\000\000"
+ VALUE "OriginalFilename", "FFCNVRT.EXE\000"
+ VALUE "ProductName", "FlashFiler (Delphi Edition)\000"
+ VALUE "ProductVersion", "2.1.3.0\000"
+ }
+
+ }
+
+ BLOCK "VarFileInfo"
+ {
+ VALUE "Translation", 0x409, 1252
+ }
+
+}
+
diff --git a/components/flashfiler/sourcelaz/convert/ffcnvrt.res b/components/flashfiler/sourcelaz/convert/ffcnvrt.res
new file mode 100644
index 000000000..3939998d3
Binary files /dev/null and b/components/flashfiler/sourcelaz/convert/ffcnvrt.res differ
diff --git a/components/flashfiler/sourcelaz/convert/ffcnvrtc.dpr b/components/flashfiler/sourcelaz/convert/ffcnvrtc.dpr
new file mode 100644
index 000000000..17f755a24
--- /dev/null
+++ b/components/flashfiler/sourcelaz/convert/ffcnvrtc.dpr
@@ -0,0 +1,396 @@
+{*********************************************************}
+{* FlashFiler: Command line conversion utility *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+program FFCnvrtC;
+{$APPTYPE CONSOLE}
+uses
+ FFMemMgr,
+ {$IFDEF USETeDEBUG}
+ TeDebug,
+ {$ENDIF}
+ Classes,
+ SysUtils,
+ FileCtrl,
+ Windows,
+ FFConvrt,
+ FFSrEng,
+ FFLLEng,
+ FFLLComp;
+
+{$R *.RES}
+
+type
+ FF2CvtErrorCode = (cecNone,
+ {No errors}
+ cecNoDestination,
+ {Target parameter doesn't exist}
+ cecNoSource,
+ {One of the source files does not exist}
+ cecTooManySources,
+ {Only 1 source parameter is allowed}
+ cecNoTables,
+ {no tables were listed or in the source directory}
+ cecInvalidTable,
+ {The table doesn't exist in the source directory}
+ cecOverwrite,
+ {There are file(s) of the same name as a source
+ file in the destination directory}
+ cecInvalidSource,
+ {No valid source directory were given}
+ cecInvalidDestination,
+ {No valid target directory was given}
+ cecDataConvertFailed,
+ {The data conversion failed}
+ cecNoParameters,
+ {No parameters given}
+ cecUnknownFailure);
+ {Conversion Failed: unknown reason}
+
+ {This class is only here to provide a event handler for
+ TffDataConverter.OnProgress event}
+ TFFConvUtil = class
+ public
+ procedure OnProgress(aSender : TffDataConverter);
+ end;
+
+var
+ FF2Server : TffServerEngine;
+ TableConverter : TffDataConverter;
+ Utility : TFFConvUtil;
+ SourceTables : TStringList;
+ Destination : string;
+ SourceDir : string;
+ ScreenPos : TCoord;
+ CurrentTable : Integer;
+ GoodSource : Boolean;
+ GoodDest : Boolean;
+
+{--------}
+function WillOverwrite : boolean;
+var
+ i : integer;
+begin
+ Result := False;
+ {check if any of the selected files in srcFiles have the same name
+ as any files in the destination directory.}
+ for i := 0 to pred(SourceTables.Count) do begin
+ {Ensure this file isn't in the destination directory.}
+ if FileExists((Destination + '\' + ChangeFileExt(SourceTables[i], '.FF2'))) then begin
+ writeln(format('*** ERROR: %s already in destination ***', [ExtractFileName(SourceTables[i])]));
+ writeln;
+ ExitCode := integer(cecOverwrite);
+ Result := True;
+ Exit;
+ end;
+ end;
+end;
+{--------}
+procedure DisplayHelp;
+begin
+ writeln('Converts a FlashFiler 1 table to a FlashFiler 2 table.');
+ writeln;
+ writeln('FFCnvrtC -s -d [-t]');
+ writeln('Multiple tables can be listed or leave off the table parameter');
+ writeln('to convert all tables in the source.');
+ writeln('Example:');
+ writeln(' FFCnvrtC -sC:\MyApp -dC:\MyNewApp -tTable1 -tTable2');
+ writeln;
+end;
+{--------}
+procedure BuildTableList;
+var
+ ATable : TSearchRec;
+ CurrTable : string;
+ i : integer;
+begin
+ {are table parameters given?}
+ if (StrPos(CmdLine, '-t') <> nil) then begin
+ {yes. we need to add each table to SourceTables}
+ for i := 1 to ParamCount do begin
+ {if the second letter in the parameter is an t, it's a table}
+ if IsDelimiter('t', ParamStr(i), 2) then begin
+ CurrTable := ParamStr(i);
+ {strip delimiter off table parameter}
+ Delete(CurrTable, 1, 2);
+ {does the target file actually exist?}
+ if FileExists(SourceDir + '\' + CurrTable + '.FFD') then begin
+ {add the table to SourceTables}
+ SourceTables.Add(CurrTable + '.FFD');
+ end else begin
+ writeln(format('*** ERROR: %s doesn''t exist ***', [CurrTable + '.FFD']));
+ writeln;
+ ExitCode := integer(cecInvalidTable);
+ Exit;
+ end;
+ end;
+ end;
+ end else begin
+ {add all tables in the source directory to the SourceTables list}
+
+ {are there any tables in the source directory}
+ if FindFirst(SourceDir + '\*.FFD', faAnyFile, ATable) = 0 then begin
+ {yes. good, add each of them to the SourceTables list}
+ SourceTables.Add(ATable.Name);
+ while FindNext(ATable) = 0 do begin
+ SourceTables.Add(ATable.Name);
+ end;
+ end else begin
+ {no. Not good, we were expecting at least 1 FlashFiler table
+ here.}
+ ExitCode := integer(cecNoTables);
+ Exit;
+ end;
+ SysUtils.FindClose(ATable);
+ end;
+end;
+{--------}
+function IsSameDatabase : boolean;
+begin
+ {ensure that we are not trying to put our new file in the same
+ directory as the old file.}
+
+ {Assumption: local paths - No UNCs}
+ Result := UpperCase(Destination) = UpperCase(SourceDir);
+end;
+{--------}
+function IsValidDest : boolean;
+var
+ i : integer;
+begin
+ Result := False;
+ {Does the command line contain a source parameter?}
+ if (StrPos(CmdLine, '-d') <> nil) then begin
+ {yes. we need to parse out the target directory name}
+ for i := 1 to ParamCount do begin
+ {if the second letter in the parameter is an d, it's a source}
+ if IsDelimiter('d', ParamStr(i), 2) then begin
+ Destination := ParamStr(i);
+ {strip delimiter off string}
+ Delete(Destination, 1, 2);
+ {does the target file actually exist?}
+ if DirectoryExists(Destination) then begin
+ Result := True;
+ {Remove the trailing "\" if it's there}
+ if Destination[Length(Destination)] = '\' then
+ Delete(Destination, Length(Destination), 1);
+ {we're exiting if we get a valid target because there can
+ only be a single destination}
+ exit;
+ end else begin
+ writeln(format('*** ERROR: %s doesn''t exist ***', [Destination]));
+ writeln;
+ ExitCode := integer(cecInvalidDestination);
+ Result := False;
+ Exit;
+ end;
+ end; {if}
+ end; {for}
+ end else
+ ExitCode := integer(cecNoDestination);
+ if ((not Result) and (ExitCode = 0)) then
+ ExitCode := integer(cecInvalidDestination);
+end;
+{--------}
+function IsValidSource : Boolean;
+var
+ CurrParam : string;
+ i : Integer;
+ FirstSource : Boolean;
+begin
+ FirstSource := False;
+ Result := False;
+ {Does the command line contain a source parameter?}
+ if (StrPos(CmdLine, '-s') <> nil) then begin
+ {if so we need to parse out each source}
+ for i := 1 to ParamCount do begin
+ {if the second letter in the parameter is an s, it's a source}
+ if IsDelimiter('s', ParamStr(i), 2) then begin
+ {ensure only 1 source parameter is listed}
+ if not FirstSource then
+ FirstSource := True
+ else begin
+ ExitCode := integer(cecTooManySources);
+ Exit;
+ end;
+ CurrParam := ParamStr(i);
+ {strip delimiter off parameter}
+ Delete(CurrParam, 1, 2);
+ {does the source file actually exist?}
+ if DirectoryExists(CurrParam) then begin
+ SourceDir := CurrParam;
+ if SourceDir[Length(SourceDir)] = '\' then
+ Delete(SourceDir, Length(SourceDir), 1);
+ Result := True;
+ end else begin
+ writeln(format('*** ERROR: %s doesn''t exist ***', [CurrParam]));
+ writeln;
+ Result := False;
+ ExitCode := (integer(cecInvalidSource));
+ Exit;
+ end; {if..else}
+ end; {if}
+ end; {for}
+ end else
+ ExitCode := integer(cecNoSource);
+ {if the source parameters aren't all valid and we haven't already
+ set an exit code, we will set the ExitCode to 'Invalid Source'}
+ if ((not Result) and (ExitCode = integer(cecNone))) then
+ ExitCode := integer(cecInvalidSource);
+end;
+{--------}
+procedure ShowExitCodeMessage;
+begin
+ case ExitCode of
+ integer(cecNone): writeln('*** Conversion successful ***');
+ integer(cecNoDestination): writeln('*** ERROR: No destination parameter ***');
+ integer(cecNoSource): writeln('*** ERROR: No source parameters ***');
+ integer(cecTooManySources): writeln('*** ERROR: Too many source directories ***');
+ integer(cecNoTables): writeln('*** ERROR: No tables to convert ***');
+ integer(cecDataConvertFailed): writeln('*** ERROR: Conversion failed ***');
+ integer(cecUnknownFailure): writeln('*** ERROR: Unknown failure ***');
+ end;
+end;
+{--------}
+procedure DisplayStatus;
+var
+ ConsoleOutputHandle : THandle;
+begin
+ {reposition cursor}
+ ConsoleOutputHandle := GetStdHandle(STD_OUTPUT_HANDLE);
+ SetConsoleCursorPosition(ConsoleOutputHandle, ScreenPos);
+
+ Write(format('Table %d of %d - %d percent complete.',
+ [Succ(CurrentTable),
+ SourceTables.Count,
+ ((TableConverter.RecordsProcessed * 100) div
+ TableConverter.TotalRecords)]));
+end;
+{--------}
+procedure SetScreenPos;
+var
+ ConsoleOutputHandle : THandle;
+ ScreenInfo : TConsoleScreenBufferInfo;
+begin
+ { get screen pos}
+ ConsoleOutputHandle := GetStdHandle(STD_OUTPUT_HANDLE);
+ GetConsoleScreenBufferInfo(ConsoleOutputHandle, ScreenInfo);
+ ScreenPos.X := ScreenInfo.dwCursorPosition.X;
+ ScreenPos.Y := ScreenInfo.dwCursorPosition.Y;
+end;
+{--------}
+procedure ConvertTables;
+var
+ i : integer;
+begin
+ {Ensure we are not overwriting any tables that the user doesn't want
+ overwritten. If this isn't a problem, continue.}
+ if ExitCode = 0 then begin
+ if not WillOverwrite then begin
+ CurrentTable := -1;
+ for i := 0 to pred(SourceTables.Count) do begin
+ inc(CurrentTable);
+ {build the complete path to the table we're updating}
+ {convert the table}
+ try
+ Write(SourceTables[i] + ' ');
+ SetScreenPos;
+ Write(format('Table %d of %d - 100 percent complete.',
+ [Succ(CurrentTable), SourceTables.Count]));
+ TableConverter.Convert((SourceDir + '\' + SourceTables[i]), Destination);
+ Writeln;
+ except
+ on E: Exception do begin
+ writeln;
+ writeln(format('*** ERROR: Conversion of %s failed ***' + #13#10 +
+ '*** %s ***', [SourceTables[i], E.Message]));
+ ExitCode := integer(cecDataConvertFailed);
+ end;
+ end;
+ end;
+ end else
+ ExitCode := integer(cecOverwrite);
+ end;
+end;
+{--------}
+procedure TFFConvUtil.OnProgress;
+begin
+ DisplayStatus;
+end;
+{--------}
+procedure InitializeUnit;
+begin
+ ExitCode := 0;
+ {startup our server engine}
+ FF2Server := TffServerEngine.Create(nil);
+ FF2Server.Configuration.GeneralInfo.giNoAutoSaveCfg := True;
+ FF2Server.State := ffesStarted;
+ {setup our table converter and its events}
+ TableConverter := TffDataConverter.Create(FF2Server);
+ TableConverter.ProgressFrequency := 100;
+ {give ourself a 5 meg buffer for the FF2 server}
+ TableConverter.BufferSize := 1024 * 1024;
+ Utility := TFFConvUtil.Create;
+ TableConverter.OnProgress := Utility.OnProgress;
+ SourceTables := TStringList.Create;
+end;
+{--------}
+procedure FinalizeUnit;
+begin
+ SourceTables.Free;
+ TableConverter.Free;
+ FF2Server.State := ffesShuttingDown;
+ FF2Server.Free;
+ Utility.Free;
+end;
+{====================================================================}
+begin
+ InitializeUnit;
+ try
+ if ParamCount > 0 then begin
+ GoodSource := IsValidSource;
+ if ExitCode = 0 then begin
+ GoodDest := IsValidDest;
+ if GoodSource and GoodDest and (ExitCode = 0) then begin
+ BuildTableList;
+ if ExitCode = 0 then
+ ConvertTables;
+ writeln;
+ end else
+ DisplayHelp;
+ end;
+ end else begin
+ ExitCode := integer(cecNoParameters);
+ DisplayHelp;
+ end;
+ finally
+ FinalizeUnit;
+ ShowExitCodeMessage;
+ end;
+{====================================================================}
+end.
diff --git a/components/flashfiler/sourcelaz/convert/ffcnvrtc.rc b/components/flashfiler/sourcelaz/convert/ffcnvrtc.rc
new file mode 100644
index 000000000..82426e55b
--- /dev/null
+++ b/components/flashfiler/sourcelaz/convert/ffcnvrtc.rc
@@ -0,0 +1,60 @@
+/*********************************************************
+ * Main program icon resource *
+ *********************************************************/
+
+/* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** */
+
+#define VERSIONINFO_1 1
+
+VERSIONINFO_1 VERSIONINFO
+FILEVERSION 2, 1, 3, 0
+PRODUCTVERSION 2, 1, 3, 0
+FILEOS VOS__WINDOWS32
+FILETYPE VFT_APP
+{
+ BLOCK "StringFileInfo"
+ {
+ BLOCK "040904E4"
+ {
+ VALUE "CompanyName", "TurboPower Software Company\000\000"
+ VALUE "FileDescription", "FlashFiler Console Converter\000"
+ VALUE "FileVersion", "2.1.3.0\000"
+ VALUE "InternalName", "FFCNVRTC\000"
+ VALUE "LegalCopyright", "Copyright (c) TurboPower Software Co. 1996-2002\000\000"
+ VALUE "OriginalFilename", "FFCNVRTC.EXE\000"
+ VALUE "ProductName", "FlashFiler (Delphi Edition)\000"
+ VALUE "ProductVersion", "2.1.3.0\000"
+ }
+
+ }
+
+ BLOCK "VarFileInfo"
+ {
+ VALUE "Translation", 0x409, 1252
+ }
+
+}
+
diff --git a/components/flashfiler/sourcelaz/convert/ffcnvrtc.res b/components/flashfiler/sourcelaz/convert/ffcnvrtc.res
new file mode 100644
index 000000000..5e170a902
Binary files /dev/null and b/components/flashfiler/sourcelaz/convert/ffcnvrtc.res differ
diff --git a/components/flashfiler/sourcelaz/convert/ffconvrt.pas b/components/flashfiler/sourcelaz/convert/ffconvrt.pas
new file mode 100644
index 000000000..27e6b9443
--- /dev/null
+++ b/components/flashfiler/sourcelaz/convert/ffconvrt.pas
@@ -0,0 +1,972 @@
+{*********************************************************}
+{* FlashFiler: TffDataConvertClass used to convert a *}
+{* FlashFiler 1.xx table to a FlashFiler 2 *}
+{* table. *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+unit FFConvrt;
+
+{$I FFDEFINE.INC}
+
+{$IFDEF DCC6OrLater}
+!!! Conversion utilities should be compiled only with Delphi 5 or lower, and
+!!! C++Builder 5 or lower. Using Delphi 6 or higher, or C++Builder 6 or higher
+!!! would lead to an error because the D6 streams are incompatible with streams
+!!! from D5 and lower.
+{$ENDIF}
+
+interface
+
+uses
+ WinTypes, Classes, DB, FFLLDict, FFLLBase, FFLLEng, FFDB, FFLLExcp,
+ FFSRMgr;
+
+type
+ TffDataConverter = class; {forward declaration}
+
+ { FlashFiler v1.x DLL function types. }
+ TFF1TableDataDictionary = procedure(var aDict : TStream); stdcall;
+ TFF1TableFirst = procedure; stdcall;
+ TFF1TableNext = procedure; stdcall;
+ TFF1TableFieldValue = function(aFieldNo : Integer) : Variant; stdcall;
+ TFF1DirOpen = procedure(aPath : PChar); stdcall;
+ TFF1TableOpen = function(aTableName : PChar) : Integer; stdcall;
+ TFF1TableClose = procedure; stdcall;
+ TFF1TableEOF = function : boolean; stdcall;
+ TFF1TableRecordCount = function : Integer; stdcall;
+ TFF1IsFileBLOB = function(aFieldNo : Integer;
+ var aBuffer : array of Byte) : Boolean; stdcall;
+ TFF1SetNewMemMgr = function(aMemManager : TMemoryManager) : TMemoryManager; stdcall;
+ TFF1SetOldMemMgr = procedure(aMemMgr : TMemoryManager); stdcall;
+ TFF1GetAutoInc = function : Longint; stdcall;
+
+
+ { TProtOptions is a record that holds settings for all the protocol
+ options.}
+ TffProtOptions = packed record
+ IsSingleUser : Boolean;
+ IsIPXSPX : Boolean;
+ IPXSPXLFB : Boolean;
+ IsTCPIP : Boolean;
+ TCPIPLFB : Boolean;
+ TCPIPPort : Longint;
+ UDPPortSr : Longint;
+ UDPPortCl : Longint;
+ IPXSocketSr : Longint;
+ IPXSocketCl : Longint;
+ SPXSocket : Longint;
+ TCPIntf : Longint;
+ end;
+
+ EffConverterException = class(EffException);
+
+ { Event Types }
+ TffDataConverterEvent = procedure(aSender : TffDataConverter) of object;
+ { Event type used for status events during the execution of the
+ converter}
+ TffDCNetBiosEvent = procedure(aSender : TffDataConverter;
+ var aCanceled : Boolean;
+ var aOptions : TffProtOptions) of object;
+ { Since the NetBIOS protocol isn't supported in FF2, we raise this
+ type of event to give the application a chance to change the
+ protocol and provide options for the new protocol.}
+
+
+ {---FF1 to FF2 Converter Class---}
+
+ { This class contains the business logic for converting a FlashFiler 1.x
+ file to the FlashFiler 2.0 file format.
+ Call the Convert method to convert a file. The converter opens the source
+ file in exclusive mode hence the file may not be opened by a server.
+ }
+ TffDataConverter = class
+ private
+ FAfterConvert : TffDataConverterEvent;
+ { The method called after successfully completing the Convert Records
+ stage. }
+ FBeforeConvert : TffDataConverterEvent;
+ { The method called before starting the Convert Records stage. }
+ FCanceled : Boolean;
+ { Flag to stop the conversion process.}
+ FClient : TffClient;
+ { The FF2 client used for the conversion. }
+ FCommitFrequency : TffWord32;
+ { The number of records that must be converted before a
+ transaction is committed.}
+ FDatabase : TffDatabase;
+ { The FF2 database used for the conversion. }
+ FDLLHandle : THandle;
+ { Handle to the FF1 DLL.}
+ FFF2Table : TffTable;
+ { The new FF2 table.}
+ FOnCancel : TffDataConverterEvent;
+ { Event called if a conversion is aborted.}
+ FOnComplete : TffDataConverterEvent;
+ { The method called after all operations are complete on a single
+ table.}
+ FOnNetBios : TffDCNetBiosEvent;
+ { Since the NetBIOS protocol isn't supported in FF2, we raise
+ this event to give the application a chance to change the
+ protocol and provide options for the new protocol.}
+ FOnProgress : TffDataConverterEvent;
+ { The method called during the conversion of records. It is
+ raised after converting the number of records specified by
+ ProgressFrequency. This event is raised at the very end of
+ the conversion if less than ProgressFrequency records were
+ processed since the last OnProgress event. }
+ FProgressFrequency : TffWord32;
+ { The number of records that must be converted before the
+ OnProgress event may be raised. }
+ FBufferSize : TffWord32;
+ { How big of a buffer to allow the converter to use. This is
+ used to determine how often transactions are committed.}
+ FRecordsProcessed : TffWord32;
+ { This is the total number of records converted.}
+ FServerEngine : TffBaseServerEngine;
+ { The FF2 server used for the conversion. }
+ FSession : TffSession;
+ { The FF2 session used for the conversion. }
+ FSource : string;
+ { The directory and name of the file being converted. }
+ FDestination : string;
+ { The directory and name of the new file being created from the old
+ file. }
+ FTotalRecords : TffWord32;
+ { The total number of records in the table that must be converted. }
+
+ procedure FFTableAfterOpen(aDataSet : TDataSet);
+ { Used to get access to the FF2 table after it's opened.}
+ function IsFileBLOB(aField : TField; aFieldNo : Integer) : Boolean;
+ { Fields that are stored as file BLOBs must be converted in a
+ different way than other fields. This function is used to
+ check for file-BLOB field types.}
+ procedure LoadFF1DLL;
+ { Load the FF1 server from a DLL since we can't have a FF1 and
+ FF2 server in the same application.}
+ procedure ProcessGenInfo(const aFileName : string);
+ { The FFSINFO is a FlashFiler system table that can't be handled
+ by the standard routine below. This procedure will convert
+ the FFSINFO table correctly.}
+ procedure SetBufferSize(aSize : TffWord32);
+ { This function is called by the BufferSize property to set the
+ buffer size.}
+
+ {==FF1 Routine Types==}
+ protected
+ public
+ constructor Create(aServerEngine : TffBaseServerEngine);
+ destructor Destroy; override;
+
+ procedure Cancel;
+ { Call this method to abort the conversion process.}
+ procedure Convert(const aSource : string;
+ const aDest : string);
+ { Call this method to convert a file in the old format to a file
+ in the new format. This method raises an exception if an error
+ occurs.
+ aSource - The absolute path to an existing FFD file
+ in the old format. (Ex: c:\MyApp\MyTable.FFD)
+ aDest - The absolute path of the directory to which
+ aSource is being converted to. If a file
+ exists in aDest with the same filename that
+ is in aSource it will be overwritten.
+ (Ex: c:\MyNewApp) }
+ property AfterConvert : TffDataConverterEvent
+ read FAfterConvert
+ write FAfterConvert;
+ { This event is raised after the record conversion stage has successfully
+ finished. If an error occurs during convert records then this event is
+ not raised. }
+ property BeforeConvert : TffDataConverterEvent
+ read FBeforeConvert
+ write FBeforeConvert;
+ { This event is raised before the file is converted. When this method
+ is called, the converter will have opened the file and determined
+ how many records need to be converted. }
+ property BufferSize : TffWord32
+ read FBufferSize
+ write SetBufferSize
+ default 1024 * 1024;
+ { Size of the buffer used by the converter. This number is used
+ to determine how often transactions are committed.}
+ property Canceled : Boolean read FCanceled;
+ { Check if conversion was canceled.}
+ property OnCancel : TffDataConverterEvent
+ read FOnCancel
+ write FOnCancel;
+ { The event called when a conversion is aborted.}
+ property OnComplete : TffDataConverterEvent
+ read FOnComplete
+ write FOnComplete;
+ { The method called after all operations are complete on a table.}
+ property OnProgress : TffDataConverterEvent
+ read FOnProgress
+ write FOnProgress;
+ { This event is raised after converting the number of records
+ specified by ProgressFrequency. This event is also raised at
+ the end of the conversion if fewer then ProgressFrequency
+ records were processed since the last OnProgress event. }
+ property OnNetBios : TffDCNetBiosEvent
+ read FOnNetBios
+ write FOnNetBios;
+ { Since the NetBIOS protocol isn't supported in FF2, we raise
+ this event to give the application a chance to change the
+ protocol and provide options for the new protocol.}
+ property ProgressFrequency : TffWord32
+ read FProgressFrequency
+ write FProgressFrequency default 100;
+ { The number of records that must be converted before the
+ OnProgress event will be raised. }
+ property RecordsProcessed : TffWord32 read FRecordsProcessed;
+ { The number of records converted. This number is accurate at
+ the time OnProgress is raised. }
+ property Source : string read FSource;
+ { The directory and name of the file being converted. }
+ property Destination : string read FDestination;
+ { The drive and path of the location to place the new FF2 tables.}
+ property TotalRecords : TffWord32 read FTotalRecords;
+ { The total number of records to be processed in the Convert Records
+ stage. }
+ property ServerEngine : TffBaseServerEngine read FServerEngine;
+ { The FF2 server engine used to make the new (converted) table.}
+ end;
+
+implementation
+
+uses
+ SysUtils,
+ Dialogs,
+ Winsock,
+ {$IFDEF DCC6OrLater} {!!.06 - Start}
+ Variants,
+ {$ENDIF} {!!.06 - End}
+ FFClintf;
+
+const
+ ffc_ConvAlias = 'ConvAlias';
+
+var
+ ffStrResConverter : TffStringResource;
+
+ { Functions mapped to FF1 DLL}
+ FF1DirOpen : TFF1DirOpen;
+ FF1TableClose : TFF1TableClose;
+ FF1TableDataDictionary : TFF1TableDataDictionary;
+ FF1TableEOF : TFF1TableEOF;
+ FF1TableFieldValue : TFF1TableFieldValue;
+ FF1TableFirst : TFF1TableFirst;
+ FF1TableNext : TFF1TableNext;
+ FF1TableOpen : TFF1TableOpen;
+ FF1TableRecordCount : TFF1TableRecordCount;
+ FF1IsFileBLOB : TFF1IsFileBLOB;
+ FF1SetNewMemMgr : TFF1SetNewMemMgr;
+ FF1SetOldMemMgr : TFF1SetOldMemMgr;
+ FF1GetAutoInc : TFF1GetAutoInc;
+
+{$I FFCvCNST.INC}
+{$R FFCVCNST.RES}
+
+{===TffDataConverter=================================================}
+procedure TffDataConverter.Cancel;
+begin
+ FCanceled := True;
+end;
+{--------}
+procedure TffDataConverter.Convert(const aSource : string;
+ const aDest : string);
+var
+ FF2Dict : TffDataDictionary;
+ FF1DictStream : TMemoryStream;
+ Value : Variant;
+ OldFileName : AnsiString;
+ SourceDir : AnsiString;
+ Msg : TMsg;
+ FieldNumber : Integer;
+ FieldCount : Integer;
+ Data : Pointer;
+begin
+ FTotalRecords := 0;
+ FRecordsProcessed := 0;
+ FSource := aSource;
+ OldFileName := ExtractFileName(aSource);
+ FDestination := aDest + '\' + ChangeFileExt(OldFileName, {!!.03}
+ '.' + ffc_ExtForData); {!!.03}
+ FCanceled := False;
+
+ {setup a FF2 table}
+ FFF2Table := TffTable.Create(nil);
+ FFF2Table.AfterOpen := FFTableAfterOpen;
+ try
+ FFF2Table.DatabaseName := FDatabase.DatabaseName;
+ FFF2Table.SessionName := FSession.SessionName;
+ FFF2Table.Timeout := -1;
+
+ {parse out the directory to the source file(s)}
+ SourceDir := ExtractFilePath(aSource);
+ {remove the trailing backslash from the directory}
+ Delete(SourceDir, Length(SourceDir), 1);
+ FF1DirOpen(PChar(SourceDir));
+ {extract the FF1 table name and remove its extension}
+ Delete(OldFileName, Length(OldFileName) - 3, 4);
+ {if we are able to open the FF1 table we'll start the conversion
+ process}
+ if FF1TableOpen(PChar(OldFileName)) <> 0 then begin
+ FFRaiseExceptionNoData(EffConverterException,
+ ffStrResConverter,
+ ffcverrFF1TableOpen)
+ end else begin
+ {add our alias if we haven't added it already}
+ if not FSession.IsAlias(ffc_ConvAlias) then begin
+ FSession.AddAlias(ffc_ConvAlias, PChar(aDest), False); {!!.11}
+ FDatabase.AliasName := ffc_ConvAlias;
+ end;
+ FDatabase.Open;
+
+ FTotalRecords := FF1TableRecordCount;
+
+ { the rest of this routine will not properly convert a FF1
+ FFSINFO system table so we'll convert it in a separate procedure}
+ if UpperCase(OldFileName) = 'FFSINFO' then begin
+ ProcessGenInfo(OldFileName);
+ exit;
+ end;
+ {create a dictionary from the FF1 table that will be used in our
+ new FF2 table}
+ FF2Dict := TffDataDictionary.Create(4096);
+ {read the FF1 dictionary into a stream and then read it into the
+ new dictionary}
+ FF1DictStream := TMemoryStream.Create;
+ FF1TableDataDictionary(TStream(FF1DictStream));
+ FF1DictStream.Position := 0;
+ FF2Dict.ReadFromStream(FF1DictStream);
+ FF2Dict.FileDescriptor[0]^.fdExtension := ffc_ExtForData;
+
+ try
+ {create the new table}
+ if FFDbiCreateTable(FDatabase, True, OldFileName, FF2Dict) = 0 then begin
+ try
+ {don't prceed if the conversion has been canceled}
+ if not FCanceled then begin
+ {execute the BeforeConvert event if assigned}
+ if Assigned(FBeforeConvert) then
+ FBeforeConvert(self);
+ {name and open the new table}
+ FFF2Table.TableName := OldFileName;
+ FFF2Table.Exclusive := True;
+ FFF2Table.Open;
+ {now move to the first record in the FF1 table and iterate
+ through them - adding each record to the FF2 table, field-
+ by-field}
+ FF1TableFirst;
+ FDatabase.StartTransaction;
+ while ((not FF1TableEOF) and (not FCanceled)) do begin
+ FFF2Table.Insert;
+ {copy the value of each field to the FF2 record we're
+ inserting}
+ FieldCount := pred(FFF2Table.FieldCount);
+ for FieldNumber := 0 to FieldCount do begin
+ {we have to handle file BLOBs differently than other
+ field types else they will be added to the new table
+ as "normal" BLOBs -- and folks wouldn't like that. The
+ file BLOB process is contained within the call to
+ IsFileBLOB(..) for efficiency.}
+ if (not IsFileBLOB(FFF2Table.Fields[FieldNumber], FieldNumber)) then
+ try {!!.01}
+ if (FFF2Table.Dictionary.FieldType[FieldNumber] <> fftByteArray) then {!!.06 - Start}
+ FFF2Table.Fields[FieldNumber].Value :=
+ FF1TableFieldValue(FieldNumber)
+ else begin
+ Value := FF1TableFieldValue(FieldNumber);
+ if (Value <> NULL) then begin {!!.07 - Start}
+ Data := VarArrayLock(Value);
+ try
+ FFF2Table.Fields[FieldNumber].SetData(Data);
+ finally
+ VarArrayUnlock(Value);
+ end;
+ end; {!!.07 - End}
+ end; {!!.06 - End}
+ except {!!.01}
+ FCanceled := False; {!!.01}
+ raise; {!!.01}
+ end; {!!.01}
+ end; {for}
+ {post the new record}
+ FFF2Table.Post;
+ inc(FRecordsProcessed);
+ {move to the next record}
+ FF1TableNext;
+ {execute the OnProgress event if assigned and we're at one
+ of the progress points}
+ if ((Assigned(FOnProgress)) and (FProgressFrequency <> 0) and
+ (FRecordsProcessed mod FProgressFrequency = 0)) then begin
+ FOnProgress(self);
+ end;
+ if ((FCommitFrequency <> 0) and
+ (FRecordsProcessed mod FCommitFrequency = 0)) then begin
+ try
+ FDatabase.Commit;
+ except
+ {no need to rollback because we're deleting the table}
+ FCanceled := True;
+ raise;
+ end;
+ {process messages: there could have been a Cancel raised.}
+ if PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE) then
+ while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
+ DispatchMessage(Msg);
+ FDatabase.StartTransaction;
+ end;
+ end; {while}
+
+ {we have to commit the outstanding transaction even if it
+ was canceled}
+ try
+ if FDatabase.InTransaction then
+ FDatabase.Commit;
+ if FFF2Table.Dictionary.HasAutoIncField(FieldNumber) then
+ FFDbiSetTableAutoIncValue(FFF2Table, FF1GetAutoInc);
+ except
+ {no need to rollback because we're deleting the table}
+ FCanceled := True;
+ raise;
+ end;
+
+ {only proceed if not canceled}
+ if not FCanceled then begin
+ {execute the OnProgress event if assigned to ensure we get
+ a final count on the number of records converted}
+ if ((Assigned(FOnProgress)) and
+ (FProgressFrequency <> 0) and
+ (FRecordsProcessed mod FProgressFrequency > 0)) then
+ FOnProgress(self);
+ {now we need to call the AfterConvert event}
+ if Assigned(FAfterConvert) then
+ FAfterConvert(self);
+ end; {if not canceled}
+ end; {if not canceled}
+ finally
+ {if an exception was raised during a conversion, it's
+ possible to have an open transaction. We need to see if
+ there's an open transaction and roll it back if so}
+ if FDatabase.InTransaction then
+ FDatabase.Rollback;
+ FFF2Table.Close;
+ FDatabase.Close;
+ if not FCanceled then begin
+ {we didn't complete the conversion if it was canceled.}
+ if Assigned(FOnComplete) then
+ FOnComplete(self);
+ end else begin
+ {if canceled, we raise the Canceled event, delete the
+ aborted table, and reset the canceled flag.}
+ if Assigned(FOnCancel) then
+ FOnCancel(self);
+ FDatabase.Open;
+ FFF2Table.DeleteTable;
+ FFF2Table.Close;
+ FDatabase.Close;
+ FCanceled := False;
+ end; {if..else}
+ FFF2Table.Free;
+ FFF2Table := nil; {!!.01}
+ FSession.DeleteAlias(ffc_ConvAlias);
+ FF1TableClose;
+ FF1DictStream.Free;
+ FF2Dict.Free;
+ end; {try..finally}
+ end else
+ FFRaiseException(EffConverterException, ffStrResConverter,
+ ffcverrFF2TableCreate,
+ [format('Couldn''t create new %s', [FDestination])])
+ except
+ on E: Exception do
+ if E.ClassType <> EffConverterException then
+ FFRaiseException(EffConverterException,
+ ffStrResConverter,
+ ffcverrFF2TableCreate,
+ [E.Message])
+ else
+ raise;
+ end;
+ end; {if}
+ except
+ on E: Exception do begin
+ FFF2Table.Free;
+ if E.ClassType <> EffConverterException then begin
+ FFRaiseExceptionNoData(EffConverterException,
+ ffStrResConverter,
+ ffcverrFF1TableOpen)
+ end else
+ raise;
+ end;
+ end;
+end;
+{--------}
+constructor TffDataConverter.Create(aServerEngine: TffBaseServerEngine);
+begin
+ FCanceled := False;
+ FServerEngine := aServerEngine;
+ LoadFF1DLL;
+ BufferSize := 1024 * 1024;
+ FCommitFrequency := 1000;
+ {setup our client}
+ FClient := TffClient.Create(nil);
+ FClient.ClientName := 'ConvClient' + IntToStr(GetCurrentThreadID);
+ FClient.ServerEngine := aServerEngine;
+ {setup our session}
+ FSession := TffSession.Create(nil);
+ FSession.ClientName := FClient.ClientName;
+ FSession.SessionName := 'ConvSess' + IntToStr(GetCurrentThreadID);
+ FSession.Open;
+ {setup a database}
+ FDatabase := TffDatabase.Create(nil);
+ FDatabase.SessionName := FSession.SessionName;
+ FDatabase.DatabaseName := ffc_ConvAlias;
+end;
+{--------}
+destructor TffDataConverter.Destroy;
+begin
+ {free the database}
+ FDatabase.Free;
+ {free the session}
+ FSession.Free;
+ {free the client}
+ FClient.Free;
+
+ if FDLLHandle <> 0 then
+ FreeLibrary(FDLLHandle);
+
+ inherited;
+end;
+{--------}
+procedure TffDataConverter.FFTableAfterOpen(aDataSet : TDataSet);
+var
+ TempFreq : Integer;
+begin
+ if ((FBufferSize <= 0) or
+ (aDataSet = nil)) then
+ Exit;
+ if aDataSet.Active then begin
+ TempFreq := Integer(FBufferSize) div
+ TffTable(aDataSet).Dictionary.RecordLength;
+{Begin !!.03}
+ {ensure we have a min commit freq of 10 records}
+ if TempFreq > 10 then begin
+ if TffTable(aDataSet).Dictionary.HasBLOBFields then
+ FCommitFrequency := 10
+ else
+ FCommitFrequency := TempFreq;
+ end
+ else
+ FCommitFrequency := 10;
+{End !!.03}
+ end else
+ FCommitFrequency := 1000;
+end;
+{--------}
+function TffDataConverter.IsFileBLOB(aField : TField;
+ aFieldNo : Integer) : Boolean;
+var
+ FileName : string[255];
+ Buffer : array[0..255] of Byte;
+begin
+ Result := False;
+ if aField is TBLOBField then begin
+ Result := FF1IsFileBLOB(aFieldNo, Buffer);
+ if Result then begin
+ SetLength(FileName, Buffer[0]);
+ Move(Buffer[1], FileName[1], Buffer[0]);
+ FFDbiAddFileBLOB(FFF2Table, succ(aFieldNo), FileName);
+ end;
+ end; {if}
+end;
+{--------}
+procedure TffDataConverter.LoadFF1DLL;
+var
+ Msg, Msg2 : string;
+ ErrorMode : Word;
+begin
+ { Use setErrorMode to prohibit the Windows error dialog that appears if the
+ DLL is not found. Load the DLL dynamically. }
+ ErrorMode := SetErrorMode(SEM_NoOpenFileErrorBox);
+ FDllHandle := LoadLibrary('FF1Intfc.DLL');
+ SetErrorMode(ErrorMode);
+
+ FDLLHandle := GetModuleHandle('FF1Intfc.DLL');
+
+ if FDllHandle = 0 then
+ begin
+ Msg := 'Unable to load DLL FF1Intfc. ';
+ case GetLastError of
+ 0 : Msg2 := 'System out of memory, executable corrupt, ' +
+ 'or relocations invalid.';
+ 2 : Msg2 := 'File not found.';
+ 3 : Msg2 := 'Path not found.';
+ 8 : Msg2 := 'There is insufficient memory to load the DLL.';
+ 10 : Msg2 := 'The Windows version of the DLL is incorrect.';
+ else
+ Msg2 := '';
+ end; { case }
+ raise Exception.Create(Msg + Msg2 + ' Unable to run conversion.');
+ end { if dll not loaded }
+ else begin
+ {map our function calls to the FF1 DLL}
+ @FF1TableDataDictionary := GetProcAddress(FDLLHandle, 'FF1TableDataDictionary');
+ @FF1TableFirst := GetProcAddress(FDLLHandle, 'FF1TableFirst');
+ @FF1TableNext := GetProcAddress(FDLLHandle, 'FF1TableNext');
+ @FF1TableFieldValue := GetProcAddress(FDLLHandle, 'FF1TableFieldValue');
+ @FF1DirOpen := GetProcAddress(FDLLHandle, 'FF1DirOpen');
+ @FF1TableOpen := GetProcAddress(FDLLHandle, 'FF1TableOpen');
+ @FF1TableClose := GetProcAddress(FDLLHandle, 'FF1TableClose');
+ @FF1TableEOF := GetProcAddress(FDLLHandle, 'FF1TableEOF');
+ @FF1TableRecordCount := GetProcAddress(FDLLHandle, 'FF1TableRecordCount');
+ @FF1IsFileBLOB := GetProcAddress(FDLLHandle, 'FF1IsFileBLOB');
+ @FF1SetNewMemMgr := GetProcAddress(FDLLHandle, 'FF1SetNewMemManager');
+ @FF1SetOldMemMgr := GetProcAddress(FDLLHandle, 'FF1SetOldMemManager');
+ @FF1GetAutoInc := GetProcAddress(FDLLHandle, 'FF1GetAutoInc');
+ end;
+end;
+{--------}
+procedure TffDataConverter.ProcessGenInfo(const aFileName : string);
+var
+ FF1DictStream : TMemoryStream;
+ FF1Dict : TffDataDictionary;
+ FF2Dict : TffDataDictionary;
+ ProtocolString : string;
+ NewFileName : string;
+ FieldNumber : Integer;
+ IsNotCanceled : Boolean;
+ SkipProtocols : Boolean;
+ ProtOptions : TffProtOptions;
+begin
+ {since some of the earlier FF1 tables don't have all the fields that
+ v1.56 has we need FF1's dictionary so we can get its field count.}
+ FF1DictStream := TMemoryStream.Create;
+ FF1TableDataDictionary(TStream(FF1DictStream));
+ FF1Dict := TffDataDictionary.Create(4096);
+ FF1DictStream.Position := 0;
+ FF1Dict.ReadFromStream(FF1DictStream);
+ {we'll build the dictionary to build our new FF2 table}
+ FF2Dict := TffDataDictionary.Create(4096);
+ with FF2Dict do begin
+ AddField('ServerName', '', fftShortString,
+ pred(sizeof(TffNetName)), 0, true, nil);
+ AddField('MaxPages', '', fftWord32, 0, 0, True, nil);
+ AddField('IsSecure', '', fftBoolean, 0, 0, True, nil);
+ AddField('AutoUp', '', fftBoolean, 0, 0, True, nil);
+ AddField('AutoMini', '', fftBoolean, 0, 0, True, nil);
+ AddField('DebugLog', '', fftBoolean, 0, 0, True, nil);
+ AddField('UseSingleUser', '', fftBoolean, 0, 0, True, nil);
+ AddField('UseIPXSPX', '', fftBoolean, 0, 0, True, nil);
+ AddField('IPXSPXLFB', '', fftBoolean, 0, 0, True, nil);
+ AddField('UseTCPIP', '', fftBoolean, 0, 0, True, nil);
+ AddField('TCPIPLFB', '', fftBoolean, 0, 0, True, nil);
+ AddField('TCPPort', '', fftInt32, 0, 0, True, nil);
+ AddField('UDPPortSr', '', fftInt32, 0, 0, True, nil);
+ AddField('UDPPortCl', '', fftInt32, 0, 0, True, nil);
+ AddField('IPXSocketSr', '', fftInt32, 0, 0, True, nil);
+ AddField('IPXSocketCl', '', fftInt32, 0, 0, True, nil);
+ AddField('SPXSocket', '', fftInt32, 0, 0, True, nil);
+ AddField('UseEncrypt', '', fftBoolean, 0, 0, True, nil);
+ AddField('ReadOnly', '', fftBoolean, 0, 0, True, nil);
+ AddField('LstMsgIntvl', '', fftInt32, 0, 0, True, nil);
+ AddField('KAInterval', '', fftInt32, 0, 0, True, nil);
+ AddField('KARetries', '', fftInt32, 0, 0, True, nil);
+ AddField('Priority', '', fftInt32, 0, 0, True, nil);
+ AddField('TCPInterface', '', fftInt32, 0, 0, True, nil);
+ AddField('NoAutoSaveCfg', '', fftBoolean, 0, 0, True, nil);
+ Addfield('TempStoreSize', '', fftInt32, 0, 0, True, nil);
+ AddField('CollectEnabld', '', fftBoolean, 0, 0, True, nil); {!!.01}
+ AddField('CollectFreq', '', fftInt32, 0, 0, True, nil); {!!.01}
+ end;
+ {create the new table}
+ NewFileName := ExtractFileName(FDestination);
+ if FFDbiCreateTable(FDatabase, True, aFileName, FF2Dict) = 0 then begin
+ try
+ {execute the BeforeConvert event if assigned}
+ if Assigned(FBeforeConvert) then
+ FBeforeConvert(self);
+ {name and open the new table}
+ FFF2Table.TableName := NewFileName;
+ FFF2Table.Open;
+ {now we'll move to the first record in the FF1 table and
+ iterate through them - adding each record to the FF2 table}
+ FF1TableFirst;
+
+ FFF2Table.Insert;
+ {we know the first six fields will match so we'll just copy
+ those over to the new table.}
+ FFF2Table.Fields[0].Value := FF1TableFieldValue(0); {ServerName}
+ {we are going to assume that all the old RAM pages were for a
+ 4K block size and then round up to turn the memory used for
+ the old RAM pages into megabytes of RAM in the new table.}
+ FFF2Table.Fields[1].Value := (((FF1TableFieldValue(1) * 4096) +
+ pred(1024 * 1024)) {to prevent 0 MB RAM}
+ div (1024 * 1024));
+ for FieldNumber := 2 to 5 do
+ FFF2Table.Fields[FieldNumber].Value := FF1TableFieldValue(FieldNumber);
+ {setup the protocols}
+ SkipProtocols := False;
+ ProtocolString := FF1TableFieldValue(6);
+ if ProtocolString = '' then begin
+ FFF2Table.Fields[6].Value := True; {SingleUser}
+ FFF2Table.Fields[7].Value := False; {IPXSPX}
+ FFF2Table.Fields[8].Value := False; {IPXSPXLFB}
+ FFF2Table.Fields[9].Value := False; {TCPIP}
+ FFF2Table.Fields[10].Value := False; {TCPIPLFB}
+ end else if ProtocolString = 'TCP/IP' then begin
+ FFF2Table.Fields[6].Value := False;
+ FFF2Table.Fields[7].Value := False;
+ FFF2Table.Fields[8].Value := False;
+ FFF2Table.Fields[9].Value := True;
+ FFF2Table.Fields[10].Value := FF1TableFieldValue(7);
+ end else if ProtocolString = 'IPX/SPX' then begin
+ FFF2Table.Fields[6].Value := False;
+ FFF2Table.Fields[7].Value := True;
+ FFF2Table.Fields[8].Value := FF1TableFieldValue(7);
+ FFF2Table.Fields[9].Value := False;
+ FFF2Table.Fields[10].Value := False;
+ end else if ProtocolString = 'SINGLE' then begin
+ FFF2Table.Fields[6].Value := True;
+ FFF2Table.Fields[7].Value := False;
+ FFF2Table.Fields[8].Value := False;
+ FFF2Table.Fields[9].Value := False;
+ FFF2Table.Fields[10].Value := False;
+ end else if ProtocolString = 'NETBIOS' then begin
+ {NetBios has been removed from FF2 so we need to have the
+ user select a new protocol before converting the table or
+ find a way to have the application select new protocol and
+ assign it during the conversion.}
+ SkipProtocols := True;
+ if Assigned(FOnNetBios) then begin
+ {yes. initialize ProtOptions and raise the FOnNetBIOS event
+ so the using application can get updated protocol options
+ and update ProtOptions. We will use ProtOptions to
+ initialize the protocol options of the table.}
+ with ProtOptions do begin
+ IsSingleUser := False;
+ IsIPXSPX := False;
+ IPXSPXLFB := False;
+ IsTCPIP := False;
+ TCPIPLFB := False;
+ {FF1 stored the TCPIP port incorrectly, so we'll convert
+ it now. We are also changing the defaults in FF2.}
+ TCPIPPort := htons(FF1TableFieldValue(8));
+ if TCPIPPort = 24677 then
+ TCPIPPort := 25445;
+ UDPPortSr := htons(FF1TableFieldValue(9));
+ if UDPPortSr = 24677 then
+ UDPPortSr := 25445;
+ UDPPortCl := htons(FF1TableFieldValue(10));
+ if UDPPortCl = 24933 then
+ UDPPortCl := 25701;
+ IPXSocketSr := htons(FF1TableFieldValue(11));
+ if IPXSocketSr = 24677 then
+ IPXSocketSr := 25445;
+ IPXSocketCl := htons(FF1TableFieldValue(12));
+ if IPXSocketCl = 24933 then
+ IPXSocketCl := 25701;
+ SPXSocket := htons(FF1TableFieldValue(13));
+ if SPXSocket = 25189 then
+ SPXSocket := 25957;
+ if FF1Dict.FieldCount > 20 then
+ TCPIntf := FF1TableFieldValue(20)
+ else
+ TCPIntf := 0;
+
+ {now that we've setup the previous protocol options we
+ can raise the event with the previous settings}
+ FOnNetBIOS(self, IsNotCanceled, ProtOptions);
+
+ {assign the values returned to the appropriate FF2 field}
+ FFF2Table.Fields[6].Value := IsSingleUser;
+ FFF2Table.Fields[7].Value := IsIPXSPX;
+ FFF2Table.Fields[8].Value := IPXSPXLFB;
+ FFF2Table.Fields[9].Value := IsTCPIP;
+ FFF2Table.Fields[10].Value := TCPIPLFB;
+ FFF2Table.Fields[11].Value := TCPIPPort;
+ FFF2Table.Fields[12].Value := UDPPortSr;
+ FFF2Table.Fields[13].Value := UDPPortCl;
+ FFF2Table.Fields[14].Value := IPXSocketSr;
+ FFF2Table.Fields[15].Value := IPXSocketCl;
+ FFF2Table.Fields[16].Value := SPXSocket;
+ FFF2Table.Fields[23].Value := TCPIntf;
+ end; {with}
+ end else begin
+ {if the FOnNetBIOS isn't assigned, setup all protocol
+ settings to defaults.}
+ FFF2Table.Fields[6].Value := True;
+ FFF2Table.Fields[7].Value := False;
+ FFF2Table.Fields[8].Value := False;
+ FFF2Table.Fields[9].Value := False;
+ FFF2Table.Fields[10].Value := False;
+ FFF2Table.Fields[11].Value := 25445;
+ FFF2Table.Fields[12].Value := 25445;
+ FFF2Table.Fields[13].Value := 25701;
+ FFF2Table.Fields[14].Value := 25445;
+ FFF2Table.Fields[15].Value := 25701;
+ FFF2Table.Fields[16].Value := 25957;
+ FFF2Table.Fields[23].Value := 0;
+ end;
+ end;
+ {we can match up FF1 fields 8 through 13 with FF2 fields
+ 12 through 17. We will skip this section if we've already
+ setup the protocols.}
+ if not SkipProtocols then begin
+ {since FF1 stored the TCP/IP port incorrectly, correct it now}
+ FFF2Table.Fields[11].Value := htons(FF1TableFieldValue(8));
+ if FFF2Table.Fields[11].Value = 24677 then
+ FFF2Table.Fields[11].Value := 25445;
+ FFF2Table.Fields[12].Value := htons(FF1TableFieldValue(9));
+ if FFF2Table.Fields[12].Value = 24677 then
+ FFF2Table.Fields[12].Value := 25445;
+ FFF2Table.Fields[13].Value := htons(FF1TableFieldValue(10));
+ if FFF2Table.Fields[13].Value = 24933 then
+ FFF2Table.Fields[13].Value := 25701;
+ FFF2Table.Fields[14].Value := htons(FF1TableFieldValue(11));
+ if FFF2Table.Fields[14].Value = 24677 then
+ FFF2Table.Fields[14].Value := 25445;
+ FFF2Table.Fields[15].Value := htons(FF1TableFieldValue(12));
+ if FFF2Table.Fields[15].Value = 24933 then
+ FFF2Table.Fields[15].Value := 25701;
+ FFF2Table.Fields[16].Value := htons(FF1TableFieldValue(13));
+ if FFF2Table.Fields[16].Value = 25189 then
+ FFF2Table.Fields[16].Value := 25957;
+ end;
+ {we may be able to match up the rest of the FF1 fields, but
+ all fields may not be present in all FF1 tables depending on
+ what version of FF the tables were created with. We will
+ assign default values for any fields not in the FF1 table.}
+
+ {AllowEncrypt?}
+ if FF1Dict.FieldCount > 14 then
+ FFF2Table.Fields[17].Value := FF1TableFieldValue(14)
+ else
+ FFF2Table.Fields[17].Value := False;
+ {ReadOnly? - Although this is the same name as the old setting
+ it a new setting to turn off all output from the server}
+ FFF2Table.Fields[18].Value := False;
+ if FF1Dict.FieldCount > 16 then begin
+ for FieldNumber := 19 to 21 do
+ FFF2Table.Fields[FieldNumber].Value :=
+ FF1TableFieldValue(FieldNumber - 3);
+ end else begin
+ {set to defaults if they weren't in the FF1 table}
+ FFF2Table.Fields[19].Value := 5000; {LastMsgInterval}
+ FFF2Table.Fields[20].Value := 2500; {KAInterval}
+ FFF2Table.Fields[21].Value := 5; {KARetries}
+ end;
+ if FF1Dict.FieldCount > 19 then
+ FFF2Table.Fields[22].Value := FF1TableFieldValue(19)
+ else
+ {set the priority to "normal" if it wasn't in the FF1 table}
+ FFF2Table.Fields[22].Value := 2;
+ {set the default TCP and IPX interfaces}
+ if not SkipProtocols then begin
+ if FF1Dict.FieldCount > 20 then
+ FFF2Table.Fields[23].Value := FF1TableFieldValue(20)
+ else
+ FFF2Table.Fields[23].Value := 0;
+ end;
+ {NoAutoSaveCfg - we set this value according to the old
+ ReadOnly setting since the functionality matches}
+ FFF2Table.Fields[24].Value := FF1TableFieldValue(15);
+ {New settings added for FF2 and their defaults}
+ FFF2Table.Fields[25].Value := ffcl_TempStorageSize; {Temp storage size (MB)}
+ FFF2Table.Fields[26].Value := True; {Garbage collection enabled}
+ FFF2Table.Fields[27].Value := ffcl_CollectionFrequency; {Garbage collection frequency (ms)}
+ {post the new record}
+ FFF2Table.Post;
+ inc(FRecordsProcessed);
+
+ {execute the OnProgress event if assigned and we're at one
+ of the progress points}
+ if ((Assigned(FOnProgress)) and
+ (FRecordsProcessed mod FProgressFrequency = 0)) then
+ FOnProgress(self);
+ {now we need to call the AfterConvert event}
+ if Assigned(FAfterConvert) then
+ FAfterConvert(self);
+ finally
+ FFF2Table.Close;
+ FDatabase.Close; {!!.01}
+ if not FCanceled then begin
+ {we didn't complete the conversion if it was canceled.}
+ if Assigned(FOnComplete) then
+ FOnComplete(self);
+ end else begin
+ {if canceled, we raise the Canceled event, delete the
+ aborted table, and reset the canceled flag.}
+ if Assigned(FOnCancel) then
+ FOnCancel(self);
+ FFF2Table.DeleteTable;
+ FCanceled := False;
+ end; {if..else}
+ FFF2Table.Free;
+ {FDatabase.Close;} {!!.01 Moved above}
+ FSession.DeleteAlias(ffc_ConvAlias);
+ FF1TableClose;
+ FF2Dict.Free;
+ FF1DictStream.Free;
+ FF1Dict.Free;
+ end;
+ end else
+ FFRaiseException(EffConverterException, ffStrResConverter,
+ ffcverrFF2TableCreate,
+ [format('Couldn''t create new %s', [FDestination])])
+end;
+{--------}
+procedure TffDataConverter.SetBufferSize(aSize : TffWord32);
+begin
+ FBufferSize := aSize;
+ if aSize <= 0 then
+ FFRaiseExceptionNoData(EffConverterException,
+ ffStrResConverter,
+ FFCvErrZeroCommitFreq);
+ FFTableAfterOpen(FFF2Table);
+end;
+{====================================================================}
+procedure InitializeUnit;
+begin
+ ffStrResConverter := nil;
+ ffStrResConverter := TffStringResource.Create(hInstance, 'FF_CONVERTER_STRINGS');
+end;
+
+procedure FinalizeUnit;
+begin
+ ffStrResConverter.Free;
+end;
+
+initialization
+ InitializeUnit;
+
+finalization
+ FinalizeUnit;
+{====================================================================}
+end.
diff --git a/components/flashfiler/sourcelaz/convert/ffcvcnst.inc b/components/flashfiler/sourcelaz/convert/ffcvcnst.inc
new file mode 100644
index 000000000..9c2bf3a67
--- /dev/null
+++ b/components/flashfiler/sourcelaz/convert/ffcvcnst.inc
@@ -0,0 +1,35 @@
+{*********************************************************}
+{* FlashFiler: FF2 Converter Stringtable constants *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{String constants}
+const
+
+ ffcverrZeroCommitFreq = $D1;
+ ffcverrFF1TableOpen = $D2;
+ ffcverrFF2TableCreate = $D3;
diff --git a/components/flashfiler/sourcelaz/convert/ffcvcnst.rc b/components/flashfiler/sourcelaz/convert/ffcvcnst.rc
new file mode 100644
index 000000000..d2d3e2cca
--- /dev/null
+++ b/components/flashfiler/sourcelaz/convert/ffcvcnst.rc
@@ -0,0 +1,31 @@
+/*********************************************************
+ * FlashFiler: FF2 Converter string table resource *
+ *********************************************************/
+
+/* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** */
+
+
+FF_CONVERTER_STRINGS RCDATA FFCVCNST.SRM
diff --git a/components/flashfiler/sourcelaz/convert/ffcvcnst.res b/components/flashfiler/sourcelaz/convert/ffcvcnst.res
new file mode 100644
index 000000000..82feddec1
Binary files /dev/null and b/components/flashfiler/sourcelaz/convert/ffcvcnst.res differ
diff --git a/components/flashfiler/sourcelaz/convert/ffcvcnst.srm b/components/flashfiler/sourcelaz/convert/ffcvcnst.srm
new file mode 100644
index 000000000..bd0549cae
Binary files /dev/null and b/components/flashfiler/sourcelaz/convert/ffcvcnst.srm differ
diff --git a/components/flashfiler/sourcelaz/convert/ffcvcnst.str b/components/flashfiler/sourcelaz/convert/ffcvcnst.str
new file mode 100644
index 000000000..3c8fd4721
--- /dev/null
+++ b/components/flashfiler/sourcelaz/convert/ffcvcnst.str
@@ -0,0 +1,34 @@
+;*********************************************************
+;* FlashFiler: FF2 Converter string table resource *
+;*********************************************************
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+#include "FFCvCnst.INC"
+
+ffcverrZeroCommitFreq, "CommitFrequency can not be set to 0"
+ffcverrFF1TableOpen, "Unable to open the FlashFiler 1 table"
+ffcverrFF2TableCreate, "%s"
diff --git a/components/flashfiler/sourcelaz/convert/fflogo.jpg b/components/flashfiler/sourcelaz/convert/fflogo.jpg
new file mode 100644
index 000000000..5439bee01
Binary files /dev/null and b/components/flashfiler/sourcelaz/convert/fflogo.jpg differ
diff --git a/components/flashfiler/sourcelaz/convert/ffmemmgr.pas b/components/flashfiler/sourcelaz/convert/ffmemmgr.pas
new file mode 100644
index 000000000..e1b005c38
--- /dev/null
+++ b/components/flashfiler/sourcelaz/convert/ffmemmgr.pas
@@ -0,0 +1,164 @@
+{*********************************************************}
+{* FlashFiler: Replacement Memory Manger used in the *}
+{* FF1 to FF2 application. This is used to prevent the *}
+{* problems associated with passing string types between *}
+{* an application. We decide not to use ShareMem because *}
+{* of the size of its required DLL. *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+unit FFMemMgr;
+
+interface
+
+function FFMMGetMem(Size : Integer) : Pointer;
+ { Allocates memory using the DLL's memory manager. }
+function FFMMFreeMem(P : Pointer) : integer;
+ { Deallocates memory using the DLL's memory manger.}
+function FFMMReallocMem(P : Pointer; Size : integer) : Pointer;
+ { Reallocates memory using the DLL's memory manager.}
+function LoadFF1DLL : boolean;
+ { Dynamically loads the FF1 DLL.}
+
+implementation
+
+uses
+ Windows, SysUtils;
+
+type
+ { These are exported functions from the FlashFiler 1 DLL. These
+ functions are used to let the DLL's memory manager manage the
+ memory for the conversion application also. We are doing this
+ to prevent the inherent problems caused by passing strings
+ between an application and a DLL. This also prevents a requirement
+ on the ShareMem DLL.}
+ TFF1GetMemFunc = procedure (var P : pointer; aSize : integer);
+ TFF1FreeMemFunc = procedure (P : pointer);
+ TFF1ReallocMemFunc = procedure (var P : pointer; aSize : integer);
+
+var
+ FOldMemMgr : TMemoryManager;
+ FNewMemMgr : TMemoryManager;
+ FDLLHandle : THandle;
+
+ { Functions mapped to FF1 DLL}
+ FF1GetMem : TFF1GetMemFunc;
+ FF1FreeMem : TFF1FreeMemFunc;
+ FF1ReallocMem : TFF1ReallocMemFunc;
+
+{====================================================================}
+function FFMMGetMem(Size : Integer) : Pointer;
+begin
+ FF1GetMem(Result, Size);
+end;
+{--------}
+function FFMMFreeMem(P : Pointer) : integer;
+begin
+ FF1FreeMem(P);
+ Result := 0;
+end;
+{--------}
+function FFMMReallocMem(P : Pointer; Size : integer) : Pointer;
+begin
+ FF1ReallocMem(P, Size);
+ Result := P;
+end;
+{--------}
+function LoadFF1DLL : boolean;
+var
+ Msg,Msg2 : string;
+ ErrorMode : word;
+begin
+ { Use setErrorMode to prohibit the Windows error dialog that appears
+ if the DLL is not found. Load the DLL dynamically. }
+ ErrorMode := SetErrorMode(SEM_NoOpenFileErrorBox);
+ FDllHandle := LoadLibrary('FF1Intfc.DLL');
+ SetErrorMode(ErrorMode);
+ if FDllHandle = 0 then begin
+ Msg := 'Unable to load FF1Intfc.DLL. ';
+ case GetLastError of
+ 0 : Msg2 := 'System out of memory, executable corrupt, ' +
+ 'or relocations invalid.';
+ 2 : Msg2 := 'File not found.';
+ 3 : Msg2 := 'Path not found.';
+ 8 : Msg2 := 'There is insufficient memory to load the DLL.';
+ 10 : Msg2 := 'The Windows version of the DLL is incorrect.';
+ else
+ Msg2 := '';
+ end; { case }
+ raise Exception.Create(Msg + Msg2 + ' Unable to run conversion.');
+ Result := False;
+ end
+ else begin
+ @FF1GetMem := GetProcAddress(FDLLHandle, 'FF1GetMem');
+ @FF1FreeMem := GetProcAddress(FDLLHandle, 'FF1FreeMem');
+ @FF1ReallocMem := GetProcAddress(FDLLHandle, 'FF1ReallocMem');
+ Result := True;
+ end;
+end;
+{--------}
+procedure InitializeUnit;
+begin
+ {setup our heap manager}
+ FNewMemMgr.GetMem := FFMMGetMem;
+ FNewMemMgr.FreeMem := FFMMFreeMem;
+ FNewMemMgr.ReallocMem := FFMMReallocMem;
+
+ {load FF1 DLL}
+ try
+ if LoadFF1DLL then begin
+ {get the original manager, replace with ours}
+ GetMemoryManager(FOldMemMgr);
+ SetMemoryManager(FNewMemMgr);
+ end;
+ except
+ on E: Exception do begin
+ MessageBox( 0, PChar(E.message),
+ 'Critical Error!',
+ MB_ICONSTOP + MB_OK);
+ raise;
+ end;
+ end;
+end;
+{--------}
+procedure FinalizeUnit;
+begin
+ {restore the original manager}
+ SetMemoryManager(FOldMemMgr);
+
+ {unload the DLL}
+ if FDllHandle <> 0 then
+ FreeLibrary(FDllHandle);
+end;
+{====================================================================}
+initialization
+ InitializeUnit;
+{--------}
+finalization
+ FinalizeUnit;
+{====================================================================}
+end.
diff --git a/components/flashfiler/sourcelaz/convert/uff1data.pas b/components/flashfiler/sourcelaz/convert/uff1data.pas
new file mode 100644
index 000000000..bcdef7b16
--- /dev/null
+++ b/components/flashfiler/sourcelaz/convert/uff1data.pas
@@ -0,0 +1,430 @@
+{*********************************************************}
+{* FlashFiler: DLL used to perform FlashFiler v1.5x *}
+{* in the conversion program that is used to convert *}
+{* v1.5x tables to v2.x tables *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+unit uFF1Data;
+
+interface
+
+uses Windows, Classes;
+
+{ The conversion program is designed to use a single memory manager
+ for the application and the FlashFiler 1.5x DLL. This is to prevent
+ the inherrent problems when using string types between an
+ an application and a DLL. We also did not want to require our users
+ to have to ship the ShareMem DLL with their applications. The three
+ following procedures allow the application to manage its memory
+ with the DLL's memory manager.}
+procedure FF1GetMem(var P : Pointer; aSize : Integer);
+procedure FF1FreeMem(P : Pointer);
+procedure FF1ReallocMem(var P : Pointer; aSize : Integer);
+
+procedure FF1TableDataDictionary(var aDict : TStream); stdcall;
+ { retrieves a FF1 data dictionary into a TStream}
+procedure FF1TableFirst; stdcall;
+ { moves to the first record in a FF1 table}
+procedure FF1TableNext; stdcall;
+ { moves to the next record in a FF1 table}
+function FF1TableFieldValue(aFieldNo : Integer): Variant; stdcall;
+ { retrieves the value of aField into a variant}
+procedure FF1DirOpen(aPath : PChar); stdcall;
+ { opens a FF1 database }
+function FF1GetAutoInc : Longint; stdcall;
+ { retrieves the auto-increment seed}
+function FF1IsFileBLOB(aFieldNo : Integer;
+ var aBuffer : array of Byte) : Boolean; stdcall;
+ { determines if a BLOB Field is a file BLOB. If so, it copies the
+ file name into aBuffer.}
+function FF1TableOpen(aTableName: PChar): Integer; stdcall;
+ { opens a FF1 table.}
+procedure FF1TableClose; stdcall;
+ { Closes a FF1 table.}
+function FF1TableEOF : Boolean; stdcall;
+ { Checks if a FF1 table is positioned at the end of file.}
+function FF1TableRecordCount : Integer; stdcall;
+ { Retrieves the record count for a FF1 table}
+
+implementation
+
+uses
+ SysUtils, FFLLDict, FFLLBase, FFSrEng, FFSrBase, FFSrCmd, FFSrHlpr,
+ FFSrComm, FFLLProt, FFTbBLOB, FFTbData, FFSTDate, FFSrMisc;
+
+{$I FFCONST.INC}
+
+type
+ PDateTime = ^TDateTime;
+
+var
+ OurServerEngine : TffServerEngine = nil;
+ DB : TffSrDatabase = nil;
+ FCursor : TffSrCursor = nil;
+ FDatabase : string = '';
+ FTableName : string = '';
+ RecordBuf : PffByteArray = nil;
+ CursorTableRefNr : TffWord32;
+
+const ffc_AliasClientID = -1;
+{====================================================================}
+procedure FF1GetMem(var P : pointer; aSize : Integer);
+begin
+ GetMem(P, aSize);
+end;
+{--------}
+procedure FF1FreeMem(P : Pointer);
+begin
+ FreeMem(P);
+end;
+{--------}
+procedure FF1ReallocMem(var P : pointer; aSize : Integer);
+begin
+ ReallocMem(P, aSize);
+end;
+{--------}
+function FF1GetAutoInc : Longint;
+var
+ FileBlock : PffBlock;
+begin
+ FileBlock := OurServerEngine.BufferManager.GetBlock(FCursor.Table.Files[0] , 0, False);
+ Move(FileBlock^[80], Result, SizeOf(Result));
+end;
+{--------}
+function FF1IsFileBLOB(aFieldNo : Integer; var aBuffer : array of byte) : Boolean;
+var
+ FileName : TffFullFileName;
+ BLOBNr : TffWord32;
+ BLOBIsNull : Boolean;
+begin {Assumption: this is only being called for TBLOBFields}
+ with FCursor.Table do
+ begin
+ Dictionary.GetRecordField(aFieldNo, RecordBuf, BLOBIsNull,
+ PffByteArray(@BLOBNr));
+ result := (not BLOBIsNull) and
+ FFTblGetFileNameBLOB(Files[Dictionary.BLOBFileNumber],
+ BLOBNr, FileName);
+ end;
+ if result then
+ begin
+ Move(FileName[0], aBuffer[0], succ(byte(FileName[0])));
+ end;
+end;
+{--------}
+procedure FF1TableDataDictionary(var aDict: TStream);
+begin
+ OurServerEngine.TableGetDictionary(FCursor.Database.DatabaseID,
+ FTableName, false, aDict);
+end;
+{--------}
+procedure FF1TableFirst;
+begin
+ CursorTableRefNr := 0;
+ FF1TableNext;
+end;
+{--------}
+procedure FF1TableNext;
+begin
+ FCursor.Table.GetNextRecordSeq(CursorTableRefNr, RecordBuf);
+end;
+{--------}
+function FF1TableFieldValue(aFieldNo : Integer): Variant;
+var
+ FldIsNull : Boolean;
+ Buffer : array[0..8192] of Char; { 8192=dsMaxStringSize in DB.pas}
+ BufferW : array[0..8192] of WideChar; {!!.11}
+
+ {--------}
+ function GetSTDate : TDateTime;
+ var
+ STD : TStDate;
+ begin
+ FCursor.Table.Dictionary.GetRecordField(aFieldNo, RecordBuf, FldIsNull, @STD);
+ result := StDateToDateTime(STD);
+ end;
+ {--------}
+ function GetSTTime : TDateTime;
+ var
+ STT: TStTime;
+ begin
+ FCursor.Table.Dictionary.GetRecordField(aFieldNo, RecordBuf, FldIsNull, @STT);
+ result:= StTimeToDateTime(STT);
+ end;
+ {--------}
+ function GetBLOBAsVariant: Variant;
+ var
+ SourceBLOBNr : TffWord32;
+ BLOBLen : Longint;
+ Err : DWORD;
+ Buff : PChar;
+ s : string;
+ {--------}
+ function GetBLOBSize : Longint;
+ begin
+ Err:= OurServerEngine.BLOBGetLength(FCursor.CursorID,
+ SourceBLOBNr, result);
+ if Err <> 0 then
+ result := 0;
+ end;
+ {--------}
+ procedure ReadBLOB;
+ var
+ BytesRead : Longint;
+ begin
+ {fetch BLOB Len BlobLen into s}
+ Err := OurServerEngine.BLOBRead(FCursor.CursorID,
+ SourceBLOBNr, 0,
+ BLOBLen, Buff^, BytesRead);
+ end;
+ {--------}
+ begin
+ with FCursor.Table.Dictionary do
+ begin
+ GetRecordField(aFieldNo, RecordBuf, FldIsNull, @SourceBLOBNr);
+ BLOBLen := GetBLOBSize;
+ if (BLOBLen > 0) and (SourceBLOBNr <> 0) then begin
+ GetMem(Buff, BLOBLen+1);
+ try
+ ReadBLOB;
+ Buff[BLOBLen] := #0;
+ SetString(s, Buff, BLOBLen);
+ result := s;
+ finally
+ FreeMem(Buff, BLOBLen + 1);
+ end;
+ end else
+ Result:= Null;
+ end;
+ end;
+ {--------}
+ function GetByteArrayAsVariant : Variant;
+ var
+ Data : Pointer;
+ begin
+ with FCursor.Table.Dictionary do
+ begin
+ Result := VarArrayCreate([0, FieldLength[aFieldNo] - 1], varByte);
+ Data:= VarArrayLock(Result);
+ try
+ GetRecordField(aFieldNo, RecordBuf, FldIsNull, Data); {!!.02}
+ finally
+ VarArrayUnlock(Result);
+ end;
+ end;
+ end;
+ {--------}
+ function GetShortStringAsVariant : Variant;
+ var
+ S : string[255];
+ begin
+ with FCursor.Table.Dictionary do
+ begin
+ GetRecordField(aFieldNo, RecordBuf, FldIsNull, @S);
+ Result:= S;
+ end;
+ end;
+ {--------}
+ function GetStringAsVariant : Variant;
+ var
+ S : string;
+ begin
+ with FCursor.Table.Dictionary do
+ begin
+ SetLength(S, FieldLength[aFieldNo]);
+ GetRecordField(aFieldNo, RecordBuf, FldIsNull, @Buffer);
+ S := Buffer;
+ Result := S;
+ end;
+ end;
+ {--------}
+{Begin !!.11}
+ function GetWideStringAsVariant : Variant;
+ var
+ S : Widestring;
+ begin
+ with FCursor.Table.Dictionary do
+ begin
+ SetLength(S, FieldLength[aFieldNo]);
+ GetRecordField(aFieldNo, RecordBuf, FldIsNull, @BufferW);
+ S := BufferW;
+ Result := S;
+ end;
+ end;
+{End !!.11}
+ {--------}
+
+type
+ PBoolean = ^Boolean;
+var
+ P : PChar;
+ Wide : array [0..1] of WideChar;
+begin
+ with FCursor.Table.Dictionary do
+ begin
+ GetRecordField(aFieldNo, RecordBuf, FldIsNull, nil);
+ if FldIsNull then begin
+ Result:= Null;
+ exit;
+ end;
+ P := PChar(RecordBuf) + FieldOffset[aFieldNo];
+ case FieldType[aFieldNo] of
+ fftBoolean : result:= PBoolean(p)^;
+ fftChar :
+ begin
+ result:= P^;
+ end;
+ fftWideChar :
+ begin
+ StringToWideChar(StrPas(P), Wide, 2);
+ result := Wide[0];
+ end;
+ fftByte : result := PByte(P)^;
+ fftWord16 : result := PWord(P)^;
+ fftWord32 : result := PffWord32(P)^;
+ fftInt8 : result := Shortint(P^);
+ fftInt16 : result := PSmallint(P)^;
+ fftInt32 : result := PLongint(P)^;
+ fftAutoInc : result := PLongint(P)^;
+ fftSingle : result := PSingle(P)^;
+ fftDouble : result := PDouble(P)^;
+ fftExtended : result := PExtended(P)^;
+ fftComp : result := Comp(Pointer(P)^);
+ fftCurrency : result := PCurrency(P)^;
+ fftStDate : result := VarFromDateTime(GetSTDate);
+ fftStTime : result := VarFromDateTime(GetSTTime);
+ fftDateTime : result := PDateTime(P)^ - 693594;
+ fftBLOB..fftBLOBTypedBin : result := GetBLOBAsVariant;
+ fftByteArray : result := GetByteArrayAsVariant;
+ fftShortString, fftShortAnsiStr :
+ result := GetShortStringAsVariant;
+ fftNullString, fftNullAnsiStr :
+ result := GetStringAsVariant;
+ fftWideString : result := GetWideStringAsVariant; {!!.11}
+ end;
+ end;
+end;
+{--------}
+procedure FF1TableClose;
+begin
+ if RecordBuf <> nil then
+ ReAllocMem(RecordBuf, 0);
+ if (OurServerEngine<>nil) and (FCursor<>nil) then
+ OurServerEngine.CursorClose(FCursor.CursorID);
+ FCursor:= nil;
+ DB.free;
+ DB:= nil;
+ OurServerEngine.Free;
+ OurServerEngine := nil;
+end;
+{--------}
+function FF1TableEOF : Boolean;
+begin
+ Result := CursorTableRefNr = 0;
+end;
+{--------}
+function FF1TableRecordCount : Integer;
+var
+ RecordInfo: TffRecordInfo;
+begin
+ FFTblGetRecordInfo(FCursor.Table.Files[0],RecordInfo);
+ Result := RecordInfo.riRecCount;
+end;
+{--------}
+procedure FF1DirOpen(aPath: PChar);
+begin
+ FDatabase:= aPath;
+end;
+{--------}
+function FF1TableOpen(aTableName : PChar) : Integer;
+var
+ Hash, Err : TffWord32;
+ CursorID : Longint;
+begin
+ if RecordBuf <> nil then
+ FF1TableClose;
+ Result := -1;
+ FTableName := aTableName;
+ try
+ if OurServerEngine = nil then begin
+ OurServerEngine:= TffServerEngine.Create;
+ { do not create FF server tables}
+ OurServerEngine.Configuration.GeneralInfo^.giReadOnly:= true;
+ if OurServerEngine.Configuration.UserList.Count=0 then
+ FFCreateAdminUser;
+ FFProcessAliasScript;
+ {create a client}
+ Err:= OurServerEngine.ClientAdd(ffc_AliasClientID, '', 'admin', Hash);
+ if Err <> 0 then
+ Exit;
+ {open a no alias database}
+ Err := OurServerEngine.DatabaseOpenNoAlias(ffc_AliasClientID,
+ FDatabase,
+ omReadWrite,
+ smExclusive,
+ DB);
+ if Err <> 0 then begin
+ OurServerEngine.ClientRemove(ffc_AliasClientID);
+ Exit;
+ end;
+ end;
+ Err := OurServerEngine.TableOpen(DB.DatabaseID,
+ ChangeFileExt(aTableName, ''),
+ False,
+ '',
+ 0,
+ omReadOnly, {!!.01}
+ smShared,
+ CursorID,
+ nil);
+ {Start !!.01}
+ { If we receive an error about a bad stream block, we need to see
+ if this is an encrypted server table. We do this by telling
+ the server engine to open the table for the server (3rd
+ parameter). NOTE: This error always comes about this way because
+ the stream block is always the first encrypted block in an
+ encrypted table.}
+ if Err = DBIERR_FF_BadStreamBlock then
+ Err := OurServerEngine.TableOpen(DB.DatabaseID,
+ ChangeFileExt(aTableName, ''),
+ True,
+ '',
+ 0,
+ omReadOnly, {!!.01}
+ smShared,
+ CursorID,
+ nil); {End !!.01}
+ if Err <> 0 then
+ exit;
+ OurServerEngine.CheckCursorIDAndGet(CursorID, FCursor);
+ ReAllocMem(RecordBuf, FCursor.Table.Dictionary.RecordLength);
+ Result:= 0;
+ except
+ end;
+end;
+{====================================================================}
+end.
diff --git a/components/flashfiler/sourcelaz/convert/uff2cnv.dfm b/components/flashfiler/sourcelaz/convert/uff2cnv.dfm
new file mode 100644
index 000000000..94e046fb2
Binary files /dev/null and b/components/flashfiler/sourcelaz/convert/uff2cnv.dfm differ
diff --git a/components/flashfiler/sourcelaz/convert/uff2cnv.pas b/components/flashfiler/sourcelaz/convert/uff2cnv.pas
new file mode 100644
index 000000000..c8f6f4930
--- /dev/null
+++ b/components/flashfiler/sourcelaz/convert/uff2cnv.pas
@@ -0,0 +1,648 @@
+{*********************************************************}
+{* FlashFiler: Application used to convert FF1 tables to *}
+{* FF2 tables. *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+unit uFF2Cnv;
+
+{$I FFDEFINE.INC} {!!.01}
+
+{ NOTE: The following define kills a warning in Delphi6. } {!!.06}
+{$IFDEF DCC6OrLater} {!!.06}
+{$WARN UNIT_PLATFORM OFF} {!!.06}
+{$ENDIF} {!!.06}
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
+ FileCtrl,
+ StdCtrls, ComCtrls, ExtCtrls, FFConvrt, FFLLBase, fflleng,
+ ffsrIntm, FFSrEng, FFLLLog, uFFNet, FFLLComp,
+ {$IFDEF DCC4OrLater}
+ ImgList,
+ {$ENDIF}
+ ToolWin, Menus;
+
+type
+ TfrmFF2Conv = class(TForm)
+ pnlStatBars: TPanel;
+ ProgressBar: TProgressBar;
+ StatusBar: TStatusBar;
+ pnlSrcTgt: TPanel;
+ gbSource: TGroupBox;
+ srcFiles: TFileListBox;
+ gbDest: TGroupBox;
+ pnlStatusView: TPanel;
+ lvStatus: TListView;
+ splSplitter: TSplitter;
+ pnlSrcDriveDir: TPanel;
+ srcDirectory: TDirectoryListBox;
+ pnlSrcDrive: TPanel;
+ srcDrive: TDriveComboBox;
+ pnlTgtDrvDir: TPanel;
+ tgtDirectory: TDirectoryListBox;
+ pnlTgtDrive: TPanel;
+ tgtFiles: TFileListBox;
+ tgtDrive: TDriveComboBox;
+ MainMenu: TMainMenu;
+ mnuFile: TMenuItem;
+ mnuFileExit: TMenuItem;
+ ToolBar1: TToolBar;
+ btnExecute: TToolButton;
+ imMain: TImageList;
+ Panel1: TPanel;
+ Panel2: TPanel;
+ mnuFileSep: TMenuItem;
+ mnuFileConvert: TMenuItem;
+ mnuAbout: TMenuItem;
+ mnuHelp: TMenuItem;
+ procedure btnConvertClick(Sender: TObject);
+ procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
+ procedure FormCreate(Sender: TObject);
+ procedure FormDestroy(Sender: TObject);
+ procedure FormShow(Sender: TObject);
+ procedure SetControls(aIsConverting : Boolean);
+ function GetSourceDirectory : string;
+ function GetSourceDrive : char;
+ function GetTableSize(aFile : string) : string;
+ function GetTargetDirectory : string;
+ function GetTargetDrive : char;
+ procedure SetSourceDirectory(const aDirectory : string);
+ procedure SetSourceDrive(aDrive : char);
+ procedure SetTargetDirectory(const aDirectory : string);
+ procedure SetTargetDrive(aDrive : char);
+ procedure srcDriveChange(Sender : TObject);
+ procedure tgtDriveChange(Sender : TObject);
+ procedure mnuFileExitClick(Sender : TObject);
+ procedure mnuAboutClick(Sender: TObject);
+ private
+ { Private declarations }
+ public
+ { Public declarations }
+ procedure BeforeConvert(aSender : TffDataConverter);
+ function CheckForOverwrites : Boolean;
+ {Check if a user is overwritting files in the destination}
+ procedure OnCancel(aSender : TffDataConverter);
+ procedure OnComplete(aSender : TffDataConverter);
+ procedure OnProgress(aSender : TffDataConverter);
+ procedure OnNetBios(aSender : TffDataConverter;
+ var aCanceled : Boolean;
+ var aOptions : TffProtOptions);
+ property SourceDirectory : string
+ read GetSourceDirectory
+ write SetSourceDirectory;
+ property SourceDrive : char
+ read GetSourceDrive
+ write SetSourceDrive;
+ property TargetDirectory : string
+ read GetTargetDirectory
+ write SetTargetDirectory;
+ property TargetDrive : char
+ read GetTargetDrive
+ write SetTargetDrive;
+ end;
+
+var
+ frmFF2Conv : TfrmFF2Conv;
+ TableConverter : TffDataConverter;
+ ServerEngine : TffServerEngine;
+ StartTime : DWord;
+ CurrentTable : Integer;
+ SelTableCount : Integer;
+ Canceled : Boolean;
+
+implementation
+
+uses
+ FFLLWsck, FFAbout;
+
+const
+ cnExecute = 0;
+ cnCancel = 1;
+ UpdateFrequency = 100;
+
+{$R *.DFM}
+
+{====================================================================}
+procedure TfrmFF2Conv.BeforeConvert(aSender : TffDataConverter);
+var
+ TotalRecords : TffWord32;
+begin
+ TotalRecords := aSender.TotalRecords;
+
+ {setup the status bar and progress bar}
+ StatusBar.Panels[1].Text := 'Adding records';
+ StatusBar.Panels[2].Text := 'Record 0 of ' +
+ FFCommaizeChL(TotalRecords, ThousandSeparator);
+ ProgressBar.Position := 0;
+ {initialize our progress bar not that we can get total records from
+ the converter}
+ ProgressBar.Min := 0;
+ ProgressBar.Max := TotalRecords;
+ if TotalRecords <> 0 then
+ ProgressBar.Step := UpdateFrequency
+ else
+ ProgressBar.Step := TotalRecords;
+ Application.ProcessMessages;
+end;
+{--------}
+procedure TfrmFF2Conv.btnConvertClick(Sender : TObject);
+var
+ ListItem : TListItem;
+ SourceFile : string;
+ TargetDir : string;
+ i : Integer;
+begin
+ {if the Convert button has been changed to a Cancel then we need to
+ cancel the current conversion.}
+ if btnExecute.ImageIndex = cnCancel then begin
+ {tell the converter that we're canceling}
+ TableConverter.Cancel;
+ Canceled := True;
+ Application.ProcessMessages;
+ SetControls(False);
+ exit;
+ end;
+ Canceled := False;
+ SetControls(True);
+ {Ensure we are not overwriting any tables that the user doesn't want
+ overwritten. If this isn't a problem, continue.}
+ if CheckForOverwrites then begin
+ {make an entry for each selected table in the status view}
+ lvStatus.Items.Clear;
+ for i := 0 to pred(srcFiles.Items.Count) do begin
+ if srcFiles.Selected[i] then begin
+ ListItem := lvStatus.Items.Add;
+ ListItem.Caption := srcFiles.Items[i];
+ ListItem.SubItems.Add('0');
+ SourceFile := srcDirectory.Directory + '\' + srcFiles.Items[i];
+ ListItem.SubItems.Add(GetTableSize(SourceFile));
+ ListItem.SubItems.Add('...');
+ ListItem.SubItems.Add('...');
+ ListItem.SubItems.Add('Queued');
+ end;
+ end;
+ SelTableCount := srcFiles.SelCount;
+ TargetDir := tgtDirectory.Directory;
+ CurrentTable := -1;
+ i := -1;
+ while ((i < pred(srcFiles.Items.Count)) and (not Canceled)) do begin
+ inc(i);
+ if srcFiles.Selected[i] then begin
+ inc(CurrentTable);
+ {change the status of the table about to be converted}
+ lvStatus.Items[CurrentTable].SubItems[4] := 'Converting data';
+ {update the status bar}
+ StatusBar.Panels[0].Text := format('Table %d of %d in progress',
+ [succ(CurrentTable), SelTableCount]);
+ {build the complete path to the table we're updating}
+ SourceFile := srcDirectory.Directory + '\' + srcFiles.Items[i];
+ {convert the table}
+ StartTime := GetTickCount;
+ try
+ TableConverter.Convert(SourceFile, TargetDir);
+ except
+ on E: Exception do begin
+ lvStatus.Items[CurrentTable].SubItems[4] := 'FAILED';
+ MessageDlg(format('ERROR: Unable to convert %s.' + #13#10 +
+ '[%s]',
+ [lvStatus.Items[CurrentTable].Caption,
+ E.Message]),
+ mtError, [mbOK], 0);
+ Break; {!!.07}
+ end;
+ end;
+ {if the table is successfully converted, deselected it from
+ the list of source files}
+ srcFiles.Selected[i] := False;
+ {update the list of target files so that it will show the new
+ table}
+ tgtFiles.Update;
+ end;
+ end;
+ end;
+ SetControls(False);
+end;
+{--------}
+function TfrmFF2Conv.CheckForOverwrites : Boolean;
+var
+ i, k : Integer;
+begin
+ Result := True;
+ {check if any of the selected files in srcFiles have the same name
+ as any files in the destination directory.}
+ for i := 0 to pred(srcFiles.Items.Count) do begin
+ {is this srcFile selected?}
+ if srcFiles.Selected[i] then
+ {if selected, we need to check it against every file in the
+ destination directory.}
+ for k := 0 to pred(tgtFiles.Items.Count) do begin
+ {if we find a match, ask the user if it's OK to overwrite the
+ files in the destination directory.}
+ if ChangeFileExt(srcFiles.Items[i], '.' + ffc_ExtForData) = {!!.03}
+ tgtFiles.Items[k] then begin {!!.03}
+ Result := MessageDlg('You are going to overwrite tables ' +
+ 'in your destination directory. ' +
+ 'Continue?', mtWarning,
+ [mbYes, mbNo], 0) = mrYes;
+ exit; {we only want to ask once}
+ end;
+ end;
+ end;
+end;
+{--------}
+procedure TfrmFF2Conv.FormCloseQuery(Sender : TObject;
+ var CanClose : Boolean);
+begin
+ {Clean up before we close}
+ srcFiles.Items.Clear;
+ {call ConvertClick}
+ SetControls(True);
+ btnConvertClick(self);
+ {when it completes (btnConvert.Caption = &Convert) we can close}
+ while btnExecute.ImageIndex = cnCancel do
+ CanClose := False;
+ CanClose := True;
+end;
+{--------}
+procedure TfrmFF2Conv.FormCreate(Sender : TObject);
+begin
+ {startup our server engine}
+ ServerEngine := TffServerEngine.Create(self);
+ ServerEngine.Configuration.GeneralInfo.giNoAutoSaveCfg := True;
+ ServerEngine.State := ffesStarted;
+ {setup our table converter and its events}
+ TableConverter := TffDataConverter.Create(ServerEngine);
+ TableConverter.ProgressFrequency := UpdateFrequency;
+ {Give ourself a 5 meg buffer on the FF2 server}
+ TableConverter.BufferSize := 1024 * 1024;
+ TableConverter.BeforeConvert := BeforeConvert;
+ TableConverter.OnCancel := OnCancel;
+ TableConverter.OnComplete := OnComplete;
+ TableConverter.OnProgress := OnProgress;
+ TableConverter.OnNetBIOS := OnNetBIOS;
+end;
+{--------}
+procedure TfrmFF2Conv.FormDestroy(Sender : TObject);
+begin
+ TableConverter.Free;
+ ServerEngine.State := ffesShuttingDown;
+ ServerEngine.Free;
+end;
+{--------}
+procedure TfrmFF2Conv.FormShow(Sender : TObject);
+begin
+ srcDrive.SetFocus;
+end;
+{--------}
+function TfrmFF2Conv.GetSourceDirectory : string;
+begin
+ Result := srcDirectory.Directory;
+end;
+{--------}
+function TfrmFF2Conv.GetSourceDrive : Char;
+begin
+ Result := srcDrive.Drive;
+end;
+{--------}
+function TfrmFF2Conv.GetTableSize(aFile : string) : string;
+var
+ {TheFile : file of Byte;} {!!.01 Deleted}
+ FileHandle : DWord; {!!.01 Added}
+begin
+ FileHandle := CreateFile(PChar(aFile), {!!.01 Start - Added}
+ GENERIC_READ,
+ 0,
+ nil,
+ OPEN_EXISTING,
+ FILE_ATTRIBUTE_NORMAL,
+ 0);
+ try
+ try
+ Result := FFCommaizeChL(GetFileSize(FileHandle, nil), ThousandSeparator);
+ except
+ Result := '0';
+ end;
+ finally
+ CloseHandle(FileHandle);
+ end; {!!.01 End - Added}
+
+ {!!.01 Start - Deleted}
+{ AssignFile(TheFile, aFile);
+ try
+ Reset(TheFile);
+ try
+ Result := FFCommaizeChL(FileSize(TheFile), ThousandSeparator);
+ finally
+ CloseFile(TheFile);
+ end;
+ except
+ MessageDlg('Unable to read source file', mtError, [mbOK], 0);
+ Canceled := True;
+ Result := '';
+ end;} {!!.01 End - Deleted}
+end;
+{--------}
+function TfrmFF2Conv.GetTargetDirectory : string;
+begin
+ Result := tgtDirectory.Directory;
+end;
+{--------}
+function TfrmFF2Conv.GetTargetDrive : char;
+begin
+ Result := tgtDrive.Drive;
+end;
+{--------}
+procedure TfrmFF2Conv.OnCancel(aSender : TffDataConverter);
+var
+ i : Integer;
+begin
+ if lvStatus.Items.Count > 0 then begin
+ {update the status view}
+ lvStatus.Items[CurrentTable].SubItems[4] := 'Aborted';
+ for i := CurrentTable to pred(SelTableCount) do begin
+ lvStatus.Items[i].SubItems[4] := 'Canceled';
+ end;
+ {update the progress bar}
+ ProgressBar.Position := 0;
+ {update the status bar}
+ StatusBar.Panels[0].Text := format('Canceled on table %d of %d',
+ [succ(CurrentTable), SelTableCount]);
+ StatusBar.Panels[2].Text := 'CONVERSION WAS NOT SUCCESSFUL!';
+ end;
+ Canceled := True;
+end;
+{--------}
+procedure TfrmFF2Conv.OnComplete(aSender : TffDataConverter);
+var
+ RecordsProcessed : Integer;
+ TotalRecords : Integer;
+begin
+ RecordsProcessed := aSender.RecordsProcessed;
+ TotalRecords := aSender.TotalRecords;
+ {update the status view}
+ lvStatus.Items[CurrentTable].SubItems[3] :=
+ FFCommaizeChL(GetTickCount - StartTime, ThousandSeparator);
+ lvStatus.Items[CurrentTable].SubItems[0] := FFCommaizeChL(RecordsProcessed, ThousandSeparator) +
+ ' of ' +
+ FFCommaizeChL(TotalRecords, ThousandSeparator);
+ lvStatus.Items[CurrentTable].SubItems[4] := 'Converted';
+ {setup the status bar and progress bar}
+ StatusBar.Panels[0].Text := format('Table %d of %d converted',
+ [succ(CurrentTable), SelTableCount]);
+ StatusBar.Panels[1].Text := format('%s converted',
+ [ExtractFileName(aSender.Source)]);
+ StatusBar.Panels[2].Text := FFCommaizeChL(RecordsProcessed, ThousandSeparator) +
+ ' Records converted';
+ ProgressBar.Position := RecordsProcessed;
+ {set total time}
+ lvStatus.Items[CurrentTable].SubItems[3] :=
+ FFCommaizeChL(GetTickCount - StartTime, ThousandSeparator);
+ {set new file size}
+ lvStatus.Items[CurrentTable].SubItems[2] := GetTableSize(aSender.Destination);
+ {change status to Completed}
+ lvStatus.Items[CurrentTable].SubItems[4] := 'Successfully completed';
+ lvStatus.Items[CurrentTable].SubItems[0] := FFCommaizeChL(RecordsProcessed, ThousandSeparator) +
+ ' of ' +
+ FFCommaizeChL(TotalRecords, ThousandSeparator);
+ Application.ProcessMessages;
+end;
+{--------}
+procedure TfrmFF2Conv.OnProgress(aSender : TffDataConverter);
+var
+ RecordsProcessed : Integer;
+ TotalRecords : Integer;
+begin
+ RecordsProcessed := aSender.RecordsProcessed;
+ TotalRecords := aSender.TotalRecords;
+ {step the progress bar}
+ StatusBar.Panels[2].Text := 'Record ' +
+ FFCommaizeChL(RecordsProcessed, ThousandSeparator) +
+ ' of ' +
+ FFCommaizeChL(TotalRecords, ThousandSeparator);
+ {update records converted in status view}
+ lvStatus.Items[CurrentTable].SubItems[0] := FFCommaizeChL(RecordsProcessed, ThousandSeparator) +
+ ' of ' +
+ FFCommaizeChL(TotalRecords, ThousandSeparator);
+ ProgressBar.StepIt;
+ Application.ProcessMessages;
+end;
+{--------}
+procedure TfrmFF2Conv.OnNetBios(aSender : TffDataConverter;
+ var aCanceled : Boolean;
+ var aOptions : TffProtOptions);
+var
+ ProtForm : TfrmFFTransport;
+begin
+ { This only occurs when we are converting a system table that uses
+ NetBIOS as the default protocol. Since FlashFiler 2 doesn't
+ support the NetBIOS protocol. We are going to present the user a
+ dialog box that lets the user choose a new protocol and options.}
+ aCanceled := False;
+ ProtForm := TfrmFFTransport.Create(self);
+ try
+ {setup the protocol form with the values given in aOptions}
+ with ProtForm, aOptions do begin
+ cbxSUEnabled.Checked := IsSingleUser;
+ cbxIPXEnabled.Checked := IsIPXSPX;
+ cbxIPXListen.Checked := IPXSPXLFB;
+ cbxTCPEnabled.Checked := IsTCPIP;
+ cbxTCPListen.Checked := TCPIPLFB;
+ edtTCPPort.Text := IntToStr(TCPIPPort);
+ edtUDPServer.Text := IntToStr(UDPPortSr);
+ edtUDPClient.Text := IntToStr(UDPPortCl);
+ edtIPXSr.Text := IntToStr(IPXSocketSr);
+ edtIPXCl.Text := IntToStr(IPXSocketCl);
+ edtSPX.Text := IntToStr(SPXSocket);
+ cbTCPIntf.ItemIndex := TCPIntf + 1;
+ TCPIntfcNum := TCPIntf + 1;
+ end;
+ if ProtForm.ShowModal = MrOK then begin
+ aCanceled := False;
+ {update changes to the protocol form in aOptions}
+ with ProtForm, aOptions do begin
+ IsSingleUser := cbxSUEnabled.Checked;
+ IsIPXSPX := cbxIPXEnabled.Checked;
+ IPXSPXLFB := cbxIPXListen.Checked;
+ IsTCPIP := cbxTCPEnabled.Checked;
+ TCPIPLFB := cbxTCPListen.Checked;
+ TCPIPPort := StrToInt(edtTCPPort.Text);
+ UDPPortSr := StrToInt(edtUDPServer.Text);
+ UDPPortCl := StrToInt(edtUDPClient.Text);
+ IPXSocketSr := StrToInt(edtIPXSr.Text);
+ IPXSocketCl := StrToInt(edtIPXCl.Text);
+ SPXSocket := StrToInt(edtSPX.Text);
+ TCPIntf := pred(cbTCPIntf.ItemIndex);
+ end;
+ end else
+ aCanceled := True;
+ finally
+ ProtForm.Free;
+ end;
+end;
+{--------}
+procedure TfrmFF2Conv.SetControls(aIsConverting : Boolean);
+begin
+ if aIsConverting then begin
+ btnExecute.ImageIndex := cnCancel;
+ mnuFileConvert.Caption := '&Cancel';
+ mnuFileConvert.ShortCut := ShortCut(Word('C'), [ssCtrl]);;
+ end
+ else begin
+ btnExecute.ImageIndex := cnExecute;
+ mnuFileConvert.Caption := '&Convert';
+ mnuFileConvert.ShortCut := ShortCut(Word('E'), [ssCtrl]);;
+ end;
+
+ mnuFileExit.Enabled := not aIsConverting;
+ gbSource.Enabled := not aIsConverting;
+ gbDest.Enabled := not aIsConverting;
+end;
+{--------}
+procedure TfrmFF2Conv.SetSourceDirectory(const aDirectory : string);
+var
+ OldDirectory : string;
+begin
+ OldDirectory := srcDirectory.Directory;
+ try
+ srcDrive.Drive := ExtractFileDrive(aDirectory)[1];
+ srcDirectory.Drive := ExtractFileDrive(aDirectory)[1];
+ srcDirectory.Directory := aDirectory;
+ except
+ on E : EInOutError do begin
+ MessageDlg(aDirectory + ' doesn''t exist. Please choose ' +
+ 'another directory.', mtWarning, [mbOK], 0);
+ srcDirectory.Directory := OldDirectory;
+ end;
+ end;
+end;
+{--------}
+procedure TfrmFF2Conv.SetSourceDrive(aDrive : char);
+begin
+ {set to both components and check for EInOutError}
+ try
+ srcDrive.Drive := aDrive;
+ srcDirectory.Drive := aDrive;
+ except
+ on E : EInOutError do begin
+ MessageDlg(aDrive + ' drive doesn''t exist. Please choose ' +
+ 'another drive.', mtWarning, [mbOK], 0);
+ end;
+ end;
+end;
+{--------}
+procedure TfrmFF2Conv.SetTargetDirectory(const aDirectory : string);
+var
+ OldDirectory : string;
+begin
+ {set to both components and check for EInOutError}
+ OldDirectory := tgtDirectory.Directory;
+ try
+ tgtDrive.Drive := ExtractFileDrive(aDirectory)[1];
+ tgtDirectory.Drive := ExtractFileDrive(aDirectory)[1];
+ tgtDirectory.Directory := aDirectory;
+ except
+ on E : EInOutError do begin
+ MessageDlg(aDirectory + ' doesn''t exist. Please choose ' +
+ 'another directory.', mtWarning, [mbOK], 0);
+ tgtDirectory.Directory := OldDirectory;
+ end;
+ end;
+end;
+{--------}
+procedure TfrmFF2Conv.SetTargetDrive(aDrive : char);
+var
+ OldDrive : char;
+begin
+ OldDrive := tgtDrive.Drive;
+ try
+ tgtDrive.Drive := aDrive;
+ tgtDirectory.Drive := aDrive;
+ except
+ on E : EInOutError do begin
+ MessageDlg(aDrive + ' drive doesn''t exist. Please choose ' +
+ 'another drive.', mtWarning, [mbOK], 0);
+ tgtDrive.Drive := OldDrive;
+ end;
+ end;
+end;
+{--------}
+procedure TfrmFF2Conv.srcDriveChange(Sender : TObject);
+var
+ OldDrive : char;
+begin
+ OldDrive := srcDirectory.Drive;
+ try
+ srcDirectory.Drive := srcDrive.Drive;
+ except
+ on E : EInOutError do begin
+ MessageDlg(srcDrive.Drive + ' drive doesn''t exist. Please choose ' +
+ 'another drive.', mtWarning, [mbOK], 0);
+ srcDirectory.Drive := OldDrive;
+ srcDrive.Drive := OldDrive;
+ end;
+ end;
+ FocusControl(srcDirectory);
+end;
+{--------}
+procedure TfrmFF2Conv.tgtDriveChange(Sender : TObject);
+var
+ OldDrive : char;
+begin
+ OldDrive := srcDirectory.Drive;
+ try
+ tgtDirectory.Drive := tgtDrive.Drive;
+ except
+ on E : EInOutError do begin
+ MessageDlg(tgtDrive.Drive + ' drive doesn''t exist. Please choose ' +
+ 'another drive.', mtWarning, [mbOK], 0);
+ tgtDirectory.Drive := OldDrive;
+ tgtDrive.Drive := OldDrive;
+ end;
+ end;
+ FocusControl(tgtDirectory);
+end;
+{====================================================================}
+procedure TfrmFF2Conv.mnuFileExitClick(Sender : TObject);
+begin
+ Close;
+end;
+{--------}
+procedure TfrmFF2Conv.mnuAboutClick(Sender: TObject); {new !!.07}
+begin
+ with TFFAboutBox.Create(nil) do
+ try
+ ShowModal;
+ finally
+ Free;
+ end;
+end;
+{====================================================================}
+
+end.
diff --git a/components/flashfiler/sourcelaz/convert/uffnet.dfm b/components/flashfiler/sourcelaz/convert/uffnet.dfm
new file mode 100644
index 000000000..b0f337409
Binary files /dev/null and b/components/flashfiler/sourcelaz/convert/uffnet.dfm differ
diff --git a/components/flashfiler/sourcelaz/convert/uffnet.pas b/components/flashfiler/sourcelaz/convert/uffnet.pas
new file mode 100644
index 000000000..badab9a68
--- /dev/null
+++ b/components/flashfiler/sourcelaz/convert/uffnet.pas
@@ -0,0 +1,95 @@
+{*********************************************************}
+{* FlashFiler: Form used to set for FF1 to FF2 *}
+{* conversion program. *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+unit uFFNet;
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
+ Dialogs, StdCtrls, ExtCtrls;
+
+type
+ TfrmFFTransport = class(TForm)
+ gbSingle: TGroupBox;
+ gbIPXSPX: TGroupBox;
+ gbTCPIP: TGroupBox;
+ cbxSUEnabled: TCheckBox;
+ cbxIPXEnabled: TCheckBox;
+ cbxIPXListen: TCheckBox;
+ cbxTCPEnabled: TCheckBox;
+ cbxTCPListen: TCheckBox;
+ btnOK: TButton;
+ btnCancel: TButton;
+ lblTCPNic: TLabel;
+ cbTCPIntf: TComboBox;
+ lblTCPPort: TLabel;
+ lblUDPSr: TLabel;
+ lblUDPCl: TLabel;
+ edtTCPPort: TEdit;
+ edtUDPServer: TEdit;
+ edtUDPClient: TEdit;
+ lblIPXSocket: TLabel;
+ lblIPXClient: TLabel;
+ lblSPX: TLabel;
+ edtIPXSr: TEdit;
+ edtIPXCl: TEdit;
+ edtSPX: TEdit;
+ procedure FormShow(Sender: TObject);
+ private
+ { Private declarations }
+ public
+ { Public declarations }
+ TCPIntfcNum : longint;
+ end;
+
+var
+ frmFFTransport : TfrmFFTransport;
+
+implementation
+
+uses
+ FFLLWsck;
+
+{$R *.DFM}
+
+procedure TfrmFFTransport.FormShow(Sender : TObject);
+begin
+ FFWSGetLocalHosts(cbTCPIntf.Items);
+ if TCPIntfcNum > Pred(cbTCPIntf.Items.Count) then begin
+ MessageDlg('The bound interface is no longer available. ' + #13#10 +
+ 'Bindings will be reset to all adapters.',
+ mtInformation, [mbOK], 0);
+ cbTCPIntf.ItemIndex := 0;
+ end else
+ cbTCPIntf.ItemIndex := TCPIntfcNum;
+end;
+
+end.
diff --git a/components/flashfiler/sourcelaz/crystal/ffcrdefn.inc b/components/flashfiler/sourcelaz/crystal/ffcrdefn.inc
new file mode 100644
index 000000000..6affff08c
--- /dev/null
+++ b/components/flashfiler/sourcelaz/crystal/ffcrdefn.inc
@@ -0,0 +1,42 @@
+{*********************************************************}
+{* Compiler options/directives include file *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{NOTE: FFCRDEFN.INC is included in all Crystal Reports driver units;
+ hence you can specify global compiler options here.
+ FFCRDEFN.INC is included *before* each unit's own required
+ compiler options, so options specified here could be
+ overridden by hardcoded options in the unit source file.}
+
+{$I ffdefine.inc}
+
+{.$DEFINE Debug}
+
+{====Global fixed compiler options (do NOT change)====}
+{$A- Force alignment on byte boundaries}
+{$Z2 Enumerations in Crystal Reports are word sized}
diff --git a/components/flashfiler/sourcelaz/crystal/ffcrdrvr.rc b/components/flashfiler/sourcelaz/crystal/ffcrdrvr.rc
new file mode 100644
index 000000000..90a794bd8
--- /dev/null
+++ b/components/flashfiler/sourcelaz/crystal/ffcrdrvr.rc
@@ -0,0 +1,60 @@
+/*********************************************************
+ * Main program icon resource *
+ *********************************************************/
+
+/* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** */
+
+#define VERSIONINFO_1 1
+
+VERSIONINFO_1 VERSIONINFO
+FILEVERSION 2, 0, 6, 1
+PRODUCTVERSION 2, 0, 6, 1
+FILEOS VOS__WINDOWS32
+FILETYPE VFT_APP
+{
+ BLOCK "StringFileInfo"
+ {
+ BLOCK "040904E4"
+ {
+ VALUE "CompanyName", "TurboPower Software Company\000\000"
+ VALUE "FileDescription", "FlashFiler Crystal Reports Driver\000"
+ VALUE "FileVersion", "2.0.6.1\000"
+ VALUE "InternalName", "P2BFF213\000"
+ VALUE "LegalCopyright", "Copyright (c) TurboPower Software Co. 1996-2002\000\000"
+ VALUE "OriginalFilename", "P2BFF213.DLL\000"
+ VALUE "ProductName", "FlashFiler 2\000"
+ VALUE "ProductVersion", "2.0.6.1\000"
+ }
+
+ }
+
+ BLOCK "VarFileInfo"
+ {
+ VALUE "Translation", 0x409, 1252
+ }
+
+}
+
diff --git a/components/flashfiler/sourcelaz/crystal/ffcrdrvr.res b/components/flashfiler/sourcelaz/crystal/ffcrdrvr.res
new file mode 100644
index 000000000..2b6c75456
Binary files /dev/null and b/components/flashfiler/sourcelaz/crystal/ffcrdrvr.res differ
diff --git a/components/flashfiler/sourcelaz/crystal/ffcrltyp.pas b/components/flashfiler/sourcelaz/crystal/ffcrltyp.pas
new file mode 100644
index 000000000..6cb9a6b35
--- /dev/null
+++ b/components/flashfiler/sourcelaz/crystal/ffcrltyp.pas
@@ -0,0 +1,130 @@
+{*********************************************************}
+(* Datatypes specific to this physical database. *)
+(* These types are extracted from the PHYSDB.CPP source *)
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffcrdefn.inc}
+
+unit ffcrltyp;
+
+interface
+
+uses
+ ffllbase,
+ SysUtils,
+ ffclbde,
+ ffsrbde,
+ ffdb,
+ ffdbbase,
+ ffcrtype;
+
+const
+ BLOB_INFO_SIZE = 8;
+
+type
+ TDbiDate = ffsrbde.DBIDATE;
+ TDbiTime = ffclbde.TIME;
+ TDbiTimestamp = ffsrbde.TIMESTAMP;
+
+ PDbiDate = ^TDbiDate;
+ PDbiTime = ^TDbiTime;
+ PDbiTimestamp = TDbiTimestamp;
+
+ PPhysDbReadFieldInfo = ^TPhysDbReadFieldInfo;
+ TPhysDbReadFieldInfo = packed record
+ ReadFieldNo : TcrInt16u;
+ FieldNo : TcrInt16u;
+ OffsetInRecord : TcrInt16u;
+ FieldLength : TcrInt16u;
+ FieldType : TFieldValueType;
+
+ NativeFieldType : TcrInt16u;
+ NBytesInNativeField : TcrInt16u;
+ NDecPlacesInNativeField : TcrInt16u;
+ NativeFieldOffset : TcrInt16u;
+
+ OffsetInStopKeyBuf : TcrInt16u; { offset of each range field }
+ StopInclusive : TcrBoolean; { only used in stopping the range search }
+ end;
+ TPhysDbReadFieldInfoArray = array[0..32767 div SizeOf(TPhysDbReadFieldInfo)] of TPhysDbReadFieldInfo;
+ PPhysDbReadFieldInfoArray = ^TPhysDbReadFieldInfoArray;
+
+ PPhysDbReadInfo = ^TPhysDbReadInfo;
+ TPhysDbReadInfo = packed record
+ NBytesInPhysRecord : TcrInt16u;
+ PhysRecordBuf : PffByteArray;
+
+ CurrentRecord : TcrInt32u;
+ KeyBuf : array[0..1023] of Char;
+
+ NBytesInReadRecord : TcrInt16u;
+ NFieldsInReadRecord : TcrInt16u;
+ FieldInfo : PPhysDbReadFieldInfoArray;
+
+ NBytesInIndexRecord : TcrInt16u;
+ NFieldsInIndexRecord : TcrInt16u;
+ IndexFieldInfo : PPhysDbReadFieldInfoArray;
+
+ ValuesUnique : TcrBoolean; { Always T for primary, F for secondary }
+ IndexCaseSensitive : TcrBoolean; { If the index in use is case sensitive }
+ AscendingIndex : TcrBoolean;
+
+ NFieldsInIndexDefn : TcrInt16u; { Save field types, etc. }
+ IndexDefnInfo : PPhysDbReadFieldInfoArray;
+
+ NumRanges : TcrInt16u;
+ RangeFieldInfo : PPhysDbReadFieldInfoArray;
+ NStopKeyRanges : TcrInt16u;
+ StopKeyBuf : array[0..254] of Char; { the upper limit for range search }
+ StopKeyLen : TcrInt16u; { generic integer type }
+
+ NFieldsInLookupValue : TcrInt16u; { Always <= NFieldsInIndexDefn }
+ LookupValueLen : TcrInt16u;
+ LastLookupFieldLen : TcrInt16u; { Only for partial lookup }
+ LastLookupFieldIsSubstr : TcrBoolean; { T = CLOSEST lookup }
+ end;
+
+ TPhysDbFileHandle = packed record
+ DatabaseID : TffWord32; { database handle from IDAPI }
+ CursorID : TffWord32; { Cursor handle from IDAPI }
+ PathAndFileName : PChar; { save data file path and name }
+ IndexFilename : PChar; { save the index file path and name }
+ TagName : PChar; { save the tag name in the index }
+ MainFile : Boolean; { for sorting and range }
+ RangeLimit : Boolean;
+ ReadInfo : PPhysDbReadInfo;
+ NotXlateDOSString : Boolean;
+ NotXlateDOSMemo : Boolean;
+ end;
+
+ TPhysDbServerHandle = packed record
+ end;
+
+implementation
+
+end.
diff --git a/components/flashfiler/sourcelaz/crystal/ffcrmain.pas b/components/flashfiler/sourcelaz/crystal/ffcrmain.pas
new file mode 100644
index 000000000..507185e1f
--- /dev/null
+++ b/components/flashfiler/sourcelaz/crystal/ffcrmain.pas
@@ -0,0 +1,4525 @@
+{*********************************************************}
+(* Implementation of all driver functions *)
+(* Direct port of the original PHYSDB.CPP source file *)
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffcrdefn.inc}
+
+unit ffcrmain;
+
+{ The import unit can be built by copying the interface section of this
+ unit and globally replacing "stdcall;" with "external 'PDBFF.DLL';" }
+
+{
+ This file contains the interface definition used by all Brahma physical
+ database DLL's.
+
+ Brahma supports three basic types of DLLs, physical database (PhysDb.hpp),
+ physical dictionary (PhysDict.hpp), and physical directory (PhysDir.hpp).
+
+ These DLLs provide some similar functions, but differ as follows:
+ PhysDb: - Supports single physical database tables (assumed to be
+ stored in single files), and provides both retrieving of
+ database info and reading of database records.
+ - May be able to retrieve structural and index info of a
+ single table, but has no support for links between multiple
+ tables.
+ - Performs reading of database records (sequentially or using
+ an index).
+ PhysDict: - Supports retrieving of database info from multiple database
+ tables, but has no support for reading of database records.
+ - May be able to retrieve structural, index and link
+ information of multiple tables.
+ - Is knowledgeable of PhysDb database table types, and informs
+ the Database Manager of these types for reading of database
+ records.
+ PhysDir: - Supports a directory of multiple database files, but does not
+ perform retrieving of database info or reading of database
+ records itself.
+ - Is knowledgeable of PhysDb and PhysDict DLLs, and informs
+ the Database Manager which DLL to use for servicing each
+ entry in its directory.
+
+ Since each physical database, dictionary and directory is implemented as a
+ DLL, other database types can be defined and linked dynamically to the
+ Database Manager in the future.
+
+ Note: As mentioned above, physical database DLLs are responsible for
+ individual database tables only, and handling the links between multiple-
+ table databases is the responsibility of the Database Manager. The
+ physical database DLL must support multiple open database tables at a
+ time however.
+
+ Friendly advice: No global static data should be used in the
+ implementation of a physical database DLL. This makes it easier to
+ support multiple open files per report, and multiple open sets of files
+ for multiple reports, by letting the Database Manager save state
+ information instead.
+
+ The general rule is that whenever any state information is required
+ by the DLL it is dynamically allocated and a reference to it passed back
+ to the Database Manager. The Database Manager is then responsible for
+ storing this reference, passing it to the DLL whenever it is needed, and
+ calling the DLL to free the associated information.
+
+ Error Messages: When any DLL function cannot complete successfully, it
+ has a choice of returning an error code (PhysDbError type) or an error
+ message (code PhysDbErrMsgReturned, and returning a message in ErrMsg
+ parameter). The recommended behavior of the DLL is:
+ - Return an error string if no error code matches the situation
+ well, or if very specific information is available that would help
+ the user (e.g. "Please execute DOS share program", "Table is
+ corrupted at record 15", etc.). If an error string is returned it
+ will be displayed by the Database Manager.
+ - Return an error code in all other cases. The Database Manager
+ will display a standard error message of its own in these cases,
+ which will be consistent for all physical database types
+ (e.g. "Not enough memory", "File could not be found", etc.).
+}
+
+{$DEFINE IDAPI_INTERNAL_LIMITS}
+
+interface
+
+uses
+ ffllbase,
+ fflllog, {!!.12}
+ ffcrptyp,
+ ffcrtype,
+ ffclreng,
+ ffstdate, {!!.02}
+ SysUtils;
+
+
+{ --------------------- Database Abilities ------------------------ }
+
+{ Return physical database version number. }
+
+function PhysDbVersionNumber(
+ var MajorVersionNumber : Word;
+ var MinorVersionNumber : Word;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ Return whether this physical database can recognize data files of
+ its own type. For example, a Paradox physical database DLL can recognize
+ a data file passed to it by its file name extension and internal header
+ information, whereas an ASCII physical database DLL cannot uniquely
+ identify a data file as being of its type.
+
+ If this returns true, the Database Manager may pass arbitrary file names to
+ the function OpenDataFileIfRecognizedVer12, and assumes it only opens data
+ files belonging to it. If this is false the function OpenDataFileIfRecognizedVer12
+ is only called when the user has confirmed that a file is of this data
+ type (via a dialog of FetchDatabaseName names) and can assume that the
+ type is correct. }
+
+function CanRecognizeDataFile(var CanRecognize : TcrBoolean;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ Return whether this physical database can retrieve info describing
+ an open data file (whether flat or recurring records, number of
+ fields in the file, the width & type of each data field, etc.).
+ This can be done by the physical database either by "inhaling" the
+ data file information (without user interaction), or by displaying
+ Windows dialogs to prompt the user for this information.
+
+ If this returns true, the Database Manager calls FetchDataFileInfo
+ to retrieve this info, if false the Database Manager uses default Windows
+ dialogs of its own to prompt the user to provide this information. }
+
+function CanFetchDataFileInfo(var CanFetchFileInfo : TcrBoolean;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ Return whether this physical database can fetch index information
+ for data files of its type. There are four possible cases:
+ 1. indexesNeverExist: e.g. for ASCII files.
+ 2. indexesExistButNotKnown: e.g. if not implemented yet.
+ 3. someIndexesKnown: e.g. for dBase, default indexes known, but
+ others may exist.
+ 4. allIndexesKnown: e.g. for Paradox, all indexes known by system.
+
+ In cases 3 and 4 the function FetchDataFileIndexInfo is called to
+ retrieve information on all known indexes. In cases 2 and 3 the
+ Database Manager uses default Windows dialogs to allow the user to
+ select file names containing indexes. }
+
+function CanFetchDataFileIndexInfo(
+ var CanFetchIndexInfo : TPhysDbIndexInfoCases;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ Return whether this physical database can build indexes on data files
+ if required. There are three possible cases:
+ 1. cannotBuildIndex
+ 2. canBuildNonMaintainedIndex
+ 3. canBuildMaintainedIndex }
+
+function CanBuildIndex(var CanBuildIndex : TPhysDbBuildIndexCases;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ Return whether this physical database can (efficiently) retrieve the
+ number of records in an open data file. This information is required
+ by the Database Manager to estimate the % completion of reading of a
+ data file.
+
+ If this returns true, the Database Manager calls NRecurringRecordsToRead
+ to retrieve the record count, if false it does not.
+
+ Note: It is not recommended to read the entire data file to determine
+ the number of records, since performance will be seriously slowed.
+ Therefore if the physical database system does not easily provide this
+ info, this function should return false indicating that the ability is
+ not provided. }
+
+function CanFetchNRecurringRecords(var CanFetchNrecords : TcrBoolean;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ This function is to tell whether this DLL has SQL functionality,
+ three parameters are passed back, isSQLTypeDLL, canBuildAndExecSQLQuery,
+ and canExecSQLQuery. }
+
+function SQLCompatible(
+ var IsSQLTypeDLL : TcrBoolean;
+ var CanBuildAndExecSQLQuery : TcrBoolean;
+ var CanExecSQLQuery : TcrBoolean;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ Return if physical database supports reading of main file using an index.
+ This is a speed-up option, since Brahma will not need to sort the report. }
+
+function CanReadSortedOrder(var CanReadSorted : TcrBoolean;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ Return if physical database supports selecting records using a range.
+ This is a speed-up option, since Brahma will only be given records
+ matching the record selection criteria. }
+
+function CanReadRangeOfValues(var CanReadRange : TcrBoolean;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ Each physical database type may or may not support multi-user access.
+ If a database does support multi-user access, it may allow a choice of
+ either file locking or record locking, or it may always use one method.
+ This function returns whether record locking is available for this
+ physical database type. }
+
+function CanUseRecordLocking(var RecordLockingPossible : TcrBoolean;
+ var RecordLockingPreferred : TcrBoolean;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ This function returns whether file locking is available for this
+ physical database type. }
+
+function CanUseFileLocking(var FileLockingPossible : TcrBoolean;
+ var FileLockingPreferred : TcrBoolean;
+ ErrMsg: PAnsiChar) : TPhysDbError; stdcall;
+
+{ ---------------- Initialization and Termination ----------------- }
+
+{ Any database system initialization is performed at this point.
+ Note: No global static structures should be allocated, as discussed in
+ the program header above. }
+
+function InitPhysicalDatabase(ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ Termination of the database system is performed at this point. }
+
+function TermPhysicalDatabase(ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ OpenSession and TermSession are called to initialize and terminate on
+ a per task basis. The Database Manager determines when a new task
+ attempts to use a DLL, and calls OpenSession at that time. }
+
+function OpenSession(ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+function TermSession(ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+
+{ ------------------------- Database Name -------------------------- }
+
+{ Return the text name of this physical database format. This is used
+ in Database Manager dialogs to describe the database type of a data
+ file, and to store with a database dictionary to describe which physical
+ database DLL to use for a file. }
+
+function FetchDatabaseName(var Name : PAnsiChar;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ Free the text name of this physical database format. }
+
+function FreeDatabaseName(var Name : PAnsiChar;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ ---------------------- Log On and Log Off ----------------------- }
+
+{ These functions allow the CRPE user to pass log on and log off
+ information to a PhysDB DLL.
+
+ Note: These functions are only required if the database supports
+ password-protected database files (e.g. Paradox). Otherwise
+ they do not need to be implemented. }
+
+function LogOnServer(ServerInfo : PPhysDbServerInfo;
+ var ServerHandle : PPhysDbServerHandle;
+ Password : PAnsiChar;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+function LogOffServer(var ServerHandle : PPhysDbServerHandle;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ ------------------- Parse and Rebuild SQL Info -------------------- }
+
+{ These functions are helpers to parse SQL connect info passed
+ down from a PhysDir type DLL.
+
+ Note: These functions are only useful for MS Access tables. These
+ functions do not need to be implemented in any other case. In
+ general, for SQL databases the PhysDs.hpp (PDS*.DLL) interface
+ should be used.
+
+ SST: These routines must be exported even if they are not used or Crystal
+ will not load the driver DLL. }
+
+function ParseLogOnInfo(ConnectBuf : PAnsiChar;
+ BufSize : Word;
+ ServerInfo : PPhysDbServerInfo;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+function RebuildConnectBuf(ServerInfo : PPhysDbServerInfo;
+ ConnectBuf : PAnsiChar;
+ BufSize : Word;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ -------------------- Open and Close Files ----------------------- }
+
+{ This function is passed a file name, including its path and extension,
+ and determines whether it is a data file of its physical database type,
+ and if so opens the data file and returns a file handle.
+
+ This function is called the first time a data file is attempted to be
+ opened, and before fetching the file info (from FetchDataFileInfo) and
+ index info (from FetchDataFileIndexInfo) structures that describe the
+ file. This function may also be called to open a data file for
+ sequential reading (without an index) using ReadNextRecurringRecord.
+
+ The Database Manager may pass arbitrary file names to this function,
+ and assumes it only opens data files belonging to it. If it is false
+ this function is only called when the user has confirmed that a file
+ is of this data type (via a dialog of FetchDatabaseName names) and this
+ function opens the file as if the database type is correct.
+
+ The new parameter logOnInfo can contain a password to use in opening
+ password-protected files.
+
+ Note: The parameter sessionInfo is only of use for MS Access DLLs
+ that track user session info. The parameter dirInfo is also only
+ currently useful for MS Access DLLs.
+
+ The parameter silentMode is used to tell DLL whether to pop up any
+ dialog or message itself or just return an error code.
+
+ The parameter aliasName allows the DLL to pass back its own alias
+ name to be used for the file, it can ignore this parameter if it wants
+ to use the default alias.
+
+ The parameter calledFromDirDLL indicates whether the user has
+ chosen a directory or database type file. If the user chose a
+ directory type file, the directory file says to call this database
+ DLL with an internal file name. }
+
+function OpenDataFileIfRecognizedVer113(
+ FileName : PAnsiChar;
+ OpenDefaultIndex : TcrBoolean;
+ var Recognized : TcrBoolean;
+ var FileHandle : PPhysDbFileHandle;
+ CalledFromDirDLL : TcrBoolean;
+ var AliasName : PAnsiChar;
+ SilentMode : TcrBoolean;
+ DirInfo : PPhysDbFileDirectoryInfo;
+ DictInfo : PPhysDbFileDictionaryInfo;
+ SessionInfo : PPhysDbSessionInfo;
+ LogOnInfo : PPhysDbLogOnInfo;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ This function is passed both a data file name and index file name,
+ including paths and extensions, and determines whether they are of
+ its physical database type. If so it opens the data file using the
+ specified index, and returns a file handle.
+
+ This function is called when the user has selected an index file
+ to attempt to open, or to open a data file for reading, using either
+ ReadNextRecurringRecord (in the order of the chosen index file) or
+ LookupMatchingRecurringRecord to search directly for a record (using the
+ chosen index file).
+
+ This function will only be called if CanFetchDataFileIndexInfo has
+ returned indexesExistButNotKnown or someIndexesKnown.
+
+ The new parameter logOnInfo can contain a password to use in opening
+ password-protected files.
+
+ Note: The parameter sessionInfo is only of use for MS Access DLLs
+ that track user session info. The parameter dirInfo is also only
+ currently useful for MS Access DLLs.
+
+ The parameter silentMode is used to tell DLL whether to pop up any
+ dialog or message itself or just return an error code.
+
+ The parameter aliasName allows the DLL to pass back its own alias
+ name to be used for the file, it can ignore this parameter if it wants
+ to use the default alias. }
+
+function OpenDataAndIndexFileIfRecogV113(
+ FileName : PAnsiChar;
+ IndexName : PAnsiChar;
+ var Recognized : TcrBoolean;
+ var FileHandle : PPhysDbFileHandle;
+ var AliasName : PAnsiChar;
+ SilentMode : TcrBoolean;
+ DirInfo : PPhysDbFileDirectoryInfo;
+ DictInfo : PPhysDbFileDictionaryInfo;
+ SessionInfo : PPhysDbSessionInfo;
+ LogOnInfo : PPhysDbLogOnInfo;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ This function is passed a file name, including its path and extension,
+ and the file info (from FetchDataFileInfo) and index info (from
+ FetchDataFileIndexInfo) structures, with usedInRead field set to
+ indicate the index file chosen. This function opens the data file
+ using the chosen index and returns a file handle.
+
+ This function is called to open a data file for reading, using either
+ ReadNextRecurringRecord (in the order of the chosen index file) or
+ LookupMatchingRecurringRecord to search directly for a record (using the
+ chosen index file).
+
+ This function can assume that the data file is of its physical
+ database type, since it was opened and recognized previously in order
+ to fetch the file info and index info passed as parameters.
+
+ The new parameter logOnInfo can contain a password to use in opening
+ password-protected files.
+
+ Note: The parameter sessionInfo is only of use for MS Access DLLs
+ that track user session info. The parameter dirInfo is also only
+ currently useful for MS Access DLLs.
+
+ The parameter silentMode is used to tell DLL whether to pop up any
+ dialog or message itself or just return an error code. }
+
+function OpenDataFileAndIndexChoiceVer113(
+ FileName : PAnsiChar;
+ InfoPtr : PPhysDbFileInfo;
+ IndexesPtr : PPhysDbIndexesInfo;
+ var FileHandle : PPhysDbFileHandle;
+ SilentMode : TcrBoolean;
+ DirInfo : PPhysDbFileDirectoryInfo;
+ DictInfo : PPhysDbFileDictionaryInfo;
+ SessionInfo : PPhysDbSessionInfo;
+ LogOnInfo : PPhysDbLogOnInfo;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ This function closes a data file opened with OpenDataFileIfRecognized,
+ OpenDataAndIndexFileIfRecognized or OpenDataFileAndIndexChoice, and
+ deletes any allocated memory structures. }
+
+function CloseDataFile(var FileHandle : PPhysDbFileHandle;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+
+{ ---------------------- Fetch Data File Info --------------------- }
+
+{ This function is passed a file handle of an open data file, and returns
+ info describing its file structure (whether flat or recurring records,
+ number of fields in the file, the width & type of each data field,
+ etc.)
+
+ This function may retrieve this information by:
+ 1. "Inhaling" the data file information (without user interaction),
+ if it has facilities to query the data file definition directly.
+ 2. Displaying Windows dialogs to prompt the user for this information,
+ and then returning these values as the file structure.
+
+ This function is only called if CanFetchDataFileInfo has previously
+ returned true. If it has not, the Database Manager uses default Windows
+ dialogs to allow the user to describe the data file structure (with
+ obvious risks of error).
+
+ The parameter infoDefaultsExist is only meaningful in case 2 above.
+ (In case 1 the function should always retrieve the most current data
+ file definition from the system.) In case 2 if this parameter is true
+ the user has executed this function on this table before, and if
+ false this is the first time. If true, the previous values are passed as
+ defaults in the info structure, and the function can display them as
+ defaults in its Windows dialogs.
+
+ Note: This function is not responsible for filling in certain information
+ in PhysDbFileInfo:
+ - nBytesInReadRecord
+ - nFieldsInReadRecord
+ - nBytesInIndexRecord
+ - nFieldsInIndexRecord
+ and certain information in PhysDbFieldInfo:
+ - usedInReadRecord
+ - offsetInReadRecord
+ - usedInIndexRecord
+ - offsetInIndexRecord
+ This information is only meaningful in the InitDataFile functions
+ below. It can be set to zero or ignored by FetchDataFileInfo. }
+
+function FetchDataFileInfo(
+ FileHandle : PPhysDbFileHandle;
+ InfoDefaultsExist : TcrBoolean;
+ var InfoPtr : PPhysDbFileInfo;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ This function frees the file info structure allocated by FetchDataFileInfo. }
+
+function FreeDataFileInfo(
+ var InfoPtr : PPhysDbFileInfo;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+
+{ ------------------- Fetch Data File Index Info ------------------ }
+
+{ This function is passed a file handle of an open data file, and returns
+ an index info structure (such as the number of known indexes, which
+ fields are used in each index definition, etc.). The fields in an
+ index definition are identified by their (0-origin) index in the
+ PhysDbFileInfoPtr->fieldInfo array of fields returned by FetchDataFileInfo.
+ The file info structure is passed as a parameter to this function to
+ look up these field numbers.
+
+ This function is expected to "inhale" the index information (without user
+ interaction) by querying the data file definition directly.
+
+ This function is only called if CanFetchDataFileIndexInfo has previously
+ returned someIndexesKnown or allIndexesKnown. If indexesExistButNotKnown
+ or someIndexesKnown the Database Manager uses default Windows dialogs
+ to allow the user to select file names containing indexes.
+
+ Note: This function is not responsible for filling in certain information
+ in PhysDbIndexInfo:
+ - usedInRead
+ This information is only meaningful in the function OpenDataFileAndIndexChoice
+ above. It can be set to zero or ignored by FetchDataFileIndexInfo. }
+
+function FetchDataFileIndexInfo(
+ FileHandle : PPhysDbFileHandle;
+ InfoPtr : PPhysDbFileInfo;
+ var IndexesPtr : PPhysDbIndexesInfo;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ This function frees the index info structure created by
+ FetchDataFileIndexInfo. }
+
+function FreeDataFileIndexInfo(var IndexesPtr : PPhysDbIndexesInfo;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ ---- Initialization and Termination of Reading from Data File ---- }
+
+{ Note: This function is only useful for non-SQL databases that prefer a
+ SQL-type interface. In general, for SQL databases the PhysDs.hpp
+ (PDS*.DLL) interface should be used.
+
+ SST: This routine must be exported even if it is not used or Crystal
+ will not load the driver DLL. }
+
+function BuildAndExecSQLQuery(
+ FileHandleList : PPhysDbFileHandleArray;
+ FileInfoList : PPhysDbFileInfoArray;
+ LinkNonSQLFlags : PcrBooleanArray;
+ IndexesInfoList : PPhysDbIndexesInfoArray;
+ RangeInfoList : PPhysDbRangeInfoArray;
+ NFiles : Word;
+ LinkInfoList : PPhysDbFileLinkInfoArray;
+ NFileLinks : Word;
+ SqlDrivingFile : TcrBoolean;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ This function is passed a file handle of an open data file, and the
+ file info structure (from FetchDataFileInfo) describing this file,
+ before starting to read from the file. This function should perform
+ any file initialization, and determine the sets of fields to be read
+ for each record.
+
+ During the Database Manager print cycle, the physical database functions
+ are called as follows for each data file to be read:
+ if (OpenDataFileIfRecognizedVer12 ()) // or OpenDataFileAndIndexChoice ()
+ if (InitDataFileForReading ()) // or InitDataFileAndIndexForReading ()
+ ... // perform reading
+ TermDataFileForReading ()
+ CloseDataFile ()
+
+ Important: This function must not interfere with other data files
+ being read at the same time by this physical database implementation.
+ Therefore no global (static) data should be used by this function,
+ and all state information needed during reading should be kept local
+ to its own file handle. This function should also not perform any
+ global initialization of the database system that will affect other
+ open data files, (this can be done during InitPhysicalDatabase instead).
+
+ Translated and Non-Translated Fields: The Database Manager specifies
+ two sets of fields to be read from each data record, using the
+ additional information in the file info structure:
+ - nBytesInReadRecord
+ - nFieldsInReadRecord
+ - nBytesInIndexRecord
+ - nFieldsInIndexRecord
+ and in each field info structure:
+ - usedInReadRecord
+ - offsetInReadRecord
+ - usedInIndexRecord
+ - offsetInIndexRecord
+
+ The two sets of fields are required for different purposes. The
+ fields indicated by usedInReadRecord are used in the printed report
+ and must be translated to generic Brahma data types before returning.
+ The fields flagged by usedInIndexRecord are used in constructing an
+ index value for looking up records in another file, and should
+ not be translated from their native format.
+
+ The function now allows the main file of the report to be opened using
+ an index, to speed up sorting and selection of records.
+
+ The function now also allows an array of range values.
+
+ If indexesPtr is NULL, OpenDataFileIfRecognizedVer12 was called to
+ open the data file. If indexesPtr is non-NULL, OpenDataFileAndIndexChoice
+ was called to open the file, and indexPtr contains the index choice.
+
+ This function returns in canDoLimitRange whether it is able to perform
+ the range check on this particular field type. }
+
+function InitDataFileForReadingVer17(
+ FileHandle : PPhysDbFileHandle;
+ InfoPtr : PPhysDbFileInfo;
+ IndexesPtr : PPhysDbIndexesInfo;
+ RangeInfoList : PPhysDbRangeInfoArray;
+ NRanges : TcrInt16u;
+ var CanDoRangeLimit : TcrBoolean;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ This function serves the same purpose as InitDataFileForReading, but
+ is called when initializing reading from a file with an index,
+ whereas InitDataFileForReading is called when reading from a file
+ without. The index info structure (from FetchDataFileIndexInfo) is
+ passed to this function to identify the chosen index. }
+
+function InitDataFileAndIndexForReadV115(
+ FileHandle : PPhysDbFileHandle;
+ InfoPtr : PPhysDbFileInfo;
+ IndexesPtr : PPhysDbIndexesInfo;
+ LookupOptPtr : PPhysDbLookupOptInfo;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ This function frees the read state information allocated by
+ InitDataFile functions. }
+
+function TermDataFileForReading(
+ FileHandle : PPhysDbFileHandle;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+
+{ --------------- Number of Records in Data File ------------------- }
+
+{ This function is passed a file handle of an open data file, and
+ returns the number of recurring records in the file. }
+
+function NRecurringRecordsToRead(
+ FileHandle : PPhysDbFileHandle;
+ var NRecordsToRead : LongInt;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ ----------------------- Read Functions --------------------------- }
+
+{ The following comments apply to all three of the functions for
+ data file reading: ReadFlatRecord, ReadNextRecurringRecord, and
+ LookupMatchingRecurringRecord.
+
+ Translated and Non-Translated Fields: The Database Manager requires
+ two sets of fields to be returned from each data record, as explained in
+ InitDataFile functions above. The two buffers readRecordBuf and
+ indexRecordBuf are passed to these functions for the two sets of field
+ values. As well indexNullFlags is an array of flags indicating whether
+ a field has special database "null value" and its indexRecordBuf entry
+ should be ignored.
+
+ The two sets of fields are required for different purposes. The fields
+ returned in readRecordBuf are used in the printed report and must be
+ translated to generic Brahma data types before returning. The fields
+ returned in indexRecordBuf are used in constructing an index value for
+ looking up records in another file, and should not be translated from
+ their native format. }
+
+{ --------------------- Read Flat File Record ---------------------- }
+
+{ This function is passed a file handle of an open flat data file, and
+ reads the first data record. }
+
+function ReadFlatRecordVer15(
+ FileHandle : PPhysDbFileHandle;
+ ReadRecordBuf : PByteArray;
+ ReadNullFlags : PcrBooleanArray;
+ IndexRecordBuf : PByteArray;
+ IndexNullFlags : PcrBooleanArray;
+ var RecordRead : TcrBoolean;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+
+{ -------- Read Next Recurring Record (Sequential Access) ---------- }
+
+{ This function is passed a file handle of an open data file, and
+ reads the next data record (from its current file position) sequentially.
+ It sets recordRead to true if it is successful, and to false if it is
+ at end of file. }
+
+function ReadNextRecurringRecordVer15(
+ FileHandle : PPhysDbFileHandle;
+ ReadRecordBuf : PByteArray;
+ ReadNullFlags : PcrBooleanArray;
+ IndexRecordBuf : PByteArray;
+ IndexNullFlags : PcrBooleanArray;
+ var RecordRead : TcrBoolean;
+ var NRecordsSkipped : LongInt;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ ------- Lookup Matching Recurring Record (Random Access) --------- }
+
+{ This function is passed a file handle of an open data file, a lookup
+ value and whether to start searching from first record, and looks up
+ a record matching the lookup value. This function is only called if
+ OpenDataFileAndIndexChoice has been called to open the data file.
+
+ The lookup value passed in the parameters lookupValueRecordBuf and
+ lookupValueNullFlags agrees in type and ordering with the fields of the
+ index chosen in the file open call. The lookup value fields are not
+ translated from the native field format, so no translation needs to occur
+ back to their native format when doing record lookup.
+
+ If the parameter startTopOfFile is true this function should begin its
+ search from the beginning of the data file, if it is false it should
+ search from its current file position.
+
+ This function sets recordRead to true if it is successful, and to false
+ if it is at end of file. }
+
+function LookupMatchingRecurringRecVer15(
+ FileHandle : PPhysDbFileHandle;
+ LookupValueRecordBuf : PAnsiChar;
+ LookupValueNullFlags : PcrBooleanArray;
+ LookupValueType : Word;
+ StartTopOfFile : TcrBoolean;
+ ReadRecordBuf : PByteArray;
+ ReadNullFlags : PcrBooleanArray;
+ IndexRecordBuf : PByteArray;
+ IndexNullFlags : PcrBooleanArray;
+ var RecordRead : TcrBoolean;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+
+{ ------------------------- Memo Fields ---------------------------- }
+
+{ There are two types of memo fields: transientMemoField and
+ persistentMemoField. A transient memo field is one that must
+ be read at the same time as the recurring data record, and a
+ persistent memo field is one that can be read at any later point.
+
+ For example, dBase supports persistent memo fields by storing a
+ memo field number in the data record that uniquely identifies the
+ field value in the memo file. This field number can be stored
+ by the physical database in the recurring record, and then read from
+ the memo file at any later point.
+
+ Persistent memo fields are preferred by Brahma, since the (potentially
+ very large) variable length text values do not need to be saved with
+ the data record (including buffering in memory, sorting, etc.)
+
+ The following functions are used to support memo fields. The
+ functions FetchMemoField and FreeMemoField are only called for fields
+ identified as transientMemoField's by this physical database.
+ The functions FetchPersistentMemoField and FreePersistentMemoField
+ are only called for fields identified as persistentMemoField's by
+ this physical database.
+
+ Memo field identifiers are stored in data records returned to Brahma
+ by the above Read functions, and these identifiers are used to
+ retrieve the memo field value. }
+
+function FetchMemoField(MemoFieldRecordBuf : PAnsiChar;
+ var MemoField : PAnsiChar;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+function FreeMemoField(var MemoField : PAnsiChar;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+function FetchPersistentMemoField(FileHandle : PPhysDbFileHandle;
+ MemoFieldRecordBuf : PAnsiChar;
+ var MemoField : PAnsiChar;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+function FreePersistentMemoField(FileHandle : PPhysDbFileHandle;
+ var MemoField : PAnsiChar;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ --------------------- Multi-User Access -------------------------- }
+
+{ This function is called to tell the physical database functions to use
+ record locking when reading from the database file(s). }
+
+function UseRecordLocking(
+ FileHandle : PPhysDbFileHandle;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{ This function is called to tell the physical database functions to use
+ file locking when reading from the database file(s). }
+
+function UseFileLocking(
+ FileHandle : PPhysDbFileHandle;
+ ErrMsg : PAnsiChar) : TPhysDbError; stdcall;
+
+{===DEBUG LOGGING===}
+procedure StartLog;
+procedure EndLog;
+procedure AddToLog(const S : string);
+procedure AddToLogFmt(const S : string; args : array of const); {!!.12}
+procedure AddBlockToLog(const S : string; Buf : pointer; BufLen : TffMemSize);
+procedure AddResultToLog(aResult : TPhysDbError);
+
+
+implementation
+
+uses
+ Dialogs,
+ Forms,
+ Classes,
+ Windows,
+ ffclbde,
+ ffsrbde,
+ ffclconv,
+ ffcrltyp,
+ ffcrutil,
+ ffllunc,
+ ffdb,
+ fflleng,
+ ffdbbase;
+
+type
+ TTaskListItem = record
+ TaskHandle : THandle;
+ AlreadyInitialized : Boolean;
+ end;
+ PTaskListItem = ^TTaskListItem;
+
+ TTaskList = class(TList)
+ function AddTask(TaskHandle: THandle) : TPhysDbError;
+ function DeleteTask(var TaskFound: Boolean;
+ var AlreadyInitialized: Boolean;
+ ErrMsg: PAnsiChar) : TPhysDbError;
+ function FindTask(TaskHandle: THandle) : integer;
+ function NewTask(var TaskFound: Boolean;
+ var TaskIndex: integer;
+ ErrMsg: PAnsiChar) : TPhysDbError;
+ end;
+
+var
+ TaskList : TTaskList;
+ IsTaskSuccess : Boolean;
+ DebugBuff : array[0..1023] of AnsiChar;
+ Log : TffEventLog; {!!.12}
+
+{$IFDEF IDAPI_INTERNAL_LIMITS}
+const
+ MAX_DBS_PER_SESSION = 32;
+ nOpenDatabase: Word = 0;
+{$ENDIF}
+
+function ServerEngine : TffBaseServerEngine;
+{return the default sessions server engine}
+begin
+ Result := FFSession.ServerEngine;
+end;
+
+{ ----------------------- TTaskList methods ------------------------- }
+
+function TTaskList.AddTask(TaskHandle: THandle) : TPhysDbError;
+var
+ Item : PTaskListItem;
+begin
+ try
+ FFGetMem(Item, sizeof(TTaskListItem));
+ Item^.TaskHandle := TaskHandle;
+ Item^.AlreadyInitialized := False;
+ Add(Item);
+ Result := errPhysDbNoError;
+ except
+ Result := errPhysDbNotEnoughMemory;
+ end;
+end;
+
+function TTaskList.DeleteTask(var TaskFound: Boolean;
+ var AlreadyInitialized: Boolean;
+ ErrMsg: PAnsiChar) : TPhysDbError;
+var
+ Item : PTaskListItem;
+ TaskHandle : THandle;
+ TaskIndex : integer;
+begin
+ TaskFound := False;
+ AlreadyInitialized := False;
+
+ TaskHandle := HInstance; {!!GetCurrentTask }
+ TaskIndex := FindTask(TaskHandle);
+ if TaskIndex <> -1 then begin
+ TaskFound := True;
+ Item := PTaskListItem(TaskList.Items[TaskIndex]);
+ AlreadyInitialized := Item^.AlreadyInitialized;
+ FFFreeMem(Item, sizeof(TTaskListItem));
+ Delete(TaskIndex);
+ end;
+ Result := errPhysDbNoError;
+end;
+
+function TTaskList.FindTask(TaskHandle: THandle) : integer;
+var
+ i : integer;
+begin
+ Result := -1;
+ for i := 0 to pred(Count) do
+ if PTaskListItem(Items[i])^.TaskHandle = TaskHandle then begin
+ Result := i;
+ Break;
+ end;
+end;
+
+function TTaskList.NewTask(var TaskFound : Boolean;
+ var TaskIndex : integer;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+var
+ TaskHandle : THandle;
+begin
+ TaskFound := False;
+
+ { See if current task is already in the list of tasks }
+ TaskHandle := HInstance; {GetCurrentTask;}
+ TaskIndex := FindTask(TaskHandle);
+ if TaskIndex <> -1 then begin
+ TaskFound := True;
+ Result := errPhysDbNoError;
+ Exit;
+ end;
+
+ { If not, then add it }
+ TaskIndex := Count;
+ Result := AddTask(TaskHandle);
+end;
+
+{ ----------------------- Helper Routines ------------------------- }
+
+function IDAPIError(ErrCode: TffResult; var ErrMsg: PAnsiChar) : TPhysDbError;
+begin
+ with EffDatabaseError.CreateViaCode(ErrCode, False) do
+ try
+ StrPCopy(ErrMsg, ErrorString);
+ finally
+ Free;
+ end;
+ AddToLogFmt(' IDAPI Error: [%s]', [ErrMsg]);
+ Result := errPhysDbErrMsgReturned;
+end;
+
+function Convert2BrahmaType(FileHandle : PPhysDbFileHandle;
+ NativeType : TcrInt16u;
+ var NativeWidth : TcrInt16u;
+ var BrahmaType : TFieldValueType;
+ var BrahmaWidth : TcrInt16u;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+var
+ BookmarkSize : Integer;
+ FFError : TffResult;
+begin
+ Result := errPhysDbNoError;
+ case NativeType of
+ fldZSTRING:
+ begin
+ BrahmaType := ftStringField;
+ if NativeWidth = 1 then begin { Handle Char types }
+ BrahmaWidth := 2;
+ end
+ else begin
+ BrahmaWidth := NativeWidth;
+(* Dec(NativeWidth);*)
+ end;
+ end;
+ fldDATE:
+ begin
+ BrahmaType := ftDateField;
+ BrahmaWidth := SizeOf(TcrDate);
+ NativeWidth := SizeOf(TcrDate);
+ end;
+ fldBLOB, fldstBINARY, fldstGRAPHIC, fldstTYPEDBINARY:
+ begin
+ BrahmaType := ftBlobField;
+
+ { Get bookmark size }
+ FFError := ServerEngine.CursorGetBookmarkSize(FileHandle^.CursorID, BookmarkSize);
+ if FFError <> DBIERR_NONE then begin
+ Result := IDAPIError(FFError, ErrMsg);
+ Exit;
+ end;
+
+ BrahmaWidth := SizeOf(TcrInt16u) + BookmarkSize;
+ NativeWidth := SizeOf(TcrInt16u) + BookmarkSize;
+ end;
+ fldstMEMO, fldstFMTMEMO:
+ { Memo field, or variable length char string. save only the FieldNo
+ in this field. }
+ begin
+ BrahmaType := ftPersistentMemoField;
+
+ { Get bookmark size }
+ FFError := ServerEngine.CursorGetBookmarkSize(FileHandle^.CursorID, BookmarkSize);
+ if FFError <> DBIERR_NONE then begin
+ Result := IDAPIError(FFError, ErrMsg);
+ Exit;
+ end;
+
+ BrahmaWidth := SizeOf(TcrInt16u) + BookmarkSize + 100;
+ NativeWidth := SizeOf(TcrInt16u) + BookmarkSize + 100;
+ end;
+ fldBOOL:
+ begin
+ BrahmaType := ftBooleanField;
+ BrahmaWidth := SizeOf(TcrBoolean);
+ end;
+ fldTIME:
+ begin
+ BrahmaType := ftTimeField;
+ BrahmaWidth := SizeOf(TcrTime);
+ NativeWidth := SizeOf(TDbiTime);
+ end;
+ fldTIMESTAMP:
+ begin
+ BrahmaType := ftStringField;
+ BrahmaWidth := SIZEOF_DATETIME_FIELD_STRING;
+ NativeWidth := SizeOf(TDbiTimeStamp);
+ end;
+ fldINT16, fldUINT16:
+ begin
+ BrahmaType := ftInt16sField;
+ BrahmaWidth := SizeOf(TcrInt16s);
+ end;
+ fldINT32, fldUINT32:
+ begin
+ BrahmaType := ftInt32sField;
+ BrahmaWidth := SizeOf(TcrInt32s);
+ end;
+ fldFLOAT:
+ begin
+ BrahmaType := ftNumberField;
+ BrahmaWidth := SizeOf(TcrNumber);
+ end;
+ fldstMONEY:
+ begin
+ BrahmaType := ftCurrencyField;
+ BrahmaWidth := SizeOf(TcrNumber);
+ end;
+ else
+ begin
+ BrahmaType := ftUnknownField;
+ BrahmaWidth := 1;
+ NativeWidth := 1;
+ end;
+ end;
+end;
+
+function DoubleToNumber(const D: Double) : TcrNumber;
+begin
+ Result := D * NUMBER_SCALING_FACTOR;
+end;
+
+function NumberToDouble(const N : TcrNumber) : Double;
+begin
+ Result := (N / NUMBER_SCALING_FACTOR);
+end;
+
+procedure ConvertTimestampToDateTimeString(
+ aDate : TDbiDate;
+ aTime : TDbiTime;
+ aBrahmaValue : PAnsiChar);
+var
+ Year : TcrInt16u;
+ Fraction : TcrInt16s;
+ Hour : TcrInt16u;
+ Minute : TcrInt16u;
+ Second : TcrInt16u;
+ Millisec : TcrInt16u;
+ Month : TcrInt16u;
+ Day : TcrInt16u;
+ I : TcrInt16u;
+ ZeroOrd : Integer;
+begin
+ Year := 0;
+ Fraction := 0;
+ FFBDEDateDecode(aDate, Day, Month, Year);
+ FFBDETimeDecode(aTime, Hour, Minute, MilliSec);
+ Second := Millisec div 1000;
+ ZeroOrd := Ord('0');
+
+ { Translate year to string }
+ for I := 3 downto 0 do begin
+ aBrahmaValue[I] := Chr((Year mod 10) + ZeroOrd);
+ Year := Year div 10;
+ end;
+
+ aBrahmaValue[4] := '/';
+ aBrahmaValue[5] := Chr((Month div 10) + ZeroOrd);
+ aBrahmaValue[6] := Chr((Month mod 10) + ZeroOrd);
+
+ aBrahmaValue[7] := '/';
+ aBrahmaValue[8] := Chr((Day div 10) + ZeroOrd);
+ aBrahmaValue[9] := Chr((Day mod 10) + ZeroOrd);
+
+ aBrahmaValue[10] := ' ';
+ aBrahmaValue[11] := Chr((Hour div 10) + ZeroOrd);
+ aBrahmaValue[12] := Chr((Hour mod 10) + ZeroOrd);
+
+ aBrahmaValue[13] := ':';
+ aBrahmaValue[14] := Chr((Minute div 10) + ZeroOrd);
+ aBrahmaValue[15] := Chr((Minute mod 10) + ZeroOrd);
+
+ aBrahmaValue[16] := ':';
+ aBrahmaValue[17] := Chr((Second div 10) + ZeroOrd);
+ aBrahmaValue[18] := Chr((Second mod 10) + ZeroOrd);
+
+ aBrahmaValue[19] := '.';
+ aBrahmaValue[20] := Chr((Fraction div 10) + ZeroOrd);
+ aBrahmaValue[21] := Chr((Fraction mod 10) + ZeroOrd);
+
+ aBrahmaValue[22] := #0;
+end;
+
+{ --------------------- Database Abilities ------------------------ }
+
+{ This is the version number for the driver DLL, not the physical database.
+ Crystal Reports uses this number to decide which list of function names
+ to expect to be exported from the DLL.
+
+ Crystal Reports OEM Tech Support advised me that this should be
+ identical to the version number coded into the PDBXBSE driver. As such,
+ the exported function names should be identical to PDBXBSE as well. }
+
+function PhysDbVersionNumber(
+ var MajorVersionNumber : Word;
+ var MinorVersionNumber : Word;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+begin
+ AddToLog('PhysDbVersionNumber');
+ MajorVersionNumber := 1;
+ MinorVersionNumber := 17;
+ Result := errPhysDbNoError;
+ AddToLogFmt(' MajMin: [%d.%d]', [MajorVersionNumber, MinorVersionNumber]);
+ AddResultToLog(Result);
+end;
+
+function CanRecognizeDataFile(
+ var CanRecognize : TcrBoolean;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+begin
+ AddToLog('CanRecognizeDataFile');
+ CanRecognize := true;
+ Result := errPhysDbNoError;
+ AddToLogFmt(' Can?: [%s]', [BoolToStr(CanRecognize)]);
+ AddResultToLog(Result);
+end;
+
+function CanFetchDataFileInfo(
+ var CanFetchFileInfo : TcrBoolean;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+begin
+ AddToLog('CanFetchDataFileInfo');
+ CanFetchFileInfo := true;
+ Result := errPhysDbNoError;
+ AddToLogFmt(' Can?: [%s]', [BoolToStr(CanFetchFileInfo)]);
+ AddResultToLog(Result);
+end;
+
+function CanFetchDataFileIndexInfo(
+ var CanFetchIndexInfo : TPhysDbIndexInfoCases;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+begin
+ AddToLog('CanFetchDataFileIndexInfo');
+ CanFetchIndexInfo := iiAllIndexesKnown;
+ Result := errPhysDbNoError;
+ AddToLogFmt(' Can?: [%d]', [Ord(CanFetchIndexInfo)]);
+ AddResultToLog(Result);
+end;
+
+function CanBuildIndex(
+ var CanBuildIndex : TPhysDbBuildIndexCases;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+begin
+ AddToLog('CanBuildIndex');
+ CanBuildIndex := biCannotBuildIndex;
+ Result := errPhysDbNoError;
+ AddToLogFmt(' Can?: [%d]', [ord(CanBuildIndex)]);
+ AddResultToLog(Result);
+end;
+
+function CanFetchNRecurringRecords(
+ var CanFetchNrecords : TcrBoolean;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+begin
+ AddToLog('CanFetchNRecurringRecords');
+ CanFetchNRecords := true;
+ Result := errPhysDbNoError;
+ AddToLogFmt(' Can?: [%s]', [BoolToStr(CanFetchNRecords)]);
+ AddResultToLog(Result);
+end;
+
+function SQLCompatible(
+ var IsSQLTypeDLL : TcrBoolean;
+ var CanBuildAndExecSQLQuery : TcrBoolean;
+ var CanExecSQLQuery : TcrBoolean;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+begin
+ AddToLog('SQLCompatible');
+ IsSQLTypeDLL := false;
+ CanBuildAndExecSQLQuery := false;
+ CanExecSQLQuery := false; {true - allow passing down rangeinfolist }
+ Result := errPhysDbNoError;
+ AddToLogFmt(' IsSQLTypeDLL?: [%s]', [BoolToStr(IsSQLTypeDLL)]);
+ AddToLogFmt(' CanBuildAndExecSQLQuery?: [%s]', [BoolToStr(CanBuildAndExecSQLQuery)]);
+ AddToLogFmt(' CanExecSQLQuery?: [%s]', [BoolToStr(CanExecSQLQuery)]);
+ AddResultToLog(Result);
+end;
+
+function CanReadSortedOrder(
+ var CanReadSorted : TcrBoolean;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+begin
+ AddToLog('CanReadSortedOrder');
+ CanReadSorted := True;
+ Result := errPhysDbNoError;
+ AddToLogFmt(' Can?: [%s]', [BoolToStr(CanReadSorted)]);
+ AddResultToLog(Result);
+end;
+
+function CanReadRangeOfValues(
+ var CanReadRange : TcrBoolean;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+begin
+ AddToLog('CanReadRangeOfValues');
+ CanReadRange := False;
+ Result := errPhysDbNoError;
+ AddToLogFmt(' Can?: [%s]', [BoolToStr(CanReadRange)]);
+ AddResultToLog(Result);
+end;
+
+function CanUseRecordLocking(
+ var RecordLockingPossible : TcrBoolean;
+ var RecordLockingPreferred : TcrBoolean;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+begin
+ AddToLog('CanUseRecordLocking');
+ RecordLockingPossible := false;
+ RecordLockingPreferred := false;
+ Result := errPhysDbNoError;
+ AddToLogFmt(' Record Locking Possible?: [%s]', [BoolToStr(RecordLockingPossible)]);
+ AddToLogFmt(' Record Locking Preferred?: [%s]', [BoolToStr(RecordLockingPreferred)]);
+ AddResultToLog(Result);
+end;
+
+function CanUseFileLocking(
+ var FileLockingPossible : TcrBoolean;
+ var FileLockingPreferred : TcrBoolean;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+begin
+ AddToLog('CanUseFileLocking');
+ FileLockingPossible := false;
+ FilelockingPreferred := false;
+ Result := errPhysDbNoError;
+ AddToLogFmt(' File Locking Possible?: [%s]', [BoolToStr(FileLockingPossible)]);
+ AddToLogFmt(' File Locking Preferred?: [%s]', [BoolToStr(FileLockingPreferred)]);
+ AddResultToLog(Result);
+end;
+
+
+{ ----------- Database Initialization and Termination ------------- }
+
+function InitPhysicalDatabase(ErrMsg : PAnsiChar) : TPhysDbError;
+begin
+ AddToLog('InitPhysicalDatabase');
+ { No special processing to initilize the database.
+ But we can't return PhysDbNotImplemented or Crystal will choke. }
+ IsTaskSuccess := True;
+ Result := errPhysDbNoError;
+ AddResultToLog(Result);
+end;
+
+function TermPhysicalDatabase(ErrMsg : PAnsiChar) : TPhysDbError;
+begin
+ AddToLog('TermPhysicalDatabase');
+ { No special processing to deinitialize the database.
+ But we can't return PhysDbNotImplemented or Crystal will choke. }
+ Result := errPhysDbNoError;
+ AddResultToLog(Result);
+end;
+
+function OpenSession(ErrMsg : PAnsiChar) : TPhysDbError;
+var
+ TaskFound : Boolean;
+ TaskIndex : integer;
+begin
+ AddToLog('OpenSession');
+ Result := errPhysDbNoError;
+ TaskIndex := -1;
+ {handling in the except block? }
+ try
+ Result := TaskList.NewTask(TaskFound, TaskIndex, ErrMsg);
+ if (Result = errPhysDbNoError) then
+ if not TaskFound then
+ FFSession.Open;
+ except
+ on EOutOfMemory do begin
+ Result := errPhysDbNotEnoughMemory;
+ StrPCopy(ErrMsg, '');
+ end;
+
+ on E: Exception do begin
+ if Result = errPhysDbNoError then
+ Result := errPhysDbErrMsgReturned;
+ if not Assigned(ErrMsg) then
+ StrPCopy(ErrMsg, E.Message);
+ end;
+ end;
+ if (Result = errPhysDbErrMsgReturned) then
+ AddToLogFmt(' ErrMsg: [%s]', [ErrMsg]);
+ AddResultToLog(Result);
+end;
+
+function TermSession(ErrMsg : PAnsiChar) : TPhysDbError;
+var
+ TaskFound : Boolean;
+ AlreadyInitialized : Boolean;
+begin
+ AddToLog('TermSession');
+ Result := TaskList.DeleteTask(TaskFound, AlreadyInitialized, ErrMsg);
+ if (Result = errPhysDbNoError) then
+ if TaskFound then
+ if not AlreadyInitialized then
+ FFSession.Close;
+ AddResultToLog(Result);
+end;
+
+
+{ ------------------------- Database Name -------------------------- }
+
+function FetchDatabaseName(var Name : PAnsiChar;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+begin
+ AddToLog('FetchDatabaseName');
+ try
+ Name := FFStrNew('FlashFiler 2');
+ Result := errPhysDbNoError;
+ except
+ Result := errPhysDbNotEnoughMemory;
+ end;
+ AddToLogFmt(' Name: [%s]', [Name]);
+ AddResultToLog(Result);
+end;
+
+function FreeDatabaseName(var Name : PAnsiChar;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+begin
+ AddToLog('FreeDatabaseName');
+ AddToLogFmt(' Name: [%s]', [Name]);
+ Result := errPhysDbNoError;
+ try
+ FFStrDispose(Name);
+ Name := nil;
+ except
+ on E: Exception do begin
+ if Result = errPhysDbNoError then
+ Result := errPhysDbErrMsgReturned;
+ StrPCopy(ErrMsg, E.Message);
+ end;
+ end;
+ if (Result = errPhysDbErrMsgReturned) then
+ AddToLogFmt(' ErrMsg: [%s]', [ErrMsg]);
+ AddResultToLog(Result);
+end;
+
+
+{ ---------------------- Log On and Log Off ----------------------- }
+
+function LogOnServer(ServerInfo : PPhysDbServerInfo;
+ var ServerHandle : PPhysDbServerHandle;
+ Password : PAnsiChar;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+begin
+ AddToLog('LogOnServer');
+ { Can't return PhysDbNotImplemented or Crystal will choke. }
+ Result := errPhysDbNoError;
+ AddToLogFmt(' Server Handle: [%d]', [ServerHandle]);
+ AddResultToLog(Result);
+end;
+
+function LogOffServer(
+ var ServerHandle : PPhysDbServerHandle;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+begin
+ AddToLog('LogOffServer');
+ { Can't return PhysDbNotImplemented or Crystal will choke. }
+ Result := errPhysDbNoError;
+ AddToLogFmt(' Server Handle: [%d]', [ServerHandle]);
+ AddResultToLog(Result);
+end;
+
+{ ------------------- Parse and Rebuild SQL Info -------------------- }
+
+function ParseLogOnInfo(
+ connectBuf : PAnsiChar;
+ bufSize : Word;
+ serverInfo : PPhysDbServerInfo;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+begin
+ AddToLog('ParseLogOnInfo');
+ Result := errPhysDbNotImplemented;
+ AddResultToLog(Result);
+end;
+
+function RebuildConnectBuf(
+ serverInfo : PPhysDbServerInfo;
+ connectBuf : PAnsiChar;
+ bufSize : Word;
+ ErrMsg : PAnsiChar) : TphysDbError;
+begin
+ AddToLog('RebuildConnectBuf');
+ Result := errPhysDbNotImplemented;
+ AddResultToLog(Result);
+end;
+
+
+{ -------------------- Open and Close Files ----------------------- }
+
+function InitDataFileHandle(FileName : PAnsiChar;
+ var FileHandle : PPhysDbFileHandle;
+ DatabaseHandle : TffDatabaseID;
+ hCursor : TffcursorID;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+var
+ vNotXlateDOSString : Boolean;
+ vNotXlateDOSMemo : Boolean;
+begin
+ Result := errPhysDbNoError;
+ try
+ {By default these two flags are FALSE : always convert OEM to ANSI,
+ check it now}
+ vNotXlateDOSString :=
+ (LongInt(FileHandle) and TRANSLATE_DOS_STRINGS) = 0;
+ vNotXlateDOSMemo :=
+ (LongInt(FileHandle) and TRANSLATE_DOS_MEMOS) = 0;
+
+ FFGetZeroMem(FileHandle, sizeof(TPhysDbFileHandle));
+ FileHandle^.DatabaseID := DatabaseHandle;
+ FileHandle^.CursorID := hCursor;
+ FileHandle^.NotXlateDOSString := vNotXlateDOSString;
+ FileHandle^.NotXlateDOSMemo := vNotXlateDOSMemo;
+
+ FileHandle^.PathAndFileName := FFStrAllocCopy(FileName);
+ except
+ on EOutOfMemory do begin
+ Result := errPhysDbNotEnoughMemory;
+ ServerEngine.CursorClose(hCursor);
+ ServerEngine.DatabaseClose(DatabaseHandle);
+ if Assigned(FileHandle) then
+ FFFreeMem(FileHandle, sizeof(TPhysDbFileHandle));
+ StrPCopy(ErrMsg, '');
+ end;
+
+ on E: Exception do begin
+ if Result = errPhysDbNoError then
+ Result := errPhysDbErrMsgReturned;
+ ServerEngine.CursorClose(hCursor);
+ ServerEngine.DatabaseClose(DatabaseHandle);
+ if Assigned(FileHandle) then
+ FFFreeMem(FileHandle, sizeof(TPhysDbFileHandle));
+ if not Assigned(ErrMsg) then {not assigned? }
+ StrPCopy(ErrMsg, E.Message);
+ end;
+ end;
+end;
+
+function OpenDatabase(DBName : PAnsiChar;
+ var DatabaseHandle : TffDatabaseID;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+var
+ FFError : TffResult;
+ DBNameUNC : TffShStr;
+begin
+ if not Assigned(DBName) then begin
+ Result := errPhysDbProgrammingError;
+ Exit;
+ end;
+
+ DBNameUNC := FFExpandUNCFilename(FFStrPas(DBName));
+ if (length(DBNameUNC) > 3) and
+ (DBNameUNC[length(DBNameUNC)] = '\') then
+ dec(DBNameUNC[0]);
+
+ FFSession.Open;
+ FFError := ServerEngine.DatabaseOpenNoAlias(FFSession.Client.ClientID,
+ DBNameUNC,
+ omReadOnly,
+ smShared,
+ DefaultTimeOut, {2000}{-1} {!!.05}
+ DatabaseHandle);
+ if FFError <> DBIERR_NONE then begin
+ Result := IDAPIError(FFError, ErrMsg);
+ Exit;
+ end;
+ Result := errPhysDbNoError;
+end;
+
+function OpenDataFile(DatabaseHandle : TffDatabaseID;
+ FileName : PAnsiChar;
+ var FileHandle : PPhysDbFileHandle;
+ IndexFileName : PAnsiChar;
+ TagName : PAnsiChar;
+ IndexId : Word;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+var
+ FFError : TffResult;
+ hCursor : TffCursorID;
+ TableName : TffShStr;
+ IndexName : TffShStr;
+ Stream : TMemoryStream;
+begin
+ TableName := FFExtractTableName(FFStrPas(FileName));
+ if (IndexFileName = nil) then
+ IndexName := ''
+ else
+ IndexName := FFStrPas(IndexFilename);
+
+ AddToLogFmt(' TableName: [%s]', [TableName]);
+ AddToLogFmt(' IndexName: [%s]', [IndexName]);
+
+ Stream := TMemoryStream.Create;
+ try
+ FFError := ServerEngine.TableOpen(DatabaseHandle,
+ TableName,
+ False,
+ IndexName,
+ IndexId,
+ omReadOnly,
+ smShared,
+ DefaultTimeOut, {2000}{-1} {!!.05}
+ hCursor,
+ Stream);
+ finally
+ Stream.Free;
+ end;
+ if FFError <> DBIERR_NONE then begin
+ ServerEngine.DatabaseClose(DatabaseHandle);
+ Result := IDAPIError(FFError, ErrMsg);
+ Exit;
+ end;
+
+ Result := InitDataFileHandle(FileName, FileHandle, DatabaseHandle,
+ hCursor, ErrMsg);
+end;
+
+function OpenDataFileIfRecognizedVer113(
+ FileName : PAnsiChar;
+ OpenDefaultIndex : TcrBoolean;
+ var Recognized : TcrBoolean;
+ var FileHandle : PPhysDbFileHandle;
+ CalledFromDirDLL : TcrBoolean;
+ var AliasName : PAnsiChar;
+ SilentMode : TcrBoolean;
+ DirInfo : PPhysDbFileDirectoryInfo;
+ DictInfo : PPhysDbFileDictionaryInfo;
+ SessionInfo : PPhysDbSessionInfo;
+ LogOnInfo : PPhysDbLogOnInfo;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+var
+ FileNameStr : TffShStr;
+ DatabaseHandle : TffDatabaseID;
+ DBNameOem : array[0..255] of AnsiChar;
+begin
+ AddToLog('OpenDataFileIfRecognizedVer113');
+ AddToLogFmt(' File Name: [%s]', [FileName]);
+ AddToLogFmt(' OpenDefIndex: [%s]', [BoolToStr(OpenDefaultIndex)]);
+
+ Result := errPhysDbNoError;
+ Recognized := false;
+ if not IsTaskSuccess then begin
+ AddToLog(' IsTaskSuccess is false');
+ AddToLogFmt(' Recognized? [%s]', [BoolToStr(Recognized)]);
+ AddResultToLog(Result);
+ Exit;
+ end;
+
+ FileHandle := nil;
+ DBNameOem[0] := #0;
+
+ if (AliasName <> nil) then
+ AliasName[0] := #0;
+
+ try
+
+ { Return error if file does not exist. }
+ FileNameStr := FFStrPas(FileName);
+ if not FileExists(FileNameStr) then begin
+ Result := errPhysDbFileDoesNotExist;
+ AddToLogFmt(' Recognized? [%s]', [BoolToStr(Recognized)]);
+ AddResultToLog(Result);
+ Exit;
+ end;
+
+ { Check to see if the file name has an FF2 extension. If not, then
+ we assume that it's not a FF table (this avoids the time-
+ consuming protocol and FF client initialization stuff).}
+ if (FFCmpShStrUC(FFExtractExtension(FileNameStr),
+ ffc_ExtForData, ffcl_Extension) <> 0) then begin
+ { No error, but file is not recognized }
+ Result := errPhysDbNoError;
+ AddToLogFmt(' Recognized? [%s]', [BoolToStr(Recognized)]);
+ AddResultToLog(Result);
+ Exit;
+ end;
+
+ {$IFDEF IDAPI_INTERNAL_LIMITS}
+ if NOpenDatabase >= MAX_DBS_PER_SESSION then begin
+ Recognized := false;
+ AddToLogFmt(' Recognized? [%s]', [BoolToStr(Recognized)]);
+ AddResultToLog(Result);
+ Exit;
+ end;
+ {$ENDIF}
+
+ FFStrPCopy(DBNameOem, FFExtractPath(FFStrPas(FileName)));
+ Result := OpenDatabase(DBNameOem, DatabaseHandle, ErrMsg);
+ if Result <> errPhysDbNoError then begin
+ AddToLogFmt(' Recognized? [%s]', [BoolToStr(Recognized)]);
+ AddResultToLog(Result);
+ Exit;
+ end;
+
+ {$IFDEF IDAPI_INTERNAL_LIMITS}
+ Inc(NOpenDatabase);
+ {$ENDIF}
+
+ {convert filename to oem? }
+ Recognized := OpenDataFile(DatabaseHandle, FileName, FileHandle, nil, nil, 0, ErrMsg) = errPhysDbNoError;
+ AddToLogFmt(' CursorID: [%d]', [FileHandle^.CursorID]);
+ Result := errPhysDbNoError;
+ except
+ on EOutOfMemory do begin
+ Result := errPhysDbNotEnoughMemory;
+ CloseDataFile(FileHandle, ErrMsg);
+ StrPCopy(ErrMsg, '');
+ end;
+
+ on E: Exception do begin
+ CloseDataFile(FileHandle, ErrMsg);
+ if Result = errPhysDbNoError then
+ Result := errPhysDbErrMsgReturned;
+ StrPCopy(ErrMsg, E.Message);
+ end;
+ end;
+ AddToLogFmt(' Recognized? [%s]', [BoolToStr(Recognized)]);
+ if (Result = errPhysDbErrMsgReturned) then
+ AddToLogFmt(' ErrMsg: [%s]', [ErrMsg]);
+ AddResultToLog(Result);
+end;
+
+function OpenDataAndIndexFileIfRecogV113(
+ FileName : PAnsiChar;
+ IndexName : PAnsiChar;
+ var Recognized : TcrBoolean;
+ var FileHandle : PPhysDbFileHandle;
+ var AliasName : PAnsiChar;
+ SilentMode : TcrBoolean;
+ DirInfo : PPhysDbFileDirectoryInfo;
+ DictInfo : PPhysDbFileDictionaryInfo;
+ SessionInfo: PPhysDbSessionInfo;
+ LogOnInfo : PPhysDbLogOnInfo;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+var
+ FFError : TffResult;
+begin
+ AddToLog('OpenDataAndIndexFileIfRecogV113');
+ AddToLogFmt(' FName: [%s]', [FileName]);
+ AddToLogFmt(' InxName: [%s]', [IndexName]);
+ Result := errPhysDbNoError;
+ try
+ Recognized := false;
+ AliasName := nil;
+
+ { Open the data file first }
+ Result := OpenDataFileIfRecognizedVer113(FileName, False, Recognized,
+ FileHandle, False, FileName, SilentMode, DirInfo,
+ DictInfo, SessionInfo, LogOnInfo, ErrMsg);
+ if Result <> errPhysDbNoError then Exit;
+ AddToLogFmt(' FName: [%s]', [FileHandle^.PathAndFileName]);
+ AddToLogFmt(' Cursor ID: [%d]', [FileHandle^.CursorID]);
+ FFError := ServerEngine.CursorSwitchToIndex(FileHandle^.CursorID,
+ IndexName,
+ 0,
+ True);
+ if (FFError = DBIERR_NOCURRREC) then
+ FFError := ServerEngine.CursorSwitchToIndex(FileHandle^.CursorID,
+ IndexName,
+ 0,
+ False);
+
+ if FFError <> DBIERR_NONE then
+ Result := IDAPIError(FFError, ErrMsg);
+ except
+ on E: Exception do begin
+ if Result = errPhysDbNoError then
+ Result := errPhysDbErrMsgReturned;
+ StrPCopy(ErrMsg, E.Message);
+ end;
+ end;
+ if (Result = errPhysDbErrMsgReturned) then
+ AddToLogFmt(' ErrMsg: [%s]', [ErrMsg]);
+ AddResultToLog(Result);
+end;
+
+function OpenDataFileAndIndexChoiceVer113(
+ FileName : PAnsiChar;
+ InfoPtr : PPhysDbFileInfo;
+ IndexesPtr : PPhysDbIndexesInfo;
+ var FileHandle : PPhysDbFileHandle;
+ SilentMode : TcrBoolean;
+ DirInfo : PPhysDbFileDirectoryInfo;
+ DictInfo : PPhysDbFileDictionaryInfo;
+ SessionInfo: PPhysDbSessionInfo;
+ LogOnInfo : PPhysDbLogOnInfo;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+var
+ DatabaseHandle: TffDatabaseID;
+ FileNameOem: array[0..MAX_PATH] of AnsiChar;
+ DBNameOem: array[0..MAX_PATH] of AnsiChar;
+begin
+ AddToLog('OpenDataFileandIndexChoiceVer113');
+
+ Result := errPhysDbNoError;
+ try
+ {$IFDEF IDAPI_INTERNAL_LIMITS}
+ if NOpenDatabase >= MAX_DBS_PER_SESSION then begin
+ Result := errPhysDbErrorHandledByDBDLL;
+ Exit;
+ end;
+ {$ENDIF}
+
+ StrPCopy(DBNameOem, ExtractFilePath(StrPas(FileName)));
+ Result := OpenDatabase(DBNameOem, DatabaseHandle, ErrMsg);
+ AddToLogFmt(' DatabaseID: [%d]', [DatabaseHandle]);
+ if Result = errPhysDbNoError then begin
+ {$IFDEF IDAPI_INTERNAL_LIMITS}
+ Inc(NOpenDatabase);
+ {$ENDIF}
+
+ StrCopy(FileNameOem, FileName);
+
+ with IndexesPtr^.IndexInfo^[IndexesPtr^.IndexInUse] do
+ Result := OpenDataFile(DatabaseHandle, FilenameOem, FileHandle,
+ IndexFilename, TagName, IndexesPtr^.IndexInUse, ErrMsg);
+ AddToLogFmt(' FName: [%s]', [FileHandle^.PathAndFileName]);
+ AddToLogFmt(' CursorID: [%d]', [FileHandle^.CursorID]);
+ end;
+ except
+ on E: Exception do begin
+ if Result = errPhysDbNoError then
+ Result := errPhysDbErrMsgReturned;
+ StrPCopy(ErrMsg, E.Message);
+ end;
+ end;
+ if (Result = errPhysDbErrMsgReturned) then
+ AddToLogFmt(' ErrMsg: [%s]', [ErrMsg]);
+ AddResultToLog(Result);
+end;
+
+function CloseDataFile(var FileHandle : PPhysDbFileHandle;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+begin
+ AddToLog('CloseDataFile');
+ Result := errPhysDbNoError;
+ try
+ if Assigned(FileHandle) then begin
+ AddToLogFmt(' FName: [%s]', [FileHandle^.PathAndFileName]);
+ AddToLogFmt(' CursorID: [%d]', [FileHandle^.CursorID]);
+ with FileHandle^ do begin
+ ServerEngine.CursorClose(CursorID);
+ if DatabaseID > 0 then { not sure why DbiCloseCursor is clearing this }
+ ServerEngine.DatabaseClose(DatabaseID);
+ {$IFDEF IDAPI_INTERNAL_LIMITS}
+ if NOpenDatabase > 0 then
+ Dec(NOpenDatabase);
+ {$ENDIF}
+
+ FFStrDispose(PathAndFileName);
+ FFStrDispose(IndexFileName);
+ FFStrDispose(TagName);
+ end;
+ FFFreeMem(FileHandle, sizeof(TPhysDbFileHandle));
+ end;
+ FileHandle := nil;
+ except
+ on E: Exception do begin
+ if Result = errPhysDbNoError then
+ Result := errPhysDbErrMsgReturned;
+ StrPCopy(ErrMsg, E.Message);
+ end;
+ end;
+ if (Result = errPhysDbErrMsgReturned) then
+ AddToLogFmt(' ErrMsg: [%s]', [ErrMsg]);
+ AddResultToLog(Result);
+end;
+
+
+{ ---------------------- Fetch Data File Info --------------------- }
+
+function FetchDataFileInfo(
+ FileHandle : PPhysDbFileHandle;
+ InfoDefaultsExist : TcrBoolean;
+ var InfoPtr : PPhysDbFileInfo;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+var
+ I : Integer;
+ FieldOffset : LongInt;
+
+ Buffer : TffShStr;
+ FFFieldType : TffFieldType;
+
+ BDEType : Word;
+ BDESubType : Word;
+ LogSize : Word;
+begin
+ AddToLog('FetchDataFileInfo');
+ AddToLogFmt(' File Name: [%s]', [FileHandle^.PathAndFileName]);
+ AddToLogFmt(' CursorID: [%d]', [FileHandle^.CursorID]);
+
+ Result := errPhysDbNoError;
+ try
+ try
+
+ { Allocate the file info structure }
+ FFGetZeroMem(InfoPtr, sizeof(TPhysDbFileInfo));
+
+ with InfoPtr^ do begin
+ NFields := 0;
+ FieldInfo := nil;
+ { Always set the file to the recurring type, even if file contains only
+ 0 or 1 records, since the file may grow in size. }
+ FileType := ftRecurringFile;
+ { Set tablename to nil so the file name will be used by default }
+ TableName := nil;
+
+ { Get number of fields in table }
+ NFields := TFFProxyCursor(FileHandle^.CursorID).Dictionary.FieldCount;
+ NBytesInPhysRecord := TFFProxyCursor(FileHandle^.CursorID).PhysicalRecordSize;
+
+ if NFields > 0 then begin
+ { Retrieve field info }
+
+ { Allocate the field info array structure }
+ FFGetZeroMem(FieldInfo, SizeOf(TPhysDbFieldInfo) * NFields);
+
+ { Build the field info array }
+ FieldOffset := 0;
+ for I := 0 to pred(NFields) do begin
+ with FieldInfo^[I], TFFProxyCursor(FileHandle^.CursorID) do begin
+ { Allocate space for the field name }
+ Name := FFStrNew(Dictionary.FieldName[I]);
+ { Determine Brahma data type and width }
+ NBytesInNativeField := Dictionary.FieldLength[I];
+ FFFieldType := Dictionary.FieldType[I];
+ MapFFTypeToBDE(FFFieldType, NBytesInNativeField, BDEType, BDESubType, LogSize);
+ NativeFieldType := BDEType;
+ if NativeFieldType = fldBLOB then
+ NativeFieldType := BDESubType;
+ if (NativeFieldType = fldFLOAT) and (BDESubType = fldstMONEY) then
+ NativeFieldType := BDESubType;
+
+ Result := Convert2BrahmaType(FileHandle,
+ NativeFieldType,
+ NBytesInNativeField,
+ FieldType,
+ NBytesInField,
+ ErrMsg);
+ if Result <> errPhysDbNoError then Exit;
+
+ if FieldType = ftUnknownField then begin
+ AddToLog('Convert2BrahmaType: Unknown field');
+ AddToLogFmt(' Field: [%s]', [Dictionary.FieldName[I]]);
+ AddToLogFmt(' Type : [%d]', [NativeFieldType]);
+ end;
+
+ case FFFieldType of
+ fftShortString,
+ fftShortAnsiStr : NativeFieldOffset := Succ(FieldOffset);
+ else
+ NativeFieldOffset := FieldOffset;
+ end;
+ NDecPlacesInNativeField := Dictionary.FieldUnits[I];
+ Picture := nil;
+ Alignment := alLeftAlignedChars;
+ Sortable := true;
+ end;
+
+ { Calculate the offset for the next field }
+ Inc(FieldOffset, FieldInfo^[I].NBytesInNativeField);
+ end;
+ end;
+
+ { these are not set by this routine }
+ NBytesInReadRecord := 0;
+ NFieldsInReadRecord := 0;
+ NBytesInIndexRecord := 0;
+ NFieldsInIndexRecord := 0;
+ end;
+ except { InfoPtr error handler }
+ on EOutOfMemory do begin
+ Result := errPhysDbNotEnoughMemory;
+ FreeDataFileInfo(InfoPtr, ErrMsg);
+ StrPCopy(ErrMsg, '');
+ end;
+
+ on E: Exception do begin
+ FreeDataFileInfo(InfoPtr, ErrMsg);
+ if Result = errPhysDbNoError then
+ Result := errPhysDbErrMsgReturned;
+ StrPCopy(ErrMsg, E.Message);
+ end;
+ end;
+ finally
+ Buffer := PhysDbErrors[Result]; { this seems necessary for 32-bit, debug mode only }
+ end;
+ if (InfoPtr <> nil) then begin
+ with InfoPtr^ do begin
+ AddToLogFmt(' InfoPtr.NFields: [%d]', [NFields]);
+ AddToLogFmt(' InfoPtr.NBytesInPhysRecord: [%d]', [NBytesInPhysRecord]);
+ for i := 0 to pred(NFields) do begin
+ AddToLogFmt(' FieldName[%d]: [%s]', [i, FieldInfo^[i].Name]);
+ end;
+ AddBlockToLog(' InfoPtr.FieldInfo', FieldInfo, sizeOf(TPhysDbFieldInfo) * NFields);
+ end;
+ end;
+ if (Result = errPhysDbErrMsgReturned) then
+ AddToLogFmt(' ErrMsg: [%s]', [ErrMsg]);
+ AddResultToLog(Result);
+end;
+
+function FreeDataFileInfo(
+ var InfoPtr : PPhysDbFileInfo;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+var
+ i : Integer;
+begin
+ AddToLog('FreeDataFileInfo');
+ Result := errPhysDbNoError;
+ try
+ if Assigned(InfoPtr) then begin
+ with InfoPtr^ do begin
+ FFStrDispose(TableName);
+ if Assigned(FieldInfo) then begin
+ for I := 0 to pred(NFields) do begin
+ FFStrDispose(FieldInfo^[I].Name);
+ FFStrDispose(FieldInfo^[I].Picture);
+ end;
+ FFFreeMem(FieldInfo, Sizeof(TPhysDbFieldInfo) * NFields);
+ end;
+ end;
+ FFFreeMem(InfoPtr, sizeof(TPhysDbFileInfo));
+ end;
+ InfoPtr := nil;
+ except
+ on E: Exception do begin
+ if Result = errPhysDbNoError then
+ Result := errPhysDbErrMsgReturned;
+ StrPCopy(ErrMsg, E.Message);
+ end;
+ end;
+ if (Result = errPhysDbErrMsgReturned) then
+ AddToLogFmt(' ErrMsg: [%s]', [ErrMsg]);
+ AddResultToLog(Result);
+end;
+
+function FetchDataFileIndexInfo(
+ FileHandle: PPhysDbFileHandle;
+ InfoPtr: PPhysDbFileInfo;
+ var IndexesPtr: PPhysDbIndexesInfo;
+ ErrMsg: PAnsiChar) : TPhysDbError;
+var
+ I : Integer;
+
+
+ function FetchIndexInfo: TPhysDbError;
+ var
+ Index : integer;
+ IndexDesc : IDXDesc;
+ FFIndexDesc : TffIndexDescriptor;
+ FieldN : Integer;
+ begin
+ with IndexesPtr^ do begin
+ for Index := 1 to NIndexes do begin {!!.02}
+ FFIndexDesc := TFFProxyCursor(FileHandle^.CursorID).Dictionary.IndexDescriptor[Index]^;
+ GetBDEIndexDescriptor(FFIndexDesc, IndexDesc);
+
+ with IndexInfo^[Pred(Index)] do begin {!!.02}
+ ValuesUnique := IndexDesc.bUnique;
+ Ascending := not IndexDesc.bDescending;
+
+ { Allocate space for the filename }
+ if StrLen(IndexDesc.szName) <> 0 then begin
+ IndexFileName := FFStrAlloc(StrLen(IndexDesc.szName) + 1);
+ OemToAnsi(IndexDesc.szName, IndexFilename);
+ end;
+
+ { Allocate space for the tagname }
+ if StrLen(IndexDesc.szTagName) <> 0 then begin
+ TagName := FFStrAlloc(StrLen(IndexDesc.szTagName) + 1);
+ OemToAnsi(IndexDesc.szTagName, TagName);
+ end;
+
+ IndexType := IndexDesc.iKeyExpType;
+ CaseSensitive := not IndexDesc.bCaseInsensitive;
+
+ if IndexDesc.bExpIdx then begin
+ { omitted a bunch}
+ end
+ else begin
+ DefaultIndexFileName := not Assigned(IndexFileName);
+ DefaultTagName := not Assigned(TagName);
+ IndexExpr := nil;
+ EstimatedNBytesInexpr := 0;
+
+ NFields := IndexDesc.iFldsInKey;
+
+ { Allocate the output list structure }
+ FFGetZeroMem(FieldNumInFile, SizeOf(TcrInt16u) * NFields);
+
+ for FieldN := 0 to pred(NFields) do
+ FieldNuminFile^[FieldN] := IndexDesc.aiKeyFld[FieldN] - 1; {!!.02}
+ end;
+ end;
+ end;
+ end;
+ Result := errPhysDbNoError;
+ end;
+
+begin
+ AddToLog('FetchDataFileIndexInfo');
+ Result := errPhysDbNoError;
+
+ { Allocate the index info structure }
+ try
+ FFGetZeroMem(IndexesPtr, SizeOf(TPhysDbIndexesInfo));
+ with IndexesPtr^ do begin
+
+ { Get number of indexes in the table minus the SEQ Idx} {!!.02}
+ NIndexes := TFFProxyCursor(FileHandle^.CursorID).Dictionary.IndexCount - 1; {!!.02}
+ AddToLogFmt(' File Name: [%s]', [FileHandle^.PathAndFileName]);
+ AddToLogFmt(' CursorID: [%d]', [FileHandle^.CursorID]);
+
+ if NIndexes > 0 then begin
+
+ { Allocate the index info structures }
+ FFGetZeroMem(IndexInfo, SizeOf(TPhysDbIndexInfo) * NIndexes);
+
+ Result := FetchIndexInfo;
+ if Result <> errPhysDbNoError then SysUtils.Abort;
+ end;
+ end;
+ except { InfoPtr error handler }
+ on EOutOfMemory do begin
+ Result := errPhysDbNotEnoughMemory;
+ FreeDataFileIndexInfo(IndexesPtr, ErrMsg);
+ StrPCopy(ErrMsg, '');
+ end;
+
+ on E: Exception do begin
+ FreeDataFileIndexInfo(IndexesPtr, ErrMsg);
+ if Result = errPhysDbNoError then
+ Result := errPhysDbErrMsgReturned;
+ StrPCopy(ErrMsg, E.Message);
+ end;
+ end;
+ if (IndexesPtr <> nil) then begin
+ with IndexesPtr^ do begin
+ AddToLogFmt(' IndexesPtr.NIndexes: [%d]', [NIndexes]);
+ for i := 0 to pred(NIndexes) do begin
+ AddToLogFmt(' IndexName[%d]: [%s]', [i, IndexInfo^[i].IndexFileName]);
+ end;
+ AddBlockToLog(' IndexesPtr.IndexInfo', IndexInfo, sizeOf(TPhysDbIndexInfo) * NIndexes);
+ end;
+ end;
+ if (Result = errPhysDbErrMsgReturned) then
+ AddToLogFmt(' ErrMsg: [%s]', [ErrMsg]);
+ AddResultToLog(Result);
+end;
+
+function FreeDataFileIndexInfo(
+ var IndexesPtr: PPhysDbIndexesInfo;
+ ErrMsg: PAnsiChar) : TPhysDbError;
+var
+ I: Integer;
+begin
+ AddToLog('FreeDataFileIndexInfo');
+ Result := errPhysDbNoError;
+ try
+ if Assigned(IndexesPtr) then begin
+ if Assigned(IndexesPtr^.IndexInfo) then begin
+ for I := 0 to pred(IndexesPtr^.NIndexes) do
+ with IndexesPtr^.IndexInfo^[I] do begin
+ FFFreeMem(FieldNumInFile, SizeOf(Word) * NFields);
+ FFStrDispose(IndexExpr);
+ FFStrDispose(IndexFileName);
+ FFStrDispose(TagName);
+ end;
+
+ FFFreeMem(IndexesPtr^.IndexInfo, SizeOf(TPhysDbIndexInfo) * IndexesPtr^.NIndexes);
+ end;
+ FFFreeMem(IndexesPtr, SizeOf(TPhysDbIndexesInfo));
+ IndexesPtr := nil;
+ end;
+ except
+ on E: Exception do begin
+ if Result = errPhysDbNoError then
+ Result := errPhysDbErrMsgReturned;
+ StrPCopy(ErrMsg, E.Message);
+ end;
+ end;
+ if (Result = errPhysDbErrMsgReturned) then
+ AddToLogFmt(' ErrMsg: [%s]', [ErrMsg]);
+ AddResultToLog(Result);
+end;
+
+function BuildAndExecSQLQuery(
+ FileHandleList: PPhysDbFileHandleArray;
+ FileInfoList: PPhysDbFileInfoArray;
+ LinkNonSQLFlags: PcrBooleanArray;
+ IndexesInfoList: PPhysDbIndexesInfoArray;
+ RangeInfoList: PPhysDbRangeInfoArray;
+ NFiles: Word;
+ LinkInfoList: PPhysDbFileLinkInfoArray;
+ NFileLinks: Word;
+ SqlDrivingFile: TcrBoolean;
+ ErrMsg: PAnsiChar) : TPhysDbError;
+begin
+ AddToLog('BuildAndExecSQLQuery');
+ { This is what PDBBDE returns }
+ Result := errPhysDbNotImplemented;
+ AddResultToLog(Result);
+end;
+
+function InitDataFileForReadingVer17(
+ FileHandle : PPhysDbFileHandle;
+ InfoPtr : PPhysDbFileInfo;
+ IndexesPtr : PPhysDbIndexesInfo;
+ RangeInfoList : PPhysDbRangeInfoArray;
+ NRanges : TcrInt16u;
+ var CanDoRangeLimit : TcrBoolean;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+var
+ FFError : TffResult;
+
+ function CanDoRangeLimitOnField(
+ FileHandle : PPhysDbFileHandle;
+ InfoPtr : PPhysDbFileInfo;
+ IndexesPtr : PPhysDbIndexesInfo;
+ RangeInfoList : PPhysDbRangeInfoArray;
+ NRanges : Word;
+ var CanDoRangeLimit : TcrBoolean;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+ var
+ IndexInfo : TPhysDbIndexInfo;
+ ContinueBuildStopKey : Boolean;
+ ContinueBuildStartKey : Boolean;
+ StopKeyOffset : integer;
+ StartKeyLen : integer;
+ NFieldsInStartKey : integer;
+ MinInclusive : Boolean;
+
+ RangeN : integer;
+ FieldN : integer;
+ TempPtr : Pointer;
+ TempBool : TcrBoolean;
+ IndexFieldN : integer;
+ RangeFieldN : integer;
+
+ SearchCond : TffSearchKeyAction;
+
+ function InitLimitRangeInfo(
+ FileHandle : PPhysDbFileHandle;
+ RangeInfoList : PPhysDbRangeInfoArray;
+ RangeIndex : integer;
+ RangeFieldN : integer;
+ FieldInfo : PPhysDbFieldInfo;
+ var ContinueBuildStartKey : Boolean;
+ var StartKeyLen : integer;
+ var ContinueBuildStopKey : Boolean;
+ var StopKeyOffset : integer;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+ begin
+ Result := errPhysDbNoError;
+
+ with FileHandle^.ReadInfo^.RangeFieldInfo^[RangeIndex] do begin
+ FieldNo := RangeFieldN;
+ OffsetInRecord := FieldInfo^.OffsetInIndexRecord;
+ FieldLength := FieldInfo^.NBytesInNativeField;
+ FieldType := FieldInfo^.FieldType;
+ NativeFieldOffset := FieldInfo^.NativeFieldOffset;
+ NativeFieldType := FieldInfo^.NativeFieldType;
+ NBytesInNativeField := FieldINfo^.NBytesInNativeField;
+ end;
+
+ with RangeInfoList^[RangeIndex].FieldRanges^[0] do begin
+ if ContinueBuildStartKey and Assigned(MinFieldValue) then
+ Inc(StartKeyLen, FieldInfo^.NBytesInNativeField)
+ else
+ ContinueBuildStartKey := False;
+
+ if ContinueBuildStopKey and Assigned(MaxFieldValue) then begin
+ with FileHandle^.ReadInfo^.RangeFieldInfo^[RangeIndex] do begin
+ { Makes no sense to me; we already did this }
+ FieldNo := RangeFieldN;
+ OffsetInRecord := FieldInfo^.OffsetInIndexRecord;
+ FieldLength := FieldInfo^.NBytesInNativeField;
+ FieldType := FieldInfo^.FieldType;
+ NativeFieldOffset := FieldInfo^.NativeFieldOffset;
+ NativeFieldType := FieldInfo^.NativeFieldType;
+ NBytesInNativeField := FieldInfo^.NBytesInNativeField;
+ NDecPlacesInNativeField := FieldInfo^.NDecPlacesInNativeField;
+ OffsetInStopKeyBuf := StopKeyOffset;
+ StopInclusive := RangeInfoList^[RangeIndex].FieldRanges^[0].MaxInclusive;
+ end;
+ Inc(StopKeyOffset, FieldInfo^.NBytesInNativeField);
+ FileHandle^.ReadInfo^.StopKeyLen := StopKeyOffset;
+ Inc(FileHandle^.ReadInfo^.NStopKeyRanges);
+ end
+ else
+ ContinueBuildStopKey := False;
+ end;
+ end;
+
+ function BuildStringRanges(
+ FileHandle: PPhysDbFileHandle;
+ RangeInfoList: PPhysDbRangeInfoArray;
+ RangeIndex: TcrInt16u;
+ RangeFieldN: TcrInt16u;
+ FieldInfo: PPhysDbFieldInfo;
+ ErrMsg: PAnsiChar) : TPhysDbError;
+ var
+ SavedOffset: TcrINt16u;
+ KeyBuf,
+ KeyBufOem,
+ StartKeyBuf,
+ StopKeyBuf: PAnsiChar;
+ begin
+ SavedOffset := StopKeyOffset;
+ Result := InitLimitRangeInfo(FileHandle, RangeInfoList, RangeIndex,
+ RangeFieldN, FieldInfo, ContinueBuildStartKey,
+ StartKeyLen, ContinueBuildStopKey, StopKeyOffset,
+ ErrMsg);
+ if Result <> errPhysDbNoError then Exit;
+
+ if ContinueBuildStartKey then begin
+ KeyBuf := RangeInfoList^[RangeIndex].FieldRanges^[0].MinFieldValue;
+ try
+ KeyBufOem := FFStrAllocCopy(KeyBuf);
+ except
+ Result := errPhysDbNotEnoughMemory;
+ Exit;
+ end;
+
+ try
+ AnsiToOem(keyBufOem, keyBufOem);
+
+ TFFProxyCursor(FileHandle^.CursorID).Dictionary.SetRecordField(RangeFieldN,
+ FileHandle^.ReadInfo^.PhysRecordBuf,
+ KeyBufOem);
+ finally
+ FFStrDispose(KeyBufOem);
+ end;
+ end;
+
+ if ContinueBuildStopKey then begin
+ KeyBuf := @FileHandle^.ReadInfo^.StopKeyBuf[SavedOffset];
+ StrCopy(KeyBuf, @RangeInfoList^[RangeIndex].FieldRanges^[0].MaxFieldValue);
+ AnsiToOem(keyBuf, keyBuf);
+ end;
+
+ { If current field of min and max range in index are not equal, do not
+ try to build stop key. }
+
+ with RangeInfoList^[RangeIndex].FieldRanges^[0] do begin
+ StartKeyBuf := @MinFieldValue;
+ StopKeyBuf := @MaxFieldValue;
+ end;
+
+ if not Assigned(StartKeyBuf) or
+ not Assigned(StopKeyBuf) or
+ (StrComp(StartKeyBuf, StopKeyBuf) <> 0) then
+ ContinueBuildStopKey := False;
+ end;
+
+ function BuildDateRanges(
+ FileHandle: PPhysDbFileHandle;
+ RangeInfoList: PPhysDbRangeInfoArray;
+ RangeIndex: TcrInt16u;
+ RangeFieldN: TcrInt16u;
+ FieldInfo: PPhysDbFieldInfo;
+ ErrMsg: PAnsiChar) : TPhysDbError;
+ var
+ SavedOffset : TcrInt16u;
+ Year : TcrInt16s;
+ Month : TcrInt16u;
+ Day : TcrInt16u;
+ DateValue : TDbiDate;
+ FieldLen : TcrInt16u;
+ KeyBuf : PDBIDate;
+ StartKeyBuf : PDBIDate;
+ StopKeyBuf : PDbiDate;
+ begin
+ SavedOffset := StopKeyOffset;
+
+ Result := InitLimitRangeInfo(FileHandle, RangeInfoList, RangeIndex,
+ RangeFieldN, FieldInfo, ContinueBuildStartKey,
+ StartKeyLen, ContinueBuildStopKey, StopKeyOffset,
+ ErrMsg);
+ if Result <> errPhysDbNoError then Exit;
+
+ if ContinueBuildStartKey then begin
+ with RangeInfoList^[RangeIndex].FieldRanges^[0] do
+ CrDateToYearMonthDay(TcrDate(MinFieldValue^), Year, Month, Day);
+ DateValue := FFBDEDateEncode(Day, Month, Year);
+ TFFProxyCursor(FileHandle^.CursorID).Dictionary.SetRecordField(RangeFieldN,
+ FileHandle^.ReadInfo^.PhysRecordBuf,
+ @DateValue);
+ end;
+
+ if ContinueBuildStopKey then begin
+ FieldLen := StopKeyOffset - SavedOffset;
+ KeyBuf := PDbiDate(@FileHandle^.ReadInfo^.StopKeyBuf[SavedOffset]);
+ with RangeInfoList^[RangeIndex].FieldRanges^[0] do
+ CrDateToYearMonthDay(TcrDate(MaxFieldValue^), Year, Month, Day);
+ DateValue := FFBDEDateEncode(Day, Month, Year);
+ Move(DateValue, KeyBuf^, FieldLen);
+ end;
+
+ { If current field of min and max range in index are not equal, do not
+ try to build stop key. }
+
+ with RangeInfoList^[RangeIndex].FieldRanges^[0] do begin
+ StartKeyBuf := PDbiDate(@MinFieldValue);
+ StopKeyBuf := PDbiDate(@MaxFieldValue);
+ end;
+
+ if not Assigned(StartKeyBuf) or
+ not Assigned(StopKeyBuf) or
+ (StartKeyBuf^ <> StopKeyBuf^) then
+ ContinueBuildStopKey := False;
+ end;
+
+ function BuildIntegerRanges(
+ FileHandle: PPhysDbFileHandle;
+ RangeInfoList: PPhysDbRangeInfoArray;
+ RangeIndex: TcrInt16u;
+ RangeFieldN: TcrInt16u;
+ FieldInfo: PPhysDbFieldInfo;
+ ErrMsg: PAnsiChar) : TPhysDbError;
+ var
+ SavedLen,
+ SavedOffset: TcrInt16u;
+ FieldLen: TcrInt16u;
+ KeyBuf: PAnsiChar;
+ StartKeyValue,
+ StopKeyValue: TcrInt32s;
+ ShortValue: TcrInt16s;
+ LongValue: TcrInt32s;
+ begin
+ SavedLen := StartKeyLen;
+ SavedOffset := StopKeyOffset;
+
+ Result := InitLimitRangeInfo(FileHandle, RangeInfoList, RangeIndex,
+ RangeFieldN, FieldInfo, ContinueBuildStartKey,
+ StartKeyLen, ContinueBuildStopKey, StopKeyOffset,
+ ErrMsg);
+ if Result <> errPhysDbNoError then Exit;
+
+ StartKeyValue := 0;
+ StopKeyValue := 0;
+
+ if ContinueBuildStartKey then begin
+ FieldLen := StartKeyLen - SavedLen;
+ if FieldLen = 2 then begin
+ with RangeInfoList^[RangeIndex].FieldRanges^[0] do
+ ShortValue := TcrInt16s(MinFieldValue^);
+ StartKeyValue := ShortValue;
+ TFFProxyCursor(FileHandle^.CursorID).Dictionary.SetRecordField(RangeFieldN,
+ FileHandle^.ReadInfo^.PhysRecordBuf,
+ @ShortValue);
+ end
+ else begin
+ with RangeInfoList^[RangeIndex].FieldRanges^[0] do
+ LongValue := TcrInt32s(MinFieldValue^);
+ StartKeyValue := LongValue;
+ TFFProxyCursor(FileHandle^.CursorID).Dictionary.SetRecordField(RangeFieldN,
+ FileHandle^.ReadInfo^.PhysRecordBuf,
+ @LongValue);
+ end;
+ end;
+
+ if ContinueBuildStopKey then begin
+ FieldLen := stopKeyOffset - SavedOffset;
+ KeyBuf := @FileHandle^.ReadInfo^.StopKeyBuf[SavedOffset];
+ if FieldLen = 2 then begin
+ with RangeInfoList^[RangeIndex].FieldRanges^[0] do
+ ShortValue := TcrInt16s(MaxFieldValue^);
+ StopKeyValue := ShortValue;
+ Move(ShortValue, KeyBuf^, FieldLen);
+ end
+ else begin
+ with RangeInfoList^[RangeIndex].FieldRanges^[0] do
+ LongValue := TcrInt32s(MaxFieldValue^);
+ StopKeyValue := LongValue;
+ Move(LongValue, KeyBuf^, FieldLen);
+ end;
+ end;
+
+ { If current field of min and max range in index are not equal, do not
+ try to build stop key. }
+ if ContinueBuildStopKey and ContinueBuildStartKey then
+ if StartKeyValue <> StopKeyValue then
+ ContinueBuildStopKey := False;
+ end;
+
+ function BuildDoubleRanges(
+ FileHandle: PPhysDbFileHandle;
+ RangeInfoList: PPhysDbRangeInfoArray;
+ RangeIndex: TcrInt16u;
+ RangeFieldN: TcrInt16u;
+ FieldInfo: PPhysDbFieldInfo;
+ ErrMsg: PAnsiChar) : TPhysDbError;
+ var
+ SavedOffset: TcrInt16u;
+ DoubleValue: Double;
+ FieldLen: TcrInt16u;
+ KeyBuf: PAnsiChar;
+ StartKeyBuf,
+ StopKeyBuf: PcrNumber;
+ begin
+ SavedOffset := StopKeyOffset;
+
+ Result := InitLimitRangeInfo(FileHandle, RangeInfoList, RangeIndex,
+ RangeFieldN, FieldInfo, ContinueBuildStartKey,
+ StartKeyLen, ContinueBuildStopKey, StopKeyOffset,
+ ErrMsg);
+ if Result <> errPhysDbNoError then Exit;
+
+ if ContinueBuildStartKey then begin
+ with RangeInfoList^[RangeIndex].FieldRanges^[0] do
+ DoubleValue := NumberToDouble(TcrNumber(MinFieldValue^));
+ TFFProxyCursor(FileHandle^.CursorID).Dictionary.SetRecordField(RangeFieldN,
+ FileHandle^.ReadInfo^.PhysRecordBuf,
+ @DoubleValue);
+ end;
+
+ if ContinueBuildStopKey then begin
+ FieldLen := StopKeyOffset - SavedOffset;
+ KeyBuf := @FileHandle^.ReadInfo^.StopKeyBuf[SavedOffset];
+ with RangeInfoList^[RangeIndex].FieldRanges^[0] do
+ DoubleValue := NumberToDouble(TcrNumber(MaxFieldValue^));
+ Move(DoubleValue, KeyBuf^, FieldLen);
+ end;
+
+ { If current field of min and max range in index are not equal, do not
+ try to build stop key. }
+
+ with RangeInfoList^[RangeIndex].FieldRanges^[0] do begin
+ StartKeyBuf := PcrNumber(@MinFieldValue);
+ StopKeyBuf := PcrNumber(@MaxFieldValue);
+ end;
+
+ if not Assigned(StartKeyBuf) or
+ not Assigned(StopKeyBuf) or
+ (StartKeyBuf^ <> StopKeyBuf^) then
+ ContinueBuildStopKey := False;
+ end;
+
+ function BuildDecimalRanges(
+ FileHandle: PPhysDbFileHandle;
+ RangeInfoList: PPhysDbRangeInfoArray;
+ RangeIndex: TcrInt16u;
+ RangeFieldN: TcrInt16u;
+ FieldInfo: PPhysDbFieldInfo;
+ ErrMsg: PAnsiChar) : TPhysDbError;
+(*
+ var
+ SavedLen,
+ SavedOffset: TcrInt16u;
+ FieldLen: TcrInt16u;
+ KeyBuf: PAnsiChar;
+ DoubleValue: Double;
+ StartKeyBuf,
+ StopKeyBuf: PcrNumber;
+*)
+ begin
+ Result := errPhysDbNoError;
+(* SavedLen := StartKeyLen;
+ SavedOffset := StopKeyOffset;
+
+ Result := InitLimitRangeInfo(FileHandle, RangeInfoList, RangeIndex,
+ RangeFieldN, FieldInfo, ContinueBuildStartKey,
+ StartKeyLen, ContinueBuildStopKey, StopKeyOffset,
+ ErrMsg);
+ if Result <> errPhysDbNoError then Exit;
+
+ if ContinueBuildStartKey then begin
+ FieldLen := StartKeyLen - SavedLen;
+ KeyBuf := @FileHandle^.ReadInfo^.KeyBuf[SavedLen];
+ with RangeInfoList^[RangeIndex].FieldRanges^[0] do
+ DoubleValue := NumberToDouble(TcrNumber(MinFieldValue^));
+ if Doublevalue < 0 then begin
+ ContinueBuildStartKey := False;
+ StartKeyLen := SavedLen;
+ end
+ else
+ {
+ DoubleToDecimal(FileHandle, DoubleValue, KeyBuf, FieldLen,
+ FieldInfo^.NDecPlacesInNativeField)};
+ end;
+
+ if ContinueBuildStopKey then begin
+ FieldLen := StopKeyOffset - SavedOffset;
+ KeyBuf := @FileHandle^.ReadInfo^.StopKeyBuf[SavedOffset];
+ with RangeInfoList^[RangeIndex].FieldRanges^[0] do
+ DoubleValue := NumberToDouble(TcrNumber(MaxFieldValue^));
+ Move(DoubleValue, KeyBuf^, FieldLen);
+ end;
+
+ { If current field of min and max range in index are not equal, do not
+ try to build stop key. }
+
+ with RangeInfoList^[RangeIndex].FieldRanges^[0] do begin
+ StartKeyBuf := PcrNumber(@MinFieldValue);
+ StopKeyBuf := PcrNumber(@MaxFieldValue);
+ end;
+
+ if not Assigned(StartKeyBuf) or
+ not Assigned(StopKeyBuf) or
+ (StartKeyBuf^ <> StopKeyBuf^) then
+ ContinueBuildStopKey := False;*)
+ end;
+
+ function BuildTimeRanges(
+ FileHandle: PPhysDbFileHandle;
+ RangeInfoList: PPhysDbRangeInfoArray;
+ RangeIndex: TcrInt16u;
+ RangeFieldN: TcrInt16u;
+ FieldInfo: PPhysDbFieldInfo;
+ ErrMsg: PAnsiChar) : TPhysDbError;
+(*
+ var
+ SavedLen,
+ SavedOffset: TcrInt16u;
+ KeyBuf: PAnsiChar;
+ TimeValue: TcrInt32s;
+ TimeValueN: TcrNumber;
+ StartKeyBuf,
+ StopKeyBuf: PcrNumber;
+*)
+ begin
+ Result := errPhysDbNoError;
+(* SavedLen := StartKeyLen;
+ SavedOffset := StopKeyOffset;
+
+ Result := InitLimitRangeInfo(FileHandle, RangeInfoList, RangeIndex,
+ RangeFieldN, FieldInfo, ContinueBuildStartKey,
+ StartKeyLen, ContinueBuildStopKey, StopKeyOffset,
+ ErrMsg);
+ if Result <> errPhysDbNoError then Exit;
+
+ if ContinueBuildStartKey then begin
+ KeyBuf := @FileHandle^.ReadInfo^.KeyBuf[SavedLen];
+ with RangeInfoList^[RangeIndex].FieldRanges^[0] do
+ TimeValue := TBrahmaNumber(MinFieldValue^);
+ if TimeValue < 0 then begin
+ ContinueBuildStartKey := False;
+ StartKeyLen := SavedLen;
+ end
+ else
+ Convert2BTTime(TimeValue, KeyBuf);
+ end;
+
+ if ContinueBuildStopKey then begin
+ KeyBuf := @FileHandle^.ReadInfo^.StopKeyBuf[SavedOffset];
+ with RangeInfoList^[RangeIndex].FieldRanges^[0] do
+ TimeValueN := TBrahmaNumber(MaxFieldValue^);
+ if TimeValue < 0 then begin
+ ContinueBuildStopKey := False;
+ StartKeyLen := SavedLen;
+ end
+ else
+ Move(TimeValueN, KeyBuf, SizeOf(TBrahmaNumber));
+ end;
+
+ { If current field of min and max range in index are not equal, do not
+ try to extend the stop key. }
+
+ with RangeInfoList^[RangeIndex].FieldRanges^[0] do begin
+ StartKeyBuf := PBrahmaNumber(@MinFieldValue);
+ StopKeyBuf := PBrahmaNumber(@MaxFieldValue);
+ end;
+
+ if not Assigned(StartKeyBuf) or
+ not Assigned(StopKeyBuf) or
+ (StartKeyBuf^ <> StopKeyBuf^) then
+ ContinueBuildStopKey := False;*)
+ end;
+
+ function BuildLogicalRanges(
+ FileHandle: PPhysDbFileHandle;
+ RangeInfoList: PPhysDbRangeInfoArray;
+ RangeIndex: TcrInt16u;
+ RangeFieldN: TcrInt16u;
+ FieldInfo: PPhysDbFieldInfo;
+ ErrMsg: PAnsiChar) : TPhysDbError;
+ var
+ SavedLen,
+ SavedOffset,
+ FieldLen: TcrInt16u;
+ KeyBuf: PAnsiChar;
+ LogicalValue: TcrBoolean;
+ StartKeyValue,
+ StopKeyValue: TcrBoolean;
+ begin
+ SavedLen := StartKeyLen;
+ SavedOffset := StopKeyOffset;
+
+ Result := InitLimitRangeInfo(FileHandle, RangeInfoList, RangeIndex,
+ RangeFieldN, FieldInfo, ContinueBuildStartKey,
+ StartKeyLen, ContinueBuildStopKey, StopKeyOffset,
+ ErrMsg);
+ if Result <> errPhysDbNoError then Exit;
+
+ if ContinueBuildStartKey then begin
+ FieldLen := StartKeylen - SavedLen;
+ KeyBuf := @FileHandle^.ReadInfo^.KeyBuf[SavedLen];
+ with RangeInfoList^[RangeIndex].FieldRanges^[0] do
+ LogicalValue := TcrBoolean(MinFieldValue^);
+ if FieldLen = 1 then
+ TcrInt8u(KeyBuf^) := Ord(LogicalValue)
+ else
+ PcrInt16u(KeyBuf)^ := Ord(LogicalValue);
+ end;
+
+ if ContinueBuildStopKey then begin
+ FieldLen := StopKeyOffset - SavedOffset;
+ KeyBuf := @FileHandle^.ReadInfo^.StopKeyBuf[SavedOffset];
+ with RangeInfoList^[RangeIndex].FieldRanges^[0] do
+ LogicalValue := TcrBoolean(MaxFieldValue^);
+ if FieldLen = 1 then
+ TcrInt8u(KeyBuf^) := Ord(LogicalValue)
+ else
+ PcrInt16u(KeyBuf)^ := Ord(LogicalValue);
+ end;
+
+ { If current field of min and max range in index are not equal, do not
+ try to extend the stop key. }
+
+ with RangeInfoList^[RangeIndex].FieldRanges^[0] do begin
+ StartKeyValue := TcrBoolean(@MinFieldValue);
+ StopKeyValue := TcrBoolean(@MaxFieldValue);
+ end;
+
+ if StartKeyValue = StopKeyValue then
+ ContinueBuildStopKey := False;
+ end;
+
+ begin
+ CanDoRangeLimit := false;
+ Result := errPhysDbNoError;
+ if NRanges = 0 then Exit;
+
+ with FileHandle^.ReadInfo^ do
+ FillChar(KeyBuf, SizeOf(KeyBuf), #0);
+
+ StopKeyOffset := 0;
+ StartKeyLen := 0;
+ NFieldsInStartKey := 0;
+ ContinueBuildStopKey := True;
+ ContinueBuildStartKey := True;
+ MinInclusive := True;
+
+ FileHandle^.ReadInfo^.AscendingIndex :=
+ IndexesPtr^.IndexInfo^[IndexesPtr^.IndexInUse].Ascending;
+
+ { Swap the begin and end range key, when descending index }
+ if not FileHandle^.ReadInfo^.AscendingIndex then begin
+ AddToLog(' swapping begin and end range key');
+ for RangeN := 0 to pred(NRanges) do begin
+ with RangeInfoList^[RangeN] do begin
+ for FieldN := 0 to pred(RangeInfoList^[RangeN].NFieldRanges) do begin
+ with RangeInfoList^[RangeN].FieldRanges^[FieldN] do begin
+ TempPtr := MinFieldValue;
+ MinFieldValue := MaxFieldValue;
+ MaxFieldValue := TempPtr;
+
+ TempBool := MinInclusive;
+ MinInclusive := MaxInclusive;
+ MaxInclusive := TempBool;
+ end;
+ end;
+ end;
+ end;
+ end;
+
+ { Start to do the range search }
+ IndexInfo := IndexesPtr^.IndexInfo^[IndexesPtr^.IndexInUse];
+ for RangeN := 0 to pred(NRanges) do begin
+ RangeFieldN := IndexInfo.FieldNumInFile^[RangeN];
+
+ if not RangeInfoList^[RangeN].SelectIfWithinRange or
+ (RangeInfoList^[RangeN].NFieldRanges <> 1) then
+ Break;
+
+ case InfoPtr^.FieldInfo^[RangeFieldN].NativeFieldType of
+ fldZSTRING:
+ begin
+ CanDoRangeLimit := true;
+ Result := BuildStringRanges(FileHandle, RangeInfoList, RangeN,
+ RangeFieldN, @InfoPtr^.FieldInfo^[RangeFieldN], ErrMsg);
+ end;
+
+ fldDATE:
+ begin
+ CanDoRangeLimit := true;
+ Result := BuildDateRanges(FileHandle, RangeInfoList, RangeN,
+ RangeFieldN, @InfoPtr^.FieldInfo^[RangeFieldN], ErrMsg);
+ end;
+
+ fldINT16, fldINT32:
+ begin
+ CanDoRangeLimit := true;
+ Result := BuildIntegerRanges(FileHandle, RangeInfoList, RangeN,
+ RangeFieldN, @InfoPtr^.FieldInfo^[RangeFieldN], ErrMsg);
+ end;
+
+ fldFLOAT, fldstMONEY:
+ begin
+ CanDoRangeLimit := true;
+ Result := BuildDoubleRanges(FileHandle, RangeInfoList, RangeN,
+ RangeFieldN, @InfoPtr^.FieldInfo^[RangeFieldN], ErrMsg);
+ end;
+
+ fldBCD:
+ begin
+ CanDoRangeLimit := true;
+ ShowMessage('BCD datatypes not supported for ranges');
+ {Result := BuildDecimalRanges(FileHandle, RangeInfoList, RangeN,
+ RangeFieldN, @InfoPtr^.FieldInfo^[RangeFieldN], ErrMsg);}
+ end;
+
+ fldTIME:
+ begin
+ CanDoRangeLimit := true;
+ ShowMessage('Time datatypes are not supported for ranges');
+ {Result := BuildTimeRanges(FileHandle, RangeInfoList, RangeN,
+ RangeFieldN, @InfoPtr^.FieldInfo^[RangeFieldN], ErrMsg);}
+ end;
+
+ fldBOOL:
+ begin
+ CanDoRangeLimit := true;
+ Result := BuildLogicalRanges(FileHandle, RangeInfoList, RangeN,
+ RangeFieldN, @InfoPtr^.FieldInfo^[RangeFieldN], ErrMsg);
+ end;
+
+ else CanDoRangeLimit := false;
+ end;
+
+ if ContinueBuildStartKey and
+ not RangeInfoList^[RangeN].FieldRanges^[0].MinInclusive then
+ MinInclusive := False;
+
+ if (Result <> errPhysDbNoError) or not CanDoRangeLimit then
+ Break;
+
+ if ContinueBuildStartKey then
+ Inc(NFieldsInStartKey)
+ else
+ TFFProxyCursor(FileHandle^.CursorID).Dictionary.SetRecordField(RangeFieldN,
+ FileHandle^.ReadInfo^.PhysRecordBuf,
+ nil);
+ end;
+
+ { Clear the remaining fields in index }
+ for FieldN := NFieldsInStartKey to pred(IndexInfo.NFields) do begin
+ IndexFieldN := IndexInfo.FieldNumInFile^[FieldN];
+ TFFProxyCursor(FileHandle^.CursorID).Dictionary.SetRecordField(IndexFieldN,
+ FileHandle^.ReadInfo^.PhysRecordBuf,
+ nil);
+ end;
+
+ if (Result = errPhysDbNoError) and CanDoRangeLimit then begin
+ if StartKeyLen > 0 then begin
+ with TFFProxyCursor(FileHandle^.CursorID) do begin
+ Dictionary.ExtractKey(IndexID,
+ @FileHandle^.ReadInfo^.PhysRecordBuf,
+ @FileHandle^.ReadInfo^.KeyBuf);
+ end;
+
+ if MinInclusive then
+ SearchCond := skaEqual
+ else
+ SearchCond := skaGreater;
+
+ FFError := ServerEngine.CursorSetToKey(FileHandle^.CursorID,
+ SearchCond,
+ True,
+ NFieldsInStartKey,
+ 0,
+ @FileHandle^.ReadInfo^.KeyBuf);
+ AddToLogFmt(' CursorSetToKey: [%d]', [FFError]);
+ if FFError = DBIERR_NONE then begin
+ FFError := ServerEngine.CursorSetRange(FileHandle^.CursorID,
+ True,
+ NFieldsInStartKey,
+ 0,
+ @FileHandle^.ReadInfo^.KeyBuf,
+ MinInclusive,
+ 0,
+ 0,
+ nil,
+ True);
+ AddToLogFmt(' CursorSetRange: [%d]', [FFError]);
+ end;
+ end else begin
+ FFError := ServerEngine.CursorSetToBegin(FileHandle^.CursorID);
+ AddToLogFmt(' CursorSetRange: [%d]', [FFError]);
+ end;
+
+ if FFError <> DBIERR_NONE then SysUtils.Abort;
+
+ FileHandle^.RangeLimit := True;
+ end;
+ end;
+
+ function InitReadInfoForRange(
+ FileHandle : PPhysDbFileHandle;
+ InfoPtr : PPhysDbFileInfo;
+ IndexesPtr : PPhysDbIndexesInfo;
+ RangeInfoList : PPhysDbRangeInfoArray;
+ NRanges : Word;
+ var CanDoRangeLimit : TcrBoolean;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+ begin
+ Result := errPhysDbNoError;
+ with fileHandle^ do begin
+ RangeLimit := False;
+ with ReadInfo^ do begin
+ RangeFieldInfo := nil;
+ NStopKeyRanges := 0;
+ StopKeyLen := 0;
+
+ if NRanges > 0 then begin
+ IndexCaseSensitive := IndexesPtr^.IndexInfo^[IndexesPtr^.IndexInUse].CaseSensitive;
+
+ { Allocate structure for range field info }
+ FFGetZeroMem(RangeFieldInfo, SizeOf(TPhysDbReadFieldInfo) * NRanges);
+ Result := CanDoRangeLimitOnField(FileHandle, InfoPtr, IndexesPtr,
+ RangeInfoList, NRanges,
+ CanDoRangeLimit, ErrMsg);
+ end;
+ end;
+ end;
+ end;
+
+var
+ ReadFieldNo : integer;
+ IndexFieldNo : integer;
+ FieldN : integer;
+begin { InitDataFileForReadingVer17 }
+ AddToLog('InitDataFileForReadingVer17');
+ AddToLogFmt(' PathAndFilename: [%s]', [FileHandle^.PathAndFileName]);
+ AddToLogFmt(' CursorID: [%d]', [FileHandle^.CursorID]);
+ if Assigned(IndexesPtr) then
+ AddToLogFmt(' IndexesPtr^.IndexInUse: [%d]', [IndexesPtr^.IndexInUse]);
+ AddToLogFmt(' NRanges: [%d]', [NRanges]);
+ if Assigned(RangeInfoList) then begin
+ AddBlockToLog(' RangeInfoList^[0]: ', @RangeInfoList^[0], SizeOf(TPhysDbRangeInfo));
+ with RangeInfoList^[0] do begin
+ AddToLogFmt(' RangeInfoList^[0].FieldName: [%s]', [FieldName]);
+ AddToLogFmt(' RangeInfoList^[0].BrahmaType: [%s]', [FieldValueTypes[BrahmaType]]);
+ AddToLogFmt(' RangeInfoList^[0].BrahmaFieldLen: [%d]', [BrahmaFieldLen]);
+ AddToLogFmt(' RangeInfoList^[0].SelectIfWithinRange: [%s]', [BoolToStr(SelectIfWithinRange)]);
+ AddToLogFmt(' RangeInfoList^[0].NFieldRanges: [%d]', [NFieldRanges]);
+ end;
+ end;
+
+ Result := errPhysDbNoError;
+ try
+ try
+ CanDoRangeLimit := false;
+ with FileHandle^ do begin
+ ReadInfo := nil;
+
+ { Allocate structure for read state info }
+ FFGetZeroMem(ReadInfo, SizeOf(TPhysDbReadInfo));
+
+ MainFile := True;
+ ReadInfo^.NumRanges := NRanges;
+
+ with ReadInfo^ do begin
+ ValuesUnique := true;
+ NBytesInReadRecord := InfoPtr^.NBytesInReadRecord;
+ NFieldsInReadRecord := InfoPtr^.NFieldsInReadRecord;
+ NBytesInIndexRecord := InfoPtr^.NBytesInIndexRecord;
+ NFieldsInIndexRecord := InfoPtr^.NFieldsInIndexRecord;
+ NBytesInPhysRecord := InfoPtr^.NBytesInPhysRecord + 1;
+
+ { Allocate the physical record buffer }
+ FFGetZeroMem(PhysRecordBuf, NBytesInPhysRecord);
+
+ { Position at first record of file for subsequent reading }
+ CurrentRecord := 0;
+
+ { Allocate structure for read state information per translated field }
+ FFGetZeroMem(FieldInfo, SizeOf(TPhysDbReadFieldInfo) * InfoPtr^.NFieldsInReadRecord);
+
+ { Allocate structure for read state information per untranslated field }
+ FFGetZeroMem(IndexFieldInfo, SizeOf(TPhysDbReadFieldInfo) * InfoPtr^.NFieldsInIndexRecord);
+
+ NFieldsInIndexDefn := 0;
+ IndexDefnInfo := nil;
+
+ { Pass through complete file info structure to find all (translated)
+ read record fields and (untranslated) index record fields. }
+ ReadFieldNo := 0;
+ IndexFieldNo := 0;
+ for FieldN := 0 to pred(InfoPtr^.NFields) do begin
+ with InfoPtr^.FieldInfo^[FieldN] do begin
+ if UsedInReadRecord then begin
+
+ { At a field to be translated in read record }
+ FieldInfo^[ReadFieldNo].FieldNo := FieldN;
+ FieldInfo^[ReadFieldNo].ReadFieldNo := ReadFieldNo;
+ FieldInfo^[ReadFieldNo].OffsetInRecord := OffsetInReadRecord;
+ FieldInfo^[ReadFieldNo].FieldType := FieldType;
+ FieldInfo^[ReadFieldNo].FieldLength := NBytesInField;
+ FieldInfo^[ReadFieldNo].NativeFieldOffset := NativeFieldOffset;
+ FieldInfo^[ReadFieldNo].NativeFieldType := NativeFieldType;
+ FieldInfo^[ReadFieldNo].NBytesInNativeField := NBytesInNativeField;
+ FieldInfo^[ReadFieldNo].NDecPlacesInNativeField := NDecPlacesInNativeField;
+ Inc(ReadFieldNo);
+ end;
+
+ if UsedInIndexRecord then begin
+
+ { At a field to be untranslated in index record }
+ IndexFieldInfo^[IndexFieldNo].FieldNo := FieldN;
+ IndexFieldInfo^[IndexFieldNo].ReadFieldNo := IndexFieldNo;
+ IndexFieldInfo^[IndexFieldNo].OffsetInRecord := OffsetInIndexRecord;
+ IndexFieldInfo^[IndexFieldNo].FieldType := FieldType;
+ IndexFieldInfo^[IndexFieldNo].FieldLength := NBytesInNativeField;
+ IndexFieldInfo^[IndexFieldNo].NativeFieldOffset := NativeFieldOffset;
+ IndexFieldInfo^[IndexFieldNo].NativeFieldType := NativeFieldType;
+ IndexFieldInfo^[IndexFieldNo].NBytesInNativeField := NBytesInNativeField;
+ IndexFieldInfo^[IndexFieldNo].NDecPlacesInNativeField := NDecPlacesInNativeField;
+ Inc(IndexFieldNo);
+ end;
+ end;
+ end;
+ end;
+ end;
+
+ Result := InitReadInfoForRange(FileHandle, InfoPtr, IndexesPtr,
+ RangeInfoList, NRanges, CanDoRangeLimit, ErrMsg);
+ if Result <> errPhysDbNoError then
+ raise Exception.Create(StrPas(ErrMsg));
+ AddToLogFmt(' CanDoRangeLimit: [%s]', [BoolToStr(CanDoRangeLimit)]);
+ except
+ on EOutOfMemory do begin
+ Result := errPhysDbNotEnoughMemory;
+ TermDataFileForReading(FileHandle, ErrMsg);
+ StrPCopy(ErrMsg, '');
+ end;
+
+ on E: Exception do begin
+ if Result = errPhysDbNoError then
+ Result := errPhysDbErrMsgReturned;
+ TermDataFileForReading(FileHandle, ErrMsg);
+ StrPCopy(ErrMsg, E.Message);
+ if FFError <> DBIERR_NONE then
+ Result := IDAPIError(FFError, ErrMsg);
+ end;
+ end;
+ finally
+ StrPCopy(DebugBuff, PhysDbErrors[Result]); { this seems necessary for 32-bit }
+ end;
+ if (Result = errPhysDbErrMsgReturned) then
+ AddToLogFmt(' ErrMsg: [%s]', [ErrMsg]);
+ AddResultToLog(Result);
+end;
+
+function InitDataFileAndIndexForReadV115(
+ FileHandle: PPhysDbFileHandle;
+ InfoPtr: PPhysDbFileInfo;
+ IndexesPtr: PPhysDbIndexesInfo;
+ LookupOptPtr: PPhysDbLookupOptInfo;
+ ErrMsg: PAnsiChar) : TPhysDbError;
+var
+ CanDoRangeLimit: TcrBoolean;
+
+{ This function serves the same purpose as InitDataFileForReading, but
+ is called when initializing reading from a file with an index,
+ whereas InitDataFileForReading is called when reading from a file
+ without. The index info structure (from FetchDataFileIndexInfo) is
+ passed to this function to identify the chosen index. }
+
+ function InitReadInfoForIndex: TPhysDbError;
+ var
+ IndexInfo: TPhysDbIndexInfo;
+ IndexOffset,
+ FieldIndex,
+ FieldN: integer;
+ begin
+ Result := errPhysDbNoError;
+
+ if IndexesPtr^.NIndexes = 0 then begin
+ Result := errPhysDbFileIntegrityError;
+ Exit;
+ end;
+
+ { Allocate structure to save information on index fields }
+ IndexInfo := IndexesPtr^.IndexInfo^[IndexesPtr^.IndexInUse];
+
+ with FileHandle^.ReadInfo^ do begin
+ ValuesUnique := IndexInfo.ValuesUnique;
+ IndexCaseSensitive := IndexInfo.CaseSensitive;
+ NFieldsInIndexDefn := IndexInfo.NFields;
+ FFGetZeroMem(IndexDefnInfo, SizeOf(TPhysDbReadFieldInfo) * IndexInfo.NFields);
+
+ { Default number of lookup fields to same as index }
+ NFieldsInLookupValue := NFieldsInIndexDefn;
+ LookupValueLen := LookupOptPtr^.LookupValueLen;
+ LastLookupFieldLen := 0;
+ LastLookupFieldIsSubstr := false;
+
+ IndexOffset := 0;
+ for FieldN := 0 to pred(IndexInfo.NFields) do begin
+ FieldIndex := IndexInfo.FieldNumInFile^[FieldN];
+ IndexDefnInfo^[FieldN].FieldNo := FieldIndex;
+ IndexDefnInfo^[FieldN].OffsetInRecord := IndexOffset;
+ IndexDefnInfo^[FieldN].FieldLength := InfoPtr^.FieldInfo^[FieldIndex].NBytesInNativeField;
+ IndexDefnInfo^[FieldN].FieldType := InfoPtr^.FieldInfo^[FieldIndex].FieldType;
+
+ { Detect if we have link on partial number of fields }
+ if IndexDefnInfo^[FieldN].OffsetInRecord >= LookupOptPtr^.LookupValueLen then
+ if NFieldsInLookupValue = NFieldsInIndexDefn then
+ if FieldN > 0 then
+ NFieldsInLookupValue := FieldN;
+ IndexOffset := IndexOffset + InfoPtr^.FieldInfo^[FieldIndex].NBytesInNativeField;
+ end;
+
+ { Detect if we have link to a partial string field at the end
+ of lookup value. }
+ if (IndexDefnInfo^[IndexInfo.NFields - 1].FieldType = ftStringField) and
+ LookupOptPtr^.PartialMatch then
+ LastLookupFieldIsSubstr := True;
+ end;
+ end;
+
+begin
+ AddToLog('InitDataFileAndIndexForReadV115');
+ AddToLogFmt(' PathAndFilename: [%s]', [FileHandle^.PathAndFileName]);
+ AddToLogFmt(' CursorID: [%d]', [FileHandle^.CursorID]);
+ AddBlockToLog(' LookupOptPtr^:', LookupOptPtr, SizeOf(LookupOptPtr^));
+
+ Result := errPhysDbNoError;
+ try
+
+ { Perform same initialization as for no index file }
+ Result := InitDataFileForReadingVer17(FileHandle, InfoPtr, IndexesPtr,
+ nil, 0, CanDoRangeLimit, ErrMsg);
+ if Result = errPhysDbNoError then begin
+
+ { Perform index specific initialization }
+ Result := InitReadInfoForIndex;
+ if Result <> errPhysDbNoError then
+ TermDataFileForReading(FileHandle, ErrMsg);
+ end;
+
+ FileHandle^.MainFile := False;
+ except
+ on EOutOfMemory do begin
+ Result := errPhysDbNotEnoughMemory;
+ StrPCopy(ErrMsg, '');
+ end;
+
+ on E: Exception do begin
+ if Result = errPhysDbNoError then
+ Result := errPhysDbErrMsgReturned;
+ StrPCopy(ErrMsg, E.Message);
+ end;
+ end;
+ if (Result = errPhysDbErrMsgReturned) then
+ AddToLogFmt(' ErrMsg: [%s]', [ErrMsg]);
+ AddResultToLog(Result);
+end;
+
+function TermDataFileForReading(
+ FileHandle: PPhysDbFileHandle;
+ ErrMsg: PAnsiChar) : TPhysDbError;
+begin
+ AddToLog('TermDataFileForReading');
+
+ Result := errPhysDbNoError;
+ try
+ if Assigned(FileHandle) then begin
+ AddToLogFmt(' FileName: [%s]', [FileHandle^.PathAndFileName]);
+ AddToLogFmt(' CursorID: [%d]', [FileHandle^.CursorID]);
+ with FileHandle^ do begin
+ if Assigned(ReadInfo) then begin
+ with ReadInfo^ do begin
+ FFFreeMem(PhysRecordBuf, NBytesInPhysRecord);
+ PhysRecordBuf := nil;
+
+ FFFreeMem(FieldInfo, SizeOf(TPhysDbReadFieldInfo) * NFieldsInReadRecord);
+ FieldInfo := nil;
+
+ FFFreeMem(IndexFieldInfo, SizeOf(TPhysDbReadFieldInfo) * NFieldsInIndexRecord);
+ IndexFieldInfo := nil;
+
+ FFFreeMem(RangeFieldInfo, SizeOf(TPhysDbReadFieldInfo) * NumRanges);
+ RangeFieldInfo := nil;
+ end;
+
+ FFFreeMem(ReadInfo, sizeof(TPhysDbReadInfo));
+ ReadInfo := nil;
+ end;
+ end;
+ end;
+ except
+ on E: Exception do begin
+ if Result = errPhysDbNoError then
+ Result := errPhysDbErrMsgReturned;
+ StrPCopy(ErrMsg, E.Message);
+ end;
+ end;
+ if (Result = errPhysDbErrMsgReturned) then
+ AddToLogFmt(' ErrMsg: [%s]', [ErrMsg]);
+ AddResultToLog(Result);
+end;
+
+function NRecurringRecordsToRead(
+ FileHandle: PPhysDbFileHandle;
+ var NRecordsToRead: LongInt;
+ ErrMsg: PAnsiChar) : TPhysDbError;
+var
+ NRecords : TcrInt32u;
+ FFError : TffResult;
+begin
+ AddToLog('NRecurringRecordsToRead');
+ AddToLogFmt(' FName: [%s]', [FileHandle^.PathAndFileName]);
+ AddToLogFmt(' CursorID: [%d]', [FileHandle^.CursorID]);
+
+ Result := errPhysDbNoError;
+ try
+ FFError := ServerEngine.TableGetRecCount(FileHandle^.CursorID, NRecords);
+ if FFError <> DBIERR_NONE then begin
+ Result := IDAPIError(FFError, ErrMsg);
+ Exit;
+ end;
+
+ NRecordsToRead := NRecords;
+ except
+ on E: Exception do begin
+ if Result = errPhysDbNoError then
+ Result := errPhysDbErrMsgReturned;
+ StrPCopy(ErrMsg, E.Message);
+ end;
+ end;
+ AddToLogFmt(' Records count: [%d]', [NRecordsToRead]);
+ if (Result = errPhysDbErrMsgReturned) then
+ AddToLogFmt(' ErrMsg: [%s]', [ErrMsg]);
+ AddResultToLog(Result);
+end;
+
+{ Translate and copy fields requested by Database Manager to read
+ record buffer. }
+
+function FetchReadRecFields(
+ ReadInfo : PPhysDbReadInfo;
+ HCursor : TffCursorID;
+ NotXlateDOSString : Boolean;
+ ReadRecordBuf : PByteArray;
+ ReadNullFlags : PcrBooleanArray;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+var
+ FFError : TffResult;
+ I : integer;
+ ReadRecOffset : integer;
+ BoolValue : Bool;
+ DoubleValue : Double;
+ SingleValue : Single; {!!.02}
+ CompValue : Comp; {!!.02}
+ ExtendedValue : Extended; {!!.02}
+ CurrencyValue : Currency; {!!.02}
+ Int16Value : TcrInt16s;
+ Int32Value : TcrInt32s;
+ UInt16Value : TcrInt16u;
+ UInt32Value : TcrInt32u;
+ DateValue : TDbiDate;
+ Year : TcrInt16u;
+ Month, Day : TcrInt16u;
+ SYear : Integer; {!!.02}
+ SMonth, SDay : Integer; {!!.02}
+ TimeValue : TDbiTime;
+ Millisec : TcrInt16u;
+ SHours, {!!.02}
+ SMinutes, {!!.02}
+ SSeconds : Byte; {!!.02}
+ HourL,
+ MinuteL : TcrInt32u;
+ DateTime : TDateTime; {!!.02}
+ CrTime : TcrTime;
+ CrTimeArray : array[1..4] of Byte absolute CrTime;
+ IsNull : boolean;
+ FType : TffFieldType; {!!.02}
+ aByte : Byte; {!!.02}
+begin
+// AddToLog('FetchReadRecFields');
+// AddToLogFmt(' CursorID: [%d]', [HCursor]);
+
+ if hCursor = 0 then begin
+ Result := IDAPIError(DBIERR_NOTINITIALIZED, ErrMsg);
+ Exit;
+ end;
+
+ Result := errPhysDbNoError;
+
+ { Translate and copy fields requested by Database Manager to read
+ record buffer. }
+ for I := 0 to pred(ReadInfo^.NFieldsInReadRecord) do begin
+ with ReadInfo^.FieldInfo^[I] do begin
+ ReadRecOffset := OffsetInRecord;
+ case NativeFieldType of
+ fldZSTRING:
+ begin
+ FType := TFFProxyCursor(HCursor).Dictionary.FieldType[FieldNo];
+ if (FType = fftNullString) or
+ (FType = fftNullAnsiStr) or {!!.02}
+ (FType = fftChar) then begin {!!.02}
+ TFFProxyCursor(HCursor).Dictionary.GetRecordField(FieldNo,
+ ReadInfo^.PhysRecordBuf,
+ IsNull,
+ @ReadRecordBuf^[ReadRecOffset]);
+// AddToLogFmt(' read Null String field: [%s]',
+// [PChar(@ReadRecordBuf^[ReadRecOffset])]);
+ end
+ else if (FType = fftWideChar) or {!!.02}
+ (FType = fftWideString) then {!!.02}
+ ShowMessage('Widestring types not supported') {!!.02}
+ else begin
+ TFFProxyCursor(HCursor).Dictionary.GetRecordField(FieldNo,
+ ReadInfo^.PhysRecordBuf,
+ IsNull,
+ @ReadRecordBuf^[Pred(ReadRecOffset)]);
+// AddToLogFmt(' read String field: [%s]',
+// [PChar(@ReadRecordBuf^[Pred(ReadRecOffset)])]);
+ end;
+ ReadNullFlags^[I] := IsNull;
+
+ if not NotXlateDOSString then
+ OemToAnsi(@ReadRecordBuf^[ReadRecOffset],
+ @ReadRecordBuf^[ReadRecOffset]);
+ TrimStrR(@ReadRecordBuf^[ReadRecOffset]);
+ end;
+
+ fldBOOL:
+ begin
+ TFFProxyCursor(HCursor).Dictionary.GetRecordField(FieldNo,
+ ReadInfo^.PhysRecordBuf,
+ IsNull,
+ @BoolValue);
+
+ if IsNull then
+ ReadNullFlags^[I] := true
+ else begin
+ ReadNullFlags^[I] := false;
+ PcrBoolean(@ReadRecordBuf^[ReadRecOffset])^ := BoolValue;
+ end;
+// AddToLogFmt(' read Bool field: [%s]',
+// [BoolToStr(BoolValue)]);
+ end;
+
+ fldFLOAT,
+ fldstMONEY:
+ begin
+ FType := TFFProxyCursor(HCursor).Dictionary.FieldType[FieldNo];{begin !!.02}
+ case FType of
+ fftSingle :
+ begin
+ TFFProxyCursor(HCursor).Dictionary.GetRecordField(FieldNo,
+ ReadInfo^.PhysRecordBuf,
+ IsNull,
+ @SingleValue);
+ DoubleValue := SingleValue;
+ end;
+ fftComp :
+ begin
+ TFFProxyCursor(HCursor).Dictionary.GetRecordField(FieldNo,
+ ReadInfo^.PhysRecordBuf,
+ IsNull,
+ @CompValue);
+ DoubleValue := CompValue;
+ end;
+ fftExtended :
+ begin
+ TFFProxyCursor(HCursor).Dictionary.GetRecordField(FieldNo,
+ ReadInfo^.PhysRecordBuf,
+ IsNull,
+ @ExtendedValue);
+ DoubleValue := ExtendedValue;
+ end;
+ fftCurrency :
+ begin
+ TFFProxyCursor(HCursor).Dictionary.GetRecordField(FieldNo,
+ ReadInfo^.PhysRecordBuf,
+ IsNull,
+ @CurrencyValue);
+ DoubleValue := CurrencyValue;
+ end;
+ else
+ TFFProxyCursor(HCursor).Dictionary.GetRecordField(FieldNo,
+ ReadInfo^.PhysRecordBuf,
+ IsNull,
+ @DoubleValue);
+ end; {end !!.02}
+
+
+ if IsNull then
+ ReadNullFlags^[I] := true
+ else begin
+ ReadNullFlags^[I] := false;
+ PcrNumber(@ReadRecordBuf^[ReadRecOffset])^ :=
+ DoubleToNumber(DoubleValue);
+ end;
+ end;
+
+ fldINT16:
+ begin
+ TFFProxyCursor(HCursor).Dictionary.GetRecordField(FieldNo,
+ ReadInfo^.PhysRecordBuf,
+ IsNull,
+ @Int16Value);
+ if IsNull then
+ ReadNullFlags^[I] := true
+ else begin
+ ReadNullFlags^[I] := false;
+ PcrInt16s(@ReadRecordBuf^[ReadRecOffset])^ := Int16Value;
+ end;
+ end;
+
+ fldINT32:
+ begin
+ TFFProxyCursor(HCursor).Dictionary.GetRecordField(FieldNo,
+ ReadInfo^.PhysRecordBuf,
+ IsNull,
+ @Int32Value);
+
+ if IsNull then
+ ReadNullFlags^[I] := true
+ else begin
+ ReadNullFlags^[I] := false;
+ PcrInt32s(@ReadRecordBuf^[ReadRecOffset])^ := Int32Value;
+ end;
+ end;
+
+ fldUINT16:
+ begin
+ FType := TFFProxyCursor(HCursor).Dictionary.FieldType[FieldNo]; {begin !!.02}
+ if FType <> fftByte then
+ TFFProxyCursor(HCursor).Dictionary.GetRecordField(FieldNo,
+ ReadInfo^.PhysRecordBuf,
+ IsNull,
+ @UInt16Value)
+ else begin
+ TFFProxyCursor(HCursor).Dictionary.GetRecordField(FieldNo,
+ ReadInfo^.PhysRecordBuf,
+ IsNull,
+ @aByte);
+ UInt16Value := aByte;
+ end; {end !!.02}
+ if IsNull then
+ ReadNullFlags^[I] := true
+ else begin
+ ReadNullFlags^[I] := false;
+ PcrInt16u(@ReadRecordBuf^[ReadRecOffset])^ := UInt16Value;
+ end;
+ end;
+
+ fldUINT32:
+ begin
+ TFFProxyCursor(HCursor).Dictionary.GetRecordField(FieldNo,
+ ReadInfo^.PhysRecordBuf,
+ IsNull,
+ @UInt32Value);
+
+ if IsNull then
+ ReadNullFlags^[I] := true
+ else begin
+ ReadNullFlags^[I] := false;
+ PcrInt32s(@ReadRecordBuf^[ReadRecOffset])^ := UInt32Value;
+ end;
+ end;
+
+ fldDATE:
+ begin
+ TFFProxyCursor(HCursor).Dictionary.GetRecordField(FieldNo,
+ ReadInfo^.PhysRecordBuf,
+ IsNull,
+ @DateValue);
+
+ if IsNull then
+ ReadNullFlags^[I] := true
+ else begin
+ ReadNullFlags^[I] := false;
+ FType := TFFProxyCursor(HCursor).Dictionary.FieldType[FieldNo]; {begin !!.02}
+ if FType = fftStDate then begin
+ StDateToDMY(TStDate(DateValue), SDay, SMonth, SYear);
+ Day := SDay;
+ Month := SMonth;
+ Year := SYear;
+ end else
+ FFBDEDateDecode(DateValue, Day, Month, Year); {end !!.02}
+ PcrDate(@ReadRecordBuf^[ReadRecOffset])^ :=
+ YearMonthDayToCrDate(Year, Month, Day);
+ end;
+ end;
+
+ fldTIME:
+ begin
+ TFFProxyCursor(HCursor).Dictionary.GetRecordField(FieldNo,
+ ReadInfo^.PhysRecordBuf,
+ IsNull,
+ @TimeValue);
+
+ if IsNull then
+ ReadNullFlags^[I] := true
+ else begin
+ ReadNullFlags^[I] := false;
+ StTimeToHMS(TimeValue, SHours, SMinutes, SSeconds); {begin !!.02}
+ HourL := SHours;
+ MinuteL := SMinutes;
+ Millisec := SSeconds * 1000;
+
+ { Compute Brahma time (number of hundredths of seconds) }
+ CrTime := (HourL * 360000 + MinuteL * 6000 + (Millisec div 10)) div 100; {end !!.02}
+ PcrTime(@ReadRecordBuf^[ReadRecOffset])^ := CrTime;
+ end;
+ end;
+
+ fldTIMESTAMP:
+ begin
+ TFFProxyCursor(HCursor).Dictionary.GetRecordField(FieldNo, {begin !!.02}
+ ReadInfo^.PhysRecordBuf,
+ IsNull,
+ @DateTime);
+ StrPCopy(PChar(@ReadRecordBuf^[ReadRecOffset]),
+ FormatDateTime('yyyy/mm/dd hh:nn:zz', DateTime - 693594.0)); {end !!.02}
+ end;
+
+ fldBCD:
+ begin
+ ShowMessage('BCD datatypes not supported');
+ end;
+
+ fldBLOB,
+ fldstMEMO,
+ fldstFMTMEMO,
+ fldstBINARY,
+ fldstOLEOBJ,
+ fldstGRAPHIC,
+ fldstTYPEDBINARY:
+ begin
+
+(*
+ { Check the unstable bookmark }
+ FFError := DbiGetCursorProps(HCursor, CursorProps);
+ if not CursorProps.bBookMarkStable then begin
+ Result := IDAPIError(90, ErrMsg); { 90? }
+ Exit;
+ end;
+
+ { Check any primary index, sometimes bBookMarkStable doesn't work }
+ HasPrimaryIndex := False;
+ for IndexN := 0 to CursorProps.iIndexes do begin
+ DbiGetIndexDesc(HCursor, IndexN + 1, IndexDesc);
+ if IndexDesc.bPrimary = True then begin
+ HasPrimaryIndex := True;
+ Break;
+ end;
+ end;
+
+(*
+ if not HasPrimaryIndex then begin
+ Result := IDAPIError(90, ErrMsg);
+ Exit;
+ end;
+*)
+ { Save the field info and RecNo for memo read. }
+ PcrInt16u(@ReadRecordBuf^[ReadRecOffset])^:= FieldNo;
+
+ FFError := ServerEngine.CursorGetBookmark(HCursor,
+ @ReadRecordBuf^[ReadRecOffset + SizeOf(TcrInt16u)]);
+ if FFError <> DBIERR_NONE then begin
+ Result := IDAPIError(FFError, ErrMsg);
+ Exit;
+ end;
+ end;
+ else
+ Break;
+ end;
+ end;
+ end;
+end;
+
+{ Copy fields (without translating) requested by Database Manager to
+ index record buffer. }
+
+function FetchIndexRecFields(
+ ReadInfo : PPhysDbReadInfo;
+ HCursor : TffCursorID;
+ IndexRecordBuf : PByteArray;
+ IndexNullFlags : PcrBooleanArray;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+var
+ I : integer;
+ IsNull : Boolean;
+begin
+// AddToLog('FetchIndexRecFields');
+// AddToLogFmt(' CursorID: [%d]', [HCursor]);
+// AddToLogFmt(' Field count: [%d]', [ReadInfo^.NFieldsInIndexRecord]);
+ Result := errPhysDbNoError;
+ for I := 0 to pred(ReadInfo^.NFieldsInIndexRecord) do begin
+ IndexNullFlags^[I] := false;
+// AddToLogFmt(' Field: [%d]', [ReadInfo^.IndexFieldInfo^[I].FieldNo]);
+ with ReadInfo^.IndexFieldInfo^[I] do begin
+ TFFProxyCursor(HCursor).Dictionary.GetRecordField(FieldNo,
+ ReadInfo^.PhysRecordBuf,
+ IsNull,
+ @IndexRecordBuf^[OffsetInRecord]);
+ IndexNullFlags^[I] := IsNull;
+ end;
+ end;
+end;
+
+function ReadFlatRecordVer15(
+ FileHandle: PPhysDbFileHandle;
+ ReadRecordBuf: PByteArray;
+ ReadNullFlags: PcrBooleanArray;
+ IndexRecordBuf: PByteArray;
+ IndexNullFlags: PcrBooleanArray;
+ var RecordRead: TcrBoolean;
+ ErrMsg: PAnsiChar) : TPhysDbError;
+var
+ NRecordsSkipped : TcrInt32u;
+ FFError : TffResult;
+begin
+ AddToLog('ReadFlatRecordVer15');
+ AddToLogFmt(' FName: [%s]', [FileHandle^.PathAndFileName]);
+ AddToLogFmt(' CursorID: [%d]', [FileHandle^.CursorID]);
+
+ Result := errPhysDbNoError;
+ try
+ if FileHandle^.ReadInfo^.CurrentRecord > 0 then begin
+ FileHandle^.ReadInfo^.CurrentRecord := 0;
+
+ { Position at the first record of file for subsequent reading }
+ FFError := ServerEngine.CursorSetToBegin(FileHandle^.CursorID);
+ if FFError <> DBIERR_NONE then begin
+ Result := IDAPIError(FFError, ErrMsg);
+ Exit;
+ end;
+ end;
+
+ Result := ReadNextRecurringRecordVer15(
+ FileHandle,
+ ReadRecordBuf,
+ ReadNullFlags,
+ IndexRecordBuf,
+ IndexNullFlags,
+ RecordRead,
+ NRecordsSkipped,
+ ErrMsg);
+ except
+ on E: Exception do begin
+ if Result = errPhysDbNoError then
+ Result := errPhysDbErrMsgReturned;
+ StrPCopy(ErrMsg, E.Message);
+ end;
+ end;
+ if (Result = errPhysDbErrMsgReturned) then
+ AddToLogFmt(' ErrMsg: [%s]', [ErrMsg]);
+ AddResultToLog(Result);
+end;
+
+function ReadNextRecurringRecordVer15(
+ FileHandle: PPhysDbFileHandle;
+ ReadRecordBuf: PByteArray;
+ ReadNullFlags: PcrBooleanArray;
+ IndexRecordBuf: PByteArray;
+ IndexNullFlags: PcrBooleanArray;
+ var RecordRead: TcrBoolean;
+ var NRecordsSkipped: LongInt;
+ ErrMsg: PAnsiChar) : TPhysDbError;
+
+ function RecordWithinRange(
+ FileHandle: PPhysDbFileHandle;
+ StopHere: Boolean;
+ ErrMsg: PAnsiChar) : TPhysDbError;
+ var
+ RangeFieldInfo : TPhysDbReadFieldInfo;
+ RangeN : integer;
+ StopKeyOffset : integer;
+ KeyBuf : Pointer;
+ StopKeyBuf : PAnsiChar;
+ NullField : Boolean;
+
+ function TestRangeLimitForOneField(
+ KeyBuf : PAnsiChar;
+ IndexCaseSensitive,
+ AscendingIndex : TcrBoolean;
+ var StopHere : Boolean) : TPhysDbError;
+ var
+ SaveKeyCh : AnsiChar;
+ SaveStopKeyCh : AnsiChar;
+ CompResult : Integer;
+ MinLen : Integer;
+ DateKey,
+ StopDate : TDbiDate;
+ ShortKey,
+ StopShort : TcrInt16s;
+ LongKey,
+ StopLong : TcrInt32s;
+ DoubleKey,
+ StopDouble : Double;
+ StopKeyLen : TcrInt16u;
+ Evaluate : Boolean;
+ begin
+ Result := errPhysDbNoError;
+ StopHere := False;
+ Evaluate := True;
+ CompResult := 0;
+
+ case RangeFieldInfo.NativeFieldType of
+ fldZSTRING:
+ begin
+ StopKeyLen := StrLen(StopKeyBuf);
+ if RangeFieldInfo.NBytesInNativeField > StopKeyLen then
+ MinLen := StopKeyLen
+ else
+ MinLen := RangeFieldInfo.NBytesInNativeField;
+
+ SaveKeyCh := KeyBuf[MinLen];
+ KeyBuf[MinLen] := #0;
+
+ SaveStopKeyCh := StopKeyBuf[RangeFieldInfo.NBytesInNativeField];
+ StopKeyBuf[RangeFieldInfo.NBytesInNativeField] := #0;
+
+ if IndexCaseSensitive then
+ CompResult := StrComp(KeyBuf, StopKeyBuf)
+ else
+ CompResult := StrIComp(KeyBuf, StopKeyBuf);
+
+ KeyBuf[MinLen] := SaveKeyCh;
+ StopKeyBuf[RangeFieldInfo.NBytesInNativeField] := SaveStopKeyCh;
+ end;
+
+ fldDATE:
+ begin
+ DateKey := PDbiDate(KeyBuf)^;
+ StopDate := PDbiDate(StopKeyBuf)^;
+
+ CompResult := -1;
+ if DateKey = StopDate then CompResult := 0
+ else if DateKey > StopDate then CompResult := 1;
+ end;
+
+ fldINT16:
+ begin
+ ShortKey := PcrInt16s(KeyBuf)^;
+ StopShort := PcrInt16s(StopKeyBuf)^;
+
+ CompResult := -1;
+ if ShortKey = StopShort then CompResult := 0
+ else if ShortKey > StopShort then CompResult := 1;
+ end;
+
+ fldINT32:
+ begin
+ LongKey := PcrInt32s(KeyBuf)^;
+ StopLong := PcrInt32s(StopKeyBuf)^;
+
+ CompResult := -1;
+ if LongKey = StopLong then CompResult := 0
+ else if LongKey > StopLong then CompResult := 1;
+ end;
+
+ fldFLOAT,
+ fldstMONEY:
+ begin
+ DoubleKey := PDouble(KeyBuf)^;
+ StopDouble := PDouble(StopKeyBuf)^;
+
+ CompResult := -1;
+ if DoubleKey = StopDouble then CompResult := 0
+ else if DoubleKey > StopDouble then CompResult := 1;
+ end;
+
+ fldTIME:
+ begin
+ {}
+ end;
+
+ fldBOOL:
+ begin
+ Evaluate := False;
+ if TcrBoolean(StopKeyBuf^) then
+ if TcrBoolean(KeyBuf^) then
+ StopHere := False
+ else
+ StopHere := True
+ else
+ if TcrBoolean(KeyBuf^) then
+ StopHere := True
+ else
+ StopHere := False;
+ end;
+ else
+ begin
+ Result := errPhysDbProgrammingError;
+ Exit;
+ end;
+ end;
+
+ if Evaluate then begin
+ if RangeFieldInfo.StopInclusive then
+ if AscendingIndex then
+ StopHere := (CompResult > 0)
+ else
+ StopHere := (CompResult < 0)
+ else
+ if AscendingIndex then
+ StopHere := (CompResult >= 0)
+ else
+ StopHere := (CompResult <= 0);
+ end;
+ end;
+
+ begin
+ Result := errPhysDbNoError;
+ if FileHandle^.ReadInfo^.StopKeyLen = 0 then Exit;
+
+ { Loop through all the range fields for the current index }
+ for RangeN := 0 to pred(FileHandle^.ReadInfo^.NStopKeyRanges) do begin
+ RangeFieldInfo := FileHandle^.ReadInfo^.RangeFieldInfo^[RangeN];
+ StopHere := False;
+
+ { KeyBuf points to the values from the current current.
+ stopKeyBuf points to the values that define the end of the range. }
+ StopKeyOffset := RangeFieldInfo.OffsetInStopKeyBuf;
+ KeyBuf := Addr(FileHandle^.ReadInfo^.KeyBuf[StopKeyOffset]);
+ StopKeyBuf := Addr(FileHandle^.ReadInfo^.StopKeyBuf[StopKeyOffset]);
+
+ { Get the range value values out of the current record and into
+ the comparison buffer in their native format. }
+ TFFProxyCursor(FileHandle^.CursorID).Dictionary.GetRecordField(RangeFieldInfo.FieldNo,
+ FileHandle^.ReadInfo^.PhysRecordBuf,
+ NullField,
+ KeyBuf);
+
+ if NullField then
+ Continue;
+
+ { Test this record for out of range on the current range field }
+ Result := TestRangeLimitForOneField(
+ KeyBuf,
+ FileHandle^.ReadInfo^.IndexCaseSensitive,
+ FileHandle^.ReadInfo^.AscendingIndex,
+ StopHere);
+ if Result <> errPhysDbNoError then Exit;
+
+ { Once we've found a field with an out of range value, we needn't look
+ at the remaining range fields }
+ if StopHere then
+ Break;
+ end;
+ end;
+
+var
+ FFError : TffResult;
+ StopHere : Boolean;
+ Buffer : TffShStr;
+begin
+// AddToLog('ReadNextRecurringRecordVer15');
+// AddToLogFmt(' FName: [%s]', [FileHandle^.PathAndFileName]);
+// AddToLogFmt(' CursorID: [%d]', [FileHandle^.CursorID]);
+ Result := errPhysDbNoError;
+ try
+ try
+ RecordRead := false;
+ NRecordsSkipped := 0;
+
+ while not RecordRead do begin
+
+ { Advance to the next recurring record, skipping if it is locked
+ or deleted by another user }
+ FFError := ServerEngine.RecordGetNext(FileHandle^.CursorID,
+ ffltNoLock,
+ nil);
+ if (FFError = DBIERR_RECDELETED) or (FFError = DBIERR_RECNOTFOUND) then begin
+ Inc(FileHandle^.ReadInfo^.CurrentRecord);
+ Inc(NRecordsSkipped);
+ Continue; { Try the next record }
+ end;
+
+ if FFError = DBIERR_EOF then
+ Exit;
+
+ if FFError <> DBIERR_NONE then begin
+ Result := IDAPIError(FFError, ErrMsg);
+ Exit;
+ end;
+
+ FFError := ServerEngine.RecordGet(FileHandle^.CursorID,
+ ffltNoLock,
+ FileHandle^.ReadInfo^.PhysRecordBuf);
+ if FFError = DBIERR_NONE then begin
+ { Test if index fields still in range. If in range, break, else return }
+ if FileHandle^.RangeLimit then begin
+ StopHere := False;
+ if RecordWithinRange(FileHandle, StopHere, ErrMsg) <> errPhysDbNoError then
+ Break;
+ if StopHere then
+ Exit;
+ end;
+
+ RecordRead := true;
+ Inc(FileHandle^.ReadInfo^.CurrentRecord);
+ end
+ else begin
+ if (FileHandle^.ReadInfo^.CurrentRecord > 0) and
+ ((FFError = DBIERR_RECDELETED) or (FFError = DBIERR_RECNOTFOUND)) then
+ Inc(NRecordsSkipped)
+ else begin
+ Result := IDAPIError(FFError, ErrMsg);
+ Exit;
+ end;
+ end;
+ end;
+
+ Result := FetchReadRecFields(FileHandle^.ReadInfo, FileHandle^.CursorID,
+ FileHandle^.NotXlateDOSString, ReadRecordBuf, ReadNullFlags, ErrMsg);
+ if Result <> errPhysDbNoError then Exit;
+
+ RecordRead := true;
+ Result := FetchIndexRecFields(FileHandle^.ReadInfo, FileHandle^.CursorID,
+ IndexRecordBuf, IndexNullFlags, ErrMsg);
+
+ except
+ on E: Exception do begin
+ if Result = errPhysDbNoError then
+ Result := errPhysDbErrMsgReturned;
+ StrPCopy(ErrMsg, E.Message);
+ end;
+ end;
+ finally
+ Buffer := PhysDbErrors[Result]; { this seems necessary for 32-bit }
+ end;
+end;
+
+function LookupMatchingRecurringRecVer15(
+ FileHandle: PPhysDbFileHandle;
+ LookupValueRecordBuf: PAnsiChar;
+ LookupValueNullFlags: PcrBooleanArray;
+ LookupValueType: TcrInt16u;
+ StartTopOfFile: TcrBoolean;
+ ReadRecordBuf: PByteArray;
+ ReadNullFlags: PcrBooleanArray;
+ IndexRecordBuf: PByteArray;
+ IndexNullFlags: PcrBooleanArray;
+ var RecordRead: TcrBoolean;
+ ErrMsg: PAnsiChar) : TPhysDbError;
+
+ function CompareLookupResult(
+ FileHandle : PPhysDbFileHandle;
+ LookupValueRecordBuf : PAnsiChar;
+ LookupValueNullFlags : PcrBooleanArray;
+ var Match : Boolean;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+ var
+ FFError : TffResult;
+ I : integer;
+ FieldNo : integer;
+ LookupOffset : integer;
+ LookupValueLen : DWORD;
+ FieldLen : integer;
+ CompareLen : DWORD;
+ NFields : integer;
+ LookupNullFlag : Boolean;
+ NullField : Boolean;
+ begin
+ Result := errPhysDbNoError;
+ Match := False;
+
+ { Ensure that fields are in system buffer }
+ FFError := ServerEngine.RecordGet(FileHandle^.CursorID,
+ ffltNoLock,
+ FileHandle^.ReadInfo^.PhysRecordBuf);
+ if FFError <> DBIERR_NONE then begin
+ Result := IDAPIError(FFError, ErrMsg);
+ Exit;
+ end;
+
+ { Fetch fields from system record buffer }
+ NFields := FileHandle^.ReadInfo^.NFieldsInLookupValue;
+ LookupNullFlag := False;
+ if NFields > 0 then
+ LookupNullFlag := LookupValueNullFlags^[0];
+
+ for I := 0 to pred(NFields) do begin
+ FieldNo := FileHandle^.ReadInfo^.IndexDefnInfo^[I].FieldNo;
+ LookupOffset := FileHandle^.ReadInfo^.IndexDefnInfo^[I].OffsetInRecord;
+ FieldLen := FileHandle^.ReadInfo^.IndexDefnInfo^[I].FieldLength;
+ NullField := False;
+ TFFProxyCursor(FileHandle^.CursorID).Dictionary.GetRecordField(FieldNo,
+ FileHandle^.ReadInfo^.PhysRecordBuf,
+ NullField,
+ @FileHandle^.ReadInfo^.KeyBuf[LookupOffset]);
+ if FFError <> DBIERR_NONE then begin
+ Result := IDAPIError(FFError, ErrMsg);
+ Exit;
+ end;
+
+ if LookupNullFlag or NullField then Exit;
+
+ { Compare each individual field to see if matches lookup value.
+ Only compare as much data as present if substring field }
+ CompareLen := FieldLen;
+ if FileHandle^.ReadInfo^.LookupValueLen < (LookupOffset + FieldLen) then
+ CompareLen := FileHandle^.ReadInfo^.LookupValueLen - LookupOffset;
+ if FileHandle^.ReadInfo^.IndexDefnInfo^[I].FieldType = ftStringField then begin
+ LookupValueLen := StrLen(@LookupValueRecordBuf[LookupOffset]);
+ if LookupValueLen < CompareLen then begin
+ if I = NFields - 1 then begin
+ if FileHandle^.ReadInfo^.LastLookupFieldIsSubstr then
+ CompareLen := LookupValueLen
+ else if LookupValueLen <> StrLen(@FileHandle^.ReadInfo^.KeyBuf[LookupOffset]) then
+ Exit
+ else
+ CompareLen := LookupValueLen;
+ end;
+ end;
+ end;
+
+(* if FileHandle^.ReadInfo^.IndexCaseSensitive then begin*)
+ if (CompareLen = 0) or (FFCmpBytes(PffByteArray(@FileHandle^.ReadInfo^.KeyBuf[LookupOffset]),
+ PffByteArray(@LookupValueRecordBuf[LookupOffset]),
+ CompareLen) <> 0) then begin
+ Exit;
+ end;
+ end;
+
+ Match := True;
+ end;
+var
+ FFError : TffResult;
+ Match : Boolean;
+ I : integer;
+ FieldN : integer;
+ NFields : integer;
+ LookupNullFlag : Boolean;
+begin
+ AddToLog('LookupMatchingRecurringRecVer15');
+ AddToLogFmt(' FileName: [%s]', [FileHandle^.PathAndFileName]);
+ AddToLogFmt(' CursorID: [%d]', [FileHandle^.CursorID]);
+ Result := errPhysDbNoError;
+ try
+
+ { Set up for search }
+ RecordRead := false;
+
+ with FileHandle^.ReadInfo^ do begin
+ if not StartTopOfFile then begin
+ AddToLog(' StartTopOfFile [False]');
+ if ValuesUnique and
+ not LastLookupFieldIsSubstr and
+ (NFieldsInLookupValue > NFieldsInIndexDefn) then
+ Exit;
+
+ { See if next record also matches }
+ FFError := ServerEngine.RecordGetNext(FileHandle^.CursorID,
+ ffltNoLock,
+ nil);
+ AddToLogFmt(' RecordGetNext Result [%d]', [FFError]);
+
+ if FFError <> DBIERR_NONE then
+ Exit;
+
+ Result := CompareLookupResult(FileHandle,
+ LookupValueRecordBuf,
+ LookupValueNullFlags,
+ Match,
+ ErrMsg);
+ AddToLogFmt(' Match Result [%s]', [BoolToStr(Match)]); {!!.12}
+ if (Result <> errPhysDbNoError) or not Match then Exit;
+ end else begin
+ AddToLog(' StartTopOfFile [True]');
+ { Clear all the fields in index }
+ for FieldN := 0 to pred(NFieldsInIndexDefn) do begin
+ TFFProxyCursor(FileHandle^.CursorID).Dictionary.SetRecordField(
+ IndexDefnInfo^[FieldN].FieldNo,
+ PhysRecordBuf,
+ nil);
+ end;
+
+ { Copy fields (without translating) from lookup value buffer to
+ system record buffer }
+ NFields := NFieldsInLookupValue;
+ LookupNullFlag := False;
+ if NFields > 0 then
+ LookupNullFlag := LookupValueNullFlags^[0];
+ FillChar(PhysRecordBuf^, NBytesInPhysRecord, #0);
+
+ for I := 0 to pred(NFields) do begin
+ if not LookupNullFlag then begin
+
+ { Copy index record field into system record buffer }
+ with IndexDefnInfo^[I] do
+ TFFProxyCursor(FileHandle^.CursorID).Dictionary.SetRecordField(
+ FieldNo,
+ PhysRecordBuf,
+ @LookupValueRecordBuf[OffsetInRecord]);
+ end;
+ end;
+
+ with TFFProxyCursor(FileHandle^.CursorID) do
+ Dictionary.ExtractKey(IndexID, PhysRecordBuf, @KeyBuf);
+
+ FFError := ServerEngine.CursorSetToKey(FileHandle^.CursorID,
+ skaEqual,
+ True,
+ NFieldsInLookupValue,
+ LastLookupFieldLen,
+ @KeyBuf);
+ AddToLogFmt(' CursorSetToKey Result [%d]', [FFError]);
+
+ { Test if exact lookup succeeeded }
+ if (FFError = DBIERR_EOF) or
+ (FFError = DBIERR_OUTOFRANGE) or
+ (FFError = DBIERR_RECNOTFOUND) or
+ (FFError = DBIERR_RECDELETED) then begin
+ Result := errPhysDbNoError;
+ Exit;
+ end
+ else if FFError <> DBIERR_NONE then begin
+ Result := IDAPIError(FFError, ErrMsg);
+ Exit;
+ end;
+
+ { read in the current record }
+ FFError := ServerEngine.RecordGetNext(FileHandle^.CursorID,
+ ffltNoLock,
+ FileHandle^.ReadInfo^.PhysRecordBuf);
+ AddToLogFmt(' RecordGetNext Result here [%d]', [FFError]);
+ if FFError <> DBIERR_NONE then begin
+ Result := IDAPIError(FFError, ErrMsg);
+ Exit;
+ end;
+ end;
+
+ Result := FetchReadRecFields(FileHandle^.ReadInfo,
+ FileHandle^.CursorID,
+ FileHandle^.NotXlateDOSString,
+ ReadRecordBuf,
+ ReadNullFlags,
+ ErrMsg);
+ if Result <> errPhysDbNoError then Exit;
+
+ RecordRead := true;
+ Result := FetchIndexRecFields(FileHandle^.ReadInfo,
+ FileHandle^.CursorID,
+ IndexRecordBuf,
+ IndexNullFlags,
+ ErrMsg);
+ end;
+ except
+ on EOutOfMemory do begin
+ Result := errPhysDbNotEnoughMemory;
+ StrPCopy(ErrMsg, '');
+ end;
+
+ on E: Exception do begin
+ if Result = errPhysDbNoError then
+ Result := errPhysDbErrMsgReturned;
+ StrPCopy(ErrMsg, E.Message);
+ end;
+ end;
+ if (Result = errPhysDbErrMsgReturned) then
+ AddToLogFmt(' ErrMsg: [%s]', [ErrMsg]);
+ AddResultToLog(Result);
+end;
+
+{ ------------------------- Memo Fields ---------------------------- }
+
+function FetchMemoField(
+ MemoFieldRecordBuf: PAnsiChar;
+ var MemoField: PAnsiChar;
+ ErrMsg: PAnsiChar) : TPhysDbError;
+begin
+ AddToLog('FetchMemoField');
+ MemoField := nil;
+ Result := errPhysDbNoError;
+ AddResultToLog(Result);
+end;
+
+function FreeMemoField(
+ var MemoField: PAnsiChar;
+ ErrMsg: PAnsiChar) : TPhysDbError;
+begin
+ AddToLog('FreeMemoField');
+ FFStrDispose(MemoField);
+ MemoField := nil;
+ Result := errPhysDbNoError;
+ AddResultToLog(Result);
+end;
+
+function FetchPersistentMemoField(FileHandle : PPhysDbFileHandle;
+ MemoFieldRecordBuf : PAnsiChar;
+ var MemoField : PAnsiChar;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+var
+ FFError : TffResult;
+ NativeType : TcrInt16u;
+ FieldN : integer;
+ FieldNo : integer;
+ ValueType : TFieldValueType;
+ CmpResult : Integer;
+ BlobSize : TcrInt32u;
+ NBytesReturned : TffWord32;
+ BlobHandle : THandle;
+ Handle : THandle;
+ BlobFieldPtr : PByteArray;
+ FinalBlobFieldPtr : PByteArray;
+ Size : TcrInt32u;
+ SavedBlobSize : TcrInt32u;
+ FirstTime : Boolean;
+ Offset : TcrInt32u;
+ NBytesCopied : TcrInt32u;
+ StartPos : TcrInt32u;
+ BookmarkSize : Integer;
+ IsNull : Boolean;
+ aBlobNr : TffInt64;
+ TempI64 : TffInt64;
+ BookmarkBuf : Pointer;
+begin
+ AddToLog('FetchPersistentMemoField');
+ AddBlockToLog(' Memo Data', MemoFieldRecordBuf, 12);
+
+ Result := errPhysDbNoError;
+ MemoField := nil;
+ try
+ try
+
+ { Restore the field info from brahma buffer }
+ FieldNo := TcrInt16s(MemoFieldRecordBuf^);
+ ValueType := ftPersistentMemoField;
+ NativeType := 0;
+ with FileHandle^.ReadInfo^ do
+ for FieldN := 0 to pred(NFieldsInReadRecord) do begin
+ if FieldInfo^[FieldN].FieldNo = FieldNo then begin
+ NativeType := FieldInfo^[FieldN].NativeFieldType;
+ if FieldInfo^[FieldN].FieldType = ftBlobField then
+ ValueType := ftBlobField;
+ end;
+ end;
+
+ { Get the current bookmark }
+ FFError := ServerEngine.CursorGetBookmarkSize(FileHandle^.CursorID, BookmarkSize);
+ if FFError <> DBIERR_NONE then begin
+ Result := IDAPIError(FFError, ErrMsg);
+ Exit;
+ end;
+
+ FFGetMem(BookmarkBuf, BookmarkSize + 1);
+ try
+ FFError := ServerEngine.CursorGetBookmark(FileHandle^.CursorID,
+ BookmarkBuf);
+ if FFError <> DBIERR_NONE then begin
+ Result := IDAPIError(FFError, ErrMsg);
+ Exit;
+ end;
+
+ ServerEngine.CursorCompareBookmarks(FileHandle^.CursorID,
+ BookmarkBuf,
+ @MemoFieldRecordBuf[SizeOf(TcrInt16u)],
+ CmpResult);
+
+ finally
+ FFFreeMem(BookmarkBuf, BookmarkSize+1);
+ end;
+
+ { If it is not the current position, reposition to the old position }
+ if CmpResult <> 0 then begin
+ FFError := ServerEngine.CursorSetToBookmark(FileHandle^.CursorID,
+ @MemoFieldRecordBuf[SizeOf(TcrInt16u)]);
+ if FFError = DBIERR_NONE then
+ FFError := ServerEngine.RecordGet(FileHandle^.CursorID,
+ ffltNoLock,
+ FileHandle^.ReadInfo^.PhysRecordBuf);
+
+ if FFError <> DBIERR_NONE then begin
+ Result := IDAPIError(FFError, ErrMsg);
+ Exit;
+ end;
+ end;
+
+ TempI64.iLow := 0;
+ TempI64.iHigh := 0;
+ TFFProxyCursor(FileHandle^.CursorID).Dictionary.GetRecordField(
+ FieldNo, FileHandle^.ReadInfo^.PhysRecordBuf, IsNull, @aBLOBNr);
+
+ if (not IsNull) and (ffCmpI64(aBLOBNr, TempI64) = 0) then
+ FFError := DBIERR_INVALIDBLOBHANDLE
+ else
+ FFError := DBIERR_NONE;
+
+ if FFError <> DBIERR_NONE then begin
+ Result := IDAPIError(FFError, ErrMsg);
+ Exit;
+ end;
+
+ if not IsNull then begin {!!.02}
+ try
+ FFError := ServerEngine.BLOBGetLength(FileHandle^.CursorID,
+ aBlobNr,
+ BlobSize);
+ if FFError <> DBIERR_NONE then begin
+ Result := IDAPIError(FFError, ErrMsg);
+ Exit;
+ end;
+
+ if BlobSize = 0 then
+ Exit;
+
+ if ValueType = ftPersistentMemoField then begin
+ {Handle only 64K memos for now }
+ BlobSize := BlobSize;
+ Handle := GlobalAlloc(GHND or GMEM_SHARE, BlobSize);
+ if Handle = 0 then
+ raise EOutOfMemory.Create('');
+ try
+ BlobHandle := GlobalAlloc(GHND or GMEM_SHARE, BlobSize + 1);
+ BlobFieldPtr := GlobalLock(Handle);
+ try
+ if Assigned(BlobFieldPtr) then begin
+ FinalBlobFieldPtr := GlobalLock(BlobHandle);
+ try
+ FFError := ServerEngine.BLOBRead(FileHandle^.CursorID,
+ aBlobNr,
+ 0,
+ BlobSize,
+ BlobFieldPtr^,
+ NBytesReturned);
+ if FFError <> DBIERR_NONE then begin
+ Result := IDAPIError(FFError, ErrMsg);
+ Exit;
+ end;
+
+ if NativeType = fldstFMTMEMO then begin
+ if BlobSize > 44 then begin
+ if StrLComp(PAnsiChar(BlobFieldPtr), #1#0#0#0#$C7#0#0#0, 8) = 0 then begin
+ Move(BlobFieldPtr^[8], FinalBlobFieldPtr^, BlobSize - 8);
+ FinalBlobFieldPtr[NBytesReturned - 8] := $0;
+ end else begin
+ Move(BlobFieldPtr^[44], FinalBlobFieldPtr^, BlobSize - 44);
+ FinalBlobFieldPtr[NBytesReturned - 44] := $0;
+ end;
+ end else begin
+ Move(BlobFieldPtr^, FinalBlobFieldPtr^, BlobSize);
+ FinalBlobFieldPtr[NBytesReturned] := $0;
+ end;
+ end else begin
+ Move(BlobFieldPtr^, FinalBlobFieldPtr^, BlobSize);
+ FinalBlobFieldPtr[NBytesReturned] := $0;
+ end;
+
+ if not FileHandle^.NotXlateDOSMemo then
+ OemToAnsi(PAnsiChar(FinalBlobFieldPtr), PAnsiChar(FinalBlobFieldPtr));
+
+ MemoField := PAnsiChar(FinalBlobFieldPtr);
+ finally
+ GlobalUnlock(BlobHandle);
+ end;
+ end;
+ finally
+ GlobalUnlock(Handle)
+ end;
+ finally
+ GlobalFree(Handle);
+ end;
+
+ end else begin
+ { Nonmemo BLOB, may be a bitmap }
+ Handle := GlobalAlloc(GHND or GMEM_SHARE, BlobSize);
+ if Handle = 0 then
+ raise EOutOfMemory.Create('');
+ try
+ if NativeType = fldstBINARY then
+ { No BLOB_INFO }
+ BlobHandle := GlobalAlloc(GHND or GMEM_SHARE, BlobSize - SizeOf(TBitmapFileHeader))
+ else
+ BlobHandle := GlobalAlloc(GHND or GMEM_SHARE, BlobSize - BLOB_INFO_SIZE - SizeOf(TBitmapFileHeader));
+ BlobFieldPtr := GlobalLock(Handle);
+ try
+ if Assigned(BlobFieldPtr) then begin
+ FinalBlobFieldPtr := GlobalLock(BlobHandle);
+ try
+ NBytesReturned := 0;
+ SavedBlobSize := BlobSize;
+ Size := FFMinDW(SavedBlobSize, $FFE0);
+ FirstTime := True;
+ Offset := 0;
+ NBytesCopied := 0;
+ while Size <> 0 do begin
+ FFError := ServerEngine.BLOBRead(FileHandle^.CursorID,
+ aBlobNr,
+ Offset,
+ Size,
+ BlobFieldPtr^,
+ NBytesReturned);
+ if FFError <> DBIERR_NONE then begin
+ Result := IDAPIError(FFError, ErrMsg);
+ Exit;
+ end;
+
+ Inc(Offset, NBytesReturned);
+ Dec(SavedBlobSize, NBytesReturned);
+ StartPos := 0;
+ if FirstTime then begin
+ if NativeType <> fldstBINARY then
+ Inc(StartPos, BLOB_INFO_SIZE);
+
+ { If it is not a bitmap, return nil }
+ if Copy(StrPas(PAnsiChar(@BlobFieldPtr^[StartPos])), 1 ,2) <> 'BM' then
+ Exit;
+
+ Inc(StartPos, SizeOf(TBitmapFileHeader));
+ end;
+
+ { Copy the bitmap data of size FFE0 or less depending on the size
+ of whole bitmap }
+ Move(BlobFieldPtr^[StartPos], FinalBlobFieldPtr^[NBytesCopied], Size - StartPos);
+
+ Inc(NBytesCopied, Size - StartPos);
+ { The size of data to be got }
+ Size := FFMinDW(SavedBlobSize, $FFE0);
+ FirstTime := False
+ end;
+ finally
+ GlobalUnlock(BlobHandle);
+ end;
+ end;
+ finally
+ GlobalUnlock(Handle);
+ end;
+ finally
+ GlobalFree(Handle);
+ end;
+
+ { Pass back the handle to the bitmap to Crystal. Allegedly, Crystal
+ will handle freeing it }
+ MemoField := PAnsiChar(BlobHandle);
+ end;
+ finally
+ ServerEngine.BLOBFree(FileHandle^.CursorID,
+ aBlobNr,
+ True);
+ end;
+ end; {!!.02}
+ except
+ on EOutOfMemory do begin
+ Result := errPhysDbNotEnoughMemory;
+ StrPCopy(ErrMsg, '');
+ end;
+ on E: Exception do begin
+ if Result = errPhysDbNoError then
+ Result := errPhysDbErrMsgReturned;
+ StrPCopy(ErrMsg, E.Message);
+ end;
+ end;
+ finally
+ StrPCopy(DebugBuff, PhysDbErrors[Result]); { this seems necessary for 32-bit }
+ end;
+ if (Result = errPhysDbErrMsgReturned) then
+ AddToLogFmt(' ErrMsg: [%s]', [ErrMsg]);
+ AddResultToLog(Result);
+end;
+
+function FreePersistentMemoField(
+ FileHandle: PPhysDbFileHandle;
+ var MemoField: PAnsiChar;
+ ErrMsg: PAnsiChar) : TPhysDbError;
+begin
+ AddToLog('FreePersistentMemoField');
+
+ GlobalFree(THandle(MemoField));
+ MemoField := nil;
+ Result := errPhysDbNoError;
+ AddResultToLog(Result);
+end;
+
+
+{ --------------------- Multi-User Access -------------------------- }
+
+function UseRecordLocking(FileHandle : PPhysDbFileHandle;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+begin
+ AddToLog('UseRecordLocking');
+ Result := errPhysDbNotImplemented;
+ AddResultToLog(Result);
+end;
+
+function UseFileLocking(FileHandle : PPhysDbFileHandle;
+ ErrMsg : PAnsiChar) : TPhysDbError;
+begin
+ AddToLog('UseFileLocking');
+ Result := errPhysDbNotImplemented;
+ AddResultToLog(Result);
+end;
+
+
+{===Debug logging====================================================}
+{Begin !!.12}
+procedure StartLog;
+begin
+{$IFDEF Debug}
+ Log := TffEventLog.Create(nil);
+ Log.FileName := FFMakeFullFileName(FFExtractPath(FFGetExeName), 'FFDRIVER.LOG');
+ Log.Enabled := True;
+ Log.WriteString('FF server log started');
+{$ELSE}
+ Log := nil;
+{$ENDIF}
+end;
+{--------}
+procedure EndLog;
+begin
+ if Log <> nil then
+ Log.Free;
+end;
+{--------}
+procedure AddToLog(const S : string);
+begin
+ if Log <> nil then
+ Log.WriteString(S);
+end;
+{--------}
+procedure AddToLogFmt(const S : string; args : array of const);
+begin
+ if Log <> nil then
+ Log.WriteStringFmt(S, args);
+end;
+{--------}
+procedure AddBlockToLog(const S : string; Buf : pointer; BufLen : TffMemSize);
+begin
+ if Log <> nil then
+ Log.WriteBlock(S, Buf, BufLen);
+end;
+{--------}
+procedure AddResultToLog(aResult : TPhysDbError);
+{$IFDEF Debug}
+var
+ S : string;
+{$ENDIF}
+begin
+{$IFDEF Debug}
+ case aResult of
+ errPhysDbNoError : S := 'errPhysDbNoError';
+ errPhysDbErrMsgReturned : S := 'errPhysDbErrMsgReturned';
+ errPhysDbNotEnoughMemory : S := 'errPhysDbNotEnoughMemory';
+ errPhysDbFileDoesNotExist : S := 'errPhysDbFileDoesNotExist';
+ errPhysDbFilePermissionError : S := 'errPhysDbFilePermissionError';
+ errPhysDbFileIntegrityError : S := 'errPhysDbFileIntegrityError';
+ errPhysDbUserCancelOperation : S := 'errPhysDbUserCancelOperation';
+ errPhysDbProgrammingError : S := 'errPhysDbProgrammingError';
+ errPhysDbNotImplemented : S := 'errPhysDbNotImplemented';
+ errPhysDbSQLServerError : S := 'errPhysDbSQLServerError';
+ errPhysDbIncorrectPassword : S := 'errPhysDbIncorrectPassword';
+ errPhysDbOpenSessionError : S := 'errPhysDbOpenSessionError';
+ errPhysDbLogOnServerError : S := 'errPhysDbLogOnServerError';
+ errPhysDbErrorHandledByDBDLL : S := 'errPhysDbErrorHandledByDBDLL';
+ errPhysDbStopProceeding : S := 'errPhysDbStopProceeding';
+ else
+ S := '***Unknown***';
+ end;{case}
+ Log.WriteStringFmt(' Result: %s [%d]', [S, ord(aResult)]);
+{$ENDIF}
+end;
+{End !!.12}
+{====================================================================}
+
+procedure UnitEnterProc;
+begin
+ TaskList := TTaskList.Create;
+ StartLog;
+end;
+
+procedure UnitExitProc;
+begin
+ EndLog;
+ TaskList.Free;
+end;
+
+initialization
+ UnitEnterProc;
+
+finalization
+ UnitExitProc;
+
+end.
+
diff --git a/components/flashfiler/sourcelaz/crystal/ffcrptyp.pas b/components/flashfiler/sourcelaz/crystal/ffcrptyp.pas
new file mode 100644
index 000000000..ad01e6756
--- /dev/null
+++ b/components/flashfiler/sourcelaz/crystal/ffcrptyp.pas
@@ -0,0 +1,354 @@
+{*********************************************************}
+{* Datatypes common to PhysDB, PhysDict, PhysDir, PhysDs *)
+(* Direct port of the original PHYSTYPE.HPP source file *)
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffcrdefn.inc}
+
+unit ffcrptyp;
+
+{ This file contains data types common to PhysDb.hpp, PhysDict.hpp,
+ PhysDir.hpp and PhysDs.hpp. }
+
+interface
+
+uses
+ SysUtils,
+ ffcrtype,
+ ffcrltyp;
+
+const
+ ERR_MSG_BUFFER_LEN = 255;
+ ALIAS_NAME_BUFFER_LEN = 255;
+
+ { bitflag constants for opening database. }
+ INCL_SYSTEM_TABLE : LongInt = $01;
+ CONVERT_DATETIME_TO_STRING : LongInt = $02;
+ TRANSLATE_DOS_STRINGS : LongInt = $04;
+ TRANSLATE_DOS_MEMOS : Longint = $08;
+ NEED_PROMPT_FOR_TABLES : LongInt = $16;
+ NEED_PROMPT_FOR_BROWSER : LongInt = $32;
+
+ MAX_LEN_SQL_INFO = 255;
+ MAX_LEN_DIR_INFO = 512;
+ MAX_LEN_SHORT_DIR_INFO = 128;
+
+ MAX_READ_FILES = 255;
+ MAX_FILE_LINKS = 255;
+ MAX_FIELDS_PER_FILE_LINK = 10;
+
+ BUFSIZE = 255;
+
+ CRYSTAL_LIKE = 'CRYSTAL_LIKE';
+ CRYSTAL_STARTWITH = 'CRYSTAL_STARTWITH';
+
+type
+ {$Z4 These enumerations are long sized, not word sized}
+ TPhysDbError = (errPhysDbNoError,
+ errPhysDbErrMsgReturned,
+ errPhysDbNotEnoughMemory,
+ errPhysDbFileDoesNotExist,
+ errPhysDbFilePermissionError,
+ errPhysDbFileIntegrityError,
+ errPhysDbUserCancelOperation,
+ errPhysDbProgrammingError,
+ errPhysDbNotImplemented,
+ errPhysDbSQLServerError,
+ errPhysDbIncorrectPassword,
+ errPhysDbOpenSessionError,
+ errPhysDbLogOnServerError,
+ errPhysDbErrorHandledByDBDLL,
+ errPhysDbStopProceeding);
+
+ TPhysDbIndexInfoCases = (iiIndexesNeverExist, { e.g. ASCII files }
+ iiIndexesExistButNotKnown,
+ iiSomeIndexesKnown,
+ iiAllIndexesKnown);
+
+ TPhysDbBuildIndexCases = (biCannotBuildIndex,
+ biCanBuildNonMaintainedIndex,
+ biCanBuildMaintainedIndex);
+
+ TPhysDbIndexTypes = (itNoIndex,
+ itdBase3,
+ itdBase4,
+ itClipper,
+ itFoxBase,
+ itFoxPro);
+ {$Z2 end of long sized enumerations}
+
+{ Pointers to file handle definition.
+ Note: The file handle structure is defined local to the physical
+ database or dictionary module (in FFCRLTYP.PAS), since its contents
+ vary per implementation. Crystal will not manipulate this info,
+ only pass a pointer to it in and out of the DLL. }
+
+ PPhysDbFileHandle = ^TPhysDbFileHandle;
+ TPhysDbFileHandleArray = array[0..32767 div SizeOf(TPhysDbFileHandle)] of TPhysDbFileHandle;
+ PPhysDbFileHandleArray = ^TPhysDbFileHandleArray;
+
+ PPhysDbServerHandle = ^TPhysDbServerHandle;
+
+{ Info describing a data field.
+ Note: The following fields of this structure are meaningful to the
+ InitDataFile functions, but not to FetchDataFileInfo:
+ - usedInReadRecord
+ - offsetInReadRecord
+ - usedInIndexRecord
+ - offsetInIndexRecord
+ This information can be set to zero or ignored by FetchDataFileInfo.
+}
+
+ PPhysDbFieldInfo = ^TPhysDbFieldInfo;
+ TPhysDbFieldInfo = packed record
+ Name : PChar; { field name }
+ FieldType : TFieldValueType; { generic Brahma field type }
+ NBytesInField : Word; { width of Brahma field type }
+ Picture : PChar; { picture format }
+ Alignment : TDBFieldAlignment; { left or right aligned }
+ Sortable : TcrBoolean;
+
+ NativeFieldType : Word; { native field type, 0 if not used }
+ NativeFieldOffset : Word; { offset to native field in phys record }
+ NBytesInNativeField : Word; { width of native field type }
+ NDecPlacesInNativeField : Word; { number decimal places in native field }
+
+ UsedInReadRecord : TcrBoolean; { set by caller of InitDataFile functions }
+ OffsetInReadRecord : Word; { set by caller of InitDataFile functions }
+ UsedInIndexRecord : TcrBoolean; { set by caller of InitDataFile functions }
+ OffsetInIndexRecord : Word; { set by caller of InitDataFile functions }
+ end;
+ TPhysDbFieldInfoArray = array[0..32767 div SizeOf(TPhysDbFieldInfo)] of TPhysDbFieldInfo;
+ PPhysDbFieldInfoArray = ^TPhysDbFieldInfoArray;
+
+{ Info describing a data file.
+ Note: The following fields of this structure are meaningful to the
+ InitDataFile functions, but not to FetchDataFileInfo:
+ - nBytesInReadRecord
+ - nFieldsInReadRecord
+ - nBytesInIndexRecord
+ - nFieldsInIndexRecord
+ This information can be set to zero or ignored by FetchDataFileInfo. }
+
+type
+ PPhysDbFileInfo = ^TPhysDbFileInfo;
+ TPhysDbFileInfo = packed record
+ FileType : TDBFieldFileType; { whether flat or recurring records }
+ TableName : PChar; { table name, nil if doesn't exist }
+ NBytesInPhysRecord : Word; { physical record length, 0 if not used }
+ NFields : Word; { number of fields in data file }
+ FieldInfo : PPhysDbFieldInfoArray; { array of field definitiona }
+
+ NBytesInReadRecord : Word; { set by caller of InitDataFile functions }
+ NFieldsInReadRecord : Word; { set by caller of InitDataFile functions }
+ NBytesInIndexRecord : Word; { set by caller of InitDataFile functions }
+ NFieldsInIndexRecord : Word; { set by caller of InitDataFile functions }
+ end;
+ TPhysDbFileInfoArray = array[0..32767 div SizeOf(TPhysDbFileInfo)] of TPhysDbFileInfo;
+ PPhysDbFileInfoArray = ^TPhysDbFileInfoArray;
+
+{ Info describing an index. }
+
+ PPhysDbIndexInfo = ^TPhysDbIndexInfo;
+ TPhysDbIndexInfo = packed record
+ ValuesUnique : TcrBoolean; { true if indx values known to be
+ unique (1:1 lookup), else false (1:n) }
+ NFields : Word; { number of fields in index definition }
+ FieldNumInFile : PWordArray; { array of fields in index definition;
+ each entry is a (0-origin) index into
+ the PhysDbFileInfo.fieldInfo array of
+ fields returned by FetchDataFileInfo }
+ IndexExpr : PChar; { if nFields == 0, fieldNumInFile is not
+ used and indexExpr is used instead;
+ it contains a text string describing
+ the calculated index expression }
+ EstimatedNBytesInExpr : Word; { if indexExpr is used this is the
+ estimated length of the expression }
+
+ IndexType : Word; { index type info }
+ DefaultIndexFileName : TcrBoolean;{ true if use default index file name,
+ false if indexFileName define below }
+ DefaultTagName : TcrBoolean; { true if use default tag, fals eif
+ tagname defined below }
+ IndexFileName : PChar; { defined if defaultIndexFilename = false }
+ TagName : PChar; { defined if defaultTagName = false }
+ Ascending : TcrBoolean;
+ CaseSensitive : TcrBoolean;
+ end;
+ TPhysDbIndexInfoArray = array[0..32767 div SizeOf(TPhysDbIndexInfo)] of TPhysDbIndexInfo;
+ PPhysDbIndexInfoArray = ^TPhysDbIndexInfoArray;
+
+{ Info describing set of indexes. }
+
+ PPhysDbIndexesInfo = ^TPhysDbIndexesInfo;
+ TPhysDbIndexesInfo = packed record
+ NIndexes : Word; { number of indexes for data file }
+ IndexInfo : PPhysDbIndexInfoArray; { array of index definitions }
+ IndexInUse : Word; { set by caller of OpendataFileAndIndexChoice }
+ NIndexesInUse : Word; { only valid for SQL table linking }
+ IndexInUseList : array[0..MAX_FILE_LINKS - 1] of Word; { a list of index for SQL linking }
+ end;
+ TPhysDbIndexesInfoArray = array[0..32767 div SizeOf(TPhysDbIndexesInfo)] of TPhysDbIndexesInfo;
+ PPhysDbIndexesInfoArray = ^TPhysDbIndexesInfoArray;
+
+{ Info describing a search range. }
+
+ PPhysDbFieldRangeInfo = ^TPhysDbFieldRangeInfo;
+ TPhysDbFieldRangeInfo = packed record
+ MinFieldValue : Pointer;
+ MinInclusive : TcrBoolean;
+ MaxFieldValue : Pointer;
+ MaxInclusive : TcrBoolean;
+ end;
+ TPhysDbFieldRangeInfoArray = array[0..32767 div SizeOf(TPhysDbFieldRangeInfo)] of TPhysDbFieldRangeInfo;
+ PPhysDbFieldRangeInfoArray = ^TPhysDbFieldRangeInfoArray;
+
+ PPhysDbRangeInfo = ^TPhysDbRangeInfo;
+ TPhysDbRangeInfo = packed record
+ FieldName : PChar;
+ BrahmaType : TFieldValueType;
+ BrahmaFieldLen : TcrInt16u;
+
+ SelectIfWithinRange: TcrBoolean;{ if FALSE, first calculate all ranges
+ in fieldRanges, then select those outside }
+ NFieldRanges : TcrInt16u; { if >1, these are implicitly OR'ed together }
+ FieldRanges : PPhysDbFieldRangeInfoArray;
+ end;
+ TPhysDbRangeInfoArray = array[0..32767 div SizeOf(TPhysDbRangeInfo)] of TPhysDbRangeInfo;
+ PPhysDbRangeInfoArray = ^TPhysDbRangeInfoArray;
+
+{ Info describing SQL search range. Multiple field ranges can be
+ specified for each table. }
+
+ PPhysDbSQLRangeInfo = ^TPhysDbSQLRangeInfo;
+ TPhysDbSQLRangeInfo = packed record
+ TableName : PChar;
+ RangeInfo : TPhysDbRangeInfo;
+ end;
+
+{ Info describing a link. }
+
+ PPhysDbFileLinkInfo = ^TPhysDbFileLinkInfo;
+ TPhysDbFilelinkInfo = packed record
+ FromFile : PPhysDbFileInfo;
+ ToFile : PPhysDbFileInfo;
+ FromFieldList : array[0..MAX_FIELDS_PER_FILE_LINK - 1] of Word;
+ ToFieldList : array[0..MAX_FIELDS_PER_FILE_LINK - 1] of Word;
+ NFields : Word;
+ LookupType : TDBLinkJoinType; { defined to pass the join type to DLL }
+ end;
+ TPhysDbFileLinkInfoArray = array[0..32767 div Sizeof(TPhysDbFileLinkInfo)] of TPhysDbFileLinkInfo;
+ PPhysDbFileLinkInfoArray = ^TPhysDbFileLinkInfo;
+
+{$IFDEF INCL_SERVER_OPTIONS}
+ PPhysDbServerOption = ^TPhysDbServerOption;
+ TPhysDbServerOption = packed record
+ ConvertDateTimeToString : TBoolean;
+ CountNRecordsBeforeReading : TBoolean;
+ NRecordsThreshold : Word;
+ end;
+{$ENDIF}
+
+ PPhysDbServerInfo = ^TPhysDbServerInfo;
+ TPhysDbServerInfo = packed record
+ ServerType : array[0..MAX_LEN_SQL_INFO - 1] of char; { SQL server type name }
+ ServerName : array[0..MAX_LEN_SQL_INFO - 1] of char;
+ DatabaseName : array[0..MAX_LEN_SQL_INFO - 1] of char;
+ UserID : array[0..MAX_LEN_SQL_INFO - 1] of char;
+
+ SqlLinIndex : Word; { index to sqlLibs }
+
+ UseDictPath : TcrBoolean; { ver 1.10 for NetWare SQL }
+ UseDataPath : TcrBoolean;
+
+ {$IFDEF INCL_SERVER_OPTIONS}
+ Option: PPhysDbServerOption;
+ Pid : HTASK; (* ?? *)
+ {$ENDIF}
+ end;
+
+ PPhysDbFileDirectoryInfo = ^TPhysDbFileDirectoryInfo;
+ TPhysDbFileDirectoryInfo = packed record
+ { Fixed length strings since DbMgr and DLLs can both edit these values,
+ and use different memory allocation methods. }
+ DirPath: array[0..MAX_LEN_SHORT_DIR_INFO - 1] of char; { path and directory file name (e.g. "C:\ACCESS\SAMPLE.MDB") }
+ ConnectBuf: array[0..MAX_LEN_DIR_INFO - 1] of char; { connection info (e.g. "ODBC;DSN=DSQUERY;UID=user") }
+ end;
+
+ PPhysDbFileDictionaryInfo = ^TPhysDbFileDictionaryInfo;
+ TPhysDbFileDictionaryInfo = packed record
+ { Fixed length string since DbMgr and DLLs can both edit these values,
+ and use different memory allocation methods. }
+ DictPath: array[0..MAX_LEN_SHORT_DIR_INFO - 1] of char; { path abd dictionary file name (e.g., "C:\BTRIEVE\FILE.DDF") }
+ end;
+
+ PPhysDbSessionInfo = ^TPhysDbSessionInfo;
+ TPhysDbSessionInfo = packed record
+ { Fixed length strings since DbMgr and DLLs can both edit these values,
+ and use different memory allocation methods. }
+ SessionUserID: array[0..MAX_LEN_SHORT_DIR_INFO - 1] of char;
+ SessionPassword: array[0..MAX_LEN_SHORT_DIR_INFO - 1] of char;
+ SessionHandle: Cardinal; { if <> 0 use sessionHandle, else use
+ sessionUserID and sessionPassword }
+ end;
+
+ PPhysDbLogOnInfo = ^TPhysDbLogOnInfo;
+ TPhysDbLogOnInfo = packed record
+ { Fixed length string since DbMgr and DLLs can both edit these values,
+ and use different memory allocation methods. }
+ LogOnPassword: array[0..MAX_LEN_SHORT_DIR_INFO - 1] of char;
+ end;
+
+ PPhysDbLookupOptInfo = ^TPhysDbLookupOptInfo;
+ TPhysDbLookupOptInfo = packed record
+ LookupValueLen : Word;
+ PartialMatch : TcrBoolean;
+ end;
+
+const
+ { temporary, for debugging purposes }
+ PhysDbErrors: array[TPhysDbError] of string[30] =(
+ 'PhysDbNoError',
+ 'PhysDbErrMsgReturned',
+ 'PhysDbNotEnoughMemory',
+ 'PhysDbFileDoesNotExist',
+ 'PhysDbFilePermissionError',
+ 'PhysDbFileIntegrityError',
+ 'PhysDbUserCancelOperation',
+ 'PhysDbProgrammingError',
+ 'PhysDbNotImplemented',
+ 'PhysDbSQLServerError',
+ 'PhysDbIncorrectPassword',
+ 'PhysDbOpenSessionError',
+ 'PhysDbLogOnServerError',
+ 'PhysDbErrorHandledByDBDLL',
+ 'PhysDBStopProceeding');
+
+implementation
+
+end.
diff --git a/components/flashfiler/sourcelaz/crystal/ffcrtype.pas b/components/flashfiler/sourcelaz/crystal/ffcrtype.pas
new file mode 100644
index 000000000..daa221481
--- /dev/null
+++ b/components/flashfiler/sourcelaz/crystal/ffcrtype.pas
@@ -0,0 +1,138 @@
+{*********************************************************}
+{* Low-level datatypes. *)
+(* Direct port of original TYPES.HPP and DBTYPES.HPP *)
+(* source files *)
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffcrdefn.inc}
+
+unit ffcrtype;
+
+interface
+
+{ The following types are derived from the original DBTYPES.HPP source file }
+type
+ TDBFieldFileType = (ftFlatFile, ftRecurringFile, ftStoredProcedure);
+
+ TDBFieldAlignment = (alLeftAlignedChars, alRightAlignedChars);
+
+ TDBLinkLookupType = (luLookupParallel, luLookupProduct, luLookupSeries);
+
+ TDBLinkJoinType = (
+ jtUnused1,
+ jtUnused2,
+ jtUnused3,
+ jtLookupEqual,
+ jtLookupLeftOuter,
+ jtLookupRightOuter,
+ jtLookupOuter,
+ jtLookupGreaterThan,
+ jtLookupLessThan,
+ jtLookupGreaterOrEqual,
+ jtLookupLessOrEqual,
+ jtLookupNotEqual
+ );
+
+{ The following types are derived from the original TYPES.HPP source file.
+ These are generally datatypes shared between the driver and the CRW application. }
+type
+ DWORD = LongInt;
+ TcrInt8u = Byte;
+ TcrInt8s = ShortInt;
+ TcrInt16u = Word;
+ PcrInt16u = ^TcrInt16u;
+ TcrInt16s = SmallInt;
+ PcrInt16s = ^TcrInt16s;
+ TcrInt32u = DWORD;
+ TcrInt32s = LongInt;
+ PcrInt32s = ^TcrInt32s;
+ TcrBoolean = WordBool;
+ PcrBoolean = ^TcrBoolean;
+ TcrNumber = Double;
+ PcrNumber = ^TcrNumber;
+ TcrCurrency = Double;
+ PcrCurrency = ^TcrCurrency;
+ TcrDate = LongInt;
+ PcrDate = ^TcrDate;
+ TcrTime = TcrInt32u;
+ PcrTime = ^TcrTime;
+
+ TcrBooleanArray = array[0..32767 div SizeOf(TcrBoolean)] of TcrBoolean;
+ PcrBooleanArray = ^TcrBooleanArray;
+
+ PSmallInt = ^SmallInt;
+ PDateTime = ^TDateTime;
+ PDouble = ^Double;
+
+ TFieldValueType = (ftInt8sField,
+ ftInt8uField,
+ ftInt16sField,
+ ftInt16uField,
+ ftInt32sField,
+ ftInt32uField,
+ ftNumberField,
+ ftCurrencyField,
+ ftBooleanField,
+ ftDateField,
+ ftTimeField,
+ ftStringField,
+ ftTransientMemoField,
+ ftPersistentMemoField,
+ ftBlobField,
+ ftUnknownField);
+
+const
+ NULL_BRAHMA_DATE : TcrDate = -1;
+ NULL_BRAHMA_TIME : TcrTime = -1;
+
+ NUMBER_SCALING_FACTOR : TcrNumber = 100.0;
+
+ SIZEOF_DATETIME_FIELD_STRING = 22; { YYYY/MM/DD HH:MM:SS.mm }
+
+ { temporary, for debugging purposes }
+ FieldValueTypes: array[TFieldValueType] of string[20] =
+ ('Int8sField',
+ 'Int8uField',
+ 'Int16sField',
+ 'Int16uField',
+ 'Int32sField',
+ 'Int32uField',
+ 'NumberField',
+ 'CurrencyField',
+ 'BooleanField',
+ 'DateField',
+ 'TimeField',
+ 'StringField',
+ 'TransientMemoField',
+ 'PersistentMemoField',
+ 'BlobField',
+ 'UnknownField');
+
+implementation
+
+end.
diff --git a/components/flashfiler/sourcelaz/crystal/ffcrutil.pas b/components/flashfiler/sourcelaz/crystal/ffcrutil.pas
new file mode 100644
index 000000000..b551bf5b1
--- /dev/null
+++ b/components/flashfiler/sourcelaz/crystal/ffcrutil.pas
@@ -0,0 +1,147 @@
+{*********************************************************}
+{* Low-Level functions for general use. *)
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffcrdefn.inc}
+
+unit ffcrutil;
+
+interface
+
+uses
+ ffllbase,
+ ffcrltyp,
+ ffcrtype;
+
+function PadStr(const S : TffShStr; const Width : Word): TffShStr;
+procedure TrimStrR(P : PChar);
+function CrDateToDateTime(BDate : TcrDate) : TDateTime;
+procedure CrDateToYearMonthDay(BDate : TcrDate;
+ var Year : TcrInt16s;
+ var Month : TcrInt16u;
+ var Day : TcrInt16u);
+function YearMonthDayToCrDate(const Year, Month, Day: SmallInt): TcrDate;
+function BoolToStr(const Bool: TcrBoolean): TffShStr;
+function MyStrPas(S: PChar): TffShStr;
+function DumpNBytes(Data: Pointer; N: Integer): TffShStr;
+
+implementation
+
+uses
+ FFStDate,
+ SysUtils;
+
+function BoolToStr(const Bool: TcrBoolean): TffShStr;
+begin
+ if Bool then
+ Result := 'True'
+ else
+ Result := 'False';
+end;
+{--------}
+function MyStrPas(S: PChar): TffShStr;
+begin
+ if not Assigned(S) then Result := 'nil'
+ else Result := '"' + StrPas(S) + '"';
+end;
+{--------}
+function DumpNBytes(Data: Pointer; N: Integer): TffShStr;
+var
+ I: Integer;
+ DataBytes: PByteArray absolute Data;
+begin
+ Result := '';
+ if Assigned(Data) then
+ for I := 0 to N - 1 do
+ Result := Result + IntToHex(Ord(DataBytes^[I]),2) + ' '
+ else
+ Result := 'nil';
+end;
+{--------}
+function PadStr(const S : TffShStr; const Width : Word): TffShStr;
+var
+ I : Integer;
+begin
+ if Length(S) >= Width then
+ Result := Copy(S, 1, Width)
+ else begin
+ Result := S;
+ for I := Succ(Length(Result)) to Width do
+ Result := Result + ' ';
+ end;
+end;
+{--------}
+procedure TrimStrR(P : PChar);
+ {-Trim trailing blanks from P}
+var
+ I : Integer;
+begin
+ I := StrLen(P);
+ if I = 0 then
+ Exit;
+
+ {delete trailing spaces}
+ Dec(I);
+ while (I >= 0) and (P[I] = ' ') do begin
+ P[I] := #0;
+ Dec(I);
+ end;
+end;
+{--------}
+{ Conversion from gregorian to julian date representation.
+ If specificed date is invalid, dateToDate returns (-1),
+ otherwise return Julian date representation.
+
+ Julian date = 0 for date 4713/01/01 B.C. }
+
+function CrDateToDateTime(BDate: TcrDate): TDateTime;
+var
+ Day, Month, Year: Integer;
+begin
+ StDateToDMY(AstJulianDateToStDate(BDate, False), Day, Month, Year);
+ Result := EncodeDate(Year, Month, Day);
+end;
+{--------}
+procedure CrDateToYearMonthDay(BDate : TcrDate;
+ var Year : TcrInt16s;
+ var Month : TcrInt16u;
+ var Day : TcrInt16u);
+begin
+ { see date2ymd.cpp }
+end;
+{--------}
+function YearMonthDayToCrDate(const Year, Month, Day: SmallInt): TcrDate;
+begin
+ { Use SysTools routines to convert date to Julian date. DMYToStDate
+ performs date validation as well. }
+ Result := Trunc(AstJulianDate(DMYToStDate(Day, Month, Year, 1950)));
+ if Result = BadDate then Result := -1;
+end;
+{====================================================================}
+end.
+
diff --git a/components/flashfiler/sourcelaz/crystal/p2bff213.dpr b/components/flashfiler/sourcelaz/crystal/p2bff213.dpr
new file mode 100644
index 000000000..5b8eea8a9
--- /dev/null
+++ b/components/flashfiler/sourcelaz/crystal/p2bff213.dpr
@@ -0,0 +1,121 @@
+{*********************************************************}
+{* 32-bit Crystal Reports Driver Project File *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{ NOTICE: This is the source code for a database DLL driver
+ to allow Crystal Reports 4.5 to 7.x to directly access
+ TurboPower's FlashFiler database tables. Although this is
+ a driver for a third-party product, Seagate Software (Crystal
+ Reports) has no obligation to support this driver (and will
+ not in any way). All tech support concerns regarding the
+ FlashFiler driver for Crystal Reports should be directed
+ to TurboPower Software Company. }
+
+library p2bff213;
+
+{$I ffdefine.inc}
+
+{$I ffcrdefn.inc}
+
+uses
+ {$IFDEF USETeDEBUG}
+ TeDebug,
+ {$ENDIF}
+ Windows,
+ Forms,
+ SysUtils,
+ ffllbase,
+ ffcrmain in 'ffcrmain.pas' { Main routines for processing CRW requests },
+ ffcrtype in 'ffcrtype.pas' { Principal datatypes and structures },
+ ffcrptyp in 'ffcrptyp.pas' { Datatypes shared between driver and CRW },
+ ffcrltyp in 'ffcrltyp.pas' { Datatypes specific to this physical database },
+ ffcrutil in 'ffcrutil.pas' { General utility routines };
+
+{$R *.RES}
+
+exports
+ PhysDbVersionNumber index 1,
+ CanRecognizeDataFile index 2,
+ CanFetchDataFileInfo index 3,
+ CanFetchDataFileIndexInfo index 4,
+ CanBuildIndex index 5,
+ CanFetchNRecurringRecords index 6,
+ SQLCompatible index 7,
+ CanReadSortedOrder index 8,
+ CanReadRangeOfValues index 9,
+ CanUseRecordLocking index 10,
+ CanUseFileLocking index 11,
+ InitPhysicalDatabase index 12,
+ TermPhysicalDatabase index 13,
+ OpenSession index 14,
+ TermSession index 15,
+ FetchDatabaseName index 16,
+ FreeDatabaseName index 17,
+ LogOnServer index 18,
+ LogOffServer index 19,
+ ParseLogOnInfo index 20,
+ RebuildConnectBuf index 21,
+ OpenDataFileIfRecognizedVer113 index 22,
+ OpenDataAndIndexFileIfRecogV113 index 23,
+ OpenDataFileAndIndexChoiceVer113 index 24,
+ CloseDataFile index 25,
+ FetchDataFileInfo index 26,
+ FreeDataFileInfo index 27,
+ FetchDataFileIndexInfo index 28,
+ FreeDataFileIndexInfo index 29,
+ BuildAndExecSQLQuery index 30,
+ InitDataFileForReadingVer17 index 31,
+ InitDataFileAndIndexForReadV115 index 32,
+ TermDataFileForReading index 33,
+ NRecurringRecordsToRead index 34,
+ ReadFlatRecordVer15 index 35,
+ ReadNextRecurringRecordVer15 index 36,
+ LookupMatchingRecurringRecVer15 index 37,
+ FetchMemoField index 38,
+ FreeMemoField index 39,
+ FetchPersistentMemoField index 40,
+ FreePersistentMemoField index 41,
+ UseRecordLocking index 42,
+ UseFileLocking index 43;
+
+
+var
+ ExitSave : Pointer;
+
+procedure DLLExitProc; far;
+begin
+ ExitProc := ExitSave;
+ AddToLog('Unloading FlashFiler 2 driver');
+end;
+
+begin
+ AddToLog(Format('Loading FlashFiler 2 driver; Version: [%d]', [ffVersionNumber]));
+ ExitSave := ExitProc;
+ ExitProc := Addr(DLLExitProc);
+end.
+
diff --git a/components/flashfiler/sourcelaz/crystal/p2bff213.rc b/components/flashfiler/sourcelaz/crystal/p2bff213.rc
new file mode 100644
index 000000000..540bf06ce
--- /dev/null
+++ b/components/flashfiler/sourcelaz/crystal/p2bff213.rc
@@ -0,0 +1,60 @@
+/*********************************************************
+ * Main program icon resource *
+ *********************************************************/
+
+/* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** */
+
+#define VERSIONINFO_1 1
+
+VERSIONINFO_1 VERSIONINFO
+FILEVERSION 2, 1, 3, 0
+PRODUCTVERSION 2, 1, 3, 0
+FILEOS VOS__WINDOWS32
+FILETYPE VFT_APP
+{
+ BLOCK "StringFileInfo"
+ {
+ BLOCK "040904E4"
+ {
+ VALUE "CompanyName", "TurboPower Software Company\000\000"
+ VALUE "FileDescription", "FlashFiler Crystal Reports Driver\000"
+ VALUE "FileVersion", "2.1.3.0\000"
+ VALUE "InternalName", "P2BFF213\000"
+ VALUE "LegalCopyright", "Copyright (c) TurboPower Software Co. 1996-2002\000\000"
+ VALUE "OriginalFilename", "P2BFF213.EXE\000"
+ VALUE "ProductName", "FlashFiler (Delphi Edition)\000"
+ VALUE "ProductVersion", "2.1.3.0\000"
+ }
+
+ }
+
+ BLOCK "VarFileInfo"
+ {
+ VALUE "Translation", 0x409, 1252
+ }
+
+}
+
diff --git a/components/flashfiler/sourcelaz/crystal/p2bff213.res b/components/flashfiler/sourcelaz/crystal/p2bff213.res
new file mode 100644
index 000000000..1a6d6592f
Binary files /dev/null and b/components/flashfiler/sourcelaz/crystal/p2bff213.res differ
diff --git a/components/flashfiler/sourcelaz/crystal/readme.txt b/components/flashfiler/sourcelaz/crystal/readme.txt
new file mode 100644
index 000000000..9abbe934e
--- /dev/null
+++ b/components/flashfiler/sourcelaz/crystal/readme.txt
@@ -0,0 +1,96 @@
+======================================================================
+ FlashFiler Crystal Reports Driver
+======================================================================
+
+
+Introduction
+============
+
+This Dynamic Link Library is an add-on for FlashFiler v2.0x to enable
+Seagate Software's Crystal Reports to directly access FlashFiler databases.
+To use this database driver, you must already have installed Crystal Reports
+v4.5 or v5.0 (32-bit only). The driver ships as an authenticated
+DLL which you will install as a Crystal Reports database driver.
+
+Installation
+============
+
+The database driver is named: P2BFFxxx.DLL, where refers to the version
+of the build.
+
+Before installing this driver, it is assumed that Crystal Reports has already
+been installed on the machine. Copy the P2BFFxxx.DLL file into the
+C:\WINDOWS\CRYSTAL directory.This is the location where Crystal Reports stores
+most of its database drivers. If you don't already have a C:\WINDOWS\CRYSTAL
+directory, and you're certain you've correctly installed Crystal Reports,
+search your hard disks for a native Crystal Reports database driver such as
+P2BPDX.DLL, P2BXBSE.DLL, or P2BBDE.DLL. Copy your FlashFiler driver into
+that same directory. Crystal Reports also keeps drivers in the
+C:\WINDOWS\SYSTEM directory and the CRW application directory. You should
+install the FlashFiler driver into C:\WINDOWS\CRYSTAL unless you have need to
+move it to one of these other directories.
+
+When Crystal Reports opens a data file, it scans the directory containing its
+database drivers and loads each one until it finds one that responds positively
+that it can recognize the data file given to it. Unfortunately, some of the
+native Crystal Reports drivers incorrectly respond that they can recognize
+FlashFiler data files. When this happens, the table structure displayed by
+Crystal Reports usually contains only a single field called FIELD1.
+
+You can verify whether Crystal has settled on an incorrect driver by selecting
+File|Report Options from the main menu. At the bottom of this dialog, above
+the grayed out combo box is a grayed out label showing the name of the driver
+that Crystal loaded to process this data file. It should say PDBFFxxx.DLL.
+If it does not, then you've stumbled onto a native Crystal Reports driver that
+is not behaving robustly. You must remove this errant driver from the
+directory (or rename it so that it no longer matches the pattern P2B*.DLL).
+
+Remember, for 32-bit Crystal Reports, even if File|Report Options says it's
+loaded the driver PDBBDE.DLL, it's really referring to P2BBDE.DLL. All the
+32-bit drivers are prefixed with P2B although this display always reports
+PDB prefixes in both versions.
+
+Setting the Network Configuration
+=================================
+
+Since the Crystal Reports database driver is actually a FlashFiler client
+application, it needs to be aware of the network protocol to use to connect
+to the FlashFiler server. Use the FlashFiler Client Communcations Utility
+to set the protocol and optional fixed server name values for each client
+workstation.
+
+Using Crystal Reports
+=====================
+
+Accessing FlashFiler data files through Crystal Reports is similar to accessing
+desktop files. You'll have to select the physical FFD file from a drive and
+directory. For example, select File|New from the main menu. Click the
+"Custom>>>" button. Click "Data File". Then select your FlashFiler data file.
+Paths to other machines will be converted to Universal Naming Convention
+format before being processed by the FlashFiler server. Paths to the local
+machine are only valid if the server is also running on the local machine.
+
+You can change Crystal Report's default wildcard specifier to accomodate
+FlashFiler datafiles as follows:
+
+32-bit: In the registry, change DatabaseSelector to "*.ff2" in the
+ following key:
+
+ HKEY_CURRENT_USER
+ Software
+ Crystal Software
+ Crystal Reports
+ DatabaseOptions
+
+Technical Support
+=================
+
+This driver was developed by TurboPower Software Company and is not supported
+in any way by Seagate Software. DO NOT CONTACT SEAGATE SOFTWARE FOR TECHNICAL
+SUPPORT REGARDING THE FLASHFILER DATABASE DRIVER FOR CRYSTAL REPORTS. Refer
+all technical support questions related to the Crystal Reports driver directly
+to TurboPower Software.
+
+Technical support questions can be sent to support@turbopower.com, or you may
+use our support newsgroup turbopower.public.support.flashfiler
+
diff --git a/components/flashfiler/sourcelaz/explorer/DgCpyTbl.dfm b/components/flashfiler/sourcelaz/explorer/DgCpyTbl.dfm
new file mode 100644
index 000000000..0ff43ccdc
Binary files /dev/null and b/components/flashfiler/sourcelaz/explorer/DgCpyTbl.dfm differ
diff --git a/components/flashfiler/sourcelaz/explorer/DgCpyTbl.pas b/components/flashfiler/sourcelaz/explorer/DgCpyTbl.pas
new file mode 100644
index 000000000..eb6940a0b
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/DgCpyTbl.pas
@@ -0,0 +1,194 @@
+{*********************************************************}
+{* Dialog to copy records to another table *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * Eivind Bakkestuen
+ * Used with permission.
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit dgcpytbl;
+
+interface
+
+uses
+ Windows,
+ Messages,
+ SysUtils,
+ Classes,
+ Graphics,
+ Controls,
+ Forms,
+ Dialogs,
+ StdCtrls,
+ Buttons,
+ ubase,
+ uentity,
+ ffdb;
+
+type
+ TdlgCopyToTable = class(TForm)
+ lstTables: TListBox;
+ lblImport: TLabel;
+ btnOK: TBitBtn;
+ btnCancel: TBitBtn;
+ cbCopyBlobs: TCheckBox;
+ btnNewTable: TButton;
+ procedure btnOKClick(Sender: TObject);
+ procedure lstTablesDblClick(Sender: TObject);
+ procedure btnNewTableClick(Sender: TObject);
+ procedure FormShow(Sender: TObject);
+ procedure FormClose(Sender: TObject; var Action: TCloseAction);
+ private
+ public
+ FDatabase : TffeDatabaseItem;
+ FTableIndex: LongInt;
+ FSourceDataset: TffDataset;
+ FExludeTableName: String;
+ end;
+
+var
+ dlgCopyToTable: TdlgCopyToTable;
+
+function ShowCopyTableDlg(aDatabase : TffeDatabaseItem;
+ aExcludeTableIndex: LongInt;
+ aSourceDataset: TffDataset;
+ var aTableIndex: LongInt;
+ var aCopyBlobs: Boolean;
+ var aTableItem: TffeTableItem): TModalResult; {!!.11}
+
+
+implementation
+
+{$R *.DFM}
+
+uses
+ uconfig, {!!.11}
+ fmmain; { to refresh tablelist if we create new }
+
+
+function ShowCopyTableDlg(aDatabase : TffeDatabaseItem;
+ aExcludeTableIndex: LongInt;
+ aSourceDataset: TffDataset;
+ var aTableIndex: LongInt;
+ var aCopyBlobs: Boolean;
+ var aTableItem: TffeTableItem): TModalResult; {!!.11}
+var
+ T: LongInt;
+ TableName : String; {!!.11}
+ { we must save the tablename and use it to return the
+ possibly changed TableItem. Creating new tables
+ changes the tablelist structure and invalidates
+ the passed-in aTableItem. }
+begin
+ with TdlgCopyToTable.Create(nil) do
+ try
+ TableName := aTableItem.TableName; {!!.11}
+ FDatabase := aDatabase;
+ FSourceDataset := aSourceDataset;
+ FDatabase := aDatabase;
+ lstTables.Clear;
+ for T := 0 to pred(FDatabase.TableCount) do
+ with FDatabase.Tables[T] do
+ if T <> aExcludeTableIndex then
+ lstTables.Items.AddObject(TableName, Pointer(T))
+ else
+ FExludeTableName := FDatabase.Tables[T].TableName;
+ lstTables.ItemIndex := 0;
+ Result := ShowModal;
+ aTableIndex := -1;
+ if Result = mrOK then begin
+ aTableIndex := FTableIndex;
+ aCopyBlobs := cbCopyBlobs.Checked;
+ end;
+ { ensure we reset aTableName; it could have
+ changed in the underlying structure }
+ {Begin !!.11}
+ if Assigned(aTableItem) then
+ for T := 0 to Pred(aDatabase.TableCount) do
+ if aDatabase.Tables[T].TableName=TableName then begin
+ aTableItem := aDatabase.Tables[T];
+ break;
+ end;
+ {End !!.11}
+ finally
+ Free;
+ end;
+end;
+
+
+procedure TdlgCopyToTable.lstTablesDblClick(Sender: TObject);
+begin
+ btnOk.Click;
+end;
+
+procedure TdlgCopyToTable.btnOKClick(Sender: TObject);
+begin
+ with lstTables do
+ FTableIndex := LongInt(Items.Objects[ItemIndex]);
+end;
+
+procedure TdlgCopyToTable.btnNewTableClick(Sender: TObject);
+var
+ T : Integer;
+ NewTableName : String;
+begin
+ if InputQuery('New Table', 'Tablename:', NewTableName) then begin
+ FDatabase.CreateTable(NewTableName, FSourceDataset.Dictionary);
+ { refresh mainwindow treeview }
+ frmMain.outServers.Selected := frmMain.GetEntityNode(etDatabase, FDatabase);
+ frmMain.RefreshTables(Self);
+ { refresh listbox }
+ lstTables.Clear;
+ for T := 0 to pred(FDatabase.TableCount) do
+ with FDatabase.Tables[T] do
+ if TableName<>FExludeTableName then
+ lstTables.Items.AddObject(TableName, Pointer(T));
+ lstTables.ItemIndex := lstTables.Items.IndexOf(NewTableName);
+ btnOk.SetFocus;
+ end;
+end;
+
+{Begin !!.11}
+procedure TdlgCopyToTable.FormShow(Sender: TObject);
+var
+ BaseSection : string;
+begin
+ BaseSection := ClassName + '.' + Self.Caption;
+ cbCopyBlobs.Checked := FFEConfigGetBoolean(BaseSection, 'Copy BLOBs', True);
+end;
+
+procedure TdlgCopyToTable.FormClose(Sender: TObject; var Action: TCloseAction);
+var
+ BaseSection : string;
+begin
+ BaseSection := ClassName + '.' + Self.Caption;
+ FFEConfigSaveBoolean(BaseSection, 'Copy BLOBs', cbCopyBlobs.Checked);
+end;
+{End !!.11}
+
+
+end.
diff --git a/components/flashfiler/sourcelaz/explorer/FFEReportEngine.dpr b/components/flashfiler/sourcelaz/explorer/FFEReportEngine.dpr
new file mode 100644
index 000000000..445263b76
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/FFEReportEngine.dpr
@@ -0,0 +1,54 @@
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * Eivind Bakkestuen
+ * Used with permission.
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+library FFEReportEngine;
+
+{ Important note about DLL memory management: ShareMem must be the
+ first unit in your library's USES clause AND your project's (select
+ Project-View Source) USES clause if your DLL exports any procedures or
+ functions that pass strings as parameters or function results. This
+ applies to all strings passed to and from your DLL--even those that
+ are nested in records and classes. ShareMem is the interface unit to
+ the BORLNDMM.DLL shared memory manager, which must be deployed along
+ with your DLL. To avoid using BORLNDMM.DLL, pass string information
+ using PChar or ShortString parameters. }
+
+uses
+ SysUtils,
+ Classes,
+ FRFFEReportEngine in 'FRFFEReportEngine.pas',
+ fmFRFFEEngine in 'fmFRFFEEngine.pas' {dmFRFFEEngine: TDataModule};
+
+{$R *.res}
+
+exports
+
+ SingleTableReport,
+ SingleQueryReport,
+ DesignReport;
+
+begin
+end.
diff --git a/components/flashfiler/sourcelaz/explorer/FFEReportEngine.res b/components/flashfiler/sourcelaz/explorer/FFEReportEngine.res
new file mode 100644
index 000000000..aae5d65b7
Binary files /dev/null and b/components/flashfiler/sourcelaz/explorer/FFEReportEngine.res differ
diff --git a/components/flashfiler/sourcelaz/explorer/FRFFEReportEngine.pas b/components/flashfiler/sourcelaz/explorer/FRFFEReportEngine.pas
new file mode 100644
index 000000000..6836d2a66
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/FRFFEReportEngine.pas
@@ -0,0 +1,259 @@
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * Eivind Bakkestuen
+ * Used with permission.
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+unit FRFFEReportEngine;
+
+interface
+
+uses
+ ffdb,
+ ffllbase,
+ ffllprot,
+ SysUtils;
+
+type
+ TRangeFieldValues = Array[0..Pred(ffcl_MaxIndexFlds)] of Variant;
+
+
+procedure SingleTableReport(aProtocol : TffProtocolType;
+ aServerName : TffNetAddress;
+ aUserName,
+ aPassword : TffName;
+ aAliasName : PChar;
+ aTableName : TffTableName;
+ aFilter,
+ aIndexName : PChar;
+ aRangeStart,
+ aRangeEnd : TRangeFieldValues);
+{ called from the table browse window (dgTable.pas) to
+ view a table with the selected filter and range }
+
+
+procedure SingleQueryReport(aProtocol : TffProtocolType;
+ aServerName : TffNetAddress;
+ aUserName,
+ aPassword : TffName;
+ aAliasName : PChar;
+ aSQL,
+ aFilter : PChar);
+{ called from the query browse window (dgQuery.pas) to
+ view a query resultset }
+
+
+procedure DesignReport(aProtocol : TffProtocolType;
+ aServerName : TffNetAddress;
+ aUserName,
+ aPassword : TffName;
+ aAliasName : PChar);
+{ called to open a general design view }
+
+
+implementation
+
+Uses
+ classes,
+ variants,
+ ffclbase,
+ FR_DBSet,
+ fmFRFFEEngine;
+
+{ utility functions }
+
+procedure SetupDatabaseConnection(aProtocol : TffProtocolType;
+ aServerName : TffNetAddress;
+ aUserName,
+ aPassword : TffName;
+ aAliasName : PChar);
+var
+ OldPass, OldUser : string;
+begin
+ with dmFRFFEEngine do begin
+ ffLegacyTransport.Protocol := aProtocol;
+ ffLegacyTransport.ServerName := aServername;
+ OldPass := ffclPassword;
+ OldUser := ffclUserName;
+ try
+ if aPassword <> '' then begin
+ ffclPassword := aPassword;
+ ffclUserName := aUserName;
+ end;
+ ffSession.Open;
+ finally
+ ffclPassword := OldPass;
+ ffclUserName := OldUser;
+ end;
+ ffDatabase.AliasName := aAliasName;
+ end;
+end;
+
+procedure SingleTableReport(aProtocol : TffProtocolType;
+ aServerName : TffNetAddress;
+ aUserName,
+ aPassword : TffName;
+ aAliasName : PChar;
+ aTableName : TffTableName;
+ aFilter,
+ aIndexName : PChar;
+ aRangeStart,
+ aRangeEnd : TRangeFieldValues);
+var
+ ffTable : TffTable;
+ i : Integer;
+begin
+ dmFRFFEEngine := TdmFRFFEEngine.Create(NIL);
+ try
+ try
+ SetupDatabaseConnection(aProtocol, aServerName, aUserName, aPassword, aAliasName);
+ ffTable := TffTable.Create(dmFRFFEEngine);
+ with ffTable do begin
+ SessionName := dmFRFFEEngine.ffSession.SessionName;
+ DatabaseName := dmFRFFEEngine.ffDatabase.DatabaseName;
+ TableName := aTableName;
+ Filter := aFilter;
+ if Filter<>'' then
+ Filtered := True;
+ IndexName := aIndexName;
+ Open;
+ if (aRangeStart[0]<>NULL) and
+ (aRangeEnd[0]<>NULL) then begin
+ SetRangeStart;
+ for i := 0 to IndexFieldCount-1 do
+ IndexFields[i].Value := aRangeStart[i];
+ SetRangeEnd;
+ for i := 0 to IndexFieldCount-1 do
+ IndexFields[i].Value := aRangeEnd[i];
+ ApplyRange;
+ end;
+ end;
+ with dmFRFFEEngine.frPrintTable do begin
+ DataSet := ffTable;
+ ShowReport;
+ end;
+
+ except
+ on E:Exception do
+ dmFRFFEEngine.ffEventLog.WriteString(E.Message);
+ end;
+ finally
+ dmFRFFEEngine.Free;
+ end;
+end;
+
+
+procedure SingleQueryReport(aprotocol : TffProtocolType;
+ aServerName : TffNetAddress;
+ aUserName,
+ aPassword : TffName;
+ aAliasName : PChar;
+ aSQL,
+ aFilter : PChar);
+var
+ ffQuery : TffQuery;
+begin
+ dmFRFFEEngine := TdmFRFFEEngine.Create(NIL);
+ try
+ try
+ SetupDatabaseConnection(aProtocol, aServerName, aUserName, aPassword, aAliasName);
+ ffQuery := TffQuery.Create(dmFRFFEEngine);
+ with ffQuery do begin
+ SessionName := dmFRFFEEngine.ffSession.SessionName;
+ DatabaseName := dmFRFFEEngine.ffDatabase.DatabaseName;
+ SQL.Text := aSQL;
+ Filter := aFilter;
+ if Filter<>'' then
+ Filtered := True;
+ Open;
+ end;
+ with dmFRFFEEngine, frPrintTable do begin
+ DataSet := ffQuery;
+ ShowReport;
+ end;
+
+ except
+ on E:Exception do
+ dmFRFFEEngine.ffEventLog.WriteString(E.Message);
+ end;
+ finally
+ dmFRFFEEngine.Free;
+ end;
+end;
+
+
+procedure DesignReport(aProtocol : TffProtocolType;
+ aServerName : TffNetAddress;
+ aUserName,
+ aPassword : TffName;
+ aAliasName : PChar);
+{var
+ i : Integer;
+ Tables : TStringList;
+ ffTable : TffTable;}
+begin
+ dmFRFFEEngine := TdmFRFFEEngine.Create(NIL);
+{ Tables := TStringList.Create;}
+ try
+ try
+ SetupDatabaseConnection(aProtocol, aServerName, aUserName, aPassword, aAliasName);
+(* the code below is problematic since it is not possible
+ to choose indexes etc for runtime-created tables.
+ use dialogforms and TfrffTables/TfrffQueries inside
+ the FastReport designer instead.
+
+ dmFRFFEEngine.ffDatabase.GetTableNames(Tables);
+ for i := 0 to Tables.Count-1 do begin
+ ffTable := TffTable.Create(dmFRFFEEngine);
+ with ffTable do begin
+ try
+ Name := Tables[i];
+ except
+ Name := Tables[i]+IntToStr(Random(1000));
+ end;
+ SessionName := dmFRFFEEngine.ffSession.SessionName;
+ DatabaseName := dmFRFFEEngine.ffDatabase.DatabaseName;
+ TableName := Tables[i];
+ end;
+ with TfrDBDataset.Create(dmFRFFEEngine) do begin
+ try
+ Name := 'frds'+Tables[i];
+ except
+ Name := 'frds'+Tables[i]+IntToStr(Random(1000));
+ end;
+ DataSet := ffTable;
+ end;
+ end;*)
+ dmFRFFEEngine.frReport.DesignReport;
+
+ except
+ on E:Exception do
+ dmFRFFEEngine.ffEventLog.WriteString(E.Message);
+ end;
+ finally
+ dmFRFFEEngine.Free;
+ end;
+end;
+
+
+end.
diff --git a/components/flashfiler/sourcelaz/explorer/TestDll.dpr b/components/flashfiler/sourcelaz/explorer/TestDll.dpr
new file mode 100644
index 000000000..b54a06f58
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/TestDll.dpr
@@ -0,0 +1,40 @@
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * Eivind Bakkestuen
+ * Used with permission.
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+program TestDll;
+
+uses
+ Forms,
+ TestDllUnit in 'TestDllUnit.pas' {Form1},
+ uReportEngineInterface in 'uReportEngineInterface.pas';
+
+{$R *.res}
+
+begin
+ Application.Initialize;
+ Application.CreateForm(TForm1, Form1);
+ Application.Run;
+end.
diff --git a/components/flashfiler/sourcelaz/explorer/TestDllUnit.dfm b/components/flashfiler/sourcelaz/explorer/TestDllUnit.dfm
new file mode 100644
index 000000000..4fd998792
Binary files /dev/null and b/components/flashfiler/sourcelaz/explorer/TestDllUnit.dfm differ
diff --git a/components/flashfiler/sourcelaz/explorer/TestDllUnit.pas b/components/flashfiler/sourcelaz/explorer/TestDllUnit.pas
new file mode 100644
index 000000000..a4ba40262
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/TestDllUnit.pas
@@ -0,0 +1,91 @@
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * Eivind Bakkestuen
+ * Used with permission.
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+unit TestDllUnit;
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
+ Dialogs, StdCtrls, ffllbase, ffdbbase, ffdb;
+
+type
+ TForm1 = class(TForm)
+ Button1: TButton;
+ Button2: TButton;
+ Button3: TButton;
+ procedure Button1Click(Sender: TObject);
+ procedure Button2Click(Sender: TObject);
+ procedure Button3Click(Sender: TObject);
+ private
+ { Private declarations }
+ public
+ { Public declarations }
+ end;
+
+var
+ Form1: TForm1;
+
+implementation
+
+{$R *.dfm}
+
+uses
+ uReportEngineInterface,
+ ffllprot;
+
+procedure TForm1.Button1Click(Sender: TObject);
+var
+ i : Integer;
+ rs,
+ re : TRangeFieldValues;
+begin
+ if ReportEngineDLLLoaded then begin
+ for i := 0 to 15 do
+ rs[i] := NULL;
+ rs[0] := 'F';
+ for i := 0 to 15 do
+ re[i] := NULL;
+ re[0] := 'M'+#255;
+ SingleTableReport(ptTCPIP, '192.168.0.28', '', '', 'aflforwin', 'kunde', '', 'kundnavnIdx', rs, re);
+ end;
+end;
+
+procedure TForm1.Button2Click(Sender: TObject);
+begin
+ if ReportEngineDLLLoaded then begin
+ SingleQueryReport(ptTCPIP, '192.168.0.28', '', '', 'aflforwin', 'select * from sjafor', '');
+ end;
+end;
+
+procedure TForm1.Button3Click(Sender: TObject);
+begin
+ if ReportEngineDLLLoaded then begin
+ DesignReport(ptTCPIP, '192.168.0.28', '', '', 'aflforwin');
+ end;
+end;
+
+end.
diff --git a/components/flashfiler/sourcelaz/explorer/dgParams.dfm b/components/flashfiler/sourcelaz/explorer/dgParams.dfm
new file mode 100644
index 000000000..c6b074db6
Binary files /dev/null and b/components/flashfiler/sourcelaz/explorer/dgParams.dfm differ
diff --git a/components/flashfiler/sourcelaz/explorer/dgParams.pas b/components/flashfiler/sourcelaz/explorer/dgParams.pas
new file mode 100644
index 000000000..a923407b8
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/dgParams.pas
@@ -0,0 +1,324 @@
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * Eivind Bakkestuen
+ * Used with permission.
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+unit dgParams;
+
+interface
+
+{$I FFDEFINE.INC}
+
+uses Windows, SysUtils, Classes, Graphics, Forms, Controls, StdCtrls,
+ Buttons, ExtCtrls, Grids, db
+ {$IFDEF Delphi3}
+ , dbTables
+ {$ENDIF}, ffllgrid;
+
+type
+ TdlgParams = class(TForm)
+ OKBtn: TButton;
+ CancelBtn: TButton;
+ cbParamType: TComboBox;
+ gdParams: TffStringGrid;
+ procedure gdParamsDrawCell(Sender: TObject; ACol, ARow: Integer;
+ Rect: TRect; State: TGridDrawState);
+ procedure FormCreate(Sender: TObject);
+ procedure gdParamsKeyPress(Sender: TObject; var Key: Char);
+ procedure gdParamsGetEditText(Sender: TObject; ACol, ARow: Integer;
+ var Value: String);
+ procedure cbParamTypeChange(Sender: TObject);
+ procedure cbParamTypeExit(Sender: TObject);
+ procedure gdParamsSelectCell(Sender: TObject; ACol, ARow: Integer;
+ var CanSelect: Boolean);
+ private
+ { Private declarations }
+ function GetCellBackgroundColour(aColour: TColor; ACol, ARow: Integer) : TColor;
+ procedure GetStringProc(const S: String);
+ procedure CMDialogKey(var msg: TCMDialogKey); message CM_DIALOGKEY;
+ procedure ShowCellCombo(ComboBox: TCustomComboBox; Grid: TCustomGrid;
+ Rect: TRect; aColour : TColor);
+ public
+ { Public declarations }
+ function GetParamValues(aParams: TParams) : Boolean;
+ { reads values from the stringgrid }
+ function EditParamValues(aParams: TParams): Boolean;
+ { opens dialog to edit and return values from the stringgrid }
+ end;
+
+
+implementation
+
+{$R *.dfm}
+
+uses
+{$IFDEF DCC6OrLater}
+ Variants,
+{$ENDIF}
+ Messages,
+ TypInfo;
+
+
+const
+ colParamName = 0;
+ colParamValue = 1;
+ colParamType = 2;
+
+
+{ create "hack" classes we can use to
+ use the normally protected properties }
+type
+ THackGrid = class(TStringGrid)
+ public
+ property InplaceEditor;
+ end;
+
+ THackEdit = class(TInplaceEdit)
+ public
+ property Color;
+ end;
+
+
+const
+ sBlankNotSupported = 'Blank parameters not supported for non-string types';
+
+
+{ TdlgParams }
+
+function TdlgParams.GetParamValues(aParams: TParams): Boolean;
+var
+ RowIdx : Integer;
+begin
+ Result := True;
+ { copy values to Params }
+ for RowIdx := 1 to Pred(gdParams.RowCount) do begin
+ if (gdParams.Cells[colParamValue, RowIdx]<>'') or
+ (TFieldType(GetEnumValue(TypeInfo(TFieldType), gdParams.Cells[colParamType, RowIdx]))=ftString) then begin
+ aParams[RowIdx-1].DataType := TFieldType(GetEnumValue(TypeInfo(TFieldType), gdParams.Cells[colParamType, RowIdx]));
+ aParams[RowIdx-1].Value := gdParams.Cells[colParamValue, RowIdx];
+ end
+ else
+ raise Exception.Create(sBlankNotSupported);
+ end;
+end;
+
+
+function TdlgParams.EditParamValues(aParams: TParams): Boolean;
+var
+ RowIdx,
+ ParIdx : Integer;
+begin
+ { extract values previously entered }
+ { for each row in grid }
+ for RowIdx := 1 to Pred(gdParams.RowCount) do
+ { check if param exists in new params list }
+ for ParIdx := 0 to Pred(aParams.Count) do
+ if (aParams[ParIdx].Name=gdParams.Cells[colParamName, RowIdx]) and
+ (gdParams.Cells[colParamValue, RowIdx]<>'') then begin
+ { and copy value and type if so }
+ aParams[ParIdx].DataType := TFieldType(GetEnumValue(TypeInfo(TFieldType), gdParams.Cells[colParamType, RowIdx]));
+ aParams[ParIdx].Value := gdParams.Cells[colParamValue, RowIdx];
+ Break;
+ end;
+
+ { fill grid with new contents }
+ gdParams.RowCount := aParams.Count+1;
+ for RowIdx := 1 to Pred(gdParams.RowCount) do begin
+ gdParams.Cells[colParamName, RowIdx] := aParams[RowIdx-1].Name;
+ gdParams.Cells[colParamValue, RowIdx] := aParams[RowIdx-1].Value;
+ gdParams.Cells[colParamType, RowIdx] := GetEnumName(TypeInfo(TFieldType), Integer(aParams[RowIdx-1].DataType));
+ end;
+ Result := ShowModal=mrOK;
+ { copy new values to Params? }
+ if Result then
+ GetParamValues(aParams);
+end;
+
+
+function TdlgParams.GetCellBackgroundColour(aColour: TColor; ACol, ARow: Integer) : TColor;
+Const
+ BlueIdx = 0;
+var
+ ColourBytes : Array[0..3] of byte absolute Result;
+begin
+ Result := aColour;
+ if ((ARow Mod 2) = 1) and (ACol>0) then begin
+ Result := ColorToRGB(aColour);
+ if ColourBytes[BlueIdx]>127 then
+ ColourBytes[BlueIdx] := ColourBytes[BlueIdx]-16
+ else
+ ColourBytes[BlueIdx] := ColourBytes[BlueIdx]+16;
+ end;
+end;
+
+
+procedure TdlgParams.gdParamsDrawCell(Sender: TObject; ACol, ARow: Integer;
+ Rect: TRect; State: TGridDrawState);
+begin
+ with Sender as TStringGrid do
+ begin
+ { change backgroundcolour slightly on every other row }
+ Canvas.Brush.Color := GetCellBackgroundColour(Canvas.Brush.Color, ACol, ARow);
+ case ARow of
+ 1..MaxInt : case ACol of
+ colParamValue,
+ colParamType : Begin
+ Canvas.Font.Color := Font.Color;
+ Canvas.FillRect(Rect);
+ Canvas.TextRect(Rect, Rect.Left+2, Rect.Top+2, Cells[ACol, ARow]);
+ End;
+ end;
+ end;
+ if gdFocused in State then
+ Canvas.DrawFocusRect(Rect);
+ end;
+end;
+
+
+procedure TdlgParams.GetStringProc(Const S : String);
+begin
+ cbParamType.Items.Add(S);
+end;
+
+
+procedure TdlgParams.FormCreate(Sender: TObject);
+var
+ I: Integer;
+begin
+ gdParams.DefaultRowHeight := cbParamType.Height;
+ gdParams.Cells[colParamName, 0] := 'Parameter:';
+ gdParams.Cells[colParamValue, 0] := 'Value:';
+ gdParams.Cells[colParamType, 0] := 'Type:';
+
+ cbParamType.Clear;
+ with GetTypeData(TypeInfo(TFieldType))^ do
+ begin
+ for I := MinValue to MaxValue do
+ GetStringProc(GetEnumName(TypeInfo(TFieldType), I));
+ end;
+end;
+
+
+procedure TdlgParams.gdParamsKeyPress(Sender: TObject; var Key: Char);
+begin
+ if Key=#13 then begin
+ if (Succ(gdParams.Col)=gdParams.ColCount) and
+ (Succ(gdParams.Row)=gdParams.RowCount) then
+ ModalResult := mrOK
+ else
+ if (Succ(gdParams.Col)=gdParams.ColCount) then begin
+ gdParams.Col := colParamValue;
+ gdParams.Row := gdParams.Row + 1;
+ end
+ else
+ gdParams.Col := gdParams.Col + 1;
+ end
+ else
+ if Key=#27 then
+ ModalResult := mrCancel;
+end;
+
+
+procedure TdlgParams.gdParamsGetEditText(Sender: TObject; ACol,
+ ARow: Integer; var Value: String);
+begin
+ Assert(Sender is TStringGrid);
+ with THackGrid(Sender) do
+ THackEdit(InplaceEditor).Color := GetCellBackgroundColour(Color, ACol, ARow);
+end;
+
+
+procedure TdlgParams.cbParamTypeChange(Sender: TObject);
+begin
+ with gdParams do begin
+ Cells[Col, Row] := cbParamType.Items[cbParamType.ItemIndex];
+ end;
+ gdParams.Invalidate;
+end;
+
+
+procedure TdlgParams.cbParamTypeExit(Sender: TObject);
+begin
+ cbParamType.Visible := False;
+ if Assigned(ActiveControl) and not(ActiveControl = gdParams) then
+ ActiveControl.SetFocus
+ else begin
+ gdParams.SetFocus;
+ gdParams.Perform(WM_KEYDOWN, VK_TAB, 0);
+ end;
+end;
+
+
+procedure TdlgParams.gdParamsSelectCell(Sender: TObject; ACol,
+ ARow: Integer; var CanSelect: Boolean);
+var
+ R : TRect;
+begin
+ case ACol of
+ colParamType :
+ begin
+ R := gdParams.CellRect(ACol, ARow);
+ ShowCellCombo(cbParamType, gdParams, R, GetCellBackgroundColour(gdParams.Canvas.Brush.Color, ACol, ARow));
+ cbParamType.ItemIndex :=
+ cbParamType.Items.IndexOf(gdParams.Cells[ACol, ARow]);
+ end;
+ end;
+end;
+
+
+procedure TdlgParams.CMDialogKey(var msg: TCMDialogKey);
+begin
+ if (ActiveControl = cbParamType) then
+ begin
+ if (msg.CharCode = VK_TAB) then
+ begin
+ ActiveControl.Visible := False;
+ msg.result := 1;
+ Exit;
+ end;
+ end;
+ inherited;
+end;
+
+
+procedure TdlgParams.ShowCellCombo(ComboBox: TCustomComboBox;
+ Grid: TCustomGrid; Rect: TRect; aColour : TColor);
+begin
+ Rect.Left := Rect.Left + Grid.Left;
+ Rect.Right := Rect.Right + Grid.Left;
+ Rect.Top := Rect.Top + Grid.Top;
+ Rect.Bottom := Rect.Bottom + Grid.Top;
+ ComboBox.Left := Rect.Left + 1;
+ ComboBox.Top := Rect.Top + 1;
+ ComboBox.Width := (Rect.Right + 1) - Rect.Left;
+ ComboBox.Height := (Rect.Bottom + 1) - Rect.Top;
+
+ {Display the combobox}
+ ComboBox.Visible := True;
+ TComboBox(ComboBox).Color := aColour;
+ ComboBox.SetFocus;
+end;
+
+
+end.
diff --git a/components/flashfiler/sourcelaz/explorer/dgServSt.dfm b/components/flashfiler/sourcelaz/explorer/dgServSt.dfm
new file mode 100644
index 000000000..855288fa7
Binary files /dev/null and b/components/flashfiler/sourcelaz/explorer/dgServSt.dfm differ
diff --git a/components/flashfiler/sourcelaz/explorer/dgServSt.pas b/components/flashfiler/sourcelaz/explorer/dgServSt.pas
new file mode 100644
index 000000000..043b73cb6
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/dgServSt.pas
@@ -0,0 +1,431 @@
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * Eivind Bakkestuen
+ * Used with permission.
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+unit dgServSt;
+
+interface
+
+uses
+ Windows,
+ SysUtils,
+ Classes,
+ Graphics,
+ Forms,
+ Controls,
+ StdCtrls,
+ Buttons,
+ ExtCtrls,
+ Messages,
+ uConsts,
+ ffdb,
+ ffllbase,
+ ffllprot,
+ fflllgcy,
+ fflllog,
+ ffclreng,
+ ComCtrls,
+ {$IFDEF DCC4OrLater}
+ ImgList,
+ {$ENDIF}
+ ffsrbde;
+
+type
+ TdlgServerStats = class(TForm)
+ OKBtn: TButton;
+ cbAutoupdate: TCheckBox;
+ Label1: TLabel;
+ Label3: TLabel;
+ laServerVersion: TLabel;
+ Bevel1: TBevel;
+ btnRefresh: TButton;
+ tiAutoupdate: TTimer;
+ lvServers: TListView;
+ Label2: TLabel;
+ lvTransports: TListView;
+ ilIcons: TImageList;
+ Label4: TLabel;
+ edFrequency: TEdit;
+ procedure FormShow(Sender: TObject);
+ procedure FormDestroy(Sender: TObject);
+ procedure FormClose(Sender: TObject; var Action: TCloseAction);
+ procedure OKBtnClick(Sender: TObject);
+ procedure cbAutoupdateClick(Sender: TObject);
+ procedure tiAutoupdateTimer(Sender: TObject);
+ procedure btnRefreshClick(Sender: TObject);
+ procedure FormKeyDown(Sender: TObject; var Key: Word;
+ Shift: TShiftState);
+ procedure edFrequencyChange(Sender: TObject);
+ private
+ { Private declarations }
+ FLog : TffBaseLog;
+ FClient : TffClient;
+ FEngine : TffRemoteServerEngine;
+ FProtocol : TffProtocolType;
+ FServerName : TffNetAddress;
+ FSession : TFfSession;
+ FUserName : TffName;
+ FPassword : TffName;
+ FTransport : TffLegacyTransport;
+ dtShown : Boolean;
+ procedure SavePreferences;
+ procedure LoadPreferences;
+ procedure UpdateStats;
+ function ElapsedTimeToStr(T: TDateTime): string;
+ procedure OpenSession;
+ public
+ { Public declarations }
+ procedure CloseDuringShow(var Message : TMessage); message ffm_Close;
+ property Protocol : TffProtocolType
+ read FProtocol write FProtocol;
+
+ property ServerName : TffNetAddress
+ read FServerName write FServerName;
+
+ property Password : TffName
+ read FPassword write FPassword;
+
+ property UserName : TffName
+ read FUserName write FUserName;
+
+ property Log : TffBaseLog
+ read FLog write FLog;
+ end;
+
+
+implementation
+
+{$R *.dfm}
+
+uses
+ Dialogs,
+ uConfig,
+ ffclbase,
+ ffllcomm;
+
+
+procedure TdlgServerStats.OpenSession;
+var
+ OldPass, OldUser : string;
+begin
+ OldPass := ffclPassword;
+ OldUser := ffclUserName;
+ try
+ if FPassword <> '' then begin
+ ffclPassword := FPassword;
+ ffclUserName := FUserName;
+ end;
+ FSession.Open;
+ finally
+ ffclPassword := OldPass;
+ ffclUserName := OldUser;
+ end;
+end;
+
+procedure TdlgServerStats.FormShow(Sender: TObject);
+begin
+ dtShown := False;
+ try
+ { Set up the connection. }
+ FTransport := TffLegacyTransport.Create(nil);
+ with FTransport do begin
+ Mode := fftmSend;
+ Protocol := FProtocol;
+ EventLog := FLog;
+ if Assigned(FLog) then begin
+ EventLogEnabled := True;
+ EventLogOptions := [fftpLogErrors];
+ end;
+ ServerName := FServerName;
+ end;
+
+ FEngine := TffRemoteServerEngine.Create(nil);
+ FEngine.Transport := FTransport;
+
+ FClient := TffClient.Create(nil);
+ FClient.ServerEngine := FEngine;
+ FClient.AutoClientName := True;
+
+ FSession := TffSession.Create(nil);
+ FSession.ClientName := FClient.ClientName;
+ FSession.AutoSessionName := True;
+ OpenSession;
+
+ Caption := ServerName;
+ LoadPreferences;
+ UpdateStats;
+ dtShown := True;
+
+ except
+ on E:Exception do begin
+ showMessage(E.message);
+ PostMessage(Handle, ffm_Close, 0, longInt(Sender));
+ end;
+ end;
+end;
+
+
+procedure TdlgServerStats.FormDestroy(Sender: TObject);
+begin
+ try
+ FSession.Active := False;
+ finally
+ FSession.Free;
+ end;
+
+ try
+ FClient.Close;
+ finally
+ FClient.Free;
+ end;
+
+ try
+ FEngine.Shutdown;
+ finally
+ FEngine.Free;
+ end;
+
+ try
+ FTransport.Shutdown;
+ finally
+ FTransport.Free;
+ end;
+end;
+
+
+procedure TdlgServerStats.FormClose(Sender: TObject;
+ var Action: TCloseAction);
+begin
+ if dtShown then
+ SavePreferences;
+ Action := caFree;
+end;
+
+
+procedure TdlgServerStats.LoadPreferences;
+var
+ BaseSection : string;
+begin
+ BaseSection := ClassName + '.' + Self.Caption;
+ FFEConfigGetFormPrefs(BaseSection, Self);
+ cbAutoupdate.Checked := FFEConfigGetBoolean(BaseSection, 'Autoupdate', False); {!!.07}
+ tiAutoupdate.Enabled := cbAutoupdate.Checked;
+ edFrequency.Text := FFEConfigGetString(BaseSection, 'TimerFreq', '1000');
+ edFrequencyChange(Self);
+end;
+
+procedure TdlgServerStats.SavePreferences;
+var
+ BaseSection : string;
+begin
+ try
+ BaseSection := ClassName + '.' + Self.Caption;
+ FFEConfigSaveFormPrefs(BaseSection, Self);
+ FFEConfigSaveBoolean(BaseSection, 'Autoupdate', cbAutoupdate.Checked);
+ FFEConfigSaveString(BaseSection, 'TimerFreq', edFrequency.Text);
+ except
+ on E:Exception do
+ ShowMessage('Error writing INI file: '+E.Message);
+ end;
+end;
+
+
+procedure TdlgServerStats.CloseDuringShow(var Message: TMessage);
+begin
+ Close;
+end;
+
+
+procedure TdlgServerStats.OKBtnClick(Sender: TObject);
+begin
+ Close;
+end;
+
+
+function TdlgServerStats.ElapsedTimeToStr(T : TDateTime) : string;
+var
+ Dy : integer;
+ Hr : integer;
+ Mi : integer;
+ Se : integer;
+begin
+ Dy := trunc(T);
+ T := frac(T) * 24.0;
+ Hr := trunc(T);
+ T := frac(T) * 60.0;
+ Mi := trunc(T);
+ Se := trunc(frac(T) * 60.0);
+ Result := Format('%d%s%.2d%s%.2d%s%.2d',
+ [
+ Dy,
+ TimeSeparator,
+ Hr,
+ TimeSeparator,
+ Mi,
+ TimeSeparator,
+ Se
+ ]);
+end;
+
+
+procedure TdlgServerStats.UpdateStats;
+var
+ aServerStats: TffServerStatistics;
+ aCmdHandlerStats: TffCommandHandlerStatistics;
+ aTransportStats: TffTransportStatistics;
+ TransportCount,
+ CmdHandlerIdx,
+ TransportIdx,
+ ItemIdx : Integer;
+ ServerUp : Boolean;
+begin
+ ServerUp := FSession.GetServerStatistics(aServerStats)=DBIERR_NONE;
+ laServerVersion.Caption := Format('%5.4f', [aServerStats.ssVersion / 10000.0]);
+ lvServers.Items.BeginUpdate;
+ lvTransports.Items.BeginUpdate;
+ try
+ if lvServers.Items.Count=0 then begin
+ lvServers.Items.Add;
+ lvServers.Items[0].ImageIndex := 0;
+ for ItemIdx := 0 to 8 do
+ lvServers.Items[0].SubItems.Add('');
+ end;
+
+ { update server }
+ with lvServers.Items[0], aServerStats do begin
+ Caption := aServerStats.ssName;
+ SubItems[0] := ssState;
+ SubItems[1] := FFCommaizeChL(ssClientCount, ThousandSeparator);
+ SubItems[2] := FFCommaizeChL(ssSessionCount, ThousandSeparator);
+ SubItems[3] := FFCommaizeChL(ssOpenDatabasesCount, ThousandSeparator);
+ SubItems[4] := FFCommaizeChL(ssOpenTablesCount, ThousandSeparator);
+ SubItems[5] := FFCommaizeChL(ssOpenCursorsCount, ThousandSeparator);
+ SubItems[6] := FFCommaizeChL(ssRAMUsed, ThousandSeparator);
+ SubItems[7] := FFCommaizeChL(ssMaxRAM, ThousandSeparator);
+ SubItems[8] := ElapsedTimeToStr(ssUptimeSecs / (3600*24));
+ end;
+ { get transportcount }
+ TransportCount := 0;
+ for CmdHandlerIdx := 0 to Pred(aServerStats.ssCmdHandlerCount) do begin
+ FSession.GetCommandHandlerStatistics(CmdHandlerIdx, aCmdHandlerStats);
+ TransportCount := TransportCount+aCmdHandlerStats.csTransportCount;
+ end;
+ { adjust transportlistview if necessary }
+ if TransportCount>lvTransports.Items.Count then begin
+ for TransportIdx := lvTransports.Items.Count+1 to TransportCount do begin
+ lvTransports.Items.Add;
+ lvTransports.Items[lvTransports.Items.Count-1].ImageIndex := 1;
+ for ItemIdx := 0 to 5 do
+ lvTransports.Items[TransportIdx-1].SubItems.Add('');
+ end;
+ end
+ else
+ if TransportCount mrYes then Abort;
+
+ { If directory is not valid, then ask "do you want to create?" }
+ if not DirectoryExists(edtPath.Text) then
+ if MessageDlg('Directory ' + edtPath.Text + ' does not exist, ' +
+ 'do you want to create this directory?', mtConfirmation,
+ [mbYes, mbNo], 0) = mrYes then
+ ForceDirectories(edtPath.Text)
+ else
+ Exit;
+
+ { Go get all the aliases for this server. Need a fresh list in case any
+ were added by other users recently }
+ ExistingAliases := TStringList.Create;
+ try
+ FServer.GetAliases(ExistingAliases);
+ if ExistingAliases.IndexOf(edtAlias.Text) <> -1 then
+ raise Exception.CreateFmt('The alias "%s" is already defined for this server.', [edtAlias.Text]);
+ finally
+ ExistingAliases.Free;
+ end;
+
+ { Physically add the alias to the server }
+ FServer.AddAlias(edtAlias.Text, edtPath.Text, cbCheckSpace.Checked); {!!.11}
+
+ { Now add an entry to our internal list o' databases }
+ FDatabase := FServer.AddDatabase(edtAlias.Text);
+
+ ModalResult := mrOK;
+end;
+
+procedure TdlgAddAlias.lstFoldersChange(Sender: TObject);
+begin
+ edtPath.Text := lstFolders.Directory;
+end;
+
+end.
diff --git a/components/flashfiler/sourcelaz/explorer/dgautoin.dfm b/components/flashfiler/sourcelaz/explorer/dgautoin.dfm
new file mode 100644
index 000000000..6c12127be
Binary files /dev/null and b/components/flashfiler/sourcelaz/explorer/dgautoin.dfm differ
diff --git a/components/flashfiler/sourcelaz/explorer/dgautoin.pas b/components/flashfiler/sourcelaz/explorer/dgautoin.pas
new file mode 100644
index 000000000..dcf8a90c5
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/dgautoin.pas
@@ -0,0 +1,117 @@
+{*********************************************************}
+{* Dialog to rename a database/table *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit dgautoin;
+
+interface
+
+uses
+ Windows,
+ Messages,
+ SysUtils,
+ Classes,
+ Graphics,
+ Controls,
+ Forms,
+ Dialogs,
+ StdCtrls,
+ Buttons,
+ ExtCtrls,
+ Mask,
+ ffllbase;
+
+type
+ TdlgAutoInc = class(TForm)
+ btnOK: TBitBtn;
+ btnCancel: TBitBtn;
+ edtSeed: TEdit;
+ lblSeed: TLabel;
+ procedure FormShow(Sender: TObject);
+ procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
+ private
+ protected
+ FTableName : string;
+ FNewSeed : TffWord32; {!!.10}
+ public
+ property NewSeed : TffWord32 read FNewSeed write FNewSeed; {!!.10}
+
+ property TableName : string read FTableName write FTableName;
+
+ end;
+
+function ShowAutoIncDlg(const aTableName : string;
+ var aNewSeed: TffWord32): TModalResult; {!!.10}
+
+
+var
+ dlgAutoInc: TdlgAutoInc;
+
+implementation
+
+{$R *.DFM}
+
+function ShowAutoIncDlg(const aTableName : string;
+ var aNewSeed: TffWord32): TModalResult; {!!.10}
+begin
+ with TdlgAutoInc.Create(nil) do
+ try
+ FTableName := aTableName;
+ NewSeed := aNewSeed;
+ Result := ShowModal;
+ if Result = mrOK then
+ aNewSeed := NewSeed;
+ finally
+ Free;
+ end;
+end;
+
+procedure TdlgAutoInc.FormShow(Sender: TObject);
+begin
+ Caption := Format(Caption, [FTableName]);
+ edtSeed.Text := intToStr(FNewSeed);
+end;
+
+procedure TdlgAutoInc.FormCloseQuery(Sender: TObject;
+ var CanClose: Boolean);
+var
+ Value : TffWord32; {!!.10}
+ Code : Integer;
+begin
+ Val(edtSeed.Text, Value, Code);
+ NewSeed := Value;
+ CanClose := (Code = 0) or (ModalResult <> mrOK);
+ if not CanClose then begin
+ MessageBeep(0);
+ MessageDlg('A valid seed must be entered.', mtWarning, [mbOK], 0);
+ end;
+end;
+
+end.
diff --git a/components/flashfiler/sourcelaz/explorer/dgimpdef.dfm b/components/flashfiler/sourcelaz/explorer/dgimpdef.dfm
new file mode 100644
index 000000000..f6e449a19
Binary files /dev/null and b/components/flashfiler/sourcelaz/explorer/dgimpdef.dfm differ
diff --git a/components/flashfiler/sourcelaz/explorer/dgimpdef.pas b/components/flashfiler/sourcelaz/explorer/dgimpdef.pas
new file mode 100644
index 000000000..0ff34e9ac
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/dgimpdef.pas
@@ -0,0 +1,144 @@
+{*********************************************************}
+{* Dialog to import structure from another table *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit dgimpdef;
+
+interface
+
+uses
+ Windows,
+ Messages,
+ SysUtils,
+ Classes,
+ Graphics,
+ Controls,
+ Forms,
+ Dialogs,
+ StdCtrls,
+ Buttons,
+ ubase,
+ uentity;
+
+type
+ TdlgImportDefinition = class(TForm)
+ lstTables: TListBox;
+ lblImport: TLabel;
+ btnOK: TBitBtn;
+ btnCancel: TBitBtn;
+ Label1: TLabel;
+ cbDatabases: TComboBox;
+ procedure btnOKClick(Sender: TObject);
+ procedure lstTablesDblClick(Sender: TObject);
+ procedure cbDatabasesChange(Sender: TObject);
+ private
+ public
+ TableInDatabase,
+ CurrentDatabase : TffeDatabaseItem;
+ ExcludeTableIndex,
+ FTableIndex: LongInt;
+ end;
+
+var
+ dlgImportDefinition: TdlgImportDefinition;
+
+function ShowImportTableDefDlg(aDatabase : TffeDatabaseItem;
+ aExcludeTableIndex: LongInt;
+ var aImportFromDatabase: TffeDatabaseItem;
+ var aTableIndex: LongInt): TModalResult;
+
+implementation
+
+{$R *.DFM}
+
+function ShowImportTableDefDlg(aDatabase : TffeDatabaseItem;
+ aExcludeTableIndex: LongInt;
+ var aImportFromDatabase: TffeDatabaseItem;
+ var aTableIndex: LongInt): TModalResult;
+var
+ CurrentIdx,
+ i: Integer;
+begin
+ with TdlgImportDefinition.Create(nil) do
+ try
+ TableInDatabase := aDatabase;
+ CurrentDatabase := aDatabase;
+ ExcludeTableIndex := aExcludeTableIndex;
+ { load databaselist }
+ CurrentIdx := -1;
+ cbDatabases.Clear;
+ for i := 0 to CurrentDatabase.Server.DatabaseCount-1 do begin
+ cbDatabases.Items.AddObject(CurrentDatabase.Server.Databases[i].DatabaseName,
+ CurrentDatabase.Server.Databases[i]);
+ if CurrentDatabase.Server.Databases[i]=CurrentDatabase then
+ CurrentIdx := i;
+ end;
+ cbDatabases.ItemIndex := CurrentIdx;
+ cbDatabasesChange(NIL);
+ Result := ShowModal;
+ aTableIndex := -1;
+ if Result = mrOK then begin
+ aTableIndex := FTableIndex;
+ aImportFromDatabase := CurrentDatabase;
+ end;
+ finally
+ Free;
+ end;
+end;
+
+procedure TdlgImportDefinition.lstTablesDblClick(Sender: TObject);
+begin
+ btnOk.Click;
+end;
+
+procedure TdlgImportDefinition.btnOKClick(Sender: TObject);
+begin
+ with lstTables do
+ FTableIndex := LongInt(Items.Objects[ItemIndex]);
+end;
+
+procedure TdlgImportDefinition.cbDatabasesChange(Sender: TObject);
+var
+ T: LongInt;
+begin
+ lstTables.Clear;
+ CurrentDatabase := TffeDatabaseItem(cbDatabases.Items.Objects[cbDatabases.ItemIndex]);
+ { make sure tablelist exists }
+ if CurrentDatabase.TableCount=0 then
+ CurrentDatabase.LoadTables;
+ for T := 0 to pred(CurrentDatabase.TableCount) do
+ with CurrentDatabase.Tables[T] do
+ if (CurrentDatabase<>TableInDatabase) or (T <> ExcludeTableIndex) then
+ lstTables.Items.AddObject(TableName, Pointer(T));
+ if lstTables.Items.Count>0 then
+ lstTables.ItemIndex := 0;
+end;
+
+end.
diff --git a/components/flashfiler/sourcelaz/explorer/dgimpdo.dfm b/components/flashfiler/sourcelaz/explorer/dgimpdo.dfm
new file mode 100644
index 000000000..3a1872245
Binary files /dev/null and b/components/flashfiler/sourcelaz/explorer/dgimpdo.dfm differ
diff --git a/components/flashfiler/sourcelaz/explorer/dgimpdo.pas b/components/flashfiler/sourcelaz/explorer/dgimpdo.pas
new file mode 100644
index 000000000..74c2e02c3
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/dgimpdo.pas
@@ -0,0 +1,151 @@
+{*********************************************************}
+{* Progress meter for import operations *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit dgimpdo;
+
+interface
+
+uses
+ Windows,
+ Messages,
+ SysUtils,
+ Classes,
+ Graphics,
+ Controls,
+ Forms,
+ Dialogs,
+ ComCtrls,
+ StdCtrls,
+ Buttons,
+ ExtCtrls,
+ ffclimex,
+ ffllbase,
+ uentity;
+
+type
+ TdlgImportProgress = class(TForm)
+ lblProgress: TLabel;
+ btnCancel: TBitBtn;
+ lblFrom: TLabel;
+ lblTo: TLabel;
+ edtImportFilename: TEdit;
+ edtTablename: TEdit;
+ mtrProgress: TProgressBar;
+ procedure btnCancelClick(Sender: TObject);
+ private
+ public
+ FEngine: TffImportEngine;
+ procedure ShowProgress(aImportFilename, aTableName: string);
+ procedure UpdateProgress(aProgress: TffieProgressPacket);
+ end;
+
+function DoImport(aIE: TffImportEngine;
+ aImportFilename: TFilename;
+ aTableName: TffTableName;
+ aTable: TffexpTable;
+ aBlockInserts: SmallInt): Boolean;
+
+var
+ dlgImportProgress: TdlgImportProgress;
+
+implementation
+
+{$R *.DFM}
+
+function DoImport(aIE: TffImportEngine;
+ aImportFilename: TFilename;
+ aTableName: TffTableName;
+ aTable: TffexpTable;
+ aBlockInserts: SmallInt): Boolean;
+begin
+ with TdlgImportProgress.Create(nil) do
+ try {start !!.01}
+ FEngine := aIE;
+ ShowProgress(aImportFilename, aTableName);
+ try
+ FEngine.OnYield := UpdateProgress;
+ FEngine.Import(aTable, aBlockInserts);
+ finally
+ Hide;
+ end;
+ Application.ProcessMessages;
+ Result := not FEngine.Terminated;
+ finally
+ Free;
+ end; {end !!.01}
+end;
+
+procedure TdlgImportProgress.ShowProgress(aImportFilename, aTableName: string);
+begin
+ edtImportFilename.Text := aImportFilename;
+ edtTablename.Text := aTableName;
+ lblProgress.Hide;
+ mtrProgress.Position := 0;
+ inherited Show;
+ Application.ProcessMessages;
+end;
+
+procedure TdlgImportProgress.UpdateProgress(aProgress: TffieProgressPacket);
+var
+ Dividend: LongInt;
+ Divisor: LongInt;
+begin
+ with aProgress do begin
+ with lblProgress do begin
+ Caption := Format('Processing record %d of %d', [ppNumRecs, ppTotalRecs]);
+ Show;
+ end;
+
+ { Calculate % completed }
+ if (ppNumRecs >= $1000000) then begin
+ Dividend := (ppNumRecs shr 7) * 100;
+ Divisor := ppTotalRecs shr 7;
+ end
+ else begin
+ Dividend := ppNumRecs * 100;
+ Divisor := ppTotalRecs;
+ end;
+
+ if Divisor <> 0 then
+ mtrProgress.Position := Dividend div Divisor;
+
+ if IsIconic(Application.Handle) then
+ Application.Title := Format('Importing %d%% complete', [mtrProgress.Position]);
+ end;
+end;
+
+procedure TdlgImportProgress.btnCancelClick(Sender: TObject);
+begin
+ if MessageDlg('Abort importing data?', mtConfirmation, [mbYes, mbNo], 0) = mrYes then
+ FEngine.Terminate;
+end;
+
+end.
diff --git a/components/flashfiler/sourcelaz/explorer/dgimport.dfm b/components/flashfiler/sourcelaz/explorer/dgimport.dfm
new file mode 100644
index 000000000..bdc0b6923
Binary files /dev/null and b/components/flashfiler/sourcelaz/explorer/dgimport.dfm differ
diff --git a/components/flashfiler/sourcelaz/explorer/dgimport.pas b/components/flashfiler/sourcelaz/explorer/dgimport.pas
new file mode 100644
index 000000000..f77183c06
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/dgimport.pas
@@ -0,0 +1,377 @@
+{*********************************************************}
+{* Dialog to import external data files *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit dgimport;
+
+interface
+
+uses
+ Windows,
+ Messages,
+ SysUtils,
+ Classes,
+ Graphics,
+ Controls,
+ Forms,
+ Dialogs,
+ ComCtrls,
+ ExtCtrls,
+ StdCtrls,
+ FileCtrl,
+ Buttons,
+ uentity,
+ ffclimex,
+ ffllbase,
+ fflldict,
+ ubase,
+ uconsts,
+ dgimpdo;
+
+type
+ TdlgImport = class(TForm)
+ btnImport: TBitBtn;
+ btnCancel: TBitBtn;
+ grpImportFile: TGroupBox;
+ lblFilename: TLabel;
+ lblDir: TLabel;
+ lblDirectory: TLabel;
+ lblFileFilter: TLabel;
+ lblDrives: TLabel;
+ edtImportFilename: TEdit;
+ lstFiles: TFileListBox;
+ lstDirectories: TDirectoryListBox;
+ cboFilter: TFilterComboBox;
+ cboDrives: TDriveComboBox;
+ grpTable: TGroupBox;
+ cboTableName: TComboBox;
+ lblTblName: TLabel;
+ grpExistingData: TRadioGroup;
+ lblRecsPerTran: TLabel;
+ edtBlockInserts: TEdit;
+ UpDown1: TUpDown;
+ procedure btnImportClick(Sender: TObject);
+ procedure edtImportFilenameKeyPress(Sender: TObject; var Key: Char);
+ procedure btnCancelClick(Sender: TObject);
+ procedure lstFilesClick(Sender: TObject);
+ procedure FormCreate(Sender: TObject);
+ procedure FormShow(Sender: TObject);
+ private
+ FDatabase : TffeDatabaseItem;
+ FTableIndex: LongInt;
+ FImportEngine: TffImportEngine;
+ FNewTable: Boolean;
+ FImportFilename: TFilename;
+ FTableName: TffTableName;
+ FBlockInserts: Integer;
+ FSchemaOnly: Boolean;
+ public
+ end;
+
+function ShowImportDlg(aDatabase : TffeDatabaseItem;
+ var aTableIndex: LongInt): TModalResult;
+{ Shows the "Import Data" dialog, allowing the user to import data from
+ an external file into a database table, or create a new table from the
+ import file structure.
+
+ Input parameters:
+ aServer : The server associated with the import.
+ aDatabaseIndex: Within aServer's list of databases, the index of the
+ database that will contain the table being imported.
+ aTableIndex: Within aDatabase's list of tables, the index of the table
+ into which data is being imported.
+ Set this parameter to -1 if no table has been selected.
+
+ Output parameters:
+ aTableIndex: -1 if the table imported into already existed; otherwise
+ the index for the newly created table within the server's
+ database list.
+}
+var
+ dlgImport: TdlgImport;
+
+implementation
+
+uses
+ fmmain;
+
+
+{$R *.DFM}
+
+function ShowImportDlg(aDatabase : TffeDatabaseItem;
+ var aTableIndex: LongInt): TModalResult;
+var
+ I: Integer;
+begin
+ with TdlgImport.Create(nil) do
+ try
+ FDatabase := aDatabase;
+ FTableIndex := aTableIndex;
+ if FTableIndex = -1 then
+ cboTableName.ItemIndex := -1;
+
+ with cboTableName do begin
+
+ { Fill the dropdown list with table names; keep TableIndexes in
+ the stringlist's Objects property }
+ Items.Clear;
+ for I := 0 to pred(FDatabase.TableCount) do
+ with FDatabase.Tables[I] do
+ Items.AddObject(TableName, Pointer(I));
+
+ { Set the ItemIndex for the table we've selected before entering.
+ ComboBox list is sorted, so capturing the index during the loop
+ above may not be entirely accurate. }
+ if FTableIndex <> -1 then
+ with FDatabase.Tables[FTableIndex] do
+ for I := 0 to pred(FDatabase.TableCount) do
+ if FFCmpShStrUC(Items[I], TableName, 255) = 0 then begin
+ ItemIndex := I;
+ Break;
+ end;
+ end;
+
+ Result := ShowModal;
+
+ aTableIndex := -1;
+ if Result = mrOK then begin
+ if not FSchemaOnly then
+ try
+ frmMain.EnableScreen(False);
+ try
+ if DoImport(FImportEngine,
+ FImportFilename,
+ FTableName,
+ FDatabase.Tables[FTableIndex].Table,
+ FBlockInserts) then begin
+ MessageBeep(0);
+ Application.MessageBox('Import Completed',
+ 'FlashFiler Explorer',
+ MB_ICONINFORMATION or MB_OK);
+ end
+ else begin { If we've aborted and we created a new table, get rid of it }
+ if FNewTable then begin
+ FDatabase.DropTable(FTableIndex);
+ FNewTable := False;
+ end;
+ end;
+ finally
+ frmMain.EnableScreen(True);
+ end;
+ finally
+ FImportEngine.Free;
+ end;
+ if FNewTable then aTableIndex := FTableIndex;
+ end;
+ finally
+ Free;
+ end;
+end;
+
+procedure TdlgImport.FormCreate(Sender: TObject);
+begin
+ HelpContext := hcImportDataDlg;
+ edtBlockInserts.Text := '10';
+end;
+
+procedure TdlgImport.FormShow(Sender: TObject);
+begin
+ lstDirectories.Update;
+ lstFiles.Update;
+end;
+
+procedure TdlgImport.btnImportClick(Sender: TObject);
+var
+ Aborted: Boolean;
+ I: Integer;
+ Msg: TffShStr;
+ ValError : Integer;
+
+ function CreateNewTable(aTableName: TffTableName): LongInt;
+ var
+ Dict: TffDataDictionary;
+ BlockSize: LongInt;
+ begin
+ BlockSize := 4*1024;
+ Dict := TffDataDictionary.Create(BlockSize);
+ try
+ with FDatabase do begin
+
+ { Get the dictionary for the import file }
+ FImportEngine.Schema.MakeIntoDictionary(Dict);
+
+ { Determine if the block size is large enough for one record }
+ while (BlockSize - ffc_BlockHeaderSizeData < Dict.RecordLength) and
+ (BlockSize < 32 * 1024) do
+ BlockSize := BlockSize shl 1;
+ Dict.BlockSize := BlockSize;
+
+ { Create the table in the database }
+ CreateTable(aTableName, Dict);
+
+ { Make a new entry for the TableList }
+ Result := AddTable(aTableName);
+ end;
+ finally
+ Dict.Free;
+ end;
+ end;
+
+begin
+
+ { Get the import filename }
+ if ExtractFilePath(edtImportFilename.Text) <> '' then
+ FImportFilename := edtImportFilename.Text
+ else begin
+ FImportFilename := lstDirectories.Directory;
+ if (FImportFilename[length(FImportFilename)] <> '\') then
+ FImportFilename := FImportFilename + '\';
+ FImportFilename := FImportFilename +
+ edtImportFilename.Text;
+ end;
+
+ { Validate }
+ if cboTableName.Text = '' then
+ raise Exception.Create('Table name required');
+
+ if not FFFileExists(FImportFilename) then
+ raise Exception.Create('Invalid import filename');
+
+ if not FFFileExists(ChangeFileExt(FImportFilename, '.SCH')) then
+ raise Exception.Create('Schema file missing');
+
+ Val(edtBlockInserts.Text, FBlockInserts, ValError);
+ if ValError <> 0 then
+ raise Exception.Create('Invalid data for block inserts field');
+ if FBlockInserts <= 0 then
+ FBlockInserts := 1;
+
+ { See if the user has given us a new tablename }
+ with cboTableName do begin
+ for I := 0 to Items.Count - 1 do
+ if FFCmpShStrUC(Text, Items[I], 255) = 0 then
+ ItemIndex := I;
+
+ Aborted := False;
+ FImportEngine := TffImportEngine.Create(FImportFilename);
+ try
+ FNewTable := False;
+ Screen.Cursor := crHourGlass;
+ try
+ { Check for schema only import }
+ FSchemaOnly := Pos('.SCH', Uppercase(FImportFilename)) <> 0;
+ if FSchemaOnly then begin
+ if ItemIndex = -1 then begin
+ Msg := 'Create new table ' + cboTableName.Text + ' from schema only?';
+ FNewTable := True;
+ end
+ else
+ Msg := 'Replace table ' + cboTableName.Text + ' from schema only?';
+
+ if MessageDlg(Msg, mtConfirmation, [mbYes, mbNo], 0) = mrYes then begin
+
+ if not FNewTable then
+ with FDatabase.Tables[FTableIndex].Table do begin
+ if Active then Close;
+ DeleteTable;
+ end;
+ FTableIndex := CreateNewTable(cboTableName.Text);
+ end
+ else Aborted := True;
+ end
+ else begin
+ if ItemIndex = -1 then begin
+ if MessageDlg('Create new table ' + Text + '?', mtConfirmation, [mbYes, mbNo], 0) = mrYes then begin
+ FTableIndex := CreateNewTable(cboTableName.Text);
+ FNewTable := True;
+ end
+ else Exit;
+ end
+ else begin
+ FTableIndex := LongInt(Items.Objects[ItemIndex]);
+
+ { Overwrite existing data? }
+ if grpExistingData.ItemIndex <> 0 then
+ FDatabase.Tables[FTableIndex].Truncate;
+ end;
+
+ with FDatabase.Tables[FTableIndex] do begin
+ if Table.Active and Table.ReadOnly then
+ Table.Close;
+
+ if not Table.Active then begin
+ Table.ReadOnly := False;
+ Table.Open;
+ end;
+
+ FTableName := cboTableName.Text;
+ end;
+ end;
+ if Aborted then FImportEngine.Free;
+ finally
+ Screen.Cursor := crDefault;
+ end;
+ except
+ FImportEngine.Free;
+ raise;
+ end;
+ end;
+
+ if not Aborted then ModalResult := mrOK;
+end;
+
+procedure TdlgImport.btnCancelClick(Sender: TObject);
+begin
+ FTableIndex := -1;
+end;
+
+procedure TdlgImport.edtImportFilenameKeyPress(Sender: TObject;
+ var Key: Char);
+begin
+ if Key = #13 then begin
+ lstFiles.Mask := edtImportFilename.Text;
+ Key := #0;
+ end;
+end;
+
+procedure TdlgImport.lstFilesClick(Sender: TObject);
+var
+ NewTablename: TffShStr;
+ Ext: TffShStr;
+begin
+ if cboTableName.Text = '' then begin
+ NewTablename := edtImportFilename.Text;
+ Ext := ExtractFileExt(NewTablename);
+ Delete(NewTablename, Pos(Ext, NewTableName), Length(Ext));
+ cboTableName.Text := NewTablename;
+ end;
+end;
+
+end.
diff --git a/components/flashfiler/sourcelaz/explorer/dgprintg.dfm b/components/flashfiler/sourcelaz/explorer/dgprintg.dfm
new file mode 100644
index 000000000..adc865667
Binary files /dev/null and b/components/flashfiler/sourcelaz/explorer/dgprintg.dfm differ
diff --git a/components/flashfiler/sourcelaz/explorer/dgprintg.pas b/components/flashfiler/sourcelaz/explorer/dgprintg.pas
new file mode 100644
index 000000000..8cd05eee2
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/dgprintg.pas
@@ -0,0 +1,92 @@
+{*********************************************************}
+{* Print Status Dialog *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit dgprintg;
+
+interface
+
+uses
+ Windows,
+ Messages,
+ SysUtils,
+ Classes,
+ Graphics,
+ Controls,
+ Forms,
+ Dialogs,
+ StdCtrls,
+ ExtCtrls;
+
+type
+ TdlgPrinting = class(TForm)
+ Bevel1: TBevel;
+ lblPrintingCaption: TLabel;
+ private
+ FCursor: TCursor;
+ public
+ end;
+
+var
+ dlgPrinting: TdlgPrinting;
+
+procedure HidePrintingDlg;
+
+procedure ShowPrintingDlg(const aCaption: string);
+
+implementation
+
+{$R *.DFM}
+
+procedure HidePrintingDlg;
+begin
+ with dlgPrinting do begin
+ Screen.Cursor := FCursor;
+ Visible := False;
+ dlgPrinting.Free;
+ dlgPrinting := nil;
+ end;
+
+end;
+
+procedure ShowPrintingDlg(const aCaption: string);
+begin
+ if not Assigned(dlgPrinting) then
+ dlgPrinting := TdlgPrinting.Create(nil);
+ with dlgPrinting do begin
+ FCursor := Screen.Cursor;
+ Screen.Cursor := crHourglass;
+ lblPrintingCaption.Caption := aCaption;
+ Visible := True;
+ end;
+end;
+
+
+end.
diff --git a/components/flashfiler/sourcelaz/explorer/dgquery.dfm b/components/flashfiler/sourcelaz/explorer/dgquery.dfm
new file mode 100644
index 000000000..0955730ef
Binary files /dev/null and b/components/flashfiler/sourcelaz/explorer/dgquery.dfm differ
diff --git a/components/flashfiler/sourcelaz/explorer/dgquery.pas b/components/flashfiler/sourcelaz/explorer/dgquery.pas
new file mode 100644
index 000000000..6f0ca881d
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/dgquery.pas
@@ -0,0 +1,1179 @@
+{*********************************************************}
+{* FlashFiler Query Dialog *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit dgquery;
+
+interface
+
+uses
+ Windows,
+ Messages,
+ SysUtils,
+ Classes,
+ Graphics,
+ Controls,
+ Forms,
+ Dialogs,
+ StdCtrls,
+ Grids,
+ DBGrids,
+ ComCtrls,
+ ExtCtrls,
+ ToolWin,
+ Menus,
+ DBCtrls,
+ Db,
+ fflleng,
+ ffsrintm,
+ ffclreng,
+ ffllcomp,
+ ffllcomm,
+ fflllgcy,
+ ffllbase,
+ ffllprot, {!!.07}
+ ffdbbase,
+ ffdb,
+ fflllog,
+ {$IFDEF DCC4OrLater}
+ ImgList,
+ {$ENDIF}
+ Buttons,
+ usqlcfg,
+ ffclbase,
+ dgParams, {!!.11}
+ uentity; {!!.10}
+
+type
+ TffSQLConnection = class;
+
+ TdlgQuery = class(TForm)
+ StatusBar: TStatusBar;
+ ImageList1: TImageList;
+ MainMenu: TMainMenu;
+ pnlCenter: TPanel;
+ pnlSQL: TPanel;
+ memSQL: TMemo;
+ Splitter: TSplitter;
+ pnlResults: TPanel;
+ grdResults: TDBGrid;
+ OpenDialog: TOpenDialog;
+ SaveDialog: TSaveDialog;
+ DBNavigator: TDBNavigator;
+ DataSource: TDataSource;
+ Transport: TffLegacyTransport;
+ SQLRSE: TFFRemoteServerEngine;
+ Options1: TMenuItem;
+ mnuQuery: TMenuItem;
+ mnuExecute: TMenuItem;
+ mnuSave: TMenuItem;
+ mnuLoad: TMenuItem;
+ mnuLive: TMenuItem;
+ mnuProps: TMenuItem;
+ mnuConnect: TMenuItem;
+ mnuNew: TMenuItem;
+ pnlMenuBar: TPanel;
+ pnlButtons: TPanel;
+ pnlConnections: TPanel;
+ ToolBar1: TToolBar;
+ btnGo: TToolButton;
+ btnLoad: TToolButton;
+ btnSave: TToolButton;
+ ToolButton7: TToolButton;
+ btnProp: TToolButton;
+ btnLiveDS: TToolButton;
+ ToolBar2: TToolBar;
+ btnNew: TToolButton;
+ cmbQuery: TComboBox;
+ Delete1: TMenuItem;
+ mnuOptionsDebug: TMenuItem;
+ N1: TMenuItem;
+ mnuQueryPrintPreview: TMenuItem;
+ mnuQueryDesignReport: TMenuItem;
+ N2: TMenuItem;
+ mnuTableClose: TMenuItem;
+ N3: TMenuItem;
+ mnuQueryCopyToTable: TMenuItem;
+ ToolButton1: TToolButton;
+ btnParamValues: TToolButton;
+ N4: TMenuItem;
+ mnuQueryParamValues: TMenuItem;
+ procedure pbPropertiesClick(Sender: TObject);
+ procedure pbExecuteClick(Sender: TObject);
+ procedure pbSaveClick(Sender: TObject);
+ procedure pbLoadClick(Sender: TObject);
+ procedure FormShow(Sender: TObject);
+ procedure btnPropClick(Sender: TObject);
+ procedure btnLoadClick(Sender: TObject);
+ procedure btnSaveClick(Sender: TObject);
+ procedure btnNewClick(Sender: TObject);
+ procedure cmbQueryChange(Sender: TObject);
+ procedure FormDestroy(Sender: TObject);
+ procedure btnGoClick(Sender: TObject);
+ procedure mnuExecuteClick(Sender: TObject);
+ procedure mnuSaveClick(Sender: TObject);
+ procedure mnuLoadClick(Sender: TObject);
+ procedure mnuNewClick(Sender: TObject);
+ procedure mnuLiveClick(Sender: TObject);
+ procedure btnLiveDSClick(Sender: TObject);
+ procedure mnuPropsClick(Sender: TObject);
+ procedure FormKeyDown(Sender : TObject;
+ var Key : Word;
+ Shift : TShiftState);
+ procedure grdResultsKeyDown(Sender : TObject;
+ var Key : Word;
+ Shift : TShiftState);
+ procedure cmbQueryKeyDown(Sender : TObject;
+ var Key : Word;
+ Shift : TShiftState);
+ procedure Delete1Click(Sender : TObject);
+ procedure FormClose(Sender : TObject;
+ var Action : TCloseAction);
+ procedure StatusBarDrawPanel(StatusBar: TStatusBar;
+ Panel: TStatusPanel; const Rect: TRect);
+ procedure cmbQueryEnter(Sender: TObject);
+ procedure memSQLExit(Sender: TObject);
+ procedure memSQLKeyDown(Sender: TObject; var Key: Word;
+ Shift: TShiftState);
+ procedure mnuOptionsDebugClick(Sender: TObject);
+ procedure FormDeactivate(Sender: TObject);
+ procedure mnuTableCloseClick(Sender: TObject);
+ procedure mnuQueryPrintPreviewClick(Sender: TObject);
+ procedure mnuQueryDesignReportClick(Sender: TObject);
+ procedure mnuQueryCopyToTableClick(Sender: TObject);
+ procedure btnParamValuesClick(Sender: TObject);
+ private
+ { Private declarations }
+ FSyntaxOnly : Boolean;
+ FServerName : string;
+ FProtocol : TffProtocolType;
+ FDatabaseName : string;
+ FConfig : TffeSQLConfig;
+ FConnections : TffList;
+ FUserName: string;
+ FPassword: string;
+ FDatabaseItem: TffeDatabaseItem;
+ FIsLastQuerySelect: Boolean;
+ FSuppressParamsDialog : Boolean; {!!.11}
+ FSupressSyntaxOKDialog : Boolean; {!!.11}
+ FStmt : string; {!!.11}
+
+ procedure CheckLastQueryType;
+ procedure SetControls;
+ procedure NewQuery(const Stmt : string); {!!.11}
+ procedure GetNewConnection(const Stmt : string); {!!.11}
+ procedure DisplayHint(Sender : TObject);
+ procedure ReloadCombo;
+ procedure LoadConfig;
+ procedure SaveConfig;
+ procedure SaveQuery;
+ procedure WMGetMinMaxInfo(var Message : TWMGetMinMaxInfo);
+ message WM_GETMINMAXINFO;
+{Begin !!.02}
+ protected
+ FLog : TffBaseLog;
+{End !!.02}
+ public
+ { Public declarations }
+ procedure UpdateDefaultTimeout; {!!.11}
+ property ServerName : string
+ read FServerName write FServerName;
+{Begin !!.07}
+ property Protocol : TffProtocolType
+ read FProtocol write FProtocol;
+{End !!.07}
+ property DatabaseName : string
+ read FDatabaseName write FDatabaseName;
+{Begin !!.02}
+ property Log : TffBaseLog
+ read FLog write FLog;
+{End !!.02}
+ property Password : string
+ read FPassword write FPassword;
+ property InitialStatement : string {!!.11}
+ read FStmt write FStmt; {!!.11}
+ property UserName : string
+ read FUserName write FUserName;
+ property DatabaseItem: TffeDatabaseItem
+ read FDatabaseItem write FDatabaseItem;
+ end;
+
+ {This class maintains the objects required for each SQL client
+ connection.}
+ TffSQLConnection = class(TffSelfListItem)
+ protected
+ FClient : TffClient;
+ FQuery : TffQuery;
+ FSession : TffSession;
+ FName : string;
+ FText : string;
+ FExecutionTime : DWord; {!!.05}
+ FdlgParams : TdlgParams;
+ public
+ constructor Create(anEngine : TffBaseServerEngine;
+ aDatabaseName, aUserName, aPassword : string);
+ destructor Destroy; override;
+
+ property Client : TffClient read FClient;
+ property ExecutionTime : DWord read FExecutionTime write FExecutionTime;
+ property Name : string read FName write FName;
+ property Query : TffQuery read FQuery;
+ property Session : TffSession read FSession;
+ property Text : string read FText write FText;
+ { The text of the query as last entered into the SQL window.
+ We save it aside from the TffQuery so that we don't trash the
+ query's resultset. }
+ property dlgParams : TdlgParams read FdlgParams write FdlgParams;
+ { we keep an instance of the params dialog around
+ when a query has parameters; thus saving the values }
+ end;
+
+var
+ dlgQuery : TdlgQuery;
+
+implementation
+
+uses
+ dgCpyTbl, {!!.10}
+ uReportEngineInterface, {!!.07}
+ dgsqlops,
+ ffsql, {!!.10}
+ ffsqldef, {!!.10}
+ uConfig; {!!.11}
+
+{$R *.DFM}
+
+resourcestring
+ ffConnChanged = 'Connection changed';
+
+const
+ ciDefaultTimeout = 10000;
+ strExecutionTime = 'Execution time = %d ms'; {!!.07}
+
+{====SQL Error Dialog================================================}
+
+procedure SQLErrorDlg(const AMessage : string);
+var
+ Form : TForm;
+ Memo : TMemo; {!!.01}
+// Msg : TLabel; {Deleted !!.01}
+ Btn : TButton;
+ Pnl : TPanel;
+ PnlBottom : TPanel;
+resourcestring
+ cErrCaption = 'Query Error';
+begin
+ Form := TForm.Create(Application);
+ with Form do
+ try
+ Canvas.Font := Font;
+ BorderStyle := bsSizeable;
+ Caption := CErrCaption;
+ Position := poScreenCenter;
+{Begin !!.01}
+ Width := 480;
+ BorderIcons := BorderIcons - [biMinimize];
+// with TPanel.Create(Form) do begin
+// Parent := Form;
+// Caption := '';
+// Align := alLeft;
+// Width := 8;
+// BevelInner := bvNone;
+// BevelOuter := bvNone;
+// end;
+// with TPanel.Create(Form) do begin
+// Parent := Form;
+// Caption := '';
+// Align := alRight;
+// Width := 8;
+// BevelInner := bvNone;
+// BevelOuter := bvNone;
+// end;
+{End !!.01}
+ Pnl := TPanel.Create(Form);
+ with Pnl do begin
+ Parent := Form;
+ Caption := '';
+ Align := alClient;
+ BevelInner := bvNone;
+ BevelOuter := bvNone;
+ end;
+{Begin !!.01}
+ { Display the error message in a memo. }
+ Memo := TMemo.Create(Form);
+ with Memo do begin
+ Parent := Pnl;
+ Align := alClient;
+ Font.Name := 'Courier';
+ ReadOnly := True;
+ Scrollbars := ssBoth;
+ Text := aMessage;
+ WordWrap := False;
+ end;
+{End !!.01}
+ Btn := TButton.Create(Form);
+ with Btn do begin
+ Caption := 'OK';
+ ModalResult := mrOk;
+ Default := True;
+ Cancel := True;
+ Left := 0;
+ Top := 2;
+ end;
+ PnlBottom := TPanel.Create(Form);
+ with PnlBottom do begin
+ Parent := Pnl;
+ Caption := '';
+ Align := alBottom;
+ Height := Btn.Height + 4;
+ BevelInner := bvNone;
+ BevelOuter := bvNone;
+ end;
+ Btn.Parent := PnlBottom;
+{Begin !!.01}
+// Msg := TLabel.Create(Form);
+// with Msg do begin
+// Parent := Pnl;
+// AutoSize := True;
+// Left := 8;
+// Top := 8;
+// Caption := AMessage;
+// end;
+ Btn.Left := (Form.Width div 2) - (Btn.Width div 2);
+ ActiveControl := Btn;
+// Pnl.Height := Msg.Height + 16;
+{End !!.01}
+ ShowModal;
+ finally
+ Form.Free;
+ end;
+end;
+
+
+{====================================================================}
+constructor TffSQLConnection.Create(anEngine : TffBaseServerEngine;
+ aDatabaseName, aUserName, aPassword : string);
+var
+ OldPassword : string;
+ OldUserName : string;
+begin
+ inherited Create;
+ FExecutionTime := 0; {!!.05}
+ FClient := TffClient.Create(nil);
+ with FClient do begin
+ AutoClientName := True;
+ ServerEngine := anEngine;
+ TimeOut := Config.DefaultTimeout; {!!.11}
+ end;
+
+ FSession := TffSession.Create(nil);
+ with FSession do begin
+ ClientName := FClient.ClientName;
+ AutoSessionName := True;
+ OldPassword := ffclPassword;
+ OldUserName := ffclUsername;
+ try
+ ffclPassword := aPassword;
+ ffclUsername := aUserName;
+ Open;
+ finally
+ ffclPassword := OldPassword;
+ ffclUsername := OldUserName;
+ end;
+ end;
+
+ FQuery := TffQuery.Create(nil);
+ with FQuery do begin
+ SessionName := FSession.SessionName;
+ DatabaseName := aDatabaseName;
+ Name := 'Query' + IntToStr(GetTickCount);
+ RequestLive := True;
+ Timeout := ciDefaultTimeout;
+ end;
+
+ FName := 'New Query';
+ FText := '';
+end;
+{--------}
+destructor TffSQLConnection.Destroy;
+begin
+ FQuery.Free;
+ FSession.Free;
+ FClient.Free;
+ {Begin !!.11}
+ if Assigned(dlgParams) then
+ dlgParams.Free;
+ {End !!.11}
+ inherited Destroy;
+end;
+{====================================================================}
+
+{===TdlgQuery========================================================}
+procedure TdlgQuery.btnGoClick(Sender : TObject);
+begin
+ pbExecuteClick(Sender);
+end;
+{--------}
+procedure TdlgQuery.btnLiveDSClick(Sender : TObject);
+var
+ aConn : TffSQLConnection;
+begin
+ { Switch to requesting live datasets. }
+ aConn := TffSQLConnection(FConnections[cmbQuery.ItemIndex]);
+ aConn.Query.RequestLive := not aConn.Query.RequestLive;
+ SetControls;
+end;
+{--------}
+procedure TdlgQuery.btnLoadClick(Sender : TObject);
+begin
+ pbLoadClick(Sender);
+end;
+{--------}
+procedure TdlgQuery.btnNewClick(Sender : TObject);
+begin
+ GetNewConnection(''); {!!.11}
+end;
+{--------}
+procedure TdlgQuery.btnPropClick(Sender : TObject);
+begin
+ pbPropertiesClick(Sender);
+end;
+{--------}
+procedure TdlgQuery.btnSaveClick(Sender : TObject);
+begin
+ pbSaveClick(Sender);
+end;
+{--------}
+procedure TdlgQuery.cmbQueryChange(Sender : TObject);
+var
+ aConn : TffSQLConnection;
+begin
+ aConn := TffSQLConnection(FConnections[cmbQuery.ItemIndex]);
+ memSQL.Clear;
+ memSQL.Text := aConn.Text;
+ DataSource.DataSet := aConn.Query;
+ StatusBar.Panels[0].Text := ffConnChanged;
+ CheckLastQueryType;
+ SetControls;
+end;
+{--------}
+procedure TdlgQuery.cmbQueryKeyDown(Sender : TObject;
+ var Key : Word;
+ Shift : TShiftState);
+begin
+ FormKeyDown(Sender, Key, Shift);
+end;
+{--------}
+procedure TdlgQuery.Delete1Click(Sender : TObject);
+var
+ anIndex : Integer;
+begin
+ { Deletes the current connection. }
+ anIndex := cmbQuery.ItemIndex;
+ if anIndex >= 0 then begin
+ anIndex := cmbQuery.ItemIndex;
+ FConnections.DeleteAt(anIndex);
+ cmbQuery.Items.Delete(anIndex);
+ end;
+
+ { Any connections left? }
+ if cmbQuery.Items.Count = 0 then begin
+ { No. Create a new connection. }
+ NewQuery(''); {!!.11}
+ GetNewConnection(''); {!!.11}
+ ReloadCombo;
+ cmbQuery.ItemIndex := 0;
+ end else begin
+ ReloadCombo;
+ if anIndex < cmbQuery.Items.Count then
+ cmbQuery.ItemIndex := anIndex
+ else
+ cmbQuery.ItemIndex := Pred(anIndex);
+ cmbQueryChange(Sender);
+ end;
+
+ SetControls;
+ StatusBar.Panels[0].Text := 'Connection deleted';
+
+end;
+{--------}
+procedure TdlgQuery.DisplayHint(Sender : TObject);
+begin
+ StatusBar.Panels[0].Text := Application.Hint;
+end;
+{--------}
+procedure TdlgQuery.FormClose(Sender: TObject; var Action: TCloseAction);
+begin
+ Action := caFree;
+end;
+{--------}
+procedure TdlgQuery.FormDestroy(Sender: TObject);
+begin
+ FConnections.Free;
+ SaveConfig;
+ if Assigned(FConfig) then
+ FConfig.Free;
+end;
+{--------}
+procedure TdlgQuery.FormKeyDown(Sender : TObject;
+ var Key : Word;
+ Shift : TShiftState);
+begin
+ if (not (TffSQLConnection(FConnections[cmbQuery.ItemIndex]).Query.State IN [dsInsert, dsEdit])) and {!!.07} { prepare for live datasets }
+ (Key = VK_ESCAPE) then
+ Close;
+ if ssCtrl in Shift then begin
+ with cmbQuery do begin
+ if (Key = VK_UP) then begin
+ SaveQuery;
+ if ItemIndex = 0 then
+ ItemIndex := pred(Items.Count)
+ else
+ ItemIndex := Pred(ItemIndex);
+ cmbQueryChange(Sender);
+ end;
+ if (Key = VK_DOWN) then begin
+ SaveQuery;
+ if ItemIndex = pred(Items.Count) then
+ ItemIndex := 0
+ else
+ ItemIndex := Succ(ItemIndex);
+ cmbQueryChange(Sender);
+ end;
+ end;
+ end;
+end;
+{--------}
+procedure TdlgQuery.FormShow(Sender : TObject);
+begin
+ FIsLastQuerySelect := True; {!!.10}
+ FConfig := TffeSQLConfig.Create(FServerName, FDatabaseName);
+ FConnections := TffList.Create;
+ FConnections.Sorted := False;
+ LoadConfig;
+ Transport.ServerName := FServerName; {!!.01}
+ Transport.Protocol := FProtocol; {!!.07}
+ if assigned(FLog) then {!!.02}
+ Transport.EventLog := FLog; {!!.02}
+
+// NewQuery; {Deleted !!.11}
+ SetControls;
+ GetNewConnection(FStmt); {!!.11}
+ {create a new session, client, query}
+ cmbQuery.ItemIndex := 0;
+ Caption := ServerName + ' : ' + DatabaseName;
+ Application.OnHint := DisplayHint;
+ FSyntaxOnly := False;
+ { large font support... }
+ if (Screen.PixelsPerInch/PixelsPerInch)>1.001 then begin
+ Height := Round(Height * (Screen.PixelsPerInch/PixelsPerInch));
+ Width := Round(Width * (Screen.PixelsPerInch/PixelsPerInch));
+ Statusbar.Height := Round(Statusbar.Height * (Screen.PixelsPerInch/PixelsPerInch));
+ end;
+ { report menuitems }
+ mnuQueryPrintPreview.Enabled := ReportEngineDLLLoaded;
+ mnuQueryDesignReport.Enabled := ReportEngineDLLLoaded;
+end;
+{--------}
+procedure TdlgQuery.GetNewConnection(const Stmt : string); {!!.11}
+var
+ anIndex : Integer;
+ aSQLConn : TffSQLConnection;
+begin
+ {Save the existing query if it hasn't been saved.}
+ SaveQuery;
+ NewQuery(Stmt); {!!.11}
+ aSQLConn := TffSQLConnection.Create(SQLRSE, FDatabaseName, FUserName,
+ FPassword);
+ anIndex := FConnections.InsertPrim(aSQLConn);
+ { Add new connection to the list box and select it. }
+ ReloadCombo;
+ cmbQuery.ItemIndex := anIndex;
+ DataSource.DataSet := aSQLConn.Query;
+ SetControls;
+end;
+{--------}
+procedure TdlgQuery.grdResultsKeyDown(Sender : TObject;
+ var Key : Word;
+ Shift : TShiftState);
+begin
+ FormKeyDown(Sender, Key, Shift);
+end;
+{--------}
+procedure TdlgQuery.LoadConfig;
+begin
+ FConfig.Refresh;
+
+ WindowState := FConfig.WindowState;
+ with FConfig do begin
+ memSQL.Font.Name := FontName;
+ memSQL.Font.Size := FontSize;
+ if (WindowState <> wsMaximized) and
+ (WindowPos.Bottom <> 0) then begin
+ Left := WindowPos.Left;
+ Top := WindowPos.Top;
+ Height := WindowPos.Bottom - WindowPos.Top;
+ Width := WindowPos.Right - WindowPos.Left;
+ end;
+ pnlSQL.Height := SplitterPos;
+ end;
+end;
+{--------}
+procedure TdlgQuery.mnuExecuteClick(Sender : TObject);
+begin
+ pbExecuteClick(Sender);
+end;
+{--------}
+procedure TdlgQuery.mnuLiveClick(Sender : TObject);
+begin
+ btnLiveDSClick(Sender);
+end;
+{--------}
+procedure TdlgQuery.mnuLoadClick(Sender : TObject);
+begin
+ pbLoadClick(Sender);
+end;
+{--------}
+procedure TdlgQuery.mnuNewClick(Sender : TObject);
+begin
+ GetNewConnection(''); {!!.11}
+end;
+{--------}
+procedure TdlgQuery.mnuPropsClick(Sender : TObject);
+begin
+ pbPropertiesClick(Sender);
+end;
+{--------}
+procedure TdlgQuery.mnuSaveClick(Sender : TObject);
+begin
+ pbSaveClick(Sender);
+end;
+{--------}
+procedure TdlgQuery.NewQuery(const Stmt : string); {!!.11}
+begin
+ with memSQL do begin
+ Clear;
+{Begin !!.11}
+ if Stmt = '' then
+ Lines[0] := 'SELECT '
+ else
+ Lines[0] := Stmt;
+ SelStart := 7;
+{End !!.11}
+ SetFocus;
+ end;
+ FIsLastQuerySelect := True; {!!.10}
+end;
+{--------}
+procedure TdlgQuery.pbExecuteClick(Sender : TObject);
+var
+ aConn : TffSQLConnection;
+ I,
+ anIndex : Integer;
+ Buffer : PChar;
+ BuffSize : Integer;
+ ExecTime : DWord;
+begin
+ Screen.Cursor := crHourGlass;
+ anIndex := 0;
+ try
+ Application.ProcessMessages;
+ anIndex := cmbQuery.ItemIndex;
+ aConn := TffSQLConnection(FConnections.Items[anIndex]);
+ StatusBar.Panels[0].Text := 'Checking syntax...';
+ aConn.Query.SQL.Clear;
+ if memSQL.SelLength > 0 then begin
+ BuffSize := memSQL.SelLength + 1;
+ GetMem(Buffer, BuffSize);
+ memSQL.GetSelTextBuf(Buffer, BuffSize);
+ aConn.Query.SQL.Add(StrPas(Buffer));
+ aConn.Name := StrPas(Buffer);
+ FreeMem(Buffer, BuffSize);
+ end else begin
+ aConn.Query.SQL.Text := memSQL.Text;
+ aConn.Name := memSQL.Lines[0];
+ end;
+
+ try
+ CheckLastQueryType; {!!.10}
+ aConn.Query.Prepare;
+ if (not FSyntaxOnly) then begin
+ {Begin !!.11}
+ { do we need to present the Params dialog? }
+ if not FSuppressParamsDialog then begin
+ if aConn.Query.ParamCount>0 then begin
+ if not Assigned(aConn.dlgParams) then begin
+ aConn.dlgParams := TdlgParams.Create(Self);
+ end;
+ if not aConn.dlgParams.EditParamValues(aConn.Query.Params) then
+ Exit;
+ end
+ else
+ { params not needed anymore? }
+ if Assigned(aConn.dlgParams) then begin
+ aConn.dlgParams.Free;
+ aConn.dlgParams := Nil;
+ end;
+ end
+ else
+ { get stored values }
+ aConn.dlgParams.GetParamValues(aConn.Query.Params);
+ {End !!.11}
+ if FIsLastQuerySelect then begin
+ StatusBar.Panels[0].Text := 'Executing query...';
+ ExecTime := GetTickCount;
+ aConn.Query.Open;
+ ExecTime := GetTickCount - ExecTime;
+ aConn.ExecutionTime := ExecTime; {!!.05}
+ StatusBar.Panels[0].Text := 'Query retrieved';
+ StatusBar.Panels[2].Text := 'Record count = ' +
+ FFCommaizeChL(aConn.Query.RecordCount,
+ ThousandSeparator);
+ StatusBar.Panels[3].Text := Format(strExecutionTime, [aConn.ExecutionTime]); {!!.05}
+
+ { make sure no column exceeds screen width } {!!.07}
+ for I := 0 to grdResults.Columns.Count-1 do begin
+ if grdResults.Columns[i].Width>(Width DIV 5)*4 then
+ grdResults.Columns[i].Width := (Width DIV 5)*4;
+ end;
+
+ end else begin
+ StatusBar.Panels[0].Text := 'Executing SQL...';
+ ExecTime := GetTickCount;
+ aConn.Query.ExecSQL;
+ ExecTime := GetTickCount - ExecTime;
+ aConn.ExecutionTime := ExecTime; {!!.05}
+ StatusBar.Panels[0].Text := 'Query executed';
+ StatusBar.Panels[2].Text := 'Rows affected = ' +
+ FFCommaizeChL(aConn.Query.RowsAffected,
+ ThousandSeparator);
+ StatusBar.Panels[3].Text := Format(strExecutionTime, [aConn.ExecutionTime]); {!!.05}
+ end;
+ end else begin
+ if not FSupressSyntaxOKDialog then begin {!!.11}
+ ShowMessage('Syntax is valid');
+ StatusBar.Panels[0].Text := 'Syntax is valid';
+ end;
+ end;
+ except
+ on E: EffDatabaseError do
+ if (E.ErrorCode = ffdse_QueryPrepareFail) or
+ (E.ErrorCode = ffdse_QuerySetParamsFail) or
+ (E.ErrorCode = ffdse_QueryExecFail) then begin
+ SQLErrorDlg(E.Message);
+ StatusBar.Panels[0].Text := 'Query failed!';
+ StatusBar.Panels[2].Text := 'Record count = 0';
+ StatusBar.Panels[3].Text := Format(strExecutionTime, [0]); {!!.03}
+ end else
+ raise
+ else
+ raise;
+ end;
+ finally
+ SetControls;
+ Screen.Cursor := crDefault;
+ ReloadCombo;
+ cmbQuery.ItemIndex := anIndex;
+ end;
+end;
+{--------}
+procedure TdlgQuery.pbLoadClick(Sender : TObject);
+var
+ aConn : TffSQLConnection;
+ anIndex : Integer;
+begin
+ { Load a query from a file. Update combobox. }
+ if OpenDialog.Execute then begin
+ {should we start a new connection?}
+ if Assigned(DataSource.DataSet) then
+ GetNewConnection(''); {!!.11}
+ anIndex := cmbQuery.ItemIndex;
+ memSQL.Lines.LoadFromFile(OpenDialog.Files[0]);
+ cmbQuery.Items[anIndex] := memSQL.Lines[0];
+ aConn := TffSQLConnection(FConnections[anIndex]);
+ aConn.Text := memSQL.Lines.Text;
+ aConn.Query.SQL.Clear;
+ cmbQuery.ItemIndex := anIndex;
+ end;
+end;
+{--------}
+procedure TdlgQuery.pbPropertiesClick(Sender: TObject);
+var
+ aConn : TffSQLConnection;
+ OptionsForm : TfrmSQLOps;
+ anIndex : Integer;
+begin
+ {displays a set of options for the sql window and current query}
+ OptionsForm := TfrmSQLOps.Create(Self);
+ with OptionsForm do begin
+ SyntaxOnly := FSyntaxOnly;
+ anIndex := cmbQuery.ItemIndex;
+ aConn := TffSQLConnection(FConnections[anIndex]);
+ with aConn.Query do begin
+ OptionsForm.Timeout := Timeout;
+ RequestLiveDS := RequestLive;
+ QueryName := cmbQuery.Items[anIndex];
+ Font := memSQL.Font;
+ try
+ if ShowModal = mrOK then begin
+ Timeout := OptionsForm.Timeout;
+ RequestLive := RequestLiveDS;
+ aConn.Name := QueryName; {!!.12}
+ cmbQuery.Items[anIndex] := QueryName;
+ cmbQuery.ItemIndex := anIndex;
+ cmbQuery.Update;
+ memSQL.Font := Font;
+ FSyntaxOnly := SyntaxOnly;
+ end;
+ finally
+ OptionsForm.Free;
+ end;
+ end;
+ SaveConfig;
+ end;
+end;
+{--------}
+procedure TdlgQuery.pbSaveClick(Sender : TObject);
+begin
+ { Save the query to a file. }
+ if SaveDialog.Execute then begin
+ {does the file already exist?}
+ if FileExists(SaveDialog.Files[0]) then
+ DeleteFile(SaveDialog.Files[0]);
+ memSQL.Lines.SaveToFile(SaveDialog.Files[0]);
+ end;
+end;
+{--------}
+procedure TdlgQuery.ReloadCombo;
+var
+ i : Integer;
+begin
+ cmbQuery.Clear;
+ for i := 0 to Pred(FConnections.Count) do
+ cmbQuery.Items.Insert(i,
+ TffSQLConnection(FConnections[i]).Name);
+end;
+{--------}
+procedure TdlgQuery.SaveConfig;
+var
+ TempRect : TRect;
+begin
+ {save the current settings to the INI file}
+ if Assigned(FConfig) then begin
+ FConfig.WindowState := WindowState;
+ with FConfig do begin
+ FontName := memSQL.Font.Name;
+ FontSize := memSQL.Font.Size;
+ TempRect.Left := Left;
+ TempRect.Right := Left + Width;
+ TempRect.Bottom := Top + Height;
+ TempRect.Top := Top;
+ WindowPos := TempRect;
+ SplitterPos := pnlSQL.Height;
+ Save;
+ end;
+ end;
+end;
+{--------}
+procedure TdlgQuery.SetControls;
+var
+ aConn : TffSQLConnection;
+begin
+ DBNavigator.VisibleButtons :=
+ DBNavigator.VisibleButtons -
+ [nbInsert, nbDelete, nbEdit, nbPost, nbCancel];
+ btnLiveDS.Enabled := False;
+ if (cmbQuery.ItemIndex <> -1) then begin
+ btnLiveDS.Enabled := True;
+ aConn := TffSQLConnection(FConnections.Items[cmbQuery.ItemIndex]);
+ with aConn.Query do begin
+ if RequestLive and CanModify then begin
+ DBNavigator.VisibleButtons :=
+ DBNavigator.VisibleButtons +
+ [nbInsert, nbDelete, nbEdit, nbPost, nbCancel];
+ end;
+ if FIsLastQuerySelect then begin {!!.10}
+ if Active then begin
+ StatusBar.Panels[2].Text := 'Record count = ' +
+ FFCommaizeChL(RecordCount, ThousandSeparator);
+ StatusBar.Panels[3].Text := Format(strExecutionTime, [aConn.ExecutionTime]); {!!.05}
+ end else begin
+ StatusBar.Panels[2].Text := 'Record count = 0';
+ StatusBar.Panels[3].Text := Format(strExecutionTime, [0]); {!!.05}
+ end;
+ end
+ {Begin !!.10}
+ else begin
+ StatusBar.Panels[2].Text := 'Rows affected = ' +
+ FFCommaizeChL(RowsAffected, ThousandSeparator);
+ StatusBar.Panels[3].Text := Format(strExecutionTime, [aConn.ExecutionTime]); {!!.05}
+ end;
+ end;
+ end;
+
+ mnuLive.Checked := btnLiveDS.Enabled;
+ StatusBar.Panels[1].Text := format('Queries = %d', [cmbQuery.Items.Count]); {!!.05}
+ StatusBar.Refresh;
+end;
+{====================================================================}
+procedure TdlgQuery.StatusBarDrawPanel(StatusBar : TStatusBar;
+ Panel : TStatusPanel;
+ const Rect : TRect);
+var
+ aConn : TffSQLConnection;
+begin
+ with StatusBar do begin
+ if cmbQuery.ItemIndex > -1 then begin
+ aConn := TffSQLConnection(FConnections.Items[cmbQuery.ItemIndex]);
+ with aConn.Query do begin
+ if RequestLive and CanModify then
+ ImageList1.Draw(StatusBar.Canvas, Rect.Left + 3, Rect.Top, 9)
+ else
+ ImageList1.Draw(StatusBar.Canvas, Rect.Right - 30, Rect.Top, 10);
+ end
+ end
+ else
+ ImageList1.Draw(StatusBar.Canvas, Rect.Left + 3, Rect.Top, 10);
+ end;
+end;
+
+procedure TdlgQuery.SaveQuery;
+var
+ aSQLConn : TffSQLConnection;
+begin
+ {Save the existing query if it hasn't been saved.}
+ if cmbQuery.ItemIndex > -1 then begin
+ aSQLConn := TffSQLConnection(FConnections.Items[cmbQuery.ItemIndex]);
+ aSQLConn.Text := memSQL.Text;
+ end;
+end;
+
+procedure TdlgQuery.cmbQueryEnter(Sender: TObject);
+begin
+ SaveQuery;
+end;
+
+procedure TdlgQuery.WMGetMinMaxInfo(var Message: TWMGetMinMaxInfo);
+var
+ MinMax : PMinMaxInfo;
+begin
+ inherited;
+ MinMax := Message.MinMaxInfo;
+ MinMax^.ptMinTrackSize.x := 535;
+end;
+
+procedure TdlgQuery.memSQLExit(Sender: TObject);
+var
+ aConn : TffSQLConnection;
+begin
+ { Save the text in the memo so that it is preserved in the event the
+ user switches to another connection or creates a new connection. }
+ aConn := TffSQLConnection(FConnections[cmbQuery.ItemIndex]);
+ aConn.Text := memSQL.Text;
+end;
+
+procedure TdlgQuery.memSQLKeyDown(Sender: TObject; var Key: Word;
+ Shift: TShiftState);
+begin
+ { Make sure Ctrl+Up and Ctrl+Down are recognized. }
+ FormKeyDown(Sender, Key, Shift);
+ {Begin !!.11}
+ { support Ctrl-A for Select All }
+ if (Key=Ord('A')) and
+ (Shift=[ssCtrl]) then
+ memSQL.SelectAll;
+ {End !!.11}
+end;
+
+{Start !!.02}
+procedure TdlgQuery.mnuOptionsDebugClick(Sender: TObject);
+begin
+ mnuOptionsDebug.Checked := not mnuOptionsDebug.Checked;
+ if mnuOptionsDebug.Checked then
+ Transport.EventLogOptions := [fftpLogErrors, fftpLogRequests,
+ fftpLogReplies]
+ else
+ Transport.EventLogOptions := [fftpLogErrors];
+end;
+{End !!.02}
+
+procedure TdlgQuery.FormDeactivate(Sender: TObject);
+begin
+ Application.OnHint := nil; {!!.06}
+end;
+
+procedure TdlgQuery.mnuTableCloseClick(Sender: TObject);
+begin
+ Close;
+end;
+
+procedure TdlgQuery.mnuQueryPrintPreviewClick(Sender: TObject);
+var
+ Filter,
+ DatabaseName : Array[0..1024] of Char;
+ SQL : Array[0..65536] of Char;
+ aConn : TffSQLConnection;
+begin
+ aConn := TffSQLConnection(FConnections.Items[cmbQuery.ItemIndex]);
+ StrPCopy(DatabaseName, FDatabaseName);
+ if aConn.Query.Filtered then begin
+ StrPCopy(Filter, aConn.Query.Filter);
+ end
+ else
+ StrCopy(Filter, '');
+ StrPCopy(SQL, aConn.Query.SQL.Text);
+ SingleQueryReport(FProtocol,
+ FServerName,
+ FUserName,
+ FPassword,
+ DatabaseName,
+ SQL,
+ Filter);
+end;
+
+procedure TdlgQuery.mnuQueryDesignReportClick(Sender: TObject);
+var
+ DatabaseName : Array[0..1024] of Char;
+begin
+ StrPCopy(DatabaseName, FDatabaseName);
+ DesignReport(FProtocol,
+ FServerName,
+ FUserName,
+ FPassword,
+ DatabaseName);
+end;
+
+procedure TdlgQuery.mnuQueryCopyToTableClick(Sender: TObject);
+var
+ ExcludeIndex,
+ TableIndex: LongInt;
+ CopyBlobs : Boolean;
+ aConn : TffSQLConnection;
+ SaveTimeout : Integer;
+ Dummy : TffeTableItem; {!!.11}
+begin
+ aConn := TffSQLConnection(FConnections[cmbQuery.ItemIndex]);
+ ExcludeIndex := -1;
+ if ShowCopyTableDlg(FDatabaseItem, ExcludeIndex, aConn.FQuery,
+ TableIndex, CopyBlobs, Dummy) = mrOK then begin {!!.11}
+ with FDatabaseItem.Tables[TableIndex] do begin
+ Screen.Cursor := crHourGlass;
+ { the copy operation is used in the context of the table
+ that's being copied to. Use the timeout of the active
+ table, otherwise the user has no way of setting timeout. }
+ SaveTimeout := Table.Timeout;
+ Table.Timeout := aConn.FQuery.Timeout;
+ try
+ Update;
+ CopyRecords(aConn.FQuery, CopyBlobs);
+ finally
+ Screen.Cursor := crDefault;
+ Table.Timeout := SaveTimeout;
+ { force the second table to close if it wasn't open before }
+ aConn.FSession.CloseInactiveTables; {!!.11}
+ end;
+ end;
+ end;
+end;
+
+procedure TdlgQuery.CheckLastQueryType;
+var
+ Buffer : PChar;
+ BuffSize : Integer;
+ ffSqlParser : TffSql;
+begin
+ ffSqlParser := TffSql.Create(NIL);
+ BuffSize := Length(memSQL.Text) + 1;
+ GetMem(Buffer, BuffSize);
+ try
+ StrPCopy(Buffer, memSQL.Text);
+
+ ffSqlParser.SourceStream.SetSize(BuffSize);
+ move(Buffer^, ffSqlParser.SourceStream.Memory^, BuffSize);
+ ffSqlParser.Execute;
+ FIsLastQuerySelect := Assigned(ffsqlParser.RootNode) and
+ Assigned(ffsqlParser.RootNode.TableExp);
+
+ finally
+ ffsqlParser.Free;
+ FreeMem(Buffer, BuffSize);
+ end;
+end;
+
+{Begin !!.11}
+procedure TdlgQuery.UpdateDefaultTimeout;
+var
+ i : Integer;
+begin
+ for i := 0 to Pred(FConnections.Count) do
+ TffSQLConnection(FConnections[i]).FClient.TimeOut := Config.DefaultTimeout;
+end;
+
+procedure TdlgQuery.btnParamValuesClick(Sender: TObject);
+var
+ aConn : TffSQLConnection;
+ SaveSyntaxOnly : Boolean;
+begin
+ aConn := TffSQLConnection(FConnections[cmbQuery.ItemIndex]);
+ { if query isn't active then update from memo etc and prepare statement }
+ if not aConn.Query.Active then begin
+ SaveSyntaxOnly := FSyntaxOnly;
+ FSupressSyntaxOKDialog := True;
+ try
+ FSyntaxOnly := True;
+ pbExecuteClick(Sender);
+ finally
+ FSyntaxOnly := SaveSyntaxOnly;
+ FSupressSyntaxOKDialog := False;
+ end;
+ end;
+
+ if aConn.Query.ParamCount=0 then begin
+ MessageDlg('Current Query has no parameters', mtInformation, [mbOK], 0);
+ Exit;
+ end;
+
+ if not Assigned(aConn.dlgParams) then
+ aConn.dlgParams := TdlgParams.Create(Self);
+
+ if aConn.dlgParams.EditParamValues(aConn.Query.Params) then
+ if aConn.Query.Active then begin
+ FSuppressParamsDialog := True;
+ try
+ pbExecuteClick(Sender);
+ finally
+ FSuppressParamsDialog := False;
+ end;
+ end;
+end;
+{End !!.11}
+
+end.
+
diff --git a/components/flashfiler/sourcelaz/explorer/dgregsrv.dfm b/components/flashfiler/sourcelaz/explorer/dgregsrv.dfm
new file mode 100644
index 000000000..4f6cea25d
Binary files /dev/null and b/components/flashfiler/sourcelaz/explorer/dgregsrv.dfm differ
diff --git a/components/flashfiler/sourcelaz/explorer/dgregsrv.pas b/components/flashfiler/sourcelaz/explorer/dgregsrv.pas
new file mode 100644
index 000000000..252762962
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/dgregsrv.pas
@@ -0,0 +1,179 @@
+{*********************************************************}
+{* Dialog to register/unregister servers *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit dgregsrv;
+
+interface
+
+uses
+ Windows,
+ Messages,
+ SysUtils,
+ Classes,
+ Graphics,
+ Controls,
+ Forms,
+ Dialogs,
+ StdCtrls,
+ Buttons,
+ ExtCtrls,
+ ffllbase,
+ ubase,
+ uconsts;
+
+type
+ TdlgRegisteredServers = class(TForm)
+ btnRemove: TBitBtn;
+ btnCancel: TBitBtn;
+ lstServers: TListBox;
+ btnAdd: TBitBtn;
+ lblRegServers: TLabel;
+ cboServerName: TComboBox;
+ lblNewServer: TLabel;
+ btnOK: TBitBtn;
+ Bevel1: TBevel;
+ procedure btnRemoveClick(Sender: TObject);
+ procedure btnAddClick(Sender: TObject);
+ procedure cboServerNameChange(Sender: TObject);
+ procedure btnOKClick(Sender: TObject);
+ procedure FormCreate(Sender: TObject);
+ procedure lstServersClick(Sender: TObject);
+ procedure FormShow(Sender: TObject);
+ private
+ procedure SetCtrlStates;
+ protected
+ public
+ procedure FillComboBox;
+ end;
+
+function ShowRegisteredServersDlg: TModalResult;
+
+var
+ dlgRegisteredServers: TdlgRegisteredServers;
+
+implementation
+
+{$R *.DFM}
+
+uses
+ ffllprot, {!!.07}
+ uconfig;
+
+function ShowRegisteredServersDlg: TModalResult;
+begin
+ with TdlgRegisteredServers.Create(nil) do
+ try
+ lstServers.Clear;
+ lstServers.Items.AddStrings(Config.RegisteredServers);
+ FillComboBox;
+ Result := ShowModal;
+ finally
+ Free;
+ end;
+end;
+
+procedure TdlgRegisteredServers.FormCreate(Sender: TObject);
+begin
+ HelpContext := hcRegisteredServersDlg;
+end;
+
+procedure TdlgRegisteredServers.FillComboBox;
+var
+ S: Integer;
+begin
+
+ { Fill combo box dropdown with all the available server names that are not
+ already registered }
+ cboServerName.Items.Clear;
+ with ServerList do
+ for S := 0 to Count - 1 do
+ if (lstServers.Items.IndexOf(Items[S].ServerName) = -1) and
+ (Items[S].ServerName<>ffc_SingleUserServerName) then {!!.07}
+ cboServerName.Items.Add(Items[S].ServerName);
+end;
+
+procedure TdlgRegisteredServers.cboServerNameChange(Sender: TObject);
+begin
+ btnAdd.Enabled := FFShStrTrim(cboServerName.Text) <> '';
+end;
+
+procedure TdlgRegisteredServers.btnAddClick(Sender: TObject);
+begin
+ lstServers.Items.Add(cboServerName.Text);
+ cboServerName.ItemIndex := -1;
+ cboServerName.Text := '';
+ FillComboBox;
+ btnAdd.Enabled := False;
+end;
+
+procedure TdlgRegisteredServers.btnRemoveClick(Sender: TObject);
+var
+ I: Integer;
+begin
+ with lstServers do begin
+ I := 0;
+ while I < Items.Count do begin
+ if Selected[I] then
+ Items.Delete(I)
+ else
+ Inc(I);
+ end;
+ end;
+ FillComboBox;
+ SetCtrlStates;
+end;
+
+procedure TdlgRegisteredServers.btnOKClick(Sender: TObject);
+begin
+ with Config.RegisteredServers do begin
+ Clear;
+ AddStrings(lstServers.Items);
+ end;
+ Config.Save;
+end;
+
+procedure TdlgRegisteredServers.lstServersClick(Sender: TObject);
+begin
+ SetCtrlStates;
+end;
+
+procedure TdlgRegisteredServers.SetCtrlStates;
+begin
+ btnRemove.Enabled := (lstServers.SelCount > 0);
+end;
+
+procedure TdlgRegisteredServers.FormShow(Sender: TObject);
+begin
+ SetCtrlStates;
+end;
+
+end.
+
diff --git a/components/flashfiler/sourcelaz/explorer/dgselidx.dfm b/components/flashfiler/sourcelaz/explorer/dgselidx.dfm
new file mode 100644
index 000000000..001683a0a
Binary files /dev/null and b/components/flashfiler/sourcelaz/explorer/dgselidx.dfm differ
diff --git a/components/flashfiler/sourcelaz/explorer/dgselidx.pas b/components/flashfiler/sourcelaz/explorer/dgselidx.pas
new file mode 100644
index 000000000..c8ed737e0
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/dgselidx.pas
@@ -0,0 +1,155 @@
+{*********************************************************}
+{* Dialog to select a table index (for reindexing) *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit dgselidx;
+
+interface
+
+uses
+ Windows,
+ Messages,
+ SysUtils,
+ Classes,
+ Graphics,
+ Controls,
+ Forms,
+ Dialogs,
+ StdCtrls,
+ Grids,
+ Buttons,
+ ExtCtrls,
+ ffllbase,
+ ubase,
+ uelement,
+ uentity;
+
+type
+ TdlgSelectIndex = class(TForm)
+ btnOK: TBitBtn;
+ btnCancel: TBitBtn;
+ Label1: TLabel;
+ grdIndexes: TStringGrid;
+ edtTableName: TEdit;
+ procedure FormShow(Sender: TObject);
+ procedure FormCreate(Sender: TObject);
+ procedure FormDestroy(Sender: TObject);
+ procedure btnOKClick(Sender: TObject);
+ private
+ FTable : TffeTableItem;
+ FIndexNum: Integer;
+ FIndexes: TffeIndexList;
+ FCoverage: TffShStr;
+ public
+ end;
+
+function SelectIndexDlg(aTable : TffeTableItem;
+ var aIndexNum: Integer): TModalResult;
+
+var
+ dlgSelectIndex: TdlgSelectIndex;
+
+implementation
+
+{$R *.DFM}
+
+function SelectIndexDlg(aTable : TffeTableItem;
+ var aIndexNum: Integer): TModalResult;
+begin
+ with TdlgSelectIndex.Create(nil) do
+ try
+ FTable := aTable;
+ FIndexes.Empty;
+ Result := ShowModal;
+ aIndexNum := FIndexNum;
+ finally
+ Free;
+ end;
+end;
+
+procedure TdlgSelectIndex.FormShow(Sender: TObject);
+var
+ I, J: Integer;
+ OldCursor: TCursor;
+begin
+ OldCursor := Screen.Cursor;
+ Screen.Cursor := crHourglass;
+ try
+ with FTable do begin
+ edtTableName.Text := TableName;
+ FIndexes.LoadFromDict(Dictionary);
+ with grdIndexes do begin
+ RowCount := FIndexes.Count + 1;
+ for I := 0 to FIndexes.Count - 1 do begin
+ Cells[0, I + 1] := FIndexes.Items[I].Name;
+ if I = 0 then
+ FCoverage := 'physical record position'
+ else with FIndexes.Items[I] do begin
+ case iiKeyTypeIndex of
+ 0: begin
+ FCoverage := 'Comp: ';
+ for J := 0 to FieldCount - 1 do begin
+ FCoverage := FCoverage + FieldName[J];
+ if J < FieldCount - 1 then
+ FCoverage := FCoverage + ', ';
+ end;
+ end;
+ 1: begin
+ FCoverage := 'User: ';
+ end;
+ end;
+ end;
+ Cells[1, I + 1] := FCoverage;
+ end;
+ end;
+ end;
+ finally
+ Screen.Cursor := OldCursor;
+ end;
+end;
+
+procedure TdlgSelectIndex.FormCreate(Sender: TObject);
+begin
+ FIndexes := TffeIndexList.Create;
+ grdIndexes.Cells[0, 0] := 'Index Name';
+ grdIndexes.Cells[1, 0] := 'Coverage';
+end;
+
+procedure TdlgSelectIndex.FormDestroy(Sender: TObject);
+begin
+ FIndexes.Free;
+end;
+
+procedure TdlgSelectIndex.btnOKClick(Sender: TObject);
+begin
+ FIndexNum := grdIndexes.Selection.Top - 1;
+end;
+
+end.
diff --git a/components/flashfiler/sourcelaz/explorer/dgsqlops.dfm b/components/flashfiler/sourcelaz/explorer/dgsqlops.dfm
new file mode 100644
index 000000000..8aebd1c9e
Binary files /dev/null and b/components/flashfiler/sourcelaz/explorer/dgsqlops.dfm differ
diff --git a/components/flashfiler/sourcelaz/explorer/dgsqlops.pas b/components/flashfiler/sourcelaz/explorer/dgsqlops.pas
new file mode 100644
index 000000000..47755864e
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/dgsqlops.pas
@@ -0,0 +1,172 @@
+{*********************************************************}
+{* Query options dialog *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit dgsqlops;
+
+interface
+
+uses
+ Windows,
+ Messages,
+ SysUtils,
+ Classes,
+ Graphics,
+ Controls,
+ Forms,
+ Dialogs,
+ StdCtrls;
+
+type
+ TfrmSQLOps = class(TForm)
+ gbExecute: TGroupBox;
+ gbOther: TGroupBox;
+ cbSyntaxOnly: TCheckBox;
+ lblTimeout: TLabel;
+ edtTimeout: TEdit;
+ btnOK: TButton;
+ btnCancel: TButton;
+ cbLiveDS: TCheckBox;
+ edtQueryName: TEdit;
+ Label2: TLabel;
+ btnFont: TButton;
+ FontDialog: TFontDialog;
+ procedure btnFontClick(Sender: TObject);
+ procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
+ private
+ { Private declarations }
+ procedure SetQueryName(aQueryName : string);
+ procedure SetFont(aFont : TFont);
+ procedure SetSyntaxOnly(aSetting : Boolean);
+ procedure SetTimeout(aTimeout : Integer);
+ procedure SetReqLiveDS(aSetting : Boolean);
+ function GetTimeout : Integer;
+ function GetQueryName : string;
+ function GetSyntaxOnly : Boolean;
+ function GetReqLiveDS : Boolean;
+ function GetFont : TFont;
+ public
+ { Public declarations }
+ property SyntaxOnly : Boolean
+ read GetSyntaxOnly
+ write SetSyntaxOnly;
+ property Timeout : Integer
+ read GetTimeOut
+ write SetTimeout;
+ property RequestLiveDS : Boolean
+ read GetReqLiveDS
+ write SetReqLiveDS;
+ property QueryName : string
+ read GetQueryName
+ write SetQueryName;
+ property Font : TFont
+ read GetFont
+ write SetFont;
+ end;
+
+var
+ frmSQLOps: TfrmSQLOps;
+
+implementation
+
+{$R *.DFM}
+
+{ TfrmSQLOps }
+
+procedure TfrmSQLOps.SetFont(aFont : TFont);
+begin
+ FontDialog.Font := aFont;
+end;
+
+procedure TfrmSQLOps.SetQueryName(aQueryName : string);
+begin
+ edtQueryName.Text := aQueryName;
+end;
+
+procedure TfrmSQLOps.btnFontClick(Sender: TObject);
+begin
+ FontDialog.Execute;
+end;
+
+function TfrmSQLOps.GetTimeout: Integer;
+begin
+ Result := StrToInt(edtTimeout.Text);
+end;
+
+function TfrmSQLOps.GetQueryName: string;
+begin
+ result := edtQueryName.Text;
+end;
+
+function TfrmSQLOps.GetSyntaxOnly : Boolean;
+begin
+ Result := cbSyntaxOnly.Checked;
+end;
+
+function TfrmSQLOps.GetReqLiveDS : Boolean;
+begin
+ Result := cbLiveDS.Checked;
+end;
+
+function TfrmSQLOps.GetFont : TFont;
+begin
+ Result := FontDialog.Font;
+end;
+
+procedure TfrmSQLOps.SetReqLiveDS(aSetting : Boolean);
+begin
+ cbLiveDS.Checked := aSetting;
+end;
+
+procedure TfrmSQLOps.SetSyntaxOnly(aSetting : Boolean);
+begin
+ cbSyntaxOnly.Checked := aSetting;
+end;
+
+procedure TfrmSQLOps.SetTimeout(aTimeout : Integer);
+begin
+ edtTimeout.Text := IntToStr(aTimeout);
+end;
+
+procedure TfrmSQLOps.FormCloseQuery(Sender: TObject;
+ var CanClose: Boolean);
+var
+ Code : Integer;
+ Int : Integer;
+begin
+ Val(edtTimeout.Text, Int, Code);
+ CanClose := (Code = 0) and (Int > -2);
+ if not CanClose then begin
+ MessageBeep(0);
+ MessageDlg('Timeout must be an integer > -1.', mtError, [mbOk], 0);
+ end;
+end;
+
+end.
diff --git a/components/flashfiler/sourcelaz/explorer/dgtable.dfm b/components/flashfiler/sourcelaz/explorer/dgtable.dfm
new file mode 100644
index 000000000..67ddc9aec
Binary files /dev/null and b/components/flashfiler/sourcelaz/explorer/dgtable.dfm differ
diff --git a/components/flashfiler/sourcelaz/explorer/dgtable.pas b/components/flashfiler/sourcelaz/explorer/dgtable.pas
new file mode 100644
index 000000000..97f04f617
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/dgtable.pas
@@ -0,0 +1,1964 @@
+{*********************************************************}
+{* FlashFiler: Table Browser *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit dgtable;
+
+interface
+
+uses
+ Windows,
+ Messages,
+ SysUtils,
+ Classes,
+ Graphics,
+ Controls,
+ Forms,
+ Dialogs,
+ Db,
+ StdCtrls,
+ Grids,
+ DBGrids,
+ DBCtrls,
+ ExtCtrls,
+ Buttons,
+ Menus,
+ ComCtrls,
+ ffdb,
+ ffdbbase,
+ fflllgcy,
+ ffllbase,
+ ffclreng,
+ ffllprot,
+ fflllog,
+ ffutil,
+ ffclbase,
+ Mask,
+ dgSetRng,
+ uEntity,
+ uConsts;
+
+
+type
+ TdlgTable = class(TForm)
+ dsTableBrowser: TDataSource;
+ navTableBrowser: TDBNavigator;
+ barStatus: TStatusBar;
+ MainMenu1: TMainMenu;
+ mnuTable: TMenuItem;
+ N1: TMenuItem;
+ mnuTableClose: TMenuItem;
+ mnuView: TMenuItem;
+ mnuViewRefresh: TMenuItem;
+ N2: TMenuItem;
+ mnuViewShowRecordCount: TMenuItem;
+ mnuViewShowFilter: TMenuItem;
+ mnuTableResetCol: TMenuItem;
+ mnuOptions: TMenuItem;
+ mnuOptionsDebug: TMenuItem;
+ mnuOptionsTimeout: TMenuItem;
+ N3: TMenuItem;
+ paClient: TPanel;
+ grdTableBrowser: TDBGrid;
+ pcBlobfields: TPageControl;
+ splGridAndPageControl: TSplitter;
+ pnlIndex: TPanel;
+ lblIndex: TLabel;
+ cboIndex: TComboBox;
+ lblFind: TLabel;
+ edtFind: TEdit;
+ btnFindNear: TButton;
+ pnlFilter: TPanel;
+ lblFilter: TLabel;
+ btnSetFilter: TButton;
+ pnlRange: TPanel;
+ laRangeStartDesc: TLabel;
+ btnSetClearRange: TButton;
+ tsMemoTemplate: TTabSheet;
+ tsGraphicTemplate: TTabSheet;
+ tsByteArrayTemplate: TTabSheet;
+ cbStretch: TCheckBox;
+ btnLoadGraphic: TButton;
+ Image: TImage;
+ tsGenericBlobTemplate: TTabSheet;
+ meGeneric: TMemo;
+ mnuViewShowRange: TMenuItem;
+ mnuViewShowBLOBFields: TMenuItem;
+ Label2: TLabel;
+ btnClearBA: TButton;
+ OpenDialog: TOpenDialog;
+ SaveDialog: TSaveDialog;
+ btnLoadGeneric: TButton;
+ btnSaveGeneric: TButton;
+ btnClearGeneric: TButton;
+ btnSaveGraphic: TButton;
+ btnClearGraphic: TButton;
+ Label3: TLabel;
+ meByteArray: TMaskEdit;
+ N4: TMenuItem;
+ mnuTablePrintPreview: TMenuItem;
+ mnuTableDesignReport: TMenuItem;
+ dbMemo: TDBMemo;
+ btnLoadMemo: TButton;
+ btnSaveMemo: TButton;
+ btnClearMemo: TButton;
+ laRangeEndDesc: TLabel;
+ btnEditRange: TButton;
+ laRangeStart: TLabel;
+ laRangeEnd: TLabel;
+ cbWordwrap: TCheckBox;
+ mnuTableCopyToTable: TMenuItem;
+ N5: TMenuItem;
+ mnuTableDeleteRecords: TMenuItem;
+ cboFilter: TComboBox;
+ procedure FormCreate(Sender: TObject);
+ procedure FormShow(Sender: TObject);
+ procedure cboIndexChange(Sender: TObject);
+ procedure btnFindClick(Sender: TObject);
+ procedure mnuTableCloseClick(Sender: TObject);
+ procedure FormClose(Sender: TObject; var Action: TCloseAction);
+ procedure mnuViewRefreshClick(Sender: TObject);
+ procedure mnuViewShowFilterClick(Sender: TObject);
+ procedure btnFilterClick(Sender: TObject);
+ procedure FormDestroy(Sender: TObject);
+ procedure btnFindNearClick(Sender: TObject);
+ procedure btnSetFilterClick(Sender: TObject);
+ procedure edtFindEnter(Sender: TObject);
+ procedure cboFilterEnter(Sender: TObject);
+ procedure mnuViewShowRecordCountClick(Sender: TObject);
+ procedure mnuTableResetColClick(Sender: TObject);
+ procedure grdTableBrowserKeyDown(Sender: TObject; var Key: Word;
+ Shift: TShiftState);
+ procedure mnuOptionsDebugClick(Sender: TObject);
+ procedure mnuOptionsTimeoutClick(Sender: TObject);
+ procedure FormKeyDown(Sender: TObject; var Key: Word;
+ Shift: TShiftState);
+ procedure cbStretchClick(Sender: TObject);
+ procedure btnClearBAClick(Sender: TObject);
+ procedure pcBlobfieldsChange(Sender: TObject);
+ procedure mnuViewShowBLOBFieldsClick(Sender: TObject);
+ procedure btnLoadMemoClick(Sender: TObject);
+ procedure btnSaveMemoClick(Sender: TObject);
+ procedure btnLoadGenericClick(Sender: TObject);
+ procedure btnSaveGenericClick(Sender: TObject);
+ procedure btnClearMemoClick(Sender: TObject);
+ procedure btnLoadGraphicClick(Sender: TObject);
+ procedure btnSaveGraphicClick(Sender: TObject);
+ procedure btnClearGraphicClick(Sender: TObject);
+ procedure btnClearGenericClick(Sender: TObject);
+ procedure meByteArrayKeyPress(Sender: TObject; var Key: Char);
+ procedure mnuTablePrintPreviewClick(Sender: TObject);
+ procedure btnSetClearRangeClick(Sender: TObject);
+ procedure mnuTableDesignReportClick(Sender: TObject);
+ procedure tsMemoTemplateResize(Sender: TObject);
+ procedure tsGraphicTemplateResize(Sender: TObject);
+ procedure tsGenericBlobTemplateResize(Sender: TObject);
+ procedure tsByteArrayTemplateResize(Sender: TObject);
+ procedure btnEditRangeClick(Sender: TObject);
+ procedure mnuViewShowRangeClick(Sender: TObject);
+ procedure FormResize(Sender: TObject);
+ procedure meByteArrayChange(Sender: TObject);
+ procedure cbWordwrapClick(Sender: TObject);
+ procedure mnuTableCopyToTableClick(Sender: TObject);
+ procedure mnuTableDeleteRecordsClick(Sender: TObject); {!!.07}
+ private
+ procedure FTableAfterPost(DataSet: TDataSet); {!!.07}
+ procedure FTableAfterScroll(DataSet: TDataSet);
+ procedure FTableAfterCancel(DataSet: TDataSet);
+ procedure FTableBeforeEdit(DataSet: TDataSet);
+ procedure FTableBeforeInsert(DataSet: TDataSet);
+ procedure ViewActiveBlobField;
+ procedure SetRange;
+ protected
+ FClient : TffClient;
+ FDatabaseName : TffName;
+ FEngine : TffRemoteServerEngine;
+ FLog : TffBaseLog;
+ FProtocol : TffProtocolType;
+ FReadOnly : boolean;
+ FServerName : TffNetAddress;
+ FSession : TFfSession;
+ FTable : TFfTable;
+ FTableName : TffName;
+ FUserName : TffName;
+ FPassword : TffName;
+ FTransport : TffLegacyTransport;
+ FTableItem : TffeTableItem;
+
+ dtShown : boolean;
+ {-Set to True if the form was actually displayed. Lets the form know
+ it should save user preferences. }
+ InRange : boolean;
+ { true if SetRange has been performed }
+ FRangeValues : TffRangeValues;
+ { the start and end values for the active range }
+ BeforeInitDone : Boolean;
+ { to keep UpdateDisplay from being called repeatedly }
+ BAKeyPressDetected : Boolean;
+ { to avoid going to Edit mode when changing ByteArray edit programmatically }
+ AddedComponentCount : Integer;
+ { used to avoid duplicate names in dynamically added components }
+ FDynEnabledComponents, {!!.11}
+ FDynReadOnlyComponents: TList;
+ { used to easily enable and disable the dynamically added components }
+
+ procedure SavePreferences;
+ procedure LoadPreferences;
+ procedure WMGetMinMaxInfo(var Message : TWMGetMinMaxInfo);
+ message WM_GETMINMAXINFO;
+ function HasBlobOrByteArrayField : Boolean; {!!.07}
+ procedure GenerateRangeDisplayStrings; {!!.07}
+ protected { access methods }
+ procedure SetReadOnly(const Value : Boolean);
+ public
+ procedure CloseDuringShow(var Message : TMessage); message ffm_Close;
+ procedure UpdateDisplay; {!!.01}
+ procedure UpdateDefaultTimeout; {!!.11}
+
+ property Protocol : TffProtocolType
+ read FProtocol write FProtocol;
+
+ property ServerName : TffNetAddress
+ read FServerName write FServerName;
+
+ property DatabaseName : TffName
+ read FDatabaseName write FDatabaseName;
+
+ property Log : TffBaseLog
+ read FLog write FLog;
+
+ property Password : TffName
+ read FPassword write FPassword;
+
+ property TableName : TffName
+ read FTableName write FTableName;
+
+ property ReadOnly : boolean
+ read FReadOnly write SetReadOnly;
+
+ property UserName : TffName
+ read FUserName write FUserName;
+
+ property TableItem : TffeTableItem
+ read FTableItem write FTableItem;
+ end;
+
+var
+ dlgTable: TdlgTable;
+
+implementation
+
+uses
+ dgCpyTbl, {!!.10}
+ typinfo, {!!.07}
+ jpeg, {!!.07}
+ uReportEngineInterface, {!!.07}
+ {$IFDEF DCC6ORLater}
+ variants, {!!.07}
+ {$ENDIF}
+ FFLLComm,
+ FFLLComp,
+ FFLLEng,
+ uConfig;
+
+{$R *.DFM}
+
+const
+ MaxFilterComboItems = 10; {!!.11}
+
+procedure TdlgTable.FormCreate(Sender: TObject);
+begin
+
+ FClient := nil;
+ FDatabaseName := '';
+ FEngine := nil;
+ FLog := nil;
+ FProtocol := ptRegistry;
+ FReadOnly := False;
+ FServerName := '';
+ FSession := nil;
+ FTable := nil;
+ FTableName := '';
+ FTransport := nil;
+ FPassword := '';
+ FUserName := '';
+
+ InRange := False;
+ BeforeInitDone := True;
+ BAKeyPressDetected := False;
+ AddedComponentCount := 0;
+ FDynEnabledComponents := TList.Create; {!!.11}
+ FDynReadOnlyComponents := TList.Create; {!!.11}
+end;
+{--------}
+procedure TdlgTable.SetReadOnly(const Value : Boolean);
+var
+ i : Integer;
+ bm: TBookmark;
+ FieldsTags: TList;
+begin
+ FReadOnly := Value;
+ grdTableBrowser.ReadOnly := FReadOnly;
+ {Begin !!.11}
+ { only update the buttons after they are created,
+ and table when it's opened. }
+ if not dtShown then
+ Exit;
+ bm := FTable.GetBookmark;
+ FieldsTags := TList.Create;
+ try
+ { save blob-support pointers }
+ for i := 0 to Pred(FTable.FieldCount) do
+ FieldsTags.Add(Pointer(FTable.Fields[i].Tag));
+ FTable.Close;
+ FTable.ReadOnly := ReadOnly;
+ FTable.Open;
+ for i := 0 to Pred(FTable.FieldCount) do
+ FTable.Fields[i].Tag := Integer(FieldsTags[i]);
+ FTable.GotoBookmark(bm);
+ finally
+ FTable.FreeBookmark(bm);
+ FieldsTags.Free;
+ end;
+ for i := 0 to Pred(ComponentCount) do
+ if (Components[i] is TButton) and
+ (((Components[i] as TButton).Caption='Load from file...') or
+ ((Components[i] as TButton).Caption='Save to file...') or
+ ((Components[i] as TButton).Caption='Clear')) then
+ (Components[i] as TButton).Enabled := not FReadOnly;
+ {End !!.11}
+end;
+{--------}
+procedure TdlgTable.FormShow(Sender: TObject);
+var
+ aServerName : string;
+ aAddress : string;
+ I : Integer;
+ OldPass, OldUser : string;
+
+ {$IFNDEF DCC5OrLater}
+ function IsPublishedProp(Source : TObject; const PropName : string) : Boolean;
+ var
+ P: PPropInfo;
+ begin
+ P := GetPropInfo(Source.ClassInfo, PropName);
+ Result := P <> nil;
+ end;
+ {--------}
+ function GetStrProp(Source : TObject; const PropName : string) : string;
+ var
+ P: PPropInfo;
+ begin
+ P := GetPropInfo(Source.ClassInfo, PropName);
+ if Assigned(P) then begin
+ Result := TypInfo.GetStrProp(Source, P);
+ end else
+ Result := '';
+ end;
+ {--------}
+ function SetStrProp(Source : TObject; const PropName, Value : string) : string;
+ var
+ P: PPropInfo;
+ begin
+ P := GetPropInfo(Source.ClassInfo, PropName);
+ if Assigned(P) then
+ TypInfo.SetStrProp(Source, P, Value);
+ end;
+ {--------}
+ procedure SetMethodProp(Source : TObject; const PropName : string; Value : TMethod);
+ var
+ P: PPropInfo;
+ begin
+ P := GetPropInfo(Source.ClassInfo, PropName);
+ if Assigned(P) then
+ TypInfo.SetMethodProp(Source, P, Value);
+ end;
+ {--------}
+ function GetMethodProp(Source : TObject; const PropName : string) : TMethod;
+ var
+ P: PPropInfo;
+ begin
+ P := GetPropInfo(Source.ClassInfo, PropName);
+ if Assigned(P) then
+ Result := TypInfo.GetMethodProp(Source, P);
+ end;
+ {$ENDIF}
+ {Begin !!.07}
+ function CopyComponent(Source : TComponent) : TComponent;
+ var
+ PropStream : TMemoryStream;
+ OldText, OldName : String;
+ begin
+ Result := Nil;
+ if assigned(Source) then
+ begin
+ PropStream := TMemoryStream.Create;
+ try
+ //prevent doubled component names
+ OldName := Source.Name;
+ Source.Name := OldName + IntToStr(AddedComponentCount);
+ Inc(AddedComponentCount);
+ //Save the "stored" properties to memory
+ PropStream.WriteComponent(Source);
+ Source.Name := OldName;
+ //e.g. TEdit will change it's content if renamed
+ if IsPublishedProp(Source,'Text') then
+ OldText := GetStrProp(Source,'Text')
+ else
+ //Some Captions may face the same problem
+ if IsPublishedProp(Source,'Caption') then
+ OldText := GetStrProp(Source,'Caption');
+ Result := TComponentClass(Source.ClassType).Create(Source.Owner);
+ PropStream.Position := 0;
+ PropStream.ReadComponent(Result);
+// Result.Name := OldName + IntToStr(AddedComponentCount);
+ //Handle Components with a "Text" or "Caption" -property;
+ //e.g. TEdit, TLabel
+ if IsPublishedProp(Source,'Text') then
+ begin
+ SetStrProp(Source,'Text',OldText);
+ SetStrProp(Result,'Text',OldText);
+ end
+ else
+ if IsPublishedProp(Source,'Caption') then
+ begin
+ SetStrProp(Source,'Caption',OldText);
+ SetStrProp(Result,'Caption',OldText);
+ end;
+ finally
+ PropStream.Free;
+ end;
+ end;
+ end;
+
+
+
+ { generates a new tabsheet and hooks up
+ components on the new tabsheet to the field }
+ procedure CreateNewBlobTabSheet(SheetToCopy : TTabSheet; OnResizeProc : TNotifyEvent; FieldIndex : Integer);
+ var
+ NewSheet : TTabSheet;
+ Idx : Integer;
+ NewComponent : TComponent;
+ begin
+ NewSheet := TTabSheet.Create(pcBlobFields);
+ NewSheet.PageControl := pcBlobFields;
+ NewSheet.Caption := FTable.Fields[FieldIndex].FieldName;
+ {$IFDEF DCC4OrLater}
+ NewSheet.OnResize := OnResizeProc;
+ {$ENDIF}
+
+ for Idx := 0 to SheetToCopy.ControlCount-1 do begin
+ NewComponent := CopyComponent(SheetToCopy.Controls[Idx]);
+ TControl(NewComponent).Parent := NewSheet;
+ if IsPublishedProp(NewComponent, 'DataField') then
+ SetStrProp(NewComponent, 'DataField', FTable.Fields[FieldIndex].FieldName);
+ if (IsPublishedProp(NewComponent, 'OnClick')) then
+ SetMethodProp(NewComponent, 'OnClick', GetMethodProp(SheetToCopy.Controls[Idx], 'OnClick'));
+ if (IsPublishedProp(NewComponent, 'OnKeyPress')) then
+ SetMethodProp(NewComponent, 'OnKeyPress', GetMethodProp(SheetToCopy.Controls[Idx], 'OnKeyPress'));
+ if (IsPublishedProp(NewComponent, 'OnChange')) then
+ SetMethodProp(NewComponent, 'OnChange', GetMethodProp(SheetToCopy.Controls[Idx], 'OnChange'));
+// if NewComponent. IS TCheckBox
+ // SetStrProp(NewComponent, 'OnClick', FTable.Fields.Fields[FieldIndex].FieldName);
+ { save pointer to the control displaying the field }
+ if (NewComponent IS TImage) or { graphictemplate }
+ (NewComponent IS TMaskEdit) or { bytearraytemplate }
+ (NewComponent IS TMemo) or { generictemplate }
+ (NewComponent IS TdbMemo) then { memotemplate }
+ FTable.Fields[FieldIndex].Tag := Integer(NewComponent);
+
+ end;
+ end;
+ {End !!.07}
+
+begin
+ dtShown := False;
+ try
+ { Set up the connection. }
+ FTransport := TffLegacyTransport.Create(nil);
+ with FTransport do begin
+ Mode := fftmSend;
+ Protocol := FProtocol;
+ EventLog := FLog;
+ if Assigned(FLog) then begin
+ EventLogEnabled := True;
+ EventLogOptions := [fftpLogErrors];
+ end;
+ ServerName := FServerName;
+ end;
+
+ FEngine := TffRemoteServerEngine.Create(nil);
+ FEngine.Transport := FTransport;
+
+ FClient := TffClient.Create(nil);
+ FClient.ServerEngine := FEngine;
+ FClient.AutoClientName := True;
+ FClient.TimeOut := Config.DefaultTimeout; {!!.11}
+
+ FSession := TffSession.Create(nil);
+ FSession.ClientName := FClient.ClientName;
+ FSession.AutoSessionName := True;
+ OldPass := ffclPassword;
+ OldUser := ffclUserName;
+ try
+ if FPassword <> '' then begin
+ ffclPassword := FPassword;
+ ffclUserName := FUserName;
+ end;
+ FSession.Open;
+ finally
+ ffclPassword := OldPass;
+ ffclUserName := OldUser;
+ end;
+
+ FTable := TffTable.Create(nil);
+ FTable.SessionName := FSession.SessionName;
+ FTable.DatabaseName := FDatabaseName;
+ FTable.TableName := FTableName;
+ FTable.AfterPost := FTableAfterPost; {!!.07}
+ FTable.AfterDelete := FTableAfterPost; {!!.07}
+ FTable.AfterScroll := FTableAfterScroll; {!!.07}
+ FTable.AfterCancel := FTableAfterCancel; {!!.07}
+ FTable.BeforeEdit := FTableBeforeEdit;
+ FTable.BeforeInsert := FTableBeforeInsert;
+ FTable.ReadOnly := ReadOnly; {!!.11}
+ FTable.Open;
+
+ { Set up the indexes }
+ cboIndex.Items.Clear;
+ with FTable.IndexDefs do begin
+ Clear;
+ Update;
+ for I := 0 to Count - 1 do
+ cboIndex.Items.Add(Items[I].Name);
+ end;
+
+ cboIndex.ItemIndex := 0;
+ FTable.IndexName := cboIndex.Items[cboIndex.ItemIndex];
+
+ { Update the find controls }
+ cboIndexChange(nil);
+
+ FFSeparateAddress(FTransport.ServerName, aServerName, aAddress);
+ Self.Caption := format('%s : %s : %s',
+ [aServerName, FDatabaseName, FTableName]);
+
+ dsTableBrowser.DataSet := FTable;
+
+ {Begin !!.07}
+ { check if there are any BLOB fields in the table
+ and populate the pagecontrol with appropriate controls if so }
+
+ { make the templates invisible }
+ for I := 0 to pcBlobFields.PageCount-1 do
+ pcBlobFields.Pages[I].TabVisible := False;
+
+ { generate new tabsheets for blobfields }
+ for I := 0 to FTable.Dictionary.FieldCount-1 do begin
+ case FTable.Dictionary.FieldType[I] of
+ fftBLOBMemo,
+ fftBLOBFmtMemo : CreateNewBlobTabSheet(tsMemoTemplate, tsMemoTemplateResize, I);
+ fftBLOBGraphic : CreateNewBlobTabSheet(tsGraphicTemplate, tsGraphicTemplateResize, I);
+ fftByteArray : CreateNewBlobTabSheet(tsByteArrayTemplate, tsByteArrayTemplateResize, I);
+ fftBLOB,
+ fftBLOBOLEObj,
+ fftBLOBDBSOLEObj,
+ fftBLOBTypedBin,
+ fftBLOBFile : CreateNewBlobTabSheet(tsGenericBlobTemplate, tsGenericBlobTemplateResize, I);
+ end;
+ end;
+
+ {End !!.07}
+
+ LoadPreferences;
+
+ BeforeInitDone := False;
+ UpdateDisplay;
+
+ ViewActiveBlobField; {!!.07}
+
+ { make sure no column exceeds screen width } {!!.07}
+ for I := 0 to grdTableBrowser.Columns.Count-1 do begin
+ if grdTableBrowser.Columns[i].Width>(Width DIV 5)*4 then
+ grdTableBrowser.Columns[i].Width := (Width DIV 5)*4;
+ end;
+
+ dtShown := True;
+ { update newly created dynamic components }
+ ReadOnly := FReadOnly; {!!.11}
+
+ { large font support... }
+ if (Screen.PixelsPerInch/PixelsPerInch)>1.001 then begin
+ Height := Round(Height * (Screen.PixelsPerInch/PixelsPerInch));
+ Width := Round(Width * (Screen.PixelsPerInch/PixelsPerInch));
+ barStatus.Height := Round(barStatus.Height * (Screen.PixelsPerInch/PixelsPerInch));
+ end;
+
+ { report menuitems }
+ mnuTablePrintPreview.Enabled := ReportEngineDLLLoaded;
+ mnuTableDesignReport.Enabled := ReportEngineDLLLoaded;
+
+ except
+ on E:Exception do begin
+ showMessage(E.message);
+ PostMessage(Handle, ffm_Close, 0, longInt(Sender));
+ end;
+ end;
+end;
+{--------}
+procedure TdlgTable.cboIndexChange(Sender: TObject);
+var
+ BaseSection : string;
+ Index : Integer;
+begin
+ BaseSection := ClassName + '.' + Self.Caption;
+ with FTable do
+ if IndexName <> cboIndex.Items[cboIndex.ItemIndex] then begin
+ IndexName := cboIndex.Items[cboIndex.ItemIndex];
+ end;
+ lblFind.Visible := cboIndex.ItemIndex > 0;
+ edtFind.Visible := cboIndex.ItemIndex > 0;
+ btnFindNear.Visible := cboIndex.ItemIndex > 0;
+ btnSetClearRange.Enabled := cboIndex.ItemIndex > 0;
+ btnEditRange.Enabled := cboIndex.ItemIndex > 0;
+ { clear range - btnSetClearRangeClick flips InRange }
+ InRange := True;
+ btnSetClearRangeClick(Self);
+ for Index := Low(FRangeValues.Field) to FTable.IndexFieldCount do begin
+ FRangeValues.Field[Index].StartNull := FFEConfigGetBoolean(BaseSection, FTable.IndexName+'_RangeStartNull'+IntToStr(Index), True);
+ FRangeValues.Field[Index].EndNull := FFEConfigGetBoolean(BaseSection, FTable.IndexName+'_RangeEndNull'+IntToStr(Index), True);
+ FRangeValues.Field[Index].StartValue := FFEConfigGetString(BaseSection, FTable.IndexName+'_RangeStartValue'+IntToStr(Index), '');
+ FRangeValues.Field[Index].EndValue := FFEConfigGetString(BaseSection, FTable.IndexName+'_RangeEndValue'+IntToStr(Index), '');;
+ end;
+ FRangeValues.RangeStartKeyExclusive := FFEConfigGetBoolean(BaseSection, FTable.IndexName+'_RangeStartKeyExclusive', False);
+ FRangeValues.RangeEndKeyExclusive := FFEConfigGetBoolean(BaseSection, FTable.IndexName+'_RangeEndKeyExclusive', False);
+ GenerateRangeDisplayStrings;
+end;
+{--------}
+procedure TdlgTable.btnFindClick(Sender: TObject);
+begin
+ try
+ FTable.FindNearest([edtFind.Text]);
+ except
+ on E: EffDatabaseError do begin
+ if E.ErrorCode = 8706 then
+ ShowMessage(format('%s not found.', [edtFind.Text]))
+ else
+ ShowMessage(E.Message);
+ end;
+ end;
+end;
+{--------}
+procedure TdlgTable.mnuTableCloseClick(Sender: TObject);
+begin
+ Close;
+end;
+{--------}
+procedure TdlgTable.FormClose(Sender: TObject; var Action: TCloseAction);
+begin
+ if dtShown then
+ SavePreferences;
+ Action := caFree;
+end;
+{--------}
+procedure TdlgTable.mnuViewRefreshClick(Sender: TObject);
+begin
+ FTable.Refresh;
+ UpdateDisplay;
+end;
+{--------}
+procedure TdlgTable.UpdateDisplay;
+begin
+ if BeforeInitDone then
+ Exit;
+ if mnuViewShowRecordCount.Checked then
+ barStatus.Panels[0].Text := 'Records: ' + FFCommaizeChL(FTable.RecordCount, ThousandSeparator)
+ else
+ barStatus.Panels[0].Text := '';
+
+ if FTable.Filtered then
+ barStatus.Panels[1].Text := 'Filter: '
+ else
+ barStatus.Panels[1].Text := 'Filter: ';
+
+ if InRange then begin
+ barStatus.Panels[2].Text := 'Range: ';
+ laRangeStart.Font.Style := [fsBold];
+ laRangeEnd.Font.Style := [fsBold];
+ laRangeStartDesc.Font.Style := [fsBold];
+ laRangeEndDesc.Font.Style := [fsBold];
+ end
+ else begin
+ barStatus.Panels[2].Text := 'Range: ';
+ laRangeStart.Font.Style := [];
+ laRangeEnd.Font.Style := [];
+ laRangeStartDesc.Font.Style := [];
+ laRangeEndDesc.Font.Style := [];
+ end;
+
+ with navTableBrowser do begin
+ VisibleButtons := [nbFirst, nbLast, nbPrior, nbNext, nbRefresh];
+ if (not FTable.ReadOnly) and (not FReadOnly) then
+ VisibleButtons := VisibleButtons + [nbInsert, nbDelete, nbEdit, nbPost, nbCancel];
+ end;
+end;
+{--------}
+procedure TdlgTable.mnuViewShowFilterClick(Sender: TObject);
+begin
+ mnuViewShowFilter.Checked := not mnuViewShowFilter.Checked;
+ pnlFilter.Visible := mnuViewShowFilter.Checked;
+ { make sure to reset statusbar etc if status changes }
+ if FTable.Filtered then
+ btnSetFilterClick(Self);
+// edtFilter.Text := ''; why remove? makes sense to keep the text, the user might need it again!
+end;
+{--------}
+procedure TdlgTable.btnFilterClick(Sender: TObject);
+begin
+ if FTable.Filtered then begin
+ FTable.Filtered := False;
+ btnSetFilter.Caption := 'S&et Filter'; {!!.03}
+ end else begin
+ FTable.Filter := cboFilter.Text;
+ FTable.Filtered := True;
+ btnSetFilter.Caption := 'Cl&ear Filter'; {!!.03}
+ end;
+end;
+{--------}
+procedure TdlgTable.FormDestroy(Sender: TObject);
+begin
+{Begin !!.05 !!.10}
+ try
+ FTable.Close;
+ finally
+ FTable.Free;
+ end;
+
+ try
+ FSession.Active := False;
+ finally
+ FSession.Free;
+ end;
+
+ try
+ FClient.Close;
+ finally
+ FClient.Free;
+ end;
+
+ try
+ FEngine.Shutdown;
+ finally
+ FEngine.Free;
+ end;
+
+ try
+ FTransport.Shutdown;
+ finally
+ FTransport.Free;
+ end;
+{End !!.05}
+ FDynEnabledComponents.Free; {!!.11}
+ FDynReadOnlyComponents.Free; {!!.11}
+end;
+{--------}
+procedure TdlgTable.CloseDuringShow(var Message : TMessage);
+begin
+ Close;
+end;
+{--------}
+procedure TdlgTable.WMGetMinMaxInfo(var Message : TWMGetMinMaxInfo);
+var
+ MinMax : PMinMaxInfo;
+begin
+ inherited;
+ MinMax := Message.MinMaxInfo;
+ MinMax^.ptMinTrackSize.x := 590;
+end;
+{--------}
+procedure TdlgTable.btnFindNearClick(Sender: TObject);
+begin
+ try
+ FTable.FindNearest([edtFind.Text]);
+ except
+ on E: EffDatabaseError do begin
+ if E.ErrorCode = 8706 then
+ ShowMessage(format('%s not found.', [edtFind.Text]))
+ else
+ ShowMessage(E.Message);
+ end;
+ end;
+end;
+{--------}
+procedure TdlgTable.btnSetFilterClick(Sender: TObject);
+{Begin !!.05}
+var
+ SavCursor : TCursor;
+begin
+ SavCursor := Screen.Cursor;
+ Screen.Cursor := crHourGlass;
+ try
+ if FTable.Filtered then begin
+ FTable.Filtered := False;
+ btnSetFilter.Caption := 'S&et Filter'; {!!.03}
+ end else begin
+ FTable.Filter := cboFilter.Text;
+ FTable.Filtered := True;
+ btnSetFilter.Caption := 'Cl&ear Filter'; {!!.03}
+ {Begin !!.11}
+ { update history list in combobox }
+ if FTable.Filter<>'' then begin
+ { does filter exist in the list? }
+ if cboFilter.Items.IndexOf(FTable.Filter)>=0 then
+ { if so remove it; no doubles needed }
+ cboFilter.Items.Delete(cboFilter.Items.IndexOf(FTable.Filter));
+ { make last filter string top of the history list }
+ cboFilter.Items.Insert(0, FTable.Filter);
+ cboFilter.ItemIndex := 0;
+ { enforce maxcount }
+ while cboFilter.Items.Count>MaxFilterComboItems do
+ cboFilter.Items.Delete(MaxFilterComboItems);
+ end;
+ {End !!.11}
+ end;
+ UpdateDisplay;
+ finally
+ Screen.Cursor := SavCursor;
+ end;
+{End !!.05}
+end;
+{--------}
+procedure TdlgTable.edtFindEnter(Sender: TObject);
+begin
+ btnSetFilter.Default := False;
+ btnFindNear.Default := True;
+end;
+{--------}
+procedure TdlgTable.cboFilterEnter(Sender: TObject);
+begin
+ btnFindNear.Default := False;
+ btnSetFilter.Default := True;
+end;
+{--------}
+procedure TdlgTable.SavePreferences;
+var
+ BaseSection : string;
+ i : Integer; {!!.11}
+begin
+ try
+ BaseSection := ClassName + '.' + Self.Caption;
+ FFEConfigSaveString(BaseSection, 'Last Filter', cboFilter.Text);
+ {Begin !!.11}
+ for i := 0 to Pred(cboFilter.Items.Count) do
+ FFEConfigSaveString(BaseSection, 'FilterHistory'+IntToStr(i), cboFilter.Items[i]);
+ {End !!.11}
+ FFEConfigSaveString(BaseSection, 'Last Find Nearest', edtFind.Text);
+ FFEConfigSaveInteger(BaseSection, 'Last Index', cboIndex.ItemIndex);
+ FFEConfigSaveBoolean(BaseSection, 'Show record count', mnuViewShowRecordCount.Checked);
+ FFEConfigSaveFormPrefs(BaseSection, Self);
+ FFEConfigSaveDBColumnPrefs(BaseSection + '.ColumnInfo', grdTableBrowser.Columns);
+ FFEConfigSaveInteger(BaseSection, 'Table Timeout', FTable.Timeout); {!!.07}
+ FFEConfigSaveInteger(BaseSection, 'PageControl size', pcBlobfields.Height); {!!.07}
+ FFEConfigSaveBoolean(BaseSection, 'Show blob fields', mnuViewShowBLOBFields.Checked); {!!.07}
+ FFEConfigSaveBoolean(BaseSection, 'Show range', mnuViewShowRange.Checked); {!!.07}
+ FFEConfigSaveBoolean(BaseSection, 'Show filter', mnuViewShowFilter.Checked); {!!.07}
+ except
+ on E:Exception do
+ ShowMessage('Error writing INI file: '+E.Message);
+ end;
+end;
+{--------}
+procedure TdlgTable.LoadPreferences;
+var
+ BaseSection : string;
+ Index : Integer;
+ s : String; {!!.11}
+begin
+ BaseSection := ClassName + '.' + Self.Caption;
+ cboFilter.Text := FFEConfigGetString(BaseSection, 'Last Filter', '');
+ {Begin !!.11}
+ for Index := 0 to Pred(MaxFilterComboItems) do begin
+ s := FFEConfigGetString(BaseSection, 'FilterHistory'+IntToStr(Index), '');
+ if s<>'' then
+ cboFilter.Items.Add(s);
+ end;
+ {End !!.11}
+ Index := FFEConfigGetInteger(BaseSection, 'Last Index', 0);
+ if (Index < cboIndex.Items.Count) then begin
+ cboIndex.ItemIndex := Index;
+ FTable.IndexName := cboIndex.Items[cboIndex.ItemIndex];
+ { Update the find controls }
+ cboIndexChange(nil);
+ end;
+ edtFind.Text := FFEConfigGetString(BaseSection, 'Last Find Nearest', '');
+ mnuViewShowRecordCount.Checked := FFEConfigGetBoolean(BaseSection, 'Show record count', True);
+ FFEConfigGetFormPrefs(BaseSection, Self);
+ FFEConfigGetDBColumnPrefs(BaseSection + '.ColumnInfo', grdTableBrowser.Columns);
+ FTable.Timeout := FFEConfigGetInteger(BaseSection, 'Table Timeout', -1); {!!.07}
+ pcBlobfields.Height := FFEConfigGetInteger(BaseSection, 'PageControl size', pcBlobfields.Height); {!!.07}
+ mnuViewShowBLOBFields.Checked := HasBlobOrByteArrayField and FFEConfigGetBoolean(BaseSection, 'Show blob fields', True); {!!.07}
+ if not HasBlobOrByteArrayField then
+ mnuViewShowBLOBFields.Enabled := False;
+ pcBlobfields.Visible := mnuViewShowBLOBFields.Checked and HasBlobOrByteArrayField;
+ splGridAndPageControl.Visible := mnuViewShowBLOBFields.Checked and HasBlobOrByteArrayField;
+ mnuViewShowRange.Checked := FFEConfigGetBoolean(BaseSection, 'Show range', True); {!!.07}
+ pnlRange.Visible := mnuViewShowRange.Checked;
+ mnuViewShowFilter.Checked := FFEConfigGetBoolean(BaseSection, 'Show filter', True); {!!.07}
+ pnlFilter.Visible := mnuViewShowFilter.Checked;
+end;
+{--------}
+procedure TdlgTable.mnuViewShowRecordCountClick(Sender: TObject);
+begin
+ mnuViewShowRecordCount.Checked := not mnuViewShowRecordCount.Checked;
+ UpdateDisplay;
+end;
+
+procedure TdlgTable.mnuTableResetColClick(Sender: TObject);
+begin
+ grdTableBrowser.Columns.RebuildColumns;
+end;
+
+procedure TdlgTable.grdTableBrowserKeyDown(Sender: TObject; var Key: Word;
+ Shift: TShiftState);
+var
+ DoPost : Boolean; {!!.11}
+begin
+ { Delete record? }
+ if ((key = VK_DELETE) and
+ (shift = []) and
+ (dsTableBrowser.State = dsBrowse)) and
+ (not grdTableBrowser.ReadOnly) then
+ if (MessageDlg('Delete record?', mtConfirmation, mbOKCancel, 0) <> idCancel) then
+ dsTableBrowser.DataSet.Delete;
+ {Begin !!.11}
+ { set field to NULL? }
+ if ((key = Ord('0')) and
+ (shift = [ssCtrl]) and
+ (not grdTableBrowser.ReadOnly) and
+ (not FTable.IsEmpty)) then begin
+ DoPost := not (FTable.State in [dsInsert, dsEdit]);
+ if DoPost then
+ FTable.Edit;
+ grdTableBrowser.SelectedField.Clear;
+ if DoPost then
+ FTable.Post;
+ { refresh; could be blobfield }
+ ViewActiveBlobField;
+ end;
+ {End !!.11}
+end;
+{Begin !!.02}
+{--------}
+procedure TdlgTable.mnuOptionsDebugClick(Sender: TObject);
+begin
+ mnuOptionsDebug.Checked := not mnuOptionsDebug.Checked;
+ if mnuOptionsDebug.Checked then
+ FTransport.EventLogOptions := [fftpLogErrors, fftpLogRequests,
+ fftpLogReplies]
+ else
+ FTransport.EventLogOptions := [fftpLogErrors];
+end;
+{End !!.02}
+
+{Begin !!.07}
+procedure TdlgTable.FTableAfterPost(DataSet: TDataSet);
+begin
+ if FTable.Database.InTransaction then
+ FTable.Database.Commit;
+ UpdateDisplay;
+end;
+{--------}
+procedure TdlgTable.FTableAfterCancel(DataSet: TDataSet);
+begin
+ if FTable.Database.InTransaction then
+ FTable.Database.Rollback;
+ FTable.Refresh;
+ ViewActiveBlobField;
+end;
+{--------}
+procedure TdlgTable.FTableAfterScroll(DataSet: TDataSet);
+begin
+ ViewActiveBlobField;
+end;
+{--------}
+procedure TdlgTable.FTableBeforeEdit(DataSet: TDataSet);
+begin
+ if not FTable.Database.InTransaction then
+ FTable.Database.StartTransaction;
+end;
+{--------}
+procedure TdlgTable.FTableBeforeInsert(DataSet: TDataSet);
+begin
+ if not FTable.Database.InTransaction then
+ FTable.Database.StartTransaction;
+end;
+{--------}
+procedure TdlgTable.mnuOptionsTimeoutClick(Sender: TObject);
+var
+ sTimeout : String;
+ res : Boolean;
+begin
+ sTimeout := IntToStr(FTable.Timeout);
+ repeat
+ res := InputQuery('Table Timeout (ms)', 'Value:', sTimeout);
+ if res then
+ try
+ FTable.Timeout := StrToInt(sTimeout);
+ if FTable.Timeout<-1 then
+ raise EConvertError.Create('');
+ res := False;
+ except
+ on EConvertError do begin
+ MessageDlg('Value must be a number between -1 and '+IntToStr(MaxInt), mtError, [mbOK], 0);
+ end;
+ end;
+ until not res;
+end;
+{--------}
+procedure TdlgTable.FormKeyDown(Sender: TObject; var Key: Word;
+ Shift: TShiftState);
+begin
+ if (not (FTable.State IN [dsInsert, dsEdit])) and
+ (Key = VK_ESCAPE) then
+ Close;
+end;
+{--------}
+procedure TdlgTable.ViewActiveBlobField;
+const
+ JPEGHeader : array [0..10] of Char = (Chr($FF), Chr($D8), Chr($FF), Chr($E0),
+ Chr($0), Chr($10), 'J', 'F', 'I', 'F', Chr(0));
+ BMPHeader : array [0..1] of char = ('B', 'M');
+ WMFHeader : array [0..1] of char = ('B', 'M');
+ ICOHeader : array [0..1] of char = ('B', 'M');
+ HexChar : array [0..15] of char = '0123456789ABCDEF';
+var
+ HeaderBuffer : array [0..10] of char;
+ Stream : TffBlobStream;
+ jpegImage : TJPEGImage;
+ i : Integer;
+ BlobBuffer : array [0..1024] of char;
+ ByteArrayBuffer : Pointer;
+ tempStr : String;
+
+ { copied from TffEventLog.WriteBlock and transmogrified }
+ function GenerateHexLines(Buf : pointer; BufLen : TffMemSize) : String;
+ const
+ HexPos : array [0..15] of byte =
+ (1, 3, 5, 7, 10, 12, 14, 16, 19, 21, 23, 25, 28, 30, 32, 34);
+ var
+ B : PffByteArray absolute Buf;
+ ThisWidth,
+ i, j : integer;
+ Line : string[56];
+ Work : byte;
+ begin
+ Result := '';
+ if (BufLen = 0) or (Buf = nil) then
+ Exit
+ else begin
+ if (BufLen > 1024) then begin
+ BufLen := 1024;
+ end;
+ for i := 0 to ((BufLen-1) shr 4) do begin
+ FillChar(Line, 56, ' ');
+ Line[0] := #55;
+ Line[38] := '['; Line[55] := ']';
+ if (BufLen >= 16) then
+ ThisWidth := 16
+ else
+ ThisWidth := BufLen;
+ for j := 0 to ThisWidth-1 do begin
+ Work := B^[(i shl 4) + j];
+ Line[HexPos[j]] := HexChar[Work shr 4];
+ Line[HexPos[j]+1] := HexChar[Work and $F];
+ if (Work < 32) {or (Work >= $80)} then
+ Work := ord('.');
+ Line[39+j] := char(Work);
+ end;
+ Result := Result + Line + ffcCRLF;
+ dec(BufLen, ThisWidth);
+ end;
+ end;
+ end;
+
+ function ByteArrayToHexString(ByteArray : Pointer; ArrayLength : Integer) : String;
+ var
+ idx : Integer;
+ BArr : PffByteArray absolute ByteArray;
+ begin
+ Result := '';
+ for idx := 0 to ArrayLength-1 do begin
+ Result := Result + HexChar[BArr[idx] shr 4];
+ Result := Result + HexChar[BArr[idx] and $F];
+ end;
+ end;
+
+begin
+ { load non-db blob controls }
+ if mnuViewShowBLOBFields.Checked and
+ HasBlobOrByteArrayField then begin
+
+ for i := 0 to FTable.Dictionary.FieldCount-1 do begin
+ { only load blob on active tabsheet }
+ if Assigned(Pointer(FTable.Fields[i].Tag)) and
+ (FTable.Fields[i].FieldName=pcBlobfields.ActivePage.Caption) then
+ case FTable.Dictionary.FieldType[i] of
+ fftBLOBGraphic : begin
+ try
+ Stream := TffBlobStream(FTable.CreateBlobStream(FTable.Fields[i], bmRead));
+ try
+ TImage(FTable.Fields[i].Tag).Picture.Bitmap.Assign(NIL);
+ TImage(FTable.Fields[i].Tag).Invalidate;
+// if Stream.Size>0 then
+ { data in stream? }
+ if (Stream.Read(HeaderBuffer, 11)=11) then
+ { jpg? }
+ if CompareMem(@jpegHeader, @HeaderBuffer, 11) then begin
+ Stream.Position := 0;
+ jpegImage := TJPEGImage.Create;
+ try
+ jpegImage.LoadFromStream(stream);
+ TImage(FTable.Fields[i].Tag).Picture.Bitmap.Assign(jpegImage);
+ finally
+ jpegImage.Free;
+ end;
+ end
+ else
+ {bmp?}
+ if CompareMem(@BMPHeader, @HeaderBuffer, 2) or
+ CompareMem(@BMPHeader, @HeaderBuffer[8], 2) then begin
+ if CompareMem(@BMPHeader, @HeaderBuffer, 2) then
+ Stream.Position := 0
+ else
+ Stream.Position := 8;
+ TImage(FTable.Fields[i].Tag).Picture.Bitmap.LoadFromStream(stream);
+ end
+ else begin
+ {metafile?}
+ { it's difficult to check for the metafile type. we just
+ attempt to load and let the TImage component find out. }
+ Stream.Position := 8;
+ try
+ TImage(FTable.Fields[i].Tag).Picture.Metafile.LoadFromStream(stream);
+ except
+ on EInvalidGraphic do begin
+ Stream.Position := 0;
+ try
+ TImage(FTable.Fields[i].Tag).Picture.Metafile.LoadFromStream(stream);
+ except
+ on EInvalidGraphic do begin
+ {icon?}
+ { it's difficult to check for the icon type. we just
+ attempt to load and let the TImage component find out. }
+ Stream.Position := 8;
+ try
+ TImage(FTable.Fields[i].Tag).Picture.Icon.LoadFromStream(stream);
+ except
+ on EInvalidGraphic do begin
+ Stream.Position := 0;
+ try
+ TImage(FTable.Fields[i].Tag).Picture.Icon.LoadFromStream(stream);
+ except
+ on EInvalidGraphic do
+ else
+ raise;
+ end;
+ end
+ else
+ raise;
+ end;
+ end
+ else
+ raise;
+ end;
+ end
+ else
+ raise;
+ end;
+ end;
+ finally
+ Stream.Free;
+ end;
+ except
+ on E:Exception do begin
+ ShowMessage('Exception: '+E.Message+' decoding graphic field: '+FTable.Fields[i].FieldName);
+ end;
+ end;
+ end;
+ fftByteArray : begin
+ with TMaskEdit(FTable.Fields[i].Tag) do begin
+ Text := '';
+ MaxLength := FTable.Fields[i].Size*2;
+ SetLength(tempStr, MaxLength);
+ FillChar(tempStr[1], MaxLength, 'a');
+ EditMask := tempStr + ';0;_';
+ GetMem(ByteArrayBuffer, FTable.Fields[i].DataSize);
+ try
+ if FTable.Fields[i].GetData(ByteArrayBuffer) then
+ Text := ByteArrayToHexString(ByteArrayBuffer, FTable.Fields[i].DataSize);
+ finally
+ FreeMem(ByteArrayBuffer);
+ end;
+ end;
+ end;
+ fftBLOB,
+ fftBLOBOLEObj,
+ fftBLOBDBSOLEObj,
+ fftBLOBTypedBin,
+ fftBLOBFile : begin
+ try
+ Stream := TffBlobStream(FTable.CreateBlobStream(FTable.Fields[i], bmRead));
+ try
+ TMemo(FTable.Fields[i].Tag).Text := '';
+ Stream.Read(BlobBuffer, FFMinL(1024, Stream.Size));
+ TMemo(FTable.Fields[i].Tag).Text :=
+ GenerateHexLines(@BlobBuffer, FFMinL(1024, Stream.Size));
+ finally
+ Stream.Free;
+ end;
+ except
+ on E:Exception do begin
+ ShowMessage('Exception: '+E.Message+' when displaying blob field: '+FTable.Fields[i].FieldName);
+ end;
+ end;
+ end;
+ end;
+ end;
+ end;
+
+end;
+{--------}
+function TdlgTable.HasBlobOrByteArrayField: Boolean;
+var
+ i : Integer;
+begin
+ Result := False;
+ for i := 0 to FTable.Dictionary.FieldCount-1 do
+ if FTable.Dictionary.FieldType[i] IN [fftBLOB..ffcLastBLOBType, fftByteArray] then begin
+ Result := True;
+ Exit;
+ end;
+end;
+{--------}
+procedure TdlgTable.cbStretchClick(Sender: TObject);
+var
+ i : Integer;
+begin
+ for i := 0 to TCheckBox(Sender).Parent.ControlCount-1 do
+ if TCheckBox(Sender).Parent.Controls[i] IS TImage then begin
+ TImage(TCheckBox(Sender).Parent.Controls[i]).Stretch := TCheckBox(Sender).Checked;
+ Exit;
+ end;
+end;
+{--------}
+procedure TdlgTable.btnClearBAClick(Sender: TObject);
+var
+ fieldIdx,
+ controlIdx : Integer;
+ aEdit : TMaskEdit;
+ aField : TField;
+begin
+ { find edit control }
+ for controlIdx := 0 to TButton(Sender).Parent.ControlCount-1 do
+ if TButton(Sender).Parent.Controls[controlIdx] IS TMaskEdit then begin
+ aEdit := TMaskEdit(TButton(Sender).Parent.Controls[controlIdx]);
+ { find correct field }
+ for fieldIdx := 0 to FTable.Dictionary.FieldCount-1 do begin
+ if Pointer(FTable.Fields[fieldIdx].Tag)=aEdit then begin
+ aField := FTable.Fields[fieldIdx];
+ if not (FTable.State in [dsInsert, dsEdit]) then
+ FTable.Edit;
+ aField.Clear;
+ aEdit.Text := '';
+ Exit;
+ end;
+ end;
+ end;
+end;
+{--------}
+procedure TdlgTable.pcBlobfieldsChange(Sender: TObject);
+begin
+ ViewActiveBlobField;
+end;
+{--------}
+procedure TdlgTable.mnuViewShowBLOBFieldsClick(Sender: TObject);
+begin
+ mnuViewShowBLOBFields.Checked := not mnuViewShowBLOBFields.Checked;
+ pcBlobfields.Visible := mnuViewShowBLOBFields.Checked;
+ splGridAndPageControl.Visible := mnuViewShowBLOBFields.Checked;
+ if mnuViewShowBLOBFields.Checked then
+ ViewActiveBlobField;
+end;
+{--------}
+procedure TdlgTable.btnLoadMemoClick(Sender: TObject);
+var
+ fieldIdx,
+ controlIdx : Integer;
+ adbMemo : TdbMemo;
+ aField : TField;
+begin
+ if opendialog.Execute then
+ { find dbmemo control }
+ for controlIdx := 0 to TButton(Sender).Parent.ControlCount-1 do
+ if TButton(Sender).Parent.Controls[controlIdx] IS TdbMemo then begin
+ adbMemo := TdbMemo(TButton(Sender).Parent.Controls[controlIdx]);
+ { find correct field }
+ for fieldIdx := 0 to FTable.Dictionary.FieldCount-1 do begin
+ if Pointer(FTable.Fields[fieldIdx].Tag)=adbMemo then begin
+ aField := FTable.Fields[fieldIdx];
+ if not (FTable.State in [dsInsert, dsEdit]) then
+ FTable.Edit;
+ TMemoField(aField).LoadFromFile(opendialog.FileName);
+ Exit;
+ end;
+ end;
+ end;
+end;
+{--------}
+procedure TdlgTable.btnSaveMemoClick(Sender: TObject);
+var
+ fieldIdx,
+ controlIdx : Integer;
+ adbMemo : TdbMemo;
+ aField : TField;
+begin
+ if savedialog.Execute then
+ { find dbmemo control }
+ for controlIdx := 0 to TButton(Sender).Parent.ControlCount-1 do
+ if TButton(Sender).Parent.Controls[controlIdx] IS TdbMemo then begin
+ adbMemo := TdbMemo(TButton(Sender).Parent.Controls[controlIdx]);
+ { find correct field }
+ for fieldIdx := 0 to FTable.Dictionary.FieldCount-1 do begin
+ if Pointer(FTable.Fields[fieldIdx].Tag)=adbMemo then begin
+ aField := FTable.Fields[fieldIdx];
+ TMemoField(aField).SaveToFile(savedialog.FileName);
+ Exit;
+ end;
+ end;
+ end;
+end;
+{--------}
+procedure TdlgTable.btnLoadGenericClick(Sender: TObject);
+var
+ fieldIdx,
+ controlIdx : Integer;
+ aMemo : TMemo;
+ aField : TField;
+begin
+ if opendialog.Execute then
+ { find memo control }
+ for controlIdx := 0 to TButton(Sender).Parent.ControlCount-1 do
+ if TButton(Sender).Parent.Controls[controlIdx] IS TMemo then begin
+ aMemo := TMemo(TButton(Sender).Parent.Controls[controlIdx]);
+ { find correct field }
+ for fieldIdx := 0 to FTable.Dictionary.FieldCount-1 do begin
+ if Pointer(FTable.Fields[fieldIdx].Tag)=aMemo then begin
+ aField := FTable.Fields[fieldIdx];
+ if not (FTable.State in [dsInsert, dsEdit]) then
+ FTable.Edit;
+ TBlobField(aField).LoadFromFile(opendialog.FileName);
+ ViewActiveBlobField;
+ Exit;
+ end;
+ end;
+ end;
+end;
+{--------}
+procedure TdlgTable.btnSaveGenericClick(Sender: TObject);
+var
+ fieldIdx,
+ controlIdx : Integer;
+ aMemo : TMemo;
+ aField : TField;
+begin
+ if savedialog.Execute then
+ { find memo control }
+ for controlIdx := 0 to TButton(Sender).Parent.ControlCount-1 do
+ if TButton(Sender).Parent.Controls[controlIdx] IS TMemo then begin
+ aMemo := TMemo(TButton(Sender).Parent.Controls[controlIdx]);
+ { find correct field }
+ for fieldIdx := 0 to FTable.Dictionary.FieldCount-1 do begin
+ if Pointer(FTable.Fields[fieldIdx].Tag)=aMemo then begin
+ aField := FTable.Fields[fieldIdx];
+ TBlobField(aField).SaveToFile(savedialog.FileName);
+ Exit;
+ end;
+ end;
+ end;
+end;
+{--------}
+procedure TdlgTable.btnClearMemoClick(Sender: TObject);
+var
+ fieldIdx,
+ controlIdx : Integer;
+ adbMemo : TdbMemo;
+ aField : TField;
+begin
+ { find dbmemo control }
+ for controlIdx := 0 to TButton(Sender).Parent.ControlCount-1 do
+ if TButton(Sender).Parent.Controls[controlIdx] IS TdbMemo then begin
+ adbMemo := TdbMemo(TButton(Sender).Parent.Controls[controlIdx]);
+ { find correct field }
+ for fieldIdx := 0 to FTable.Dictionary.FieldCount-1 do begin
+ if Pointer(FTable.Fields[fieldIdx].Tag)=adbMemo then begin
+ aField := FTable.Fields[fieldIdx];
+ if not (FTable.State in [dsInsert, dsEdit]) then
+ FTable.Edit;
+ aField.Clear;
+ Exit;
+ end;
+ end;
+ end;
+end;
+{--------}
+procedure TdlgTable.btnLoadGraphicClick(Sender: TObject);
+var
+ fieldIdx,
+ controlIdx : Integer;
+ aImage : TImage;
+ aField : TField;
+begin
+ if opendialog.Execute then
+ { find Image control }
+ for controlIdx := 0 to TButton(Sender).Parent.ControlCount-1 do
+ if TButton(Sender).Parent.Controls[controlIdx] IS TImage then begin
+ aImage := TImage(TButton(Sender).Parent.Controls[controlIdx]);
+ { find correct field }
+ for fieldIdx := 0 to FTable.Dictionary.FieldCount-1 do begin
+ if Pointer(FTable.Fields[fieldIdx].Tag)=aImage then begin
+ aField := FTable.Fields[fieldIdx];
+ if not (FTable.State in [dsInsert, dsEdit]) then
+ FTable.Edit;
+ TBlobField(aField).LoadFromFile(opendialog.FileName);
+ ViewActiveBlobField;
+ Exit;
+ end;
+ end;
+ end;
+end;
+{--------}
+procedure TdlgTable.btnSaveGraphicClick(Sender: TObject);
+var
+ fieldIdx,
+ controlIdx : Integer;
+ aImage : TImage;
+ aField : TField;
+begin
+ if savedialog.Execute then
+ { find Image control }
+ for controlIdx := 0 to TButton(Sender).Parent.ControlCount-1 do
+ if TButton(Sender).Parent.Controls[controlIdx] IS TImage then begin
+ aImage := TImage(TButton(Sender).Parent.Controls[controlIdx]);
+ { find correct field }
+ for fieldIdx := 0 to FTable.Dictionary.FieldCount-1 do begin
+ if Pointer(FTable.Fields[fieldIdx].Tag)=aImage then begin
+ aField := FTable.Fields[fieldIdx];
+ TBlobField(aField).SaveToFile(savedialog.FileName);
+ Exit;
+ end;
+ end;
+ end;
+end;
+{--------}
+procedure TdlgTable.btnClearGraphicClick(Sender: TObject);
+var
+ fieldIdx,
+ controlIdx : Integer;
+ aImage : TImage;
+ aField : TField;
+begin
+ { find image control }
+ for controlIdx := 0 to TButton(Sender).Parent.ControlCount-1 do
+ if TButton(Sender).Parent.Controls[controlIdx] IS TImage then begin
+ aImage := TImage(TButton(Sender).Parent.Controls[controlIdx]);
+ { find correct field }
+ for fieldIdx := 0 to FTable.Dictionary.FieldCount-1 do begin
+ if Pointer(FTable.Fields[fieldIdx].Tag)=aImage then begin
+ aField := FTable.Fields[fieldIdx];
+ if not (FTable.State in [dsInsert, dsEdit]) then
+ FTable.Edit;
+ TGraphicField(aField).Clear;
+ ViewActiveBlobField;
+ Exit;
+ end;
+ end;
+ end;
+end;
+{--------}
+procedure TdlgTable.btnClearGenericClick(Sender: TObject);
+var
+ fieldIdx,
+ controlIdx : Integer;
+ aMemo : TMemo;
+ aField : TField;
+begin
+ { find memo control }
+ for controlIdx := 0 to TButton(Sender).Parent.ControlCount-1 do
+ if TButton(Sender).Parent.Controls[controlIdx] IS TMemo then begin
+ aMemo := TMemo(TButton(Sender).Parent.Controls[controlIdx]);
+ { find correct field }
+ for fieldIdx := 0 to FTable.Dictionary.FieldCount-1 do begin
+ if Pointer(FTable.Fields[fieldIdx].Tag)=aMemo then begin
+ aField := FTable.Fields[fieldIdx];
+ if not (FTable.State in [dsInsert, dsEdit]) then
+ FTable.Edit;
+ aField.Clear;
+ ViewActiveBlobField;
+ Exit;
+ end;
+ end;
+ end;
+end;
+
+procedure TdlgTable.meByteArrayKeyPress(Sender: TObject; var Key: Char);
+begin
+ if not (Key IN [#8, #9, #27, '0'..'9', 'A'..'F', 'a'..'f']) then
+ Key := #0
+ else
+ BAKeyPressDetected := True;
+end;
+
+procedure TdlgTable.mnuTablePrintPreviewClick(Sender: TObject);
+var
+ Filter,
+ DatabaseName,
+ IndexName : Array[0..1024] of Char;
+ i : Integer;
+ RangeStart,
+ RangeEnd : TRangeFieldValues;
+begin
+ StrPCopy(DatabaseName, FDatabaseName);
+ if FTable.Filtered then begin
+ StrPCopy(Filter, FTable.Filter);
+ end
+ else
+ StrCopy(Filter, '');
+ StrPCopy(IndexName, FTable.IndexName);
+ { initialize }
+ for i := 0 to ffcl_MaxIndexFlds-1 do begin
+ RangeStart[i] := NULL;
+ RangeEnd[i] := NULL;
+ end;
+ if InRange then begin
+ FTable.EditRangeStart;
+ for i := 0 to FTable.IndexFieldCount-1 do
+ RangeStart[i] := FTable.IndexFields[i].Value;
+ FTable.Cancel;
+ FTable.EditRangeEnd;
+ for i := 0 to FTable.IndexFieldCount-1 do
+ RangeEnd[i] := FTable.IndexFields[i].Value;
+ FTable.Cancel;
+ end;
+ SingleTableReport(FProtocol,
+ FServerName,
+ FUserName,
+ FPassword,
+ DatabaseName,
+ FTableName,
+ Filter,
+ IndexName,
+ RangeStart,
+ RangeEnd);
+end;
+
+procedure TdlgTable.mnuTableDesignReportClick(Sender: TObject);
+var
+ DatabaseName : Array[0..1024] of Char;
+begin
+ StrPCopy(DatabaseName, FDatabaseName);
+ DesignReport(FProtocol,
+ FServerName,
+ FUserName,
+ FPassword,
+ DatabaseName);
+end;
+
+
+{ magic resize numbers: 100 = width of buttons + 8 pixels of space on each side }
+procedure TdlgTable.tsMemoTemplateResize(Sender: TObject);
+var
+ controlIdx : Integer;
+begin
+ for controlIdx := 0 to TTabSheet(Sender).ControlCount-1 do
+ if TTabSheet(Sender).Controls[controlIdx] IS TdbMemo then begin
+ TdbMemo(TTabSheet(Sender).Controls[controlIdx]).SetBounds(0, 0, TTabSheet(Sender).Width-116, TTabSheet(Sender).Height);
+ end
+ else
+ if TTabSheet(Sender).Controls[controlIdx] IS TButton then begin
+ TButton(TTabSheet(Sender).Controls[controlIdx]).Left := TTabSheet(Sender).Width-108;
+ end
+ else
+ if TTabSheet(Sender).Controls[controlIdx] IS TCheckBox then begin
+ TCheckBox(TTabSheet(Sender).Controls[controlIdx]).Left := TTabSheet(Sender).Width-108;
+ end;
+end;
+
+procedure TdlgTable.tsGraphicTemplateResize(Sender: TObject);
+var
+ controlIdx : Integer;
+begin
+ for controlIdx := 0 to TTabSheet(Sender).ControlCount-1 do
+ if TTabSheet(Sender).Controls[controlIdx] IS TImage then begin
+ TImage(TTabSheet(Sender).Controls[controlIdx]).SetBounds(0, 0, TTabSheet(Sender).Width-116, TTabSheet(Sender).Height);
+ end
+ else
+ if TTabSheet(Sender).Controls[controlIdx] IS TButton then begin
+ TButton(TTabSheet(Sender).Controls[controlIdx]).Left := TTabSheet(Sender).Width-108;
+ end
+ else
+ if TTabSheet(Sender).Controls[controlIdx] IS TCheckBox then begin
+ TCheckBox(TTabSheet(Sender).Controls[controlIdx]).Left := TTabSheet(Sender).Width-108;
+ end;
+end;
+
+procedure TdlgTable.tsGenericBlobTemplateResize(Sender: TObject);
+var
+ controlIdx : Integer;
+begin
+ for controlIdx := 0 to TTabSheet(Sender).ControlCount-1 do
+ if TTabSheet(Sender).Controls[controlIdx] IS TMemo then begin
+ TMemo(TTabSheet(Sender).Controls[controlIdx]).SetBounds(0, 0, TTabSheet(Sender).Width-116, TTabSheet(Sender).Height);
+ end
+ else
+ if TTabSheet(Sender).Controls[controlIdx] IS TButton then begin
+ TButton(TTabSheet(Sender).Controls[controlIdx]).Left := TTabSheet(Sender).Width-108;
+ end;
+end;
+
+procedure TdlgTable.tsByteArrayTemplateResize(Sender: TObject);
+var
+ controlIdx : Integer;
+begin
+ for controlIdx := 0 to TTabSheet(Sender).ControlCount-1 do
+ if TTabSheet(Sender).Controls[controlIdx] IS TMaskEdit then begin
+ TMaskEdit(TTabSheet(Sender).Controls[controlIdx]).Width := TTabSheet(Sender).Width-2*TMaskEdit(TTabSheet(Sender).Controls[controlIdx]).Left;
+ end
+ else
+ if TTabSheet(Sender).Controls[controlIdx] IS TLabel then begin
+ TLabel(TTabSheet(Sender).Controls[controlIdx]).Width := TTabSheet(Sender).Width-2*TLabel(TTabSheet(Sender).Controls[controlIdx]).Left;
+ end
+ else
+ { this button is 75 pixels wide }
+ if TTabSheet(Sender).Controls[controlIdx] IS TButton then begin
+ if TButton(TTabSheet(Sender).Controls[controlIdx]).Caption='Clear' then
+ TButton(TTabSheet(Sender).Controls[controlIdx]).Left := TTabSheet(Sender).Width-83;
+ end;
+end;
+
+procedure TdlgTable.btnSetClearRangeClick(Sender: TObject);
+var
+ NeedEdit : Boolean;
+ FieldIdx : Integer;
+begin
+ if not InRange then begin
+ { check wether we have a useable range (not all NULL) }
+ NeedEdit := True;
+ for FieldIdx := Low(FRangeValues.Field) to FTable.IndexFieldCount do
+ if (not FRangeValues.Field[FieldIdx].StartNull) or
+ (not FRangeValues.Field[FieldIdx].EndNull) then begin
+ NeedEdit := False;
+ Break;
+ end;
+ if NeedEdit then
+ btnEditRangeClick(Self)
+ else
+ SetRange;
+ end
+ else begin
+ btnSetClearRange.Caption := 'Set &Range';
+ FTable.CancelRange;
+ InRange := False;
+ UpdateDisplay;
+ end;
+end;
+
+procedure TdlgTable.btnEditRangeClick(Sender: TObject);
+var
+ BaseSection : string;
+ Index : Integer;
+begin
+ if SetRangeDlg(FTable, FRangeValues)=mrOK then begin
+ SetRange;
+ GenerateRangeDisplayStrings;
+ BaseSection := ClassName + '.' + Self.Caption;
+ for Index := Low(FRangeValues.Field) to FTable.IndexFieldCount do begin
+ FFEConfigSaveBoolean(BaseSection, FTable.IndexName+'_RangeStartNull'+IntToStr(Index), FRangeValues.Field[Index].StartNull);
+ FFEConfigSaveBoolean(BaseSection, FTable.IndexName+'_RangeEndNull'+IntToStr(Index), FRangeValues.Field[Index].EndNull);
+ FFEConfigSaveString(BaseSection, FTable.IndexName+'_RangeStartValue'+IntToStr(Index), FRangeValues.Field[Index].StartValue);
+ FFEConfigSaveString(BaseSection, FTable.IndexName+'_RangeEndValue'+IntToStr(Index), FRangeValues.Field[Index].EndValue);
+ end;
+ FFEConfigSaveBoolean(BaseSection, FTable.IndexName+'_RangeStartKeyExclusive', FRangeValues.RangeStartKeyExclusive);
+ FFEConfigSaveBoolean(BaseSection, FTable.IndexName+'_RangeEndKeyExclusive', FRangeValues.RangeEndKeyExclusive);
+ end;
+end;
+
+procedure TdlgTable.mnuViewShowRangeClick(Sender: TObject);
+var
+ FilterFix : Boolean;
+begin
+ { necessary to get rangepanel to reappear below filterpanel }
+ FilterFix := pnlFilter.Visible and not pnlRange.Visible;
+ if FilterFix then
+ pnlFilter.Visible := False;
+ mnuViewShowRange.Checked := not mnuViewShowRange.Checked;
+ pnlRange.Visible := mnuViewShowRange.Checked;
+ { remove range and update display etc }
+ if InRange then
+ btnSetClearRangeClick(Self);
+ if FilterFix then
+ pnlFilter.Visible := True;
+end;
+
+procedure TdlgTable.FormResize(Sender: TObject);
+begin
+ btnFindNear.Left := ClientWidth - btnFindNear.Width - 8;
+ edtFind.Width := btnFindNear.Left - edtFind.Left - 8;
+ btnSetFilter.Left := ClientWidth - btnSetFilter.Width - 8;
+ cboFilter.Width := btnSetFilter.Left - cboFilter.Left - 8;
+ btnSetClearRange.Left := ClientWidth - btnSetClearRange.Width - 8;
+ laRangeStart.Width := btnSetClearRange.Left - laRangeStart.Left - 8;
+ btnEditRange.Left := ClientWidth - btnEditRange.Width - 8;
+ laRangeEnd.Width := btnEditRange.Left - laRangeEnd.Left - 8;
+end;
+
+procedure TdlgTable.GenerateRangeDisplayStrings;
+var
+ HighestNonNullIdx,
+ FieldIdx : Integer;
+ FirstField : Boolean;
+begin
+ HighestNonNullIdx := FTable.IndexFieldCount;
+ while (HighestNonNullIdx>1) and
+ FRangeValues.Field[HighestNonNullIdx].StartNull and
+ FRangeValues.Field[HighestNonNullIdx].EndNull do
+ Dec(HighestNonNullIdx);
+ laRangeStart.Caption := '[';
+ FirstField := True;
+ for FieldIdx := Low(FRangeValues.Field) to HighestNonNullIdx do begin
+ if not FirstField then laRangeStart.Caption := laRangeStart.Caption + ', ';
+ if FRangeValues.Field[FieldIdx].StartNull then
+ laRangeStart.Caption := laRangeStart.Caption + 'NULL'
+ else
+ if FRangeValues.Field[FieldIdx].StartValue<>'' then
+ laRangeStart.Caption := laRangeStart.Caption + FRangeValues.Field[FieldIdx].StartValue
+ else
+ laRangeStart.Caption := laRangeStart.Caption + '''''';
+ FirstField := False;
+ end;
+ laRangeStart.Caption := laRangeStart.Caption + ']';
+ if FRangeValues.RangeStartKeyExclusive then
+ laRangeStart.Caption := laRangeStart.Caption + ' - [KeyExclusive]';
+ laRangeEnd.Caption := '[';
+ FirstField := True;
+ for FieldIdx := Low(FRangeValues.Field) to HighestNonNullIdx do begin
+ if not FirstField then laRangeEnd.Caption := laRangeEnd.Caption + ', ';
+ if FRangeValues.Field[FieldIdx].EndNull then
+ laRangeEnd.Caption := laRangeEnd.Caption + 'NULL'
+ else
+ if FRangeValues.Field[FieldIdx].EndValue<>'' then
+ laRangeEnd.Caption := laRangeEnd.Caption + FRangeValues.Field[FieldIdx].EndValue
+ else
+ laRangeEnd.Caption := laRangeEnd.Caption + '''''';
+ FirstField := False;
+ end;
+ laRangeEnd.Caption := laRangeEnd.Caption + ']';
+ if FRangeValues.RangeEndKeyExclusive then
+ laRangeEnd.Caption := laRangeEnd.Caption + ' - [KeyExclusive]';
+end;
+
+procedure TdlgTable.SetRange;
+var
+ HighestNonNullIdx,
+ FieldIdx : Integer;
+begin
+ HighestNonNullIdx := 0;
+ FTable.SetRangeStart;
+ FTable.KeyExclusive := FRangeValues.RangeStartKeyExclusive;
+ for FieldIdx := Low(FRangeValues.Field) to FTable.IndexFieldCount do begin
+ if not FRangeValues.Field[FieldIdx].StartNull then begin
+ FTable.IndexFields[FieldIdx-1].AsString := FRangeValues.Field[FieldIdx].StartValue;
+ HighestNonNullIdx := FFMaxL(HighestNonNullIdx, FieldIdx);
+ end
+ else
+ if not FRangeValues.Field[FieldIdx].EndNull then
+ FTable.IndexFields[FieldIdx-1].Value := NULL;
+ end;
+ FTable.SetRangeEnd;
+ FTable.KeyExclusive := FRangeValues.RangeEndKeyExclusive;
+ for FieldIdx := Low(FRangeValues.Field) to FTable.IndexFieldCount do begin
+ if not FRangeValues.Field[FieldIdx].EndNull then begin
+ FTable.IndexFields[FieldIdx-1].AsString := FRangeValues.Field[FieldIdx].EndValue;
+ HighestNonNullIdx := FFMaxL(HighestNonNullIdx, FieldIdx);
+ end
+ else
+ if not FRangeValues.Field[FieldIdx].StartNull then
+ FTable.IndexFields[FieldIdx-1].Value := NULL;
+ end;
+ FTable.KeyFieldCount := HighestNonNullIdx;
+ FTable.ApplyRange;
+ InRange := True;
+ btnSetClearRange.Caption := 'Clear &Range';
+ UpdateDisplay;
+end;
+
+procedure TdlgTable.meByteArrayChange(Sender: TObject);
+var
+ ByteArrayBuffer : Pointer;
+ fieldIdx,
+ controlIdx : Integer;
+ aEdit : TMaskEdit;
+ aField : TField;
+
+ procedure HexStringToByteArray(ByteArray : Pointer; ArrayLength : Integer; S : String);
+ var
+ idx : Integer;
+ BArr : PffByteArray absolute ByteArray;
+ begin
+ for idx := 0 to ArrayLength-1 do begin
+ if Odd(Length(S)) then
+ S := S + '0';
+ if Length(S)>1 then begin
+ try
+ BArr[idx] := StrToInt('$'+Copy(S, 1, 2));
+ except
+ on EConvertError do begin
+ MessageDlg('Invalid character encountered - use only hex digits 0..9, A..F!', mtError, [mbOK], 0);
+ Abort;
+ end;
+ end;
+ Delete(S, 1, 2);
+ end
+ else begin
+ BArr[idx] := 0;
+ BArr[idx] := 0;
+ end;
+ end;
+ end;
+
+begin
+ if not BAKeyPressDetected then
+ Exit
+ else
+ BAKeyPressDetected := False;
+ FTable.Edit;
+ { find edit control }
+ for controlIdx := 0 to TButton(Sender).Parent.ControlCount-1 do
+ if TButton(Sender).Parent.Controls[controlIdx] IS TMaskEdit then begin
+ aEdit := TMaskEdit(TButton(Sender).Parent.Controls[controlIdx]);
+ if aEdit.Text='' then
+ Exit;
+ { find correct field }
+ for fieldIdx := 0 to FTable.Dictionary.FieldCount-1 do begin
+ if Pointer(FTable.Fields[fieldIdx].Tag)=aEdit then begin
+ aField := FTable.Fields[fieldIdx];
+ if not (FTable.State in [dsInsert, dsEdit]) then
+ FTable.Edit;
+ GetMem(ByteArrayBuffer, aField.Size);
+ try
+ HexStringToByteArray(ByteArrayBuffer, aField.Size, aEdit.Text);
+ aField.SetData(ByteArrayBuffer);
+ finally
+ FreeMem(ByteArrayBuffer);
+ end;
+ Exit;
+ end;
+ end;
+ end;
+end;
+
+procedure TdlgTable.cbWordwrapClick(Sender: TObject);
+var
+ i : Integer;
+begin
+ for i := 0 to TCheckBox(Sender).Parent.ControlCount-1 do
+ if TCheckBox(Sender).Parent.Controls[i] IS TdbMemo then begin
+ with TdbMemo(TCheckBox(Sender).Parent.Controls[i]) do begin
+ WordWrap := TCheckBox(Sender).Checked;
+ if WordWrap then
+ ScrollBars := ssVertical
+ else
+ ScrollBars := ssBoth;
+ end;
+ Exit;
+ end;
+end;
+
+procedure TdlgTable.mnuTableCopyToTableClick(Sender: TObject);
+var
+ ExcludeIndex,
+ TableIndex: LongInt;
+ CopyBlobs : Boolean;
+ SaveTimeout : Integer;
+begin
+ ExcludeIndex := TableItem.Database.IndexOf(TableItem);
+ if ShowCopyTableDlg(TableItem.Database, ExcludeIndex, FTable,
+ TableIndex, CopyBlobs, FTableItem) = mrOK then begin {!!.11}
+ with TableItem.Database.Tables[TableIndex] do begin
+ Screen.Cursor := crHourGlass;
+ { the copy operation is used in the context of the table
+ that's being copied to. Use the timeout of the active
+ table, otherwise the user has no way of setting timeout. }
+ SaveTimeout := Table.Timeout;
+ Table.Timeout := FTable.Timeout;
+ try
+ Update;
+ CopyRecords(FTable, CopyBlobs);
+ finally
+ Screen.Cursor := crDefault;
+ Table.Timeout := SaveTimeout;
+ { force the second table to close if it wasn't open before }
+ FSession.CloseInactiveTables; {!!.11}
+ end;
+ end;
+ end;
+end;
+
+procedure TdlgTable.mnuTableDeleteRecordsClick(Sender: TObject);
+begin
+ if MessageDlg('Delete all records matching the current filter and range - are you sure?', mtConfirmation, [mbYes,mbNo], 0)= mrYes then begin
+ Screen.Cursor := crHourGlass;
+ try
+ Update;
+ FTable.DeleteRecords;
+ finally
+ Screen.Cursor := crDefault;
+ end;
+ end;
+end;
+{End !!.07}
+
+procedure TdlgTable.UpdateDefaultTimeout;
+begin
+ FClient.TimeOut := Config.DefaultTimeout; {!!.11}
+end;
+
+end.
+
diff --git a/components/flashfiler/sourcelaz/explorer/ffe.dpr b/components/flashfiler/sourcelaz/explorer/ffe.dpr
new file mode 100644
index 000000000..2bfa28ebc
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/ffe.dpr
@@ -0,0 +1,71 @@
+{*********************************************************}
+{* Project source file *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+program ffe;
+
+uses
+ Forms,
+ fmmain in 'fmmain.pas' {frmMain},
+ fmstruct in 'fmstruct.pas' {frmTableStruct},
+ fmprog in 'fmprog.pas' {frmRebuildStatus},
+ dgselidx in 'dgselidx.pas' {dlgSelectIndex},
+ dgprintg in 'dgprintg.pas' {dlgPrinting},
+ dgaddals in 'dgaddals.pas' {dlgAddAlias},
+ dgimport in 'dgimport.pas' {dlgImport},
+ dgimpdo in 'dgimpdo.pas' {dlgImportProgress},
+ uelement in 'uelement.pas',
+ uconsts in 'uconsts.pas',
+ ubase in 'ubase.pas',
+ uentity in 'uentity.pas',
+ uconfig in 'uconfig.pas',
+ dgregsrv in 'dgregsrv.pas' {dlgRegisteredServers},
+ dgimpdef in 'dgimpdef.pas' {dlgImportDefinition},
+ dgquery in 'dgquery.pas' {dlgQuery},
+ dgtable in 'dgtable.pas' {dlgTable},
+ dgautoin in 'dgautoin.pas' {dlgAutoInc},
+ usqlcfg in 'usqlcfg.pas',
+ dgSQLOps in 'dgSQLOps.pas' {frmSQLOps},
+ uFFComms in '..\ffcomms\uFFComms.pas' {frmFFCommsMain},
+ dgSetRng in 'dgSetRng.pas' {dlgSetRange},
+ dgServSt in 'dgServSt.pas' {dlgServerStats};
+
+{$R *.RES}
+
+begin
+ Application.Title := 'FlashFiler Explorer';
+ Application.HelpFile := 'FFE.HLP';
+ Application.CreateForm(TfrmMain, frmMain);
+ frmMain.Show;
+ Application.ProcessMessages;
+ frmMain.Initialize;
+ Application.Run;
+end.
+
diff --git a/components/flashfiler/sourcelaz/explorer/ffe.rc b/components/flashfiler/sourcelaz/explorer/ffe.rc
new file mode 100644
index 000000000..d434bf8d4
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/ffe.rc
@@ -0,0 +1,112 @@
+/*********************************************************
+ * Main program icon resource *
+ *********************************************************/
+
+/* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** */
+
+#define VERSIONINFO_1 1
+MAINICON ICON
+{
+ '00 00 01 00 01 00 20 20 10 00 00 00 00 00 E8 02'
+ '00 00 16 00 00 00 28 00 00 00 20 00 00 00 40 00'
+ '00 00 01 00 04 00 00 00 00 00 80 02 00 00 00 00'
+ '00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00'
+ '00 00 00 00 80 00 00 80 00 00 00 80 80 00 80 00'
+ '00 00 80 00 80 00 80 80 00 00 C0 C0 C0 00 80 80'
+ '80 00 00 00 FF 00 00 FF 00 00 00 FF FF 00 FF 00'
+ '00 00 FF 00 FF 00 FF FF 00 00 FF FF FF 00 00 00'
+ '00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00'
+ '00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00'
+ '08 88 88 88 88 88 88 88 88 88 88 00 00 00 00 00'
+ '08 FF FF A3 FF FF FF DD 3F FF F8 00 00 00 00 00'
+ '08 FF FF A3 FF FF FF DD 3F FC C8 00 00 00 00 00'
+ '00 8F FA A3 FF FF FF FF 3F CC FF 80 00 00 00 00'
+ '00 8F A2 A3 FF FF FF FF 3C CF FF 80 00 00 00 00'
+ '00 8F A2 A3 3F FF FF FC CC 3F FF 80 00 00 00 00'
+ '00 8F AA 2A 33 FF FC CC FF 3F FF 80 00 00 00 00'
+ '00 08 FA 22 A3 33 CC CF FF 3F FF F8 00 00 00 00'
+ '00 08 FA 22 2A AC 33 FD FF 3F 33 38 00 00 00 00'
+ '00 08 FA AA AA AC F3 DD 33 33 FF F8 00 00 00 00'
+ '00 08 CC CC CC CC FD DD DF F3 FF F8 00 00 00 00'
+ '00 00 8F CC CC FF 3D DD DF F3 3F FF 80 00 00 00'
+ '00 00 8F FC CC F3 3F F3 FF FF 3F FF 80 00 00 00'
+ '00 00 8F FF FF 33 FF F3 3F FF F3 FD 80 00 00 00'
+ '00 00 83 33 33 3F FF FF 33 FF FF 3D 80 00 00 00'
+ '00 00 8F FF FF FF FF FF F3 3F FF F3 80 00 00 00'
+ '00 00 08 FF FF FF FF FF FF FF FF FF F8 00 00 99'
+ '99 90 08 99 99 9F FF 0F 0F 0F 0F 0F F8 00 00 09'
+ '90 00 08 F9 9F FF FF 0F 0F 00 0F 00 88 00 00 09'
+ '90 00 08 F9 9F FF FF 00 0F 0F 0F 0F 08 00 00 09'
+ '90 00 00 89 9F FF FF 08 0F 80 8F 00 0F 80 00 09'
+ '90 00 90 89 9F FF 9F FF FF FF FF FF FF 80 00 09'
+ '99 99 90 89 99 99 98 88 88 88 88 88 88 80 00 09'
+ '90 00 90 09 90 00 90 00 00 00 00 00 00 00 00 09'
+ '90 00 00 09 90 00 00 00 00 00 00 00 00 00 00 09'
+ '90 00 09 09 90 00 09 00 00 00 00 00 00 00 00 09'
+ '90 00 99 09 90 00 99 00 00 00 00 00 00 00 00 99'
+ '99 99 99 99 99 99 99 00 00 00 00 00 00 00 00 00'
+ '00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00'
+ '00 00 00 00 00 00 00 00 00 00 00 00 00 00 FF FF'
+ 'FF FF FF FF FF FF F8 00 00 3F F8 00 00 3F F8 00'
+ '00 3F FC 00 00 1F FC 00 00 1F FC 00 00 1F FC 00'
+ '00 1F FE 00 00 0F FE 00 00 0F FE 00 00 0F FE 00'
+ '00 0F FF 00 00 07 FF 00 00 07 FF 00 00 07 FF 00'
+ '00 07 FF 00 00 07 FF 80 00 03 C1 80 00 03 E7 80'
+ '00 03 E7 80 00 03 E7 C0 00 01 E7 40 00 01 E0 40'
+ '00 01 E7 67 7F FF E7 E7 FF FF E7 A7 BF FF E7 27'
+ '3F FF C0 00 3F FF FF FF FF FF FF FF FF FF'
+}
+
+
+VERSIONINFO_1 VERSIONINFO
+FILEVERSION 2, 1, 3, 0
+PRODUCTVERSION 2, 1, 3, 0
+FILEOS VOS__WINDOWS32
+FILETYPE VFT_APP
+{
+ BLOCK "StringFileInfo"
+ {
+ BLOCK "040904E4"
+ {
+ VALUE "CompanyName", "TurboPower Software Company\000\000"
+ VALUE "FileDescription", "FlashFiler Explorer\000"
+ VALUE "FileVersion", "2.1.3.0\000"
+ VALUE "InternalName", "FFE\000"
+ VALUE "LegalCopyright", "Copyright (c) TurboPower Software Co. 1996-2002\000\000"
+ VALUE "OriginalFilename", "FFE.EXE\000"
+ VALUE "ProductName", "FlashFiler (Delphi Edition)\000"
+ VALUE "ProductVersion", "2.1.3.0\000"
+ }
+
+ }
+
+ BLOCK "VarFileInfo"
+ {
+ VALUE "Translation", 0x409, 1252
+ }
+
+}
+
diff --git a/components/flashfiler/sourcelaz/explorer/ffe.res b/components/flashfiler/sourcelaz/explorer/ffe.res
new file mode 100644
index 000000000..ae1a7cf61
Binary files /dev/null and b/components/flashfiler/sourcelaz/explorer/ffe.res differ
diff --git a/components/flashfiler/sourcelaz/explorer/fmFRFFEEngine.dfm b/components/flashfiler/sourcelaz/explorer/fmFRFFEEngine.dfm
new file mode 100644
index 000000000..367eab176
Binary files /dev/null and b/components/flashfiler/sourcelaz/explorer/fmFRFFEEngine.dfm differ
diff --git a/components/flashfiler/sourcelaz/explorer/fmFRFFEEngine.pas b/components/flashfiler/sourcelaz/explorer/fmFRFFEEngine.pas
new file mode 100644
index 000000000..3b56c8dc8
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/fmFRFFEEngine.pas
@@ -0,0 +1,76 @@
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * Eivind Bakkestuen
+ * Used with permission.
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+unit fmFRFFEEngine;
+
+interface
+
+uses
+ SysUtils, Classes, fflllog, ffdb, DB, ffdbbase, ffllcomm, fflllgcy,
+ ffllbase, ffllcomp, fflleng, ffsrintm, ffclreng, FR_Class, FR_Desgn,
+ FR_DSet, FR_DBSet, FR_PTabl, FR_FFDB;
+
+type
+ TdmFRFFEEngine = class(TDataModule)
+ ffRemoteEngine: TFFRemoteServerEngine;
+ ffLegacyTransport: TffLegacyTransport;
+ ffClient: TffClient;
+ ffSession: TffSession;
+ ffDatabase: TffDatabase;
+ ffEventLog: TffEventLog;
+ frDesigner: TfrDesigner;
+ frReport: TfrReport;
+ frPrintTable: TfrPrintTable;
+ frFFComponents: TfrFFComponents;
+ procedure DataModuleCreate(Sender: TObject);
+ private
+ { Private declarations }
+ public
+ { Public declarations }
+ end;
+
+var
+ dmFRFFEEngine: TdmFRFFEEngine;
+
+implementation
+
+{$R *.dfm}
+
+Uses
+ Forms;
+
+procedure TdmFRFFEEngine.DataModuleCreate(Sender: TObject);
+begin
+ ffEventLog.FileName := ExtractFilePath(Application.ExeName)+'\ffe.log';
+ ffLegacyTransport.Enabled := False;
+ ffClient.Active := False;
+ ffClient.AutoClientName := True;
+ ffSession.ClientName := ffClient.ClientName;
+ ffSession.AutoSessionName := True;
+ ffDatabase.SessionName := ffSession.SessionName;
+end;
+
+end.
diff --git a/components/flashfiler/sourcelaz/explorer/fmmain.dfm b/components/flashfiler/sourcelaz/explorer/fmmain.dfm
new file mode 100644
index 000000000..b463c5077
Binary files /dev/null and b/components/flashfiler/sourcelaz/explorer/fmmain.dfm differ
diff --git a/components/flashfiler/sourcelaz/explorer/fmmain.pas b/components/flashfiler/sourcelaz/explorer/fmmain.pas
new file mode 100644
index 000000000..ce55a798f
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/fmmain.pas
@@ -0,0 +1,1937 @@
+{*********************************************************}
+{* FlashFiler Explorer Main Form *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit fmmain;
+
+{$IFDEF SingleEXE}
+!! Error: This application should not be compiled with SingleEXE mode enabled.
+{$ENDIF}
+interface
+
+uses
+ Windows,
+ Messages,
+ SysUtils,
+ Classes,
+ Graphics,
+ Controls,
+ Forms,
+ Dialogs,
+ Db,
+ Menus,
+ StdCtrls,
+ DBGrids,
+ DBCtrls,
+ Grids,
+ Outline,
+ ExtCtrls,
+ ComCtrls,
+ ffdbbase,
+ ffllbase,
+ ffllprot,
+ ffsrbde,
+ uconfig,
+ uentity,
+ fflllgcy,
+ ffdb,
+ fflllog
+{$IFDEF DCC4ORLATER}
+ ,
+ ImgList,
+ ToolWin
+{$ENDIF}
+;
+
+type
+ TfrmMain = class(TForm)
+ mnuMain: TMainMenu;
+ mnuHelp: TMenuItem;
+ mnuHelpAbout: TMenuItem;
+ mnuServer: TMenuItem;
+ N1: TMenuItem;
+ mnuServerExit: TMenuItem;
+ popmnuServer: TPopupMenu;
+ popmnuServerAttach: TMenuItem;
+ popmnuServerDetach: TMenuItem;
+ popmnuAlias: TPopupMenu;
+ popmnuTable: TPopupMenu;
+ popmnuTableDefinition: TMenuItem;
+ popmnuTableIndexes: TMenuItem;
+ popmnuTableRedefine: TMenuItem;
+ N2: TMenuItem;
+ popmnuTableDelete: TMenuItem;
+ popmnuTableRename: TMenuItem;
+ popmnuTableNew: TMenuItem;
+ popmnuDatabaseNew: TMenuItem;
+ popmnuDatabaseDelete: TMenuItem;
+ N3: TMenuItem;
+ popmnuDatabaseRefresh: TMenuItem;
+ pnlStatusContainer: TPanel;
+ pnlStatusBarComment: TPanel;
+ mnuServerRefresh: TMenuItem;
+ popmnuServerNewDatabase: TMenuItem;
+ N5: TMenuItem;
+ popmnuDatabaseNewTable: TMenuItem;
+ N6: TMenuItem;
+ popmnuServerRefresh: TMenuItem;
+ N7: TMenuItem;
+ mnuOptions: TMenuItem;
+ pnlBottomSpacer: TPanel;
+ popmnuTableReindex: TMenuItem;
+ mnuOptionsPrintSetup: TMenuItem;
+ popmnuTableImportSchema: TMenuItem;
+ mnuToolsFFComms: TMenuItem;
+ popmnuDatabaseRename: TMenuItem;
+ popmnuDatabaseImportSchema: TMenuItem;
+ mnuHelpTopics: TMenuItem;
+ N8: TMenuItem;
+ mnuHelpWebSite: TMenuItem;
+ mnuHelpEMail: TMenuItem;
+ dlgPrinterSetup: TPrinterSetupDialog;
+ mnuServerRegister: TMenuItem;
+ popmnuServerRegister: TMenuItem;
+ popmnuTableEmpty: TMenuItem;
+ pnlLeft: TPanel;
+ pnlLeftHeader: TPanel;
+ lblFlashFilerServers: TLabel;
+ mnuSetAutoInc: TMenuItem;
+ mnuOptionsLiveDatasets: TMenuItem;
+ logMain: TffEventLog;
+ outServers: TTreeView;
+ imgMain: TImageList;
+ mnuDatabaseSQL: TMenuItem;
+ mnuViewTable: TMenuItem;
+ N4: TMenuItem;
+ barToolBar: TToolBar;
+ tbRefresh: TToolButton;
+ tbServerRegister: TToolButton;
+ N12: TToolButton;
+ mnuWindows: TMenuItem;
+ mnuCloseAll: TMenuItem;
+ mnuWindowsSplitter: TMenuItem;
+ tbOptionsLiveDataSets: TToolButton;
+ tbOptionsPrintSetup: TToolButton;
+ N11: TToolButton;
+ tbCloseAll: TToolButton;
+ N13: TToolButton;
+ tbHelpTopics: TToolButton;
+ tbHelpWebSite: TToolButton;
+ tbHelpEMail: TToolButton;
+ popmnuTableSQL: TMenuItem;
+ mnuSetAsAutomaticDefault: TMenuItem;
+ N9: TMenuItem;
+ mnuTools: TMenuItem;
+ tbFFComms: TToolButton;
+ N10: TToolButton;
+ popmnuTableReindexAll: TMenuItem;
+ popmnuServerStatistics: TMenuItem;
+ mnuOptionsSetDefaultTimeout: TMenuItem;
+ N14: TMenuItem;
+
+ procedure mnuHelpAboutClick(Sender: TObject);
+ procedure FormCreate(Sender: TObject);
+ procedure mnuServerExitClick(Sender: TObject);
+ procedure outServersMouseDown(Sender: TObject; Button: TMouseButton;
+ Shift: TShiftState; X, Y: Integer);
+ procedure FormDestroy(Sender: TObject);
+ procedure mnuServerRefreshClick(Sender: TObject);
+ procedure popmnuTableDefinitionClick(Sender: TObject);
+ procedure popmnuTableNewClick(Sender: TObject);
+ procedure popmnuDatabaseNewTableClick(Sender: TObject);
+ procedure popmnuServerPopup(Sender: TObject);
+ procedure popmnuServerDetachClick(Sender: TObject);
+ procedure popmnuServerAttachClick(Sender: TObject);
+ procedure popmnuTableDeleteClick(Sender: TObject);
+ procedure popmnuTablePackClick(Sender: TObject);
+ procedure popmnuTableRedefineClick(Sender: TObject);
+ procedure popmnuTablePopup(Sender: TObject);
+ procedure popmnuTableIndexesClick(Sender: TObject);
+ procedure outServersClick(Sender: TObject);
+ procedure ExitBtnClick(Sender: TObject);
+ procedure popmnuServerNewDatabaseClick(Sender: TObject);
+ procedure popmnuTableReindexClick(Sender: TObject);
+ procedure popmnuTableImportSchemaClick(Sender: TObject);
+ procedure popmnuDatabaseImportSchemaClick(Sender: TObject);
+ procedure mnuHelpWebSiteClick(Sender: TObject);
+ procedure mnuHelpEMailClick(Sender: TObject);
+ procedure popmnuDatabaseDeleteClick(Sender: TObject);
+ procedure mnuOptionsPrintSetupClick(Sender: TObject);
+ procedure popmnuDatabaseRenameClick(Sender: TObject);
+ procedure mnuServerRegisterClick(Sender: TObject);
+ procedure mnuHelpTopicsClick(Sender: TObject);
+ procedure popmnuTableEmptyClick(Sender: TObject);
+ procedure mnuSetAutoIncClick(Sender: TObject);
+ procedure outServersDblClick(Sender: TObject);
+ procedure mnuOptionsLiveDatasetsClick(Sender: TObject);
+ procedure outServersExpanding(Sender: TObject; Node: TTreeNode;
+ var AllowExpansion: Boolean);
+ procedure outServersEditing(Sender: TObject; Node: TTreeNode;
+ var AllowEdit: Boolean);
+ procedure outServersEdited(Sender: TObject; Node: TTreeNode;
+ var S: String);
+ procedure outServersKeyDown(Sender: TObject; var Key: Word;
+ Shift: TShiftState);
+ procedure RefreshServers(Sender : TObject);
+ { Refresh the entire list of servers. }
+
+ procedure RefreshDatabases(Sender : TObject);
+ { Refresh a servers' list of databases. }
+
+ procedure RefreshTables(Sender : TObject);
+ procedure mnuDatabaseSQLClick(Sender: TObject);
+ procedure mnuViewTableClick(Sender: TObject);
+ procedure outServersCompare(Sender: TObject; Node1, Node2: TTreeNode;
+ Data: Integer; var Compare: Integer);
+ procedure FormClose(Sender: TObject; var Action: TCloseAction);
+ procedure mnuCloseAllClick(Sender: TObject);
+ procedure mnuWindowsClick(Sender: TObject);
+ procedure mnuToolsFFCommsClick(Sender: TObject);
+ procedure mnuSetAsAutomaticDefaultClick(Sender: TObject);
+ procedure outServersChange(Sender: TObject; Node: TTreeNode);
+ procedure outServersContextPopup(Sender: TObject; MousePos: TPoint;
+ var Handled: Boolean);
+ procedure popmnuServerRefreshClick(Sender: TObject);
+ procedure popmnuServerStatisticsClick(Sender: TObject);
+ procedure mnuOptionsSetDefaultTimeoutClick(Sender: TObject);
+ { Refresh a database's list of tables. }
+
+ private
+// function mapProtocolClassToProtocol(const Protocol : TffCommsProtocolClass) : TffProtocolType;
+ procedure WindowsMenuItemClick(Sender: TObject); {!!.06}
+ procedure AppMessage(var Msg: TMsg; var Handled: Boolean); {!!.06}
+ procedure DoIdle(Sender: TObject; var Done: Boolean);
+ procedure ApplicationEvents1Exception(Sender: TObject; E: Exception);
+ procedure ShowServerStatistics(aServer: TffeServerItem); {!!.06}
+ protected
+ Initialized: Boolean;
+ {- True if the (DB) Session has been started }
+
+ function GetNewSelectedNode(aNode : TTreeNode) : TTreeNode;
+ {- Assuming aNode is going to be deleted, determines which node should be
+ selected after the deletion. }
+
+ public
+ function AddOutlineDatabase(aNode : TTreeNode;
+ aDatabase: TffeDatabaseItem) : TTreeNode;
+ {- Adds a database entry to the outline. Returns outline index of new entry}
+ procedure AddOutlineServer(aServer : TffeServerItem);
+ {- Adds a server entry to the outline. Returns outline index of new entry}
+ procedure AddOutlineTable(aNode : TTreeNode; aTable : TffeTableItem);
+ {- Adds a table entry to the outline. Returns outline index of new entry}
+ procedure DeleteNodeChildren(aNode : TTreeNode);
+ {- Deletes all the children for a given outline entry }
+ function DoAttach(aNode : TTreeNode) : TffResult; {!!.01}
+ {- Attach to the given server }
+ procedure DoDetach;
+ {- Detach from given server }
+ procedure EnableScreen(aSwitch: Boolean);
+ {- Enables/Disables the main screen controls while a process runs; allows
+ main form to be minimized}
+ function GetEntityNode(aEntityType : TffeEntityType;
+ anEntity : TffeEntityItem): TTreeNode;
+ {- Returns the node for the given entity }
+ function GetNodeEntity(aNode : TTreeNode) : TffeEntityItem;
+ {- Returns the entity associated with a given node. }
+ function GetNodeEntityType(aNode : TTreeNode) : TffeEntityType;
+ {- Returns the entity type associated with a given node. }
+ function GetSelectedEntity : TffeEntityItem;
+ {- Returns the entity for the currently selected outline item. }
+ procedure Initialize;
+ {- Initial setup of the session and the server list }
+ procedure LoadConfig;
+ {- Read parameters out of persistent configuration storage }
+ procedure LoadOutlineServers;
+ {- Refreshes the entire outline view }
+ procedure LoadOutlineDatabases(aNode : TTreeNode);
+ {- Refreshes the outline view (databases, tables) for the given server}
+ procedure LoadOutlineTables(aNode : TTreeNode);
+ {- For a given database entry in the outline, load all of its member
+ tables into the outline. aNode may point to a table or
+ a database entry in the outline. }
+ procedure OutlineClear;
+ {- Frees the TffeOutlineData instances attached to the TTreeNodes in
+ outServers. Clears the TTreeView. }
+ procedure SaveConfig;
+ {- Writes the FFE configuration settings to persistent storage}
+ procedure ShowQueryWindow(aDatabaseIndex: LongInt);
+ {- Creates a modeless query window for a particular database. }
+ procedure ShowTableBrowser(aTable : TffeTableItem);
+ {- Creates a modeless table browser for a particular table. }
+ procedure slServerAttach(aServerIndex: LongInt);
+ {- event-handler for server attaches}
+ procedure StatusComment(aMsg: string);
+ {- Displays a message in the status bar}
+ procedure UncheckMenuGroupSiblings(aMenuItem: TMenuItem);
+ {- Unchecks all the menu items in the same menu group as the given item
+ (primary for compatibility with Delphi 1) }
+ procedure UpdateWindowsMenuItems; {!!.06}
+ {- populates the Windows menu with the current
+ table- and SQL-browser windows }
+ end;
+
+var
+ frmMain: TfrmMain;
+
+implementation
+
+uses
+ {$IFDEF USETeDEBUG}
+ jcldebug,
+ {$ENDIF}
+ ffclbase, {!!.07}
+ ffllcomm, {!!.07}
+ ffclreng, {!!.07}
+ ffclcfg, {!!.07}
+ ffutil,
+ uFFComms, {!!.07}
+ {$IFDEF DCC6OrLater}
+ Types, {!!.07}
+ {$ENDIF}
+ ffabout,
+ ubase,
+ uconsts,
+ dgaddals,
+ dgimport,
+ dgregsrv,
+ dgselidx,
+ ffllexcp, {!!.01}
+ fmprog,
+ fmstruct,
+ dgautoin,
+ dgtable,
+ dgquery,
+ dgServSt; {!!.11}
+
+{$R *.DFM}
+
+const
+ { Outline levels for schema entities }
+ lvServer = 1;
+ lvDatabase = 2;
+ lvTable = 3;
+
+{===TffeOutlineData==================================================}
+type
+ { This is the data kept by each outline entry to refer it to
+ the underlying data structure. }
+ TffeOutlineData = class
+ public
+ EntityType: TffeEntityType;
+ Entity : TffeEntityItem;
+ constructor Create(aEntityType: TffeEntityType; anEntity : TffeEntityItem);
+ end;
+
+
+constructor TffeOutlineData.Create(aEntityType: TffeEntityType;
+ anEntity : TffeEntityItem);
+begin
+ inherited Create;
+ EntityType := aEntityType;
+ Entity := anEntity;
+end;
+{====================================================================}
+
+{===TfrmMain=========================================================}
+function TfrmMain.AddOutlineDatabase(aNode : TTreeNode;
+ aDatabase : TffeDatabaseItem) : TTreeNode;
+var
+ OutlineData: TffeOutlineData;
+begin
+ Result := nil;
+ OutlineData := TffeOutlineData.Create(etDatabase, aDatabase);
+ with outServers do
+ with TffeOutlineData(aNode.Data) do
+ case EntityType of
+ etServer:
+ Result := Items.AddChildObject(aNode, aDatabase.DatabaseName,
+ OutlineData);
+ etDatabase:
+ Result := Items.AddObject(aNode, aDatabase.DatabaseName,
+ OutlineData);
+ end;
+ if assigned(Result) then begin
+ Result.ImageIndex := pred(lvDatabase);
+ Result.SelectedIndex := Result.ImageIndex;
+ Result.HasChildren := True;
+ end;
+ outServers.AlphaSort;
+end;
+{--------}
+procedure TfrmMain.AddOutlineServer(aServer : TffeServerItem);
+var
+ Node : TTreeNode;
+ OutlineData: TffeOutlineData;
+ aProtocol : TffCommsProtocolClass;
+ aProtocolName : TffShStr;
+
+
+ {Begin !!.07}
+ { removes leading zeroes in order to compare ip addresses
+ like 192.000.001.001 against 192.0.1.1 - necessary because
+ FFCOMMS might register addresses with extra 0's }
+ function StripLeadingZeros(servername : String) : String;
+ var
+ s : String;
+ begin
+ Result := '';
+ { while characters in string do }
+ while (Length(servername)>0) do begin
+ { if first char not a number}
+ if NOT (servername[1] IN ['0'..'9']) then begin
+ { move char to result }
+ Result := Result + servername[1];
+ Delete(servername, 1, 1);
+ end
+ else begin
+ s := '';
+ { collect numbers up to next non-numerical char }
+ while (Length(servername)>0) and (servername[1] IN ['0'..'9']) do begin
+ s := s + servername[1];
+ Delete(servername, 1, 1);
+ end;
+ { strip leading zeroes and add to Result }
+ Result := Result + IntToStr(StrToInt(s));
+ end;
+ end;
+ end;
+ {End !!.07}
+
+begin
+ OutlineData := TffeOutlineData.Create(etServer, aServer);
+ with outServers do
+ Node := Items.AddObject(outServers.TopItem, aServer.ServerName, OutlineData);
+ if assigned(Node) then begin
+ {Begin !!.07}
+ { check if the server is the default for the workstation
+ and use a different glyph if so }
+ FFClientConfigReadProtocol(aProtocol, aProtocolName);
+ if (FFGetProtocolString(aServer.Protocol)=aProtocolName) and
+ ((aServer.Protocol=ptSingleUser) or
+ (StripLeadingZeros(FFClientConfigReadServerName)=StripLeadingZeros(aServer.ServerName))) then begin
+ Node.ImageIndex := 12;
+ end
+ else
+ {End !!.07}
+ Node.ImageIndex := pred(lvServer);
+ Node.SelectedIndex := Node.ImageIndex;
+ Node.HasChildren := True;
+ end;
+ outServers.AlphaSort;
+end;
+{--------}
+procedure TfrmMain.AddOutlineTable(aNode : TTreeNode; aTable : TffeTableItem);
+var
+ Node : TTreeNode;
+ OutlineData: TffeOutlineData;
+begin
+ Node := nil;
+ OutlineData := TffeOutlineData.Create(etTable, aTable);
+ with outServers do
+ with TffeOutlineData(aNode.Data) do
+ case EntityType of
+ etDatabase:
+ Node := Items.AddChildObject(aNode, aTable.TableName, OutlineData);
+ etTable:
+ Node := Items.AddObject(aNode, aTable.TableName, OutlineData);
+ end;
+ if assigned(Node) then begin
+ Node.ImageIndex := pred(lvTable);
+ Node.SelectedIndex := Node.ImageIndex;
+ Node.HasChildren := False;
+ end;
+ outServers.AlphaSort;
+end;
+{--------}
+procedure TfrmMain.DeleteNodeChildren(aNode : TTreeNode);
+var
+ aChild : TTreeNode;
+begin
+ with outServers do begin
+ Items.BeginUpdate;
+ try
+ with aNode do begin
+ aChild := GetFirstChild;
+ while assigned(aChild) do begin
+ if assigned(aChild.Data) then begin
+ DeleteNodeChildren(aChild);
+ TffeOutlineData(aChild.Data).free;
+ end;
+ aChild := GetNextChild(aChild);
+ end;
+ end;
+ aNode.DeleteChildren;
+ finally
+ Items.EndUpdate;
+ end;
+ end;
+end;
+{--------}
+function TfrmMain.DoAttach(aNode : TTreeNode) : TffResult; {!!.01}
+var
+ aServer : TffeServerItem;
+begin
+ aServer := TffeServerItem(TffeOutlineData(aNode.Data).Entity);
+ try
+ Result := aServer.Attach(logMain); {!!.01}
+ if Result = DBIERR_NONE then begin {!!.01}
+ LoadOutlineDatabases(aNode); {!!.01}
+ Config.LastServer := aServer.ServerName; {!!.01}
+ end; {!!.01}
+ except
+ on E: EffDatabaseError do begin {!!.01}
+ if E.ErrorCode = 11278 then
+ raise EffDatabaseError.CreateFmt('Unable to connect. "%S" is currently unavailable',
+ [aServer.EntityName])
+ else
+ raise;
+ end; {!!.01}
+ end;
+end;
+{--------}
+procedure TfrmMain.DoDetach;
+var
+ aServer : TffeServerItem;
+begin
+ aServer := TffeServerItem(GetSelectedEntity);
+ if assigned(aServer) then begin
+ outServers.Selected.Collapse(True);
+ DeleteNodeChildren(outServers.Selected);
+ aServer.Detach;
+ outServers.Selected.HasChildren := True;
+ end;
+end;
+{--------}
+procedure TfrmMain.EnableScreen(aSwitch: Boolean);
+begin
+ if aSwitch then Application.ProcessMessages;
+ mnuServer.Enabled := aSwitch;
+ mnuOptions.Enabled := aSwitch;
+end;
+{--------}
+function TfrmMain.GetEntityNode(aEntityType: TffeEntityType;
+ anEntity: TffeEntityItem): TTreeNode;
+var
+ I : longInt;
+begin
+ Result := nil;
+ with outServers do
+ for I := 0 to pred(Items.Count) do
+ with TffeOutlineData(Items[I].Data) do
+ if (EntityType = aEntityType) and
+ (Entity = anEntity) then begin
+ Result := Items[I];
+ Break;
+ end;
+end;
+{--------}
+function TfrmMain.GetNodeEntity(aNode : TTreeNode) : TffeEntityItem;
+begin
+ Result := TffeOutlineData(aNode.Data).Entity;
+end;
+{--------}
+function TfrmMain.GetNodeEntityType(aNode : TTreeNode) : TffeEntityType;
+begin
+ Result := TffeOutlineData(aNode.Data).EntityType;
+end;
+{--------}
+function TfrmMain.GetSelectedEntity : TffeEntityItem;
+begin
+ Result := TffeOutlineData(outServers.Selected.Data).Entity;
+end;
+{--------}
+procedure TfrmMain.Initialize;
+begin
+ try
+ Initialized := False;
+ if not assigned(ServerList) then begin
+ ServerList := TffeServerList.Create(logMain);
+ ServerList.OnAttach := slServerAttach;
+ end;
+ LoadOutlineServers;
+ except
+ on E:Exception do
+ showMessage(E.Message);
+ end;
+end;
+{--------}
+procedure TfrmMain.LoadConfig;
+begin
+ { Set window coordinates }
+ WindowState := Config.WindowState;
+ if (WindowState <> wsMaximized) and (Config.Window.Bottom <> 0) then
+ with Config do begin
+ Left := Window.Left;
+ Top := Window.Top;
+ Width := Window.Right - Config.Window.Left;
+ Height := Window.Bottom - Config.Window.Top;
+ end;
+ mnuOptionsLiveDataSets.Checked := coLiveDatasets in Config.Options;
+ tbOptionsLiveDataSets.Down := mnuOptionsLiveDataSets.Checked; {!!.06}
+end;
+{--------}
+procedure TfrmMain.OutlineClear;
+var
+ Index : longInt;
+begin
+ { Free the TffeOutlineData structures associated with the nodes. }
+ with outServers do begin
+ for Index := 0 to pred(Items.Count) do
+ if assigned(Items[Index].Data) then
+ TffeOutlineData(Items[Index].Data).Free;
+ end;
+ outServers.Items.Clear;
+end;
+{--------}
+procedure TfrmMain.LoadOutlineServers;
+var
+ aNode : TTreeNode;
+ Server : TffeServerItem;
+ S : LongInt;
+ DefaultServerName: TffNetAddress;
+ OldCursor: TCursor;
+begin
+
+ OutlineClear;
+
+ { Load up the registered servers into the outline }
+ StatusComment('Searching for active FlashFiler servers...');
+ mnuServer.Enabled := False;
+ outServers.Enabled := False;
+ OldCursor := Screen.Cursor;
+ Screen.Cursor := crHourglass;
+ try
+ ServerList.Load;
+
+ { Load up all the servers into the outline }
+ for S := 0 to ServerList.Count - 1 do
+ AddOutlineServer(ServerList.Items[S]);
+
+ { Find the default server }
+ DefaultServerName := Config.LastServer;
+ if DefaultServerName <> '' then begin
+ S := ServerList.IndexOfName(DefaultServerName);
+ if S <> -1 then begin
+ Server := ServerList.Items[S];
+ aNode := GetEntityNode(etServer, Server);
+{Begin !!.01}
+ { Attached to server? }
+ if DoAttach(aNode) = DBIERR_NONE then
+ { Expand the attached server. If the server has only one
+ database then expand the database too. }
+ aNode.Expand(Server.DatabaseCount = 1);
+{End !!.01}
+ end;
+ end;
+ outServers.AlphaSort;
+ finally
+ Screen.Cursor := OldCursor;
+ outServers.Invalidate;
+ StatusComment('');
+ if outServers.Items.Count = 0 then
+ StatusComment('No active FlashFiler servers found.');
+ Screen.Cursor := OldCursor;
+ mnuServer.Enabled := True;
+ outServers.Enabled := True;
+ end;
+end;
+{--------}
+procedure TfrmMain.LoadOutlineDatabases(aNode : TTreeNode);
+{ For a given server entry in the outline, load all of its member
+ databases into the outline }
+var
+ D : longInt;
+ Server : TffeServerItem;
+begin
+
+ Server := TffeServerItem(TffeOutlineData(aNode.Data).Entity);
+
+ if (not Server.Attached) then
+ if DoAttach(aNode) <> DBIERR_NONE then {!!.01}
+ Exit; {!!.01}
+
+ { Delete all the children of this server }
+ DeleteNodeChildren(aNode);
+
+ { Load the databases into the outline; we assume the server's database list &
+ table list have already been populated. }
+ for D := 0 to pred(Server.DatabaseCount) do
+ AddOutlineDatabase(aNode, Server.Databases[D]);
+
+ outServers.AlphaSort;
+end;
+{--------}
+procedure TfrmMain.LoadOutlineTables(aNode : TTreeNode);
+var
+ Database : TffeDatabaseItem;
+ T: LongInt;
+begin
+ { If we're pointing to a table entry, kick up to the table's
+ database entry }
+ with TffeOutlineData(aNode.Data) do
+ if EntityType = etTable then begin
+ aNode := aNode.Parent;
+ outServers.Selected := aNode;
+ end;
+ Database := TffeDatabaseItem(TffeOutlineData(aNode.Data).Entity);
+
+ outServers.Items.BeginUpdate;
+ try
+ { Delete all the children of this database }
+ DeleteNodeChildren(aNode);
+
+ { Load the database's tables. }
+ Database.LoadTables;
+
+ { Load the database's tables into the outline }
+ for T := 0 to pred(Database.TableCount) do
+ AddOutlineTable(aNode, Database.Tables[T]);
+ outServers.AlphaSort;
+ finally
+ outServers.Items.EndUpdate;
+ end;
+
+end;
+{--------}
+procedure TfrmMain.SaveConfig;
+begin
+ if Assigned(Config) then begin
+ with Config do begin
+ Window := Bounds(Left, Top, Width, Height);
+ Options := [];
+ end;
+ Config.WindowState := WindowState;
+ Config.Options := [];
+ if mnuOptionsLiveDataSets.Checked then
+ Config.Options := [coLiveDataSets];
+
+ Config.Save;
+ end;
+end;
+{--------}
+procedure TfrmMain.ShowQueryWindow(aDatabaseIndex : LongInt);
+var
+ dummy: Boolean;
+begin
+ { implicitly check valid directory }
+ outServersExpanding(outServers, outServers.Selected, dummy); {!!.07}
+ with TdlgQuery.create(nil) do begin
+ {Begin !!.07}
+ { If we're pointing to a table entry, get the table's
+ database entry from the parent }
+ if TffeOutlineData(outServers.Selected.Data).EntityType = etTable then begin
+ DatabaseItem := TffeDatabaseItem(TffeOutlineData(outServers.Selected.Parent.Data).Entity);
+ ServerName := outServers.Selected.Parent.Parent.Text;
+ DatabaseName := outServers.Selected.Parent.Text;
+ Protocol := TffeDatabaseItem(TffeOutlineData(outServers.Selected.Parent.Data).Entity).Server.Protocol;
+ InitialStatement := 'SELECT * FROM ' +
+ TffeTableItem(TffeOutlineData(outServers.Selected.Data).Entity).TableName;
+ with TffexpSession(TffeDatabaseItem(TffeOutlineData(outServers.Selected.Parent.Data).Entity).Database.Session) do begin
+ Password := ffePassword;
+ UserName := ffeUserName;
+ end;
+ end
+ else
+ begin
+ DatabaseItem := TffeDatabaseItem(GetSelectedEntity);
+ ServerName := outServers.Selected.Parent.Text;
+ DatabaseName := outServers.Selected.Text;
+ Protocol := TffeDatabaseItem(GetSelectedEntity).Server.Protocol;
+ with TffexpSession(TffeDatabaseItem(GetSelectedEntity).Database.Session) do begin
+ Password := ffePassword;
+ UserName := ffeUserName;
+ end;
+ end;
+ {End !!.07}
+ Log := LogMain; {!!.02}
+ Show;
+ end;
+end;
+{--------}
+procedure TfrmMain.ShowTableBrowser(aTable : TffeTableItem);
+var
+ OldCursor: TCursor;
+ aTableDlg : TdlgTable;
+begin
+ OldCursor := Screen.Cursor;
+ Screen.Cursor := crHourglass;
+ try
+ aTableDlg := TdlgTable.Create(Application); {!!.02}
+ with aTableDlg do begin
+ TableItem := aTable; {!!.10}
+ Protocol := aTable.Server.Protocol; {!!.07}
+ ServerName := aTable.Server.ServerName;
+ DatabaseName := aTable.Database.DatabaseName;
+ TableName := aTable.TableName;
+ UserName := TffexpSession(aTable.Table.Session).ffeUserName;
+ Password := TffexpSession(aTable.Table.Session).ffePassword;
+ ReadOnly := (not mnuOptionsLiveDataSets.Checked);
+ Log := LogMain; {!!.02}
+ Show;
+ end;
+ finally
+ Screen.Cursor := OldCursor;
+ end;
+end;
+{--------}
+procedure TfrmMain.slServerAttach(aServerIndex: LongInt);
+begin
+ StatusComment('');
+end;
+{--------}
+procedure TfrmMain.StatusComment(aMsg: string);
+begin
+ pnlStatusBarComment.Caption := ' ' + aMsg;
+ Application.ProcessMessages;
+end;
+{====================================================================}
+
+{===Form-level event handlers========================================}
+procedure TfrmMain.ApplicationEvents1Exception(Sender: TObject; E: Exception);
+{$IFDEF USETeDEBUG}
+var
+ i : Integer;
+ sl : TSTringList;
+{$ENDIF}
+begin
+ {$IFDEF USETeDEBUG}
+ sl := TSTringList.Create;
+ try
+ sl.Add(E.Message);
+ if JclLastExceptStackList <> nil then
+ JclLastExceptStackList.AddToStrings(sl);
+ for i := 0 to sl.Count-1 do
+ logMain.WriteString(sl[i]);
+ Application.ShowException(E);
+ finally
+ sl.Free;
+ end;
+ {$ELSE}
+ Application.ShowException(E);
+ {$ENDIF}
+end;
+
+procedure TfrmMain.FormCreate(Sender: TObject);
+begin
+ { write log to app directory }
+ logMain.FileName := Config.WorkingDirectory + ChangeFileExt(ExtractFileName(Application.ExeName), '.LOG'); {!!.11}
+ Application.OnException := ApplicationEvents1Exception;
+ HelpContext := hcMainOutline;
+ Initialized := False;
+
+ if FileExists(ExtractFilePath(ParamStr(0)) + 'FFE.HLP') then
+ Application.HelpFile := ExtractFilePath(ParamStr(0)) + 'FFE.HLP'
+ else
+ Application.HelpFile := ExtractFilePath(ParamStr(0)) + '..\HELP\FFE.HLP';
+
+ mnuOptionsLiveDataSets.Checked := True;
+ tbOptionsLiveDataSets.Down := mnuOptionsLiveDataSets.Checked; {!!.06}
+
+ LoadConfig;
+
+ Application.OnMessage := AppMessage;
+ Application.OnIdle := DoIdle;
+end;
+{Begin !!.02}
+{--------}
+procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
+var
+ Idx : Integer;
+begin
+ for Idx := 0 to Pred(Screen.FormCount) do
+ if (Screen.Forms[Idx] is TdlgTable) or
+ (Screen.Forms[Idx] is TdlgQuery) or
+ (Screen.Forms[Idx] is TdlgServerStats) then {!!.11}
+ Screen.Forms[Idx].Close;
+end;
+{End !!.02}
+{--------}
+procedure TfrmMain.FormDestroy(Sender: TObject);
+begin
+ ClosingApp := True;
+ outServers.onClick := nil;
+ ServerList.Free;
+ SaveConfig;
+ OutlineClear;
+end;
+{====================================================================}
+
+{===Server menu event handlers=======================================}
+procedure TfrmMain.mnuServerRefreshClick(Sender: TObject);
+begin
+ LoadOutlineServers;
+end;
+{--------}
+procedure TfrmMain.mnuServerRegisterClick(Sender: TObject);
+begin
+ if ShowRegisteredServersDlg = mrOK then
+ LoadOutlineServers;
+end;
+{--------}
+procedure TfrmMain.mnuServerExitClick(Sender: TObject);
+begin
+ Close;
+end;
+
+{ "Options" menu event-handlers }
+
+procedure TfrmMain.mnuOptionsPrintSetupClick(Sender: TObject);
+begin
+ dlgPrinterSetup.Execute;
+end;
+{====================================================================}
+
+{===Help menu event handlers=========================================}
+procedure TfrmMain.mnuHelpTopicsClick(Sender: TObject);
+begin
+ Application.HelpCommand(HELP_FINDER, 0);
+end;
+{--------}
+procedure TfrmMain.mnuHelpAboutClick(Sender: TObject);
+var
+ AboutBox : TFFAboutBox;
+begin
+ AboutBox := TFFAboutBox.Create(Application);
+ try
+ AboutBox.Caption := 'About FlashFiler Explorer';
+ AboutBox.ProgramName.Caption := 'FlashFiler Explorer';
+ AboutBox.ShowModal;
+ finally
+ AboutBox.Free;
+ end;
+end;
+{--------}
+procedure TfrmMain.mnuHelpWebSiteClick(Sender: TObject);
+begin
+ ShellToWWW;
+end;
+{--------}
+procedure TfrmMain.mnuHelpEMailClick(Sender: TObject);
+begin
+ ShellToEMail;
+end;
+{====================================================================}
+
+{===Server outline event handlers====================================}
+procedure TfrmMain.outServersClick(Sender: TObject);
+{ Set the popup menu depending on which level we are on }
+begin
+ with outServers do begin
+ if assigned(Selected) then
+ case TffeOutlineData(Selected.Data).EntityType of
+ etServer:
+ begin
+ PopupMenu := popmnuServer;
+ end;
+ etDatabase:
+ begin
+ PopupMenu := popmnuAlias;
+ end;
+ etTable:
+ begin
+ PopupMenu := popmnuTable;
+ end;
+ end;
+ end;
+end;
+{--------}
+procedure TfrmMain.outServersCompare(Sender: TObject; Node1,
+ Node2: TTreeNode; Data: Integer; var Compare: Integer);
+begin
+ Compare := FFAnsiCompareText(Node1.Text, Node2.Text); {!!.07}
+end;
+{--------}
+procedure TfrmMain.outServersMouseDown(Sender: TObject;
+ Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
+var
+ aNode : TTreeNode;
+begin
+ if Button = mbRight then begin
+ aNode := outServers.GetNodeAt(X,Y);
+ if assigned(aNode) and assigned(aNode.Data) then begin
+ outServers.Selected := aNode;
+ case TffeOutlineData(aNode.Data).EntityType of
+ etServer: PopupMenu := popmnuServer;
+ etDatabase: PopupMenu := popmnuAlias;
+ etTable: PopupMenu := popmnuTable;
+ end;
+ PopupMenu.Popup(ClientToScreen(Point(X, Y)).X + 5,
+ ClientToScreen(Point(X, Y)).Y + 5);
+ end;
+ end;
+end;
+{====================================================================}
+
+{===Server outline context menus event handlers======================}
+procedure TfrmMain.popmnuServerPopup(Sender: TObject);
+var
+ Entity : TffeEntityItem;
+begin
+ Entity := TffeOutlineData(outServers.Selected.Data).Entity;
+ popmnuServerAttach.Enabled := not TffeServerItem(Entity).Attached;
+ popmnuServerDetach.Enabled := not popmnuServerAttach.Enabled;
+ popmnuServerNewDatabase.Enabled := not popmnuServerAttach.Enabled;
+end;
+{--------}
+procedure TfrmMain.popmnuServerAttachClick(Sender: TObject);
+var
+ aNode : TTreeNode;
+ Server : TffeServerItem;
+begin
+
+ aNode := outServers.Selected;
+{Begin !!.01}
+ if DoAttach(aNode) = DBIERR_NONE then begin
+ Server := TffeServerItem(GetSelectedEntity);
+
+ { Expand the attached server. If it has only one database then expand
+ the database too. }
+ aNode.Expand(Server.DatabaseCount = 1);
+ end;
+{End !!.01}
+end;
+{--------}
+procedure TfrmMain.popmnuServerDetachClick(Sender: TObject);
+begin
+ DoDetach;
+end;
+{--------}
+procedure TfrmMain.RefreshServers(Sender: TObject);
+begin
+ LoadOutlineServers;
+end;
+{--------}
+procedure TfrmMain.RefreshDatabases(Sender: TObject);
+var
+ aNode : TTreeNode;
+ OldCursor : TCursor;
+ Server : TffeServerItem;
+begin
+ OldCursor := Screen.Cursor;
+ Screen.Cursor := crHourglass;
+ outServers.Items.BeginUpdate;
+ try
+ { Get the server. }
+ aNode := outServers.Selected;
+ Server := TffeServerItem(GetNodeEntity(aNode));
+ Server.LoadDatabases;
+ LoadOutlineDatabases(aNode);
+ aNode.Expand(False);
+ finally
+ outServers.Items.EndUpdate;
+ Screen.Cursor := OldCursor;
+ end;
+end;
+{--------}
+procedure TfrmMain.RefreshTables(Sender: TObject);
+var
+ aNode : TTreeNode;
+ Database : TffeDatabaseItem;
+ OldCursor : TCursor;
+begin
+ OldCursor := Screen.Cursor;
+ Screen.Cursor := crHourglass;
+ outServers.Items.BeginUpdate;
+ try
+ { Get the database. }
+ aNode := outServers.Selected;
+ Database := TffeDatabaseItem(GetNodeEntity(aNode));
+ Database.LoadTables;
+ LoadOutlineTables(aNode);
+ aNode.Expand(True);
+ finally
+ outServers.Items.EndUpdate;
+ Screen.Cursor := OldCursor;
+ end;
+end;
+{--------}
+procedure TfrmMain.popmnuDatabaseNewTableClick(Sender: TObject);
+var
+ Database : TffeDatabaseItem;
+ TableIndex: LongInt;
+ dummy : Boolean;
+begin
+ { make sure tablelist is loaded; implicitly checks for valid directory }
+ outServersExpanding(outServers, outServers.Selected, dummy); {!!.06}
+ Database := TffeDatabaseItem(GetSelectedEntity);
+ with outServers do
+ if ShowCreateTableDlg(Database, TableIndex, nil) = mrOK then begin
+ LoadOutlineTables(Selected);
+ Selected.Expand(False);
+ end;
+end;
+{--------}
+procedure TfrmMain.popmnuServerNewDatabaseClick(Sender: TObject);
+var
+ aDatabase : TffeDatabaseItem;
+ anEntity : TffeEntityItem;
+ aNode : TTreeNode;
+ Server : TffeServerItem;
+begin
+ aDatabase := nil;
+ Server := nil;
+ aNode := outServers.Selected;
+ anEntity := TffeOutlineData(aNode.Data).Entity;
+ case anEntity.EntityType of
+ etServer :
+ Server := TffeServerItem(anEntity);
+ etDatabase :
+ begin
+ aNode := aNode.Parent;
+ Server := TffeServerItem(TffeOutlineData(aNode.Data).Entity);
+ end;
+ end;
+
+ with outServers do begin
+ if ShowAddAliasDlg(Server, aDatabase) = mrOK then
+ LoadOutlineTables
+ (AddOutlineDatabase(aNode, aDatabase));
+ AlphaSort;
+ end;
+end;
+{--------}
+function TfrmMain.GetNewSelectedNode(aNode : TTreeNode) : TTreeNode;
+begin
+ { Does the node have a previous sibling? }
+ Result := aNode.Parent.GetPrevChild(aNode);
+ if not assigned(Result) then begin
+ { No previous sibling. See if has next sibling. }
+ Result := aNode.Parent.GetNextChild(aNode);
+ if not assigned(Result) then
+ { No siblings. Default to parent node. }
+ Result := aNode.Parent;
+ end;
+end;
+{--------}
+procedure TfrmMain.popmnuDatabaseDeleteClick(Sender: TObject);
+var
+ aNode : TTreeNode;
+ Database : TffeDatabaseItem;
+begin
+ Database := TffeDatabaseItem(GetSelectedEntity);
+ if MessageDlg('Delete ' + Database.DatabaseName + '?',
+ mtConfirmation, [mbYes, mbNo], 0) = mrYes then begin
+ Screen.Cursor := crHourglass;
+ try
+
+ { Delete the database from the server. }
+ Database.Server.DropDatabase(Database.DatabaseName);
+
+ { Delete database from outline }
+ with outServers do begin
+ aNode := Selected;
+ if assigned(aNode.Data) then
+ TffeOutlineData(aNode.Data).free;
+ Selected := GetNewSelectedNode(aNode);
+ Items.Delete(aNode);
+ end;
+ finally
+ Screen.Cursor := crDefault;
+ end;
+ end;
+end;
+{--------}
+procedure TfrmMain.popmnuDatabaseRenameClick(Sender: TObject);
+begin
+ outServers.Selected.EditText;
+end;
+{--------}
+procedure TfrmMain.popmnuDatabaseImportSchemaClick(Sender: TObject);
+var
+ Database : TffeDatabaseItem;
+ TableIndex: LongInt;
+ dummy : Boolean;
+begin
+ outServersExpanding(outServers, outServers.Selected, dummy);
+ TableIndex := -1;
+ Database := TffeDatabaseItem(GetSelectedEntity);
+ with outServers do begin
+ ShowImportDlg(Database, TableIndex);
+ if TableIndex <> -1 then {we have a new table}
+ AddOutlineTable(Selected, Database.Tables[TableIndex]);
+ end;
+end;
+{--------}
+procedure TfrmMain.popmnuTablePopup(Sender: TObject);
+var
+ Table : TffeTableItem;
+ I: Integer;
+begin
+ Table := TffeTableItem(GetSelectedEntity);
+ with Table do
+ with popmnuTable do begin
+ if Rebuilding then begin
+ for I := 0 to Items.Count - 1 do
+ Items[I].Enabled := False;
+ popmnuTableNew.Enabled := True;
+ end
+ else
+ for I := 0 to Items.Count - 1 do
+ Items[I].Enabled := True;
+ end;
+end;
+{--------}
+procedure TfrmMain.popmnuTableDefinitionClick(Sender: TObject);
+var
+ Database : TffeDatabaseItem;
+ Table : TffeTableItem;
+begin
+ Table := TffeTableItem(GetSelectedEntity);
+ Database := Table.Database;
+ ShowViewTableStructureDlg(Database, Database.IndexOf(Table), vtViewFields);
+end;
+{--------}
+procedure TfrmMain.popmnuTableIndexesClick(Sender: TObject);
+var
+ Database : TffeDatabaseItem;
+ Table : TffeTableItem;
+begin
+ Table := TffeTableItem(GetSelectedEntity);
+ Database := Table.Database;
+ ShowViewTableStructureDlg(Database, Database.IndexOf(Table), vtViewIndexes);
+end;
+{--------}
+procedure TfrmMain.popmnuTableNewClick(Sender: TObject);
+var
+ Database : TffeDatabaseItem;
+ Table : TffeTableItem;
+ TableIndex : longInt;
+begin
+ Table := TffeTableItem(GetSelectedEntity);
+ Database := Table.Database;
+ TableIndex := Database.IndexOf(Table);
+ with outServers do
+ if ShowCreateTableDlg(Database, TableIndex, nil) = mrOK then
+ LoadOutlineTables(outServers.Selected);
+// AddOutlineTable(Selected, Table);
+end;
+{--------}
+procedure TfrmMain.popmnuTableDeleteClick(Sender: TObject);
+var
+ aNode : TTreeNode;
+ Table : TffeTableItem;
+begin
+ Table := TffeTableItem(GetSelectedEntity);
+ if MessageDlg(Format('Delete table %s?', [Table.TableName]),
+ mtConfirmation,
+ [mbYes, mbNo],
+ 0) = mrYes then begin
+ Screen.Cursor := crHourglass;
+ try
+ Table.Database.DropTable(Table.Database.IndexOf(Table));
+
+ { Remove table from tree view. }
+ with outServers do begin
+ aNode := Selected;
+ if assigned(aNode.Data) then
+ TffeOutlineData(aNode.Data).free;
+ Selected := GetNewSelectedNode(aNode);
+ aNode.Delete;
+ end;
+ finally
+ Screen.Cursor := crDefault;
+ end;
+ end;
+end;
+{--------}
+procedure TfrmMain.popmnuTablePackClick(Sender: TObject);
+var
+ aNode : TTreeNode;
+ Status: TffRebuildStatus;
+ RebuildDone: Boolean;
+ Table : TffeTableItem;
+ PromptMsg : string; {!!.10}
+ StatusMsg : string; {!!.10}
+begin
+ PromptMsg := 'Are you sure you want to pack/reindex this table?'; {!!.10}
+ StatusMsg := 'Packing'; {!!.10}
+
+ if MessageDlg(PromptMsg, mtConfirmation, {!!.10}
+ [mbYes, mbNo], 0) = mrYes then begin
+
+ aNode := outServers.Selected;
+ Table := TffeTableItem(GetNodeEntity(aNode));
+
+ with Table do begin
+ Pack;
+
+ if Rebuilding then begin
+
+ { Change the display in the outline; table will be unavailable
+ until the rebuild is done. }
+ aNode.Text := TableName + ' (packing)';
+ try
+ Application.ProcessMessages;
+
+ { Display the rebuild progress window }
+ with TfrmRebuildStatus.Create(nil) do
+ try
+ ShowProgress(StatusMsg, TableName); {!!.10}
+ try
+ repeat
+ CheckRebuildStatus(RebuildDone, Status);
+ if not RebuildDone then begin
+ UpdateProgress(RebuildDone, Status);
+ Sleep(250);
+ end;
+ until RebuildDone;
+ finally
+ Hide;
+ end;
+ finally
+ Free;
+ end;
+ finally
+ aNode.Text := TableName;
+ end;
+ end;
+ end;
+ end;
+end;
+{--------}
+procedure TfrmMain.popmnuTableReindexClick(Sender: TObject);
+var
+ aNode : TTreeNode;
+ IndexNum: Integer;
+ RebuildDone: Boolean;
+ Status: TffRebuildStatus;
+ Table : TffeTableItem;
+begin
+ Table := TffeTableItem(GetSelectedEntity);
+ if SelectIndexDlg(Table, IndexNum) = mrOk then begin
+ aNode := outServers.Selected;
+
+ with Table do begin
+ Reindex(IndexNum);
+
+ { Change the display in the outline; table will be unavailable
+ until the rebuild is done. }
+ aNode.Text := TableName + ' (reindexing)';
+ try
+ Application.ProcessMessages;
+
+ { Display the rebuild progress window }
+ with TfrmRebuildStatus.Create(nil) do
+ try
+ ShowProgress('Reindexing', TableName);
+ try
+ repeat
+ CheckRebuildStatus(RebuildDone, Status);
+ if not RebuildDone then begin
+ UpdateProgress(RebuildDone, Status);
+ Sleep(250);
+ end;
+ until RebuildDone;
+ finally
+ Hide;
+ end;
+ finally
+ Free;
+ end;
+ finally
+ aNode.Text := TableName;
+ end;
+ end;
+ end;
+end;
+{--------}
+procedure TfrmMain.popmnuTableRedefineClick(Sender: TObject);
+var
+ aNode : TTreeNode;
+ Status: TffRebuildStatus;
+ RebuildDone: Boolean;
+ Database : TffeDatabaseItem;
+ Table : TffeTableItem;
+ TableIndex : longInt;
+ UnableToOpen : Boolean;
+begin
+ Table := TffeTableItem(GetSelectedEntity);
+ Database := Table.Database;
+ TableIndex := Database.IndexOf(Table);
+ with outServers do begin
+ if Table.Table.Active then
+ Table.Table.Close;
+ Table.Table.Exclusive := True;
+ try
+ Screen.Cursor := crHourGlass;
+ try
+ Table.Table.Open;
+ Table.Table.Close;
+ UnableToOpen := False;
+ finally
+ Table.Table.Exclusive := False;
+ Screen.Cursor := crDefault;
+ end;
+ except
+ UnableToOpen := True;
+ end;
+ if UnableToOpen then begin
+ MessageDlg('Unable to gain exclusive access to the table. Restructure operation '
+ + #13 + #10 + 'cannot contiue.', mtInformation, [mbOK], 0);
+ Exit;
+ end;
+ if ShowRestructureTableDlg(Database, TableIndex) = mrOK then begin
+ aNode := outServers.Selected;
+
+ with Table do begin
+ if Rebuilding then begin
+
+ { Change the display in the outline; table will be unavailable
+ until the rebuild is done. }
+ aNode.Text := TableName + ' (restructuring)';
+ try
+ Application.ProcessMessages;
+
+ { Display the rebuild progress window }
+ with TfrmRebuildStatus.Create(nil) do
+ try
+ ShowProgress('Restructuring', TableName);
+ try
+ repeat
+ CheckRebuildStatus(RebuildDone, Status);
+ if not RebuildDone then begin
+ UpdateProgress(RebuildDone, Status);
+ Sleep(250);
+ end;
+ until RebuildDone;
+ finally
+ Hide;
+ end;
+ Check(Status.rsErrorCode);
+ finally
+ Free;
+ end;
+ finally
+ aNode.Text := TableName;
+ end;
+ end;
+ end;
+ end;
+ end;
+ if Table.Table.Active then {!!.06}
+ Table.Table.Close {!!.06}
+end;
+{--------}
+procedure TfrmMain.popmnuTableImportSchemaClick(Sender: TObject);
+var
+ Database : TffeDatabaseItem;
+ Table : TffeTableItem;
+ TableIndex : longInt;
+begin
+ Table := TffeTableItem(GetSelectedEntity);
+ Database := Table.Database;
+ TableIndex := Database.IndexOf(Table);
+
+ with outServers do begin
+ ShowImportDlg(Database, TableIndex);
+ if TableIndex <> -1 then {we have a new table}
+ AddOutlineTable(Selected, Table);
+ end;
+end;
+{--------}
+procedure TfrmMain.popmnuTableEmptyClick(Sender: TObject);
+var
+ aSavCursor : TCursor; {!!.01}
+ aTable : TffeTableItem;
+begin
+ aTable := TffeTableItem(GetSelectedEntity);
+ with aTable do begin
+ Table.DisableControls;
+ try
+// if not Table.Active or not Table.Exclusive then begin {Deleted !!.01}
+ with Table do begin
+ Close;
+ Exclusive := True;
+ Open;
+ end;
+// end; {Deleted !!.01}
+
+ if RecordCount = 0 then
+ ShowMessage('Table is already empty')
+ else begin
+ if MessageDlg('Delete all records in ' + TableName + '?',
+ mtWarning, [mbYes, mbNo], 0) = mrYes then begin
+ aSavCursor := Screen.Cursor; {!!.01}
+ Screen.Cursor := crHourglass;
+ try
+ Table.EmptyTable;
+ finally
+// Table.Close; {Deleted !!.01}
+// Table.Exclusive := False; {Deleted !!.01}
+ Screen.Cursor := aSavCursor; {!!.01}
+ end;
+ end;
+ end;
+ finally
+ Table.Close; {!!.01}
+ Table.Exclusive := False; {!!.01}
+ Table.EnableControls;
+ end;
+ end;
+end;
+{--------}
+procedure TfrmMain.ExitBtnClick(Sender: TObject);
+begin
+ Close;
+end;
+{--------}
+procedure TfrmMain.UncheckMenuGroupSiblings(aMenuItem: TMenuItem);
+var
+ I: Integer;
+begin
+ with aMenuItem.Parent do begin
+ for I := 0 to Count - 1 do
+ if (Items[I] <> aMenuItem) and (Items[I].GroupIndex = aMenuItem.GroupIndex) then
+ Items[I].Checked := False;
+ end;
+end;
+{--------}
+procedure TfrmMain.mnuSetAutoIncClick(Sender: TObject);
+var
+ aTable : TffeTableItem;
+ Seed : TffWord32; {!!.10}
+begin
+ aTable := TffeTableItem(GetSelectedEntity);
+ Seed := aTable.GetAutoInc;
+ with aTable do begin
+ if ShowAutoIncDlg(TableName, Seed) = mrOK then
+ SetAutoIncSeed(Seed);
+ end;
+end;
+{--------}
+procedure TfrmMain.outServersDblClick(Sender: TObject);
+var
+ aTable : TffeTableItem;
+// dummy : boolean;
+begin
+ with outServers do begin
+ if assigned(Selected) then
+ case TffeOutlineData(Selected.Data).EntityType of
+ etServer:
+ begin
+ PopupMenu := popmnuServer;
+// outServersExpanding(outServers, outServers.Selected, dummy);
+ end;
+ etDatabase:
+ begin
+ PopupMenu := popmnuAlias;
+// outServersExpanding(outServers, outServers.Selected, dummy);
+ end;
+ etTable:
+ begin
+ aTable := TffeTableItem(GetSelectedEntity);
+ PopupMenu := popmnuTable;
+ ShowTableBrowser(aTable);
+ end;
+ end;
+ end;
+end;
+{--------}
+{function TfrmMain.mapProtocolClassToProtocol(const Protocol : TffCommsProtocolClass) : TffProtocolType;
+begin
+ if (Protocol = TffTCPIPProtocol) then
+ result := ptTCPIP
+ else if (Protocol = TffIPXSPXProtocol) then
+ result := ptIPXSPX
+ else
+ result := ptSingleUser;
+end;}
+{--------}
+procedure TfrmMain.mnuOptionsLiveDatasetsClick(Sender: TObject);
+var {!!.01}
+ Idx : Integer; {!!.01}
+begin
+ mnuOptionsLiveDataSets.Checked := not mnuOptionsLiveDataSets.Checked;
+ tbOptionsLiveDataSets.Down := mnuOptionsLiveDataSets.Checked; {!!.06}
+ with Config do
+ if mnuOptionsLiveDataSets.Checked then
+ Options := Options + [coLiveDatasets]
+ else
+ Options := Options - [coLiveDatasets];
+
+ for Idx := 0 to Pred(Screen.FormCount) do {BEGIN !!.01}
+ if Screen.Forms[Idx] is TdlgTable then
+ with TdlgTable(Screen.Forms[Idx]) do begin
+ ReadOnly := not mnuOptionsLiveDataSets.Checked;
+ UpdateDisplay;
+ end; {END !!.01}
+end;
+{--------}
+procedure TfrmMain.outServersExpanding(Sender: TObject; Node: TTreeNode;
+ var AllowExpansion: Boolean);
+var
+ aData : TffeOutlineData;
+begin
+ aData := TffeOutlineData(Node.Data);
+ AllowExpansion := aData.EntityType in [etServer, etDatabase];
+
+ { If we can expand and the node currently has no children, go grab the
+ children. }
+ if AllowExpansion and (Node.Count = 0) then begin
+ case aData.EntityType of
+ etServer :
+ LoadOutlineDatabases(Node);
+ etDatabase :
+ LoadOutlineTables(Node);
+ end; { case }
+{Begin !!.01}
+ if Node.Expanded then begin
+ Node.HasChildren := (Node.Count > 0);
+ AllowExpansion := Node.HasChildren;
+ end;
+{End !!.01}
+ end;
+end;
+{--------}
+procedure TfrmMain.outServersEditing(Sender: TObject; Node: TTreeNode;
+ var AllowEdit: Boolean);
+begin
+ AllowEdit := GetNodeEntityType(Node) in [etDatabase, etTable];
+end;
+{--------}
+procedure TfrmMain.outServersEdited(Sender: TObject; Node: TTreeNode;
+ var S: String);
+var
+ OldCursor : TCursor;
+begin
+ { Perform the rename. }
+ OldCursor := Screen.Cursor;
+ Screen.Cursor := crHourglass;
+ try
+ case GetNodeEntityType(Node) of
+ etDatabase :
+ begin
+ TffeDatabaseItem(GetNodeEntity(Node)).Rename(S);
+ Node.Text := S;
+ LoadOutlineServers; {!!.01}
+ end;
+ etTable :
+ begin
+ TffeTableItem(GetNodeEntity(Node)).Rename(S);
+ Node.Text := S;
+ end;
+ end;
+ finally
+ Screen.Cursor := OldCursor;
+ end;
+end;
+{--------}
+{$IFNDEF DCC6OrLater}
+function CenterPoint(const Rect: TRect): TPoint;
+begin
+ with Rect do
+ begin
+ Result.X := (Right - Left) div 2 + Left;
+ Result.Y := (Bottom - Top) div 2 + Top;
+ end;
+end;
+{$ENDIF}
+{--------}
+procedure TfrmMain.outServersKeyDown(Sender: TObject; var Key: Word;
+ Shift: TShiftState);
+var
+ aNode : TTreeNode;
+begin
+ { If user presses F2 then edit current node. }
+ if (Key = VK_F2) and assigned(outServers.Selected) then
+ outServers.Selected.EditText
+ else if Key = VK_RETURN then
+ outServersDblClick(nil)
+ {Begin !!.07}
+ { support the windows keyboard context menu key }
+ else if (Key = VK_APPS) or
+ ((Shift = [ssShift]) and (Key = VK_F10)) then begin
+ aNode := outServers.Selected;
+ if assigned(aNode) and assigned(aNode.Data) then begin
+ case TffeOutlineData(aNode.Data).EntityType of
+ etServer: PopupMenu := popmnuServer;
+ etDatabase: PopupMenu := popmnuAlias;
+ etTable: PopupMenu := popmnuTable;
+ end;
+ PopupMenu.Popup(ClientToScreen(CenterPoint(aNode.DisplayRect(True))).X + 5,
+ ClientToScreen(CenterPoint(aNode.DisplayRect(True))).Y + 5);
+ end;
+ end;
+ {End !!.07}
+end;
+{--------}
+procedure TfrmMain.mnuViewTableClick(Sender: TObject);
+begin
+ outServersDblClick(nil);
+end;
+{--------}
+procedure TfrmMain.mnuDatabaseSQLClick(Sender: TObject);
+begin
+ ShowQueryWindow(0);
+end;
+{Begin !!.06}
+{--------}
+procedure TfrmMain.mnuCloseAllClick(Sender: TObject);
+var
+ Idx : Integer;
+begin
+ for Idx := 0 to Pred(Screen.FormCount) do
+ if (Screen.Forms[Idx] is TdlgTable) or
+ (Screen.Forms[Idx] is TdlgQuery) then
+ Screen.Forms[Idx].Close;
+end;
+{End !!.06}
+
+{Begin !!.06}
+{--------}
+procedure TfrmMain.UpdateWindowsMenuItems;
+var
+ Count,
+ Idx : Integer;
+ NewItem : TMenuItem;
+Begin
+ { ensure windows are closed first }
+ Application.ProcessMessages;
+ { remove all items - requires that mnuWindowsSplitter is the last
+ item in the menu at designtime! }
+ while mnuWindows.Items[mnuWindows.Count-1]<>mnuWindowsSplitter do
+ mnuWindows.Delete(mnuWindows.Count-1);
+ { add back existing forms }
+ Count := 1;
+ { note: it varies between Delphi versions wether new forms are added
+ at the beginning or end of the Screen.Forms array. The code below
+ assumes it is compiled with Delphi 6. The last opened window should
+ appear at the bottom of the menu. If it appears at the top, switch
+ the loop parameters around. }
+ for Idx := Pred(Screen.FormCount) downto 0 do
+ if (Screen.Forms[Idx] is TdlgTable) or
+ (Screen.Forms[Idx] is TdlgQuery) or
+ (Screen.Forms[Idx] is TfrmTableStruct) then begin {!!.11}
+ NewItem := TMenuItem.Create(NIL);
+ NewItem.Caption := Screen.Forms[Idx].Caption;
+ if Count<=9 then
+ NewItem.Caption := '&' + IntToStr(Count) + ' ' + NewItem.Caption;
+ Inc(Count);
+ NewItem.OnClick := WindowsMenuItemClick;
+ NewItem.Tag := Integer(Screen.Forms[Idx]);
+ mnuWindows.Add(NewItem);
+ end;
+end;
+{End !!.06}
+
+{Begin !!.06}
+{--------}
+procedure TfrmMain.WindowsMenuItemClick(Sender: TObject);
+begin
+ if (Sender IS TMenuItem) AND
+ Assigned(Pointer(TMenuItem(Sender).Tag)) then
+ TForm(TMenuItem(Sender).Tag).BringToFront;
+end;
+{End !!.06}
+
+{Begin !!.06}
+{--------}
+procedure TfrmMain.mnuWindowsClick(Sender: TObject);
+begin
+ { we only update the menu when the user actually clicks it. the update
+ executes so fast that the user won't notice anyway. }
+ UpdateWindowsMenuItems;
+ mnuCloseAll.Enabled := Screen.FormCount>1;
+ tbCloseAll.Enabled := mnuCloseAll.Enabled;
+end;
+{End !!.06}
+
+{Begin !!.06}
+{--------}
+procedure TfrmMain.AppMessage(var Msg: TMsg; var Handled: Boolean);
+var
+ Idx : Integer;
+begin
+ { trap ALT-F6 keypresses and make the next window in the
+ window list active }
+ if (Msg.message = WM_SYSKEYDOWN) and
+ (Msg.wparam = VK_F6) then
+ begin
+ if (Screen.FormCount>1) and
+ (Screen.ActiveForm is TfrmMain) or
+ (Screen.ActiveForm is TdlgTable) or
+ (Screen.ActiveForm is TdlgQuery) or
+ (Screen.ActiveForm is TfrmTableStruct) then begin {!!.11}
+ Idx := 0;
+ { find index of active form }
+ while (IdxScreen.Forms[Idx]) do
+ Inc(Idx);
+ { note: it may be that the code below will fail, depending on what delphi
+ version it is compiled with and how that delphi version updates the
+ Screen.Forms array. the code below works with Delphi 6. }
+ { if at start of array, wrap around, else pick previous in list }
+ if Idx=0 then
+ Screen.Forms[Pred(Screen.FormCount)].BringToFront
+ else
+ Screen.Forms[Idx-1].BringToFront;
+ end;
+ Handled := True;
+ end;
+ { for all other messages, Handled remains False }
+ { so that other message handlers can respond }
+end;
+{End !!.06}
+{Begin !!.06}
+{--------}
+procedure TfrmMain.DoIdle(Sender: TObject; var Done: Boolean);
+var
+ Idx : Integer;
+begin
+ { to ensure the toolbutton is correctly updated }
+ for Idx := 0 to Pred(Screen.FormCount) do
+ if (Screen.Forms[Idx] is TdlgTable) or
+ (Screen.Forms[Idx] is TdlgQuery) then begin
+ tbCloseAll.Enabled := True;
+ Exit;
+ end;
+ tbCloseAll.Enabled := False;
+end;
+{End !!.06}
+{Begin !!.07}
+procedure TfrmMain.mnuToolsFFCommsClick(Sender: TObject);
+begin
+ with uFFComms.TfrmFFCommsMain.Create(Self) do
+ try
+ Caption := 'Set Default Server';
+// Label3.Visible := False;
+ if ShowModal=mrOK then
+ Initialize;
+ finally
+ Free;
+ end;
+end;
+{End !!.07}
+{Begin !!.07}
+procedure TfrmMain.mnuSetAsAutomaticDefaultClick(Sender: TObject);
+begin
+ { leave servername alone if SUP, like FFCOMMS does }
+ if TffeServerItem(GetSelectedEntity).Protocol=ptSingleUser then
+ FFClientConfigWriteProtocolName(ffc_SingleUser)
+ else begin
+ if TffeServerItem(GetSelectedEntity).Protocol=ptTCPIP then
+ FFClientConfigWriteProtocolName(ffc_TCPIP)
+ else
+ if TffeServerItem(GetSelectedEntity).Protocol=ptIPXSPX then
+ FFClientConfigWriteProtocolName(ffc_IPXSPX);
+ FFClientConfigWriteServerName(TffeServerItem(GetSelectedEntity).ServerName);
+ end;
+ Initialize;
+end;
+{End !!.07}
+procedure TfrmMain.outServersChange(Sender: TObject; Node: TTreeNode);
+begin
+ outServersClick(Sender);
+end;
+
+procedure TfrmMain.outServersContextPopup(Sender: TObject;
+ MousePos: TPoint; var Handled: Boolean);
+begin
+{}
+end;
+
+{Begin !!.11}
+procedure TfrmMain.popmnuServerRefreshClick(Sender: TObject);
+begin
+ RefreshDatabases(Sender);
+end;
+
+{--------}
+procedure TfrmMain.ShowServerStatistics(aServer : TffeServerItem);
+var
+ OldCursor: TCursor;
+ dlgServerStats : TdlgServerStats;
+begin
+ OldCursor := Screen.Cursor;
+ Screen.Cursor := crHourglass;
+ try
+ dlgServerStats := TdlgServerStats.Create(Application); {!!.02}
+ with dlgServerStats do begin
+ Log := LogMain;
+ Protocol := aServer.Protocol;
+ ServerName := aServer.ServerName;
+ UserName := TffexpSession(aServer.Session).ffeUserName;
+ Password := TffexpSession(aServer.Session).ffePassword;
+ Show;
+ end;
+ finally
+ Screen.Cursor := OldCursor;
+ end;
+end;
+
+
+procedure TfrmMain.popmnuServerStatisticsClick(Sender: TObject);
+var
+ anEntity : TffeEntityItem;
+ Server : TffeServerItem;
+begin
+ anEntity := TffeOutlineData(outServers.Selected.Data).Entity;
+ Server := TffeServerItem(anEntity);
+ ShowServerStatistics(Server);
+end;
+
+
+procedure TfrmMain.mnuOptionsSetDefaultTimeoutClick(Sender: TObject);
+var
+ sTimeout : String;
+ res : Boolean;
+ Idx : Integer;
+begin
+ sTimeout := IntToStr(Config.DefaultTimeout);
+ repeat
+ res := InputQuery('Default Timeout (ms)', 'Value:', sTimeout);
+ if res then
+ try
+ Config.DefaultTimeout := StrToInt(sTimeout);
+ if Config.DefaultTimeout<-1 then
+ raise EConvertError.Create('');
+ {Begin !!.11}
+ { set default timeout on open servers, tables and queries }
+ for idx := 0 to ServerList.Count - 1 do
+ if Assigned(ServerList.Items[idx].Client) then
+ ServerList.Items[idx].Client.TimeOut := Config.DefaultTimeout;
+ for Idx := 0 to Pred(Screen.FormCount) do
+ if (Screen.Forms[Idx] is TdlgTable) then
+ TdlgTable(Screen.Forms[Idx]).UpdateDefaultTimeout
+ else
+ if (Screen.Forms[Idx] is TdlgQuery) then
+ TdlgQuery(Screen.Forms[Idx]).UpdateDefaultTimeout;
+ {End !!.11}
+ res := False;
+ except
+ on EConvertError do begin
+ MessageDlg('Value must be a number between -1 and '+IntToStr(MaxInt), mtError, [mbOK], 0);
+ end;
+ end;
+ until not res;
+end;
+{End !!.11}
+end.
+
diff --git a/components/flashfiler/sourcelaz/explorer/fmprog.dfm b/components/flashfiler/sourcelaz/explorer/fmprog.dfm
new file mode 100644
index 000000000..f25c3f7ab
Binary files /dev/null and b/components/flashfiler/sourcelaz/explorer/fmprog.dfm differ
diff --git a/components/flashfiler/sourcelaz/explorer/fmprog.pas b/components/flashfiler/sourcelaz/explorer/fmprog.pas
new file mode 100644
index 000000000..754b151e1
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/fmprog.pas
@@ -0,0 +1,99 @@
+{*********************************************************}
+{* Progress meter for rebuild operations *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit fmprog;
+
+interface
+
+uses
+ Windows,
+ Messages,
+ SysUtils,
+ Classes,
+ Graphics,
+ Controls,
+ Forms,
+ Dialogs,
+ ComCtrls,
+ StdCtrls,
+ ExtCtrls,
+ ffllbase;
+
+type
+ TfrmRebuildStatus = class(TForm)
+ lblProgress: TLabel;
+ mtrPercentComplete: TProgressBar;
+ private
+ FCursor: TCursor;
+ public
+ procedure Hide;
+ procedure ShowProgress(aAction, aTableName: string);
+ procedure UpdateProgress(aCompleted: Boolean; aStatus: TffRebuildStatus);
+ end;
+
+var
+ frmRebuildStatus: TfrmRebuildStatus;
+
+implementation
+
+{$R *.DFM}
+
+procedure TfrmRebuildStatus.Hide;
+begin
+ Screen.Cursor := FCursor;
+ inherited Hide;
+end;
+
+procedure TfrmRebuildStatus.ShowProgress(aAction, aTableName: string);
+begin
+ Caption := Format('%s Table %s', [aAction, aTableName]);
+ lblProgress.Hide;
+ FCursor := Screen.Cursor;
+ Screen.Cursor := crHourglass;
+ mtrPercentComplete.Position := 0;
+ inherited Show;
+end;
+
+procedure TfrmRebuildStatus.UpdateProgress(aCompleted: Boolean; aStatus: TffRebuildStatus);
+begin
+ with aStatus do begin
+ if rsErrorCode <> 0 then
+ ShowMessage(Format('%s', [rsErrorCode]));
+ with lblProgress do begin
+ Caption := Format('Processing record %d of %d', [rsRecsRead, rsTotalRecs]);
+ Show;
+ Application.ProcessMessages;
+ end;
+ mtrPercentComplete.Position := aStatus.rsPercentDone;
+ end;
+end;
+
+end.
diff --git a/components/flashfiler/sourcelaz/explorer/fmstruct.dfm b/components/flashfiler/sourcelaz/explorer/fmstruct.dfm
new file mode 100644
index 000000000..a6366237c
Binary files /dev/null and b/components/flashfiler/sourcelaz/explorer/fmstruct.dfm differ
diff --git a/components/flashfiler/sourcelaz/explorer/fmstruct.pas b/components/flashfiler/sourcelaz/explorer/fmstruct.pas
new file mode 100644
index 000000000..20d4339c3
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/fmstruct.pas
@@ -0,0 +1,3552 @@
+{*********************************************************}
+{* Create/View/Restructure Table Definition Dialog *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit fmstruct;
+
+interface
+
+uses
+ Db,
+ Windows,
+ Messages,
+ SysUtils,
+ Classes,
+ Graphics,
+ Controls,
+ Forms,
+ Dialogs,
+ Grids,
+ StdCtrls,
+ ComCtrls,
+ Buttons,
+ ExtCtrls,
+ ffllgrid,
+ ffsrbde,
+ ffllbase,
+ fflldict,
+ uelement,
+ uentity,
+ uconfig,
+ dgimpdef;
+
+type
+ TffeDialogMode = (dmNeutral, dmViewing, dmCreating, dmRestructuring);
+ TffeViewType = (vtViewFields, vtViewIndexes);
+ TffeDrawType = (dtNormal, dtGrayed, dtChecked, dtUnchecked, dtWordWrap, dtIgnore);
+
+ TffeCellComboBoxInfo = packed record
+ Index : integer; {index into Items list}
+ {$IFDEF CBuilder}
+ case integer of
+ 0 : (St : array[0..255] of char);
+ 1 : (RTItems : TStrings;
+ RTSt : array[0..255] of char);
+ {$ELSE}
+ case integer of
+ 0 : (St : ShortString); {string value if Index = -1}
+ 1 : (RTItems : TStrings; {run-time items list}
+ RTSt : ShortString); {run-time string value if Index = -1}
+ {$ENDIF}
+ end;
+
+ TfrmTableStruct = class(TForm)
+ pnlMain: TPanel;
+ dlgPrint: TPrintDialog;
+ dlgSave: TSaveDialog;
+ tabStructure: TPageControl;
+ tbsFields: TTabSheet;
+ tbsIndexes: TTabSheet;
+ tbsExistingData: TTabSheet;
+ grpExistingData: TGroupBox;
+ tabExistingData: TPageControl;
+ tbsFieldMap: TTabSheet;
+ tbsOrphanedData: TTabSheet;
+ grdOrphanedFields: TffStringGrid;
+ grdFields: TffStringGrid;
+ grdFieldMap: TffStringGrid;
+ cboFieldType: TComboBox;
+ pnlFieldDetail: TPanel;
+ grpBLOBEditStorage: TGroupBox;
+ lblBLOBExtension: TLabel;
+ lblBLOBBlockSize: TLabel;
+ lblBLOBFileDesc: TLabel;
+ imgMinus: TImage;
+ imgPlus: TImage;
+ radBLOBInternal: TRadioButton;
+ radBLOBExternal: TRadioButton;
+ cboBLOBBlockSize: TComboBox;
+ edtBlobExtension: TEdit;
+ edtBlobFileDesc: TEdit;
+ grpBLOBViewStorage: TGroupBox;
+ lblBLOBViewStorage: TLabel;
+ btnInsertField: TBitBtn;
+ btnDeleteField: TBitBtn;
+ btnMoveFieldUp: TBitBtn;
+ btnMoveFieldDown: TBitBtn;
+ pnlHeader: TPanel;
+ lblTableName: TLabel;
+ edtTableName: TEdit;
+ lblBlockSize: TLabel;
+ cboBlockSize: TComboBox;
+ pnlDialogButtons: TPanel;
+ btnImport: TBitBtn;
+ btnCreate: TBitBtn;
+ btnPrint: TBitBtn;
+ btnRestructure: TBitBtn;
+ btnCancel: TBitBtn;
+ pnlIndexDetail: TPanel;
+ grpCompositeKey: TGroupBox;
+ splIndex: TSplitter;
+ grdIndexes: TffStringGrid;
+ cboIndexType: TComboBox;
+ cboIndexBlockSize: TComboBox;
+ pnlDeleteIndex: TPanel;
+ pnlExistingDataHeader: TPanel;
+ chkPreserveData: TCheckBox;
+ pnlExistingDataButtons: TPanel;
+ btnMatchByName: TButton;
+ btnMatchByPosition: TButton;
+ btnClearAll: TButton;
+ cboMapOldField: TComboBox;
+ chkEncryptData: TCheckBox;
+ btnDeleteIndex: TButton;
+ pnlCompButtons: TPanel;
+ btnAddIndexField: TSpeedButton;
+ btnRemoveIndexField: TSpeedButton;
+ pnlCompFieldsInIndex: TPanel;
+ lstIndexFields: TListBox;
+ pnlCompAvailFields: TPanel;
+ lblFieldsInIndex: TLabel;
+ lstAvailFields: TListBox;
+ lblAvailableFields: TLabel;
+ chkAvailFieldsSorted: TCheckBox;
+ btnMoveIndexFieldUp: TSpeedButton;
+ btnMoveIndexFieldDown: TSpeedButton;
+ Label1: TLabel;
+ edtDescription: TEdit;
+ {=====Form and general events=====}
+ procedure FormCreate(Sender: TObject);
+ procedure FormDestroy(Sender: TObject);
+ procedure FormShow(Sender: TObject);
+ procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
+ procedure btnCreateClick(Sender: TObject);
+ procedure btnCancelClick(Sender: TObject);
+ procedure btnPrintClick(Sender: TObject);
+ procedure btnImportClick(Sender: TObject);
+ procedure btnRestructureClick(Sender: TObject);
+ procedure btnInsertFieldClick(Sender: TObject);
+ procedure btnDeleteFieldClick(Sender: TObject);
+ procedure btnMoveFieldUpClick(Sender: TObject);
+ procedure btnMoveFieldDownClick(Sender: TObject);
+ procedure radBLOBInternalClick(Sender: TObject);
+ procedure cboFieldTypeChange(Sender: TObject);
+ procedure cboFieldTypeExit(Sender: TObject);
+ procedure grdFieldsEnter(Sender: TObject);
+ procedure grdFieldsSelectCell(Sender : TObject;
+ Col, Row : Integer;
+ var CanSelect : Boolean);
+ procedure grdFieldsDrawCell(Sender : TObject;
+ ACol, ARow : Integer;
+ Rect : TRect;
+ State : TGridDrawState);
+ procedure grdFieldsKeyPress(Sender: TObject; var Key: Char);
+ procedure grdFieldsMouseUp(Sender: TObject; Button: TMouseButton;
+ Shift: TShiftState; X, Y: Integer);
+
+
+ {=====Indexes tab events=====}
+ procedure btnDeleteIndexClick(Sender: TObject);
+ procedure btnAddIndexFieldClick(Sender: TObject);
+ procedure btnRemoveIndexFieldClick(Sender: TObject);
+ procedure btnMoveIndexFieldUpClick(Sender: TObject);
+ procedure btnMoveIndexFieldDownClick(Sender: TObject);
+ procedure lstIndexFieldsDragOver(Sender, Source: TObject; X,
+ Y: Integer; State: TDragState; var Accept: Boolean);
+ procedure lstIndexFieldsDragDrop(Sender, Source: TObject; X,
+ Y: Integer);
+ procedure lstAvailFieldsDragOver(Sender, Source: TObject; X,
+ Y: Integer; State: TDragState; var Accept: Boolean);
+ procedure lstAvailFieldsDragDrop(Sender, Source: TObject; X,
+ Y: Integer);
+ procedure cboIndexTypeChange(Sender: TObject);
+ procedure cboIndexTypeExit(Sender: TObject);
+ procedure grdIndexesEnter(Sender: TObject);
+ procedure grdIndexesSelectCell(Sender: TObject; ACol, ARow: Integer;
+ var CanSelect: Boolean);
+ procedure grdIndexesKeyPress(Sender: TObject; var Key: Char);
+ procedure grdIndexesDrawCell(Sender: TObject; ACol, ARow: Integer;
+ Rect: TRect; State: TGridDrawState);
+ procedure grdIndexesMouseUp(Sender: TObject; Button: TMouseButton;
+ Shift: TShiftState; X, Y: Integer);
+
+ {=====Existing data tab events=====}
+ procedure tabFieldMapPageChanged(Sender: TObject; Index: Integer);
+ procedure btnMatchByNameClick(Sender: TObject);
+ procedure btnMatchByPositionClick(Sender: TObject);
+ procedure btnClearAllClick(Sender: TObject);
+ procedure chkPreserveDataClick(Sender: TObject);
+ procedure grdFieldMapEnter(Sender: TObject);
+ procedure grdFieldMapActiveCellMoving(Sender: TObject; Command: Word;
+ var RowNum: Longint; var ColNum: Integer);
+ procedure tcMapOldFieldChange(Sender: TObject);
+ procedure grdFieldsExit(Sender: TObject);
+ procedure grdFieldMapKeyPress(Sender: TObject; var Key: Char);
+ procedure grdFieldMapSelectCell(Sender: TObject; ACol, ARow: Integer;
+ var CanSelect: Boolean);
+ procedure cboMapOldFieldChange(Sender: TObject);
+ procedure cboMapOldFieldExit(Sender: TObject);
+ procedure tabStructureChange(Sender: TObject);
+ procedure grdIndexesExit(Sender: TObject);
+ procedure FormKeyPress(Sender: TObject; var Key: Char);
+ procedure lstAvailFieldsDblClick(Sender: TObject);
+ procedure lstIndexFieldsDblClick(Sender: TObject);
+ procedure chkAvailFieldsSortedClick(Sender: TObject);
+ procedure grdIndexesEnterCell(Sender: TffStringGrid; aCol,
+ aRow: Integer; const text: String);
+ procedure cboFieldTypeKeyDown(Sender: TObject; var Key: Word;
+ Shift: TShiftState);
+ procedure cboIndexTypeKeyDown(Sender: TObject; var Key: Word;
+ Shift: TShiftState);
+ procedure cboMapOldFieldKeyDown(Sender: TObject; var Key: Word;
+ Shift: TShiftState);
+ procedure tabExistingDataChange(Sender: TObject);
+ procedure edtBlobExtensionExit(Sender: TObject);
+ procedure FormClose(Sender: TObject; var Action: TCloseAction);
+
+ private
+ procedure CMDialogKey(var msg: TCMDialogKey); message CM_DIALOGKEY;
+ protected
+ FDialogMode : TffeDialogMode;
+ FHasChanged : Boolean;
+ { This flag is used to keep track of whether or not the information in the
+ dialogs has changed. The approach is simplistic, a better
+ approach would be to compare the current dict, and potential dict.
+ Perhaps this could be done at a later point. }
+ FDatabase : TffeDatabaseItem;
+ FOutputDictionary: TffDataDictionary;
+ FFieldList: TffeFieldList;
+ FIndexList: TffeIndexList;
+ FTempElementNumber: LongInt;
+ FTempStr: TffShStr;
+ FTableIndex: LongInt;
+ FFieldMapComboRec: TffeCellComboBoxInfo;
+ FFieldMap: TStringList;
+ ReverseFFieldMap: TStringList; {!!.11}
+ { to optimize lookup of fieldmappings }
+ FInEnterKeyPressed : Boolean; {!!.11}
+ FcboMapOldFieldHasBeenFocused: Boolean; {!!.11}
+ FFieldMapInShiftTab : Boolean; {!!.11}
+
+ procedure AddFieldToIndex;
+ procedure RemoveFieldFromIndex;
+
+ public
+ {=====General Routines=====}
+ procedure AlignButtons;
+ procedure PopulateForm(aTableIndex: LongInt; aReadOnly: Boolean);
+ procedure DrawCell(Grid : TffStringGrid; DrawType: TffeDrawType;
+ Rect: TRect; State: TGridDrawState; CellText: string);
+ procedure ShowCellCombo(ComboBox: TCustomComboBox; Grid: TCustomGrid;
+ Rect: TRect);
+
+ {=====Dictionary Routines=====}
+ procedure BuildDictionary;
+ procedure LoadDictionary(aTableIndex: LongInt);
+ procedure CreateTable(aTableName: TffTableName);
+ procedure PrintDictionary(aTableIndex: LongInt; aPrintToFile: Boolean);
+
+ {=====Field Grid Routines=====}
+ procedure InitializeFieldGrid;
+ procedure PopulateFieldGridHeader;
+ procedure InvalidateFieldsTable;
+ procedure InvalidateFieldsRow(const RowNum : Integer);
+ procedure EnableBLOBControls;
+ procedure EnableFieldControls(aRowNum: LongInt);
+ procedure LeavingFieldsCell(const Col, Row: LongInt);
+
+ {=====Index Grid Routines=====}
+ procedure InitializeIndexGrid;
+ procedure PopulateIndexGridHeader;
+ procedure PopulateIndexFieldsLists(aIndex: LongInt);
+ procedure InvalidateIndexesTable;
+ procedure InvalidateIndexesRow(const RowNum: Integer);
+ function CalcKeyLength(aIndex: Integer): Integer;
+ procedure EnableIndexControls(aRowNum: LongInt; aName: string);
+ procedure LeavingIndexCell(const Col, Row: Longint);
+
+ {=====FieldMap Routines=====}
+ procedure InitializeFieldMapGrid;
+ procedure PopulateFieldMapHeader;
+ procedure InvalidateFieldMapTable;
+ procedure InvalidateFieldMapRow(const RowNum: Integer);
+ procedure RetrieveFieldMapSettings(const ARow : integer;
+ var Index: Integer;
+ AStrings: TStrings);
+
+ {=====FieldGrid Validation Routines=====}
+ function AllowDefaultField(aRowNum : Integer;
+ var aErrorCode : Word) : Boolean;
+ function FieldNameValidation(const AName : string;
+ var ErrorCode : Word) : Boolean;
+ function FieldLengthValidation(const ALength : string;
+ var ErrorCode : Word): Boolean;
+ function ValidateFieldUnits(aUnits, aFieldNum: Integer): Boolean;
+ function ValidDefaultFieldKey(aUpKey : Char;
+ aFieldType : TffFieldType) : Boolean;
+
+ {=====IndexGrid Validation Routines=====}
+ function IndexNameValidation(const AName: string;
+ var ErrorCode: Word): Boolean;
+ function IndexExtensionValidation(const AExtension: string;
+ var ErrorCode: Word): Boolean;
+ function IndexKeyLenValidation(const AKeyLen: Integer;
+ var ErrorCode: Word): Boolean;
+ {Misc Validation Routines}
+ function edtBLOBExtensionValidation(const AExtension: string;
+ var ErrorCode: Word): Boolean;
+ function ValidateRestructure: Boolean;
+ procedure DisplayValidationError(ErrorCode: Word);
+ function ValidateForm: Boolean;
+ end;
+
+{=====Entry-Point routines=====}
+function ShowCreateTableDlg(aDatabase : TffeDatabaseItem;
+ var aTableIndex: LongInt;
+ DefaultFieldDefs: TFieldDefs): TModalResult; {!!.11}
+
+function ShowRestructureTableDlg(aDatabase : TffeDatabaseItem;
+ aTableIndex: LongInt): TModalResult;
+
+procedure ShowViewTableStructureDlg(aDatabase : TffeDatabaseItem;
+ aTableIndex : longInt; aViewType: TffeViewType);
+
+var
+ frmTableStruct: TfrmTableStruct;
+
+implementation
+
+{$R *.DFM}
+
+uses
+ FFConvFF,
+ dgPrintg,
+ uBase,
+ uConsts,
+ FFStDate,
+ FFCLConv,
+ FFUtil, {!!.06}
+ Printers;
+
+const
+
+{===== Grid column constants =====}
+ cnFldNumber = 0;
+ cnFldName = 1;
+ cnFldType = 2;
+ cnFldUnits = 3;
+ cnFldDecPl = 4;
+ cnFldRequired = 5;
+ cnFldDefault = 6;
+ cnFldDesc = 7;
+ cnFldHighest = 7;
+
+ cnIdxNumber = 0;
+ cnIdxName = 1;
+ cnIdxType = 2;
+ cnIdxKeyLength = 3;
+ cnIdxUnique = 4;
+ cnIdxAscending = 5;
+ cnIdxCaseSensitive = 6;
+ cnIdxExt = 7;
+ cnIdxBlockSize = 8;
+ cnIdxDesc = 9;
+ cnIdxHighest = 9;
+
+ cnMapFieldName = 0;
+ cnMapDatatype = 1;
+ cnMapOldField = 2;
+ cnMapHighest = 3;
+
+ { Cell margin constants }
+ cnTopMargin = 3;
+ cnLeftMargin = 3;
+
+{===== Grid column names =========}
+cnsAscend = 'Ascend';
+cnsBlockSize = 'Block size';
+cnsCaseSens = 'Case';
+cnsDataType = 'Data type';
+cnsDecPl = 'Decimals';
+cnsDefault = 'Default';
+cnsDesc = 'Description';
+cnsExt = 'File ext';
+cnsFieldName = 'Field name';
+cnsKeyLen = 'Key size';
+cnsName = 'Name';
+cnsNumber = '#';
+cnsRequired = 'Required';
+cnsType = 'Type';
+cnsUnique = 'Unique';
+cnsUnits = 'Units';
+
+{=====Entry-Point routines=====}
+
+function ShowCreateTableDlg(aDatabase: TffeDatabaseItem;
+ var aTableIndex: LongInt;
+ DefaultFieldDefs: TFieldDefs): TModalResult; {!!.11}
+var
+ FieldIdx : Integer;
+ OldCursor: TCursor;
+ FFType : TffFieldType; {!!.11}
+ FFSize : word; {!!.11}
+begin
+ Assert(Assigned(aDatabase));
+ with TfrmTableStruct.Create(nil) do
+ try
+ HelpContext := hcDefineNewTableDlg;
+ OldCursor := Screen.Cursor;
+ Screen.Cursor := crHourglass;
+ try
+ tabStructure.ActivePage := tbsFields;
+ FDialogMode := dmCreating;
+ tbsExistingData.TabVisible := False;
+ cboBlockSize.Style := csDropDownList;
+ cboBlockSize.Enabled := True;
+ cboBlockSize.Color := clWindow;
+ cboBlockSize.TabStop := True;
+
+ FDatabase := aDatabase;
+
+ edtTableName.Enabled := True;
+ edtTableName.Color := clWindow;
+ edtTableName.Text := '';
+
+ {Begin !!.10}
+ edtDescription.Enabled := True;
+ edtDescription.Color := clWindow;
+ edtDescription.Text := '';
+ {End !!.10}
+
+ cboBlockSize.ItemIndex := 0;
+
+ { Set up the fields tab }
+ with grdFields do
+ Options := Options + [goEditing] + [goAlwaysShowEditor];
+
+ {Begin !!.11}
+ { in order to be able to open the New Table dialog with
+ predefined fields, the DefaultFieldDefs parameter and
+ this block was added.
+ }
+ if Assigned(DefaultFieldDefs) then begin
+ grdFields.BeginUpdate;
+ try
+ for FieldIdx := 0 to Pred(DefaultFieldDefs.Count) do begin
+ MapVCLTypeToFF(DefaultFieldDefs[FieldIdx].DataType,
+ DefaultFieldDefs[FieldIdx].Size,
+ FFType,
+ FFSize);
+ FFieldList.Insert(DefaultFieldDefs[FieldIdx].Name,
+ FFEFieldTypeToIndex(FFType),
+ FFSize,
+ 0,
+ False,
+ '',
+ NIL);
+ end;
+ grdFields.RowCount := grdFields.FixedRows + DefaultFieldDefs.Count;
+ finally
+ InvalidateFieldsTable;
+ grdFields.EndUpdate;
+ { moves focus to the grid. this is intentional; if we let focus
+ remain on the tablename, then the top left editable cell doesn't
+ draw properly. }
+ ActiveControl := grdFields;
+ end;
+ end;
+ {End !!.11}
+
+ FFieldList.AddEmpty;
+ InvalidateFieldsTable; {!!.11}
+
+ { Show the field editing controls }
+ btnInsertField.Visible := True;
+ btnDeleteField.Visible := True;
+ btnMoveFieldUp.Visible := True;
+ btnMoveFieldDown.Visible := True;
+
+ { Set BLOB views }
+ grpBLOBViewStorage.Visible := False;
+ grpBLOBEditStorage.Visible := True;
+
+ { Adjust the fields grid to smaller space }
+ grdFields.Height := btnInsertField.Top - grdFields.Top - 7;
+
+ { Set up the Indexes tab }
+ with grdIndexes do
+ Options := Options + [goEditing] + [goAlwaysShowEditor];
+
+ FIndexList.AddEmpty;
+
+ btnImport.Enabled := (FDatabase.TableCount > 0);
+ btnImport.Visible := True;
+ btnCreate.Visible := True;
+
+ FTableIndex := -1;
+ grdFields.Invalidate;
+ finally
+ Screen.Cursor := OldCursor;
+ end;
+ Result := ShowModal;
+ if Result = mrOK then
+ aTableIndex := FTableIndex;
+ finally
+ Free;
+ end;
+end;
+{--------}
+function ShowRestructureTableDlg(aDatabase : TffeDatabaseItem;
+ aTableIndex : LongInt): TModalResult;
+var
+ OldCursor: TCursor;
+begin
+ Assert(Assigned(aDatabase));
+ with TfrmTableStruct.Create(nil) do
+ try
+ cboBlockSize.Style := csDropDownList;
+ cboBlockSize.Enabled := True;
+ cboBlockSize.Color := clWindow;
+ cboBlockSize.TabStop := True;
+ HelpContext := hcRedefineTableDlg;
+ OldCursor := Screen.Cursor;
+ Screen.Cursor := crHourglass;
+ try
+ tabStructure.ActivePage := tbsFields;
+ FDialogMode := dmRestructuring;
+ FTableIndex := aTableIndex;
+ FDatabase := aDatabase;
+
+ with FDatabase.Tables[aTableIndex] do begin
+ Caption := 'Redefine Table: ' + TableName + ' in ' +
+ Server.ServerName + '\' + Database.DatabaseName;
+
+ { Disable the field map if there is no data }
+ if RecordCount = 0 then
+ with tabStructure do
+ Pages[PageCount - 1].TabVisible := False;
+ end;
+
+ PopulateForm(aTableIndex, False);
+
+ edtTableName.Text := FDatabase.Tables[FTableIndex].TableName;
+ edtTableName.ReadOnly := True;
+ edtTableName.ParentColor := True;
+ edtTableName.TabStop := False;
+
+ { Set up the fields tab }
+ with grdFields do
+ Options := Options + [goEditing] + [goAlwaysShowEditor];
+
+ { Show the field editing controls }
+ btnInsertField.Visible := True;
+ btnDeleteField.Visible := True;
+ btnMoveFieldUp.Visible := True;
+ btnMoveFieldDown.Visible := True;
+
+ { Set BLOB views }
+ grpBLOBViewStorage.Visible := False;
+ grpBLOBEditStorage.Visible := True;
+
+ { Adjust the fields grid to smaller space }
+ grdFields.Height := btnInsertField.Top - grdFields.Top - 7;
+
+ { Set up the Indexes tab }
+ with grdIndexes do
+ Options := Options + [goEditing] + [goAlwaysShowEditor];
+
+ btnImport.Enabled := (FDatabase.TableCount > 0);
+ btnImport.Width := btnRestructure.Width;
+ btnImport.Visible := True;
+ btnRestructure.Visible := True;
+ ActiveControl := grdFields;
+ finally
+ Screen.Cursor := OldCursor;
+ end;
+ Result := ShowModal;
+ finally
+ Free;
+ end;
+end;
+{--------}
+procedure ShowViewTableStructureDlg(aDatabase : TffeDatabaseItem;
+ aTableIndex : longInt; aViewType: TffeViewType);
+var
+ OldCursor: TCursor;
+begin
+ Assert(Assigned(aDatabase));
+ with TfrmTableStruct.Create(nil) do
+ try
+ HelpContext := hcViewTableDlg;
+ OldCursor := Screen.Cursor;
+ Screen.Cursor := crHourglass;
+ try
+ FDialogMode := dmViewing;
+ FDatabase := aDatabase;
+ FTableIndex := aTableIndex;
+
+ tbsExistingData.TabVisible := False;
+
+ with FDatabase.Tables[aTableIndex] do
+ Caption := 'Table Definition: ' + TableName + ' in ' +
+ Server.ServerName + '\' + Database.DatabaseName;
+
+ edtTableName.Text := FDatabase.Tables[FTableIndex].TableName;
+ edtTableName.ReadOnly := True;
+ edtTableName.ParentColor := True;
+ edtTableName.TabStop := False;
+
+ {Begin !!.10}
+ edtDescription.ReadOnly := True;
+ edtDescription.ParentColor := True;
+ edtDescription.TabStop := False;
+ {End !!.10}
+
+ cboBlockSize.Style := csSimple;
+ cboBlockSize.Enabled := False;
+ cboBlockSize.ParentColor := True;
+ cboBlockSize.TabStop := False;
+
+ chkAvailFieldsSorted.Visible := False;
+
+ with tabStructure do
+ case aViewType of
+ vtViewFields:
+ begin
+ ActivePage := tbsFields;
+ ActiveControl := grdFields;
+ end;
+ vtViewIndexes:
+ begin
+ ActivePage := tbsIndexes;
+ ActiveControl := grdIndexes;
+ end;
+ end;
+
+ with grdFields do begin
+ EditorMode := False;
+ Options := Options - [goEditing] - [goAlwaysShowEditor];
+ end;
+
+ PopulateForm(aTableIndex, True);
+
+ { Set BLOB views after loading the dictionary }
+ grpBLOBViewStorage.Visible := True;
+ grpBLOBEditStorage.Visible := False;
+
+ with FDatabase.Tables[aTableIndex], Dictionary do begin
+ if BLOBFileNumber = 0 then
+ lblBLOBViewStorage.Caption :=
+ 'BLOBs are stored in the main data file.'
+ else
+ lblBLOBViewStorage.Caption :=
+ Format('BLOBs are stored in file %s, block size = %d, description = "%s"',
+ [TableName + '.' + FileExt[BLOBFileNumber],
+ FileBlockSize[BLOBFileNumber], FileDesc[BLOBFileNumber]]);
+ end;
+
+ { Adjust the table encryption group }
+ chkEncryptData.Enabled := False;
+ chkEncryptData.Top := grpBLOBViewStorage.Top + 5;
+
+ { Hide the field editing controls }
+ btnInsertField.Visible := False;
+ btnDeleteField.Visible := False;
+ btnMoveFieldUp.Visible := False;
+ btnMoveFieldDown.Visible := False;
+
+ { Adjust the fields grid to larger space }
+ grdFields.Height := grpBLOBViewStorage.Top - grdFields.Top - 2;
+
+ { Hide index field editing controls }
+ with grdIndexes do begin
+ Options := Options - [goEditing] - [goAlwaysShowEditor];
+ end;
+
+ btnDeleteIndex.Visible := False;
+ lstIndexFields.DragMode := dmManual;
+ lstAvailFields.DragMode := dmManual;
+ btnAddIndexField.Enabled := False;
+ btnRemoveIndexField.Enabled := False;
+ btnMoveIndexFieldUp.Enabled := False;
+ btnMoveIndexFieldDown.Enabled := False;
+
+ btnPrint.Visible := True;
+ finally
+ Screen.Cursor := OldCursor;
+ end;
+{Begin !!.11}
+{$IFDEF DCC4OrLater}
+ Show;
+ finally
+ end;
+{$ELSE}
+ ShowModal;
+ finally
+ Free;
+ end;
+{$ENDIF}
+{End !!.11}
+end;
+
+{=====Form and general events=====}
+
+procedure TfrmTableStruct.FormCreate(Sender: TObject);
+begin
+ FHasChanged := False;
+ FFieldMapComboRec.RTItems := TStringList.Create;
+ FFieldMap := TStringList.Create;
+ FDialogMode := dmNeutral;
+ btnPrint.Left := btnCreate.Left;
+
+ Left := Application.MainForm.ClientOrigin.X + 100;
+ Top := Application.MainForm.ClientOrigin.Y;
+
+ ClientWidth := pnlMain.Width + (pnlMain.Left * 2);
+ ClientHeight := pnlMain.Height + (pnlMain.Top * 2);
+
+ FFieldList := TffeFieldList.Create;
+
+ FIndexList := TffeIndexList.Create;
+
+ InitializeFieldGrid;
+ InitializeIndexGrid;
+ InitializeFieldMapGrid;
+
+ edtBLOBExtension.Text := 'BLB';
+ edtBLOBFileDesc.Text := 'BLOB file';
+
+ grpBLOBViewStorage.Left := grpBLOBEditStorage.Left;
+ grpBLOBViewStorage.Width := grpBLOBEditStorage.Width;
+
+ grdOrphanedFields.Cells[0,0] := cnsFieldName;
+ grdOrphanedFields.Cells[1,0] := cnsDataType;
+
+ FInEnterKeyPressed := False; {!!.11}
+ FcboMapOldFieldHasBeenFocused := False; {!!.11}
+ FFieldMapInShiftTab := False; {!!.11}
+end;
+{--------}
+procedure TfrmTableStruct.FormDestroy(Sender: TObject);
+begin
+ try
+ FFEConfigSaveFormPrefs(ClassName, Self);
+ FFEConfigSaveColumnPrefs(ClassName + '.IndexGrid', grdIndexes);
+ FFEConfigSaveColumnPrefs(ClassName + '.FieldGrid', grdFields);
+ FFEConfigSaveInteger(ClassName, 'IndexSplitterPos', pnlIndexDetail.Height); {!!.11}
+ except
+ on E:Exception do
+ ShowMessage('Error writing INI file: '+E.Message);
+ end;
+
+ Assert(Assigned(Config));
+ Config.SortAvailIndexFields := chkAvailFieldsSorted.Checked;
+ FFieldMap.Free;
+ FFieldMap := nil;
+ FFieldMapComboRec.RTItems.Free;
+ FFieldMapComboRec.RTItems := nil;
+ FFieldList.Free;
+ FFieldList := nil;
+ FIndexList.Free;
+ FIndexList := nil;
+end;
+{--------}
+procedure TfrmTableStruct.FormShow(Sender: TObject);
+begin
+ { Center dialog }
+ SetBounds(((Screen.Width - Width) div 2),
+ ((Screen.Height - Height) div 2),
+ Width, Height);
+
+ FFEConfigGetFormPrefs(ClassName, Self);
+ pnlIndexDetail.Height := FFEConfigGetInteger(ClassName, 'IndexSplitterPos', pnlIndexDetail.Height); {!!.11}
+
+ AlignButtons;
+
+ if FDialogMode = dmViewing then
+ btnCancel.Caption := 'C&lose'
+ else
+ btnCancel.Caption := 'Cancel';
+
+ { If redefining then set focus to first Name field in grid. }
+ if FDialogMode <> dmViewing then
+ grdFields.Col := cnFldName;
+
+ { Position to first real index in index grid. }
+ if (FDialogMode = dmViewing) and (grdIndexes.RowCount > 2) then
+ grdIndexes.Row := 2;
+
+end;
+{--------}
+procedure TfrmTableStruct.FormCloseQuery(Sender: TObject;
+ var CanClose: Boolean);
+begin
+ if not (ModalResult = mrOK) and {!!.10}
+ (FDialogMode <> dmViewing) and
+ (FHasChanged) then begin
+ CanClose := (MessageDlg('Are you sure you wish to cancel and lose any changes?',
+ mtConfirmation,
+ [mbYes, mbNo],
+ 0) = mrYes);
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.btnCreateClick(Sender: TObject);
+begin
+ {Begin !!.11}
+ { force typefield validation and saving }
+ if grdFields.Col=cnFldType then begin
+ grdFields.Perform(WM_KEYDOWN, VK_TAB, 0);
+ end;
+ {End !!.11}
+ if ValidateForm then begin
+ try
+ BuildDictionary;
+ CreateTable(edtTableName.Text);
+ FOutputDictionary.Free;
+ FOutputDictionary := nil;
+ ModalResult := mrOK;
+ except
+ { don't close the form }
+ raise;
+ end;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.btnCancelClick(Sender: TObject);
+{Rewritten !!.11}
+begin
+{$IFDEF DCC4OrLater}
+ if fsModal in FormState then
+ ModalResult := mrCancel
+ else
+ Close;
+{$ELSE}
+ ModalResult := mrCancel;
+{$ENDIF}
+end;
+{--------}
+procedure TfrmTableStruct.btnPrintClick(Sender: TObject);
+begin
+ if dlgPrint.Execute then
+ PrintDictionary(FTableIndex, dlgPrint.PrintToFile);
+end;
+{--------}
+procedure TfrmTableStruct.btnImportClick(Sender: TObject);
+var
+ ExcludeIndex,
+ TableIndex: LongInt;
+ ImportFromDatabase,
+ SaveDatabaseItem: TffeDatabaseItem;
+begin
+ ExcludeIndex := -1;
+ if btnRestructure.Visible then ExcludeIndex := FTableIndex;
+ if ShowImportTableDefDlg(FDatabase, ExcludeIndex, ImportFromDatabase, TableIndex) = mrOK then begin
+ tabStructure.ActivePage := tbsFields; {reset to fields display}
+
+ SaveDatabaseItem := FDatabase;
+ FDatabase := ImportFromDatabase;
+ try
+ with grdFields do
+ if EditorMode then begin
+ EditorMode := False;
+ LoadDictionary(TableIndex);
+ EditorMode := True;
+ end else
+ LoadDictionary(TableIndex);
+ {Begin !!.11}
+ { if no index in imported table, add an empty entry
+ so we have an empty line to start editing in }
+ if FIndexList.Count=0 then
+ FIndexList.AddEmpty;
+ {End !!.11}
+ finally
+ FDatabase := SaveDatabaseItem;
+ end;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.btnRestructureClick(Sender: TObject);
+begin
+ {Begin !!.07}
+ { force typefield validation and saving }
+ if grdFields.Col=cnFldType then begin
+ grdFields.Perform(WM_KEYDOWN, VK_TAB, 0);
+ end;
+ {End !!.07}
+ if ValidateForm then
+ if ValidateRestructure then begin
+ BuildDictionary;
+ with tabStructure do
+ if not Pages[PageCount - 1].Enabled or
+ not chkPreserveData.Checked or
+ (FFieldMap.Count = 0) then
+ FDatabase.Tables[FTableIndex].Restructure(FOutputDictionary, nil)
+ else
+ FDatabase.Tables[FTableIndex].Restructure(FOutputDictionary, FFieldMap);
+ FOutputDictionary.Free;
+ FOutputDictionary := nil;
+ ModalResult := mrOK;
+ end;
+end;
+
+
+{=====Fields tab events=====}
+procedure TfrmTableStruct.btnInsertFieldClick(Sender: TObject);
+begin
+ FHasChanged := True;
+ with grdFields do begin
+ try
+ EditorMode := False;
+ FFieldList.InsertEmpty(Row - 1);
+ Col := cnFldName;
+ InvalidateFieldsTable;
+ finally
+ EditorMode := True;
+ end;
+ EnableFieldControls(Row);
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.btnDeleteFieldClick(Sender: TObject);
+var
+ I: Integer;
+begin
+ FHasChanged := True;
+ with grdFields do begin
+ if (Row = RowCount - 1) and (FFieldList.Items[Row - 1].Name = '') then
+ MessageBeep(0)
+ else begin
+ with grdFields do begin
+ I := FIndexList.FieldInUse(FFieldList.Items[Row - 1].Name);
+ if I <> -1 then
+ raise Exception.CreateFmt('Field %s is in use by index %d (%s)',
+ [FFieldList.Items[Row - 1].Name,
+ I,
+ FIndexList.Items[I].Name]);
+ end;
+
+ BeginUpdate;
+ try
+ EditorMode := False;
+ FFieldList.DeleteAt(Row - 1);
+ InvalidateFieldsTable;
+ finally
+ EndUpdate;
+ EditorMode := True;
+ end;
+ EnableFieldControls(Row);
+ end;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.btnMoveFieldUpClick(Sender: TObject);
+begin
+ FHasChanged := True;
+ with grdFields do begin
+ if Row > 1 then begin
+ FFieldList.Exchange(Row - 1, Row - 2);
+ InvalidateFieldsTable;
+ Row := Row - 1;
+ end;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.btnMoveFieldDownClick(Sender: TObject);
+begin
+ FHasChanged := True;
+ with grdFields do begin
+ if Row < pred(RowCount) then begin
+ FFieldList.Exchange(Row, Row - 1);
+ InvalidateFieldsTable;
+ Row := Row + 1;
+ end;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.radBLOBInternalClick(Sender: TObject);
+begin
+ EnableBLOBControls;
+end;
+{--------}
+procedure TfrmTableStruct.cboFieldTypeChange(Sender: TObject);
+begin
+ with grdFields do begin
+ Cells[Col, Row] := cboFieldType.Items[cboFieldType.ItemIndex];
+ end;
+ grdFields.Invalidate;
+end;
+{--------}
+procedure TfrmTableStruct.cboFieldTypeExit(Sender: TObject);
+begin
+ cboFieldType.Visible := False;
+ if Assigned(ActiveControl) and not(ActiveControl = grdFields) then
+ ActiveControl.SetFocus
+ else begin
+ grdFields.SetFocus;
+ grdFields.Perform(WM_KEYDOWN, VK_TAB, 0);
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.grdFieldsEnter(Sender: TObject);
+begin
+ if FDialogMode <> dmViewing then
+ EnableFieldControls(grdFields.Row);
+end;
+{--------}
+procedure TfrmTableStruct.grdFieldsSelectCell(Sender : TObject;
+ Col, Row : Integer;
+ var CanSelect : Boolean);
+var
+ R : TRect;
+ ErrorCode : Word;
+begin
+ { Validate previously selected cell. If a validation error occurs, stop
+ processing and display the error}
+ CanSelect := (FDialogMode <> dmViewing);
+ if (not CanSelect) then Exit;
+
+ case grdFields.Col of
+ cnFldName :
+ CanSelect := FieldNameValidation(grdFields.Cells[cnFldName, grdFields.Row], ErrorCode);
+
+ cnFldUnits :
+ CanSelect := FieldLengthValidation(grdFields.Cells[cnFldUnits, grdFields.Row], ErrorCode);
+ end;
+ if not CanSelect then begin
+ DisplayValidationError(ErrorCode);
+ Exit;
+ end;
+
+ { Save data to FFieldList, and update the grid if necessary}
+ LeavingFieldsCell(grdFields.Col, grdFields.Row);
+
+
+ { Set any special cell attributes (ComboBoxes, Readonly fields)}
+ grdFields.Options := grdFields.Options + [goAlwaysShowEditor, goEditing];
+ case Col of
+ cnFldRequired :
+ grdFields.Options := grdFields.Options - [goAlwaysShowEditor, goEditing];
+
+ cnFldType :
+ begin
+ R := grdFields.CellRect(Col, Row);
+ ShowCellCombo(cboFieldType, grdFields, R);
+ cboFieldType.ItemIndex :=
+ cboFieldType.Items.IndexOf(grdFields.Cells[Col, Row]);
+ end;
+
+ cnFldUnits :
+ if not FFEFieldTypeHasUnits(FFieldList.Items[Pred(Row)].FieldType) then
+ grdFields.Options := grdFields.Options - [goAlwaysShowEditor, goEditing]
+ else
+ grdFields.Options := grdFields.Options + [goAlwaysShowEditor, goEditing];
+
+ cnFldDecPl :
+ if not FFEFieldTypeHasDecPl(FFieldList.Items[Pred(Row)].FieldType) then
+ grdFields.Options := grdFields.Options - [goAlwaysShowEditor, goEditing]
+ else
+ grdFields.Options := grdFields.Options + [goAlwaysShowEditor, goEditing];
+
+ cnFldDefault :
+ if not AllowDefaultField(Row, ErrorCode) then
+ grdFields.Options := grdFields.Options - [goAlwaysShowEditor, goEditing]
+ end;
+
+ EnableFieldControls(Row);
+end;
+{--------}
+procedure TfrmTableStruct.grdFieldsDrawCell(Sender: TObject; ACol,
+ ARow: Integer; Rect: TRect; State: TGridDrawState);
+var
+ DrawType : TffeDrawType;
+ ErrorCode : Word;
+begin
+ { Leave fixed portion of the grid alone}
+ if gdFixed in State then Exit;
+
+ with grdFields do begin
+ DrawType := dtNormal;
+ if ((not (FDialogMode = dmViewing)) and (FFieldList.Count > ARow)) or {!!.06}
+ ((FDialogMode = dmViewing) and (FFieldList.Count >= ARow)) then {!!.06}
+ case ACol of
+ cnFldUnits:
+ if not FFEFieldTypeHasUnits(FFieldList.Items[Pred(ARow)].FieldType) then
+ DrawType := dtGrayed;
+
+ cnFldDecPl:
+ if not FFEFieldTypeHasDecPl(FFieldList.Items[Pred(ARow)].FieldType) then
+ DrawType := dtGrayed;
+
+ cnFldRequired:
+ if (FFieldList.Items[Pred(ARow)].fiDataTypeIndex = Ord(fftAutoInc)) then {!!.06}
+ DrawType := dtGrayed {!!.06}
+ else begin {!!.06}
+ if FFieldList.Items[Pred(ARow)].fiRequired then
+ DrawType := dtChecked
+ else
+ DrawType := dtUnchecked;
+ end; {!!.06}
+
+ cnFldDefault:
+ if not AllowDefaultField(aRow, ErrorCode) then
+ DrawType := dtGrayed;
+ end;
+
+ { Now that the DrawType is known, we can manipulate the canvas}
+ DrawCell(Sender as TffStringGrid, DrawType, Rect, State, Cells[ACol, ARow]);
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.grdFieldsKeyPress(Sender : TObject;
+ var Key : Char);
+const
+ valValidNumber = ['0'..'9'];
+ valValidAlpha = ['a'..'z','A'..'Z'];
+var
+ Value : string;
+ Ignore : Boolean;
+begin
+ if Key = #13 then
+ { Change the selected cell (Enter as tab)}
+ with grdFields do
+ if Col < Pred(ColCount) then
+ Col := Col + 1
+ else if Row < Pred(RowCount) then begin
+ Row := Row + 1;
+ Col := cnFldName;
+ end else begin
+ Row := 1;
+ Col := cnFldName;
+ end
+ else begin
+ { Validate data entry as key's are pressed}
+ case grdFields.Col of
+ cnFldName:
+ begin
+ Value := grdFields.Cells[cnFldName, grdFields.Row];
+ Ignore := not(Key in [#8, #46]) and (Length(Value) >= 31); {!!.01}
+ end;
+
+ cnFldUnits:
+ begin
+ Value := grdFields.Cells[cnFldUnits, grdFields.Row];
+ if Key in valValidAlpha then
+ Ignore := True
+ else
+ Ignore := (Key in valValidNumber) and (Length(Value) >= 5);
+ end;
+
+ cnFldDecPl:
+ begin
+ Value := grdFields.Cells[cnFldDecPl, grdFields.Row];
+ if Key in valValidAlpha then
+ Ignore := True
+ else
+ Ignore := (Key in valValidNumber) and (Length(Value) >= 3)
+ end;
+
+ cnFldDefault:
+ begin
+ {Is the default value <= the units?}
+ if (Key <> #8) then begin
+ if ((FFEFieldTypeRequiresUnits(FFieldList.Items[pred(grdFields.Row)].FieldType)) or
+ (StrToInt(grdFields.Cells[cnFldUnits ,grdFields.Row]) > 0)) then
+ Ignore := Length(grdFields.Cells[cnFldDefault ,grdFields.Row]) >=
+ StrToInt(grdFields.Cells[cnFldUnits ,grdFields.Row])
+ else
+ Ignore := False;
+ if (not Ignore) then
+ Ignore := not ValidDefaultFieldKey(UpCase(Key),
+ FFieldList.Items[Pred(grdFields.Row)].FieldType);
+ end else
+ Ignore := False;
+ end;
+
+ cnFldDesc:
+ Ignore := not(Key in [#8, #46]) and (Length(Value) >= 63); {!!.01}
+
+ cnFldRequired :
+ begin
+ Ignore := (not (Key in [#9, #32]));
+ if (Key = ' ') and (not (FDialogMode = dmViewing)) then
+ with FFieldList.Items[Pred(grdFields.Row)] do
+ fiRequired := not fiRequired;
+ grdFields.Invalidate;
+ end;
+
+ else
+ Ignore := False;
+ end;
+ if Ignore then begin
+ Key := #0;
+ MessageBeep(0);
+ end;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.grdFieldsMouseUp(Sender : TObject;
+ Button : TMouseButton;
+ Shift : TShiftState;
+ X, Y : Integer);
+var
+ ACol, ARow: Longint;
+ Rect, Dest : TRect;
+begin
+ { Manipulate checkbox state in Fields grid}
+ if Button <> mbLeft then Exit;
+ grdFields.MouseToCell(X,Y, ACol, ARow);
+ if ACol = cnFldRequired then
+ begin
+ Rect := grdFields.CellRect(ACol, ARow);
+ with imgPlus.Picture do
+ { Retrieve the rect from around the box itself}
+ Dest := Bounds(Rect.Left + ((Rect.Right - Bitmap.Width - Rect.Left) div 2),
+ Rect.Top + (grdFields.DefaultRowHeight - Bitmap.Height) div 2,
+ Bitmap.Width,
+ Bitmap.Height);
+
+ { Only manipuate the checkbox state if an area on or within the rect was
+ clicked}
+ if (X >= Dest.Left) and (X <= Dest.Right) and
+ (Y >= Dest.Top) and (Y <= Dest.Bottom) and
+ (not (FDialogMode = dmViewing)) then begin {!!.06}
+ with FFieldList.Items[Pred(ARow)] do
+ fiRequired := not fiRequired;
+ grdFields.Invalidate;
+ end;
+ end;
+end;
+
+
+{=====Indexes tab events=====}
+procedure TfrmTableStruct.btnDeleteIndexClick(Sender: TObject);
+begin
+ FHasChanged := True;
+ if (grdIndexes.Row = grdIndexes.RowCount - 1) and
+ (FIndexList.Items[grdIndexes.Row - 1].Name = '') then
+ MessageBeep(0)
+ else begin
+ grdIndexes.BeginUpdate;
+ try
+ grdIndexes.EditorMode := False;
+ FIndexList.DeleteAt(grdIndexes.Row - 1);
+ grdIndexes.RowCount := grdIndexes.RowCount - 1;
+ InvalidateIndexesTable;
+ finally
+ grdIndexes.EndUpdate;
+ grdIndexes.EditorMode := True;
+ end;
+ EnableIndexControls(grdIndexes.Row, '');
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.AddFieldToIndex;
+var
+ Idx : Integer;
+ ItemIdx : Integer;
+ KeyLength : Integer;
+begin
+ FHasChanged := True;
+ with lstAvailFields do
+ if SelCount = -1 then begin
+ if ItemIndex <> -1 then begin
+ lstIndexFields.Items.Add(Items[ItemIndex]);
+ with grdIndexes do begin
+ BeginUpdate;
+ try
+ with FIndexList.Items[Row - 1] do begin
+ AddField(Items[ItemIndex]);
+ KeyLength := CalcKeyLength(Row - 1);
+ if KeyLength > ffcl_MaxKeyLength then begin
+ DeleteField(Items[ItemIndex]);
+ raise Exception.CreateFmt('Key length cannot exceed %d', [ffcl_MaxKeyLength]);
+ end;
+ iiKeyLen := KeyLength;
+ end;
+ finally
+ EndUpdate;
+ end;
+ end;
+ ItemIdx := ItemIndex;
+ Items.Delete(ItemIndex);
+ if ItemIdx < Items.Count then
+ ItemIndex := ItemIdx
+ else if Items.Count > 0 then
+ ItemIndex := Items.Count - 1;
+ end;
+ end else
+ { The multiselect option is selected for the list}
+ for Idx := 0 to Pred(Items.Count) do
+ if Selected[Idx] then begin
+ lstIndexFields.Items.Add(Items[Idx]);
+ with grdIndexes do begin
+ BeginUpdate;
+ try
+ with FIndexList.Items[Row - 1] do begin
+ AddField(Items[Idx]);
+ KeyLength := CalcKeyLength(Row - 1);
+ if KeyLength > ffcl_MaxKeyLength then begin
+ DeleteField(Items[Idx]);
+ raise Exception.CreateFmt('Key length cannot exceed %d', [ffcl_MaxKeyLength]);
+ end;
+ iiKeyLen := KeyLength;
+ end;
+ finally
+ EndUpdate;
+ end;
+ end;
+ ItemIdx := Idx;
+ Items.Delete(Idx);
+ if ItemIdx < Items.Count then
+ ItemIndex := ItemIdx
+ else if Items.Count > 0 then
+ ItemIndex := Pred(Items.Count);
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.RemoveFieldFromIndex;
+var
+ ItemIdx: Integer;
+begin
+ FHasChanged := True;
+ with lstIndexFields do
+ if ItemIndex <> -1 then begin
+ lstAvailFields.Items.Add(Items[ItemIndex]);
+ with grdIndexes do begin
+ BeginUpdate;
+ try
+ with FIndexList.Items[Row - 1] do begin
+ DeleteField(Items[ItemIndex]);
+ iiKeyLen := CalcKeyLength(Row - 1);
+ end;
+ finally
+ EndUpdate;
+ end;
+ end;
+ ItemIdx := ItemIndex;
+ Items.Delete(ItemIndex);
+ if ItemIdx < Items.Count then
+ ItemIndex := ItemIdx
+ else if Items.Count > 0 then
+ ItemIndex := Items.Count - 1;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.btnAddIndexFieldClick(Sender: TObject);
+begin
+ AddFieldToIndex;
+end;
+{--------}
+procedure TfrmTableStruct.btnRemoveIndexFieldClick(Sender: TObject);
+begin
+ RemoveFieldFromIndex;
+end;
+{--------}
+procedure TfrmTableStruct.btnMoveIndexFieldUpClick(Sender: TObject);
+var
+ NewItemIndex: Integer;
+begin
+ FHasChanged := True;
+ with lstIndexFields do
+ if ItemIndex > 0 then begin
+ with FIndexList.Items[grdIndexes.Row - 1] do
+ ExchangeFields(Items[ItemIndex], Items[ItemIndex - 1]);
+ NewItemIndex := ItemIndex - 1;
+ Items.Exchange(ItemIndex, ItemIndex - 1);
+ ItemIndex := NewItemIndex;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.btnMoveIndexFieldDownClick(Sender: TObject);
+var
+ NewItemIndex: Integer;
+begin
+ FHasChanged := True;
+ with lstIndexFields do
+ if (ItemIndex <> -1) and (ItemIndex < Items.Count - 1) then begin
+ with FIndexList.Items[grdIndexes.Row - 1] do
+ ExchangeFields(Items[ItemIndex], Items[ItemIndex + 1]);
+ NewItemIndex := ItemIndex + 1;
+ Items.Exchange(ItemIndex, ItemIndex + 1);
+ ItemIndex := NewItemIndex;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.lstIndexFieldsDragOver(Sender, Source: TObject;
+ X, Y: Integer; State: TDragState; var Accept: Boolean);
+begin
+ if Source is TComponent then
+ Accept := (TComponent(Source).Name = 'lstAvailFields');
+end;
+{--------}
+procedure TfrmTableStruct.lstIndexFieldsDragDrop(Sender, Source: TObject;
+ X, Y: Integer);
+begin
+ if FDialogMode <> dmViewing then
+ btnAddIndexFieldClick(Source);
+end;
+{--------}
+procedure TfrmTableStruct.lstAvailFieldsDragOver(Sender, Source: TObject;
+ X, Y: Integer; State: TDragState; var Accept: Boolean);
+begin
+ if Source is TComponent then
+ Accept := (TComponent(Source).Name = 'lstIndexFields');
+end;
+{--------}
+procedure TfrmTableStruct.lstAvailFieldsDragDrop(Sender, Source: TObject;
+ X, Y: Integer);
+begin
+ if FDialogMode <> dmViewing then
+ btnRemoveIndexFieldClick(Source);
+end;
+{--------}
+procedure TfrmTableStruct.cboIndexTypeChange(Sender: TObject);
+begin
+ with grdIndexes, TComboBox(Sender) do {!!.01}
+ Cells[Col, Row] := Items[ItemIndex]; {!!.01}
+
+ grdIndexes.Invalidate;
+end;
+{--------}
+procedure TfrmTableStruct.cboIndexTypeExit(Sender: TObject);
+begin
+ TComboBox(Sender).Visible := False;
+ if Assigned(ActiveControl) and not(ActiveControl = grdIndexes) then
+ ActiveControl.SetFocus
+ else begin
+ grdIndexes.SetFocus;
+ grdIndexes.Perform(WM_KEYDOWN, VK_TAB, 0);
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.grdIndexesEnter(Sender: TObject);
+begin
+ if FDialogMode <> dmViewing then
+ EnableIndexControls(grdIndexes.Row, '');
+end;
+{--------}
+procedure TfrmTableStruct.grdIndexesSelectCell(Sender: TObject; ACol,
+ ARow: Integer; var CanSelect: Boolean);
+var
+ Rect: TRect;
+ ErrorCode : Word;
+begin
+ { Validate previously selected cell. If a validation error occurs, stop
+ processing and display the error}
+ if FDialogMode = dmViewing then begin
+ CanSelect := grdIndexes.Row <> aRow;
+ if CanSelect then
+ PopulateIndexFieldsLists(aRow - 1);
+ Exit;
+ end;
+ case grdIndexes.Col of
+ cnIdxName:
+ CanSelect := IndexNameValidation(grdIndexes.Cells[cnIdxName, grdIndexes.Row], ErrorCode);
+ cnIdxExt:
+ CanSelect := IndexExtensionValidation(grdIndexes.Cells[cnIdxExt, grdIndexes.Row], ErrorCode);
+ cnIdxKeyLength:
+ CanSelect := IndexKeyLenValidation(StrToInt('0' + grdIndexes.Cells[cnIdxKeyLength, grdIndexes.Row]), ErrorCode);
+ end;
+ if not CanSelect then begin
+ DisplayValidationError(ErrorCode);
+ Exit;
+ end;
+
+ { Save data to FFieldList, and update the grid if necessary}
+ LeavingIndexCell(grdIndexes.Col, grdIndexes.Row);
+ PopulateIndexFieldsLists(Pred(aRow));
+
+ {Set any special cell attributes}
+ grdIndexes.Options := grdIndexes.Options + [goAlwaysShowEditor, goEditing];
+ case ACol of
+ cnIdxKeyLength:
+ if FIndexList.Items[Pred(ARow)].iiKeyTypeIndex <> ktUserDefined then
+ grdIndexes.Options := grdIndexes.Options - [goAlwaysShowEditor, goEditing];
+
+ cnIdxUnique, cnIdxAscending, cnIdxCaseSensitive:
+ grdIndexes.Options := grdIndexes.Options - [goAlwaysShowEditor, goEditing];
+
+ cnIdxType:
+ begin
+ Rect := grdIndexes.CellRect(ACol, ARow);
+ ShowCellCombo(cboIndexType, grdIndexes, Rect);
+ cboIndexType.ItemIndex :=
+ FIndexList.Items[Pred(ARow)].iiKeyTypeIndex;
+ end;
+
+ cnIdxBlockSize:
+ begin
+ if FIndexList.Items[Pred(ARow)].iiExtension = '' then
+ grdIndexes.Options := grdIndexes.Options - [goAlwaysShowEditor, goEditing]
+ else begin
+ Rect := grdIndexes.CellRect(ACol, ARow);
+ ShowCellCombo(cboIndexBlockSize, grdIndexes, Rect);
+ cboIndexBlockSize.ItemIndex :=
+ FIndexList.Items[Pred(ARow)].iiBlockSizeIndex;
+ end;
+ end;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.grdIndexesKeyPress(Sender: TObject;
+ var Key: Char);
+const
+ valValidNumber = ['0'..'9'];
+ valValidAlpha = ['a'..'z','A'..'Z'];
+var
+ Ignore: Boolean;
+begin
+ with grdIndexes do
+ if Key = #13 then
+ if Col < ColCount-1 then {next column!}
+ Col := Col + 1
+ else if Row < RowCount-1 then begin {next Row!}
+ Row := Row + 1;
+ Col := 1;
+ end else begin {End of Grid! - Go to Top again!}
+ Row := 1;
+ Col := 1;
+ {or you can make it move to another Control}
+ end
+ else begin
+ case Col of
+ cnIdxName:
+ begin
+ Ignore := not(Key in [#8, #46]) and (Length(Cells[Col, Row]) >= 31); {!!.01}
+ EnableIndexControls(Row, Cells[Col, Row] + Key);
+ end;
+
+ cnIdxKeyLength:
+ If Key in valValidAlpha then
+ Ignore := True
+ else
+ Ignore := (Key in valValidNumber) and (Length(Cells[Col, Row]) >= 3);
+
+ cnIdxExt:
+ Ignore := not(Key in [#8, #46]) and (Length(Cells[Col, Row]) >= 3); {!!.01}
+
+ cnIdxDesc:
+ Ignore := not(Key in [#8, #46]) and (Length(Cells[Col, Row]) >= 63) {!!.01}
+ else
+ Ignore := False;
+ end;
+ if Ignore then begin
+ Key := #0;
+ MessageBeep(0);
+ end;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.grdIndexesDrawCell(Sender: TObject; ACol,
+ ARow: Integer; Rect: TRect; State: TGridDrawState);
+var
+ DrawType: TffeDrawType;
+begin
+ if gdFixed in State then Exit;
+
+ with grdIndexes do begin
+ DrawType := dtNormal;
+ if (ARow = 0) then
+ DrawType := dtIgnore
+ else
+ case ACol of
+ cnIdxKeyLength:
+ if FIndexList.Items[Pred(ARow)].iiKeyTypeIndex <> ktUserDefined then
+ DrawType := dtGrayed;
+
+ cnIdxBlockSize:
+ if FIndexList.Items[Pred(ARow)].iiExtension = '' then
+ DrawType := dtGrayed;
+
+ cnIdxUnique:
+ if FIndexList.Items[Pred(ARow)].iiUnique then
+ DrawType := dtChecked
+ else
+ DrawType := dtUnchecked;
+
+ cnIdxAscending:
+ if FIndexList.Items[Pred(ARow)].iiAscending then
+ DrawType := dtChecked
+ else
+ DrawType := dtUnchecked;
+
+ cnIdxCaseSensitive:
+ if FIndexList.Items[Pred(ARow)].iiCaseSensitive then
+ DrawType := dtChecked
+ else
+ DrawType := dtUnchecked;
+ else
+ DrawType := dtIgnore;
+ end;
+
+ DrawCell(Sender as TffStringGrid, DrawType, Rect, State, Cells[ACol, ARow]);
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.grdIndexesMouseUp(Sender: TObject;
+ Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
+var
+ ACol, ARow: Longint;
+ Rect, Dest : TRect;
+begin
+ if Button <> mbLeft then Exit;
+ grdIndexes.MouseToCell(X,Y, ACol, ARow);
+ if (ARow > 0) and
+ (ACol in [cnIdxUnique, cnIdxAscending, cnIdxCaseSensitive]) then
+ begin
+ Rect := grdIndexes.CellRect(ACol, ARow);
+ with imgPlus.Picture do
+ Dest := Bounds(Rect.Left + ((Rect.Right - Bitmap.Width - Rect.Left) div 2),
+ Rect.Top + (grdIndexes.DefaultRowHeight - Bitmap.Height) div 2,
+ Bitmap.Width,
+ Bitmap.Height);
+ if (X >= Dest.Left) and (X <= Dest.Right) and
+ (Y >= Dest.Top) and (Y <= Dest.Bottom) and
+ (not (FDialogMode = dmViewing)) then begin {!!.06}
+ with FIndexList.Items[Pred(ARow)] do
+ case ACol of
+ cnIdxUnique:
+ iiUnique := not iiUnique;
+ cnIdxAscending:
+ iiAscending := not iiAscending;
+ cnIdxCaseSensitive:
+ iiCaseSensitive := not iiCaseSensitive;
+ end;
+ grdIndexes.Invalidate;
+ end;
+ end;
+end;
+
+
+{=====Existing data tab events=====}
+procedure TfrmTableStruct.tabFieldMapPageChanged(Sender: TObject;
+ Index: Integer);
+var
+ I, J, N: Integer;
+ Found: Boolean;
+begin
+ case Index of
+ 0: begin
+ btnMatchByName.Enabled := True;
+ btnMatchByPosition.Enabled := True;
+ btnClearAll.Enabled := True;
+ end;
+ 1: begin
+ btnMatchByName.Enabled := False;
+ btnMatchByPosition.Enabled := False;
+ btnClearAll.Enabled := False;
+
+ { Build the orphaned fields list }
+ with FDatabase.Tables[FTableIndex].Dictionary do begin
+ N := 0;
+ for I := 0 to FieldCount - 1 do begin
+ Found := False;
+ for J := 0 to FFieldMap.Count - 1 do
+ if Pos('=' + FieldName[I] + #255, FFieldMap[J] + #255) <> 0 then begin
+ Found := True;
+ Break;
+ end;
+
+ if not Found then
+ with grdOrphanedFields do begin
+ Cells[0, N + FixedRows] := FieldName[I];
+ if FieldType[I] >= fftByteArray then
+ Cells[1, N + FixedRows] := Format('%s[%d]', [FieldDataTypes[FieldType[I]], FieldUnits[I]])
+ else
+ Cells[1, N + FixedRows] := FieldDataTypes[FieldType[I]];
+ Inc(N);
+ end;
+ end;
+
+ with grdOrphanedFields do begin
+ RowCount := N + FixedRows + 1;
+ Cells[0, RowCount - 1] := '';
+ Cells[1, RowCount - 1] := '';
+ end;
+ end;
+ end;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.btnMatchByNameClick(Sender: TObject);
+var
+ I: Integer;
+ NewFieldName: TffDictItemName;
+ OldFieldIndex: Integer;
+begin
+ with grdFieldMap do begin
+ BeginUpdate;
+ ReverseFFieldMap := TStringList.Create; {!!.11}
+ try
+ try
+ FFieldMap.Clear;
+ for I := 0 to FFieldList.Count - 1 do begin
+ NewFieldName := FFieldList.Items[I].Name;
+ with FDatabase.Tables[FTableIndex].Dictionary do begin
+ OldFieldIndex := GetFieldFromName(NewFieldName);
+ if OldFieldIndex <> -1 then
+
+ { Check assignment compatibility }
+ if FFConvertSingleField(
+ nil,
+ nil,
+ FieldType[OldFieldIndex],
+ FFEIndexToFieldType(FFieldList.Items[I].fiDatatypeIndex),
+ -1,
+ -1) = DBIERR_NONE then begin
+ FFieldMap.Values[NewFieldName] := NewFieldName;
+ ReverseFFieldMap.Values[NewFieldName] := NewFieldName; {!!.11}
+ end;
+ end;
+ end;
+ finally
+ InvalidateFieldMapTable;
+ EndUpdate;
+ end;
+ {Begin !!.11}
+ finally
+ ReverseFFieldMap.Free;
+ ReverseFFieldMap := nil;
+ end;
+ {End !!.11}
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.btnMatchByPositionClick(Sender: TObject);
+var
+ I: Integer;
+ NewFieldName: TffDictItemName;
+begin
+ with grdFieldMap do begin
+ BeginUpdate;
+ ReverseFFieldMap := TStringList.Create; {!!.11}
+ try
+ try
+ FFieldMap.Clear;
+ for I := 0 to FFieldList.Count - 1 do begin
+ NewFieldName := FFieldList.Items[I].Name;
+ with FDatabase.Tables[FTableIndex].Dictionary do
+ if I < FieldCount then
+
+ { Check assignment compatibility }
+ if FFConvertSingleField(
+ nil,
+ nil,
+ FieldType[I],
+ FFEIndexToFieldType(FFieldList.Items[I].fiDatatypeIndex),
+ -1,
+ -1) = DBIERR_NONE then begin
+ FFieldMap.Values[NewFieldName] := FieldName[I];
+ ReverseFFieldMap.Values[FieldName[I]] := NewFieldName;
+ end;
+ end;
+ finally
+ InvalidateFieldMapTable;
+ EndUpdate;
+ end;
+ {Begin !!.11}
+ finally
+ ReverseFFieldMap.Free;
+ ReverseFFieldMap := nil;
+ end;
+ {End !!.11}
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.btnClearAllClick(Sender: TObject);
+begin
+ FFieldMap.Clear;
+ InvalidateFieldMapTable;
+end;
+{--------}
+procedure TfrmTableStruct.chkPreserveDataClick(Sender: TObject);
+begin
+ FFEEnableContainer(grpExistingData, chkPreserveData.Checked);
+end;
+{--------}
+procedure TfrmTableStruct.grdFieldMapEnter(Sender: TObject);
+var
+ Dummy: Boolean;
+begin
+ { rewritten }
+ {Begin !!.11}
+ if not FcboMapOldFieldHasBeenFocused and
+ not FFieldMapInShiftTab then begin
+ grdFieldMap.Col := 2;
+ grdFieldMap.OnSelectCell(Self, grdFieldMap.Col, grdFieldMap.Row, Dummy);
+ end
+ else
+ if FFieldMapInShiftTab then begin
+ SelectNext(grdFieldMap, False, True);
+ end;
+ FcboMapOldFieldHasBeenFocused := False;
+ FFieldMapInShiftTab := False;
+ {End !!.11}
+end;
+{--------}
+procedure TfrmTableStruct.grdFieldMapActiveCellMoving(Sender: TObject;
+ Command: Word; var RowNum: Longint; var ColNum: Integer);
+begin
+(*if ColNum < 2 then ColNum := 2;
+ with grdFieldMap do
+ case Command of
+ ccRight: begin
+ Inc(RowNum);
+ if RowNum >= RowLimit then
+ RowNum := LockedRows;
+ end;
+ ccLeft: begin
+ Dec(RowNum);
+ if RowNum < LockedRows then
+ RowNum := RowLimit - 1;
+ end;
+ end;*)
+end;
+{--------}
+procedure TfrmTableStruct.tcMapOldFieldChange(Sender: TObject);
+var
+ TCB: TComboBox;
+ I: Integer;
+ TempStr: TffShStr;
+begin
+ TCB := TComboBox(Sender as TCustomComboBox);
+ I := TCB.ItemIndex;
+
+ if I < 0 then TempStr := ''
+ else TempStr := Copy(TCB.Items[I], 1, Pos(' (', TCB.Items[I]) - 1);
+
+ FFieldMap.Values[FFieldList.Items[grdFieldMap.Row - 1].Name] := TempStr;
+end;
+
+
+{=====General routines=====}
+{--------}
+procedure TfrmTableStruct.AlignButtons;
+{ Find all the visible buttons on the main panel and center them }
+var
+ I: Integer;
+ Buttons: TffList;
+ NewLeft: Integer;
+ Offset: Integer;
+ CurrentIndex: Integer;
+ FirstIndex: Integer;
+ BaseWidth: Integer;
+begin
+ Buttons := TffList.Create;
+ try
+ with pnlDialogButtons do begin
+ for I := 0 to ControlCount - 1 do
+ if Controls[I] is TBitBtn then
+ if Controls[I].Visible then
+
+ { We store the control's horizontal position in the 1st word,
+ then the control index in the 2nd word. }
+ Buttons.Insert(TffIntListItem.Create(Controls[I].Left * ($FFFF + 1) + I));
+
+ FirstIndex := TffIntListItem(Buttons[0]).KeyAsInt and $FFFF;
+ BaseWidth := Controls[FirstIndex].Width;
+ NewLeft := 0;
+ for I := 0 to Buttons.Count - 1 do begin
+ CurrentIndex := TffIntListItem(Buttons[I]).KeyAsInt and $FFFF;
+ with Controls[CurrentIndex] do begin
+ Left := NewLeft;
+ Width := BaseWidth;
+ Inc(NewLeft, Width + 8);
+ end;
+ end;
+ Dec(NewLeft, 8);
+
+ Offset := (pnlMain.Width - NewLeft) div 2;
+ for I := 0 to Buttons.Count - 1 do
+ with Controls[TffIntListItem(Buttons[I]).KeyAsInt and $FFFF] do
+ Left := Left + Offset;
+ end;
+ finally
+ Buttons.Free;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.PopulateForm(aTableIndex: LongInt; aReadOnly: Boolean);
+begin
+ LoadDictionary(aTableIndex);
+ if not aReadOnly then begin
+ FFieldList.AddEmpty;
+ InvalidateFieldsTable;
+ FIndexList.AddEmpty;
+ InvalidateIndexesTable;
+ EnableIndexControls(1, '');
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.DrawCell(Grid : TffStringGrid; DrawType: TffeDrawType;
+ Rect: TRect; State: TGridDrawState; CellText: string);
+var
+ Bitmap: TBitmap;
+ Dest, Source: TRect;
+ X,Y: Integer;
+ WrapText, WrapTemp: string;
+ WrapPos: integer;
+begin
+ case DrawType of
+ dtIgnore: Exit;
+ dtNormal, dtGrayed:
+ with Grid do begin
+ if DrawType = dtNormal then
+ Canvas.Brush.Color := clWindow
+ else
+ Canvas.Brush.Color := clBtnFace;
+ Canvas.FillRect(Rect);
+ Canvas.TextRect(Rect, Rect.Left + cnLeftMargin, Rect.Top + cnTopMargin,
+ CellText);
+ end;
+
+ dtChecked, dtUnChecked:
+ begin
+ if DrawType = dtChecked then
+ Bitmap := imgPlus.Picture.Bitmap
+ else
+ Bitmap := imgMinus.Picture.Bitmap;
+ with Grid.Canvas do begin
+ Dest := Bounds(Rect.Left + ((Rect.Right - Bitmap.Width - Rect.Left) div 2),
+ Rect.Top + (grdIndexes.DefaultRowHeight - Bitmap.Height) div 2,
+ Bitmap.Width,
+ Bitmap.Height);
+ Source := Bounds(0, 0, Bitmap.Width, Bitmap.Height);
+ BrushCopy(Dest,
+ Bitmap,
+ Source,
+ Bitmap.TransparentColor);
+ end;
+ end;
+ dtWordWrap:
+ begin
+ with Grid.Canvas do begin
+ if gdFixed in State then begin
+ Pen.Color := clBtnText;
+ Brush.Color := clBtnFace;
+ end else begin
+ Pen.Color := clWindowText;
+ Brush.Color := clWindow;
+ end;
+ Rectangle(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
+
+ Y := Rect.Top;
+
+ WrapText := CellText;
+ repeat
+ WrapPos := Pos(#13, WrapText);
+ if WrapPos <= 0 then
+ WrapTemp := WrapText
+ else
+ WrapTemp := Copy(WrapText,1,Pred(WrapPos));
+ Delete(WrapText, 1, WrapPos);
+ X := Rect.Left + ((Rect.Right - TextWidth(WrapTemp) - Rect.Left) div 2);
+ TextOut(X, Y, WrapTemp);
+ Y := Y + TextHeight(WrapTemp);
+ until WrapPos <= 0;
+ end;
+ end;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.ShowCellCombo(ComboBox: TCustomComboBox;
+ Grid: TCustomGrid; Rect: TRect);
+begin
+ Rect.Left := Rect.Left + Grid.Left;
+ Rect.Right := Rect.Right + Grid.Left;
+ Rect.Top := Rect.Top + Grid.Top;
+ Rect.Bottom := Rect.Bottom + Grid.Top;
+ ComboBox.Left := Rect.Left + 1;
+ ComboBox.Top := Rect.Top + 1;
+ ComboBox.Width := (Rect.Right + 1) - Rect.Left;
+ ComboBox.Height := (Rect.Bottom + 1) - Rect.Top;
+
+ {Display the combobox}
+ ComboBox.Visible := True;
+ ComboBox.SetFocus;
+end;
+{--------}
+procedure TfrmTableStruct.CMDialogKey(var msg: TCMDialogKey);
+begin
+ if (ActiveControl = cboFieldType) or
+ (ActiveControl = cboIndexType) or
+ (ActiveControl = cboIndexBlockSize) then
+ begin
+ if (msg.CharCode = VK_TAB) then
+ begin
+ ActiveControl.Visible := False;
+(* if ActiveControl = cboFieldType then
+ grdFields.SetFocus
+ else
+ grdIndexes.SetFocus;*)
+ msg.result := 1;
+ Exit;
+ end;
+ end else begin
+ end;
+ if (ActiveControl = cboMapOldField) and
+ (msg.CharCode = VK_TAB) and
+ (GetKeyState(VK_SHIFT)<0) then begin
+ FFieldMapInShiftTab := True;
+ end;
+ inherited;
+end;
+
+
+{=====Dictionary routines=====}
+procedure TfrmTableStruct.BuildDictionary;
+var
+ I, J: Integer;
+ FileNumber: Integer;
+ FieldArray: TffFieldList;
+ FieldIHList : TffFieldIHList;
+ ExtFound: Boolean;
+begin
+ FOutputDictionary.Free;
+ FOutputDictionary := nil;
+
+ FOutputDictionary := TffDataDictionary.Create(StrToInt(cboBlockSize.Text));
+ try
+ with FOutputDictionary do begin
+ IsEncrypted := chkEncryptData.Checked;
+
+ { Add the fields; the field list is assumed to be valid at this point }
+ for I := 0 to FFieldList.Count - 1 do
+ with FFieldList.Items[I] do
+ if Name <> '' then
+ AddField(Name,
+ fiDescription,
+ FFEIndexToFieldType(fiDataTypeIndex),
+ fiUnits,
+ fiDecPlaces,
+ fiRequired,
+ PffVCheckDescriptor(@fiValCheck));
+
+ { Check for external BLOB file }
+ if radBLOBExternal.Checked then
+ AddFile(edtBLOBFileDesc.Text, edtBLOBExtension.Text,
+ StrToInt(cboBLOBBlockSize.Text), ftBlobFile);
+
+ { Add the Indexes }
+ for I := 0 to FIndexList.Count - 1 do
+ with FIndexList.Items[I] do
+ if Name <> '' then begin
+
+ { Determine if this index is to be stored in an external file }
+ FileNumber := 0;
+ ExtFound := False;
+ iiExtension := ANSIUppercase(iiExtension);
+ if iiExtension <> '' then begin
+ { note that file descriptions are not supported yet }
+ for J := 0 to FileCount - 1 do
+ if FFCmpShStrUC(iiExtension, FileExt[J], 255) = 0 then begin
+ ExtFound := True;
+ Break;
+ end;
+ if not ExtFound then
+ FileNumber := AddFile('', iiExtension, BlockSize, ftIndexFile);
+ end;
+
+ if iiKeyTypeIndex = ktComposite then begin
+
+ { Construct the list of fields that comprise this index }
+ for J := 0 to FieldCount - 1 do begin
+ FieldArray[J] := GetFieldFromName(FieldName[J]);
+ if FieldArray[J] = -1 then
+ raise Exception.CreateFmt('Index %d (%s) refers to nonexistent field %s', [I + 1, Name, FieldName[J]]);
+ FieldIHList[J] := '';
+ end;
+
+ AddIndex(Name, iiDescription, FileNumber,
+ FieldCount, FieldArray, FieldIHList, not iiUnique,
+ iiAscending, not iiCaseSensitive);
+ end
+ else begin
+ AddUserIndex(Name, iiDescription, FileNumber,
+ iiKeyLen, not iiUnique, iiAscending, not iiCaseSensitive);
+ end;
+ end;
+ FileDescriptor[0].fdDesc := edtDescription.Text; {!!.10}
+ CheckValid;
+ end;
+ except
+ FOutputDictionary.Free;
+ FOutputDictionary := nil;
+ raise;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.LoadDictionary(aTableIndex: LongInt);
+var
+ IndexFields : TStringList;
+ I : Integer;
+begin
+ with FDatabase.Tables[aTableIndex] do begin
+
+ { Reload always in case of restructure by another user }
+ with Dictionary do begin
+ cboBlockSize.Text := IntToStr(BlockSize);
+ cboBlockSize.ItemIndex := FFEBlockSizeIndex(BlockSize);
+
+ edtDescription.Text := FileDesc[0]; {!!.10}
+
+ { Load the fields }
+ grdFields.BeginUpdate;
+ try
+ FFieldList.Empty;
+ for I := 0 to FieldCount - 1 do begin
+ FFieldList.Insert(FieldName[I],
+ FFEFieldTypeToIndex(FieldType[I]),
+ FieldUnits[I],
+ FieldDecPl[I],
+ FieldRequired[I],
+ FieldDesc[I],
+ FieldVCheck[I]);
+ end;
+ grdFields.RowCount := grdFields.FixedRows + FieldCount;
+ finally
+ InvalidateFieldsTable;
+ grdFields.EndUpdate;
+ end;
+
+ { Check for BLOB storage }
+ edtBLOBExtension.Text := '';
+ cboBLOBBlockSize.Text := '';
+ edtBLOBFileDesc.Text := '';
+ radBLOBInternal.Checked := (BLOBFileNumber = 0);
+ radBLOBExternal.Checked := not radBLOBInternal.Checked;
+ EnableBLOBControls;
+ if BLOBFileNumber <> 0 then begin
+ edtBLOBExtension.Text := FileExt[BLOBFileNumber];
+ cboBLOBBlockSize.Text := IntToStr(FileBlockSize[BLOBFileNumber]);
+ edtBLOBFileDesc.Text := FileDesc[BLOBFileNumber];
+ end;
+
+ { Load the indexes }
+ IndexFields := TStringList.Create;
+ try
+ try
+ FIndexList.LoadFromDict(Dictionary);
+ if FDialogMode in [dmCreating, dmRestructuring] then
+ FIndexList.DeleteAt(0);
+ grdIndexes.RowCount := grdIndexes.FixedRows + IndexCount;
+ finally
+ InvalidateIndexesTable;
+ end;
+ finally
+ IndexFields.Free;
+ end;
+
+ { Encrypted? }
+ chkEncryptData.Checked := IsEncrypted;
+ end;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.CreateTable(aTableName: TffTableName);
+begin
+ with FDatabase do
+ CreateTable(aTableName, FOutputDictionary);
+
+ { Make a new entry for the TableList }
+ FTableIndex := FDatabase.AddTable(aTableName);
+end;
+{--------}
+procedure TfrmTableStruct.PrintDictionary(aTableIndex: LongInt; aPrintToFile: Boolean);
+var
+ F: System.Text;
+ I, J: Integer;
+ FldName: TffDictItemName;
+
+ procedure BoldOn;
+ begin
+ if not aPrintToFile then
+ with Printer.Canvas.Font do
+ Style := Style + [fsBold];
+ end;
+
+ procedure BoldOff;
+ begin
+ if not aPrintToFile then
+ with Printer.Canvas.Font do
+ Style := Style - [fsBold];
+ end;
+
+ function CaseFlag(aNoCase: Boolean): Char;
+ begin
+ if aNoCase then Result := 'I'
+ else Result := 'S';
+ end;
+
+begin
+ with FDatabase.Tables[aTableIndex], Dictionary do begin
+ if aPrintToFile then begin
+
+ { Get filename to save to }
+ with dlgSave do begin
+ if not Execute then Exit;
+ ShowPrintingDlg('Saving structure for ' + TableName);
+ AssignFile(F, FileName);
+ end;
+ end
+ else begin
+ ShowPrintingDlg('Printing structure for ' + TableName);
+ AssignPrn(F);
+ end;
+
+ try
+ Rewrite(F);
+ try
+ if not aPrintToFile then
+ with Printer.Canvas.Font do begin
+ Name := 'Courier New';
+ Size := 10;
+ end;
+
+ WriteLn(F, 'Table definition for:'); {!!.06}
+ WriteLn(F, Format(' Table: %s', [TableName])); {!!.06}
+ WriteLn(F, Format(' Alias: %s', [Database.DatabaseName])); {!!.06}
+ WriteLn(F, Format(' Server: %s', [Server.ServerName])); {!!.06}
+ WriteLn(F);
+ WriteLn(F, Format('Block Size: %d', [BlockSize]));
+ WriteLn(F, Format('Logical Record Length: %d', [LogicalRecordLength]));
+ WriteLn(F, Format('Physical Record Length: %d', [RecordLength]));
+ if IsEncrypted then
+ WriteLn(F, 'Encrypted Table Data: YES') {!!.06}
+ else
+ WriteLn(F, 'Encrypted Table Data: NO'); {!!.06}
+
+ WriteLn(F);
+ BoldOn;
+ WriteLn(F, 'Fields:');
+ WriteLn(F);
+ WriteLn(F, 'Num Name Type Offset Size Units Dec Req Description');
+ BoldOff;
+ for I := 0 to FieldCount - 1 do
+ WriteLn(F, Format('%3d %-20.20s%-17.17s %6d %4d %5d %3d %2.1s %s',
+ [I + 1, FieldName[I], FieldDataTypes[FieldType[I]],
+ FieldOffset[I], FieldLength[I], FieldUnits[I],
+ FieldDecPl[I], FFEBoolToStr(FieldRequired[I]), FieldDesc[I]]));
+
+ WriteLn(F);
+ BoldOn;
+ WriteLn(F, 'Indexes:');
+ WriteLn(F);
+ WriteLn(F, 'Num Name Field(s) File Type Len Uni Asc Case Description');
+ BoldOff;
+ for I := 0 to IndexCount - 1 do begin
+ with IndexDescriptor[I]^ do begin
+ FldName := '(n/a)';
+ if idCount > 0 then
+ FldName := FieldName[idFields[0]];
+ WriteLn(F, Format('%3d %-20.20s%-17.17s %3s %4.4s %3d %2.1s %2.1s %3.1s %s',
+ [idNumber,
+ idName,
+ FldName,
+ FileExt[idFile],
+ IndexTypes[IndexType[I]],
+ idKeyLen,
+ FFEBoolToStr(not idDups),
+ FFEBoolToStr(idAscend),
+ CaseFlag(idNoCase),
+ FFShStrTrimR(idDesc)]));
+ J := 1;
+ while J < idCount do begin
+ Inc(J);
+ WriteLn(F, Format('%25.25s%-17.17s', ['', FieldName[idFields[J - 1]]]));
+ end;
+ end;
+ end;
+
+ WriteLn(F);
+ BoldOn;
+ WriteLn(F, 'Files:');
+ WriteLn(F);
+ WriteLn(F, 'Num File Block Type Description');
+ BoldOff;
+ for I := 0 to FileCount - 1 do
+ WriteLn(F, Format('%3d %-3.3s %6d %-5.5s %s',
+ [I, FileExt[I], FileBlockSize[I],
+ FileTypes[FileType[I]], FileDesc[I]]));
+ WriteLn(F);
+ WriteLn(F);
+ WriteLn(F, 'FlashFiler Explorer v' + FFEVersionStr);
+ WriteLn(F, 'Printed ', DateTimeToStr(Now));
+ finally
+ System.Close(F);
+ end;
+ finally
+ HidePrintingDlg;
+ end;
+ end;
+end;
+
+
+{=====Field grid routines=====}
+
+procedure TfrmTableStruct.InitializeFieldGrid;
+var
+ T: TffFieldType;
+
+begin
+ grdFields.ColCount := cnFldHighest + 1;
+ grdFields.RowCount := 2;
+
+ grdFields.ColWidths[cnFldNumber] := 25;
+ grdFields.ColWidths[cnFldName] := 110;
+ grdFields.ColWidths[cnFldType] := 100;
+ grdFields.ColWidths[cnFldUnits] := 40;
+ grdFields.ColWidths[cnFldDecPl] := 50;
+ grdFields.ColWidths[cnFldRequired] := 50;
+ grdFields.ColWidths[cnFldDefault] := 110;
+ grdFields.ColWidths[cnFldDesc] := 250;
+
+ grdFields.DefaultRowHeight := cboFieldType.Height;
+
+
+ FFEConfigGetColumnPrefs(ClassName + '.FieldGrid', grdFields);
+
+ PopulateFieldGridHeader;
+
+ { Load up the datatype combo box }
+ for T := Low(T) to High(T) do
+ if FFEFieldTypeToIndex(T) <> -1 then
+ cboFieldType.Items.Add(FieldDataTypes[T]);
+
+ btnInsertField.Enabled := False;
+ btnDeleteField.Enabled := False;
+ btnMoveFieldUp.Enabled := False;
+ btnMoveFieldDown.Enabled := False;
+end;
+{--------}
+procedure TfrmTableStruct.PopulateFieldGridHeader;
+var
+ ColNum : Integer;
+begin
+ grdFields.BeginUpdate;
+ try
+ for ColNum := 0 to cnFldHighest do
+ case ColNum of
+ cnFldNumber : grdFields.Cells[ColNum, 0] := cnsNumber;
+ cnFldName : grdFields.Cells[ColNum, 0] := cnsName;
+ cnFldType : grdFields.Cells[ColNum, 0] := cnsType;
+ cnFldUnits : grdFields.Cells[ColNum, 0] := cnsUnits;
+ cnFldDecPl : grdFields.Cells[ColNum, 0] := cnsDecPl;
+ cnFldRequired : grdFields.Cells[ColNum, 0] := cnsRequired;
+ cnFldDefault : grdFields.Cells[ColNum, 0] := cnsDefault;
+ cnFldDesc : grdFields.Cells[ColNum, 0] := cnsDesc;
+ end;
+ finally
+ grdFields.EndUpdate;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.InvalidateFieldsTable;
+var
+ RowNum : Integer;
+begin
+ if FFieldList.Count = 0 then
+ grdFields.RowCount := 2
+ else
+ grdFields.RowCount := succ(FFieldList.Count);
+ for RowNum := 1 to FFieldList.Count do
+ InvalidateFieldsRow(RowNum);
+ for RowNum := 1 to pred(grdFields.RowCount) do {!!.06}
+ grdFields.Cells[0, RowNum] := IntToStr(RowNum-1); {!!.06}
+end;
+{--------}
+procedure TfrmTableStruct.InvalidateFieldsRow(const RowNum : Integer);
+var
+ ColNum : Integer;
+begin
+ for ColNum := 0 to Pred(grdFields.ColCount)do
+ with FFieldList.Items[Pred(RowNum)] do
+ case ColNum of
+ cnFldName:
+ grdFields.Cells[ColNum,RowNum] := Name;
+ cnFldType:
+ grdFields.Cells[ColNum,RowNum] := cboFieldType.Items.Strings[fiDataTypeIndex];
+ cnFldUnits:
+ grdFields.Cells[ColNum,RowNum] := IntToStr(fiUnits);
+ cnFldDecPl:
+ grdFields.Cells[ColNum,RowNum] := IntToStr(fiDecPlaces);
+ cnFldDefault:
+ begin
+ if fiValCheck.vdHasDefVal then begin
+ grdFields.Cells[ColNum, RowNum] := {!!.06}
+ FFVCheckValToString(fiValCheck.vdDefVal,
+ FFEIndexToFieldType(fiDataTypeIndex));
+ end else
+ grdFields.Cells[ColNum,RowNum] := '';
+ end;
+ cnFldDesc:
+ grdFields.Cells[ColNum,RowNum] := fiDescription;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.EnableBLOBControls;
+begin
+ lblBLOBExtension.Enabled := radBLOBExternal.Checked;
+ edtBLOBExtension.Enabled := radBLOBExternal.Checked;
+
+ lblBLOBBlockSize.Enabled := radBLOBExternal.Checked;
+ cboBLOBBlockSize.Enabled := radBLOBExternal.Checked;
+
+ lblBLOBFileDesc.Enabled := radBLOBExternal.Checked;
+ edtBLOBFileDesc.Enabled := radBLOBExternal.Checked;
+end;
+{--------}
+procedure TfrmTableStruct.EnableFieldControls(aRowNum: LongInt);
+begin
+ if (aRowNum > 0) and (aRowNum <= FFieldList.Count) then begin
+ btnInsertField.Enabled := FFieldList.Items[aRowNum - 1].Name <> '';
+ btnDeleteField.Enabled := aRowNum <> grdFields.RowCount - 1;
+ btnMoveFieldUp.Enabled := (aRowNum <> grdFields.RowCount - 1) and (aRowNum <> 1);
+ btnMoveFieldDown.Enabled := aRowNum < grdFields.RowCount - 2;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.LeavingFieldsCell(const Col, Row: LongInt);
+{ Store new data info FFieldList; Update the interface before the
+ Cell is changed}
+var
+ i, j : Integer;
+ TempStr : string[255];
+ TempInt : Longint;
+(* TempExtend : Extended;
+ TempCurrency: Currency;
+ TempSingle : Single;
+ TempDouble : Double;
+ TempStDate : TStDate;
+ TempStTime : TStTime;
+ TempDT : TDateTime;
+ TempTS : TTimeStamp;
+ TempComp : Comp;
+ TempWideStr : WideString;*)
+begin
+ if FFieldList.Count > (Row - 1) then
+ with FFieldList.Items[Row - 1] do
+ case Col of
+ cnFldName:
+ begin
+ TempStr := Name;
+ Name := grdFields.Cells[Col, Row];
+ {rename fields in indexes}
+ if TempStr <> '' then
+ for I := 0 to Pred(FIndexList.Count) do
+ for J := 0 to Pred(FIndexList.Items[I].FieldCount) do
+ if FIndexList.Items[I].FieldName[j] = TempStr then
+ FIndexList.Items[I].FieldName[j] := Name;
+
+ if Row = Pred(grdFields.RowCount) then
+ { If we've added a name in the empty row,
+ add a new empty row to the list }
+ if (FDialogMode in [dmRestructuring, dmCreating]) and {Start !!.01}
+ (Name <> '') then begin
+ FFieldList.AddEmpty;
+ InvalidateFieldsTable;
+ end; {End !!.01}
+
+ { Set the default datatype }
+ if (fiDataTypeIndex = -1) and (Row > 1) then begin
+ fiDataTypeIndex := FFieldList.Items[Row - 2].fiDataTypeIndex;
+ if FFEIndexToFieldType(fiDataTypeIndex) >= fftByteArray then
+ fiUnits := FFieldList.Items[Row - 2].fiUnits;
+ end else
+ if (fiDataTypeIndex = -1) then begin
+ fiDataTypeIndex := 9;
+ if FFEIndexToFieldType(fiDataTypeIndex) >= fftByteArray then
+ fiUnits := FFieldList.Items[Row - 2].fiUnits;
+ end;
+ end;
+
+ cnFldType:
+ begin
+ TempInt := fiDataTypeIndex;
+ fiDataTypeIndex := cboFieldType.Items.IndexOf(grdFields.Cells[Col, Row]);
+ if TempInt <> fiDataTypeIndex then begin
+ fiValCheck.vdHasDefVal := False;
+ FillChar(fiValCheck.vdDefVal, SizeOf(fiValCheck.vdDefVal), #0);
+ end;
+ end;
+
+ cnFldUnits:
+ begin
+ TempInt := fiUnits;
+ fiUnits := StrToInt('0' + grdFields.Cells[Col, Row]);
+ {Clear the default value if it is longer than the new
+ Units value.}
+ // Move(fiValCheck, TempStr, ffMaxL(fiUnits, TempInt));
+ if (fiUnits < TempInt) {and
+ (Length(AnsiString(TempStr)) > fiUnits))} then begin
+ fiValCheck.vdHasDefVal := False;
+ FillChar(fiValCheck.vdDefVal, SizeOf(fiValCheck.vdDefVal), #0);
+ end;
+ end;
+
+ cnFldDecPl:
+ begin
+ fiDecPlaces := StrToInt('0' + grdFields.Cells[Col, Row]);
+ if fiDataTypeIndex <> -1 then
+ CalcActualValues;
+ end;
+
+ cnFldDefault:
+ begin
+ if grdFields.Cells[Col, Row] <> '' then begin
+ FFStringToVCheckVal(grdFields.Cells[Col, Row], {!!.06}
+ FFEIndexToFieldType(fiDataTypeIndex),
+ fiValCheck.vdDefVal);
+ fiValCheck.vdHasDefVal := True;
+ end else
+ fiValCheck.vdHasDefVal := False;
+ end;
+
+ cnFldDesc:
+ fiDescription := grdFields.Cells[Col, Row];
+
+ end;
+ InvalidateFieldsRow(grdFields.Row);
+ grdFields.Invalidate;
+end;
+
+{=====Index grid routines=====}
+procedure TfrmTableStruct.InitializeIndexGrid;
+begin
+ grdIndexes.ColCount := cnIdxHighest + 1;
+ grdIndexes.RowCount := 2;
+
+ grdIndexes.ColWidths[cnIdxNumber] := 25;
+ grdIndexes.ColWidths[cnIdxName] := 110;
+ grdIndexes.ColWidths[cnIdxType] := 50;
+ grdIndexes.ColWidths[cnIdxKeyLength] := 50;
+ grdIndexes.ColWidths[cnIdxUnique] := 42;
+ grdIndexes.ColWidths[cnIdxAscending] := 42;
+ grdIndexes.ColWidths[cnIdxCaseSensitive] := 38;
+ grdIndexes.ColWidths[cnIdxExt] := 40;
+ grdIndexes.ColWidths[cnIdxBlockSize] := 60;
+ grdIndexes.ColWidths[cnIdxDesc] := 250;
+
+ grdIndexes.DefaultRowHeight := cboIndexType.Height;
+
+
+ FFEConfigGetColumnPrefs(ClassName + '.IndexGrid', grdIndexes);
+
+ chkAvailFieldsSorted.Checked := Config.SortAvailIndexFields;
+ lstAvailFields.Sorted := chkAvailFieldsSorted.Checked;
+ PopulateIndexGridHeader;
+end;
+{--------}
+procedure TfrmTableStruct.PopulateIndexGridHeader;
+var
+ ColNum : Integer;
+begin
+ grdIndexes.BeginUpdate;
+ try
+ for ColNum := 0 to cnIdxHighest do
+ case ColNum of
+ cnIdxNumber : grdIndexes.Cells[ColNum, 0] := cnsNumber;
+ cnIdxName : grdIndexes.Cells[ColNum, 0] := cnsName;
+ cnIdxType : grdIndexes.Cells[ColNum, 0] := cnsType;
+ cnIdxKeyLength : grdIndexes.Cells[ColNum, 0] := cnsKeyLen;
+ cnIdxUnique : grdIndexes.Cells[ColNum, 0] := cnsUnique;
+ cnIdxAscending : grdIndexes.Cells[ColNum, 0] := cnsAscend;
+ cnIdxCaseSensitive : grdIndexes.Cells[ColNum, 0] := cnsCaseSens;
+ cnIdxExt : grdIndexes.Cells[ColNum, 0] := cnsExt;
+ cnIdxBlockSize : grdIndexes.Cells[ColNum, 0] := cnsBlockSize;
+ cnIdxDesc : grdIndexes.Cells[ColNum, 0] := cnsDesc;
+ end;
+ finally
+ grdIndexes.EndUpdate;
+ end;
+end;
+
+procedure TfrmTableStruct.PopulateIndexFieldsLists(aIndex: LongInt);
+var
+ I: Integer;
+ IndexSelected : boolean;
+begin
+ if aIndex <= Pred(FIndexList.Count) then begin
+ case FDialogMode of
+ dmViewing, dmCreating :
+ IndexSelected := (aIndex < FIndexList.Count) and (aIndex >= 0);
+ else
+ IndexSelected := (aIndex < Pred(FIndexList.Count)) and (aIndex >= 0);
+ end;
+
+ with FIndexList.Items[aIndex] do begin
+ if Name = '' then
+ grpCompositeKey.Caption := ' Composite Key '
+ else
+ grpCompositeKey.Caption := ' Composite Key (' + Name + ') ';
+
+ { Show fields defined for the current index }
+ lstIndexFields.Clear;
+ if IndexSelected then begin
+ lstIndexFields.Items.BeginUpdate;
+ try
+ for I := 0 to FieldCount - 1 do
+ lstIndexFields.Items.Add(FieldName[I]);
+ finally
+ lstIndexFields.Items.EndUpdate;
+ end;
+ end;
+ end;
+
+ { Show fields remaining in the table eligible to become part of the index }
+ with lstAvailFields do begin
+ Items.BeginUpdate;
+ try
+ Clear;
+ for I := 0 to FFieldList.Count - 1 do
+ with FFieldList.Items[I] do
+ if (Name <> '') and
+ { ByteArray and BLOB type scan't be in keys }
+ not (FieldType in [fftByteArray, fftBLOB..ffcLastBLOBType]) and
+ { Field already in index list }
+ (lstIndexFields.Items.IndexOf(Name) = -1) then
+ Items.Add(Name);
+ finally
+ Items.EndUpdate;
+ end;
+ end;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.InvalidateIndexesTable;
+var
+ RowNum: Integer;
+begin
+ if FIndexList.Count = 0 then
+ grdIndexes.RowCount := 2
+ else
+ grdIndexes.RowCount := succ(FIndexList.Count);
+ for RowNum := 1 to FIndexList.Count do
+ InvalidateIndexesRow(RowNum);
+ for RowNum := 1 to Pred(grdIndexes.RowCount) do {!!.06}
+ grdIndexes.Cells[0, RowNum] := IntToStr(RowNum-1); {!!.06}
+end;
+{--------}
+procedure TfrmTableStruct.InvalidateIndexesRow(const RowNum: Integer);
+var
+ ColNum : LongInt;
+begin
+(* if grdIndexes.Row <> RowNum then begin {begin !!.06}
+ with FIndexList.Items[RowNum - 1] do
+ if (Name <> '') and
+ (iiKeyTypeIndex = ktComposite) and
+ (FieldCount = 0) then
+ raise Exception.Create('No fields defined for composite index');
+ end; *) {end !!.06}
+
+ with grdIndexes do
+ for ColNum := 0 to Pred(ColCount)do
+ with FIndexList.Items[Pred(RowNum)] do
+ case ColNum of
+ cnIdxName : Cells[ColNum, RowNum] := Name;
+ cnIdxType : Cells[ColNum, RowNum] := cboIndexType.Items.Strings[iiKeyTypeIndex];
+ cnIdxKeyLength : Cells[ColNum, RowNum] := IntToStr(iiKeyLen);
+ cnIdxExt : Cells[ColNum, RowNum] := iiExtension;
+ cnIdxBlockSize : Cells[ColNum, RowNum] := cboBlockSize.Items.Strings[iiBlockSizeIndex];
+ cnIdxDesc : Cells[ColNum, RowNum] := iiDescription;
+ end;
+end;
+
+function TfrmTableStruct.CalcKeyLength(aIndex: Integer): Integer;
+var
+ I, J: Integer;
+begin
+ Result := 0;
+ with FIndexList.Items[aIndex] do begin
+ for I := 0 to FieldCount - 1 do
+ with FFieldList do begin
+ J := IndexOf(FieldName[I]);
+ if J <> -1 then begin
+ Inc(Result, Items[J].fiSize);
+ Inc(Result);
+ end;
+ end;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.EnableIndexControls(aRowNum: LongInt; aName: string);
+var
+ Switch: Boolean;
+begin
+ if aRowNum = 0 then
+ Exit;
+
+ if (aRowNum > 0) and (aRowNum <= FIndexList.Count) then
+ btnDeleteIndex.Enabled := aRowNum <> grdIndexes.RowCount - 1;
+
+ with FIndexList.Items[aRowNum - 1] do begin
+ { We only enable the key controls when it's a composite key,
+ we're in edit mode, and we are focused on a valid index. }
+ if aName = '' then aName := Name;
+ Switch := (iiKeyTypeIndex = ktComposite) and
+ (aName <> '') and
+ (FDialogMode in [dmCreating, dmRestructuring]);
+
+ if grpCompositeKey.Enabled <> Switch then
+ FFEEnableContainer(grpCompositeKey, Switch);
+ end;
+end;
+
+
+{=====Fieldmap routines=====}
+procedure TfrmTableStruct.InvalidateFieldMapRow(const RowNum: Integer);
+var
+ ThisFieldType: TffFieldType;
+ ColNum: Integer;
+begin
+ with FFieldList.Items[Pred(RowNum)] do
+ if Name <> '' then
+ for ColNum := 0 to Pred(cnMapHighest) do
+ case ColNum of
+ cnMapFieldName: grdFieldMap.Cells[ColNum, RowNum] := Name;
+ cnMapDatatype:
+ begin
+ ThisFieldType := FFEIndexToFieldType(fiDataTypeIndex);
+ FTempStr := FieldDataTypes[ThisFieldType];
+ if ThisFieldType >= fftByteArray then
+ FTemPStr := Format('%s[%d]', [FTempStr, fiUnits]);
+ grdFieldMap.Cells[ColNum, RowNum] := FTempStr;
+ end;
+ cnMapOldField:
+ begin
+ RetrieveFieldMapSettings(RowNum, FFieldMapComboRec.Index, FFieldMapComboRec.RTItems);
+ grdFieldMap.Cells[ColNum, RowNum] := FFieldMapComboRec.RTItems[FFieldMapComboRec.Index];
+ end;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.InvalidateFieldMapTable;
+var
+ RowNum: Integer;
+begin
+ grdFieldMap.RowCount := FFieldList.Count;
+ for RowNum := 1 to FFieldList.Count do
+ InvalidateFieldMapRow(RowNum);
+end;
+
+
+{=====Fieldgrid validation routines=====}
+function TfrmTableStruct.FieldNameValidation(const AName: string;
+ var ErrorCode: Word): Boolean;
+var
+ FieldName: TffDictItemName;
+ I: LongInt;
+
+begin
+ FieldName := FFShStrTrim(AName);
+ if FieldName <> '' then begin
+ I := FFieldList.IndexOf(FieldName);
+ if (I <> -1) and (I <> grdFields.Row - 1) then begin
+ ErrorCode := oeDuplicateFieldName;
+ Result := False;
+ Exit;
+ end;
+ end;
+
+ with grdFields do
+ if (FieldName = '') and (Row <> RowCount - 1) then begin
+ ErrorCode := oeMissingFieldName;
+ Result := False;
+ Exit;
+ end;
+
+ ErrorCode := 0;
+ Result := True;
+end;
+{--------}
+function TfrmTableStruct.FieldLengthValidation(const ALength: string;
+ var ErrorCode: Word): Boolean;
+begin
+ if not ValidateFieldUnits(StrToInt('0' + ALength), grdFields.Row - 1) then begin
+ ErrorCode := oeInvalidFieldUnits;
+ Result := False;
+ Exit;
+ end;
+
+ ErrorCode := 0;
+ Result := True;
+end;
+{--------}
+function TfrmTableStruct.ValidateFieldUnits(aUnits, aFieldNum: Integer): Boolean;
+begin
+ case FFEIndexToFieldType(FFieldList.Items[aFieldNum].fiDataTypeIndex) of
+ fftShortString,
+ fftShortAnsiStr:
+ Result := (aUnits > 0) and (aUnits < 256);
+ fftByteArray,
+ fftNullString,
+ fftNullAnsiStr,
+ fftWideString:
+ Result := (aUnits > 0) and (aUnits <= dsMaxStringSize); {!!.06}
+ else
+ Result := True;
+ end;
+end;
+
+
+{=====Indexgrid validation routines=====}
+function TfrmTableStruct.IndexNameValidation(const AName: string;
+ var ErrorCode: Word): Boolean;
+var
+ IndexName: TffDictItemName;
+ I: LongInt;
+begin
+ IndexName := FFShStrTrim(AName);
+ if IndexName <> '' then begin
+ I := FIndexList.IndexOf(IndexName);
+ if (I <> -1) and (I <> grdIndexes.Row - 1) then begin
+ ErrorCode := oeDuplicateIndexName;
+ Result := False;
+ Exit;
+ end;
+ end;
+
+ with grdIndexes do
+ if (IndexName = '') and (Row <> RowCount - 1) then begin
+ ErrorCode := oeMissingIndexName;
+ Result := False;
+ Exit;
+ end;
+
+ ErrorCode := 0;
+ Result := True;
+end;
+{--------}
+function TfrmTableStruct.IndexExtensionValidation(const AExtension: string;
+ var ErrorCode: Word): Boolean;
+var
+ ThisExtension: TffExtension;
+ Idx : Integer; {!!.06}
+begin
+ ThisExtension := FFShStrTrim(AExtension);
+ if ThisExtension <> '' then begin
+
+ { Can't match the data file }
+ if (FFAnsiCompareText(ThisExtension, ffc_ExtForData)=0) or {!!.06}{!!.07}
+ (FFAnsiCompareText(ThisExtension, ffc_ExtForTrans)=0) or {!!.06}{!!.07}
+ (FFAnsiCompareText(ThisExtension, ffc_ExtForSQL)=0) then begin {!!.06}{!!.07}
+ ErrorCode := oeInvalidFileExtension;
+ Result := False;
+ Exit;
+ end;
+
+ { See if there's a conflict with the BLOB extension (if any) }
+ if radBLOBExternal.Checked and
+ (FFAnsiCompareText(ThisExtension, edtBLOBExtension.Text)=0) then begin {!!.06}{!!.07}
+ ErrorCode := oeDuplicateFileExtension;
+ Result := False;
+ Exit;
+ end;
+
+ { See if there's a conflict with other index extensions (if any) } {begin !!.06}
+ for Idx := 0 to Pred(FIndexList.Count) do begin
+ if Idx = grdIndexes.Row - 1 then
+ continue;
+ if FFAnsiCompareText(ThisExtension, FIndexList.Items[Idx].iiExtension) = 0 then begin {!!.07}
+ ErrorCode := oeDuplicateFileExtension;
+ Result := False;
+ Exit;
+ end;
+ end; {end !!.06}
+ end;
+
+ ErrorCode := 0;
+ Result := True;
+end;
+{--------}
+function TfrmTableStruct.IndexKeyLenValidation(const AKeyLen: Integer;
+ var ErrorCode: Word): Boolean;
+begin
+(* with grdIndexes do
+ case FIndexList.Items[Row - 1].iiKeyTypeIndex of
+ ktUserDefined:
+ if IntToStr('0' +TOvcNumericField(Sender).AsInteger = 0 then
+ ErrorCode := oeInvalidIndexKeyLength;
+ end;
+ if TOvcNumericField(Sender).AsInteger > ffcl_MaxKeyLength then
+ ErrorCode := oeMaximumIndexKeyLength;*)
+ ErrorCode := 0;
+ Result := True;
+end;
+
+
+{=====Misc validation routines}
+{--------}
+function TfrmTableStruct.edtBLOBExtensionValidation(const AExtension: string;
+ var ErrorCode: Word): Boolean;
+var
+ ThisExtension: TffExtension;
+ I: Integer;
+begin
+ ThisExtension := FFShStrTrim(AExtension);
+ if ThisExtension <> '' then begin
+
+ { Can't match the data file } {begin !!.06, !!.07}
+ if (FFAnsiCompareText(ThisExtension, ffc_ExtForData)=0) or
+ (FFAnsiCompareText(ThisExtension, ffc_ExtForTrans)=0) or
+ (FFAnsiCompareText(ThisExtension, ffc_ExtForSQL)=0) then begin
+ ErrorCode := oeInvalidFileExtension;
+ Result := False;
+ Exit;
+ end; {end !!.06, !!.07}
+
+ { See if this extension is being used for any index files }
+ for I := 0 to FIndexList.Count - 1 do
+ with FIndexList.Items[I] do begin
+ if (Name <> '') and
+ (I <> grdIndexes.Row - 1) and
+ (iiExtension = ThisExtension) then begin
+ ErrorCode := oeDuplicateFileExtension;
+ Result := False;
+ Exit;
+ end;
+ end;
+ end;
+ ErrorCode := 0;
+ Result := True;
+end;
+{--------}
+function TfrmTableStruct.ValidateRestructure: Boolean;
+begin
+ { Auto-assign field map }
+ if tabStructure.Pages[tabStructure.PageCount-1].Enabled and
+ chkPreserveData.Checked and
+ (FFieldMap.Count = 0) then begin
+ btnMatchByNameClick(nil);
+ if (FDatabase.Tables[FTableIndex].RecordCount > 0) and {!!.06}
+ (FFieldMap.Count <> FDatabase.Tables[FTableIndex].Dictionary.FieldCount) then begin
+ Result := not (MessageDlg('Some data may be lost. Would you like to ' +
+ 'verify the field mappings?', mtWarning,
+ [mbYes, mbNo], 0) = mrYes);
+ if not Result then
+ tabStructure.ActivePage := tbsExistingData;
+ Exit;
+ end;
+ end;
+
+ with tabStructure do
+ if (FDatabase.Tables[FTableIndex].RecordCount > 0) and {!!.06}
+ (not chkPreserveData.Checked or (FFieldMap.Count = 0)) and
+ Pages[PageCount - 1].Enabled then begin
+ Result := MessageDlg('Restructure without preserving existing data?', mtWarning, [mbYes, mbNo], 0) = mrYes;
+ Exit;
+ end;
+
+ Result := True;
+end;
+{--------}
+procedure TfrmTableStruct.DisplayValidationError(ErrorCode: Word);
+begin
+ case ErrorCode of
+ oeDuplicateFieldName:
+ MessageDlg('A field with this name already exists.', mtError, [mbOk], 0);
+ oeInvalidFieldName:
+ MessageDlg('Invalid field name.', mtError, [mbOk], 0);
+ oeMissingFieldName:
+ MessageDlg('A field name is required here.', mtError, [mbOk], 0);
+ oeDuplicateIndexName:
+ MessageDlg('An index with this name already exists.', mtError, [mbOk], 0);
+ oeInvalidIndexName:
+ MessageDlg('Invalid index name.', mtError, [mbOk], 0);
+ oeMissingIndexName:
+ MessageDlg('An index name is required here.', mtError, [mbOk], 0);
+ oeDuplicateFileExtension:
+ MessageDlg('This file extension has already been used.', mtError, [mbOk], 0);
+ oeInvalidFileExtension:
+ MessageDlg('Invalid file extension.', mtError, [mbOk], 0);
+ oeInvalidFieldUnits:
+ MessageDlg('Invalid units for this data type', mtError, [mbOK], 0);
+ oeInvalidIndexKeyLength:
+ MessageDlg('Must supply index key length for user-defined indexes', mtError, [mbOK], 0);
+ oeMaximumIndexKeyLength:
+ MessageDlg(Format('Index key length cannot exceed %d', [ffcl_MaxKeyLength]), mtError, [mbOK], 0);
+ end;
+end;
+{--------}
+function TfrmTableStruct.ValidateForm: Boolean;
+var
+ I: Integer;
+begin
+ if not edtTableName.ReadOnly then begin
+ if edtTableName.Text = '' then begin
+ edtTableName.SetFocus;
+ raise Exception.Create('Invalid table name');
+ end;
+ end;
+
+ { Make sure we have a correct block size }
+ if not FFVerifyBlockSize(StrToInt(cboBlockSize.Text)) then begin
+ cboBlockSize.SetFocus;
+ raise Exception.Create('Invalid block size');
+ end;
+
+ { Make sure the field list is valid }
+ { needs to be expanded}
+ for I := 0 to FFieldList.Count - 1 do
+ with FFieldList.Items[I] do begin
+ if not ((Name = '') and (I = FFieldList.Count - 1)) then begin
+ if Name = '' then begin
+ with grdFields do begin
+ Row := I + FixedRows;
+ Col := cnFldName;
+ end;
+ raise Exception.Create('Invalid field name');
+ end;
+
+ if fiDataTypeIndex = -1 then begin
+ with grdFields do begin
+ Row := I + FixedRows;
+ Col := cnFldType;
+ end;
+ raise Exception.Create('Invalid data type');
+ end;
+
+ if not ValidateFieldUnits(fiUnits, I) then begin
+ with grdFields do begin
+ Row := I + FixedRows;
+ Col := cnFldUnits;
+ end;
+ raise Exception.Create('Invalid units for this data type');
+ end;
+ end;
+ end;
+
+ { make sure the composite indexes have fields } {begin !!.06}
+ for I := 0 to Pred(FIndexList.Count) do
+ if (FIndexList.Items[I].Name <> '') and
+ (FIndexList.Items[I].iiKeyTypeIndex = ktComposite) and
+ (FIndexList.Items[I].FieldCount = 0) then
+ raise Exception.CreateFmt
+ ('No fields defined for composite index: %s',
+ [FIndexList.Items[I].Name]); {end !!.06}
+
+ Result := True;
+end;
+{--------}
+procedure TfrmTableStruct.grdFieldsExit(Sender: TObject);
+begin
+ LeavingFieldsCell(grdFields.Col, grdFields.Row);
+end;
+{--------}
+procedure TfrmTableStruct.InitializeFieldMapGrid;
+begin
+ grdFieldMap.ColCount := cnMapHighest;
+ grdFieldMap.RowCount := 2;
+
+ grdFieldMap.ColWidths[cnMapFieldName] := 135;
+ grdFieldMap.ColWidths[cnMapDatatype] := 120;
+ grdFieldMap.ColWidths[cnMapOldField] := 203;
+
+ grdFieldMap.DefaultRowHeight := cboMapOldField.Height;
+
+ PopulateFieldMapHeader;
+end;
+{--------}
+procedure TfrmTableStruct.PopulateFieldMapHeader;
+var
+ ColNum: Integer;
+begin
+ with grdFieldMap do begin
+ BeginUpdate;
+ try
+ for ColNum := 0 to cnMapHighest do
+ case ColNum of
+ cnMapFieldName : Cells[ColNum, 0] := 'New Field Name';
+ cnMapDatatype : Cells[ColNum, 0] := 'Data Type';
+ cnMapOldField : Cells[ColNum, 0] := 'Old Field';
+ end;
+ finally
+ EndUpdate;
+ end;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.grdFieldMapKeyPress(Sender: TObject;
+ var Key: Char);
+begin
+ if Key = #13 then
+ { Change the selected cell (Enter as tab)}
+ with grdFieldMap do
+ if Col < Pred(ColCount) then
+ Col := Col + 1
+ else if Row < Pred(RowCount) then begin
+ Row := Row + 1;
+ Col := cnFldName;
+ end else begin
+ Row := 1;
+ Col := cnFldName;
+ end
+end;
+{--------}
+procedure TfrmTableStruct.grdFieldMapSelectCell(Sender: TObject; ACol,
+ ARow: Integer; var CanSelect: Boolean);
+var
+ R: TRect;
+ Idx : Integer;
+begin
+ CanSelect := True;
+
+ { Set any special cell attributes (ComboBoxes, Readonly fields)}
+ case ACol of
+ cnMapOldField:
+ begin
+ R := grdFieldMap.CellRect(ACol, ARow);
+ ShowCellCombo(cboMapOldField, grdFieldMap, R);
+// Idx := cboMapOldField.ItemIndex; - Idx only used to return value below
+ RetrieveFieldMapSettings(ARow, Idx, cboMapOldField.Items);
+ cboMapOldField.ItemIndex := Idx;
+ end;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.cboMapOldFieldChange(Sender: TObject);
+begin
+ with grdFieldMap do begin
+ Cells[Col, Row] := TComboBox(Sender).Items[TComboBox(Sender).ItemIndex];
+ end;
+ tcMapOldFieldChange(Sender);
+ grdFieldMap.Invalidate;
+end;
+{--------}
+procedure TfrmTableStruct.cboMapOldFieldExit(Sender: TObject);
+begin
+ TComboBox(Sender).Visible := False;
+ FcboMapOldFieldHasBeenFocused := ActiveControl=grdFieldMap; {!!.11}
+ { only if Enter key was pressed }
+ if FInEnterKeyPressed then {!!.11}
+ if Assigned(ActiveControl) and not(ActiveControl = grdFieldMap) then
+ ActiveControl.SetFocus
+ else begin
+ grdFieldMap.SetFocus;
+ grdFieldMap.Perform(WM_KEYDOWN, VK_TAB, 0);
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.RetrieveFieldMapSettings(const ARow : integer;
+ var Index: Integer;
+ AStrings: TStrings);
+var
+ I, J: Integer;
+ OldFieldName: TffDictItemName;
+ CurrentFieldName: TffDictItemName;
+ Disqualified: Boolean;
+ DisplayDatatype: TffShStr;
+ {Begin !!.11}
+ CreateReverseFFieldMap: Boolean;
+ IndexOfOldFieldName: Integer;
+
+ { "missing" method in TStringList for optimized finding of Name part;
+ IndexOfName iterates through the whole stringlist }
+ function StringListFindFirst(Strings: TStringList; const S: string; var Index: Integer): Boolean;
+ var
+ L, H, I, C: Integer;
+ begin
+ Result := False;
+ L := 0;
+ H := Strings.Count - 1;
+ while L <= H do
+ begin
+ I := (L + H) shr 1;
+ C := AnsiStrLIComp(PChar(Strings[I]), PChar(S), Length(S));
+ if C < 0 then L := I + 1 else
+ begin
+ H := I - 1;
+ if C = 0 then
+ begin
+ Result := True;
+ if Strings.Duplicates <> dupAccept then L := I;
+ end;
+ end;
+ end;
+ Index := L;
+ end;
+ {End !!.11}
+
+begin
+ with FFieldList.Items[Pred(ARow)] do begin
+ CurrentFieldName := Name; { from FFieldList.Items[x] }
+
+ { Fill the combo box dropdown list with all old fields that are
+ a) assignment compatible with the current new field and
+ b) not already assigned to another new field. }
+ with AStrings do begin
+ Clear;
+ BeginUpdate;
+ {Begin !!.11}
+ CreateReverseFFieldMap := not Assigned(ReverseFFieldMap);
+ if CreateReverseFFieldMap then
+ ReverseFFieldMap := TStringList.Create;
+ {End !!.11}
+
+ try
+ {Begin !!.11}
+ if CreateReverseFFieldMap then
+ for i := 0 to Pred(FFieldMap.Count) do
+ ReverseFFieldMap.Values[FFieldMap.Values[FFieldMap.Names[i]]] := FFieldMap.Names[i];
+ ReverseFFieldMap.Sorted := True;
+ {End !!.11}
+ Add('');
+ with FDatabase.Tables[FTableIndex].Dictionary do begin
+ for I := 0 to FieldCount - 1 do begin
+ OldFieldName := FieldName[I];
+
+ { Check assignment compatability }
+ Disqualified := FFConvertSingleField(
+ nil,
+ nil,
+ FieldType[I],
+ FFEIndexToFieldType(fiDatatypeIndex),
+ -1,
+ -1) <> DBIERR_NONE;
+
+ { Already assigned to another new field?
+ (make sure to skip the current field) }
+ if not Disqualified then begin
+
+(* this loop has been optimized away. without the optimization,
+ entering the "existing data" tab of a table with some
+ hundred fields would take several minutes.
+ Instead of potentially looping through the whole fieldmap
+ list of strings for each row, we now build a list with the
+ names and values reversed which is used during the entire
+ populate procedure of the grid. With the added binary-search
+ enabled lookup function this works out to reduce the time spent
+ populating from 30 seconds to 1 second for a 200-field table.
+
+ for J := 0 to FFieldMap.Count - 1 do
+ if Pos(#255 + CurrentFieldName + '=', #255 + FFieldMap[J]) = 0 then
+ if Pos('=' + OldFieldName + #255, FFieldMap[J] + #255) <> 0 then begin
+ Disqualified := True;
+ Break;
+ end;*)
+ if StringListFindFirst(ReverseFFieldMap, OldFieldName+'=', IndexOfOldFieldName) and
+ (ReverseFFieldMap[IndexOfOldFieldName]<>OldFieldName+'='+CurrentFieldName) then
+ Disqualified := True;
+ end; { if }
+
+ if Disqualified then Continue;
+
+ { If OK, then add it to the list }
+ if FieldType[I] >= fftByteArray then
+ DisplayDatatype := Format('(%s[%d])', [FieldDataTypes[FieldType[I]], FieldUnits[I]])
+ else
+ DisplayDatatype := Format('(%s)', [FieldDataTypes[FieldType[I]]]);
+ Add(FieldName[I] + ' ' + DisplayDatatype);
+ end; { for }
+ end; { with }
+ finally
+ EndUpdate;
+ {Begin !!.11}
+ if CreateReverseFFieldMap then begin
+ ReverseFFieldMap.Free;
+ ReverseFFieldMap := nil;
+ end;
+ {End !!.11}
+ end;
+ end;
+
+ { See if we already have an assignment for the current field,
+ and if so set the combo box index value accordingly }
+ with AStrings do begin
+ Index := 0;
+ OldFieldName := FFieldMap.Values[CurrentFieldName];
+ if OldFieldName <> '' then begin
+ for J := 0 to Count - 1 do
+ if Pos(AnsiUpperCase(OldFieldName + ' ('), AnsiUpperCase(Strings[J])) <> 0 then begin
+ Index := J;
+ Break;
+ end; { if }
+ end; { if }
+ end; { with }
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.tabStructureChange(Sender: TObject);
+begin
+ case tabStructure.ActivePage.PageIndex of
+ 1: begin
+ PopulateIndexFieldsLists(grdIndexes.Row - 1);
+ end;
+ 2: begin
+ grdFieldMap.RowCount := FFieldList.Count;
+
+ { Auto-assign the field map }
+ if FFieldMap.Count = 0 then
+ btnMatchByNameClick(Sender);
+ end;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.LeavingIndexCell(const Col, Row: Integer);
+{ Store new data info FFieldList; Update the interface before the
+ Cell is changed}
+begin
+ if Row < 1 then
+ Exit;
+
+ with FIndexList.Items[Row - 1] do
+ case Col of
+ cnIdxName:
+ begin
+ Name := grdIndexes.Cells[Col, Row];
+ if Row = Pred(grdIndexes.RowCount) then
+ { If we've added a name in the empty row,
+ add a new empty row to the list }
+ if FDialogMode in [dmRestructuring, dmCreating] then
+ FIndexList.AddEmpty;
+ if Name <> '' then begin
+ InvalidateIndexesTable;
+ end;
+ end;
+
+ cnIdxType:
+ iiKeyTypeIndex := cboIndexType.Items.IndexOf(grdIndexes.Cells[Col, Row]);
+
+ cnIdxKeyLength:
+ iiKeyLen := StrToInt('0' + grdIndexes.Cells[Col, Row]);
+
+ cnIdxExt:
+ iiExtension := grdIndexes.Cells[Col, Row];
+
+ cnIdxBlockSize:
+ iiBlockSizeIndex := cboIndexBlockSize.Items.IndexOf(grdIndexes.Cells[Col, Row]);
+
+ cnIdxDesc:
+ iiDescription := grdIndexes.Cells[Col, Row];
+ end;
+ InvalidateIndexesRow(grdIndexes.Row);
+ grdIndexes.Invalidate;
+end;
+{--------}
+procedure TfrmTableStruct.grdIndexesExit(Sender: TObject);
+begin
+ LeavingIndexCell(grdIndexes.Col, grdIndexes.Row);
+end;
+{--------}
+procedure TfrmTableStruct.FormKeyPress(Sender: TObject; var Key: Char);
+begin
+ FHasChanged := True;
+end;
+{--------}
+procedure TfrmTableStruct.lstAvailFieldsDblClick(Sender: TObject);
+begin
+ if FDialogMode <> dmViewing then
+ AddFieldToIndex;
+end;
+{--------}
+procedure TfrmTableStruct.lstIndexFieldsDblClick(Sender: TObject);
+begin
+ if FDialogMode <> dmViewing then
+ RemoveFieldFromIndex;
+end;
+{--------}
+function TfrmTableStruct.AllowDefaultField(aRowNum : Integer;
+ var aErrorCode : Word) : Boolean;
+var
+ FieldType : TffFieldType;
+begin
+ Assert(Assigned(FFieldList.Items[pred(aRowNum)]));
+ Assert(Assigned(grdFields));
+ Assert(grdFields.ColCount > cnFldUnits);
+ Assert(grdFields.RowCount > aRowNum);
+ Result := False;
+ FieldType := FFieldList.Items[pred(aRowNum)].FieldType;
+ {This field type must allow default values}
+ if FFEFieldAllowedDefault(FieldType) then begin
+ Result := True;
+ {if this field type requires units, ensure it's set}
+ if ((FFEFieldTypeRequiresUnits(FieldType)) and
+ (grdFields.Cells[cnFldUnits, aRowNum] = '0' )) then
+ Result := False;
+ end;
+end;
+{--------}
+function TfrmTableStruct.ValidDefaultFieldKey(aUpKey : Char; aFieldType : TffFieldType) : Boolean;
+type
+ CharSet = set of Char;
+const
+ valValidNumber = ['0'..'9'];
+ valValidAlpha = ['A'..'Z'];
+ valValidBoolean = ['T','R','U','E','F','A','L','S'];
+ valValidExponent = ['E']; {!!.10}
+ valValidNegative = ['-'];
+ valValidSpace = [' '];
+ valValidAll = [#8, #9];
+var
+ valValidAMPM : set of Char;
+ valValidDecSep : set of Char;
+ valValidDateSep : set of Char;
+ valValidTimeSep : set of Char;
+ i : Integer;
+begin
+{Begin !!.10}
+ Result := (aUpKey in valValidAll) or
+ (aFieldType in [fftShortString, fftShortAnsiStr, fftNullString,
+ fftNullAnsiStr, fftWideString]);
+ if Result then
+ Exit;
+{End !!.10}
+
+ {Add Local Settings to the valValidAMPM set}
+ valValidAMPM := [];
+ for i := 1 to Length(TimeAMString) do
+ Include(valValidAMPM, UpCase(TimeAMString[i]));
+ for i := 1 to Length(TimePMString) do
+ Include(valValidAMPM, UpCase(TimePMString[i]));
+ valValidDecSep := [];
+ valValidDateSep := [];
+ valValidTimeSep := [];
+ Include(valValidDecSep, UpCase(DecimalSeparator));
+ Include(valValidDateSep, UpCase(DateSeparator));
+ Include(valValidTimeSep, UpCase(TimeSeparator));
+
+ case aFieldType of
+ fftBoolean : Result := aUpKey in valValidBoolean;
+ fftChar,
+ fftWideChar : Result := aUpKey in (valValidNumber + valValidAlpha + valValidSpace);
+ fftByte,
+ fftInt8,
+ fftInt16,
+ fftInt32 : Result := aUpKey in (valValidNumber + valValidNegative);
+
+ fftWord16,
+ fftWord32,
+ fftComp : Result := aUpKey in valValidNumber;
+
+ fftSingle,
+ fftDouble,
+ fftExtended,
+ fftCurrency : Result := aUpKey in (valValidNumber + valValidDecSep + {!!.10}
+ valValidNegative + valValidExponent); {!!.10}
+
+ fftStDate : Result := aUpKey in (valValidNumber + valValidDateSep);
+
+ fftStTime : Result := aUpKey in (valValidNumber + valValidTimeSep + valValidAMPM);
+
+ fftDateTime : Result := aUpKey in (valValidNumber +
+ valValidTimeSep +
+ valValidDateSep + {!!.01}
+ valValidAMPM +
+ valValidSpace);
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.chkAvailFieldsSortedClick(Sender: TObject);
+begin
+ lstAvailFields.Items.BeginUpdate;
+ try
+ lstAvailFields.Sorted := chkAvailFieldsSorted.Checked;
+ PopulateIndexFieldsLists(grdIndexes.Row - 1);
+ finally
+ lstAvailFields.Items.EndUpdate;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.grdIndexesEnterCell(Sender: TffStringGrid; aCol,
+ aRow: Integer; const text: String);
+begin
+ EnableIndexControls(aRow, '');
+end;
+{--------}
+procedure TfrmTableStruct.cboFieldTypeKeyDown(Sender: TObject;
+ var Key: Word; Shift: TShiftState);
+begin
+ if Key = VK_RETURN then begin
+ Key := 0;
+ grdFields.SetFocus;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.cboIndexTypeKeyDown(Sender: TObject;
+ var Key: Word; Shift: TShiftState);
+begin
+ if Key = VK_RETURN then begin
+ Key := 0;
+ grdIndexes.SetFocus;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.cboMapOldFieldKeyDown(Sender: TObject;
+ var Key: Word; Shift: TShiftState);
+begin
+ if Key = VK_RETURN then begin
+ FInEnterKeyPressed := True; {!!.11}
+ try
+ Key := 0;
+ grdFieldMap.SetFocus;
+ finally
+ FInEnterKeyPressed := False; {!!.11}
+ end;
+ end;
+end;
+{--------}
+procedure TfrmTableStruct.tabExistingDataChange(Sender: TObject);
+begin
+ tabFieldMapPageChanged(Sender, 2);
+end;
+{--------}
+procedure TfrmTableStruct.edtBlobExtensionExit(Sender: TObject); {begin !!.06}
+var
+ ErrorCode : Word;
+begin
+ if not edtBLOBExtensionValidation(edtBlobExtension.Text, ErrorCode) then begin
+ DisplayValidationError(ErrorCode);
+ edtBlobExtension.Text := '';
+ end;
+end; {end !!.06}
+{--------}
+{Begin !!.11}
+procedure TfrmTableStruct.FormClose(Sender: TObject;
+ var Action: TCloseAction);
+begin
+{$IFDEF DCC4OrLater}
+ Action := caFree;
+{$ENDIF}
+end;
+{End !!.11}
+
+end.
+
diff --git a/components/flashfiler/sourcelaz/explorer/uReportEngineInterface.pas b/components/flashfiler/sourcelaz/explorer/uReportEngineInterface.pas
new file mode 100644
index 000000000..ec55aa1af
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/uReportEngineInterface.pas
@@ -0,0 +1,112 @@
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * Eivind Bakkestuen
+ * Used with permission.
+ *
+ * Portions created by the Initial Developer are Copyright (C) 2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+unit uReportEngineInterface;
+
+interface
+
+{$I FFDEFINE.INC}
+
+uses
+ ffllbase,
+ ffllprot,
+ ffdb;
+
+type
+ TRangeFieldValues = Array[0..Pred(ffcl_MaxIndexFlds)] of Variant;
+
+var
+ ReportEngineDLLLoaded : Boolean;
+
+{ take care to ensure that the method declarations here and
+ in the reportengine DLL match! }
+
+ SingleTableReport : procedure(aProtocol : TffProtocolType;
+ aServerName : TffNetAddress;
+ aUserName,
+ aPassword : TffName;
+ aAliasName : PChar;
+ aTableName : TffTableName;
+ aFilter,
+ aIndexName : PChar;
+ aRangeStart,
+ aRangeEnd : TRangeFieldValues);
+
+ SingleQueryReport : procedure(aProtocol : TffProtocolType;
+ aServerName : TffNetAddress;
+ aUserName,
+ aPassword : TffName;
+ aAliasName : PChar;
+ aSQL,
+ aFilter : PChar);
+
+
+ DesignReport : procedure(aProtocol : TffProtocolType;
+ aServerName : TffNetAddress;
+ aUserName,
+ aPassword : TffName;
+ aAliasName : PChar);
+
+implementation
+
+uses
+ Windows,
+ SysUtils,
+ Forms;
+
+var
+ hDLL : THandle;
+
+
+function LoadReportEngineDLL : Boolean;
+var
+ DllPath : String;
+begin
+ Result := False;
+ hDLL := 0;
+ DllPath := ExtractFilePath(Application.ExeName)+'\FFEReportEngine.DLL';
+ if FileExists(DllPath) then begin
+ hDLL := LoadLibrary(PChar(DllPath));
+ if hDLL<>0 then begin
+ @SingleTableReport := GetProcAddress(hDLL, 'SingleTableReport');
+ @SingleQueryReport := GetProcAddress(hDLL, 'SingleQueryReport');
+ @DesignReport := GetProcAddress(hDLL, 'DesignReport');
+ { add new routines above, and tests for NIL below }
+ if (@SingleTableReport<>NIL) and
+ (@SingleQueryReport<>NIL) and
+ (@DesignReport<>NIL) then
+ Result := True;
+ end;
+ end;
+end;
+
+initialization
+ ReportEngineDLLLoaded := LoadReportEngineDLL;
+
+finalization
+ if hDLL<>0 then
+ FreeLibrary(hDLL);
+end.
diff --git a/components/flashfiler/sourcelaz/explorer/ubase.pas b/components/flashfiler/sourcelaz/explorer/ubase.pas
new file mode 100644
index 000000000..9075822da
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/ubase.pas
@@ -0,0 +1,253 @@
+{*********************************************************}
+{* Global data; base classes, defines, functions *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+
+unit ubase;
+
+interface
+
+uses
+ Windows,
+ Classes,
+ Controls,
+ ExtCtrls,
+ StdCtrls,
+ ffdb,
+ ffclreng,
+ ffllbase,
+ fflldict,
+ uentity,
+ uconfig;
+
+type
+ TMenuAction = (maServerAttach,
+ maServerDetach,
+ maDatabaseOpen,
+ maDatabaseClose);
+
+var
+ ClosingApp : Boolean;
+ ServerList : TffeServerList;
+ FieldTypes : array[TffFieldType] of string[20];
+
+function FFEBlockSizeIndex(const aBlockSize: LongInt): Integer;
+
+function FFEBoolToStr(B: Boolean): TffShStr;
+
+procedure FFEEnableContainer(Container: TWinControl; Switch: Boolean);
+
+function FFEFieldAllowedDefault(aFieldType : TffFieldType) : Boolean;
+{ Returns true if the field type is allowed to have a default value.
+ AutoInc, ByteArrays, and Boolean fields are not allowed to have a
+ default value}
+
+function FFEFieldTypeHasDecPl(aFieldType: TffFieldType): Boolean;
+{ Returns true if the given field type has a "decimal places" factor
+ associated with it. For example, currency and float fields. }
+
+function FFEFieldTypeHasUnits(aFieldType: TffFieldType): Boolean;
+{ Returns true if the given field type has a "number of units" factor
+ associated with it. For example, string and character fields. }
+
+function FFEFieldTypeRequiresUnits(aFieldType: TffFieldType): Boolean;
+{ Returns true if the given field type requires a units factor. }
+
+function FFEFieldTypeToIndex(aFieldType: TffFieldType): Integer;
+{ Converts a given FF fieldtype value to an integer index, skipping
+ the reserved positions }
+
+function FFEIndexToFieldType(aIndex: Integer): TffFieldType;
+{ Converts an integer index to a FF field type, skipping the
+ reserved positions }
+
+function FFEVersionStr: TffShStr;
+
+implementation
+
+uses
+ ffnetmsg,
+ ffllprot,
+ DB,
+ uconsts,
+ SysUtils,
+ TypInfo;
+
+var
+ FFEFirstReservedFieldType,
+ FFELastReservedFieldType: TffFieldType;
+{--------}
+function FFEBlockSizeIndex(const aBlockSize: LongInt): Integer;
+begin
+ case aBlockSize of
+ 4 * 1024: Result := 0;
+ 8 * 1024: Result := 1;
+ 16 * 1024: Result := 2;
+ 32 * 1024: Result := 3;
+ 64 * 1024: Result := 4;
+ else Result := -1;
+ end;
+end;
+{--------}
+function FFEBoolToStr(B: Boolean): TffShStr;
+begin
+ if B then Result := 'Y' else Result := 'N';
+end;
+{--------}
+procedure FFEEnableContainer(Container: TWinControl; Switch: Boolean);
+var
+ I: Integer;
+begin
+ with Container do
+ begin
+ Enabled := Switch;
+ for I := 0 to ControlCount - 1 do
+ begin
+ Controls[I].Enabled := Switch;
+ if (Controls[I] is TGroupBox) or (Controls[I] is TPanel) then
+ FFEEnableContainer(Controls[I] as TWinControl, Switch);
+ end;
+ end;
+end;
+{--------}
+function FFEFieldAllowedDefault(aFieldType : TffFieldType) : Boolean;
+begin
+ Result := aFieldType in [fftBoolean,
+ fftChar,
+ fftWideChar,
+ fftByte,
+ fftInt8,
+ fftInt16,
+ fftInt32,
+ fftWord16,
+ fftWord32,
+ fftComp,
+ fftSingle,
+ fftDouble,
+ fftExtended,
+ fftCurrency,
+ fftStDate,
+ fftStTime,
+ fftDateTime,
+ fftShortString,
+ fftShortAnsiStr,
+ fftNullString,
+ fftNullAnsiStr,
+ fftWideString];
+end;
+{--------}
+function FFEFieldTypeHasDecPl(aFieldType: TffFieldType): Boolean;
+begin
+ Result := aFieldType in [fftSingle,
+ fftDouble,
+ fftExtended,
+ {fftComp,}
+ fftCurrency];
+end;
+{--------}
+function FFEFieldTypeHasUnits(aFieldType: TffFieldType): Boolean;
+begin
+ Result := aFieldType in [fftByte,
+ fftWord16,
+ fftWord32,
+ fftInt8,
+ fftInt16,
+ fftInt32,
+ fftSingle,
+ fftDouble,
+ fftExtended,
+ fftComp,
+ fftCurrency,
+ fftByteArray,
+ fftShortString..High(TffFieldType)];
+end;
+{--------}
+function FFEFieldTypeRequiresUnits(aFieldType: TffFieldType): Boolean;
+begin
+ Result := aFieldType in [fftByteArray,
+ fftShortString..High(TffFieldType)];
+end;
+{--------}
+function FFEFieldTypeToIndex(aFieldType: TffFieldType): Integer;
+begin
+ if aFieldType < FFEFirstReservedFieldType then
+ Result := Ord(aFieldType)
+ else if aFieldType > FFELastReservedFieldType then
+ Result := Ord(aFieldType) -
+ (Ord(FFELastReservedFieldType) -
+ Ord(FFEFirstReservedFieldType) + 1)
+ else
+ Result := -1;
+end;
+{--------}
+function FFEIndexToFieldType(aIndex: Integer): TffFieldType;
+begin
+ if aIndex >= Ord(FFEFirstReservedFieldType) then
+ Result := TffFieldType(aIndex +
+ (Ord(FFELastReservedFieldType) -
+ Ord(FFEFirstReservedFieldType) + 1))
+ else
+ Result := TffFieldType(Ord(aIndex));
+end;
+{--------}
+procedure PopulateFieldTypes;
+var
+ I: TffFieldType;
+begin
+ FFEFirstReservedFieldType := fftBoolean;
+ FFELastReservedFieldType := fftBoolean;
+ for I := Low(I) to High(I) do begin
+ FieldTypes[I] := GetEnumName(TypeInfo(TffFieldType), Ord(I));
+
+ { Find the range of "reserved" slots. This assumes they will be
+ in a single contiguous block }
+ if Pos('FFTRESERVED', ANSIUppercase(FieldTypes[I])) = 1 then begin
+ if FFEFirstReservedFieldType = fftBoolean then
+ FFEFirstReservedFieldType := I;
+ end
+ else
+ if (FFEFirstReservedFieldType <> fftBoolean) and
+ (FFELastReservedFieldType = fftBoolean) then
+ FFELastReservedFieldType := Pred(I);
+ end;
+end;
+{--------}
+function FFEVersionStr: TffShStr;
+begin
+ Result := Format('%5.4f %d-bit', [FFVersionNumber / 10000, 32]);
+end;
+{--------}
+
+
+initialization
+ ClosingApp := False;
+ PopulateFieldTypes;
+end.
+
diff --git a/components/flashfiler/sourcelaz/explorer/uconfig.pas b/components/flashfiler/sourcelaz/explorer/uconfig.pas
new file mode 100644
index 000000000..fff1494ab
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/uconfig.pas
@@ -0,0 +1,638 @@
+{*********************************************************}
+{* Persistently Stored Configuration Info *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+
+unit uconfig;
+
+interface
+
+uses
+ Windows,
+ Forms,
+ SysUtils,
+ Grids,
+ DB,
+ DBGrids,
+ INIFiles,
+ Classes,
+ ffllbase,
+ ffllprot,
+ uconsts;
+
+const
+ {$IFDEF UseRegistryConfig}
+ cfgRootKey = HKEY_LOCAL_MACHINE;
+ {$ENDIF}
+ cfgKeyOptions = 'Options';
+ cfgWindow = 'Window';
+ cfgWindowState = 'WindowState';
+ cfgSplitter = 'Splitter';
+ cfgKeyRegisteredServers = 'Registered Servers';
+ cfgShowBrowser = 'Show Browser';
+ cfgLiveDatasets = 'Live Datasets';
+ cfgDefaultTimeout = 'Default Timeout'; {!!.11}
+
+ cfgProtocol = 'Protocol';
+ cfgProtocolSingleUser = 'Single User';
+ cfgProtocolNetBIOS = 'NetBIOS';
+ cfgProtocolTCPIP = 'TCP/IP';
+ cfgProtocolIPXSPX = 'IPX/SPX';
+
+ cfgLastServer = 'LastServer';
+
+ cfgSortAvailIndexFields = 'Available Index Fields Sorted';
+
+ defWindowState = wsNormal;
+ defcfgShowBrowser = True;
+ defcfgLiveDatasets = False;
+ defcfgSortAvailIndexFields = True;
+
+type
+ TffeConfigOptions = set of (coShowBrowser, coLiveDatasets);
+
+ TffeConfig = class(TPersistent)
+ private
+ protected {private}
+ FLastServer : string;
+ FWindow: TRect;
+ FWindowState: TWindowState;
+ FSortAvailIndexFields : Boolean;
+ FSplitterPosition: Integer;
+ FOptions: TffeConfigOptions;
+// FProtocol: TffCommsProtocolClass;
+ FRegisteredServers: TStrings;
+ FINIFilename: TFileName;
+ {$IFDEF UseRegistryConfig}
+ FRegistryKey: TffShStr;
+ {$ENDIF}
+ FDefaultTimeout: Integer; {!!.11}
+ { default timeout for all operations unless overriden in
+ table- or sqlwindows etc }
+ FWorkingDirectory: String; {!!.11}
+ { the current dir upon startup
+ (from the "start in" shortcut setting) }
+
+ protected
+// function GetProtocolName: TffShStr;
+ procedure ParseWindowString(aWindow: TffShStr);
+ procedure SetLastServer(aValue : string);
+// procedure SetProtocol(aValue: TffCommsProtocolClass);
+ procedure SetWindowState(aValue: TWindowState);
+ procedure SetDefaultTimeout(const Value: Integer); {!!.11}
+ public
+ constructor Create;
+ destructor Destroy; override;
+
+ procedure Refresh;
+ {- Reload all settings from persistent storage}
+
+ procedure Save;
+ {- Save the configuration to persistent storage}
+
+ property LastServer : string
+ read FLastServer write SetLastServer;
+ {- Last server accessed by user. }
+
+ property Options: TffeConfigOptions
+ read FOptions write FOptions;
+ {- boolean option settings}
+
+// property Protocol: TffCommsProtocolClass
+// read FProtocol write SetProtocol;
+ {- Communications protocol}
+
+// property ProtocolName: TffShStr
+// read GetProtocolName;
+ {- Returns the label associated with the protocol }
+
+ property RegisteredServers: TStrings
+ read FRegisteredServers write FRegisteredServers;
+ {- Currently registered server names}
+
+ property SortAvailIndexFields : Boolean
+ read FSortAvailIndexFields write FSortAvailIndexFields;
+ {- Should the available index fields be in sorted or natural order }
+
+ property SplitterPosition: Integer
+ read FSplitterPosition write FSplitterPosition;
+ {- Position of the main window's splitter bar}
+
+ property Window: TRect
+ read FWindow write FWindow;
+ {- Coordinates of the main window}
+
+ property WindowState: TWindowState
+ read FWindowState write SetWindowState;
+ {- State of the main window}
+
+ property DefaultTimeout: Integer read FDefaultTimeout write SetDefaultTimeout; {!!.11}
+ {- Default timeout for all Client components }
+
+ property WorkingDirectory: String read FWorkingDirectory; {!!.11}
+ {- Directory to save ini- and logfiles etc }
+ end;
+
+ procedure FFEConfigSaveFormPrefs(const Section : string; Form : TForm);
+ procedure FFEConfigGetFormPrefs(const Section : string; Form : TForm);
+ procedure FFEConfigSaveString(const Section, Ident, Value : string);
+ function FFEConfigGetString(const Section, Ident, Default : string) : string;
+ procedure FFEConfigSaveInteger(const Section, Ident : string; Value : Integer);
+ function FFEConfigGetInteger(const Section, Ident : string; Default : Integer) : Integer;
+ procedure FFEConfigSaveBoolean(const Section, Ident : string; Value : Boolean);
+ function FFEConfigGetBoolean(const Section, Ident : string; Default : Boolean) : Boolean;
+ procedure FFEConfigSaveDBColumnPrefs(const Section : string; Columns : TDBGridColumns);
+ procedure FFEConfigGetDBColumnPrefs(const Section : string; Columns : TDBGridColumns);
+ procedure FFEConfigSaveColumnPrefs(const Section : string; Grid : TStringGrid);
+ procedure FFEConfigGetColumnPrefs(const Section : string; Grid : TStringGrid);
+
+var
+ Config : TffeConfig;
+ FFEIni : TIniFile;
+ IsReadOnly : Boolean; {!!.06}
+
+implementation
+
+uses
+ {$IFDEF UseRegistryConfig}
+ Registry,
+ {$ENDIF}
+ ffllexcp,
+ ffclbase,
+ ffclcfg,
+ ffconst;
+
+procedure FFEConfigSaveFormPrefs(const Section : string; Form : TForm);
+var
+ Placement : TWindowPlacement;
+begin
+ if IsReadOnly then {!!.06}
+ Exit; {!!.06}
+ {Begin !!.11}
+ { rewritten.
+ NOTE: the 'width' and 'height' names below
+ have been kept to keep leftover unused entries to a minimum.
+ 'windowstate' isn't suitable for reuse since the values are
+ not compatible between WindowState and ShowCmd. }
+ Placement.length :=SizeOf(TWindowPlacement);
+ if not GetWindowPlacement(Form.Handle, @Placement) then
+ Exit;
+ with Placement do begin
+ FFEIni.WriteInteger(Section, 'Flags', Flags);
+ FFEIni.WriteInteger(Section, 'ShowCmd', ShowCmd);
+ FFEIni.WriteInteger(Section, 'Left', rcNormalPosition.Left);
+ FFEIni.WriteInteger(Section, 'Top', rcNormalPosition.Top);
+ FFEIni.WriteInteger(Section, 'Width', rcNormalPosition.Right);
+ FFEIni.WriteInteger(Section, 'Height', rcNormalPosition.Bottom);
+ End;
+ {End !!.11}
+end;
+{--------}
+procedure FFEConfigGetFormPrefs(const Section : string; Form : TForm);
+var
+ Placement : TWindowPlacement;
+begin
+ {Begin !!.11}
+ { rewritten.
+ NOTE: the 'width' and 'height' names below
+ have been kept to keep leftover unused entries to a minimum.
+ 'windowstate' isn't suitable for reuse since the values are
+ not compatible between WindowState and ShowCmd. }
+ with Placement do begin
+ length := SizeOf(TWindowPlacement);
+ Flags := FFEIni.ReadInteger(Section, 'Flags', 0);
+ ShowCmd := FFEIni.ReadInteger(Section, 'ShowCmd', SW_SHOW);
+ rcNormalPosition.Left := FFEIni.ReadInteger(Section, 'Left', Form.Left);
+ rcNormalPosition.Top := FFEIni.ReadInteger(Section, 'Top', Form.Top);
+ rcNormalPosition.Right := FFEIni.ReadInteger(Section, 'Width', Form.Left+Form.Width);
+ rcNormalPosition.Bottom := FFEIni.ReadInteger(Section, 'Height', Form.Top+Form.Height);
+ IF rcNormalPosition.Right > rcNormalPosition.Left THEN
+ SetWindowPlacement(Form.Handle, @Placement)
+ end;
+ {End !!.11}
+end;
+{--------}
+procedure FFEConfigSaveString(const Section, Ident, Value : string);
+begin
+ if IsReadOnly then {!!.06}
+ Exit; {!!.06}
+ FFEIni.WriteString(Section, Ident, Value);
+end;
+{--------}
+function FFEConfigGetString(const Section, Ident, Default : string) : string;
+begin
+ Result := FFEIni.ReadString(Section, Ident, Default);
+end;
+{--------}
+procedure FFEConfigSaveInteger(const Section, Ident : string; Value : Integer);
+begin
+ if IsReadOnly then {!!.06}
+ Exit; {!!.06}
+ FFEIni.WriteInteger(Section, Ident, Value);
+end;
+{--------}
+function FFEConfigGetInteger(const Section, Ident : string; Default : Integer) : Integer;
+begin
+ Result := FFEIni.ReadInteger(Section, Ident, Default);
+end;
+{--------}
+procedure FFEConfigSaveBoolean(const Section, Ident : string; Value : Boolean);
+begin
+ if IsReadOnly then {!!.06}
+ Exit; {!!.06}
+ FFEIni.WriteBool(Section, Ident, Value);
+end;
+{--------}
+function FFEConfigGetBoolean(const Section, Ident : string; Default : Boolean) : Boolean;
+begin
+ Result := FFEIni.ReadBool(Section, Ident, Default);
+end;
+{--------}
+procedure FFEConfigSaveDBColumnPrefs(const Section : string; Columns : TDBGridColumns);
+var
+ Idx : Integer;
+begin
+ if IsReadOnly then {!!.06}
+ Exit; {!!.06}
+ FFEIni.EraseSection(Section);
+ for Idx := 0 to Pred(Columns.Count) do
+ FFEConfigSaveString(Section, Columns[Idx].FieldName, IntToStr(Columns[Idx].Width));
+end;
+{--------}
+procedure FFEConfigGetDBColumnPrefs(const Section : string; Columns : TDBGridColumns);
+var
+ Idx : Integer;
+ Col : TColumn;
+ ColumnInfo : TStringList;
+ Dataset : TDataSet;
+begin
+ if Columns.Grid.FieldCount = 0 then Exit;
+
+ Dataset := Columns.Grid.Fields[0].DataSet;
+ ColumnInfo := TStringList.Create;
+ try
+ ColumnInfo.Sorted := False;
+ FFEIni.ReadSection(Section, ColumnInfo);
+ {Begin !!.10}
+ { if there are new columns in the dataset, don't use stored column
+ settings, otherwise the new columns end up to the far right. }
+ for Idx := 0 to Pred(Dataset.FieldCount) do
+ if ColumnInfo.IndexOf(Dataset.Fields[Idx].FieldName)<0 then begin
+ Columns.RebuildColumns;
+ Exit;
+ end;
+ {End !!.10}
+ Columns.BeginUpdate;
+ try
+ Columns.Clear;
+ for Idx := 0 to Pred(ColumnInfo.Count) do begin
+ if (Dataset.FindField(ColumnInfo[Idx]) <> nil) then begin
+ Col := Columns.Add;
+ Col.FieldName := ColumnInfo[Idx];
+ Col.Width := FFEConfigGetInteger(Section, Col.FieldName, Col.Width);
+ end;
+ end;
+ for Idx := 0 to Pred(Dataset.FieldCount) do begin
+ if (ColumnInfo.IndexOf(Dataset.Fields[Idx].FieldName) = -1) then begin
+ Col := Columns.Add;
+ Col.FieldName := Dataset.Fields[Idx].FieldName;
+ end;
+ end;
+ finally
+ Columns.EndUpdate;
+ end;
+ finally
+ ColumnInfo.Free;
+ end;
+end;
+{--------}
+procedure FFEConfigSaveColumnPrefs(const Section : string; Grid : TStringGrid);
+var
+ Idx : Integer;
+begin
+ if IsReadOnly then {!!.06}
+ Exit; {!!.06}
+ for Idx := 0 to Pred(Grid.ColCount) do
+ FFEConfigSaveInteger(Section, IntToStr(Idx), Grid.ColWidths[Idx]);
+end;
+{--------}
+procedure FFEConfigGetColumnPrefs(const Section : string; Grid : TStringGrid);
+var
+ Idx : Integer;
+begin
+ for Idx := 0 to Pred(Grid.ColCount) do
+ Grid.ColWidths[Idx] := FFEConfigGetInteger(Section, IntToStr(Idx), Grid.ColWidths[Idx]);
+end;
+{--------}
+constructor TffeConfig.Create;
+begin
+ {Begin !!.11}
+ FWorkingDirectory := GetCurrentDir;
+ if FWorkingDirectory='' then
+ FWorkingDirectory := ExtractFilePath(Application.ExeName);
+ if Copy(FWorkingDirectory, Length(FWorkingDirectory), 1)<>'\' then
+ FWorkingDirectory := FWorkingDirectory + '\';
+ {End !!.11}
+ FINIFilename := FWorkingDirectory + ChangeFileExt(ExtractFileName(Application.ExeName), '.INI');
+ {$IFDEF UseRegistryConfig}
+ FRegistryKey := ffStrResClient[ffccREG_PRODUCT] + ffeRegistrySubKey;
+ {$ENDIF}
+ FRegisteredServers := TStringList.Create;
+ Refresh;
+end;
+{--------}
+destructor TffeConfig.Destroy;
+begin
+ FRegisteredServers.Free;
+end;
+{--------}
+{function TffeConfig.GetProtocolName: TffShStr;
+begin
+ Result := FFClientConfigGetProtocolName(FProtocol);
+end;}
+{--------}
+procedure TffeConfig.ParseWindowString(aWindow: TffShStr);
+type
+ TElement = (teLeft, teTop, teRight, teBottom);
+var
+ J: TElement;
+ Element: TffShStr;
+begin
+ try
+ J := teLeft;
+ repeat
+ FFShStrSplit(aWindow, ' ', Element, aWindow);
+ case J of
+ teLeft: FWindow.Left := StrToInt(Element);
+ teTop: FWindow.Top := StrToInt(Element);
+ teRight: FWindow.Right := StrToInt(Element);
+ teBottom: FWindow.Bottom := StrToInt(Element);
+ end;
+ if J < High(J) then Inc(J);
+ until aWindow = '';
+ except
+ end;
+end;
+{--------}
+procedure TffeConfig.Refresh;
+{$IFDEF UseINIConfig}
+var
+ Window: TffShStr;
+{$ENDIF}
+begin
+ FOptions := [];
+// FProtocol := FFClientConfigReadProtocolClass;
+ {$IFDEF UseINIConfig}
+ with TINIFile.Create(FINIFilename) do
+ try
+ Window := ReadString(cfgKeyOptions, cfgWindow, '');
+ if Window <> '' then
+ ParseWindowString(Window);
+
+ FSplitterPosition := ReadInteger(cfgKeyOptions, cfgSplitter, -1);
+
+ FWindowState := TWindowState(ReadInteger(cfgKeyOptions, cfgWindowState, Ord(defWindowState)));
+
+ if ReadBool(cfgKeyOptions, cfgShowBrowser, defcfgShowBrowser) then
+ Include(FOptions, coShowBrowser);
+
+ if ReadBool(cfgKeyOptions, cfgLiveDatasets, defcfgLiveDatasets) then
+ Include(FOptions, coLiveDatasets);
+
+ FSortAvailIndexFields := ReadBool(cfgKeyOptions, cfgSortAvailIndexFields, defcfgSortAvailIndexFields);
+
+ ReadSection(cfgKeyRegisteredServers, FRegisteredServers);
+
+ FDefaultTimeout := ReadInteger(cfgKeyOptions, cfgDefaultTimeout, 10000);
+
+ finally
+ Free;
+ end;
+ {$ENDIF}
+
+ {$IFDEF UseRegistryConfig}
+ with TRegistry.Create do
+ try
+
+ { set defaults }
+ if defcfgShowBrowser then
+ Include(FOptions, coShowBrowser);
+ if defcfgLiveDatasets then
+ Include(FOptions, coLiveDatasets);
+ FSortAvailIndexFields := defcfgSortAvailIndexFields;
+ FWindowState := defWindowState;
+
+ { set and open the main key }
+ RootKey := cfgRootKey;
+ if KeyExists(FRegistryKey + '\' + cfgKeyOptions) then
+ OpenKey(FRegistryKey + '\' + cfgKeyOptions, False);
+
+ { get the window size, position }
+ if ValueExists(cfgWindow) then
+ ParseWindowString(ReadString(cfgWindow));
+
+ FSplitterPosition := -1;
+ if ValueExists(cfgSplitter) then
+ FSplitterPosition := ReadInteger(cfgSplitter);
+
+ if ValueExists(cfgWindowState) then
+ FWindowState := TWindowState(ReadInteger(cfgWindowState));
+
+ if ValueExists(cfgShowBrowser) then
+ if ReadBool(cfgShowBrowser) then
+ Include(FOptions, coShowBrowser)
+ else
+ Exclude(FOptions, coShowBrowser);
+
+ if ValueExists(cfgLiveDatasets) then
+ if ReadBool(cfgLiveDatasets) then
+ Include(FOptions, coLiveDatasets)
+ else
+ Exclude(FOptions, coLiveDatasets);
+
+ if ValueExists(cfgSortAvailIndexFields) then
+ FSortAvailIndexFields := ReadBool(cfgSortAvailIndexFields);
+
+ if ValueExists(cfgLastServer) then
+ FLastServer := ReadString(cfgLastServer);
+
+ {Begin !!.11}
+ FDefaultTimeout := 10000;
+ if ValueExists(cfgDefaultTimeout) then
+ FDefaultTimeout := ReadInteger(cfgDefaultTimeout);
+ {End !!.11}
+
+ OpenKey(FRegistryKey + '\' + cfgKeyRegisteredServers, False);
+ GetKeyNames(FRegisteredServers);
+ finally
+ Free;
+ end;
+ {$ENDIF}
+end;
+{--------}
+procedure TffeConfig.Save;
+var
+ {$IFDEF UseINIConfig} {BEGIN !!.01}
+ I: Integer;
+ {$ELSE}
+ {$IFDEF UseRegistryConfig}
+ I: Integer;
+ {$ENDIF}
+ {$ENDIF} {END !!.01}
+begin
+// FFClientConfigWriteProtocolClass(FProtocol);
+ {$IFDEF UseINIConfig}
+ with TINIFile.Create(FINIFilename) do
+ try
+ try
+
+ { Main window stuff }
+ with FWindow do
+ WriteString(cfgKeyOptions, cfgWindow, Format('%d %d %d %d', [Left, Top, Right, Bottom]));
+ WriteInteger(cfgKeyOptions, cfgWindowState, Ord(FWindowState));
+ WriteInteger(cfgKeyOptions, cfgSplitter, FSplitterPosition);
+
+ { Options }
+ WriteBool(cfgKeyOptions, cfgShowBrowser, (coShowBrowser in FOptions));
+ WriteBool(cfgKeyOptions, cfgLiveDatasets, (coLiveDatasets in FOptions));
+ WriteBool(cfgKeyOptions, cfgSortAvailIndexFields, FSortAvailIndexFields);
+ WriteInteger(cfgKeyOptions, cfgDefaultTimeout, FDefaultTimeout); {!!.11}
+
+ { Registered Servers }
+ EraseSection(cfgKeyRegisteredServers);
+ with FRegisteredServers do
+ for I := 0 to Count - 1 do
+ WriteString(cfgKeyRegisteredServers, Strings[I], '');
+ finally
+ Free;
+ end;
+ except
+ on E:Exception do
+ ShowMessage('Error writing INI file: '+E.Message);
+ end;
+ {$ENDIF}
+ {$IFDEF UseRegistryConfig}
+ if (FRegistryKey <> '') and (FRegistryKey[1] = '\') then begin
+ with TRegistry.Create do
+ try
+ RootKey := cfgRootKey;
+
+ {delete the options key and all that's in it}
+ DeleteKey(FRegistryKey + '\' + cfgKeyOptions);
+
+ {create the options key afresh, make it the current key}
+ OpenKey(FRegistryKey + '\' + cfgKeyOptions, True);
+
+ {write out all the config info}
+
+ { Window coordinates }
+ with FWindow do
+ WriteString(cfgWindow, Format('%d %d %d %d', [Left, Top, Right, Bottom]));
+ WriteInteger(cfgWindowState, Ord(FWindowState));
+ WriteInteger(cfgSplitter, FSplitterPosition);
+
+ { Options }
+ WriteBool(cfgShowBrowser, (coShowBrowser in FOptions));
+ WriteBool(cfgLiveDatasets, (coLiveDatasets in FOptions));
+ WriteBool(cfgSortAvailIndexFields, FSortAvailIndexFields);
+ WriteInteger(cfgDefaultTimeout, FDefaultTimeout); {!!.11}
+
+ { Last server }
+ WriteString(cfgLastServer, FLastServer);
+
+ { Registered Servers }
+ DeleteKey(FRegistryKey + '\' + cfgKeyRegisteredServers);
+ CreateKey(FRegistryKey + '\' + cfgKeyRegisteredServers);
+ with FRegisteredServers do
+ for I := 0 to Count - 1 do
+ CreateKey(FRegistryKey + '\' + cfgKeyRegisteredServers + '\' + Strings[I]);
+ finally
+ Free;
+ end;
+ end;
+ {$ENDIF}
+end;
+{--------}
+{Begin !!.11}
+procedure TffeConfig.SetDefaultTimeout(const Value: Integer);
+begin
+ FDefaultTimeout := Value;
+end;
+{End !!.11}
+{--------}
+procedure TffeConfig.SetLastServer(aValue : string);
+begin
+ if FLastServer <> aValue then
+ FLastServer := aValue;
+end;
+{--------}
+{procedure TffeConfig.SetProtocol(aValue : TffCommsProtocolClass);
+begin
+ if FProtocol <> aValue then begin
+ FProtocol := aValue;
+ FFClientConfigWriteProtocolClass(FProtocol);
+ end;
+end;}
+{--------}
+procedure TffeConfig.SetWindowState(aValue : TWindowState);
+begin
+ if aValue = wsMinimized then
+ aValue := wsNormal;
+
+ if aValue <> FWindowState then
+ FWindowState := aValue;
+end;
+{--------}
+procedure InitUnit;
+begin
+ Config := TffeConfig.Create;
+ if FileExists(Config.FINIFilename) then {!!.06}
+ IsReadOnly := (FileGetAttr(Config.FINIFilename) and {!!.06}
+ SysUtils.faReadOnly) <> 0 {!!.06}
+ else {!!.06}
+ IsReadOnly := False; {!!.06}
+
+ FFEIni := TIniFile.Create(Config.FINIFilename);
+end;
+{--------}
+procedure TermUnit;
+begin
+ Config.Free;
+ Config := nil;
+ FFEIni.Free;
+ FFEIni := nil;
+end;
+{--------}
+
+initialization
+ InitUnit;
+finalization
+ TermUnit;
+end.
diff --git a/components/flashfiler/sourcelaz/explorer/uconsts.pas b/components/flashfiler/sourcelaz/explorer/uconsts.pas
new file mode 100644
index 000000000..bcd4adad1
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/uconsts.pas
@@ -0,0 +1,85 @@
+{*********************************************************}
+{* Explorer Constants *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit uconsts;
+
+interface
+
+uses
+ messages,
+ ffllbase;
+
+const
+ FileTypes : array[TffFileType] of string[5] = ( //was string[20]
+ 'Base',
+ 'Index',
+ 'BLOB');
+
+ IndexTypes : array[TffIndexType] of string[4] = ( //was string[20]
+ 'Comp',
+ 'User');
+
+const
+ ffeNetTimeout = 4000;
+ ffeRegistrySubKey = '\Explorer';
+
+const
+ ffm_Close = WM_USER + $200;
+ { Used to close a form when a failure occurs during FormShow. }
+
+const
+ oeFFEBaseError = 1;
+ oeInvalidFieldName = oeFFEBaseError + 0;
+ oeDuplicateFieldName = oeFFEBaseError + 1;
+ oeMissingFieldName = oeFFEBaseError + 2;
+ oeInvalidIndexName = oeFFEBaseError + 3;
+ oeDuplicateIndexName = oeFFEBaseError + 4;
+ oeMissingIndexName = oeFFEBaseError + 5;
+ oeDuplicateFileExtension = oeFFEBaseError + 6;
+ oeInvalidFileExtension = oeFFEBaseError + 7;
+ oeInvalidFieldUnits = oeFFEBaseError + 8;
+ oeInvalidIndexKeyLength = oeFFEBaseError + 9;
+ oeMaximumIndexKeyLength = oeFFEBaseError + 10;
+
+{ Help contexts }
+const
+ hcMainOutline = 110;
+ hcAddDatabaseDlg = 200;
+ hcDefineNewTableDlg = 210;
+ hcRegisteredServersDlg = 220;
+ hcRedefineTableDlg = 230;
+ hcViewTableDlg = 240;
+ hcImportDataDlg = 250;
+
+implementation
+
+end.
+
diff --git a/components/flashfiler/sourcelaz/explorer/uelement.pas b/components/flashfiler/sourcelaz/explorer/uelement.pas
new file mode 100644
index 000000000..453b2669d
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/uelement.pas
@@ -0,0 +1,522 @@
+{*********************************************************}
+{* Classes for table field/index lists *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit uelement;
+
+interface
+
+uses
+ ffllbase,
+ fflldict,
+ ubase,
+ Classes,
+ SysUtils;
+
+type
+ TffeScratchDict = class(TffDataDictionary)
+ public
+ function CreateFieldDesc(const aIdent : TffDictItemName;
+ const aDesc : TffDictItemDesc;
+ aType : TffFieldType;
+ aUnits : Integer;
+ aDecPl : Integer;
+ aReqFld : Boolean;
+ const aValCheck : TffVCheckDescriptor) : PffFieldDescriptor;
+ end;
+
+ TffeBaseListItem = class(TffListItem)
+ protected
+ public
+ Name: TffDictItemName;
+ {$IFDEF DefeatWarnings}
+ function Compare(aKey : Pointer): Integer; override;
+ function Key: Pointer; override;
+ {$ENDIF}
+ end;
+
+ TffeBaseList = class(TffList)
+ protected
+ function GetItem(aIndex: LongInt): TffeBaseListItem;
+ public
+ constructor Create;
+ procedure Exchange(aIndex1, aIndex2: LongInt);
+ function IndexOf(aElementName: TffDictItemName): LongInt;
+ function InsertAt(aIndex: LongInt; aItem: TffeBaseListItem): Boolean;
+
+ property Items[aIndex: LongInt]: TffeBaseListItem
+ read GetItem;
+ end;
+
+ TffeFieldListItem = class(TffeBaseListItem)
+ protected { private }
+ protected
+ function GetFieldType: TffFieldType;
+ public
+ fiDataTypeIndex : Integer;
+ fiUnits : Word;
+ fiDecPlaces : Word;
+ fiRequired : Boolean;
+ fiDescription : TffDictItemDesc;
+ fiSize : Word;
+ fiValCheck : TffVCheckDescriptor;
+
+ constructor Create;
+ procedure CalcActualValues;
+ {- Use the DataDictionary to compute actual Units, Dec Pl, and Size }
+ property FieldType: TffFieldType
+ read GetFieldType;
+ end;
+
+ TffeFieldList = class(TffeBaseList)
+ private
+ protected
+ function GetItem(aIndex: LongInt): TffeFieldListItem;
+ public
+ function AddEmpty: Boolean;
+ function Insert(aName : TffDictItemName;
+ aType : Integer;
+ aUnits : Word;
+ aDecPl : Word;
+ aRequired : Boolean;
+ aDesc : TffShStr;
+ aValCheck : PffVCheckDescriptor): Boolean;
+ function InsertEmpty(aIndex: LongInt): Boolean;
+ property Items[aIndex: LongInt]: TffeFieldListItem
+ read GetItem;
+ end;
+
+ TffeIndexListItem = class(TffeBaseListItem)
+ protected {private}
+ FFields: TStringList; { List of field names comprising this key }
+ protected
+ function GetBlockSize: Integer;
+ function GetFieldCount: Integer;
+ function GetFieldName(aIndex: Integer): TffDictItemName;
+ procedure SetFieldName(aIndex: Integer; const Value: TffDictItemName);
+ public
+ iiKeyTypeIndex: Integer; {-1 = Undefined, 0 = Composite, 1 = User-Defined}
+ iiKeyLen: SmallInt;
+ iiUnique: Boolean;
+ iiAscending: Boolean;
+ iiCaseSensitive: Boolean;
+ iiExtension: TffExtension;
+ iiBlockSizeIndex: Integer; {-1 = Undefined, 0,1,2,3 = 4096, 8148, 16384, 32768}
+ iiDescription: TffDictItemDesc;
+
+ constructor Create;
+ destructor Destroy; override;
+ procedure AddField(aFieldName: TffDictItemName);
+ procedure DeleteField(aFieldName: TffDictItemName);
+ procedure ExchangeFields(aFieldName1, aFieldName2: TffDictItemName);
+
+ property BlockSize: Integer
+ read GetBlockSize;
+ property FieldCount: Integer
+ read GetFieldCount;
+ property FieldName[aIndex: Integer]: TffDictItemName
+ read GetFieldName
+ write SetFieldName;
+ end;
+
+ TffeIndexList = class(TffeBaseList)
+ private
+ protected
+ function GetItem(aIndex: LongInt): TffeIndexListItem;
+ public
+ function AddEmpty: Boolean;
+ function FieldInUse(aFieldName: TffDictItemName): Integer;
+ function Insert(aName: TffDictItemName;
+ aKeyTypeIndex: Integer;
+ aKeyLen: Integer;
+ aUnique: Boolean;
+ aAscending: Boolean;
+ aCaseSensitive: Boolean;
+ aExt: TffExtension;
+ aBlockSize: Integer;
+ aDesc: TffShStr): Boolean;
+ function InsertEmpty(aIndex: LongInt): Boolean;
+ procedure LoadFromDict(aDictionary: TffDataDictionary);
+ property Items[aIndex: LongInt]: TffeIndexListItem
+ read GetItem;
+ end;
+
+const
+ ktComposite = 0;
+ ktUserDefined = 1;
+
+implementation
+
+var
+ ScratchDict: TffeScratchDict;
+
+{=====TffeScratchDict methods=====}
+
+function TffeScratchDict.CreateFieldDesc(const aIdent : TffDictItemName;
+ const aDesc : TffDictItemDesc;
+ aType : TffFieldType;
+ aUnits : Integer;
+ aDecPl : Integer;
+ aReqFld : Boolean;
+ const aValCheck : TffVCheckDescriptor) : PffFieldDescriptor;
+begin
+ { This was necessary to expose the protected method }
+ Result := inherited CreateFieldDesc(aIdent, aDesc, aType, aUnits, aDecPl, aReqFld, PffVCheckDescriptor(@aValCheck));
+end;
+
+{=====TffeBaseListItem methods=====}
+
+{$IFDEF DefeatWarnings}
+function TffeBaseListItem.Compare(aKey : Pointer): Integer;
+begin
+ Result := 0;
+end;
+
+function TffeBaseListItem.Key: Pointer;
+begin
+ Result := nil;
+end;
+{$ENDIF}
+
+
+{=====TffeBaseList methods=====}
+
+constructor TffeBaseList.Create;
+begin
+ inherited Create;
+ Sorted := False;
+end;
+
+procedure TffeBaseList.Exchange(aIndex1, aIndex2: LongInt);
+var
+ Temp: Pointer;
+begin
+ if not Sorted then begin
+ Temp := fflList[aIndex1];
+ fflList[aIndex1] := fflList[aIndex2];
+ fflList[aIndex2] := Temp;
+ end;
+end;
+
+function TffeBaseList.GetItem(aIndex: LongInt): TffeBaseListItem;
+begin
+ Result := TffeBaseListItem(inherited Items[aIndex]);
+end;
+
+function TffeBaseList.IndexOf(aElementName: TffDictItemName): LongInt;
+var
+ I: LongInt;
+begin
+ Result := -1;
+ aElementName := ANSIUppercase(aElementName);
+ for I := 0 to Count - 1 do
+ if ANSIUppercase(Items[I].Name) = aElementName then begin
+ Result := I;
+ Exit;
+ end;
+end;
+
+function TffeBaseList.InsertAt(aIndex: LongInt; aItem: TffeBaseListItem): Boolean;
+begin
+ Result := False;
+ if not Sorted then begin
+ if aIndex < Count then begin
+ Result := Insert(aItem);
+ Move(fflList^[aIndex],
+ fflList^[aIndex + 1],
+ SizeOf(fflList^[0]) * ((Count - 1) - aIndex)); {!!.55}
+ fflList[aIndex] := aItem;
+ end;
+ end
+end;
+
+{=====TffeFieldListItem methods=====}
+
+constructor TffeFieldListItem.Create;
+begin
+ inherited Create;
+ Name := '';
+ fiDataTypeIndex := -1;
+ fiUnits := 0;
+ fiDecPlaces := 0;
+ fiRequired := False;
+ fiDescription := '';
+end;
+
+procedure TffeFieldListItem.CalcActualValues;
+var
+ FldCheck : TffVCheckDescriptor;
+ FldDesc : PffFieldDescriptor;
+begin
+ FldCheck.vdHasDefVal := False;
+
+ { Compute the actual size, units, and dec pl for this field type }
+ FldDesc := ScratchDict.CreateFieldDesc(Name, fiDescription, FieldType,
+ fiUnits, fiDecPlaces, fiRequired, FldCheck);
+ try
+ fiSize := FldDesc^.fdLength;
+ fiUnits := FldDesc^.fdUnits;
+ fiDecPlaces := FldDesc^.fdDecPl;
+ finally
+ FFFreeMem(FldDesc, SizeOf(TffFieldDescriptor));
+ end;
+end;
+
+function TffeFieldListItem.GetFieldType: TffFieldType;
+begin
+ Result := fftBoolean;
+ if fiDataTypeIndex <> -1 then
+ Result := FFEIndexToFieldType(fiDataTypeIndex);
+end;
+
+{=====TffeFieldList methods=====}
+
+function TffeFieldList.AddEmpty: Boolean;
+begin
+ Result := inherited Insert(TffeFieldListItem.Create);
+end;
+
+function TffeFieldList.Insert(aName : TffDictItemName;
+ aType : Integer;
+ aUnits : Word;
+ aDecPl : Word;
+ aRequired : Boolean;
+ aDesc : TffShStr;
+ aValCheck : PffVCheckDescriptor): Boolean;
+var
+ Item: TffeFieldListItem;
+begin
+ Item := TffeFieldListItem.Create;
+ with Item do begin
+ Name := aName;
+ fiDataTypeIndex := aType;
+ fiUnits := aUnits;
+ fiDecPlaces := aDecPl;
+ fiRequired := aRequired;
+ fiDescription := aDesc;
+ if Assigned(aValCheck) then
+ fiValCheck := aValCheck^;
+ CalcActualValues;
+ end;
+
+ Result := inherited Insert(Item);
+end;
+
+function TffeFieldList.InsertEmpty(aIndex: LongInt): Boolean;
+begin
+ Result := InsertAt(aIndex, TffeFieldListItem.Create);
+end;
+
+function TffeFieldList.GetItem(aIndex: LongInt): TffeFieldListItem;
+begin
+ Result := nil;
+ if aIndex < Count then
+ Result := TffeFieldListItem(inherited Items[aIndex]);
+end;
+
+{=====TffeIndexListItem methods=====}
+
+constructor TffeIndexListItem.Create;
+begin
+ inherited Create;
+ Name := '';
+ iiKeyTypeIndex := ktComposite;
+ iiKeyLen := 0;
+ iiUnique := False;
+ iiAscending := True;
+ iiCaseSensitive := False;
+ iiExtension := '';
+ iiBlockSizeIndex := -1;
+ iiDescription := '';
+ FFields := TStringList.Create;
+end;
+
+destructor TffeIndexListItem.Destroy;
+begin
+ FFields.Free;
+ inherited Destroy;
+end;
+
+procedure TffeIndexListItem.AddField(aFieldName : TffDictItemName);
+begin
+ if (Name <> '') then begin
+ if (FieldCount >= ffcl_MaxIndexFlds) then {!!.05}
+ raise Exception.CreateFmt('Maximum of %d fields per composite index',
+ [ffcl_MaxIndexFlds]);
+
+ FFields.Add(aFieldName);
+ end;
+end;
+
+procedure TffeIndexListItem.DeleteField(aFieldName: TffDictItemName);
+var
+ I: LongInt;
+begin
+ I := FFields.IndexOf(aFieldName);
+ if I <> -1 then
+ FFields.Delete(I);
+end;
+
+procedure TffeIndexListItem.ExchangeFields(aFieldName1,
+ aFieldName2 : TffDictItemName);
+begin
+ with FFields do
+ Exchange(IndexOf(aFieldName1),IndexOf(aFieldName2));
+end;
+
+function TffeIndexListItem.GetBlockSize: Integer;
+begin
+ Result := 0;
+ if iiBlockSizeIndex > -1 then
+ Result := (1 shl iiBlockSizeIndex) shl 12;
+end;
+
+function TffeIndexListItem.GetFieldCount: Integer;
+begin
+ Result := FFields.Count;
+end;
+
+function TffeIndexListItem.GetFieldName(aIndex: Integer): TffDictItemName;
+begin
+ Result := '';
+ if aIndex < FFields.Count then
+ Result := FFields[aIndex];
+end;
+
+procedure TffeIndexListItem.SetFieldName(aIndex: Integer;
+ const Value: TffDictItemName);
+begin
+ FFields.Delete(aIndex);
+ FFields.Insert(aIndex, Value);
+end;
+
+{=====TffeIndexList methods=====}
+
+function TffeIndexList.AddEmpty: Boolean;
+begin
+ Result := inherited Insert(TffeIndexListItem.Create);
+end;
+
+function TffeIndexList.FieldInUse(aFieldName: TffDictItemName): Integer;
+var
+ F: Integer;
+begin
+ for Result := 0 to Count - 1 do
+ with Items[Result] do
+ for F := 0 to FieldCount do
+ if FFCmpShStr(FieldName[F], aFieldName, 255) = 0 then
+ Exit;
+ Result := -1;
+end;
+
+function TffeIndexList.Insert(aName: TffDictItemName;
+ aKeyTypeIndex: Integer;
+ aKeyLen: Integer;
+ aUnique: Boolean;
+ aAscending: Boolean;
+ aCaseSensitive: Boolean;
+ aExt: TffExtension;
+ aBlockSize: Integer;
+ aDesc: TffShStr): Boolean;
+var
+ Item: TffeIndexListItem;
+begin
+ Item := TffeIndexListItem.Create;
+ with Item do begin
+ Name := aName;
+ iiKeyTypeIndex := aKeyTypeIndex;
+ iiKeyLen := aKeyLen;
+ iiUnique := aUnique;
+ iiAscending := aAscending;
+ iiCaseSensitive := aCaseSensitive;
+ iiExtension := aExt;
+ iiBlockSizeIndex := FFEBlockSizeIndex(aBlockSize);
+ iiDescription := aDesc;
+ end;
+ Result := inherited Insert(Item);
+end;
+
+function TffeIndexList.InsertEmpty(aIndex: LongInt): Boolean;
+begin
+ Result := InsertAt(aIndex, TffeIndexListItem.Create);
+end;
+
+function TffeIndexList.GetItem(aIndex: LongInt): TffeIndexListItem;
+begin
+ Result := nil;
+ if aIndex < Count then
+ Result := TffeIndexListItem(inherited Items[aIndex]);
+end;
+
+procedure TffeIndexList.LoadFromDict(aDictionary: TffDataDictionary);
+var
+ I, J: Integer;
+ KeyTypeIndex: Integer;
+ FileExtension: TffExtension;
+ FileBlock: Integer;
+begin
+ with aDictionary do begin
+ Empty;
+ for I := 0 to IndexCount - 1 do begin
+ with IndexDescriptor[I]^ do begin
+ if idCount = -1 then
+ KeyTypeIndex := ktUserDefined
+ else
+ KeyTypeIndex := ktComposite;
+
+ FileExtension := FileExt[idFile];
+ FileBlock := FileBlockSize[idFile];
+ if idFile = 0 then begin
+ FileExtension := '';
+ FileBlock := -1;
+ end;
+
+ Insert(idName,
+ KeyTypeIndex,
+ idKeyLen,
+ not idDups,
+ idAscend,
+ not idNoCase,
+ FileExtension,
+ FileBlock,
+ idDesc);
+
+ case KeyTypeIndex of
+ ktComposite: { Get the fields, in order, that make up this index }
+ for J := 0 to idCount - 1 do
+ Items[IndexOf(idName)].AddField(FieldName[idFields[J]]);
+ end;
+ end;
+ end;
+ end;
+end;
+
+end.
+
diff --git a/components/flashfiler/sourcelaz/explorer/uentity.pas b/components/flashfiler/sourcelaz/explorer/uentity.pas
new file mode 100644
index 000000000..d39ede486
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/uentity.pas
@@ -0,0 +1,1177 @@
+{*********************************************************}
+{* Classes for server, database, and table lists *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit uentity;
+
+interface
+
+uses
+ Classes,
+ Controls,
+ Consts,
+ DB,
+ Dialogs,
+ Forms,
+ SysUtils,
+ Windows,
+ ffclbase,
+ ffllbase,
+ fflldict,
+ ffllprot,
+ ffclreng,
+ ffdb,
+ fflllgcy,
+ fflllog,
+ fflogdlg,
+ ffsrbde;
+
+type
+ TffexpSession = class(TffSession)
+ protected
+ procedure FFELogin(aSource : TObject;
+ var aUserName : TffName;
+ var aPassword : TffName;
+ var aResult : Boolean);
+ public
+ ffePassword : string;
+ ffeUserName : string;
+ public
+ constructor Create(AOwner : TComponent); override;
+ end;
+ TffexpDatabase = class(TffDatabase);
+ TffexpTable = class(TffTable);
+
+type
+ TffeEntityType = (etServer, etDatabase, etTable);
+ TffeServerList = class;
+ TffeDatabaseList = class;
+ TffeDatabaseItem = class;
+ TffeTableList = class;
+ TffeTableItem = class;
+
+ TffeEntityItem = class(TffListItem)
+ protected { private}
+ FEntityType: TffeEntityType;
+ FEntityName: TffNetAddress;
+ FEntitySerialKey: DWORD;
+ public
+ constructor Create(aEntityType: TffeEntityType; aEntityName: TffShStr);
+
+ function Compare(aKey : Pointer): Integer; override;
+ {-compare Self's key to aKey: return <0 if aKey < Self's, 0 if
+ equal, >0 otherwise}
+
+ function Key: Pointer; override;
+ {-return a pointer to this item's key: it'll be a pointer to a
+ shortstring}
+
+ property EntityType: TffeEntityType
+ read FEntityType;
+
+ property EntityName: TffNetAddress
+ read FEntityName;
+
+ property EntitySerialKey: DWORD
+ read FEntitySerialKey;
+ end;
+
+ TffeEntityList = class(TffList)
+ protected
+ function GetItem(aIndex: LongInt): TffeEntityItem;
+ public
+ function IndexOfName(const aName: TffShStr): LongInt;
+ {-return the index of the entry whose name is given}
+
+ function IndexOfSerialKey(aSerialKey: DWORD): LongInt;
+ {-return the list index for a given entity identified by its
+ serial key (the outline control keeps track of entities
+ by the serial key) }
+
+ property Items[aIndex: LongInt]: TffeEntityItem
+ read GetItem;
+ end;
+
+ TffeServerNotifyEvent = procedure(aServerIndex: LongInt) of object;
+
+ TffeServerItem = class(TffeEntityItem)
+ protected
+ FClient : TffClient;
+ FDatabaseList: TffeDatabaseList;
+ FProtocol : TffProtocolType;
+ FServerEngine : TffRemoteServerEngine;
+ FSession : TffexpSession;
+ FTransport : TffLegacyTransport;
+
+ procedure siCheckAttached;
+ function siGetDatabaseCount : longInt;
+ function siGetDatabase(const anIndex : longInt) : TffeDatabaseItem;
+
+ public
+ ServerID: LongInt;
+ Attached: Boolean;
+
+ constructor Create(aServerName: TffNetAddress;
+ aProtocol : TffProtocolType);
+ destructor Destroy; override;
+ procedure AddAlias(aAlias : TffName;
+ aPath : TffPath;
+ aCheckSpace : Boolean); {!!.11}
+ function AddDatabase(aAlias : TffName) : TffeDatabaseItem;
+ function Attach(aLog : TffBaseLog): TffResult;
+ procedure Detach;
+ procedure DropDatabase(aDatabaseName : TffName);
+ procedure GetAliases(aList : TStrings);
+ function GetAutoInc(aTable : TffTable) : TffWord32;
+ procedure LoadDatabases;
+
+ property DatabaseCount : longInt read siGetDatabaseCount;
+ property Databases[const anIndex : longInt] : TffeDatabaseItem
+ read siGetDatabase;
+ property ServerName: TffNetAddress read FEntityName;
+ property Session : TffexpSession read FSession;
+ property Protocol : TffProtocolType read FProtocol; {!!.10}
+ property Client : TffClient read FClient; {!!.11}
+ end;
+
+ TffeServerList = class(TffeEntityList)
+ protected {private}
+ FClient : TffClient;
+ FOnAttach: TffeServerNotifyEvent;
+ FOnDetach: TffeServerNotifyEvent;
+ FServerEngine : TffRemoteServerEngine;
+ FTransport : TffLegacyTransport;
+
+ function GetItem(aIndex: LongInt): TffeServerItem;
+ public
+ constructor Create(aLog : TffBaseLog);
+ destructor Destroy; override;
+ procedure DetachAll;
+ function Insert(aItem: TffeServerItem): Boolean;
+ procedure Load;
+ procedure LoadRegisteredServers;
+
+ property Items[aIndex: LongInt]: TffeServerItem
+ read GetItem;
+
+ property OnAttach: TffeServerNotifyEvent
+ read FOnAttach write FOnAttach;
+ property OnDetach: TffeServerNotifyEvent
+ read FOnDetach write FOnDetach;
+ end;
+
+ TffeDatabaseItem = class(TffeEntityItem)
+ protected
+ FDatabase : TffexpDatabase;
+ FServer : TffeServerItem;
+ FTableList : TffeTableList;
+ diParentList: TffeDatabaseList;
+
+ function diGetIsOpen: Boolean;
+ function diGetServer: TffeServerItem;
+ function diGetTable(const anIndex : longInt) : TffeTableItem;
+ function diGetTableCount : longInt;
+
+ public
+ DatabaseID: LongInt; { FF internal DB Identifier }
+ constructor Create(aServer : TffeServerItem; aAliasName: TffName);
+ destructor Destroy; override;
+ procedure Close;
+ function AddTable(const aTableName : TffTableName) : longInt;
+ procedure CreateTable(const aTableName: TffTableName; aDict: TffDataDictionary);
+ procedure DropTable(const anIndex : longInt);
+ { Drop the specified table from the list of tables. }
+ procedure GetTableNames(Tables: TStrings);
+ function IndexOf(aTable : TffeTableItem) : longInt;
+ procedure LoadTables;
+ procedure Open;
+ procedure Rename(aNewName: TffNetAddress);
+ property Database : TffexpDatabase read FDatabase;
+ property DatabaseName: TffNetAddress read FEntityName;
+ property IsOpen: Boolean read diGetIsOpen;
+ property Server: TffeServerItem read diGetServer;
+ property TableCount : longInt read diGetTableCount;
+ property Tables[const anIndex : longInt] : TffeTableItem
+ read diGetTable;
+ end;
+
+ TffeDatabaseList = class(TffeEntityList)
+ protected
+ FServer : TffeServerItem;
+
+ function GetItem(aIndex: LongInt): TffeDatabaseItem;
+ public
+ constructor Create(aServer : TffeServerItem);
+ destructor Destroy; override;
+ function Add(const aDatabaseName: TffName): TffeDatabaseItem;
+ procedure DropDatabase(aIndex: LongInt);
+ function Insert(aItem: TffeDatabaseItem): Boolean;
+ procedure Load;
+ { Load the aliases for the server. }
+
+ property Items[aIndex: LongInt]: TffeDatabaseItem
+ read GetItem;
+ end;
+
+ TffeTableItem = class(TffeEntityItem)
+ protected {private}
+ FParent : TffeDatabaseItem;
+ protected
+ tiParentList: TffeTableList;
+ procedure AfterOpenEvent(aDataset: TDataset);
+ function GetDatabase: TffeDatabaseItem;
+ function GetDictionary: TffDataDictionary;
+ function GetRebuilding: Boolean;
+ function GetRecordCount: TffWord32;
+ function GetServer: TffeServerItem;
+ public
+ Table: TffexpTable;
+ DatabaseIndex: LongInt;
+ CursorID: LongInt;
+ TaskID: LongInt;
+ constructor Create(aDatabase : TffeDatabaseItem; aTableName: TffName);
+ destructor Destroy; override;
+
+ procedure CheckRebuildStatus(var aCompleted: Boolean;
+ var aStatus: TffRebuildStatus);
+ function GetAutoInc : TffWord32;
+ procedure Pack;
+ procedure Reindex(aIndexNum: Integer);
+ procedure Rename(aNewTableName: TffName);
+ procedure Restructure(aDictionary: TffDataDictionary; aFieldMap: TStrings);
+ procedure SetAutoIncSeed(aValue : LongInt);
+ procedure Truncate;
+ procedure CopyRecords(aSrcTable : TffDataSet; aCopyBLOBs : Boolean); {!!.10}
+
+ property Database: TffeDatabaseItem
+ read GetDatabase;
+ property Dictionary: TffDataDictionary
+ read GetDictionary;
+ property Rebuilding: Boolean
+ read GetRebuilding;
+ property RecordCount: TffWord32
+ read GetRecordCount;
+ property Server: TffeServerItem
+ read GetServer;
+ property TableName: TffNetAddress
+ read FEntityName;
+ end;
+
+ TffeTableList = class(TffeEntityList)
+ protected
+ FDatabase : TffeDatabaseItem;
+ function GetItem(aIndex: LongInt): TffeTableItem;
+ public
+ constructor Create(aDatabase : TffeDatabaseItem);
+ destructor Destroy; override;
+ function Add(const aTableName: TffName): longInt;
+ procedure DropTable(aIndex: LongInt);
+ function Insert(aItem: TffeTableItem): Boolean;
+ procedure Load;
+
+ property Items[aIndex: LongInt]: TffeTableItem
+ read GetItem;
+ end;
+
+const
+ ffcConnectTimeout : longInt = 2000;
+ {-Number of milliseconds we will wait for servers to respond to our
+ broadcast. }
+
+implementation
+
+uses
+ ffclcfg,
+ ffdbbase,
+ ffllcomm,
+ ffllcomp,
+ fflleng,
+ ubase,
+ uconsts,
+ {$IFDEF DCC6ORLATER} {!!.03}
+ RTLConsts, {!!.03}
+ {$ENDIF} {!!.03}
+ uconfig;
+
+const
+ ffcLogName = 'ffe.log';
+ ffcDatabaseClosed = 'Cannot perform this operation on a closed database';
+
+var
+ NextEntitySerialKey: DWORD;
+
+{=====TffeEntityItem methods=====}
+
+constructor TffeEntityItem.Create(aEntityType: TffeEntityType; aEntityName: TffShStr);
+begin
+ inherited Create;
+ FEntityType := aEntityType;
+ FEntityName := aEntityName;
+ FEntitySerialKey := NextEntitySerialKey;
+ Inc(NextEntitySerialKey);
+end;
+
+function TffeEntityItem.Compare(aKey: Pointer): Integer;
+begin
+ Result := FFCmpShStr(PffShStr(aKey)^, EntityName, 255);
+end;
+
+function TffeEntityItem.Key: Pointer;
+begin
+ Result := @FEntityName;
+end;
+
+{=====TffeEntityList methods=====}
+
+function TffeEntityList.GetItem(aIndex: LongInt): TffeEntityItem;
+begin
+ if (aIndex < 0) or (aIndex >= Count) then
+ raise EListError.Create(SListIndexError);
+ Result := TffeEntityItem(inherited Items[aIndex]);
+end;
+
+function TffeEntityList.IndexOfName(const aName: TffShStr): LongInt;
+begin
+ for Result := 0 to Count - 1 do
+ if Items[Result].EntityName = aName then Exit;
+ Result := -1;
+end;
+
+function TffeEntityList.IndexOfSerialKey(aSerialKey: DWORD): LongInt;
+begin
+ for Result := 0 to Count - 1 do
+ if Items[Result].EntitySerialKey = aSerialKey then Exit;
+ Result := -1;
+end;
+
+{===TffeServerItem===================================================}
+constructor TffeServerItem.Create(aServerName: TffNetAddress;
+ aProtocol : TffProtocolType);
+begin
+ inherited Create(etServer, FFShStrTrim(aServerName));
+ FDatabaseList := TffeDatabaseList.Create(Self);
+ FProtocol := aProtocol;
+ Attached := False;
+end;
+{--------}
+destructor TffeServerItem.Destroy;
+begin
+ Detach;
+ FDatabaseList.Free;
+ inherited Destroy;
+end;
+{--------}
+procedure TffeServerItem.AddAlias(aAlias : TffName;
+ aPath : TffPath;
+ aCheckSpace : Boolean); {!!.11}
+begin
+ FSession.AddAlias(aAlias, aPath, aCheckSpace); {!!.11}
+end;
+{--------}
+function TffeServerItem.AddDatabase(aAlias : TffName) : TffeDatabaseItem;
+begin
+ Result := FDatabaseList.Add(aAlias);
+end;
+{--------}
+function TffeServerItem.Attach(aLog : TffBaseLog): TffResult;
+var
+ OldCursor: TCursor;
+begin
+ Result := DBIERR_NONE;
+
+ { If we're already attached, then we don't need to do anything }
+ if Attached then Exit;
+
+ OldCursor := Screen.Cursor;
+ Screen.Cursor := crHourglass;
+ try
+
+ if not assigned(FTransport) then
+ FTransport := TffLegacyTransport.Create(nil);
+ with FTransport do begin
+ Mode := fftmSend;
+ Enabled := True;
+ Protocol := FProtocol;
+ EventLog := aLog;
+ EventLogEnabled := True;
+ EventLogOptions := [fftpLogErrors];
+ ServerName := FEntityName;
+ end;
+
+ if not assigned(FServerEngine) then
+ FServerEngine := TffRemoteServerEngine.Create(nil);
+ with FServerEngine do begin
+ Transport := FTransport;
+ end;
+
+ if not assigned(FClient) then
+ FClient := TffClient.Create(nil);
+ with FClient do begin
+ TimeOut := Config.DefaultTimeout; {!!.11}
+ ServerEngine := FServerEngine;
+ AutoClientName := True;
+ Active := True;
+ end;
+
+ if not assigned(FSession) then
+ FSession := TffexpSession.Create(nil);
+ with FSession do begin
+ ClientName := FClient.ClientName;
+ AutoSessionName := True;
+ Active := True;
+ end;
+
+ Attached := FSession.Active;
+ if Attached then begin
+ { Automatically load up all the databases for this server }
+ if not assigned(FDatabaseList) then
+ FDatabaseList := TffeDatabaseList.Create(Self);
+ FDatabaseList.Load;
+
+ { Run the event-handler if any }
+ with ServerList do
+ if Assigned(FOnAttach) then
+ FOnAttach(Index(FEntityName));
+ end;
+ finally;
+ Screen.Cursor := OldCursor;
+ end;
+end;
+{--------}
+procedure TffeServerItem.Detach;
+var
+ S: TffNetAddress;
+begin
+
+ if assigned(FDatabaseList) then begin
+ FDatabaseList.Free;
+ FDatabaseList := nil;
+ end;
+
+ if assigned(FSession) then begin
+ FSession.Active := False;
+ FSession.Free;
+ FSession := nil;
+ end;
+
+ if assigned(FClient) then begin
+ FClient.Active := False;
+ FClient.Free;
+ FClient := nil;
+ end;
+
+ if assigned(FTransport) then begin
+ FTransport.State := ffesInactive;
+ FTransport.Free;
+ FTransport := nil;
+ end;
+
+ if assigned(FServerEngine) then begin
+ FServerEngine.Free;
+ FServerEngine := nil;
+ end;
+
+ Attached := False;
+
+ S := ServerName;
+ with ServerList do
+ if Assigned(FOnDetach) then
+ FOnDetach(Index(S));
+end;
+{--------}
+procedure TffeServerItem.DropDatabase(aDatabaseName : TffName);
+begin
+ siCheckAttached;
+ FDatabaseList.DropDatabase(FDatabaseList.IndexOfName(aDatabaseName));
+end;
+{--------}
+procedure TffeServerItem.GetAliases(aList : TStrings);
+begin
+ siCheckAttached;
+ FSession.GetAliasNames(aList);
+end;
+{--------}
+function TffeServerItem.GetAutoInc(aTable : TffTable) : TffWord32;
+begin
+ Result := 1;
+ FServerEngine.TableGetAutoInc(aTable.CursorID, Result);
+end;
+{--------}
+procedure TffeServerItem.LoadDatabases;
+begin
+ siCheckAttached;
+ FDatabaseList.Load;
+end;
+{--------}
+procedure TffeServerItem.siCheckAttached;
+begin
+ if not Attached then
+ Attach(nil);
+end;
+{--------}
+function TffeServerItem.siGetDatabaseCount : longInt;
+begin
+ Result := FDatabaseList.Count;
+end;
+{--------}
+function TffeServerItem.siGetDatabase(const anIndex : Longint)
+ : TffeDatabaseItem;
+begin
+ Result := TffeDatabaseItem(FDatabaseList[anIndex]);
+end;
+{====================================================================}
+
+{===TffeServerList===================================================}
+constructor TffeServerList.Create(aLog : TffBaseLog);
+begin
+ inherited Create;
+ Sorted := True;
+
+ { The transport will be left inactive. Its sole purpose is to
+ broadcast for servers using the protocol identified in the registry. }
+ FTransport := TffLegacyTransport.Create(nil);
+ with FTransport do begin
+ Mode := fftmSend;
+ Enabled := True;
+ Protocol := ptRegistry;
+ EventLog := aLog;
+ EventLogEnabled := True;
+ EventLogOptions := [fftpLogErrors];
+ Name := 'ffeTransport';
+ end;
+
+ FServerEngine := TffRemoteServerEngine.Create(nil);
+ with FServerEngine do begin
+ Transport := FTransport;
+ Name := 'ffeServerEngine';
+ end;
+
+ FClient := TffClient.Create(nil);
+ with FClient do begin
+ ServerEngine := FServerEngine;
+ Name := 'ffeClient';
+ ClientName := Name;
+ Timeout := ffcConnectTimeout;
+ Active := True;
+ end;
+
+end;
+{--------}
+destructor TffeServerList.Destroy;
+begin
+ Empty;
+ FClient.Active := False;
+ FClient.Free;
+ FServerEngine.Free;
+ FTransport.State := ffesInactive;
+ FTransport.Free;
+ inherited Destroy;
+end;
+{--------}
+procedure TffeServerList.DetachAll;
+var
+ I: Integer;
+begin
+ for I := 0 to Count - 1 do
+ with Items[I] do
+ if Attached then Detach;
+end;
+{--------}
+function TffeServerList.Insert(aItem: TffeServerItem): Boolean;
+begin
+ Result := inherited Insert(aItem);
+end;
+{--------}
+function TffeServerList.GetItem(aIndex: LongInt): TffeServerItem;
+begin
+ Result := TffeServerItem(inherited Items[aIndex]);
+end;
+{--------}
+procedure TffeServerList.Load;
+var
+ Servers: TStringList;
+ I: Integer;
+ tryProt: TffProtocolType; {!!.10}
+
+function ServerRegistered(const ServerName : string) : Boolean; {begin !!.06}
+var
+ Idx : Integer;
+begin
+ Result := False;
+ with Config do
+ for Idx := 0 to Pred(RegisteredServers.Count) do
+ if FFAnsiCompareText(ServerName, RegisteredServers[Idx]) = 0 then begin {!!.10}
+ Result := True;
+ Exit;
+ end;
+end; {end !!.06}
+
+begin
+ Empty;
+
+// if not (Config.Protocol = TffSingleUserProtocol) then {!!.06}
+ LoadRegisteredServers;
+
+ {Begin !!.07}
+ { added loop to try all protocols. we no longer let the user
+ select protocol, but instead list all servers on all protocols. }
+ { Broadcast for currently active servers }
+ Servers := TStringList.Create;
+ try
+ for tryProt := ptSingleUser to ptIPXSPX do begin
+ try
+ FTransport.Enabled := False;
+ FTransport.Protocol := tryProt;
+ FClient.GetServerNames(Servers);
+ for I := 0 to Servers.Count - 1 do
+ if not ServerRegistered(Servers[I]) then {!!.06}
+ Insert(TffeServerItem.Create(Servers[I], tryProt));
+ except
+ { swallow all errors. assume that the particular protocol failed. }
+ end;
+ end;
+ {End !!.07}
+ finally
+ Servers.Free;
+ end;
+end;
+{--------}
+procedure TffeServerList.LoadRegisteredServers;
+var
+ I: Integer;
+begin
+ with Config.RegisteredServers do
+ for I := 0 to Count - 1 do
+ Self.Insert(TffeServerItem.Create(Strings[I], ptTCPIP)); {!!.10} {changed protocol type}
+end;
+{=====================================================================}
+
+{== TffeDatabaseItem =================================================}
+constructor TffeDatabaseItem.Create(aServer : TffeServerItem;
+ aAliasName : TffName);
+begin
+ inherited Create(etDatabase, aAliasName);
+ FServer := aServer;
+ DatabaseID := -1;
+ diParentList := nil;
+ FDatabase := TffexpDatabase.Create(nil);
+ FTableList := TffeTableList.Create(Self);
+ with FDatabase do begin
+ DatabaseName := 'exp' + aAliasName;
+ SessionName := aServer.Session.SessionName;
+ AliasName := aAliasName;
+ end;
+end;
+{--------}
+destructor TffeDatabaseItem.Destroy;
+begin
+ if IsOpen then Close;
+ FTableList.Free;
+ FDatabase.Free;
+ inherited Destroy;
+end;
+{--------}
+procedure TffeDatabaseItem.Close;
+begin
+ FDatabase.Connected := False;
+end;
+{--------}
+function TffeDatabaseItem.AddTable(const aTableName : TffTableName)
+ : Longint;
+begin
+ Result := FTableList.Add(aTableName);
+end;
+{--------}
+procedure TffeDatabaseItem.CreateTable(const aTableName : TffTableName;
+ aDict : TffDataDictionary);
+begin
+ if not IsOpen then
+ Open;
+
+ Check(FDatabase.CreateTable(False, aTableName, aDict));
+end;
+{--------}
+procedure TffeDatabaseItem.DropTable(const anIndex : longInt);
+begin
+ FTableList.DropTable(anIndex);
+end;
+{--------}
+function TffeDatabaseItem.diGetIsOpen: Boolean;
+begin
+ Result := FDatabase.Connected;
+end;
+{--------}
+function TffeDatabaseItem.diGetServer: TffeServerItem;
+begin
+ Result := FServer;
+end;
+{--------}
+function TffeDatabaseItem.diGetTable(const anIndex : longInt) : TffeTableItem;
+begin
+ Result := TffeTableItem(FTableList[anIndex]);
+end;
+{--------}
+function TffeDatabaseItem.diGetTableCount : longInt;
+begin
+ Result := FTableList.Count;
+end;
+{--------}
+procedure TffeDatabaseItem.GetTableNames(Tables: TStrings);
+begin
+ if Tables is TStringList then
+ TStringList(Tables).Sorted := True;
+ FDatabase.GetTableNames(Tables);
+end;
+{--------}
+function TffeDatabaseItem.IndexOf(aTable : TffeTableItem) : longInt;
+begin
+ Result := FTableList.IndexOfName(aTable.TableName);
+end;
+{--------}
+procedure TffeDatabaseItem.LoadTables;
+{ Find all the tables in the database and add to the table list. }
+var
+ Tables: TStringList;
+ I: Integer;
+begin
+ Tables := TStringList.Create;
+ try
+ FTableList.Empty;
+// try
+ FDatabase.GetTableNames(Tables);
+ for I := 0 to Tables.Count - 1 do
+ FTableList.Add(Tables[I]);
+{ except
+ on EffDatabaseError do
+ {do nothing}
+{ else
+ raise;
+ end;}
+ finally
+ Tables.Free;
+ end;
+end;
+{--------}
+procedure TffeDatabaseItem.Open;
+begin
+ FDatabase.Connected := True;
+end;
+{--------}
+procedure TffeDatabaseItem.Rename(aNewName: TffNetAddress);
+begin
+ FDatabase.Close;
+ Check(FServer.Session.ModifyAlias(FEntityName, aNewName, '', False)); {!!.11}
+ FEntityName := aNewName;
+end;
+{=====================================================================}
+
+{== TffeDatabaseList =================================================}
+constructor TffeDatabaseList.Create(aServer : TffeServerItem);
+begin
+ inherited Create;
+ FServer := aServer;
+ Sorted := False;
+end;
+{--------}
+destructor TffeDatabaseList.Destroy;
+begin
+ { Close all databases. }
+ Empty;
+ inherited Destroy;
+end;
+{--------}
+function TffeDatabaseList.Add(const aDatabaseName : TffName)
+ : TffeDatabaseItem;
+begin
+ Result := TffeDatabaseItem.Create(FServer, aDatabaseName);
+ Insert(Result);
+end;
+{--------}
+procedure TffeDatabaseList.DropDatabase(aIndex: LongInt);
+begin
+ with Items[aIndex] do begin
+ FDatabase.Connected := False;
+ FServer.Session.DeleteAlias(DatabaseName);
+ end;
+ DeleteAt(aIndex);
+end;
+{--------}
+function TffeDatabaseList.GetItem(aIndex: LongInt): TffeDatabaseItem;
+begin
+ Result := TffeDatabaseItem(inherited Items[aIndex]);
+end;
+{--------}
+function TffeDatabaseList.Insert(aItem: TffeDatabaseItem): Boolean;
+begin
+ aItem.diParentList := Self;
+ Result := inherited Insert(AItem);
+end;
+{--------}
+procedure TffeDatabaseList.Load;
+var
+ Aliases : TStringList;
+ Index : longInt;
+ OldCursor: TCursor;
+begin
+ OldCursor := Screen.Cursor;
+ Aliases := TStringList.Create;
+ Screen.Cursor := crHourglass;
+ try
+ Empty;
+ FServer.GetAliases(Aliases);
+ for Index := 0 to pred(Aliases.Count) do begin
+ Add(Aliases[Index]);
+ end;
+ finally
+ Aliases.Free;
+ Screen.Cursor := OldCursor;
+ end;
+end;
+{=====================================================================}
+
+{== TffeTableItem ====================================================}
+constructor TffeTableItem.Create(aDatabase : TffeDatabaseItem;
+ aTableName : TffName);
+begin
+ inherited Create(etTable, aTableName);
+ FParent := aDatabase;
+ CursorID := -1;
+ TaskID := -1;
+ tiParentList := nil;
+ Table := TffexpTable.Create(nil);
+ with Table do begin
+ SessionName := aDatabase.Server.Session.SessionName;
+ DatabaseName := aDatabase.Database.DatabaseName;
+ TableName := aTableName;
+ ReadOnly := False;
+ AfterOpen := AfterOpenEvent;
+ end;
+end;
+{--------}
+destructor TffeTableItem.Destroy;
+begin
+ Table.Free;
+ inherited Destroy;
+end;
+{--------}
+procedure TffeTableItem.CheckRebuildStatus(var aCompleted: Boolean;
+ var aStatus: TffRebuildStatus);
+var
+ WasOpen : Boolean;
+begin
+ WasOpen := Database.IsOpen;
+ if not Database.IsOpen then
+ Database.Open;
+
+ try
+ Check(FParent.Server.Session.GetTaskStatus(TaskID, aCompleted, aStatus));
+ if aCompleted then
+ TaskID := -1;
+ except
+ TaskID := -1;
+ end;
+ if not WasOpen then
+ Database.Close;
+end;
+{--------}
+function TffeTableItem.GetAutoInc : TffWord32;
+var
+ WasOpen : Boolean;
+begin
+ WasOpen := Table.Active;
+ if not Table.Active then
+ Table.Open;
+
+ Result := FParent.Server.GetAutoInc(Table);
+
+ if not WasOpen then
+ Table.Close;
+end;
+{--------}
+procedure TffeTableItem.AfterOpenEvent(aDataset: TDataset);
+var
+ I: Integer;
+begin
+ with aDataset do
+ for I := 0 to FieldCount - 1 do
+ case Fields[I].DataType of
+ ftString: TStringField(Fields[I]).Transliterate := False;
+ ftMemo: TMemoField(Fields[I]).Transliterate := False;
+ end;
+end;
+{--------}
+function TffeTableItem.GetDatabase: TffeDatabaseItem;
+begin
+ Result := FParent;
+end;
+{--------}
+function TffeTableItem.GetDictionary: TffDataDictionary;
+var
+ WasOpen : Boolean;
+begin
+ WasOpen := Table.Active;
+ if not Table.Active then
+ Table.Open;
+
+ Result := Table.Dictionary;
+
+ if not WasOpen then
+ Table.Close;
+end;
+{--------}
+function TffeTableItem.GetRebuilding: Boolean;
+begin
+ Result := TaskID <> -1;
+end;
+{--------}
+function TffeTableItem.GetRecordCount: TffWord32;
+var {!!.06}
+ WasOpen : Boolean; {!!.06}
+begin {!!.06}
+ WasOpen := Table.Active;
+ if not Table.Active then
+ Table.Open;
+
+ Result := Table.RecordCount;
+
+ if WasOpen then {!!.06}
+ Table.Close; {!!.06}
+end;
+{--------}
+function TffeTableItem.GetServer: TffeServerItem;
+begin
+ Result := FParent.Server;
+end;
+{--------}
+procedure TffeTableItem.Pack;
+var
+ WasOpen : Boolean;
+begin
+ WasOpen := Database.IsOpen;
+ if not Database.IsOpen then
+ Database.Open;
+
+ Check(Database.FDatabase.PackTable(Table.TableName, TaskID));
+
+ if not WasOpen then
+ Database.Close;
+end;
+{--------}
+procedure TffeTableItem.Reindex(aIndexNum: Integer);
+var
+ WasOpen: Boolean;
+begin
+ WasOpen := Database.IsOpen;
+ if not Database.IsOpen then
+ Database.Open;
+
+ if Table.Active then Table.Close;
+ Check(Database.FDatabase.ReindexTable(Table.TableName, aIndexNum, TaskID));
+
+ if not WasOpen then
+ Database.Close;
+end;
+{--------}
+procedure TffeTableItem.Rename(aNewTableName: TffName);
+begin
+ with Table do begin
+ if Active then Close;
+ RenameTable(aNewTableName);
+ FEntityName := aNewTableName;
+ end;
+end;
+{--------}
+procedure TffeTableItem.Restructure(aDictionary: TffDataDictionary; aFieldMap: TStrings);
+var
+ Result: TffResult;
+ WasOpen: Boolean;
+begin
+ WasOpen := Database.IsOpen;
+ if not Database.IsOpen then
+ Database.Open;
+
+ Table.Close;
+
+ Result := Database.FDatabase.RestructureTable
+ (Tablename, aDictionary, aFieldMap, TaskID);
+ if Result = DBIERR_INVALIDRESTROP then
+ raise Exception.Create('Cannot preserve data if user-defined indexes have been added or changed')
+ else Check(Result);
+
+ if not WasOpen then
+ Database.Close;
+end;
+{--------}
+procedure TffeTableItem.SetAutoIncSeed(aValue: Integer);
+var
+ WasOpen : Boolean;
+begin
+ WasOpen := Table.Active;
+ if not Table.Active then
+ Table.Open;
+
+ Check(Table.SetTableAutoIncValue(aValue));
+
+ if not WasOpen then
+ Table.Close;
+end;
+{--------}
+procedure TffeTableItem.Truncate;
+begin
+ { Make sure we suck in the dictionary before the table gets deleted }
+ GetDictionary;
+ with Table do begin
+ Close;
+ DeleteTable;
+ end;
+ Database.CreateTable(TableName, Dictionary);
+end;
+{--------}
+procedure TffeTableItem.CopyRecords(aSrcTable: TffDataSet;
+ aCopyBLOBs: Boolean);
+var
+ WasOpen : Boolean;
+begin
+ WasOpen := Table.Active;
+ if not Table.Active then
+ Table.Open;
+ Table.CopyRecords(aSrcTable, aCopyBLOBs);
+ if not WasOpen then
+ Table.Close;
+end;
+{=====================================================================}
+
+{== TffeTableList ====================================================}
+constructor TffeTableList.Create(aDatabase : TffeDatabaseItem);
+begin
+ inherited Create;
+ FDatabase := aDatabase;
+ Sorted := False;
+end;
+{--------}
+destructor TffeTableList.Destroy;
+begin
+ Empty;
+ inherited Destroy;
+end;
+{--------}
+function TffeTableList.Add(const aTableName: TffName): longInt;
+var
+ aTable : TffeTableItem;
+begin
+ aTable := TffeTableItem.Create(FDatabase, aTableName);
+ Insert(aTable);
+ Result := pred(Count);
+end;
+{--------}
+procedure TffeTableList.DropTable(aIndex: LongInt);
+begin
+ with Items[aIndex].Table do begin
+ if Active then
+ Close;
+ DeleteTable;
+ end;
+
+ DeleteAt(aIndex);
+end;
+{--------}
+function TffeTableList.GetItem(aIndex: LongInt): TffeTableItem;
+begin
+ Result := TffeTableItem(inherited Items[aIndex]);
+end;
+{--------}
+function TffeTableList.Insert(aItem: TffeTableItem): Boolean;
+begin
+ aItem.tiParentList := Self;
+ Result := inherited Insert(aItem);
+end;
+{--------}
+procedure TffeTableList.Load;
+var
+ I: Integer;
+ OldCursor: TCursor;
+ Tables: TStringList;
+begin
+ Tables := TStringList.Create;
+ OldCursor := Screen.Cursor;
+ Screen.Cursor := crHourglass;
+ try
+ { Remove any existing tables for this database }
+ Empty;
+ FDatabase.GetTableNames(Tables);
+ for I := 0 to Tables.Count - 1 do
+ Add(Tables[I]);
+ finally
+ Screen.Cursor := OldCursor;
+ Tables.Free;
+ end;
+end;
+{=====================================================================}
+
+{ TffexpSession }
+
+constructor TffexpSession.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+
+ OnLogin := FFELogin;
+ ffePassword := '';
+ ffeUserName := '';
+end;
+
+procedure TffexpSession.FFELogin(aSource: TObject; var aUserName,
+ aPassword: TffName; var aResult: Boolean);
+var
+ FFLoginDialog : TffLoginDialog;
+begin
+ FFLoginDialog := TFFLoginDialog.Create(nil);
+ try
+ with FFLoginDialog do begin
+ UserName := aUserName;
+ Password := aPassword;
+ ShowModal;
+ aResult := ModalResult = mrOK;
+ if aResult then begin
+ aUserName := UserName;
+ ffeUserName := UserName;
+ aPassword := Password;
+ ffePassword := Password;
+ aResult := True;
+ end;
+ end;
+ finally
+ FFLoginDialog.Free;
+ end;
+end;
+
+initialization
+ NextEntitySerialKey := 0;
+end.
+
diff --git a/components/flashfiler/sourcelaz/explorer/usqlcfg.pas b/components/flashfiler/sourcelaz/explorer/usqlcfg.pas
new file mode 100644
index 000000000..171e5b48c
--- /dev/null
+++ b/components/flashfiler/sourcelaz/explorer/usqlcfg.pas
@@ -0,0 +1,195 @@
+{*********************************************************}
+{* Persistently Stored SQL Window Configuration Info *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit usqlcfg;
+
+interface
+
+uses
+ Classes,
+ Forms,
+ Windows,
+ Graphics,
+ SysUtils,
+ ffllbase;
+
+const
+ sqlCfgKeyOptions = 'SQLOpts:';
+ sqlCfgSplitterPosition = 'SQLSplitterPos';
+ sqlCfgWindow = 'SQLWindow';
+ sqlCfgWindowState = 'SQLWindowState';
+ sqlCfgWindowFontName = 'SQLFontName';
+ sqlCfgWindowFontSize = 'SQLFontSize';
+
+ defWindowState = wsNormal;
+ defSplitterPos = 129;
+
+type
+ TffeSQLConfig = class(TPersistent)
+ protected {private}
+ FSplitterPos : Integer;
+ FWindowRect : TRect;
+ FWindowState : TWindowState;
+ FFontName : string;
+ FFontSize : Integer;
+ FServerName : string;
+ FDBName : string;
+ FINIFilename : TFileName;
+ FINISection : string;
+ protected
+ procedure ParseWindowString(aWindowStr : TffShStr);
+ procedure SetWindowPos(aRect : TRect);
+ public
+ constructor Create(const aServerName, aDBName : string);
+ procedure Refresh;
+ {- Reload all settings from persistent storage}
+ procedure Save;
+ {- Save the configuration to persistent storage}
+
+ property FontName : string
+ read FFontName
+ write FFontName;
+ property FontSize : Integer
+ read FFontSize
+ write FFontSize;
+ property SplitterPos : Integer
+ read FSplitterPos
+ write FSplitterPos;
+ property WindowPos : TRect
+ read FWindowRect
+ write FWindowRect;
+ property WindowState : TWindowState
+ read FWindowState
+ write FWindowState;
+ end;
+
+implementation
+
+uses
+ Dialogs,
+ Inifiles,
+ uConfig; {!!.11}
+
+{ TffeSQLConfig }
+
+{====================================================================}
+constructor TffeSQLConfig.Create(const aServerName, aDBName : string);
+begin
+ FServerName := aServerName;
+ FDBName := aDBName;
+ FINISection := sqlCfgKeyOptions + aServerName + aDBName;
+ {Begin !!.11}
+ FINIFilename := Config.WorkingDirectory + ChangeFileExt(ExtractFileName(Application.ExeName), '.');
+ FINIFilename := Copy(FINIFilename, 1, Length(FINIFilename)-1) + 'SQL.INI';
+ {End !!.11}
+ Refresh;
+end;
+{--------}
+procedure TffeSQLConfig.ParseWindowString(aWindowStr : TffShStr);
+type
+ TElement = (teLeft, teTop, teRight, teBottom);
+var
+ J : TElement;
+ Element : TffShStr;
+begin
+ try
+ J := teLeft;
+ repeat
+ FFShStrSplit(aWindowStr, ' ', Element, aWindowStr);
+ case J of
+ teLeft : FWindowRect.Left := StrToInt(Element);
+ teTop : FWindowRect.Top := StrToInt(Element);
+ teRight : FWindowRect.Right := StrToInt(Element);
+ teBottom : FWindowRect.Bottom := StrToInt(Element);
+ end;
+ if J < High(J) then Inc(J);
+ until aWindowStr = '';
+ except
+ end;
+end;
+{--------}
+procedure TffeSQLConfig.Refresh;
+var
+ Window : TffShStr;
+begin
+ with TINIFile.Create(FINIFilename) do begin
+ try
+ {get the window settings}
+ FWindowState := TWindowState(ReadInteger(FINISection,
+ sqlCfgWindowState,
+ Ord(defWindowState)));
+ Window := ReadString(FINISection, sqlCfgWindow, '');
+ if Window <> '' then
+ ParseWindowString(Window);
+ {get the font settings}
+ FFontName := ReadString(FINISection, sqlCfgWindowFontName, '');
+ FFontSize := ReadInteger(FINISection, sqlCfgWindowFontSize, 8);
+ {get the height of the SQL window}
+ FSplitterPos :=
+ ReadInteger(FINISection, sqlCfgSplitterPosition, 129);
+ finally
+ free;
+ end;
+ end; {with}
+end;
+{--------}
+procedure TffeSQLConfig.Save;
+begin
+ with TINIFile.Create(FINIFilename) do
+ try
+ try
+ with FWindowRect do
+ WriteString(FINISection, sqlCfgWindow, Format('%d %d %d %d', [Left, Top, Right, Bottom]));
+ WriteString(FINISection, sqlCfgWindowFontName, FFontName);
+ WriteInteger(FINISection, sqlCfgWindowFontSize, FFontSize);
+ WriteInteger(FINISection, sqlCfgWindowState, Ord(FWindowState));
+ WriteInteger(FINISection, sqlCfgSplitterPosition, FSplitterPos);
+ finally
+ Free;
+ end;
+ except
+ on E:Exception do
+ ShowMessage('Error writing INI file: '+E.Message);
+ end;
+end;
+{--------}
+procedure TffeSQLConfig.SetWindowPos(aRect : TRect);
+begin
+ with FWindowRect do begin
+ Left := aRect.Left;
+ Right := aRect.Right;
+ Top := aRect.Top;
+ Bottom := aRect.Bottom;
+ end;
+end;
+{====================================================================}
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffabout.dfm b/components/flashfiler/sourcelaz/ffabout.dfm
new file mode 100644
index 000000000..bf42ffec7
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffabout.dfm
@@ -0,0 +1,1281 @@
+object FFAboutBox: TFFAboutBox
+ Left = 330
+ Height = 312
+ Top = 180
+ Width = 398
+ BorderStyle = bsDialog
+ Caption = 'About TurboPower FlashFiler'
+ ClientHeight = 312
+ ClientWidth = 398
+ Color = clBtnFace
+ Font.Color = clWindowText
+ Font.Height = -11
+ Font.Name = 'MS Sans Serif'
+ OnActivate = FormActivate
+ OnMouseMove = FormMouseMove
+ Position = poScreenCenter
+ LCLVersion = '1.6.1.0'
+ object Bevel2: TBevel
+ Left = 6
+ Height = 17
+ Top = 265
+ Width = 387
+ Shape = bsTopLine
+ end
+ object ProgramName: TLabel
+ Left = 152
+ Height = 16
+ Top = 8
+ Width = 74
+ Caption = 'FlashFiler '
+ Font.Color = clWindowText
+ Font.Height = -13
+ Font.Name = 'MS Sans Serif'
+ Font.Style = [fsBold]
+ ParentColor = False
+ ParentFont = False
+ end
+ object VersionNumber: TLabel
+ Left = 152
+ Height = 13
+ Top = 25
+ Width = 35
+ Caption = 'Version'
+ Font.Color = clWindowText
+ Font.Height = -11
+ Font.Name = 'MS Sans Serif'
+ ParentColor = False
+ ParentFont = False
+ end
+ object Label3: TLabel
+ Left = 153
+ Height = 13
+ Top = 53
+ Width = 164
+ Caption = 'TurboPower FlashFiler home page:'
+ ParentColor = False
+ end
+ object lblTurboLink: TLabel
+ Cursor = crHandPoint
+ Left = 161
+ Height = 13
+ Top = 69
+ Width = 199
+ Caption = 'http://sourceforge.net/projects/tpflashfiler'
+ Font.Color = clHighlight
+ Font.Height = -11
+ Font.Name = 'MS Sans Serif'
+ ParentColor = False
+ ParentFont = False
+ OnClick = lblTurboLinkClick
+ OnMouseMove = lblTurboLinkMouseMove
+ end
+ object Label9: TLabel
+ Left = 153
+ Height = 13
+ Top = 93
+ Width = 218
+ Caption = 'Released under the Mozilla Public License 1.1'
+ ParentColor = False
+ end
+ object Label10: TLabel
+ Left = 161
+ Height = 13
+ Top = 108
+ Width = 46
+ Caption = '(MPL 1.1)'
+ ParentColor = False
+ end
+ object Label11: TLabel
+ Left = 7
+ Height = 13
+ Top = 273
+ Width = 273
+ Caption = '(C) Copyright 1996-2002, TurboPower Software Company.'
+ ParentColor = False
+ end
+ object Label12: TLabel
+ Left = 7
+ Height = 13
+ Top = 289
+ Width = 86
+ Caption = 'All rights reserved.'
+ ParentColor = False
+ end
+ object Label4: TLabel
+ Left = 152
+ Height = 13
+ Top = 131
+ Width = 93
+ Caption = 'Online newsgroups:'
+ ParentColor = False
+ end
+ object lblNewsGeneral: TLabel
+ Cursor = crHandPoint
+ Left = 168
+ Height = 13
+ Top = 146
+ Width = 224
+ Caption = 'http://sourceforge.net/forum/?group_id=72211'
+ Font.Color = clHighlight
+ Font.Height = -11
+ Font.Name = 'MS Sans Serif'
+ ParentColor = False
+ ParentFont = False
+ OnClick = lblNewsGeneralClick
+ OnMouseMove = lblTurboLinkMouseMove
+ end
+ object Panel1: TPanel
+ Left = 6
+ Height = 251
+ Top = 6
+ Width = 139
+ BevelOuter = bvLowered
+ ClientHeight = 251
+ ClientWidth = 139
+ TabOrder = 0
+ object Image1: TImage
+ Left = 1
+ Height = 249
+ Top = 1
+ Width = 137
+ Align = alClient
+ Picture.Data = {
+ 07544269746D6170628C0000424D628C00000000000036040000280000008900
+ 0000F900000001000800000000002C8800000000000000000000000100000001
+ 0000000000000000800000800000008080008000000080008000808000008080
+ 8000C0DCC000F0CAA600AA3F2A00FF3F2A00005F2A00555F2A00AA5F2A00FF5F
+ 2A00007F2A00557F2A00AA7F2A00FF7F2A00009F2A00559F2A00AA9F2A00FF9F
+ 2A0000BF2A0055BF2A00AABF2A00FFBF2A0000DF2A0055DF2A00AADF2A00FFDF
+ 2A0000FF2A0055FF2A00AAFF2A00FFFF2A000000550055005500AA005500FF00
+ 5500001F5500551F5500AA1F5500FF1F5500003F5500553F5500AA3F5500FF3F
+ 5500005F5500555F5500AA5F5500FF5F5500007F5500557F5500AA7F5500FF7F
+ 5500009F5500559F5500AA9F5500FF9F550000BF550055BF5500AABF5500FFBF
+ 550000DF550055DF5500AADF5500FFDF550000FF550055FF5500AAFF5500FFFF
+ 550000007F0055007F00AA007F00FF007F00001F7F00551F7F00AA1F7F00FF1F
+ 7F00003F7F00553F7F00AA3F7F00FF3F7F00005F7F00555F7F00AA5F7F00FF5F
+ 7F00007F7F00557F7F00AA7F7F00FF7F7F00009F7F00559F7F00AA9F7F00FF9F
+ 7F0000BF7F0055BF7F00AABF7F00FFBF7F0000DF7F0055DF7F00AADF7F00FFDF
+ 7F0000FF7F0055FF7F00AAFF7F00FFFF7F000000AA005500AA00AA00AA00FF00
+ AA00001FAA00551FAA00AA1FAA00FF1FAA00003FAA00553FAA00AA3FAA00FF3F
+ AA00005FAA00555FAA00AA5FAA00FF5FAA00007FAA00557FAA00AA7FAA00FF7F
+ AA00009FAA00559FAA00AA9FAA00FF9FAA0000BFAA0055BFAA00AABFAA00FFBF
+ AA0000DFAA0055DFAA00AADFAA00FFDFAA0000FFAA0055FFAA00AAFFAA00FFFF
+ AA000000D4005500D400AA00D400FF00D400001FD400551FD400AA1FD400FF1F
+ D400003FD400553FD400AA3FD400FF3FD400005FD400555FD400AA5FD400FF5F
+ D400007FD400557FD400AA7FD400FF7FD400009FD400559FD400AA9FD400FF9F
+ D40000BFD40055BFD400AABFD400FFBFD40000DFD40055DFD400AADFD400FFDF
+ D40000FFD40055FFD400AAFFD400FFFFD4005500FF00AA00FF00001FFF00551F
+ FF00AA1FFF00FF1FFF00003FFF00553FFF00AA3FFF00FF3FFF00005FFF00555F
+ FF00AA5FFF00FF5FFF00007FFF00557FFF00AA7FFF00FF7FFF00009FFF00559F
+ FF00AA9FFF00FF9FFF0000BFFF0055BFFF00AABFFF00FFBFFF0000DFFF0055DF
+ FF00AADFFF00FFDFFF0055FFFF00AAFFFF00FFCCCC00FFCCFF00FFFF3300FFFF
+ 6600FFFF9900FFFFCC00007F0000557F0000AA7F0000FF7F0000009F0000559F
+ 0000AA9F0000FF9F000000BF000055BF0000AABF0000FFBF000000DF000055DF
+ 0000AADF0000FFDF000055FF0000AAFF000000002A0055002A00AA002A00FF00
+ 2A00001F2A00551F2A00AA1F2A00FF1F2A00003F2A00553F2A00F0FBFF00A4A0
+ A000808080000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFF
+ FF00000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000F00700000000
+ 0000F5F000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00000000000031FFF100002DF507F6F100000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000312DF6550031FF2D86080000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000000000000000000000000000000000F12D000031FFF5AF
+ 083107F6F1F60700000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000007FFF5002DFF55F7FF3107082DFFAFF0F7F6F52D31F0000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00000000000000000000000000000000F008D10731868631F6F582F707FF3131
+ FF55F5F6AFF10000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00000000000000000000000000000000000000000000000000000000310008FF
+ 822DF62DAFF1AA31AAF7F0F6072DF686F0000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00000000000000F0FFF7F009FFF1083186078631AFF5AAF7F5AFFF0700000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000000000000000000000000007FFF7F00882078207868207
+ AA82862DF6F607F5F52D00000000000000000000072D00000000002DF7088231
+ 0000002D07000000F007F52D070707310000000000000782088207F00000002D
+ 070000000000000000F05982088207F00000000000002DF10000000000310000
+ 0000F0070707070707F03131000000F0072D00000000000000000000F0F50000
+ F131D182F008AA0807FF8282088231AF5AF02D86F6F6F5000000000000000000
+ F6F70000000007FFAF8208FF820000AAF600000008F6F108FFAFAFF608F10000
+ 31F6F6088208F6AF31000007FF000000000000002DAFFF088208F6D131000000
+ 0000AA0700000000F0F6F1000000F5FFB3F6AFF6AFF082F600000008F6F10000
+ 0000000000000000F5F6D407F631F08608F186FF07865586D431D4075508F686
+ 55F52D310000000000000000FFF7000000F1F6F700000031FF310086080000F7
+ FF2D0008AA0000F5F6080031FF86F1000000F5AAFF2D0007FFF0000000000031
+ FF08F1000000F186FF31000000F0FF080000000031FFF7000000F4FF55000000
+ 000086AB000007FF2D0000000000000000000000000786F6FFFFF7F4F7AA2D82
+ 2D000000F008F68682072D3107AFFFF60700000000000000F60700000007FFF0
+ 0000000008080082AF00F5F6070000088200000007F6F0F6AA00000000000000
+ 08AF0007FF000000000000AF080000000000000008D100000007FFFF2D000000
+ AAFF08000000F5F63100000000008208002DFF07000000000000000000000000
+ 00F031F52D0782D408AF080000000000002D0707F786AFFFFF0831F500000000
+ 00000000F60700000086D10000000000F7F6008208F0AF860000000882000000
+ F7AF07F6F5000000000000002DFF3131FF000000000031F62D00000000000000
+ F5FF550000AF8208F70000F5F6F7FF310000F5FF310000000000820800080800
+ 000000000000000000000000002DFFFF08F7073155F7F70000000000000086D1
+ 86072D2D313100000000000000000000F6F70000008208000000000007F600F7
+ AFAAFF310000000886F0F507FF0782D1000000000000000000F60707FFF70731
+ F000F7F6000000000000000000AF820031FFF507FFF00007F60008860000F5FF
+ 310000000000F7AFAAFF31000000000000000000000000000000310707F78686
+ 82F731000000000000000782868282F707312D000000000000000000F65A0000
+ 0082AF000000000007FF0082FF0808F682000086FFF6F6FF0700860800000000
+ 0000000000AFF731FF08AFF6AFF0F7AF00000000000000000008860086AF00F0
+ FF3100F6F70007FFF100F0FF08A68682860082FF0808F6820000000000000000
+ 000000000000005531312D0786D1F70000000000000082F7313107F708F6FFF5
+ 0000000000000000F6070000008608000000000007FF00860800002DFF070008
+ AAF131AF310082F6000000000000000000FF0707FFF000F5088207F600000000
+ 0000000000F607F0FF07000008AA31FFF500F0FF0700F5F60882868682008208
+ 00002DF6070000000000000000000000F0F531AFFFFFAF82F707072D00000000
+ 00F0AFAFAA0886072D2D31F10000000000000000F6F700000082AF0000000000
+ 07F60082AF00000082AA000882000007F60031FF2D0000000000000031FFF555
+ FF00000007AF31FF31000000000000002DFF2D55FFF0000031F6AF0800000086
+ AF00F5FF310000000000820800000082080000000000000000000000F7FFFF08
+ 07312D078286D186F00000002D8631AA07F582FFFFF682310000000000000000
+ F6070000008208000000000007FF008208000000088600AB86000007FF0000AA
+ D4F00000000000F0AF080007FF00000007F600AAAFF00000000000F0080800AF
+ 8600000000AFFF3100000031F62DF0FF31000000000082AF0000008686F02D2D
+ 000000000000000000312DF15586F60831820831AFF7558607D1082D0882F007
+ AFF708F6F00000000000F0F0D1F700F00086AF000000000007FF0082AFF0F107
+ FF31000886002DAF820000F5F6082D0000002DAFF6F00007FFF0F031FF8200F1
+ F6D42D0000002D08F6F1F5FF3100000000F7F6F000000000AF82F5F60700F000
+ F000820800F107FF072D07350000000000000000000031F6FFF7F5F0F70831AA
+ AF0786D1318682D42DAAAF2DF40000F5F00000000082F6FFFFFFF6FF2DF70800
+ 0000000007F600F7F6F6FFFF07000086FFF6F686F0000000F5AAFFF608F6F686
+ F1000007FFF6F6FF82F00000F008FFF608F6F608F100AAF600000000002D5E00
+ 0000000007FF31F6FFF6FFF6D1F5F7F6F6FFFF07003107550000000000000000
+ 00000031F52DF7F6082908078655820807AA318608F182FF0700000000000000
+ 002D313131313131F0F52D0000000000F13100F531312DF00000002D3131F100
+ 0000000000002D07F7072D00000000F031312DF0000000000000F507F7072D00
+ 000031F5000000000000F00000000000F031F52D313131313100F531312DF000
+ 0000F5000000000000000000000000000007F6AFF586862DAF318607860786F0
+ FF08F0F7FF000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00000000000000000000000000000000000000000000000000000000F008AFF4
+ F7F6F08682078231AF31F6F1F7F6AFF131000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00000000000000F4AFF6F107FF2D31FF07F7F72DFF2D08F7F507F608F0000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00000000000000000000000000000000000000F155F531FF07F1AFF62DAF0707
+ F60707FFF000F1F6310000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000F000F007F62DFF3159AFAAF5F62D0000F5F00000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000000000000000000000088231F62D0055FFF53100000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000F5FF31
+ F5F50000F5FF3100000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000F0F50000000000F0070000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000A0C2A0A0A0A0C29CC2A09CC29CA09CBEA09C9CC29C9CA0BEA09CBEA09C9C
+ BE9CBEA0BEA0BE9CBE9CC29CBEBEA0BE9CA0BE9C9CBE9CBE9CBE9CBE9CBE9CBA
+ 9C989CBE989C98BE98989C9898989C9CBFA1A5C6A5A5C7A5C6A5C6C7C6A5C7A9
+ C6CBA5C7C6C6A4C2A1C2A1C3A0A0A19C9CBFA09C9C9C98989C98987498947494
+ 7470747074707474707494000000A1A0A1A0C2A0A1A09CC2A09CA0BE9CA09CC2
+ 9C9CA0BE9C9C9CBE9CBE9CBE9C9C9CBE9C9CC29CC29C9CBEA09CBE9C9CBE9C9C
+ BE9CBE9C9CBE9C9CBE9C9C9C9CBE989C98BE9898BE98989C989898989C9CC3A1
+ C6A5C7A5A5C7A5C7A5C7C6C7A5C7C6CBA5C7C7A5C6C7A1A0A1C3A0C3A1A09D9D
+ BF9D9C9C99989898987494749474707470747070747074000000A0A0A0A0A0A0
+ C2A0A09CC29CA09CA0BE9C9CA0BE9C9CBE9C9C9C9C9C9C9CBE9CBE9CBE9CBE9C
+ 9CC29C9CBEA09CBE9CBEA0BE9CBE9CBE9C9CBE9C9CBE9CBE9C9CBE9C9C989C9C
+ 989C98BA9C9898BA98989CBFA1C7A5C7A5C7A5A5C6A5C7A4C7A5CBC7CAA5C6CB
+ A5C6C6C7C2A1C3A0C2A1C2A09CA19C9C9C989898989874987498709870749474
+ 707470000000A0A1C2A1A0A0A0A0BEA09CA09CC29C9CA09CBE9C9CBE9C9CBE9C
+ BE9CBE9C9C9C9C9C9C9C9CBE9C9CBE9CBE9CBEC29C9CBEBE9C9CBE9CBE9C9CBE
+ 9C9CBE9C9CBA9C9CBA9CBA9CBA9C989C98BA9C989C98BE9C9CC2A5A5C7A5C7CB
+ A5C7A4A5C6C7A4C7A5CBC7A5C6C7A5C6A5C6C3A1C3A0A1C3A19CA19D9C9C9898
+ 989898947494747074707470947498000000A1A0A0A0A0C29DA0A0A09CC29C9C
+ A09CBE9C9C9C9C9C9C9C9C9C9C9C989C9CBE9C9CBE9CBE9C9CBE9CC29CC29C9C
+ 9CBE9C9C9CBE9CBE9CBE9CBE9CBE9C9CBE9C9CBA9C9C9C989C98BA9C989C989C
+ 989C989CBE9DC3C2C7A5C7A5A5CBA5C7C7A5C7C6C7C6A5CAC7A9C6A5CBC6A5C6
+ A0A1C3A0A0C29D9C9C9D9898989898749874709870987098749894000000A0A0
+ A1A0A1A0A0C29C9CA09CC29C9C9C9C9C9C9C9C9C9C9C989C9C9C9C9C9C9CBE9C
+ 9C9C9C9CBE9CBE9C9CBEBEA0BEA0BE9CC29CBE9C9C9CBE9C9C9CBE9C9CBE9C9C
+ BE9CBA9CBE9C9C9CBE9C98BE98BE9C989C9C9CA1A1C7A5C7C7A5C7A5A4C7A4C7
+ A4C7C6A5C6C7CBC6C7A5CBA5C7C7A4C3C3A1A0A1BE9C9C989898989874949870
+ 98749474947498000000A0C3A0A0A09DA0A0A1C29CA19CA09C9C9C9C9C9C9C9C
+ 9C9C9C9C989C989C989C9C9CBE9CBE9C9C9C9CBE9C9CBE9CBE9CBE9CBE9C9CBE
+ BE9C9CBEBE9C9CBE9C9CBE9C989C9C9C98BE989C98BE9C9C9C989CBE9CBE9CBE
+ 9CC3A4A5C7A5C7C7C7A5C7A5C7A5C7C7A5C6C7A5CAC6C7C6A9C6C7A4A0C3C2A1
+ 9DA09D9C9C9898989874987494749898989898000000A1A0A0A1C2A0A09CA09C
+ A09C9C9C9C9C9C9C9C9C989C9C989C989C989C989C989C989C9C9C9CBE9CBE9C
+ BE9C9CBE9C9CBE9C9CBEBE9C9CBE9C9C9CBEBE9C9CBE9C9CBE9CBE98BE9C9CBE
+ 9C989CBA9CBE989C989C9C9C9D9CC3C3A5C7A5A5A5C7A5A4C7A4C7A4C7C7A4C7
+ C7A5CBA5CBA5C6C7C7A4A1C2A0BF9C9C9D9C9898989898989898989898989800
+ 0000A0A0A1A0A0A19CA1A09CA19CA09C9C9C9C9C9C9C9C9C989C989C989C989C
+ 989C9C9C9C9C9CBE9C9C9C9C9C9CBE9C9CBE9C9CBE9C9C9CBE9CBE9CBE9C9C9C
+ BE9C9CBE9CBE9CBE9C9CBE989CBE9C9C9C9C9CBE9CBE9CBE9CBE9D9CA1C3A5C7
+ C7A4C7C3A4C7C6A1C6A4C7C6A5C6C6C7C6C7CBC7A4C6C6C6A1A09D9C9C9C9C98
+ 9898989898989898989898000000A0A1A0A0A1A0A0A09CA09C9C9C9C9C9C9D9C
+ 989C989C989C9898987498989C98989C989C9C9C9CBE9CBE9CBE9C9CBE9C9CBE
+ 9CBE9CBE9CBE9CBE9C9CBEBE9C9CBE9C9C9C989C9CBA9C9CBE9CBA9CBE98BE98
+ 9C989C9C9C9C9C98BE9CC3A0A5C3A4A5C7A1A5C6A5C7A4C7C6A5C7C6A9C6A5CA
+ C7C7C6A5C6C6A0A0BF9C9D9C9898989898989898989898000000A1A0A1A0A09D
+ A09DA09DA09C9C9C9D9C9C9C9C9C9C989C989C98989C9898989C98989C989C9C
+ 989C9C9C9C9CBE9C9CBE9C9CBE9CBE9C9C9CBE9CBE9C9C9CBEBE9CBE9CBE9CBE
+ 9C9CBE989C9C9CBE9C9C9CBE9CBE989CBE989C9C9C989CBF9CA1C3C2A1C6C3A1
+ C6A1C6A5C7C6A5C7C6C7CAA5CAA5CAC7C6C7C6C6A0A0BE9C9C989C989898989C
+ 989898000000A1A0A0A19CA0A09CA09C9C9C9D9C9C9C9C9C9C989C989C989874
+ 9898989C98749C98989C9C989C9C989CBE9C9C9CBE9CBE9C9C9C9CBEBE9CBE9C
+ 9CBE9CBE9C9C9C9CBE9CBE9C9CBE9C9CBE9CBE989CBE989C989C9CBA9C9CBA98
+ 989898989CBE9CA1C2A1A4C2A5C2A5C2A4C7C6A4C7A4C7C6C7CBC7A8C7A8C7CA
+ C6C6A09CBE9C98989C989898989898000000A0A0A1A0A0A19CA19C9C9D9C9C9C
+ 9C9C9C989C9C98989C989C989C9898749898989C989C98989C98BE9C9C9CBE9C
+ 9C9C9C9CBE9CBE9C9C9C9C9CBE9CBE9C9CBE9CBE9C9C9C98BE9C98BE9C989C9C
+ BE989C9CBE9CBA9C9898989C9898989898989CBFA0A1C2C3A1C6A1C6A1C7A4C7
+ C7C6C7A5CAC7A8C7CAC7CAC6C7C6CAC6A0A09C9CBE989C98989C98000000A0A1
+ A09CA19CA09C9D9C9C9C9C9C9D9C9C9C9D989C9C987498987498789874989898
+ 9898989C989C9C9CBA9C9CBE9CBE9CBE9CBE9CBE9CBE9CBE9C9C9CBE9C9CBE9C
+ 9CBEBE9C9CBE9C9CBE9CBE989C9CBE989C989C98989CBA989C98989898989898
+ 9CBEA1A0C2A1C2A1C6A0C7A4C6A5C6C6A5C6CBC6CBCAA5CBA8CBC6CAC6C6C6A0
+ 9C9C9C9C9C9898000000A1A0A1A09CA19CA09CA19C9C9D9C9C9C9D9C9C9C989C
+ 989C9878989898989898749898989C989898989C9C9C9C9C989C9C9C9C9C9C9C
+ BE9CBE9CBE9CBE9CBE9C9CBE9C9C9CBE9C9CBE989CBE9CBE9C989C9CBA9CBA9C
+ BA989C9898989898989898989898BEA1A0C3A0C7A1C6A1C7A4C7A5C6C6A9C7CB
+ A4CBCACACBCAA9CACBCACAC6C6A0BE9C9C9C9C000000A0A19CA1A09C9C9D9C9C
+ 9C9D9C9C9C9C9C9C9C989C749C7498987498749874989898989898989C9C9C98
+ 9CBA9C9C9C9CBE9CBE9CBE9C9C9C9CBE9C9CBE9C9CBE9C9CBE9CBE9CBA9C9C9C
+ BE9C989C98BE9CBA9C989C989C9C9898BE9898989898989898989898BEA1A0C2
+ A0C3A4C2A5C6C6C7A5C6C6CAC7CBA5CBCACBCACBCAA8CACBCACAA4C29C9CBE00
+ 0000A1A0A1A09DA09DA09C9C9D9C9C9D9C9D9C9C989D9C989D989C7499749874
+ 9898749898989C989C98989C9C9C9CBA9CBE9C9C9CBE9C9CBE9CBE9C9CBE9C9C
+ BE9C9CBE9C989CBE9C9C9CBE989CBE9CBE9C989C989CBA9C98BA989C98989898
+ 9898989898989898989CBEA1C2A1C2A5C2A5C7A4C6C6A9C7A9CACBCAA9CACBCA
+ CBCACBCACACACACAC6C6A0000000A0A1A09DA0A19C9C9D9CA09D9C9C9C9C9C9D
+ 9C9C749C749874989C989899749898989C98989C989C9C989C989C9C9C989CBE
+ 9C9CBE9C9CBE9C9CBE9C9CBE9C9CBE9C9CBE9C9C9CBE989CBE989C989C98BE9C
+ BA9C989C989CBA98989CBA9898989898989898989898989CA1C2A1C2C7A0C6C7
+ A5C7C6C6CAC7CACBCBCACBA8CBCACECBA8CBCECACAA8C6000000A1A0A1A0A19C
+ A1A09C9D9C9C9C9D9C9C9C9C9C9C9C989C789C749874989898989C9898989C98
+ 9C989C9C989C989C9C9C9C9CBE9C9CBE9C9CBE9C9CBE9C9CBE9C9CBE9C9CBE9C
+ 9C9CBE989CBE9CBE9C9C989C9CBA9CBA9C989C98BA989C989898989898989898
+ 989898989C9CC2A0A0C7A0C6C6A5CBC7A4CBC6A9CACBCACBCACBCACFCACBCACF
+ CACACA000000A0A1A0A09DA09D9CA19C9DA09DA09C9D9C9C9D989C7998989898
+ 989898749C749898989C989C989C98989C989C98BE9C9CBE9C9CBE9CBE9C9CBE
+ 9C9CBE9C9C9CBE9C9CBE9CBE98BE9C9CBE989C989CBA9CBE989C989C98BE989C
+ 98989898BA989898989898989898989898989CC3A0C2C7A4C7C6C6C6CBC6A9CA
+ CBA8CBCACFA8CFCACBCECBA8CECBCE000000A1A0A1A1A0A1A0A19C9CA09C9C9C
+ 9C9C9C9C9C9C78989C9878999C749898989898989C989C989C989C9C989C9C9C
+ 989CBE9C9CBE9C9C9C9CBE9C9CBE9C9CBEBE9C9CBE9C989C9C9CBE9C989C9CBE
+ 9C9C9C989C98BE98BA9C98989C98BA989C98989898989898989898989498989C
+ BEC3A0C7C6A4C7A9CAC6CBCBC6CBCACBCACBCAA9CEADCACFCFCACB000000A09D
+ A0A0A1A09DA0A1A09D9CA19C9D9C9D9C9C989C98749C9874989C74989998989C
+ 98989C989C989C989C9CBA9CBE9C9C9CBE9C9CBE9CBE9CBEBE9CBE9C9C9CBE9C
+ 9CBE9CBE9CBE98BE9CBE989CBA9CBA9CBA9C989C9C989C98BA9C989898989898
+ 989898989898989898989898989CC2A0C6C7C6C6C7A9CACACBCAA9CACBCECBCE
+ CBCBCFCECACBCE000000A0A0A1A0A1A0A1A09CA1A0A09CA09C9C9C9C9D9C9C9C
+ 9D989C9C9C749C9878989C989C989C98989C989C989C9C9C9CBE9C9C9CBE9C9C
+ BE9C9C9C9C9C9CBE9C9C98BE9C9CBE9C989C9C989C98BE9C9C989C9C989CBE98
+ 9CBA989C98989CBA9898989898989898989898989898989898989CC2A5C6C7C6
+ CAC6CBA8CBCACACFCACBCACBCECACFA9CFACCB000000A0A1A0A19CA19CA1A0A1
+ 9CA19C9D9C9C9C9C9C9C9C989C9C7498749898749898989C989C989C9C989C98
+ 9CBE9CBE9C9CBE9CBE9C9CBE9CBE9CBE9CBE9C9CBE9CBE9C9CBA9C9CBE9CBE9C
+ BE9C9C98BE9CBA9CBE989C989C989CBA9C989898989CBA989898989898989898
+ 9898989498989898C2C2A4C6C7CAC7CACACBCBCACBACCBCECBADCACFCACBCF00
+ 0000A0A0A0A0A0A0A1A0A19CA0A09CA09C9D9C9C9C98789C74989C759C987998
+ 9C989C989C989C9C989C9CBE9C9C9C9C9CBE9C9C9C9CBE9C9C9CBE9C9C9C9CBE
+ 9C9C9C9CBE9C9CBE989C989C989CBA9C9C989C9C989C98BE98BE989C9898BA9C
+ 9898989898989898989898989898989898989498989CC2C7C6CACACACBCACACA
+ CBCACBA8CFCACFCACFACCF000000A1A0A1A0A1A0A0A0A0A0A19CA09D9C9C9C9D
+ 9C9C989D9878989874989898989C989C989C989C9C989C9C9CBE9CBE9C9C9CBE
+ 9CBE9CBE9CBE9C9CBEBE9C9CBE9CBE989C9CBE9CBE9CBE9CBE9C9CBA9CBE98BA
+ 9CBE989C989C9898BA9C9898BA98989898BA9898989898989898989898989898
+ 949898C2C6C7C6CBCACACBCBCACBCECFCACFCAADCFCBCF000000A0A0A0A0A0A1
+ A0A1A0A09CA19CA09C9C9C9C9C9D78987898789C98749C9C999C98989C989C98
+ 9CBE9CBE9C9C9C9CBE9CBE9C9C9C9C9CBE9CBE9C9C9CBE9C9C9C9CBE9C9C989C
+ 9C9C989C9CBA9C9C989C9C9C989C98BE989C9C9C98989C989C989CBA98989898
+ 989898989898989898989898989898989CC2C6C6CBCACACACFCACBCACFCACFCA
+ CFACCF000000A0A1A0A1A0A0A0A0A0A1A0A0A09CA19C9C9C9C78987898787598
+ 789C98989C989C9C989C9CBE9C9C9C9C9CBE9CBE9C9C9CBE9CBE9CBE9C9C9CBE
+ 9CBE9C9CBE98BE9C9CBA9CBE98BE9CBE989C98BE9CBA98BE989C9C989CBA9898
+ BA9C98BA989898989C98989898989898989898989898989898989498989CC2C7
+ C6C6CBCACACACFCAADCACFADCBCFCF000000A0A0A0A0A0A1A0A1A0A0A0A09DA0
+ 9C9C9D9C78987898797498989D98989C9C9C9C989C9C9C9C9C9CBE9CBE9C9C9C
+ 9C9CBE9C9C9CBE9C9C9CBE9C9C9C98BE9C9C9C9CBE9C9C9CBE9C9C989C9CBE9C
+ 989C9C9C9CBA98BE98989C989C989C989C989898989898989898989898989898
+ 98989898989898989894989CC2C7CACBCACBCECBCACFCBCACFCFA9000000A0A5
+ A0A1A0A0A0A0A0A1A0A0A09CA09C9C9C9C9D7874989C9C78989C9C9C989C989C
+ BE9C9C9CBE9C9C9C9C9CBE9CBE9C9C9CBE9C9C9CBE9C9CBE9CBE9C9CBE9CBE98
+ 9C9CBE989C98BE9CBE989C98BE9CBA98989C9C989C9CBA9C98BA989898BA9C98
+ 98BA9C9898989898989898989898989898989898989898989CC2C6C6CBCACBCA
+ CFCAADCFACCFCF000000A0A0A0A0A0A1A0A0A0C2A0A1A0A09DA09C9C789C9C78
+ 747498989C989C989C9C9C9C9C9CBE9C9CBE9CBE9C9C9C9C9CBE9CBE9CBE9CBE
+ 9C9CBE9C9C9CBE9C9C989CBE9C989CBE9C9C989C9CBE989C989C9C9CBE989C98
+ BA9C98989C989C989C9898989898989898989898989898989898989898989898
+ 98989898989C9DC2CBCACBCACBCFCACFCBADCF000000A0A5A0A5C2A0A4C3A0A1
+ A0A0A09CA09C9C9D9C9C789D9C9C9D9C9C9C9C9C9C9C9C9C9C9C9C9C9C9C9C9C
+ 9CBE9CBE9C9C9C9C9C9C9C9C9CBE9CBE9CBE9CBE9CBE9C9C9CBE9C989CBE9CBE
+ 989C9CBE9CBA9CBA9C98BE9C9C989CBE989C98BA98989CBA9C98989898989898
+ 9898989898989898989898989898989898989C9CC2C6CBC6A9CACFCBCECFCB00
+ 0000A4A0A0A0A0A0A1A0A0A0A0A0A1A0A09CA09C9C9C9C9C9C9C9C9C9C9C9C9C
+ 9C9C9C9CBE9CBE9CBE9C9CBE9C9C9C9C9C9CBE9CBE9CBE9CBE9C9C9C9C9C9C98
+ 9C9CBA9CBA9C989CBE989C989C9CBA9C989C989C989C989898BE989898989898
+ 9C989898989898989C989898989898989898989898989898989898989C9C989C
+ 9CC3C2CBCBCACBACCFADCF000000A0A0A5A0A5A0A0A0A0A0A1A0A0A09CA19C9C
+ 9C9D9C9C9C9C9C9C9C9C9C9C9C9C9C9C9C9C9C9C9CBE9C9CBE9CBE9CBE9C9C9C
+ 9C9C9C9C9C9CBE9CBE9CBE9CBE9C9C9C9C9CBE989C9CBE9CBA9C9C989CBE989C
+ 9CBA9C9C9C989C989CBA9C9898989C989C9C9D9C9C9C9D9C9C9D9C9C9C9C9C9C
+ 9D989898989C989C989C9C9C989C9CC2C6CBCBCBCFCFCA000000A5A0C2A0A0A1
+ A0A0C3A0A0A0A09DA09CA09C9C9C9C9C9D9C9C9C9C9D9C9C9C9CBE9C9CBE9C9C
+ 9C9CBE9C9C9C9C9C9CBE9CBE9CBE9CBE9C9C9C9C9C989C9C98BE98BE989C9CBE
+ 989C989C9CBA9CBE989C9CBA989CBA98BA9C98BE989C989C9C9C9C9D9C9C9C9D
+ 9C9C9CA19C9C9D9C9D9C9D9C9C9C9C9C9C9D9C9C9C9C989C9C9C9C9C9CC2CACA
+ CBCACF000000A4A5A0A4A0C6A0A0A0A0A0A1A0A0A09CA09DA09CA19C9C9C9C9C
+ 9C9C9CBE9C9C9C9C9C9C9CBE9C9C9C9CBE9C9CBE9C9C9C9C9C9C9C9C9CBE9CBE
+ 9CBE9CBA9C9C9C9C9CBE989C9CBE98BE989C989C98BE989C9C989C9C9C9C9C9C
+ 9C9C9C9C9C9C9D9C9C9D9DA09D9D9D9D9D9D9DA1A19D9D9D9D9DA19DA19C9C9D
+ 9C9C9C9C999C989D9C9CC3C6CACBCA000000A5A4A4A1A0A0A1A0A0A1A0A0A0A0
+ 9CA19CA09C9C9C9CA09CA19CA09C9C9C9C9C9C9C9C9C9C9C9CBE9C9C9C9CBE9C
+ 9CBE9C9CBE9CBE9CBE989C9C989C9C9C9CBE9CBA9C989CBA9C989C9C9C98BE9C
+ 989C989CBA9C9C9C9C9C9D9C9C9D9C9D9C9D9CA19DA1A09DA1A1A1A1A1A1A1A1
+ 9DA1A1A1A1A1A1A1A1A19D9C9C9C9C9C9C9C9C9C9C9C9C9CC3C6CA000000A5A5
+ A5A4A4A0A0A0A0A0A0A0A1A0A0A0A09CA0A09CA09C9C9C9C9C9C9C9C9C9CBE9C
+ 9CBE9C9C9C9C9CBE9C9C9C9C9C9CBE9C9C9C9C9C9C9C9CBE9CBE98BE9C989C9C
+ 9CBE9C9C989CBA9CBA9C9C98BE989C9C9C9CBE9C9DBE9C9C9D9C9C9CA19CA19D
+ A09DA1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A19D9C9C9C989C9C98
+ 9C989C9C9CC3C6000000A5A9A5A5A5A4A5A0A1A0A0A0A0A0A09CA0A0BEA1A09C
+ A09CA09C9C9CA09C9C9C9C9C9C9C9CBE9C9C9C9C9CBE9C9CBE9C9CBE9CBE9CBE
+ 9CBE9C9C9C9C9C989CBE98BE989C98BE9C9C9C989C98BA9C9C9CBE9D9CA19C9D
+ A09DA19CA19DC39DA19DA0A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A2A1A2
+ A1A2A1A1A19D9D9C9C9C9C9C9C9C9C989C9C9C000000A9A5A9A9A5A5A4A0A0A0
+ A1A0A0A0A1A0A0A0A0A09CA09DA0BE9CA09C9CBE9C9C9C9C9C9C9C9C9C9CBE9C
+ 9C9C9CBE9C9C9C9C9C9C9C9C989C9CBA9C9CBE9CBE989C9C9CBA9C9C98BE9898
+ 9C9C9C9C9C9D9C9CA09DA0C3A0A1C2A1A0A1A0A1A0A1A1A1A1A1A1A1A1A1A1A1
+ A1A1A1A1A1A1A1A1A2A1A1A1A1A1A1A1A1A1A19C9D9C9C9D989C989D9C989C00
+ 0000A9A9AAA5A5A5A5A5A4A0A0A0A1A0A0A0A19CA09CA0C29CA09DA0BE9CA09C
+ A09C9C9C9C9C9C9C9C9C9C9CBE9C9C9C9C9CBE9CBE98BE9C9C9CBE9C9CBA9C9C
+ 989C9CBA9C989CBA9C989CBE9CBE9C9CBFA0A1C3A1C3A1A1A1A1A1A1C3A1A1A1
+ A1A19DA1A19DA1A1A1A1A1A1A1A1A1A1A1A1A1A17DA1A17EA1A2A1A2A1A19D9D
+ 9C9C9C9C9C9C9C9C9C9C9C000000AA85A9A9AAA9A5A5A5A5A0A0A0A0A0A0A0A0
+ A0A09DA09CA09C9CA19C9C9C9C9C9CBE9C9C9C9C9CBE9C9C9CBE9C9CBE9C9C9C
+ 9C9C9C98BE9C989C9C9C989C9CBE989C98BE989C989C9C9D9C9D9DA0A1A1A1A1
+ A1A1A1A1A1C3A1A1A1A1A1A1A1A1A19DA1A19DA19DA1A1A1A1A1A1A1A1A1A1A1
+ A1A1A1A1A17DA1A1A27DA1A19D9D9C9C9C9C9C989C989C000000AAAAAAA9A9AA
+ A9A5A5A5A5A0A1A0A1A0A0A19CA0A09CA09CA0A09CA0A09C9CC29C9C9C9C9CBE
+ 9C9C9C9C9C9C9C9C9C98BE9C9C9CBE9C9CBE9CBE989C9CBA9C9C9C9C9C9CBA9C
+ 9CBE9C9C9CA0C3A1A1C3A5C3A5C3A5C3A1A1A1A1A1A1A1A1A1A1A1A1A1A1A0A1
+ A1A19DA1A19DA1A1A19DA1A1A1A17DA1A1A17DA1A1A1A17DA1799D9C9D9C9C9C
+ 9D9C9C000000AAAAAAAAAAA9AAA9AAA5A5A5A4A0A0A0A09CA0A09CA09DA0BE9C
+ A0BE9C9CA09C9C9C9C9C9C9C9C9C9C9CBE9C9CBE9C9C9C9CBA9C9C9C989C9C98
+ 9CBE989C98BE98BA989C9C9C9C9C9CC3A1A1A1A1C7A5A1A5A1A1A1A5A1A5A1C3
+ A1A1A1A1A1A1A1A19CA19DA19DA1A1A19CA1A19DA1A1A19DA19DA19DA1A1A1A1
+ 7D9D7DA1A19DA19D9C9D9C9C9C9C9C00000008AA86AAAA86AAA9A9A9A9A5A5A5
+ A0A1A0A09C9DA0A09CA09CA0A09CA09C9C9C9C9C9C9C9C9C9C9CBE9C9C9C989C
+ 9CBE9C9C9C9C9CBA9C9C989C9C989C9C9C989C9C9C9C9C9D9CA1A1A1A1C7A5C7
+ A5C3A5C3A5C3A5C3A1C3A1A1A1C7A1A1A1A1A1A1A1A1A1A1A19DA19DA1A19CA1
+ A1A19DA1A1A1A1A17DA1A179A17DA1799D7DA1799DA09C9D9C9C9C000000AA08
+ AA08AAAAAAAAAAAAA9A9A5A5A5A4A1A0A0A09C9CA09CA09C9D9C9CA09CA09D9C
+ 9C9C9C9C9C9C9C9C9C9C9C9C9C9C98BE989C989C989CBE9CBA9C98BE989C989C
+ 9D9CBFA0C3A1C3A5C7A5A5A5A6A5A5A5A5A5A1A1A5A1A5A1A1A1A1A1C3A1A1A1
+ A1A1A19DA0A1A0A1A19DA19D9CA1A19DA19DA19DA19DA1A19DA19D7D7D9D79A1
+ 799D799C9C9C9C000000AA08AA0808AA08AAAAAAAAA9AAA9A5A5A4A1A0A0A19C
+ 9C9CA0A0A09CA09D9C9C9C9C9C9C9C9C9C9C9C989CBE9C9CBA9C9C9C9CBE9C9C
+ BE989C989C9C9C989CBE9C9C9CA0A1A1A1C7A5A5A5C7A5C7A5A6C3A6C3A5A5C3
+ A5A1C3A5C3A1C3A1A1A1A1A1A1A1A1A1A19DA19DA09DA0A19D9D9CA19CA19DA1
+ 9DA179A1A179A19DA179A179A179A1799D9D9C000000080808AA0808AA08AAAA
+ AAAAA9AAA9A5A5A5A0A0A0A0A0A19C9C9CA09C9CA09C9C9C9C9C9C9C9C9C9C9C
+ 9C9C9C9C9C9C9C989C9C989C989C9C9C989C989C9C9C9DA0C3A1A1C7A5A5C8A5
+ C7A5A6A6A5C7A5A5A5A6C3A5A1C7A1A1A5A5A1A5A1C3A1A1A1A1A1A1A1A1A1A0
+ 9DC39D9DA09DA19DA19DA19DA19DA19D7DA19D7D9DA17D9D799D799D79789D00
+ 000008AA080808AA080808AA08AAAAAAA9A9A9A5A5A5A0A09C9C9C9CA09CA09C
+ 9C9C9C9C9C9C9C9C9C9C9C9C9C989C9C9C98BE9C9C989C9C9C9CBE989CBE9C9C
+ 9C9DA0A1A1A5C7A5A5C8A5A9A6A6C7A5C7A6A5A6A1C3A5A2A5A1A5A5C3A1A1C3
+ A1A5A1A1A1A1A1A1A1A0A19DA1A09DA09D9C9D9C9D9C9DA19C9D7D9DA19D79A1
+ 79A1799D7D9D7979799D790000000809AAABAA09AA08AA08AA08AAAAAAAAAAA9
+ A9A5A5A5A0A0A09C9D9C9CA09C9C9C9C9C9D9C9C9C9C9C9C9C9C9C989C9C9C98
+ 9C9C9CBE989C989C9C9C9CBFA0A1C3A1C7A5A5C7A6A9C7A6C7A5A6A5A6A5A5C3
+ A6A5A1A5C4A5C3A1A1A5A1A5A1A1A1C3A1A1A1A1A1A1A0C39CA19C9D9C9D9C9D
+ 9D9D9C9D9D9C9D9D799DA19D9D7D9D7D9D7D799D797979000000AA0808080808
+ 08AB08AB0808AA08AAAAAAAAA9AAA5A5A5A0A1A09C9C9D9C9C9D9C9C9C9C9C9C
+ 9C9C9C9C9C9C9C9C989C9C9C98BE989C9C9C9C9C9C9D9CA1A1A1A5A6A5C7AAA5
+ C7A6A9C8AAC7A6C7A5A6A5A5A1A5A1A5A1A1A5A5A1A1C8A1A5C3A5A1A1A1C3A1
+ A1C3A1A0A19DC29DA19C9D9C9C9D9D9C9D9D9C9D9D799D799D9D799D799D9D79
+ 9D797900000008AB0809AAAB0808080808AB0808AA08AAAAAAA9A9A5A5A5A0A0
+ A09CA09C9C9C9CA09C9C9C9C9C9C9C989C989C9C9D9C989C9C9C9C9C9CBE9C9C
+ A1A0A1A1A5C7A5A5C7AAC7A6AAC7A6A5A5A6A5A5A6C7A1C8A1A5C4A5A1A5A1C4
+ A1C7A1A1A1A1A1A1C7A1A5A1A1A1A1C39DC29D9C9CBF9C9D9D9C9C9D9C9D9D9C
+ 9D9C9D9C9D789D799D79797979799D0000000808AA0808080808AB0809AA08AA
+ 08AA08AAAAAAAAA9A9A5A5A5A0A09C9C9C9C9C9C9D9C9C9C9C9C9C9C9C9C9C9C
+ 989C9C9C9D9C9C9C9D9CA0A1C3A1A5A5C7A6C7C8AAC7A5AAC7A5AAC7A6C8A5C8
+ A5A6A5A1A5A1A5A1C8A1A5A1A5A1A1A5A1C7A1A5A1A1A1A1C3A1C3A1A0A1A0BE
+ 9D9C9CBE9C9C9D9D9C9D9C9D9C9D799D799D799C79799D799D7979000000AA09
+ 08AB0808AB0808AA080808AB08AB0808AAAAAAAAAAA9A9A5A5A1A0A0A19CA19C
+ A09C9D9C9C9C9C9C9C9C989C9C9C9C9C9C9C9D9C9CA1A1A1A1A5C7A5A6A5AAA5
+ A9A6AAC7AAC8A5A6A5A5A5A6A5A1A5A5A2A5A1A1A1A1A1A1A1A5A1A1A1A1A1C3
+ A1A5C3A1A1A1A0C3A0BF9CA19C9D9C9D9C9D9C9C9D9C9D9C9D9C999C9D989D79
+ 9D9D7879799C7900000008AA08AA0908AA0908AB08AB08080808AA08080808AA
+ AAAAA9AAA5A5A1A09CA09C9C9C9C9C9C9C9D9C9C9C9C9C9C9C9C9C9C9C9CA0A1
+ A1A1A1A5A5A5A6C7AAC7AAC8A6CBA6A6A5A9C8A5A6C8A5A5C8A5C4A5A1C7A1A5
+ A1A5A1A5A1A1A5A1A5A1A5A1A1A1A1A5C3A1A1A1A1A09DBE9CBE9C9C9D9C9D9C
+ 9D9C989D989D9C9D789D789D78759D9C79757900000008AB0809AA0809AA0808
+ 080808AB08D408ABAA08AA08AAAAAAA9A9A9A5A5A0A19CA19C9D9C9C9C9C9C9C
+ 9D9C9C9C9C9DA0A1A1A1A1A1A5A5C7A5C7AAC8A9A6A6A9A6A9A6A5CCA6C8A5A6
+ C7A5A6A5A5A1A5A1A5A1A6A1A1A1A1A1A1A1A1A1A1A1A1A1A5A1A5C3A1A1C3A1
+ C29DC29C9D9C9D9C9CBE9C9C9C9C9D9C9C9D989D989D9879989D78759D787900
+ 0000080808AA08AB080808AB08AB080808AA080808080808AA08AAAAAAA9A9A5
+ A5A0A09C9C9C9C9C9C9C9C9C9C9CA1A0A1A1A1A1A1A5A5C7A6C7AAA6AAA6A5AA
+ A6CBA6CCA6A5CCA5A6A9A5C8A5A6A5C7A2A5A1A2A5A1A1A1A5A1A1A5A1A1A1A1
+ A1A1A1A1A1A1A1A1A1C3A0A19CC39C9D9CBE9CBE9D9C9C9D9C9D9C989D989C9C
+ 999C759C9979749D747998000000AA09AA09080808AB08AA080808AB08AB08AB
+ 08D4AA0808AA08AAAAAAAAA9A5A5A1A1A09DA0A1A1A1A1A1A1A1A1A1A5A1A5A5
+ A5A5A6A5A9A6A9CCA5CCAAC7AAA6A5A6CBA6A6C7A5C8A6A5A6A5A6A5A5C3A5C7
+ A1A1A5A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1C3A1A1C3A0C39C9CBE9C9C9D9C
+ 9C9D9C9C9C9C9D9C9C9D989D989C989978989D749D747500000009AA0808AB08
+ AA080908AB08AA0808080808AA08AB08AB080808AAAAAAAAA9A6A5A5A5A1A1A1
+ A1A1A5A1A5A5A5A5A5CBA5CCAACCAAC8AAC8AAA6AAA6A6A6A6A9C8A6A6A5A6A6
+ A6A5A5C8A5C8A5A2A5A2A1A1A5A1A1A1A5A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1
+ A1C2A19DA0BF9C9CBF9CBE9C9CBE9C9D9C989C9D989C9C989D989D9899749899
+ 749974000000AA0808AA08860908AA0808080908AB08AB08AB080808AA08ABAA
+ 0808AAAAAAA9A5A5A5A5A5A5A5A5A6A5AAA6CCAAAAAAAAAAAAAAAAAAAAAAAAAA
+ A6A9C8AAC7A6A5A6C7A6C7A5A5C8A6A5A5A6A5A5A1A5A5A5A1A1A5A1A1A1A1A1
+ A1A1A1A1A1A1A1A1A1A1A1A1C3A19CC29C9CBE9C9C9C9C9D9C9C9C9CBE9D9C9C
+ 9C9D989C989C989C989C99749874740000000809AA0908ABAAAA08ABAA09AA08
+ 080808AA0808AB08AB08080808AA08AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+ CCAAAAAAAAAAAACCAAA6CCA5CCA6AAA5A6A6A6A5A6A5A6A6A6A6A5A5A6A5A1A1
+ A6A5A1A2A1A5A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1C2A1A1A0C39C9DBE9C9C
+ 9CBE98BE9C9D9C9D9C9C989C9D989C9D9C989D9899987498997499000000AA08
+ AA08AA08080908080808ABAA09AA0908AB0808080808AB08AB08AAAB08AAAAAA
+ AA08AACCAAAAAAAAAAAEAAAAAAAAAAAACCAAAAAAAAAAA6AAA6A6A5C8A5A6C7A6
+ A5A6A5A5A5A1A5A6A1A1A6A5A1A1A1A5A1A2A1A1A1A1A1A1A1A1A1A1A1A1A1A1
+ A1A1A1A1A0BF9CBE9C9C9CBE9C9C9C9C9C98BE989C9C9D989C9C9C989D989C98
+ 9C999C9874987400000008AA09AA09AAAA08AA09AA080808AA0808AA08AB0808
+ AB0808AA080808AA08AA08AAAAAA080808AA08AAAEAAAFAA08AAD5AAAAAAAAAA
+ A6AAA6AAA5AAA6A6A6A5A6A5A6A5A6A6A5A6A1A5A6A1A1A2A5A2A1A1A5A1A5A1
+ A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1C29DA09D9CBE9C9C9CBA9CBE9CBE9C9C9C
+ 9C98BE9C989C999C989C999C98989899989898000000AA09AAAA080809AA09AA
+ 08ABAA0908AB08AB0808AA09AA08AB08AB08AB0808ABAAD408ABAA08AA08AAAF
+ 08ABAA08CC08AAAAAAAACCAAAACCAAA6CCA6A5A6A5A6A5A6A5A6A5A1A6A1A5A2
+ A1A5A5A1A1A1A5A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1C3A09DC29CBE9C
+ 9C9CBA9C9C9C989C989CBA9C9C989C989D989C9C989C98989C989D9898997400
+ 00000808AA09AA08AA08AA0809AA0808AA08AA0808AA09AAAB08080808AA0808
+ 080808AA08AA08AB08AB0808AAAA08CC08AAAAAAAAAAAAAAA6AAA6AAA6A5A6A5
+ A6A5A6A5A2A5A1A6A5A2A5A1A5A1A2A1A5A1A1A2A1A1A1A1A1A1A1A1A1A1A1A1
+ A1A1A1A1A1A09DC29D9C9CBE9CBE9C9C98BE9CBA9C9C9C98BA9C9C989C989C98
+ 999C999C99989898989898000000AAAA0808AA09AAAA09AA08AA09AA090809AA
+ AB0808080808AAAB08D4AAABAAAB080808AB0808AA08AAAAAB08AAABAAAAAAAA
+ AAAAAAAAAAAAA6A9AAA6A6A5A6A5A6A5A5A2A5A1A1A1A2A1A1A1A1A1A2A1A1A1
+ A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1C2A1BEA19C9CBE9C9C989C98BE9C989C9C
+ 98BE989C9C98989C989C98989C9898989C9898989998980000000886AA08AAAA
+ 0908AA080886AA08AAAA080808AAD4AA08AB0808AA0808080808AAABAA08AAAB
+ 0808AB08AA08AA08AAAAAAAAAACCAAAAC8AAA6C8A5A6C8A5A6A5A1A6A5A1A5A2
+ A5A1A5A1A2A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A0BF9C
+ BE9CBE9CBE9C9C98BE9C98BE989CBA989C9C98989CBA9C98989C989898989D98
+ 98989800000086AA08860808AAAA09AAAA08AB080809AA08AA09AA0808AA08AA
+ D408AA08ABAAD40808AB08AA08AA08AAD4AA08AAAAAAAAAAAAAAAAA6A9AAA9AA
+ A6A9A5A6A5A6A5A5A2A5A2A5A1A2A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1
+ A1A1A1A1A1C3A1C29DC29C9C9C9C9C989C98BE9C9C989C989C989C9C98BA9C98
+ 9898989C9898989C98989898989898000000AA08A608AAAA860808AA09AA86AA
+ 08AAAA09AA08AA09AA08AB0886AAD408AA0808AAAA08AA08AAABAA08AAAAAAAA
+ AAAAAAAAAAAAA6AAAAA6A6A6A5A6A6A5A6A5A6A1A5A1A1A1A1A1A1A1A1A1A1A1
+ A1A1A1A1A17DA1A1A1A1A1A1A1A1A1A1A1A1A09DA09DBE9CBE9CBA9CBE9C989C
+ 98BE989CBA9C98BA989C98BE989C9898989898989898989898989800000086AA
+ 08AA8608AAAA86AA08AA0808A60908AA09AA08AA09AA08AAAB08AAAA09AAAAAB
+ 08AAABAA08AA08AAAA08AAAAAAAAAAAAAAAAAAA6AACBA6A9C8A5A5A6A5A5A1A6
+ A1A5A1A2A5A1A1A1A17DA1A1A17DA1A1A1A1A1A1A1A1A1A1A1A1A1A1A1C29DC2
+ 9CBE9C9C989C9C9C98BE9CBA9C98BE989C989C989C98989898989898989C9898
+ 98989898989898000000AA86AA86AA8608AA08AA8608A60808AA08AAAA09AA08
+ AA08AA08AA0809AAAA09AA0808AA0808AA08AA08AAAAAAAAAAAAAAAAAAAAAAA9
+ A6AAAAA6A5AAA6C7A6A5A5A5A1A2A5A1A1A1A1A1A1A1A1A1A1A1A1A1A1A17DA1
+ A1A1A1A1A1A1A1A1A19DA09DBE9CBE9CBE98BE9C9C989C989C989C9898BE9898
+ BA9C989C98BA9C989898989898989898989898000000AAAA86AAAAAAAA86AA08
+ AAAA08AAAA08AA0886AA088208AA09A608AAAA0808AA08AAAA08AAAA08AA08AA
+ AAAAAAAAAAAAAAAAA6AAAAA6AAA5A6A9A6A5A5A6A5A5A6A1A6A5A1A5A1A1A1A1
+ A1A1A1A1A1A1A17DA1A1A19DA17DA19DA1A1A1A09DC29DBE9C9C9C9C9C9C989C
+ BA9CBA9CBA9C98BE9C98989C9898BA9898989898BE9898989C98989898989800
+ 0000AA86AAAA86AA86AAAA86AA0886AA0886AA08AA08AA08AA08AA0808AA0808
+ AAAA08AA08AAAA08AAAAAAAAAAAAAAAAAAAAAAAAAAA9A6AAA5A6A9A6A5C7A6A5
+ A5A6A5A5A1A1A1A1A1A1A1A1A1A1A1A19D7DA1A19DA1A17DA19DA1A1A1A0A1BF
+ A09D9C9CBE98BE98BE989CBA9C989C989C989C9898BA9C989C98989C989C989C
+ 98989C9898989898989898000000AAAA86AAAA86AAAA86AA86AAAA86AAAA86AA
+ 08AA08AA08AA08AAAA08AAAA0808AA08AA08AAAAAAAAAAAAAAAAAAAAAAAAA6AA
+ AAA6A9AAA6AAC7AAA5A6A5A6A5A5A1A5A5A1A5A1A1A1A1A1A1A1A17DA19DA1A1
+ 7D9DA19DA1A1A1A19DA19CA1BE9CBE9C9C9C9C9C98BE9C9C989C989C989CBA9C
+ 989C9898BA9C98989898BA989898989898989CBA98989800000086AAAA86AAAA
+ 86AAAAAAAA86AAAA86AAAA86AA86AAAA86AA8608AAAA08AAAAAA86AAAAAAAAAA
+ 86AAAAAAAAAAAAAAAAAAAAA9A6AAA6A9AAA5A6A5A6A5A5A5A6A5A5A2A5A5A1A1
+ A5A1A1A1A1A1A1A1A1A1A19DA1A179A19DA1A1A1A1C2A1BE9D9C9CBE98BE9C98
+ 9C98BE989CBA9CBA989C9898BA9C989C9898BE989C989C98989CBA9C98BA9898
+ 989898000000AAAA86AAAA86AAAA86AA86AAAA86AAAA86AAAAAAAA86AAAAAAAA
+ AA86AA86AA86AAAA86AAAAAAAAAAAAAAAAAAAAAAA9A6A9A6AAA5AAA6A5AAA5AA
+ C7A6A5A6A5A5A5A5A1A1A5A1A1A1A1A1A1A1A1A1A17D9DA19D7DA1A1A1A19DA1
+ C29D9C9C9CBE9C989C9C98BE989C98989C98989C9CBA989C9898BA989C989898
+ 98BA9898BE989898989C98989C9898000000AA82AA86AA86AA86AA86AAAA86AA
+ AA86AAAA86AA86AAAAAA86AA86AAAAAAAAAAAAAAAAAA86AAAAAAAAAAAAAAAAAA
+ A6AAAAAAA5AAA5A6A9A6A5A5A6A5A6A5A5A2A5A1A1A5A1A1A5A1A1A1A1A1A1A1
+ 9DA1A17DA19DA1A19DA1A1A09DA0BF9CBE9C9C9CBA9CBA9C98BE989CBA989CBA
+ 98989C989C98989C98BA989C98989C989898989C9898989CBA989C000000AAA9
+ AAAAA6AAAAAAAA86AA86AA86AAAAAA86AAAAAA86AA86AAAAAA86AA86AAAA86AA
+ AAAAAAAAAAAAAAAAAAA9A6AAAAAAA5A6AAA6A9A5A6A5A6A5A5A5A5A5A5A5A5A5
+ A5A1A5A1A1A1A1A1A1A1A1A1A19DA19DA1A19DA1A1A09DA1BE9C9C9C9C9CBA9C
+ 9C989C989C98989C9C9898989C9C9898BA9C9898989C98BA9C98BA9C989C98BA
+ 9C98BA9898989800000082AA82AA86AAF7AAAAAAAAAAA6AA86AA86AA86AA86AA
+ AAAA86AAAAAAAAAA86AAAAA686AAAAAAA6AAAAAAA6AAAAA6A9A6AAA5A9A6A6A9
+ A5A6A5A6A5A6A5A6A1A5A1A5A1A5A1A5A1A1A1A1A1A1A1A1A1A1A1A19DA1A1A0
+ 9DC3A0A09DBE9CBE989C9C98BE989CBE989CBA9898BE9C989898BE989C989CBA
+ 9898989C98989C98BA989C98989C98989C9898000000A9A6AAA9A6A9AAAAF7AA
+ 82AA86AAAAAAAAAAAAAAAAAA86AAAAAA86AA86AAAAAAAA86AAAAAA86AAAAAAA6
+ AAAAA6A9A6AAA9A6A6A9A5A6A5A5A5A5A5A5A5A5A5A5A5A1A5A1A1A1A1A5A1A1
+ A1A1A1A1A1A1A19DA1A19DA1A1A09DBE9C9C9C9C9CBE989C989C98989C989C98
+ 9C9898BA9CBA989898BA98989CBA9C98BA9C98989C98BA989C98989CBA989800
+ 0000A686A982AAF7AA82AAAAAAAAAA86AA86AA86AAF7AA86AAAAAAF7AAAAA6AA
+ AA82AAAAAAAAAAAAA5AAA5AAA9A6A9AAA5A5A6A6A9A5A6A5A6A5A6A5A5A5A5A5
+ A1A5A1A5A1A5A1A5A1A1A1A1A1A1A1A1A19DA1A1A0A1A0A1C29DC29D9CBE9CBA
+ 9C989C98BE989C98BE9898BE9898989C989C989C989C989C9898989C989CBA9C
+ 989C9C9CBA98BE98989C98000000AAA5A6AAA5AAAAA9AA82A982AAA6AAAAA6AA
+ AAAAAAAAAA86AAAAAA86AA86AAAAAAAAA686A6AAAAAAAAA6A6AAA6A6AAA6A9A5
+ A6A6A5A5A5A5A5A5A6A5A1A5A5A1A5A1A1A1A1A1A1A1A1A1A1A1A1A1A1A19DA1
+ A1A1A1A09DA09CBE9C989C9C989CBA989C98BA9C98989C9898BE9898989898BA
+ 989898BA9C989CBA9C989CBA9CBA98989C9C989C98989C000000A586A586A681
+ A686A5AAAAAA85AA81AA86AA86AA86AAA6AAAA86A6AAAAAAA586A6A9AAA6A9A6
+ AAA5AAA9A6A9AAA5A5AAA6A9A5A5A6A5A6A5A6A5A5A5A5A1A5A1A5A5A1A5A1A5
+ A1A1A1A1A1A1A1A1A1A1A1A1A19CC3A1A0BF9C9CBE9C98BE989C9C9C989C9898
+ 9CBA9C9898989C98BE989C989C989C9898BE989CBA989C989C9CBE98BA989C98
+ 9CBA98000000A6A5A6A5AAAAA9A6AA82A9F7AAA6AAAAA5AAA6A9A6AA86A982AA
+ AA86A586AAAAAA86A6A9AAAAA586A6A6A9A6A5A6AAA5A5A6A5A6A5A5A5A5A5A5
+ A1A5A5A5A1A5A1A1A5A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A0BE9C9C9C
+ 989C9C989C98BA989CBA989C989898989C9898BA9898BA9898BA989C989C9898
+ 9C9CBA9CBA98989C9C9CBA9CBA9C98000000A586A5AA81A582A586A9A6AAA685
+ AA81AA82AA86AA85A6AAAAAAA9A6AAA6AAA5AAA6A9AA82A5AAA6A9A9A6AAA5AA
+ A5A5A6A5A5A5A6A5A5A6A5A5A5A5A1A1A5A1A1A5A1A1A1A1A1A1A1A1A1A1A1A1
+ A1A1A1A0A1A1A0BE9D9C9CBA9C9CBA9C9C989C989C989C98BE9898BE9898989C
+ 989C989C989C9C989CBA98BE9CBA989C989C9CBE98BA9C98989C98000000A5A5
+ A6A5A6AAA5AAA5A6A982A9AAA6AAAAA9AAA9A6AAAAA685A686AAA9AAA586A5AA
+ A6A5AAAAA5AAA6A6A5A5A6A5A5A6A5A6A5A5A5A5A5A5A5A1A5A1A5A5A1A5A1A1
+ A1A1A1A1A1A0A1A1A1A1A1A1A0A1A1A1A1BEA19C9CBE9C9C989C9898BA9C989C
+ 989C9898989C989898BA9898989898BA9C9898BE989C9C98989C9CBA9CBE9898
+ 9C9C98BE9C9898000000A5A681A981A5AA81AA81A6A9A681AAA5F7AAA582A982
+ A9AAA6A9A6AAF7AAAAAAA685AAA6A5AAA5A5A9A6AAA5A9A6A5A5A5A5A6A5A6A5
+ A5A5A5A5A5A5A1A5A5A1A5A1A5A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A0A1A0BF
+ 9C9C9C989C989C9C989C989898BA9C9898989C98989C9898BE989C9898BE9898
+ 9CBA9CBE9CBA9C9C989CBE9CBA9C9C98BE9C9C000000A5A5A5A6A5A6A5A5A6A9
+ A586A5AAA586A9A686AAA6A9AA82A9AA86A5AAA582A5AAA5A685A6A5A6AA82A5
+ A5A6A5A5A6A5A6A5A5A5A5A5A5A1A5A1A5A1A5A1A1A1A1A1A1A1A1A1A1A1A1A1
+ A0A1A19DA1A1A1A0A1A0BF9C9C9CBA9C98BE98989C98BA9C989C9898BE9898BA
+ 98989898989898989C989C9CBA9C989C989C98BE9CBA9C989C9CBA9C98989800
+ 0000A582A5A581A981A6A982A6A6A982A9A6A5A6A9A6A986A6A9A6AAA5AAA9A6
+ A9AAA5A6A9A6A9A5AAA5A5A9A6A5A6A5A5A5A5A5A5A5A5A5A5A5A5A5A1A5A1A5
+ A1A5A1A1A1A1A1A1A1A1A1A1A1A1A1A1A1A0A1A1C29D9C9C9C989C989C98989C
+ 98989C98BE98989C989C98989CBA989C989CBA9C98BE98BA9C989CBE9C9CBE98
+ 9C9C9CBE98BE9C989C9C98000000A5A5A5A5A5A6A5A5A5A5A981A5AAA5AA85AA
+ 81A9A6A6A9A685A685A6A586A5A6A986A5A6A5A6A5A5A6A5A5A5A5A5A6A5A5A6
+ A1A5A5A1A5A1A5A1A5A1A5A1A1A1A5A1A1A1A1A0A1A1A0A1A19DA0A1A1A1A0A1
+ 9DA09C9CBE9C989C98989CBA9C9C989C989C9CBA9C989C98989C9898BA989C98
+ 9C989C9C9CBE989CBA9C989CBA9CBA9C9C98BE9C98989C000000A5A581A6A5A5
+ A5AA81A6A5AAA582A5A6A5AAA685A9A586A5AAA9A6A9AAA5AAA5A5A6A9A582A9
+ A6A9A5A6A5A5A6A5A5A5A5A5A5A5A5A5A5A5A1A5A1A5A1A5A1A1A1A1A1A1A1A1
+ A1A1A1A1A0A1A1A0A19DA19CA1BE9D9C989C98989C989898989CBA989CBA9C98
+ 9C98BE9C98989C98989C98BE989CBA9C989CBE989CBE9C9C9C9C9C9CBA9C989C
+ 9C9898000000A5A5A5A581AA81A5A5A9A5A581A9A585A6A5A9A6A6AAA5AAA5A6
+ A982A5A6A982AAA5A6A5A9A5A5A5A6A5A5A6A5A5A6A5A1A5A5A5A1A5A1A5A5A1
+ A5A1A1A1A1A5A1A1A0A1A1A1A1A1A1A1A1A1A19DA1A0A1A0A19C9C989C989C98
+ 989C989C9C989C9C9C9C9CBE9CBA9C98BE9CBA989C98BE989CBA9C98BE9C989C
+ BE989CBA9CBA9CBA9C9CBE9C989C9C000000A5A681A5A5A5A5A5A5A681AAA5A6
+ A9A6A585A6A585A5A982A986A5A9A6A9A6A5A9A5A9A6A5A6A582A5A5A5A5A5A5
+ A5A5A5A5A5A5A5A5A5A1A1A5A1A5A1A5A1A1A1A1A1A1A1A1A0A1A1A0A19CA1A1
+ A0A1A19C9D9C9C9C9C98989C989CBA9C98BE9C9CBE9CBE9C9C9C9CBE9C989C9C
+ 989C989C989C9CBE989C9CBA9C9CBE9C989C9C9CBE989C98BE9C98000000A5A5
+ A5A5A6A5A9A685A5A5A5A9A5A581AAA5AAA5AAA5A6A9A6A5AAA5AA81A9A5A681
+ A6A5A5A5A5A5A5A5A6A5A5A5A5A5A5A5A1A5A1A5A1A5A5A1A1A1A1A1A1A1A1A1
+ A1A1A0A1A1A0A19DA1A19CA1A19DA0A19C9C9C9898989C989C989C9C9C9CBE9C
+ 9C9C9C9C9CBE9C9C9CBE9CBA9CBA9CBA9CBA9C989CBA9C9CBA9C989CBE9CBA9C
+ 98BE9C9C989C9C00000081A5A5A581A581A5A5A9A6A582A9A6A9A585A5A981AA
+ 81A5A9A6A982A9A6A9A6A9A5A9A685A6A5A5A6A5A5A5A6A5A5A581A5A5A5A5A5
+ A5A1A5A1A5A1A1A5A1A1A1A0A1A1A1A1A1A1A1A0A1A1A19DA0A19DA09D9C9C9C
+ 989C989C989C9CBE9C9C9CBE9CBE9CBEBE9CBE9C9C9C989C9C989C989C9CBA9C
+ 9C9CBA9C9CBE9CBA9C989CBE9C9CBA9C9CBA9C000000A5A582A5A5A5A6A5A681
+ A5A9A5A585A5A6A9A6A5AAA5AAA586A5AAA5A9A5A685A5A6A5A5A5A5A9A5A581
+ A5A5A5A5A5A5A5A5A5A5A1A5A1A5A1A5A1A5A1A1A1A0A1A1A1A1A1A0A1A0A1A1
+ A19CA1A09DA19CA19C9D9C989C989CBA9CBE9C9C9CBE9C9CA09CBE9C9C9C9CBE
+ 9CBE9CBE989CBA9CBE989C98BE989C98BE989C9C9CBE9C989CBA9C9CBA9C9C00
+ 0000A5A5A5A5AAA5A981A9A5AA81A5AAA5A685A5A9F7A9A5A9A6A9A5A9A685A6
+ A9A5A6A981A9A6A5A6A5A5A6A5A5A5A5A5A5A5A1A5A1A5A5A5A1A5A1A1A1A1A0
+ A1A1A1A1A1A0A1A1A1A19DA09DA1A19DA1A0A19D9C9C9C989C989C9C9C9C9C9C
+ BEA09CBE9CBEA09CBE9CBE9CBE9C9C9CBE9C9C9C989C9CBE9C9C9CBE9C9CBE98
+ BE9C989CBA9C9CBA9C9CBA000000A582A5A5A581A6A5A6A5A5AAA981A9A5AAA5
+ A6A9A685A685A6A9A6A9A6A9A5AAA5A5A6A5A9A581A5A5A5A5A5A5A5A5A5A5A5
+ A5A5A5A1A1A5A5A1A5A1A5A1A1A1A1A0A1A1A1A09DA0A1A1A0A19CA1A09D9CA0
+ 9D9C9C9C9C9C9C9C9C9CBE9C9C9CC29CC29CBE9C9CC29C9C9C9CBE9C9CBA9CBA
+ 9CBA9C989CBA9C989CBA9C9C989CBE9C9CBE989CBA9C9C000000A5A5A582A5A5
+ A5A9A586A5A5A6A9A685A585A9A5A9A6A9A5A9A685A5A9A685A586A5A9A5A6A9
+ A5AAA5A9A6A5A5A5A5A5A5A5A1A5A5A5A5A1A1A5A1A1A1A1A1A1A1A1A1A0A1A1
+ A1A19CA19DA0A179A1A1A19DA0A19C9C9C9C9C9CBE9C9CBEA0BEA0BE9CA0BEA0
+ BE9CBEC2BE9C9CBE9C9CBE9C9C9CBE9C989CBE9C9C9CBE98BE989CBA9C9CBE9C
+ 9CBA9C000000A5A5A5A5A9A685A6A5A5A982A9A5AAA5AAA5A686A5A986A6A981
+ AAA6A9A5AAA5A9A6A586A5A5A6A5A5A5A5A5A581A5A5A5A5A5A5A1A5A1A5A5A1
+ A5A1A5A1A1A1A0A1A1A1A1A0A19CA17D9CA19CA19CA19CA1A0A1A4A1A09C9CBE
+ 9C9CBEA0BEA0BEA0C2C29CBEA0BEA09C9CBEBE9C9CBE9C98BE989C98BE9C989C
+ BA9C989C9C9CBE9C9CBA9CBA9C9C9C000000A582A5A681A5A5A585A9A6A9A586
+ A5A9A982A9A9A9AAA5A9A9A6A9A9A982A9A5AAA5A9A5A5AAA5A5A5A6A5A5A6A5
+ A5A5A5A5A5A1A5A5A5A5A1A1A1A1A1A0A1A1A1A1A1A0A19DA1A1A19CA19DA19C
+ A19CA1A1A1C7A5C7A4C2A09CA0BEA0A0BEA0C29CC29CC2A0BEA0BE9CBE9C9C9C
+ BE989CBE9C9C9CBE9C989CBE9C989CBE9CBA9C9CBA9C9C9C9C9CBA000000A5A5
+ A5A9A5A6A9A6A5A681A9A6A9A586A6A9AAA586A5AAA586A9A685A6A9A6A9A586
+ A5AAA5A5A982A9A5A5A5A5A5A5A5A5A5A5A5A5A1A5A1A5A5A1A5A1A1A1A1A1A0
+ A1A1A0A1A09DA09DA19C7C9DA19DA0A0A5A5CBA9CBA9C7A0C29C9CBEA0BEA0C2
+ 9CC2A0BEA0BE9CC29CBE9CBE9C9CBE9CBE98BE989CBE9C989CBE989C989CBA9C
+ 9C9CBA9CBA9C9C000000A5A5F7A5A585A585A5A9A6A981AAA9A5A9A685AAA5AA
+ 85AAA5AAA9A6A9AAA982A9A5AAA586A5A5A9A6A5AAA5A9A5A6A5A5A5A5A5A5A5
+ A5A5A1A5A5A1A5A1A1A0A1A1A1A1A1A1A17CA1A0A19DA19C9C7D9DA1A1A5CBA9
+ CBCBA9C7A4C2A0BEA0C29CC2A0C29CC2A0C2C29CBE9CBE9CBE9C9CBA9C9C9CBE
+ 989CBA9C989C9CBE9CBE9CBA9C989C9C9CBA9C000000A5A5A5A5AAA5A6A5AA81
+ A9A5AAA582A986A5AAA5AAA9A6A986A9A6A982A9A6A9AAA5A9A5A9A6A9A6A5A9
+ 81A5A6A5A5A5A5A5A5A5A5A5A5A1A5A1A5A1A1A1A5A1A1A0A1A0A1A09DA19DA1
+ 9CA09DA19D9C9DA0A1A5A5CBA9A9CBA9CBA5C6A0C29CC29CC29CC2A0BEA0BE9C
+ C29CBE9C9CBE989C9CBA9C9C9CBE9C9CBE9CBA9C989C989C9CBE9CBA9C9C9C00
+ 0000A581AAA581A5A985A5AAA586A5AAA9AAA5AAA986A982A9AAA6A986A9AAA9
+ AAA5A685A6A9A6A981A5A9A5A6A5A5A5A5A5A5A5A5A5A5A5A1A5A5A5A1A1A5A1
+ A1A1A1A1A1A1A1A1A1A0A19CA19DA19C9CA19C7DA1A1A5A5A9CBCBADCFCBA9C7
+ A0C29CA0BEA0C2BEA0C29CC29CBE9C9CBE9C9C9CBE9C9C98BE98BE989C989CBE
+ 9C9CBE9CBA9C989C98BE98000000A5A5A5A6A9A6A5A6A585A6A9A982A9A5AA81
+ AAA5AAA9AA86A9A6A9A6A9A685AAA9AA81AAA5A9A6A9A6A5A9AAA5A5A6A5A5A5
+ A6A5A5A5A5A5A1A5A5A5A1A5A1A1A0A1A1A0A1A09DA19CA17D9CA09D7D9C9D9C
+ 9D9C7DA1A5A5A9CBA9ADCFA9C7A5A0BEA0BEA0A0BEC2A09CBE9CBE9C9CBE9CBA
+ 9CBA9CBE9C9C9CBE9CBE989CBA9C989C9CBE9CBE9C9CBE000000A6A5A585A5A9
+ 82A9A6A9A582A9A9A685AAA985AAA5AAA5A9AA85AAA986A9A6A9A6A9AAA586A5
+ A9A6A9A6A5A5AAA5A9A5A6A5A5A5A5A5A5A5A5A1A5A1A5A1A5A1A1A1A1A1A1A1
+ A0A1A19C9DA19D9C9D9CA19C7D9C9D9CA1A1A5A5CBA9CFADCFCFA5C6A0C2BEA0
+ A0BEBEC29CBE9CBE9C9CBE9C9C9C989CBA9CBA9C989CBE9C9CBA9C98BE989C98
+ BE989C000000A581A6A5A6A5A9A585A6A9A9A6A9AAA5AAA6AAA586A986AAA5AA
+ A9AAAAAAA986A9A6A9AAA5AAA685A5A982A9A5A5A6A5A5A5A5A5A5A5A5A5A5A5
+ A5A5A1A5A1A1A5A1A0A1A1A1A1A19CA1A09DA09DA09D789D9C9D9C9D78A0A1A1
+ A5A9A9CCAEAECFADC7A4A0C2BEA0A09CBEA0BE9C9CBE9C9CBE9CBE9C9C9C9C9C
+ BE9C989CBA9C9CBE9C9CBE9C9CBE9C000000A5AAA585A5A982A9A6A9AA81AA85
+ A5AA85A9A986A9AAAAA9AA85A686A585A6AAA5AA85A6A9A6A9A5AAA6A9A6A5AA
+ A5A9A5A6A5A5A5A5A5A5A5A5A5A1A5A5A1A5A1A1A1A1A0A1A1A0A1A19DA09D7C
+ 9D9C9D9C9DA0799C9D9D789DA1A1A5A9AED0AECFADCFC7C6A0A0BEBEA0BE9C9C
+ BE9C9CBE989C989C98BE98BE989C9CBE9C9CBA9C98BE989CBA9C98000000A5A5
+ A5A6A9A6A9A586A9A5AAA5AA86A9A6AAA6A9AAA6A982A9AAAAA9AAAAAAA986A9
+ A6A9AA85AAA6A9A9A6A5A9A581A6A5A9A5A6A5A5A5A5A5A5A5A5A1A5A1A5A1A5
+ A1A1A1A0A1A1A09DA09DA09D9CA19C9D9C9D9C9D9C9C9D9C789CA1A1A5A9ADAE
+ D0AEAEA9C6C2A0A0BE9CBE9C9CBE9C9CBE9CBE9CBE9C9C9CBE9CBA9C98BE9CBE
+ 9C9CBE9C9C9CBE00000082A586A5A585A6A9A5A685AAA9A5AAA985A986A6A986
+ A9AAAA85AAAA85AAA9A6A9AAAA81AAA5A9AA82A9A9AA82AAA5A9A5A6A5A9A5A6
+ A5A5A5A5A5A5A5A1A5A1A5A1A5A1A1A1A1A1A1A0A1A19CA19C9CA19C799C9D9C
+ 799D9C9D9D9C9D78A1A1A9AEAEF6AFD3AECBC6C2A0BEA0BE9C9CBE9C9C9C989C
+ 98BE98BE989C9CBE9C9C989CBE989CBA9C989C000000A5A9A5A5AAA5A982A9A9
+ A6A982AAA9A6AAAAA9AA86A9AA86A9A6A9AAAAA6A986AA81AAA9AAAAAAA5A9A6
+ AAA5A9A5AAA5A6A9A5A6A5A5A5A5A6A5A5A5A5A5A5A5A5A1A1A5A1A1A0A1A1A1
+ A09DA19DA19D789D9C9D9C789C9C799C789D789C9D78A1A5AA08F6AF08D0A9CA
+ C6A0BE9CBE9C9CBE9CBE9CBE9C9C9C9C9CBE989C98BE9CBE989CBE9CBE9CBE00
+ 0000A5A6A982A9A686A5AA81AAA9AAA981AA85A5AA85A9A6AAA9AAAA86A986A9
+ 86A6A9AAA9AAA685A6A9AAAAA5A9A6AAA5A6A9A5A6A9A5A5AAA5A5A5A5A5A5A5
+ A5A1A5A1A5A1A1A1A1A1A0A1A1A1A0A19CA09DA09D9C9D9C9D9D9C9C9D9C9D9D
+ 789D9C79A181AAAEF6AFF6AECBCAC6A09C9CBE9C9C9CBE9C989CBA9CBE989C9C
+ BE9C989C9CBE9C989C989C000000A585A6A5A9A5A9A6A9AA81AA81AAAAA9AAAA
+ A5AAAAAA85AA85AAA9A6A9AAA9AAAAA982AAA9AA85A6AA81AAAA81A9AAA9A6A9
+ A5A5A6A5A5A5A5A5A5A5A5A5A5A5A5A5A5A1A5A1A1A1A1A1A0A1A19CA19D9C9D
+ A0799C9D9C9C789D789D789C9D9C799C9D787DA60808AFD1AEAACBC6C6C29C9C
+ BE9C9C9CBE9C9C989CBE9CBE98BE9CBA9C98BE9CBE9CBE000000A5A6A9A685A6
+ A985A6A9AAA9AAA981AAA986AAA986A9AAA6AAA986AAAA86A6A986AAA986AAA5
+ AAA9A9AAA5AAAAA5A685A6A5AAA5A9A6A5A6A9A5A6A5A5A5A5A5A5A1A5A1A5A1
+ A5A1A1A1A1A1A0A1A0A1A19C9DA09D9C799C9D9C9D9C9D789C9C9D789D9C9D78
+ A1AA0808D108AECCA4C6C29C9CBE9C9C9CBE9CBE9C989C9C9C9C9C9CBE9C9CBA
+ 9C9C9C000000AA81A585A6A9A6A9A982A9A6A982AAAAA5AAA986A9AA85AA85AA
+ AAA9AAA9AA86A9A6AAA9A6A9AA82AAA6A9AAA5AAA9A6A9AAA5AAA6A5A9A5A5A6
+ A5A5A6A5A5A5A5A5A5A5A1A5A1A1A5A1A1A0A1A1A19D9CA19C9D9C9D9C9D9C9C
+ 799C9C9D9C799C9C9D789D9C7978A1AA08AFD0AACCA9A4C6C29CBE9CBE9C9C9C
+ 9CBE9CBA9CBA9CBA9C9CBA9C9CBA9C000000A5A5AAA6A982A986A6A9AA85AAA9
+ AA85AA86A9A6AAAAAAA9AAAAA986A986AAA9AAAA85AAAA86AAA9AAA986A5AAA9
+ A6A9AAA5A6A9A5A9A6A9A6A5A5A5A5A5A5A5A5A5A5A1A5A5A1A5A1A1A1A1A1A1
+ A1A0A1A09DA09DA09D9C789D9C9C9D789D9C9C9D789C9D789D9C9D787DAA08AF
+ AACCCCC7A4C2A0BE9C9CBE9CBE9CBE9C9C9CBE9C9CBE9C9CBE9CBE000000A5AA
+ A585A5A9AAA5A986A5AAA586A9AAA9AA86AA85A685AAA986AAAAA6A9AA86A5AA
+ A9A6A9AAA5AA81AAA6A982AAA9A6A5AAA9A6A9A6A5A5A9A6A5AAA5A5A5A6A5A5
+ A5A5A5A1A5A1A1A5A1A1A1A0A1A1A19DA19C9D9DA09D9D9C9D789D9C789C799C
+ 9C79989C799C789D9C9D7DAAAE08AAAACBA4C6A0C29CBE9C9C9C9C9CBE9C9CBE
+ 9C9C9CBE9C9C9C000000A981AAA5AA81AAAAA5AAA986A9AAA685AAA9AAA9AAAA
+ AA86AAA5AA86A9AAAAA9AA86AAAA86A9AAA9AAA9AAA9AAA5AA85AAA5A6A9A6A9
+ AAA6A5A9A5A5A6A5A5A5A5A5A5A5A5A5A5A5A5A1A5A1A1A1A1A0A1A0A1A1A09D
+ 9C9CA19C9D9C9C9D9C9D9C799C9C799C9C799D78799C9C79A1AAAEAAAACCA5C6
+ C6A0A0C2BE9CBE9C9CBE9C9CBE9CBE9CBE9CBE000000A6A9A586A5AAA585AA85
+ A6A9AA85A9AAAA82A9AA86A9AAA9AA86AAA9AA86A9AA85AAA986A5AA86A6A982
+ AAA6A9AAA5AAA6A9AA81AAA5A5A5AAA5A6A9A5A5A6A5A5A6A5A5A5A5A1A5A1A5
+ A1A1A5A1A1A1A1A1A1A09DA0A1A19C9D9C9D9D789D9C9C9C9D799C799C989C9C
+ 9D9C799C9D79A1AAAAAACCAAA5C6C6A0A0C29CBEA09CBE9C9C9CBE9C9CBE9C00
+ 0000A981A6A9AA81A9A6A9A6A986A5AAAA86A9A9AA86A9AA85AA86AAA986AAA9
+ AA86AAAAA6A9AAAAA9A9AAAAA9AAA9A6A9AAA5AAA5AAA5AAA5AAA5AAA5A5A6A5
+ A5A5A5A5A5A5A5A5A5A5A5A5A1A5A1A1A5A1A1A0A1A1A1A19D9C9D9DA09DA09C
+ 9D789D799C9C9C9C99789D759C799C9D789C789DA1AAAAAACCCBA4C6C6C2A0C2
+ 9CBE9CBEBEBE9C9CBE9C9C000000A5AA85A5A5AAA986A985AAA9AA85A6A9AA86
+ AAA9A6AAAAAAA5AAAAA982AAA9A6A9AA85AAA9A686AAA685A6A9F7AAA685AAA5
+ AAA5AAA5AAA5A5A5AAA5A9A6A9A6A5A5A5A6A5A5A5A5A1A5A5A1A5A1A1A1A1A1
+ A1A0A1A0A1A1A0A19C9C9D9D9C9D9C9C789D789D789C789C78989D749C9D9D78
+ 9C79A1AAAAAACCA9C6A4C6C2A0C2C2A09C9CBE9CBEA0BE000000A5A5AAA986A5
+ AAA5AAA5AA82A9AAA986A5AA85AA85AA85AA86A986AAA986AA85AAAAAAAA86A9
+ AAA9AAAAA9AAA9A9AAA5AAAAA5AAA5AAA5AAAAA5A5A6A5A5A5A5A5A6A5A5A5A5
+ A5A5A5A5A1A5A1A5A1A1A5A1A1A1A1A1A1A09DA1A19DA09D9C9D9D9C9D9C9D9C
+ 9D9C999C9D789C9D74789C9D9C9C9D9DA6AAAEAACCCBA8CAC6A4C2C2C2A0C2C2
+ 9CBE9C000000A586A581AAA981AA85AAA9A9A986A9AAAAA9AAAAAAA9AAAAA9AA
+ AAA9AAAAA9AAAA81AAA9A6AA85A6AAA982AAA6AAA5AAA981AAA5AAA5AAA5A5A6
+ AAA5A9A6A5A6A5A9A5A5A5A6A5A5A5A5A5A5A5A5A1A5A1A1A1A1A1A1A0A1A1A0
+ 9DA09D9CA19C9C9D9D9C799C789D7878989D749C9D9C759C759C789C9C9DA6CC
+ AEAACCCAA8CAC6A4C2C2C2A0C2A0BE000000A9A9A5AAA9A5AAA9AAA585A686A6
+ A9AA85AA85A685AA86A9AA86A586AA85AA86A9AAA9AA86A9AAAA85A6A9A9AAA9
+ 86A6A9A6AAA9A6A9A6A9A6A9A5A5A6A5AAA5A5A5A6A5A5A5A5A5A5A5A1A5A1A5
+ A1A5A1A5A1A1A1A1A1A1A0A1A1A1A1A19CA19D9D9C9C9D9C9D9C9D9C9D789C79
+ 9C759C789C9D9C799D789CA1A6AAD0AACBCACACACAC6A0C2A0C2C2000000A5A6
+ A985A586A9A586A9AAA9A9A986A9A6A9AAA9AAAAA982A9AAAAA9AAAAAAA5AA86
+ AAA5AAAA86A5AAAAAA86A5AAA6A9AAAAA586A5AAA5AAA5A6A9A6A9A5A5A9A6A5
+ A5A6A5A5A6A5A5A5A5A5A5A1A5A1A5A1A1A5A1A5A1A1A1A1A1A0A19CA19CA1A0
+ 9D9D9C9D9C9D789D789D989C749C989D749C759C9C749D789CA1AAF608D0A9CA
+ CACACAC6C6A0C2000000A981AAA5AAA586A9A586A5AA85AAA5AA85AAA9AA85AA
+ AAA986A986AA85A5AA86A9A685AAA9A6A9AA81AAA9A6A9AAA9A6A9A5AAA5AAA5
+ AAA5AAA5A6A9A6A5A6A5A5A6A5A5A5A5A5A5A5A5A5A5A5A5A5A5A1A5A1A1A1A1
+ A1A1A1A1A1A1A1A1A1A19C9DA09DA09D9C9D9C9C9C789D789D749D749D789C75
+ 9C9D9C9D9C9D9CA1AEAFF6AECFCACACACAC6C6000000A5A9A581A9A9A5AAA9A9
+ AAA9A6AA85AAA9AAF7A9AAA986A9AAA6A9AAA6AA85A9AAA9AAAA86A9AAAAAAA9
+ A5AA86A581AAAAA6A9A6A9AAA5A6A9A6A9A6A5AAA5A9A6A9A6A5A6A5A5A6A5A5
+ A5A5A5A5A5A5A5A5A5A5A5A1A5A1A1A1A1A1A1A1A1A1A1A19DA19D9D9D9D9D9D
+ 9D9D9C9D9C9D789C9878999C749C759C759C9C9D9CC7AEAFF6AECFCACACACA00
+ 0000A986A5A9AA81AA85A586A585A985A9AA81A9A9AA81AAAAA5AAA986A986A9
+ AAA686A6A9A6A9AA81AA85A686AAA5AAAAAAA585AAA5AAA5A6A9A6A9A6A5AAA5
+ A5A6A5A5A5A5A5A6A5A5A5A5A6A59DBE99BA9DBA99BA99BA99BA99BA99BA99BA
+ 99BA98BB98BA98BA98BA98BA94BA949894989C759C759C749C759C749C789D78
+ 9D9CA1CBAEF608CFCECACA000000A5A5AA85A5A9A9A5AAA9AAA5AAA9A6A9AAAA
+ 86A9AAA9A9AA85A6A9A6A9A685AAA9A986A986A9AAA5AAA9A6A9AAA5AAA5AAAA
+ A5AA81AAA9A6A9A6A9A6A5A5AAA5A5A6A5A6A5A5A5A6A5A5A5A599F9F9F9F9F9
+ F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9949D9C
+ 749C987998789879989D7498789D9C9CA5AEF6B3F6ADCF000000A9A5A9A6A982
+ A9A981A985AA81AA85A981A9A5AA81AA81AAA9AA85AAA986A5AA82A9AAA6A9A6
+ AAA9A6AAA9A6A9A685AAA5AAA5AAA5A6A9A6A5AAA5A9A6A5A6A9A6A9A5A9A6A5
+ A5A5A6A5A5A5A5B7F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9
+ F9F9F9F9F9F9F9F9F9F99C9D9C799C78989D749C749C799C759C79989D9CC7AE
+ AFFFAE000000A585A5A985A5A982A9AAA5A9A9A9A6A9AAA9AA85AAA9AAA982A9
+ A6A9A6A9AAA9A9AA81A9AA85A982AA85A586AAA9AAA5AA81AAA6A9AAA5AAA9A6
+ A5A6A6A9A6A5A5A6A5A6A5A5A6A5A5A5A6A5A5A5BAF9F9F9F9F9F9F9F9F9F9F9
+ F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9949C9D9C9D989D749C75
+ 9C759898789C98799C789DA0CBB2AF000000A5A9A6A9A5A9AAA9A9A5A986A982
+ A986A586A9A6A9A9F7A9AA85AA85AAA986A586A6A9AAA6A9A6AAA9A5AAA6A5A9
+ A6AAA5AAA5A9AAA5A5AAA5A6A9A6A9A5A5A5AAA5A5A5A5A6A5A5A5A6A5A5A5A5
+ A6BFF9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9
+ F9F9F99D9D9C789D78987998789878789974799878999C9D9CA5D0000000A9A5
+ A981AA85A581A986A5A9A5A9A5A9A9A5A985A6A9AAA5A9A6A9A586A5AAA9A5A9
+ A6A985A6A9A5A6AAA9A9AAA6A981AAA5AAA6A586A6A5A6A9A6A5A5A6A9A6A5A6
+ AAA5A6A9A5A6A5A5A5A5A6A5A5A59DF9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9
+ F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9989C9D9D9C9D9C9C7899789998789C9878
+ 999C749C999CA100000081A9A5A9A5A9AAA9A5A9A9A586A985A6A986A5AA85A5
+ 85AA81A9AAA9A5AA81AAA986A9A6A9AA86A985A686A5A9AAA6A9AAA5A9AAA5A9
+ A6A9A5A6A9A6A9A5A6A5A9A5A5A5A5A6A5A5A6A5A6A5A5A5A5A6A5A1F9F9F9F9
+ F9F9F9B6F9B6B6F9B6F9B6F9F9B6F9B6F9B6B6F9B6F9F9F9F9F9F9F99D9C9C9D
+ 789D9C999C98789998749D7478749D74789C98000000A5A586A5A9A5A981A9A9
+ F7A9A5A9A6A985A5A9A5A9AAA5A9A9A685A586A9A9A5AAA5AA85A6A9A5AAA6A9
+ A5AAA681A9A6A586A5A5AAA5A9A6A9A6A5A5A6A6A9A6A5A6A5A6A5A5A5A6A5A5
+ A5A5A6A5A6A5A5A5A1B6F9F9BBA5A5A5A5A1A5A5A1A5A1A5A5A1A5A1A1A1A1A1
+ A1A1A198B6F9F9F9989D9D9C9D9C799C789D789C7899749C989D74989D749D00
+ 0000A9A9A5A9A585A5A9AAA5A9A9A9A585A9A5A986A986A585AA81A9AAA9A5AA
+ A5AA81AAA5A5AAA5AAA5A9A5AAA5A9A9AAA5AAA9A686A5A6A6A5A6A5A5AAA5A9
+ A5A5A6A9A5A5A6A5A6A5A6A5A6A5A5A5A5A5A5A5A6A1B6F9F9B6A5A5A5A5A5A1
+ A5A5A5A1A1A1A1A1A1A5A1A1A1A1A1A1A1BAF9F9B69D9C9D9D9C9D9C9D9C9899
+ 98749C9875749C9978749C00000081A5A981AAA5A9A581A9A5A981AAA981AAA9
+ A5A9A5A9A9A5AAA585A6A9A585A9A585A9AAA585A586A586A585A6A6A5AAA5A6
+ A5A5AAA9A585A5AAA6A5A5A6A5A6A5A5A6A9A5A5A9A5A5A5A5A6A5A6A5A6A5A5
+ A5A5A5B6F9F9B6A1A5A5A5A5A5A1A5A5A5A5A1A5A1A1A1A1A1A1A1A1A1A198F9
+ F998A19D9C9D9C9D9C799C789D9C9978989C7474989D74000000A9A5A9A5A9A5
+ 85A9A9A585A5A9A5A9A5A981AAA5A982A9A985A5A9A982A9A6A9A6A5A585A6A9
+ AAA5AAA5AAA5A9A9A5A685A9AAA581A6A9A6A5A5A5AAA5A5A6A9A5A6A5A6A5A6
+ A5A6A5A6A5A5A5A5A5A5A6A5A6A5A6A5BAF9F9B6A1A5A5A5A5A5A1A5A1A5A5A1
+ A5A1A5A1A1A1A1A1A1A1A1BAF9B69DA09DA09D9C9D9C9D9C98789C9978989D98
+ 74989C000000A5A982A9A5A9A5A5A5A9A5A9A585A5A9A5A9A585A5A9A5A6A5AA
+ A581A9A585A5A9A9AAA5A9A5A5A9A5A9A5AAA582A9A5A5A6A5A6A9A5A6A5AAA6
+ A9A5A6A9A5A5A6A5A5A5A5A5A5A5A5A5A5A6A5A6A5A5A5A5A5A5A5A5A5BBF9F9
+ F9A1A5A5A5A5A5A5A5A5A1A5A1A5A1A1A5A1A1A1A1A1A1A1B6F998A19D9D9C9D
+ 9C9D9C799C9D9878989C749C987898000000A9A5A9A585A9A5A985A5A9A5A9A5
+ A9A585A5A9A5A9A585A9A985A5AAA9A5A6A586A581A5A582A981AAA586A5A5A9
+ A6A9A6A9A5A9A5A6A5A9A5A5A5A6A5A6A5A6A5A5AAA5A6A5A6A5A5AAA5A5A5A5
+ A5A6A5A5A6A5A5A6A5A5BBF9F9F99DA5A5A5A6A5A5A1A5A5A5A1A1A5A1A1A1A1
+ A1A1A1A1A1BEA19C9DA0A19C9D9C9D9C9D789C9D98799899789974000000A585
+ A5A9A5A5A9A5A5A9A585A5A9A5A9A5A981A9A5A9A5A5A5A5A9A5A5A985A9A5A5
+ AAA9A9A9A6A9A5A9A5A5AAA5A5A5A9A6A5A6A9A5A5A6A5A6A5A9A5A5A5A9A6A5
+ A5A5A5A5A9A6A5A5A6A5A5A6A5A5A5A5A5A5A5A5A6A5A5BFF9F9F99DA5A5A5A5
+ A5A5A5A1A5A5A5A1A5A1A5A1A1A1A1A1A1A1A1A1A19D9DA09DA09C9D9C9D9C78
+ 9C98789C989C98000000A5A9A581A9A981A9A9A5A9A5A9A585A5A9A5A9A585A5
+ A985A5A9A5A981A5A5A5A9A5A5A5A6A5A9A6A5A5AA81A5AAA5A6A581A9A5A681
+ A9A5A5A9A6A5A6A5A6A5A5A5A6A5A6A5A5A5A6A5A5A6A5A5A5A6A5A6A5A6A5A5
+ A5A5A5A59DF9F9F9BBA5A5A6A5A5A6A5A5A1A5A5A1A5A1A5A1A1A1A1A1A1A1A1
+ A0A1A19D9D9D9D9C9D9C9D9D9C9D98799C749C000000A9A5A9A9A5A5A9A5A581
+ A9A5A5A9A5A9A5A5A5A9A5A9A5A5A9A585A5A9A5A981A5A981A9A585A5A585A6
+ A5A5A9A581A9A5AAA5A5A9A5A6A5A6A5A5A5A5A5A5A5A6A5A5A5A5A5A6A5A5A5
+ A5A5A5A6A5A5A5A9A5A5A5A6A5A6A5A5A5C3F9F9F9BBA5A5A5A5A5A5A5A5A5A1
+ A5A1A5A1A1A5A1A1A1A1A1A1A1A19CA1A09DA09D9C9D9C9C9D789C9C989D9800
+ 0000A581A9A5A5A9A5A9A5A9A5A9A5A9A5A581A9A9A5A5A9A5A9A5A9A5A5A5A9
+ A5A5A9A5A9A5A5A5A5A9A5A5A9A5A6A5A9A6A5A5A5A6A5A6A5A5A5A5A6A5A5A6
+ A5A6A5A5A6A5A5A6A5A5A6A5A6A5A6A5A5A5A6A5A6A5A6A5A9A5A5A6A5A69DF9
+ F9F9B6A5A6A5A6A5A5A6A5A5A6A5A5A1A5A1A5A1A1A1A1A1A1A1A1A19DA09D9D
+ A09D9C9D9C9D9C99789878000000A5A9A5A585A5A9A5A9A5A9A5A9A5A9A5A9A5
+ A5A5A9A5A5A5A5A5A5A9A5A5A5A5A5A5A5A5A5A9A5A5A5A5A5A5A5A5A5A5A5A5
+ A5A5A5A5A5A5A6A5A5A5A5A5A5A5A5A5A5A6A5A5A5A5A5A5A5A5A5A5A6A5A5A5
+ A5A5A9A5A5A6A5A5A5A5A5A1F9F9F9B6A5A5A5A5A5A5A5A5A5A1A6A5A1A5A1A5
+ A1A1A1A1A1A0A19CA19DA09C9D9C9D9C9C9C9C9C9C9D98000000A9A5A9A5A9A5
+ A581A9A5FFFFAEA5A5A9A5A9A5A9A5AEFFFFA9A9A5A5AEF6F6F6AAA5F6FFD0A5
+ AAF6F6FFF6AEA9A5A5A5FFFFAFA5A5A6A5A5D0FFFFA6A5AAFFF6AAA5A5A5A5A6
+ A5A6A5FFF6F6A5A5D0FFF6AAA5A5A6A5AAD0F6FFF6F6D0A5A1F9FFFFCCA1A6A5
+ A6A5A6A5A5A5A5A5A5A5A1A5A1A1A5A1A1A1A1A1A09DA19DA09D9C9D9C9D9C9D
+ 989C9C000000A5A5A9A5A5A9A5A9A5A5FFFFF6A5A9A5A9A5A5A5A5D0FFF6A9A5
+ A5F6FFFFFFFFFFAEF6FFAAA9FFFFFFFFFFFFF6AAA5A5FFFFD0A5A5A5A5A5F6F6
+ FFA5A5D0FFF6AAA5A5A5A6A5A5A5A5FFFFF6A5A5AAFFFFAAA5A5A5D0FFFFFFFF
+ F6FFFFAAA5C3FFFFCCF9A1A5A5A5A5A5A6A5A5A1A6A1A5A1A1A5A1A1A1A1A19D
+ A1A09DA09D9C9D9C9D9C9C9C789D98000000A5A981A5A9A5A9A5A5A9F6FFD0A5
+ A5A5A5A5A5A9A5AEF6FFAAA5AEFFFFD0A9A9AEFFFFFFD0A5D0AEA9A9AAF6FFF6
+ A5A5FFFFF6A5A581A5A5AFFFFFA5A5AAFFFFAAA5A5A5A5A5A5A5A5FFFFD0A5A6
+ D0FFFFAAA5AACCFFFFFFCCAACCCCF6A5A5A6FFFFCCF9F9A1A5A6A5A6A5A5A6A5
+ A5A5A5A1A5A1A1A1A1A1A0A1A09DA19C9D9C9D9C9C9D9C9C9D989C000000A5A5
+ A9A5A5A5A5A5A9A5FFF6F6A9A5A9A5A9A5A5A5AEFFFFA9A5F6FFF6A5A5A5A5D0
+ FFFFAEA5A5A5A5A5A5AAFFFFAAA5FFFFAEA5A5A5A5A5D0FFFFA5A5AEFFF6AAA5
+ A6A5A5A5A5A6A5FFFFD1A5A5AEFFF6AAA5A5FFFFFFA9A5A9A6A5A9A6A5A5FFFF
+ CCF9F9F99DA5A5A5A5A5A5A5A5A1A5A5A1A1A1A1A1A1A1A19DA19C9D9C9D9C9C
+ 9D9C9D989C9C98000000A5A5A5A9A5A9A5A5A5A5FFFFAEA5A5A5A5A5A5A9A5CC
+ FFFFA9A5FFFFF6A5A5A5A5AAFFF6CCA5A5A5A5A5A5A5FFFFAAA5FFFFF6A5A5A5
+ A5A1F6FFFFA5A5CCFFF6AAA5A5A5A5A6A5A5A5FFF6F6A5A5D0FFF6AAA5AAFFF6
+ D0A6A5A5A9A6A5A5AAA5FFFFD0F9F9F9F9BFA5A6A5A6A5A5A5A5A1A5A5A1A5A1
+ A1A1A1A1A09DA0A19D9C9D9C9C9C9C9D9C9D9C000000A5A9A5A5A5A5A5A9A5A9
+ F6FFD0A5A9A5A9A5A9A5A5AEFFFFA9A5FFFFD0A5A5A5A5A9FFFFAEA5A5A5A5A5
+ A5A5FFF6D0A5FFFFAEA5A5A5A5A5AEFFFFA5A5AEFFFFA6A5A5A5A5A5A5A5A5FF
+ FFF6A5A6AAFFFFAAA5F6F6FFA6A5A9A6A5A5A9A6A5A6FFF6F6A1F9F9F9F9BBA5
+ A5A5A5A6A5A5A5A1A5A1A1A1A1A1A1A0A1A19D9CA19D9C9D9D9C9D9C9C749C00
+ 0000A5A5A5A5A9A5A9A5A5A5F6FFF6A5A5A4A5A5A5A5A4AEFFFFA9A5D0FFF6A5
+ A5A5A5A9FFFFCCA5A5A5A5A5A5AEFFFFAAA5F6FFF6A5A5A1A5A5F6FFFFA5A5AA
+ FFFFA9A5A5A5A5A5A5A5A5FFFFD0A5A5D0FFFFAAA5F6FFF6A5A9A6A5A5A9A6A5
+ A5A9FFFFF6A5A1F9F9F9F9BAA6A5A5A5A5A1A5A1A5A1A1A1A1A1A0A19DA19CA1
+ 9C9C9D9C9C9C9C9D9C9C9D000000A5A5A9A5A5A5A5A5A5A5FFFFD0A5A5A5A5A4
+ A5A5A5D0FFFFA9A5AAFFFFAAA5A5A5A9FFFFAEA5A5A5A5A5D0FFFFF6A5A5FFFF
+ D0A5A5A5A5A5AEFFFFA5A5CCFFF6AAA5A5A5A5A5A5A5A5FFFFF6A5A5AEFFFFAA
+ A5FFFFD0A6A5A5AAA5A6A5AAA5A6FFF6F6A5A6C3F9F9F9F9B6A5A6A5A5A5A1A5
+ A1A1A5A1A1A1A1A1A19CA19C9DA19C9D9C9D9C9C9D9C9C000000A5A5A5A5A5A5
+ A5A4A5A5FFFFAEA5A5A5A5A5A5A5A5AAFFFFA9A4A5D0FFF6F6A9A5A9FFF6CCA5
+ A4A5AAF6FFFFF6A5A5A5FFFFD0A1A5A5A1A5F6FFF6A5A5AEFFFFA9A5A5A5A5A5
+ A5A5A5FFF6F6A5A5CCFFF6AAA5FFFFF6AECCAECCAECCAECCA9A5FFF6F6A6A5A5
+ A1F9F9F9F9B6A1A5A1A5A5A1A5A1A1A1A1A1A1A1A0A19DA19C9C9D9C9D9C9D9C
+ 9C9D9C000000A5A5A5A4A5A5A5A5A5A5F6FFF6A5A4A5A5A5A4A5A4D0FFFFA9A5
+ A5A5AEFFF6F6FFFFFFFFAAA5A5AAF6FFFFF6A5A5A5A5F6FFAEA5A5A5A5A5D0FF
+ FFA5A5CCFFFFA6A5A5A5A5A5A5A5A5FFFFF6A5A5AEFFFFAAA5FFFFFFFFFFFFFF
+ FFFFFFFFA6A9FFFFF6A5A5AAA5BFF9F9F9F9B6A1A5A5A1A5A1A5A1A1A1A1A1A0
+ 9DA1A09DA1A19CA19C9D9C9D9C9C9C000000A5A5A5A5A5A5A5A5A5A5F6FFD0A5
+ A5A5A4A5A5A5A5AAF6FFA5A5A5A5A5A5AAF6F6FFFFFFD0A4AAFFFFFFAAA5A4A5
+ A5A1F6FFF6A1A5A1A5A5D0FFFFA5A5AAF6FFA9A5A5A5A5A5A5A5A5FFFFD0A5A5
+ D0FFFFA9A5F6F6F6D0D0D0D0AEF6FFFFA5A6FFFFF6A5AAA5A6A5BBF9F9F9F9B6
+ A1A5A1A5A1A1A1A1A1A0A1A1A1A09DA09D9C9C9D9C9D9C9C9D9C9D000000A5A5
+ A5A5A5A5A4A5A4A5FFFFF6F6F6F6F6F6AEA5A4D0FFFFA9A4A5A4A1A4A5A4A5A5
+ FFF6AAA5D0FFFFA9A4A1A5A1A4A5FFFFD0A5A5A5A1A5D0FFF6A5A5CCFFFFF6F6
+ F6F6F6F6A6A5A5FFF6F6A5A5AAFFF6AAA5F6FFF6A5A5A5A9A6D0FFF6A5A9FFFF
+ FFA5A5A5A5A5A5B7F9F9F9F9B6A1A5A1A1A5A1A1A1A1A19CA19DA19DA09DA19C
+ 9DA09D9D9C9D9C000000A5A4A5A4A5A5A5A5A5A5FFFFFFF6F6FFFFFFD0A5A5AA
+ FFFFA5A5A4A5A5A5A4A1A5A9FFFFCCA5FFFFD0A1A5A4A5A5A1A5FFFFF6A1A5A4
+ A5A5F6FFF6A5A5AEFFFFFFFFF6F6F6FFA9A5A5FFFFF6A5A5D0FFF6AAA5D0FFF6
+ AAA5A6A5A5F6F6F6A6A5FFFFFFAAA6A6A5A6A5A1B6F9F9F9F9B6A1A5A1A1A1A1
+ A1A1A1A1A1A09DA09DA09DA09D9C9C9D9C9D9C000000A5A5A5A5A5A4A5A5A4A5
+ F6FFF6AACCAEA9CCAAA4A4CCFFFFA5A5A5A4A5A4A1A5A4AAFFFFA9A1F6FFD0A5
+ A4A1A4A1A4A5F6FFFFA9A5A1A5A5FFFFF6A0A5CCFFFFD0CCCCCCCCCCA5A5A5FF
+ FFD0A5A5AAFFFFAAA5AAFFFFAAA9A5A9AAFFFFD0A5AAF6FFFFF6A5A5A5A5A5A5
+ A1F9F9F9F9F9B6A1A5A1A1A1A1A1A1A1A0A1A1A19DA09D9DA09DA19C9D9C9D00
+ 0000A5A5A5A4A5A5A5A4A5A1FFFFD0A5A0A5A1A5A4A5A5AAF6FFA9A5A0A5A5A0
+ A5A4A5F6FFF6A5A4D0FFF6A5A1A5A5A5A5A1F6FFFFF6A5A5A5D0FFFFD0A5A5AA
+ F6FFA5A5A5A5A5A5A5A5A5F6FFF6A5A5D0FFFFA9A5A5D0FFF6A6A5A6D0FFF6AA
+ AAA5FFFFF6FFF6AAAAA5A6A5A6BBF9F9F9F9F9B6A1A1A1A1A1A0A1A1A19DA09D
+ A09D9DA09DA19C9D9CA19C000000A5A4A5A5A5A4A5A5A5A4FFFFAEA5A5A4A5A4
+ A5A0A5CCFFFFA5A4A5CCF6F6D0D0FFFFFFAEA1A4A5FFFFF6F6D0F6F6A0A5FFFF
+ F6F6FFF6F6FFFFFFA5A5A5CCFFFFA9A5A5A5A5A5A5A5A5FFFFD0A5A5AEFFF6AA
+ A5A5AAF6F6FFAEF6FFF6D1A5A5A5FFFFAAF6FFFFF6A5A5A5A5A1B6F9F9F9F9F9
+ BAA1A1A1A1A1A1A1A0A1A1A1A1A1A0A19DA09DA09D9C9D000000A5A5A4A5A5A5
+ A0A5A5A5FFFFF6A0A5A1A4A1A4A5A4AAFFFFA5A1A4AAF6F6F6F6F6FFD0A0A5A1
+ A4A5F6FFFFFFF6F6A5A0FFFFD0A5F6FFF6F6FFCBA5A1A4AAFFFFC7A5A1A4A5A5
+ A5A5A5F6F6F6A5A5CCFFFFCCA5A9A5AAF6FFFFFFFFF6A9A6A9A6FFFFCCAAFFFF
+ D0A6A5A5A5A5A1F9F9F9F9F9F99DA1A1A1A1A1A1A19CA1A09DA19DA0A19DA09D
+ A19C9D000000A5A5A5A5A0A5A5A5A0A5F6FFD0A5A0A5A1A4A1A0A4CCF6FFA5A4
+ A0A5A5A5AAAAAAA5A4A5A0A4A1A4A1A9A9CCA9A5A0A5F6FFD0A1A4A9CCAAA5A0
+ A5A4A5CCFFFFA9A5A5A5A5A4A5A5A5CCD0A9A5A5AEFFF6A9A5A5A5A5A5CCD0D0
+ AAA5AAA5A5AAD0D0AAA5A5CCAAA5A5A6A1A5A1BBF9F9F9F9F9F9A1A1A1A1A0A1
+ A1A1A19DA1A0A1A19DA09DA09DA19C000000A5A4A1A4A5A5A5A0A5A1F6FFD0A5
+ A0A5A4A1A4A5A5AAF6FFA5A1A5A0A0A1A4A1A4A0A0A1A4A1A0A5A0A4A1A5A0A5
+ A0A5FFFFD0A5A4A1A4A1A4A5A5A1A5CCF6FFA5A5A5A5A5A5A5A5A5A5A5A5A5A5
+ CCFFFFAAA5A5A5AAA5A5A6A5A5A5A5A5A6A9A6A5A6A5A6A5A6A1A5A5A5A1A5A1
+ F9F9F9F9F9F9B6A1A1A1A1A1A1A1A0A1A0A19DA0A1A1A19DA19C9D000000A5A5
+ A5A5A1A4A1A5A4A5FFFFD0A1A5A0A1A4A1A0A0AAFFFFA5A4A0A5A1A4A1A0A1A4
+ A1A4A0A5A4A0A5A1A4A0A5A0A5A0F6FFD0A1A1A4A1A4A1A4A1A4A4AAFFFFA9A4
+ A1A4A5A5A5A5A5A5A5A5A5A5D0FFFFA9A5A5A5A5A5A9A5A9A6A9A6A9A5A5A5A5
+ A5A5A5A5A5A6A5A1A5A5A1A1BAF9F9F9F9F9F99DA1A1A1A0A1A1A1A1A1A1A19D
+ A09DA0A19CA1A1000000A5A4A1A4A5A1A4A1A0A5FFFF08A4A1A4A1A1A4A1A5CC
+ FFFFA5A1A0A0A0A1A4A0A0A1A4A1A0A0A1A0A4A0A5A4A0A5A0A5FFFFD0A4A1A4
+ A1A4A5A0A5A1A5CCFFFFA5A5A5A5A0A5A4A5A5A5AAA5A5A5AAFFFFAAA5A5A5A5
+ A5A6A5A5A5A5A5A6A5A6A5A6A5A6A5A5A5A5A1A5A1A1A5A1A1F9F9F9F9F9F9B6
+ A1A1A1A1A1A0A1A1A1A0A1A1A1A19DA19D9C9D000000A5A1A5A5A1A4A5A5A5A1
+ F6FFD0A1A0A1A0A0A1A0A0AAFFFFA5A0A1A0A1A0A1A1A0A0A1A0A5A1A4A1A0A1
+ A0A1A0A5A0A0FFFFF6A0A4A1A4A1A4A1A4A4A0AEFFFFA5A5A0A5A5A5A5A5A9FF
+ FFD0A5A5D0FFFFA9A5A5A5A5A5A5A5A5A5A6A5A5A5A5A5A5A5A5A5F6A1D0A1F6
+ A1F6A1A1A1B6F9F9F9F9F9F99DA1A1A1A1A1A1A1A0A1A1A0A1A1A0A1A0A1A100
+ 0000A5A4A1A1A4A1A1A0A1A0FFFFFFF6F6F6F6F6F6A5A1CBFFFFA5A0A1A0A1A0
+ A0A0A0A1A0A0A0A0A0A0A5A0A4A0A5A0A4A5FFFFD0A4A1A4A1A0A4A1A4A1A5CC
+ F6FFF6F6F6F6F6F6AEA5AAFFFFFFA5A5AAF6FFAAA5A5A5A5A5A5A5A6A5A5A5A5
+ A6A5A6A5A5A6A5D1A5F6AAF6A5FFA1A1A598F9F9F9F9F9F9B6A1A1A1A1A1A1A1
+ A1A1A1A1A19CA19DA19D9C000000A1A5A4A5A1A5A4A1A4A1FFF6F6F6F6F6F6F6
+ FFA5A0AAFFFFA5A1A0A0A0A0A1A0A1A0A1A0A1A0A1A0A0A1A1A4A0A5A0A0FFFF
+ D0A1A4A1A0A4A1A4A1A4A0CCF6F6FFF6F6F6F6FFD0A5CBFFFFD0A5A5D0FFFFA9
+ A5A5A5A5A5A5A5A5A5A5A6A5A5A5A5A6A5A5A5D0A1D1CCAAAAF6A1A1A19DF9F9
+ F9F9F9F9F9A1A1A0A1A1A0A1A1A1A0A1A1A1A1A19CA1A1000000A5A07DA4A1A0
+ A1A5A1A0AAAAAAAAAAAAAAAAA9A1A1AAF6FFA5A0A1A0A1A0A0A1A0A0A0A1A0A0
+ A0A1A0A0A0A1A0A0A5A0FFFFD0A0A5A4A5A5A0A4A1A5A4A5CCCCD0CCCCCCCCCC
+ CBA1A5A9CBC7A5A5CCF6F6CBA5A5A5A5A5A5A5A5A5A5A5A5A6A5A5A1A5A5A1D1
+ A1D0F6A1CCD0A1A1A1A1F9F9F9F9F9F9F99CA1A1A1A1A1A1A1A1A1A1A0A19CA1
+ A19C9D000000A1A5A5A1A5A180A0A1A1A1A0A1A0A1A0A1A0A1A1A0A0A1A0A1A0
+ A0A1A09DA0A0A1A0A1A0A1A0A1A0A1A0A1A0A0A1A0A0A5A0A4A1A0A0A0A0A5A0
+ A4A0A0A5A0A5A0A4A1A5A4A5A5A5A4A5A5A5A5A5A5A5A5A5A5A5A5A5A5A5A5A5
+ A5A5A5A5A5A1A5A5A5A1F608F6AEAAA1AAAAA1A1A1A1B6F9F9F9F9F9F999A1A1
+ A1A1A1A1A0A1A1A1A1A1A1A19CA1A1000000A5A4A1A0A1A0A1A1A1A0A0A1A0A1
+ A0A1A0A1A0A0A0A1A0A1A0A0A1A0A1A0A0A1A0A0A0A0A0A1A0A0A0A0A0A0A1A0
+ A0A5A0A0A1A4A0A5A4A5A0A5A0A5A5A0A5A0A4A1A5A4A5C2A5A4A5A1A5A5A5A5
+ A5A5A5A5A5A5A5A5A5A5A5A5A5A5A5A5A5A5A5A5A1A5A1A5A1A1A1A1A1A1A1A1
+ A1A194F9F9F9F9F9F9B6A1A1A1A1A1A1A1A1A1A1A1A1A1A0A1A19C000000A1A1
+ A5A180A1A1A07CA1A1A0A1A07DA0A1A09DA07DA0A1A09CA1A0A0A07CA1A0A17C
+ A1A0A1A0A0A1A1A0A1A0A0A1A0A0A1A4A0A1A4A0A1A0A4A1A4A0A4A0A5A4A1A4
+ A4A1A4A5A1A5A5A4A5A5A4A5A5A5A5A5A5A5A5A5A5A5A5A5A5A1A5A5A1A5A1A1
+ A5A1A1A1A1A1A1A1A17DA1A1A1A1B6F9F9F9F9F9F9B6A1A1A1A1A1A1A1A1A1A1
+ A1A09DA19DA09D000000A47DA0A1A1A0A1A1A1A09D7CA1A09CA19C7DA0A1A09D
+ A07DA0A079A09DA09CA09CA1A0A09CA1A0A0A0A0A0A1A0A0A1A0A0A1A0A4A1A4
+ A0A5A0A4A1A4A1A4A0A1A4A1A5A4A1A4A4A0A5A5A4A5A5A5A5A5A5A5A5A1A5A5
+ A5A5A5A1A5A5A5A1A5A5A5A1A1A17DA1A1A1A1A1A1A1A1A1A1A1B6F9F9F9F9F9
+ F9B6A1A1A1A1A1A1A1A1A1A0A1A1A0A1A1A1A0000000A5A1A5A0A1A17CA1A0A1
+ A0A1A0A1A0A0A1A09CA19CA0A19CA0A1A0A1A0A1A0A1A0A09DA0A1A0A1A0A1A0
+ A1A0A0A1A0A0A1A0A1A0A0A1A0A4A1A4A0A5A0C6A5A5A4A0A4A1A4A5A1A5A4A1
+ A5A1A4A1A5A4A5A5A5A5A5A5A1A19CA5A5A1A5A5A1A1A1A1A1A1A1A1A17DA1A1
+ A1A1A19DA1A1F9F9F9F9F9F9F9B6A1A1A1A1A1A1A1A0A1A1A1A1A19DA09D9D00
+ 0000A0A1A07DA1A0A1A0A1A0A1A09D7C9DA1789DA079A0A178A0A1789C9C7C9C
+ A178A09DA07CA09CA0A0A0A1A0A0A1A0A0A1A0A0A0A0A1A4A0A5A0A0A5A0A4A5
+ A0A0A0A5A5A0A5A1A4A4A1A5A4A5A5A5A5A1A5A5A1A5A5A1A5B6F99DA1A5A1A1
+ A1A1A1A1A1A1A1A1A19DA1A19DA1A1A1A0A1F9F9F9F9F9F9F9B6A1A1A1A1A1A1
+ A1A1A1A1A1A1A0A1A1A1A0000000A5A0A1A1A0A1A0A1A0A178A1A09DA09CA1A0
+ 9DA0789CA09D9CA1A0A19CA19CA178A0A19CA1A0A19CA178A1A0A0A1A0A0A1A0
+ A1A0A0A1A0A0A5A0A0A5A1A0A5A4A5C2A0A5A0A4A1A1A4A1A5A0A5A0A5A5A1A5
+ A5A1A5A1A59DF9F9A1A1A1A1A1A1A1A1A1A1A17DA1A1A1A17CA1A1A1A199F9F9
+ F9F9F9F9F9B6A1A1A1A1A0A1A1A1A1A1A0A19DA09DA09D000000A1A1A0A1A07D
+ A1A07DA0A19CA19C7D9C9D7C9C9DA0799CA0799C9C7C9D7CA09CA19CA09C7C9D
+ A07CA0A0A0A1A0A0A1A0A0A1A0A1A0A0A1A0A0A5A0A0A4A0A0A1A4A5A0A4A5A1
+ A4A5A0A5A0A5A1A5A1A0A5A1A5A5A1A5A1A598F9F9A1A1A1A1A1A1A17DA1A1A1
+ A17D9DA1A19DA0A1A1B6F9F9F9F9F9F9F9BEA0A1A1A1A1A1A1A1A1A1A1A1A0A1
+ A19DA0000000A1A0A1A0A1A09CA0A1A09DA079A09DA0789D9C7C9DA09D78A09C
+ 7D9C9C9C9D7C9C7C9DA09DA0A19C9DA09DA0A09DA0A0A1A0A0A0A0A1A0A0A1A0
+ A1A4A1A4A1A4A0A0A5A1A0A4A0A1A4A1A5A0A5A0A5A5A1A5A1A0A1A1A1A1A1B6
+ F9F99DA1A1A17DA1A1A179A19DA1A1A09DA1A1A19DF9F9F9F9F9F9F9F99DA1A1
+ A1A1A1A1A1A0A1A1A0A19DA19CA19D000000A0A1A0A1A1A0A1A19C9C7D9CA19C
+ A078A19C7C9D9C9C789D9C799C9D7C9D7C9CA09D9C7C9CA09CA1A0A0A0A1A0A0
+ A0A1A0A0A1A0A1A0A0A1A0A0A0A1A0A0A4A1A0A5A0A4A0A5A1A5A0A1A0A1A1A1
+ A1A0A1A0A1A1A1A0A1A1A19DF9F9F99DA1A19DA1A079A1A07D9CA179A1A1A19D
+ B6F9F9F9F9F9F9F9F9A1A1A1A1A5A1A1A1A1A1A1A1A1A1A0A19DA0000000A1A0
+ A1A0A0A1A078A1A19C7C9C799C9D789C9D789D789D789C9C789C9C9C9D789D7C
+ 9DA09D9C7D9C7C9DA09CA19CA1A0A1A0A0A1A0A1A0A0A1A0A1A0A1A0A1A0A1A0
+ A1A0A1A0A0A0A1A0A1A0A1A0A1A1A1A1A1A1A1A1A1A1A0A19DF9F9F9989D7D9D
+ 7D9D7D9D9D7D9CA19DA0A1B6F9F9F9F9F9F9F9F9BAA1A1A1A0A1A1A1A1A1A1A0
+ A1A09DA19CA09D000000A0A1A0A1A19CA1A09CA09D9DA09CA1789D789C9C789C
+ 9C799C799C799C799C9C789C789D7C9C9CA19CA079A0A0A17C9CA0A1A0A0A0A0
+ A1A0A0A1A0A0A0A1A0A0A0A0A0A1A0A1A0A1A0A1A0A1A0A1A0A1A1A0A1A0A1A1
+ A1A1A1A1A198F9F9F9F99D9D9DA19D7C9DA1A1A1A199F9F9F9F9F9F9F9F9F9F9
+ A0A1A1A1A1A1A1A1A0A1A1A1A1A1A0A1A19DA0000000A1A0A1A0A0A1A09DA079
+ A09C789D789C9C9D789D9C799C9C789C789C789C789D789D9C789C9D7C9C789D
+ A09D9D9C9DA0A19CA19CA1A0A0A1A1A0A1A0A1A0A1A0A1A0A1A0A1A0A1A0A1A0
+ A0A1A0A1A1A0A0A1A1A1A1A09DA09D7D9CA194F9F9F9F9F998999C9D9D9C99BA
+ F9F9F9F9F9F9F9F9F9F9F9BAA1A1A1A5A1A1A1A1A1A1A0A1A0A1A19CA1A09D00
+ 0000A0A0A1A0A1A09DA0A19C9C7C9D9C9D789D789C78799C7878799C799C799C
+ 799C9C9C789C9D789D9C9D7C9CA07CA0A0A19CA0A0A1A09DA1A09CA0A0A1A0A0
+ A0A1A0A1A0A0A0A0A0A1A0A0A19DA0A1A0A1A1A19CA1A09DA179A19CA1799DB6
+ F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9B6A1A1A1A0A1A1A1A0A1
+ A0A1A1A19DA09CA1A19CA1000000A1A1A0A1A0A1A0789CA19C9DA0789C9C789C
+ 799C9C789D9C9C789C789C789C7879789D789C789C789C9D789D9C799C78A178
+ A19CA0A0A0A0A19CA1A0A0A1A1A0A0A0A1A09DA09DA0A1A1A0A0A19CA19CA19C
+ A179A17C9DA0799D799C799D94F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9
+ F9B6C3A1A1A1A1A1A0A1A1A1A1A1A0A1A0A1A1A19CA19D000000A0A0A1A0A178
+ A1A0A178A0789D9C799C9D789C789D7478759C799C749D789D9C98789C799C79
+ 9C789D789C78A19CA19C9CA19CA179A09DA0A0A1A0A19CA0A0A1A09DA0A0A0A1
+ A0A09CA09DA09CA1A09DA09DA09D9C9D799D9C799D799C799D98F9F9F9F9F9F9
+ F9F9F9F9F9F9F9F9F9F9F9F9B6A1A0A1A0A5A1A1A1A1A1A0A1A1A1A1A19CA19C
+ A1A0A0000000A1A1A0A0A1A0A09DA09CA19CA0789C789C9C799C789C9C9C7898
+ 789D789C7878799C799C789C789D789C799C9C789C7D9D78A09CA09DA09DA09D
+ A09CA1A09DA09DA0A19CA19CA19CA19CA09DA09C9D9C799C799C799C9C79799C
+ 799C797879799C94F9F9F9F9F9F9F9F9F9F9F9F9F9F9F9BEA1A0A1A1A5A1A1A1
+ A0A1A0A1A1A0A1A0A1A1A0A1A09DA1000000A0A0A0A19CA09DA09CA19C799C9D
+ 9C9C9D789C9C789D7479749C799C749C759C9C78789C759C799C789D789C799C
+ 799C9CA0799C7D9CA178A19CA09DA09DA09CA0A09C9DA09CA09DA09C9D9C9D9D
+ 9C799C9D9C9D789D79799C797875799D799C799D9C98B6F9F9F9F9F9F9F9F9F9
+ B6BEA1A1A1A1A1A5A1A0A1A0A1A1A1A1A0A1A0A19DA09DA19CA19C000000A1A0
+ A1A0A1A0A09DA0789CA09C7C9D789C9D789D749C9C9C9C789874799C78787578
+ 9978789878799C789D799C799C789D799CA19C7D9C9CA078A1A079A09CA19D9C
+ 7DA09DA09D789D9C9C799C789C9D789C79789D789D7879797978787978799C79
+ 9C9DA1A098BB98BABABEBFA0A1A1A1A0A1A4A1A0A1A1A1A1A1A0A1A0A1A19CA1
+ A0A1A09CA19CA0000000A0A1A0A0A09DA07C9DA09D789D9C9C9C789C9C789C79
+ 747899789C78987899789C74789D78799C78799C78789C789D789C789D789D9C
+ 7D9DA19C799CA09DA078A09D9C9C9C799C9C9C799C9C9D9C799C799D9C997879
+ 7479787479757978799D799D7D9C799DA09DA0A1A1A0A1A1A0A1A1A1C3A1A5A1
+ A0A1C2A1A1A1A0A1A0A1A09DA09CA1A1A09DA1000000A1A0A19C7DA0A09DA09C
+ A09CA0789D789D789C9C789C9C9C789C759C7875749C759C79749C7479987879
+ 789D79789C799C799C789C799C9C789DA09C799C799D9C789D9D789C9D789D9C
+ 9C799C799C799C7879787974797875757879747978799C799C9DA09DA1A0A1A1
+ A0A1A1A0A1C6A1A4A1A0A1C2A1A1A1A0A1A0C3A0A19CA1A0A1A1A09CA1A09C00
+ 0000A0A0A0A1A0A09DA09D7C9D9C799C9C9C9C9C9D789C9D78749D749C789878
+ 9C787478749C74799C789D749C74789C79789D789C799D789C799D9C9C799C9D
+ 9C9C789D9C789C9D789D9C78799C79749C797479747974797875747879747979
+ 799C799D79A0A19DA0A1A1A0A1A1A0A1A1A1A1A1A0A5A1A1A0A1A0A1A0A1A0A1
+ A0A1A0A19CA09CA1A09CA1000000A19CA1A0A19CA09CA09C9CA09C799C789D78
+ 9C799C789D9C789C749D78997899789978759C7478757879789D74799C789C79
+ 9D789C9D799C789D799C9D789C799D789C799D789C78799D9878799C75787974
+ 7974797475787975747978797879799C9C9D9DA0A1A1A0A1A1A0A1C7A0A5A0A5
+ A1C2A1A0C3A0A1A0C3A0A1A09DA09DC2A1A0A19CA1A09C000000A0A1A09CA0A1
+ 9C7D9CA0799CA09C799C9C9C789C789C78989D789C749C7898789C749C78749D
+ 74789878757879987975789C789D78789C799C789C79789D789C9C799C9C789D
+ 799C78787998787578757875787574797475507974757974799C799D7D9CA19D
+ A0A1A0A1A0C3A0A1A1A0A1C2A1A0A1A0A1A0C3A0A0A1C2A1A0A0A1A09CA19CA0
+ 9CA1A0000000A0A0A1A0A19CA09CA09DA09C799C9C9C799C9D9C9D789D789C9C
+ 799C79987998797899789D749C7578759C749C79789C797875789D78799C799C
+ 799C9D789D78799C79789D787899789978797574787475787578757479747974
+ 7979747979799C789D9DA0A1A0A1A1A0A1A4A1A0A5C3A4A1A0A1C2A1A0A1A0A1
+ A0A0A1A0A1C2A09CA1A0A0A1A0C29C000000A0A19CA09C7D9CA09D7C9C9D9CA0
+ 9C799C9C789C789C789C78759C749C789C7878987875787479749D7478757974
+ 9C79749D789D78799C799C79789D78799C799C9D789D789C7578797478747478
+ 75797475747550797479747555747978789D789DA1A0A1A0A1A1A0A1A1A1A1C6
+ A1A0A1A0C3A0A1A0C2A1A0C39CA1A09CA0A19CA1A09DA09CA19CA1000000A0A0
+ A0A1A0A0A19CA09D78A0789D789C9C799C799C9D9C799C9C9C799C799C759C79
+ 9C7898799C7478759C7874787578797879789D78799C799C7978799C79747978
+ 797478759C74747975757875747475787578757475745179747978759D789D9D
+ 9CA1A0A1A4A5A5A5A5A6A5A1A1A4C3A0A0A1A0A1A0A0A0A0A0A0C2A1A0A0A0A0
+ A0C2A1A0A0A0A0000000A1A09CA09D9CA079A09CA19CA09CA0799CA09C9C789C
+ 789C79789C789D749C789D74799C79747998797475789979749D74759C75789D
+ 787974799C799C799C799C759C79757879797474787475747574745174757479
+ 5079747479747978797878A1A0A1A5A5A5C7A9CBAAABAAA5A5A1A0A1A0A0C3A0
+ A1C2A1A0A1A0A0A0C2A1A09DA09CA09DC29DA0000000A09DA0A17CA0A19CA09D
+ 9C789D789D9C9C799C799C9D789D9C9C799C789D789D749C78759C799C78799C
+ 787974787974787875787974799C799C797479787978757879749C7574747974
+ 7574787578757578757455747574795174797578799DA1A0A1A4C7A4A9A9A9A9
+ 08ABAAAAAAA5A5C2A1A0A0A0C2A0A0A0C2A0A1A09DA0A0C2A0A1A0A0A0A0A000
+ 0000A0A0A0A09CA178A09D7C9CA19CA09C9C799C9C9C9C789D9C78799C799C79
+ 9C78799C799C789878759C749D749C79749C79757879987875787978799C7978
+ 9978799C75787578747974757875757475747874757875747950757478757879
+ 9C79A0A1A5A5A9A9A9A9A9AE08AE0808ABAAA6A5A0C2A0A1A0A1A0A1A0A1A0A0
+ A0A09CA1A0A0A0A19CA19C000000A1A09DA0A19CA19CA09DA09C799C79A09C78
+ 9D789D9C9C799C9C789D9C789C9D9C789D749D789D7878797879749D78757898
+ 7974799D78759C7979749D78799C757879747974797475787574787578757579
+ 74757875747974797578799C79A0A1A4A5A4A5A9CBA9AAAEAF08AEAF08AFAAAA
+ A5A5C2A0A0A0A0C2A0A0C2A0A1C2A0A0A0BFA0A0C2A0A00000009CA1A078A0A0
+ 9C7D9CA079A09CA09C799DA0789D789D789C799D9C78799C79789D789C797875
+ 789D759C759C79749D78797899787479787875789C7978757879787998797479
+ 74797475787574757478747578757479757479747475787978A1A1A5A5A9CBA9
+ A9A9AA0808AA08AB080808AEAAA6A5A0C3A0A0A1A0A0A1A0A0A0A1A0A0A0A1A0
+ A1A0A0000000A0A09CA1A09DA0A09DA09C9D7C9D9CA09C789DA09C799C799C78
+ 799D9C799C9D789D799C799C9D749C79789D789D78759C7578799D78759D7879
+ 75799C799D749D74797879747974797475787578757579747574797474797475
+ 79787978A1A0A4A5C6A5A9A9A9AEAED4AE08AF08AFAFAEAAAFAEA5A5A5A0C2A0
+ A0A0A0A0A0A1A0C2A0A0A0A0A09CA0000000A1A0A1A09D7C9C9D9C7C9DA09D9C
+ 7C9D78A19C9C799C9C9D9C799C9C789D78799C799C789C79787979789D747875
+ 789D7879789D74789D78759C789C797478797879787574797479747879747974
+ 79787474797875787975787578747978A1A1A5A5A5A9A9A9ADAA08AE0808AF08
+ 0808AA0808AAAEAAAAA6A5A1C2A0C3A0A0A0A0A0A1C2A09CC2A1A0000000A09D
+ 7C9CA09DA0A0A09DA09C7C9D9CA09D9C7D9D9CA179A0799C9D799D789D9C799C
+ 799D799C799C789D78799D789D74799879789D79749D787979759C799D757899
+ 789C797479787575757875797475797974757875747875787579789DA1A0A5A4
+ A9A9A9A9AAAEAF08AED40808AF08AEAFAEAEAEAF08AAA6A5A5A0A0C2A1C2A0A0
+ A0A0A1A0A0A0A0000000A0A0A1A0A1A09D78A19C7D9CA1A0799C7D9C9C7D9C78
+ 9D789D79789C79A079789D789C789D789D799C799C78799C799C79789D74789D
+ 78799D789C797978789D7879757978799879789C749D74787978747978757879
+ 7578757874797879A0A5A5A5CBA9A9A9AA0808AAAF08AF08AFAE0808AEAA0808
+ AEAEAEABA6A5A1A0A0A0A1C2A0A0A0A0A0A0A0000000A09DA09D7C9CA0A1A09C
+ A19C789DA09D9C9D7D9CA179A09DA09C9D799C799C9D789D799D789D789C799C
+ 799D787978799C79789D79789D7878799D789D799D78799C799C749D79787579
+ 79787975787579747978757874797479757879A0A1A0A5A4A5A9A9AAAEAB0808
+ 08AF080808AA08AFAAAE08AFAAAEAFAFAAAAA6A5C2A1A0A0A1C2A0C2A1C2A000
+ 0000A1A0A1A0A0A1A19C9C7D9C9CA1A079A09D7C9CA1799C9C799C797D9C9D78
+ 9D789D799C789D799C79799C799C799C799C79799C79789D7879799D7879789D
+ 78799D797879797978749D789879759C78799879787579987979787578799C79
+ A0A5A5A5A9A9A9AA08080808D40808AFAEAEAF08AE08AFAEAEAF080808D508AA
+ A6A4C2A0A0A0A1A0A0A0A0000000A0A178A09DA078A0A19CA07D9C9DA079A09D
+ 799D9CA17D9D7D9D9C7D789D79A0789C799D789C799D789D78799C799C79789C
+ 79799C78799D9C78799D9D78799C78789D799C789D797879799C787999787974
+ 9D7878797578757875787978A1A4A5A5A9A9A9AEAF08AA08AF08AB08AE08D408
+ 080808AA080808AF0808AF08AAA6A5C7A0C2A0A0A0A0A00000009CA1A0A1A09D
+ A09D7C9D9CA1A0799CA178A09D7C9D789D789D7C9D9DA1789D799D799C799D78
+ 9D789D789D789D79789D9D799C79799D7879799D7879789D79799D79789D7979
+ 789D799C79799D78799D787979759C799C79789D78799C79A1A1A5A5A9A9AAD4
+ 0808AED408AF0808AA08AFAEAAAFAF08AEAF0808AF0808D508AFAAA6A5A1A0C2
+ A1C2A0000000A0A09DA079A0A1A09DA07D9C79A1A079A19D7C9DA079A09D7C9D
+ 78A178A1789D78A1799C799D789D789D789D789C797879789D789D789D789C79
+ 9D789D789D789D789D789D789D7879799C7879799C78799C789D797875789978
+ 75787978A0A1A4A5A9A9AA0808AA0808AF08080808AF0808AF0808AE0808AB08
+ 0808AF08080808AAAAA6A4A0A0A0A0000000A179A0A1A0A178A19CA19CA0A19C
+ 79A09D7C9DA179A19D7D9D79A1789D799D7C9D799C799D789D799C799D789D79
+ 9D799C9D789D789D799D799D789D799D789D799D789D799D789D799C799D799C
+ 79799D789D79789D789D7879799C799D79A1A5A5A9AA08D4AAAED4AF08AAAFAE
+ AF0808AA0808AA08AFAF08AF08AB080808D508AFAFAAA6A6A5C2A0000000A0A0
+ A09D7C9CA178A17C9D7D9D7CA19D7C9DA079A079A0799CA178A178A1789D7C9D
+ 7D9C78A1799C799D789D789D789C79799D799D789D789D789D789D789D789D78
+ 9D789D789D789D799C799C799C9D789D799C799C7979789D787979789DA0A5A5
+ A9AA0808AEAA0808080808D4080808AEAF08080808080808AF0808AF08080808
+ 08AED4AAA6A5A10000009DA09DA09DA09DA09CA1A09CA19D7CA179A179A179A1
+ 9D7D9D7D9D79A179A1799D789D799D789D799C799D789D799D799C799C799C7D
+ 9D799C7D9D79A0799D799C799D799C799D799C799D789D79799C79789D799C79
+ 9C799D789D789C79787DA1A5A6AAD4AEAA08AFAB08080808AF08AA0808AEAE08
+ D408AF0808AF0808AF08AFAFAAAEAF08ABAAA6000000A079A079A079A079A178
+ A17D9C7DA09DA079A09D7C9D7C9D7C9D7C9D7C9D78A17C9D7CA178A178A0799C
+ 7C9D7C9C79A0799C7D9C799C79A0799C799C799C7D9C79A0799C7D9C799C799C
+ 789D789C9D789D9D789D789D799C799D789D799C799D7CA5AA0808AAAE080808
+ 0808AF0808AAAE0808AA08AF08AF0808AF08AF0808080808AE0808AF08AF0800
+ 00009CA19CA19CA19CA19CA19DA079A19D7D9D7D9D7D9D7D9D7D9D7D9D7D9D79
+ A1799D799D799D799D799D799D799D799D799D799D799D799D799D799D799D79
+ 9D799D799D799D799D799D799D799D799D799D789D799D799C799D789D799C79
+ 9D789D7DAA0808AAAA08D4080808080808AE0808AEAE0808080808AF08080808
+ AF08AFAEAE08AF08080808000000
+ }
+ end
+ end
+ object OKButton: TButton
+ Left = 316
+ Height = 25
+ Top = 277
+ Width = 75
+ Cancel = True
+ Caption = 'OK'
+ OnClick = OKButtonClick
+ TabOrder = 1
+ end
+end
diff --git a/components/flashfiler/sourcelaz/ffabout.lrs b/components/flashfiler/sourcelaz/ffabout.lrs
new file mode 100644
index 000000000..fda4f4ed4
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffabout.lrs
@@ -0,0 +1,1749 @@
+{ This is an automatically generated lazarus resource file }
+
+LazarusResources.Add('TFFAboutBox','FORMDATA',[
+ 'TPF0'#11'TFFAboutBox'#10'FFAboutBox'#4'Left'#3'J'#1#6'Height'#3'8'#1#3'Top'#3
+ +#180#0#5'Width'#3#142#1#11'BorderStyle'#7#8'bsDialog'#7'Caption'#6#27'About '
+ +'TurboPower FlashFiler'#12'ClientHeight'#3'8'#1#11'ClientWidth'#3#142#1#5'Co'
+ +'lor'#7#9'clBtnFace'#10'Font.Color'#7#12'clWindowText'#11'Font.Height'#2#245
+ +#9'Font.Name'#6#13'MS Sans Serif'#10'OnActivate'#7#12'FormActivate'#11'OnMou'
+ +'seMove'#7#13'FormMouseMove'#8'Position'#7#14'poScreenCenter'#10'LCLVersion'
+ +#6#7'1.6.1.0'#0#6'TBevel'#6'Bevel2'#4'Left'#2#6#6'Height'#2#17#3'Top'#3#9#1#5
+ +'Width'#3#131#1#5'Shape'#7#9'bsTopLine'#0#0#6'TLabel'#11'ProgramName'#4'Left'
+ +#3#152#0#6'Height'#2#16#3'Top'#2#8#5'Width'#2'J'#7'Caption'#6#11'FlashFiler '
+ +#10'Font.Color'#7#12'clWindowText'#11'Font.Height'#2#243#9'Font.Name'#6#13'M'
+ +'S Sans Serif'#10'Font.Style'#11#6'fsBold'#0#11'ParentColor'#8#10'ParentFont'
+ +#8#0#0#6'TLabel'#13'VersionNumber'#4'Left'#3#152#0#6'Height'#2#13#3'Top'#2#25
+ +#5'Width'#2'#'#7'Caption'#6#7'Version'#10'Font.Color'#7#12'clWindowText'#11
+ +'Font.Height'#2#245#9'Font.Name'#6#13'MS Sans Serif'#11'ParentColor'#8#10'Pa'
+ +'rentFont'#8#0#0#6'TLabel'#6'Label3'#4'Left'#3#153#0#6'Height'#2#13#3'Top'#2
+ +'5'#5'Width'#3#164#0#7'Caption'#6' TurboPower FlashFiler home page:'#11'Pare'
+ +'ntColor'#8#0#0#6'TLabel'#12'lblTurboLink'#6'Cursor'#7#11'crHandPoint'#4'Lef'
+ +'t'#3#161#0#6'Height'#2#13#3'Top'#2'E'#5'Width'#3#199#0#7'Caption'#6',http:/'
+ +'/sourceforge.net/projects/tpflashfiler'#10'Font.Color'#7#11'clHighlight'#11
+ +'Font.Height'#2#245#9'Font.Name'#6#13'MS Sans Serif'#11'ParentColor'#8#10'Pa'
+ +'rentFont'#8#7'OnClick'#7#17'lblTurboLinkClick'#11'OnMouseMove'#7#21'lblTurb'
+ +'oLinkMouseMove'#0#0#6'TLabel'#6'Label9'#4'Left'#3#153#0#6'Height'#2#13#3'To'
+ +'p'#2']'#5'Width'#3#218#0#7'Caption'#6'-Released under the Mozilla Public Li'
+ +'cense 1.1'#11'ParentColor'#8#0#0#6'TLabel'#7'Label10'#4'Left'#3#161#0#6'Hei'
+ +'ght'#2#13#3'Top'#2'l'#5'Width'#2'.'#7'Caption'#6#9'(MPL 1.1)'#11'ParentColo'
+ +'r'#8#0#0#6'TLabel'#7'Label11'#4'Left'#2#7#6'Height'#2#13#3'Top'#3#17#1#5'Wi'
+ +'dth'#3#17#1#7'Caption'#6'5(C) Copyright 1996-2002, TurboPower Software Comp'
+ +'any.'#11'ParentColor'#8#0#0#6'TLabel'#7'Label12'#4'Left'#2#7#6'Height'#2#13
+ +#3'Top'#3'!'#1#5'Width'#2'V'#7'Caption'#6#20'All rights reserved.'#11'Parent'
+ +'Color'#8#0#0#6'TLabel'#6'Label4'#4'Left'#3#152#0#6'Height'#2#13#3'Top'#3#131
+ +#0#5'Width'#2']'#7'Caption'#6#18'Online newsgroups:'#11'ParentColor'#8#0#0#6
+ +'TLabel'#14'lblNewsGeneral'#6'Cursor'#7#11'crHandPoint'#4'Left'#3#168#0#6'He'
+ +'ight'#2#13#3'Top'#3#146#0#5'Width'#3#224#0#7'Caption'#6',http://sourceforge'
+ +'.net/forum/?group_id=72211'#10'Font.Color'#7#11'clHighlight'#11'Font.Height'
+ +#2#245#9'Font.Name'#6#13'MS Sans Serif'#11'ParentColor'#8#10'ParentFont'#8#7
+ +'OnClick'#7#19'lblNewsGeneralClick'#11'OnMouseMove'#7#21'lblTurboLinkMouseMo'
+ +'ve'#0#0#6'TPanel'#6'Panel1'#4'Left'#2#6#6'Height'#3#251#0#3'Top'#2#6#5'Widt'
+ +'h'#3#139#0#10'BevelOuter'#7#9'bvLowered'#12'ClientHeight'#3#251#0#11'Client'
+ +'Width'#3#139#0#8'TabOrder'#2#0#0#6'TImage'#6'Image1'#4'Left'#2#1#6'Height'#3
+ +#249#0#3'Top'#2#1#5'Width'#3#137#0#5'Align'#7#8'alClient'#12'Picture.Data'#10
+ +'n'#140#0#0#7'TBitmapb'#140#0#0'BMb'#140#0#0#0#0#0#0'6'#4#0#0'('#0#0#0#137#0
+ +#0#0#249#0#0#0#1#0#8#0#0#0#0#0','#136#0#0#0#0#0#0#0#0#0#0#0#1#0#0#0#1#0#0#0#0
+ +#0#0#0#0#128#0#0#128#0#0#0#128#128#0#128#0#0#0#128#0#128#0#128#128#0#0#128
+ +#128#128#0#192#220#192#0#240#202#166#0#170'?*'#0#255'?*'#0#0'_*'#0'U_*'#0#170
+ +'_*'#0#255'_*'#0#0#127'*'#0'U'#127'*'#0#170#127'*'#0#255#127'*'#0#0#159'*'#0
+ +'U'#159'*'#0#170#159'*'#0#255#159'*'#0#0#191'*'#0'U'#191'*'#0#170#191'*'#0
+ +#255#191'*'#0#0#223'*'#0'U'#223'*'#0#170#223'*'#0#255#223'*'#0#0#255'*'#0'U'
+ +#255'*'#0#170#255'*'#0#255#255'*'#0#0#0'U'#0'U'#0'U'#0#170#0'U'#0#255#0'U'#0
+ +#0#31'U'#0'U'#31'U'#0#170#31'U'#0#255#31'U'#0#0'?U'#0'U?U'#0#170'?U'#0#255'?'
+ +'U'#0#0'_U'#0'U_U'#0#170'_U'#0#255'_U'#0#0#127'U'#0'U'#127'U'#0#170#127'U'#0
+ +#255#127'U'#0#0#159'U'#0'U'#159'U'#0#170#159'U'#0#255#159'U'#0#0#191'U'#0'U'
+ +#191'U'#0#170#191'U'#0#255#191'U'#0#0#223'U'#0'U'#223'U'#0#170#223'U'#0#255
+ +#223'U'#0#0#255'U'#0'U'#255'U'#0#170#255'U'#0#255#255'U'#0#0#0#127#0'U'#0#127
+ +#0#170#0#127#0#255#0#127#0#0#31#127#0'U'#31#127#0#170#31#127#0#255#31#127#0#0
+ +'?'#127#0'U?'#127#0#170'?'#127#0#255'?'#127#0#0'_'#127#0'U_'#127#0#170'_'#127
+ +#0#255'_'#127#0#0#127#127#0'U'#127#127#0#170#127#127#0#255#127#127#0#0#159
+ +#127#0'U'#159#127#0#170#159#127#0#255#159#127#0#0#191#127#0'U'#191#127#0#170
+ +#191#127#0#255#191#127#0#0#223#127#0'U'#223#127#0#170#223#127#0#255#223#127#0
+ +#0#255#127#0'U'#255#127#0#170#255#127#0#255#255#127#0#0#0#170#0'U'#0#170#0
+ +#170#0#170#0#255#0#170#0#0#31#170#0'U'#31#170#0#170#31#170#0#255#31#170#0#0
+ +'?'#170#0'U?'#170#0#170'?'#170#0#255'?'#170#0#0'_'#170#0'U_'#170#0#170'_'#170
+ +#0#255'_'#170#0#0#127#170#0'U'#127#170#0#170#127#170#0#255#127#170#0#0#159
+ +#170#0'U'#159#170#0#170#159#170#0#255#159#170#0#0#191#170#0'U'#191#170#0#170
+ +#191#170#0#255#191#170#0#0#223#170#0'U'#223#170#0#170#223#170#0#255#223#170#0
+ ,#0#255#170#0'U'#255#170#0#170#255#170#0#255#255#170#0#0#0#212#0'U'#0#212#0
+ +#170#0#212#0#255#0#212#0#0#31#212#0'U'#31#212#0#170#31#212#0#255#31#212#0#0
+ +'?'#212#0'U?'#212#0#170'?'#212#0#255'?'#212#0#0'_'#212#0'U_'#212#0#170'_'#212
+ +#0#255'_'#212#0#0#127#212#0'U'#127#212#0#170#127#212#0#255#127#212#0#0#159
+ +#212#0'U'#159#212#0#170#159#212#0#255#159#212#0#0#191#212#0'U'#191#212#0#170
+ +#191#212#0#255#191#212#0#0#223#212#0'U'#223#212#0#170#223#212#0#255#223#212#0
+ +#0#255#212#0'U'#255#212#0#170#255#212#0#255#255#212#0'U'#0#255#0#170#0#255#0
+ +#0#31#255#0'U'#31#255#0#170#31#255#0#255#31#255#0#0'?'#255#0'U?'#255#0#170'?'
+ +#255#0#255'?'#255#0#0'_'#255#0'U_'#255#0#170'_'#255#0#255'_'#255#0#0#127#255
+ +#0'U'#127#255#0#170#127#255#0#255#127#255#0#0#159#255#0'U'#159#255#0#170#159
+ +#255#0#255#159#255#0#0#191#255#0'U'#191#255#0#170#191#255#0#255#191#255#0#0
+ +#223#255#0'U'#223#255#0#170#223#255#0#255#223#255#0'U'#255#255#0#170#255#255
+ +#0#255#204#204#0#255#204#255#0#255#255'3'#0#255#255'f'#0#255#255#153#0#255
+ +#255#204#0#0#127#0#0'U'#127#0#0#170#127#0#0#255#127#0#0#0#159#0#0'U'#159#0#0
+ +#170#159#0#0#255#159#0#0#0#191#0#0'U'#191#0#0#170#191#0#0#255#191#0#0#0#223#0
+ +#0'U'#223#0#0#170#223#0#0#255#223#0#0'U'#255#0#0#170#255#0#0#0#0'*'#0'U'#0'*'
+ +#0#170#0'*'#0#255#0'*'#0#0#31'*'#0'U'#31'*'#0#170#31'*'#0#255#31'*'#0#0'?*'#0
+ +'U?*'#0#240#251#255#0#164#160#160#0#128#128#128#0#0#0#255#0#0#255#0#0#0#255
+ +#255#0#255#0#0#0#255#0#255#0#255#255#0#0#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#240#7#0#0#0#0#0#0#245
+ +#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'1'#255#241#0#0'-'#245#7#246#241#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0'1-'#246'U'#0'1'#255'-'#134#8#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#241
+ +'-'#0#0'1'#255#245#175#8'1'#7#246#241#246#7#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#7#255#245#0
+ +'-'#255'U'#247#255'1'#7#8'-'#255#175#240#247#246#245'-1'#240#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#240#8
+ +#209#7'1'#134#134'1'#246#245#130#247#7#255'11'#255'U'#245#246#175#241#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +'1'#0#8#255#130'-'#246'-'#175#241#170'1'#170#247#240#246#7'-'#246#134#240#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#240#255#247#240#9#255#241#8'1'#134#7#134'1'#175#245#170#247#245#175#255
+ +#7#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#7#255#247#240#8#130#7#130#7#134#130#7#170#130#134'-'#246#246#7
+ +#245#245'-'#0#0#0#0#0#0#0#0#0#0#7'-'#0#0#0#0#0'-'#247#8#130'1'#0#0#0'-'#7#0#0
+ +#0#240#7#245'-'#7#7#7'1'#0#0#0#0#0#0#7#130#8#130#7#240#0#0#0'-'#7#0#0#0#0#0#0
+ +#0#0#240'Y'#130#8#130#7#240#0#0#0#0#0#0'-'#241#0#0#0#0#0'1'#0#0#0#0#240#7#7#7
+ +#7#7#7#240'11'#0#0#0#240#7'-'#0#0#0#0#0#0#0#0#0#0#240#245#0#0#241'1'#209#130
+ +#240#8#170#8#7#255#130#130#8#130'1'#175'Z'#240'-'#134#246#246#245#0#0#0#0#0#0
+ +#0#0#0#246#247#0#0#0#0#7#255#175#130#8#255#130#0#0#170#246#0#0#0#8#246#241#8
+ +#255#175#175#246#8#241#0#0'1'#246#246#8#130#8#246#175'1'#0#0#7#255#0#0#0#0#0
+ +#0#0'-'#175#255#8#130#8#246#209'1'#0#0#0#0#0#170#7#0#0#0#0#240#246#241#0#0#0
+ +#245#255#179#246#175#246#175#240#130#246#0#0#0#8#246#241#0#0#0#0#0#0#0#0#0#0
+ ,#245#246#212#7#246'1'#240#134#8#241#134#255#7#134'U'#134#212'1'#212#7'U'#8
+ +#246#134'U'#245'-1'#0#0#0#0#0#0#0#0#255#247#0#0#0#241#246#247#0#0#0'1'#255'1'
+ +#0#134#8#0#0#247#255'-'#0#8#170#0#0#245#246#8#0'1'#255#134#241#0#0#0#245#170
+ +#255'-'#0#7#255#240#0#0#0#0#0'1'#255#8#241#0#0#0#241#134#255'1'#0#0#0#240#255
+ +#8#0#0#0#0'1'#255#247#0#0#0#244#255'U'#0#0#0#0#0#134#171#0#0#7#255'-'#0#0#0#0
+ +#0#0#0#0#0#0#0#0#7#134#246#255#255#247#244#247#170'-'#130'-'#0#0#0#240#8#246
+ +#134#130#7'-1'#7#175#255#246#7#0#0#0#0#0#0#0#246#7#0#0#0#7#255#240#0#0#0#0#8
+ +#8#0#130#175#0#245#246#7#0#0#8#130#0#0#0#7#246#240#246#170#0#0#0#0#0#0#0#8
+ +#175#0#7#255#0#0#0#0#0#0#175#8#0#0#0#0#0#0#0#8#209#0#0#0#7#255#255'-'#0#0#0
+ +#170#255#8#0#0#0#245#246'1'#0#0#0#0#0#130#8#0'-'#255#7#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#240'1'#245'-'#7#130#212#8#175#8#0#0#0#0#0#0'-'#7#7#247#134#175#255#255#8
+ +'1'#245#0#0#0#0#0#0#0#0#246#7#0#0#0#134#209#0#0#0#0#0#247#246#0#130#8#240#175
+ +#134#0#0#0#8#130#0#0#0#247#175#7#246#245#0#0#0#0#0#0#0'-'#255'11'#255#0#0#0#0
+ +#0'1'#246'-'#0#0#0#0#0#0#0#245#255'U'#0#0#175#130#8#247#0#0#245#246#247#255
+ +'1'#0#0#245#255'1'#0#0#0#0#0#130#8#0#8#8#0#0#0#0#0#0#0#0#0#0#0#0#0#0'-'#255
+ +#255#8#247#7'1U'#247#247#0#0#0#0#0#0#0#134#209#134#7'--11'#0#0#0#0#0#0#0#0#0
+ +#0#246#247#0#0#0#130#8#0#0#0#0#0#7#246#0#247#175#170#255'1'#0#0#0#8#134#240
+ +#245#7#255#7#130#209#0#0#0#0#0#0#0#0#0#246#7#7#255#247#7'1'#240#0#247#246#0#0
+ +#0#0#0#0#0#0#0#175#130#0'1'#255#245#7#255#240#0#7#246#0#8#134#0#0#245#255'1'
+ +#0#0#0#0#0#247#175#170#255'1'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'1'#7#7#247#134
+ +#134#130#247'1'#0#0#0#0#0#0#0#7#130#134#130#130#247#7'1-'#0#0#0#0#0#0#0#0#0
+ +#246'Z'#0#0#0#130#175#0#0#0#0#0#7#255#0#130#255#8#8#246#130#0#0#134#255#246
+ +#246#255#7#0#134#8#0#0#0#0#0#0#0#0#0#175#247'1'#255#8#175#246#175#240#247#175
+ +#0#0#0#0#0#0#0#0#0#8#134#0#134#175#0#240#255'1'#0#246#247#0#7#255#241#0#240
+ +#255#8#166#134#130#134#0#130#255#8#8#246#130#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'U'
+ +'11-'#7#134#209#247#0#0#0#0#0#0#0#130#247'11'#7#247#8#246#255#245#0#0#0#0#0#0
+ +#0#0#246#7#0#0#0#134#8#0#0#0#0#0#7#255#0#134#8#0#0'-'#255#7#0#8#170#241'1'
+ +#175'1'#0#130#246#0#0#0#0#0#0#0#0#0#255#7#7#255#240#0#245#8#130#7#246#0#0#0#0
+ +#0#0#0#0#0#246#7#240#255#7#0#0#8#170'1'#255#245#0#240#255#7#0#245#246#8#130
+ +#134#134#130#0#130#8#0#0'-'#246#7#0#0#0#0#0#0#0#0#0#0#0#240#245'1'#175#255
+ +#255#175#130#247#7#7'-'#0#0#0#0#0#240#175#175#170#8#134#7'--1'#241#0#0#0#0#0
+ +#0#0#0#246#247#0#0#0#130#175#0#0#0#0#0#7#246#0#130#175#0#0#0#130#170#0#8#130
+ +#0#0#7#246#0'1'#255'-'#0#0#0#0#0#0#0'1'#255#245'U'#255#0#0#0#7#175'1'#255'1'
+ +#0#0#0#0#0#0#0'-'#255'-U'#255#240#0#0'1'#246#175#8#0#0#0#134#175#0#245#255'1'
+ +#0#0#0#0#0#130#8#0#0#0#130#8#0#0#0#0#0#0#0#0#0#0#0#247#255#255#8#7'1-'#7#130
+ +#134#209#134#240#0#0#0'-'#134'1'#170#7#245#130#255#255#246#130'1'#0#0#0#0#0#0
+ +#0#0#246#7#0#0#0#130#8#0#0#0#0#0#7#255#0#130#8#0#0#0#8#134#0#171#134#0#0#7
+ +#255#0#0#170#212#240#0#0#0#0#0#240#175#8#0#7#255#0#0#0#7#246#0#170#175#240#0
+ +#0#0#0#0#240#8#8#0#175#134#0#0#0#0#175#255'1'#0#0#0'1'#246'-'#240#255'1'#0#0
+ +#0#0#0#130#175#0#0#0#134#134#240'--'#0#0#0#0#0#0#0#0#0'1-'#241'U'#134#246#8
+ +'1'#130#8'1'#175#247'U'#134#7#209#8'-'#8#130#240#7#175#247#8#246#240#0#0#0#0
+ +#0#240#240#209#247#0#240#0#134#175#0#0#0#0#0#7#255#0#130#175#240#241#7#255'1'
+ +#0#8#134#0'-'#175#130#0#0#245#246#8'-'#0#0#0'-'#175#246#240#0#7#255#240#240
+ +'1'#255#130#0#241#246#212'-'#0#0#0'-'#8#246#241#245#255'1'#0#0#0#0#247#246
+ +#240#0#0#0#0#175#130#245#246#7#0#240#0#240#0#130#8#0#241#7#255#7'-'#7'5'#0#0
+ +#0#0#0#0#0#0#0#0'1'#246#255#247#245#240#247#8'1'#170#175#7#134#209'1'#134#130
+ +#212'-'#170#175'-'#244#0#0#245#240#0#0#0#0#130#246#255#255#255#246#255'-'#247
+ +#8#0#0#0#0#0#7#246#0#247#246#246#255#255#7#0#0#134#255#246#246#134#240#0#0#0
+ +#245#170#255#246#8#246#246#134#241#0#0#7#255#246#246#255#130#240#0#0#240#8
+ +#255#246#8#246#246#8#241#0#170#246#0#0#0#0#0'-^'#0#0#0#0#0#7#255'1'#246#255
+ +#246#255#246#209#245#247#246#246#255#255#7#0'1'#7'U'#0#0#0#0#0#0#0#0#0#0#0'1'
+ +#245'-'#247#246#8')'#8#7#134'U'#130#8#7#170'1'#134#8#241#130#255#7#0#0#0#0#0
+ +#0#0#0'-111111'#240#245'-'#0#0#0#0#0#241'1'#0#245'11-'#240#0#0#0'-11'#241#0#0
+ +#0#0#0#0#0'-'#7#247#7'-'#0#0#0#0#240'11-'#240#0#0#0#0#0#0#245#7#247#7'-'#0#0
+ +#0'1'#245#0#0#0#0#0#0#240#0#0#0#0#0#240'1'#245'-11111'#0#245'11-'#240#0#0#0
+ +#245#0#0#0#0#0#0#0#0#0#0#0#0#0#0#7#246#175#245#134#134'-'#175'1'#134#7#134#7
+ +#134#240#255#8#240#247#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#240#8#175#244#247#246#240#134#130#7#130
+ +'1'#175'1'#246#241#247#246#175#241'1'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#244#175#246#241#7#255'-1'#255#7
+ ,#247#247'-'#255'-'#8#247#245#7#246#8#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#241'U'#245'1'#255#7#241#175
+ +#246'-'#175#7#7#246#7#7#255#240#0#241#246'1'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#240#0#240#7#246
+ +'-'#255'1Y'#175#170#245#246'-'#0#0#245#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#8#130'1'#246
+ +'-'#0'U'#255#245'1'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#245#255'1'#245#245#0#0#245
+ +#255'1'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#240#245#0#0#0#0#0#240#7#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0
+ +#0#0#0#0#0#0#0#0#0#0#0#0#0#160#194#160#160#160#160#194#156#194#160#156#194
+ +#156#160#156#190#160#156#156#194#156#156#160#190#160#156#190#160#156#156#190
+ +#156#190#160#190#160#190#156#190#156#194#156#190#190#160#190#156#160#190#156
+ +#156#190#156#190#156#190#156#190#156#190#156#186#156#152#156#190#152#156#152
+ +#190#152#152#156#152#152#152#156#156#191#161#165#198#165#165#199#165#198#165
+ +#198#199#198#165#199#169#198#203#165#199#198#198#164#194#161#194#161#195#160
+ +#160#161#156#156#191#160#156#156#156#152#152#156#152#152't'#152#148't'#148't'
+ +'ptptpttpt'#148#0#0#0#161#160#161#160#194#160#161#160#156#194#160#156#160#190
+ +#156#160#156#194#156#156#160#190#156#156#156#190#156#190#156#190#156#156#156
+ +#190#156#156#194#156#194#156#156#190#160#156#190#156#156#190#156#156#190#156
+ +#190#156#156#190#156#156#190#156#156#156#156#190#152#156#152#190#152#152#190
+ +#152#152#156#152#152#152#152#156#156#195#161#198#165#199#165#165#199#165#199
+ +#165#199#198#199#165#199#198#203#165#199#199#165#198#199#161#160#161#195#160
+ +#195#161#160#157#157#191#157#156#156#153#152#152#152#152't'#148't'#148'tptpt'
+ +'pptpt'#0#0#0#160#160#160#160#160#160#194#160#160#156#194#156#160#156#160#190
+ +#156#156#160#190#156#156#190#156#156#156#156#156#156#156#190#156#190#156#190
+ +#156#190#156#156#194#156#156#190#160#156#190#156#190#160#190#156#190#156#190
+ +#156#156#190#156#156#190#156#190#156#156#190#156#156#152#156#156#152#156#152
+ +#186#156#152#152#186#152#152#156#191#161#199#165#199#165#199#165#165#198#165
+ +#199#164#199#165#203#199#202#165#198#203#165#198#198#199#194#161#195#160#194
+ +#161#194#160#156#161#156#156#156#152#152#152#152#152't'#152't'#152'p'#152'pt'
+ +#148'tptp'#0#0#0#160#161#194#161#160#160#160#160#190#160#156#160#156#194#156
+ +#156#160#156#190#156#156#190#156#156#190#156#190#156#190#156#156#156#156#156
+ +#156#156#156#190#156#156#190#156#190#156#190#194#156#156#190#190#156#156#190
+ +#156#190#156#156#190#156#156#190#156#156#186#156#156#186#156#186#156#186#156
+ +#152#156#152#186#156#152#156#152#190#156#156#194#165#165#199#165#199#203#165
+ +#199#164#165#198#199#164#199#165#203#199#165#198#199#165#198#165#198#195#161
+ +#195#160#161#195#161#156#161#157#156#156#152#152#152#152#152#148't'#148'tptp'
+ +'tp'#148't'#152#0#0#0#161#160#160#160#160#194#157#160#160#160#156#194#156#156
+ +#160#156#190#156#156#156#156#156#156#156#156#156#156#156#152#156#156#190#156
+ +#156#190#156#190#156#156#190#156#194#156#194#156#156#156#190#156#156#156#190
+ +#156#190#156#190#156#190#156#190#156#156#190#156#156#186#156#156#156#152#156
+ +#152#186#156#152#156#152#156#152#156#152#156#190#157#195#194#199#165#199#165
+ +#165#203#165#199#199#165#199#198#199#198#165#202#199#169#198#165#203#198#165
+ ,#198#160#161#195#160#160#194#157#156#156#157#152#152#152#152#152't'#152'tp'
+ +#152'p'#152'p'#152't'#152#148#0#0#0#160#160#161#160#161#160#160#194#156#156
+ +#160#156#194#156#156#156#156#156#156#156#156#156#156#156#152#156#156#156#156
+ +#156#156#156#190#156#156#156#156#156#190#156#190#156#156#190#190#160#190#160
+ +#190#156#194#156#190#156#156#156#190#156#156#156#190#156#156#190#156#156#190
+ +#156#186#156#190#156#156#156#190#156#152#190#152#190#156#152#156#156#156#161
+ +#161#199#165#199#199#165#199#165#164#199#164#199#164#199#198#165#198#199#203
+ +#198#199#165#203#165#199#199#164#195#195#161#160#161#190#156#156#152#152#152
+ +#152#152't'#148#152'p'#152't'#148't'#148't'#152#0#0#0#160#195#160#160#160#157
+ +#160#160#161#194#156#161#156#160#156#156#156#156#156#156#156#156#156#156#156
+ +#156#152#156#152#156#152#156#156#156#190#156#190#156#156#156#156#190#156#156
+ +#190#156#190#156#190#156#190#156#156#190#190#156#156#190#190#156#156#190#156
+ +#156#190#156#152#156#156#156#152#190#152#156#152#190#156#156#156#152#156#190
+ +#156#190#156#190#156#195#164#165#199#165#199#199#199#165#199#165#199#165#199
+ +#199#165#198#199#165#202#198#199#198#169#198#199#164#160#195#194#161#157#160
+ +#157#156#156#152#152#152#152't'#152't'#148't'#152#152#152#152#152#0#0#0#161
+ +#160#160#161#194#160#160#156#160#156#160#156#156#156#156#156#156#156#156#156
+ +#152#156#156#152#156#152#156#152#156#152#156#152#156#152#156#156#156#156#190
+ +#156#190#156#190#156#156#190#156#156#190#156#156#190#190#156#156#190#156#156
+ +#156#190#190#156#156#190#156#156#190#156#190#152#190#156#156#190#156#152#156
+ +#186#156#190#152#156#152#156#156#156#157#156#195#195#165#199#165#165#165#199
+ +#165#164#199#164#199#164#199#199#164#199#199#165#203#165#203#165#198#199#199
+ +#164#161#194#160#191#156#156#157#156#152#152#152#152#152#152#152#152#152#152
+ +#152#152#152#0#0#0#160#160#161#160#160#161#156#161#160#156#161#156#160#156
+ +#156#156#156#156#156#156#156#156#152#156#152#156#152#156#152#156#152#156#156
+ +#156#156#156#156#190#156#156#156#156#156#156#190#156#156#190#156#156#190#156
+ +#156#156#190#156#190#156#190#156#156#156#190#156#156#190#156#190#156#190#156
+ +#156#190#152#156#190#156#156#156#156#156#190#156#190#156#190#156#190#157#156
+ +#161#195#165#199#199#164#199#195#164#199#198#161#198#164#199#198#165#198#198
+ +#199#198#199#203#199#164#198#198#198#161#160#157#156#156#156#156#152#152#152
+ +#152#152#152#152#152#152#152#152#152#0#0#0#160#161#160#160#161#160#160#160
+ +#156#160#156#156#156#156#156#156#157#156#152#156#152#156#152#156#152#152#152
+ +'t'#152#152#156#152#152#156#152#156#156#156#156#190#156#190#156#190#156#156
+ +#190#156#156#190#156#190#156#190#156#190#156#190#156#156#190#190#156#156#190
+ +#156#156#156#152#156#156#186#156#156#190#156#186#156#190#152#190#152#156#152
+ +#156#156#156#156#156#152#190#156#195#160#165#195#164#165#199#161#165#198#165
+ +#199#164#199#198#165#199#198#169#198#165#202#199#199#198#165#198#198#160#160
+ +#191#156#157#156#152#152#152#152#152#152#152#152#152#152#152#0#0#0#161#160
+ +#161#160#160#157#160#157#160#157#160#156#156#156#157#156#156#156#156#156#156
+ +#152#156#152#156#152#152#156#152#152#152#156#152#152#156#152#156#156#152#156
+ +#156#156#156#156#190#156#156#190#156#156#190#156#190#156#156#156#190#156#190
+ +#156#156#156#190#190#156#190#156#190#156#190#156#156#190#152#156#156#156#190
+ +#156#156#156#190#156#190#152#156#190#152#156#156#156#152#156#191#156#161#195
+ +#194#161#198#195#161#198#161#198#165#199#198#165#199#198#199#202#165#202#165
+ +#202#199#198#199#198#198#160#160#190#156#156#152#156#152#152#152#152#156#152
+ +#152#152#0#0#0#161#160#160#161#156#160#160#156#160#156#156#156#157#156#156
+ +#156#156#156#156#152#156#152#156#152#152't'#152#152#152#156#152't'#156#152
+ +#152#156#156#152#156#156#152#156#190#156#156#156#190#156#190#156#156#156#156
+ +#190#190#156#190#156#156#190#156#190#156#156#156#156#190#156#190#156#156#190
+ +#156#156#190#156#190#152#156#190#152#156#152#156#156#186#156#156#186#152#152
+ +#152#152#152#156#190#156#161#194#161#164#194#165#194#165#194#164#199#198#164
+ +#199#164#199#198#199#203#199#168#199#168#199#202#198#198#160#156#190#156#152
+ +#152#156#152#152#152#152#152#152#0#0#0#160#160#161#160#160#161#156#161#156
+ +#156#157#156#156#156#156#156#156#152#156#156#152#152#156#152#156#152#156#152
+ +#152't'#152#152#152#156#152#156#152#152#156#152#190#156#156#156#190#156#156
+ +#156#156#156#190#156#190#156#156#156#156#156#190#156#190#156#156#190#156#190
+ +#156#156#156#152#190#156#152#190#156#152#156#156#190#152#156#156#190#156#186
+ +#156#152#152#152#156#152#152#152#152#152#152#156#191#160#161#194#195#161#198
+ +#161#198#161#199#164#199#199#198#199#165#202#199#168#199#202#199#202#198#199
+ +#198#202#198#160#160#156#156#190#152#156#152#152#156#152#0#0#0#160#161#160
+ +#156#161#156#160#156#157#156#156#156#156#156#157#156#156#156#157#152#156#156
+ +#152't'#152#152't'#152'x'#152't'#152#152#152#152#152#152#156#152#156#156#156
+ +#186#156#156#190#156#190#156#190#156#190#156#190#156#190#156#190#156#156#156
+ +#190#156#156#190#156#156#190#190#156#156#190#156#156#190#156#190#152#156#156
+ ,#190#152#156#152#156#152#152#156#186#152#156#152#152#152#152#152#152#152#156
+ +#190#161#160#194#161#194#161#198#160#199#164#198#165#198#198#165#198#203#198
+ +#203#202#165#203#168#203#198#202#198#198#198#160#156#156#156#156#156#152#152
+ +#0#0#0#161#160#161#160#156#161#156#160#156#161#156#156#157#156#156#156#157
+ +#156#156#156#152#156#152#156#152'x'#152#152#152#152#152#152't'#152#152#152
+ +#156#152#152#152#152#156#156#156#156#156#152#156#156#156#156#156#156#156#190
+ +#156#190#156#190#156#190#156#190#156#156#190#156#156#156#190#156#156#190#152
+ +#156#190#156#190#156#152#156#156#186#156#186#156#186#152#156#152#152#152#152
+ +#152#152#152#152#152#152#152#190#161#160#195#160#199#161#198#161#199#164#199
+ +#165#198#198#169#199#203#164#203#202#202#203#202#169#202#203#202#202#198#198
+ +#160#190#156#156#156#156#0#0#0#160#161#156#161#160#156#156#157#156#156#156
+ +#157#156#156#156#156#156#156#156#152#156't'#156't'#152#152't'#152't'#152't'
+ +#152#152#152#152#152#152#152#156#156#156#152#156#186#156#156#156#156#190#156
+ +#190#156#190#156#156#156#156#190#156#156#190#156#156#190#156#156#190#156#190
+ +#156#186#156#156#156#190#156#152#156#152#190#156#186#156#152#156#152#156#156
+ +#152#152#190#152#152#152#152#152#152#152#152#152#152#152#190#161#160#194#160
+ +#195#164#194#165#198#198#199#165#198#198#202#199#203#165#203#202#203#202#203
+ +#202#168#202#203#202#202#164#194#156#156#190#0#0#0#161#160#161#160#157#160
+ +#157#160#156#156#157#156#156#157#156#157#156#156#152#157#156#152#157#152#156
+ +'t'#153't'#152't'#152#152't'#152#152#152#156#152#156#152#152#156#156#156#156
+ +#186#156#190#156#156#156#190#156#156#190#156#190#156#156#190#156#156#190#156
+ +#156#190#156#152#156#190#156#156#156#190#152#156#190#156#190#156#152#156#152
+ +#156#186#156#152#186#152#156#152#152#152#152#152#152#152#152#152#152#152#152
+ +#152#156#190#161#194#161#194#165#194#165#199#164#198#198#169#199#169#202#203
+ +#202#169#202#203#202#203#202#203#202#202#202#202#202#198#198#160#0#0#0#160
+ +#161#160#157#160#161#156#156#157#156#160#157#156#156#156#156#156#157#156#156
+ +'t'#156't'#152't'#152#156#152#152#153't'#152#152#152#156#152#152#156#152#156
+ +#156#152#156#152#156#156#156#152#156#190#156#156#190#156#156#190#156#156#190
+ +#156#156#190#156#156#190#156#156#190#156#156#156#190#152#156#190#152#156#152
+ +#156#152#190#156#186#156#152#156#152#156#186#152#152#156#186#152#152#152#152
+ +#152#152#152#152#152#152#152#152#156#161#194#161#194#199#160#198#199#165#199
+ +#198#198#202#199#202#203#203#202#203#168#203#202#206#203#168#203#206#202#202
+ +#168#198#0#0#0#161#160#161#160#161#156#161#160#156#157#156#156#156#157#156
+ +#156#156#156#156#156#156#152#156'x'#156't'#152't'#152#152#152#152#156#152#152
+ +#152#156#152#156#152#156#156#152#156#152#156#156#156#156#156#190#156#156#190
+ +#156#156#190#156#156#190#156#156#190#156#156#190#156#156#190#156#156#156#190
+ +#152#156#190#156#190#156#156#152#156#156#186#156#186#156#152#156#152#186#152
+ +#156#152#152#152#152#152#152#152#152#152#152#152#152#152#156#156#194#160#160
+ +#199#160#198#198#165#203#199#164#203#198#169#202#203#202#203#202#203#202#207
+ +#202#203#202#207#202#202#202#0#0#0#160#161#160#160#157#160#157#156#161#156
+ +#157#160#157#160#156#157#156#156#157#152#156'y'#152#152#152#152#152#152#152
+ +'t'#156't'#152#152#152#156#152#156#152#156#152#152#156#152#156#152#190#156
+ +#156#190#156#156#190#156#190#156#156#190#156#156#190#156#156#156#190#156#156
+ +#190#156#190#152#190#156#156#190#152#156#152#156#186#156#190#152#156#152#156
+ +#152#190#152#156#152#152#152#152#186#152#152#152#152#152#152#152#152#152#152
+ +#152#152#152#156#195#160#194#199#164#199#198#198#198#203#198#169#202#203#168
+ +#203#202#207#168#207#202#203#206#203#168#206#203#206#0#0#0#161#160#161#161
+ +#160#161#160#161#156#156#160#156#156#156#156#156#156#156#156#156'x'#152#156
+ +#152'x'#153#156't'#152#152#152#152#152#152#156#152#156#152#156#152#156#156
+ +#152#156#156#156#152#156#190#156#156#190#156#156#156#156#190#156#156#190#156
+ +#156#190#190#156#156#190#156#152#156#156#156#190#156#152#156#156#190#156#156
+ +#156#152#156#152#190#152#186#156#152#152#156#152#186#152#156#152#152#152#152
+ +#152#152#152#152#152#152#152#148#152#152#156#190#195#160#199#198#164#199#169
+ +#202#198#203#203#198#203#202#203#202#203#202#169#206#173#202#207#207#202#203
+ +#0#0#0#160#157#160#160#161#160#157#160#161#160#157#156#161#156#157#156#157
+ +#156#156#152#156#152't'#156#152't'#152#156't'#152#153#152#152#156#152#152#156
+ +#152#156#152#156#152#156#156#186#156#190#156#156#156#190#156#156#190#156#190
+ +#156#190#190#156#190#156#156#156#190#156#156#190#156#190#156#190#152#190#156
+ +#190#152#156#186#156#186#156#186#156#152#156#156#152#156#152#186#156#152#152
+ +#152#152#152#152#152#152#152#152#152#152#152#152#152#152#152#152#152#156#194
+ +#160#198#199#198#198#199#169#202#202#203#202#169#202#203#206#203#206#203#203
+ +#207#206#202#203#206#0#0#0#160#160#161#160#161#160#161#160#156#161#160#160
+ +#156#160#156#156#156#156#157#156#156#156#157#152#156#156#156't'#156#152'x'
+ +#152#156#152#156#152#156#152#152#156#152#156#152#156#156#156#156#190#156#156
+ ,#156#190#156#156#190#156#156#156#156#156#156#190#156#156#152#190#156#156#190
+ +#156#152#156#156#152#156#152#190#156#156#152#156#156#152#156#190#152#156#186
+ +#152#156#152#152#156#186#152#152#152#152#152#152#152#152#152#152#152#152#152
+ +#152#152#152#152#152#156#194#165#198#199#198#202#198#203#168#203#202#202#207
+ +#202#203#202#203#206#202#207#169#207#172#203#0#0#0#160#161#160#161#156#161
+ +#156#161#160#161#156#161#156#157#156#156#156#156#156#156#156#152#156#156't'
+ +#152't'#152#152't'#152#152#152#156#152#156#152#156#156#152#156#152#156#190
+ +#156#190#156#156#190#156#190#156#156#190#156#190#156#190#156#190#156#156#190
+ +#156#190#156#156#186#156#156#190#156#190#156#190#156#156#152#190#156#186#156
+ +#190#152#156#152#156#152#156#186#156#152#152#152#152#156#186#152#152#152#152
+ +#152#152#152#152#152#152#152#152#148#152#152#152#152#194#194#164#198#199#202
+ +#199#202#202#203#203#202#203#172#203#206#203#173#202#207#202#203#207#0#0#0
+ +#160#160#160#160#160#160#161#160#161#156#160#160#156#160#156#157#156#156#156
+ +#152'x'#156't'#152#156'u'#156#152'y'#152#156#152#156#152#156#152#156#156#152
+ +#156#156#190#156#156#156#156#156#190#156#156#156#156#190#156#156#156#190#156
+ +#156#156#156#190#156#156#156#156#190#156#156#190#152#156#152#156#152#156#186
+ +#156#156#152#156#156#152#156#152#190#152#190#152#156#152#152#186#156#152#152
+ +#152#152#152#152#152#152#152#152#152#152#152#152#152#152#152#152#148#152#152
+ +#156#194#199#198#202#202#202#203#202#202#202#203#202#203#168#207#202#207#202
+ +#207#172#207#0#0#0#161#160#161#160#161#160#160#160#160#160#161#156#160#157
+ +#156#156#156#157#156#156#152#157#152'x'#152#152't'#152#152#152#152#156#152
+ +#156#152#156#152#156#156#152#156#156#156#190#156#190#156#156#156#190#156#190
+ +#156#190#156#190#156#156#190#190#156#156#190#156#190#152#156#156#190#156#190
+ +#156#190#156#190#156#156#186#156#190#152#186#156#190#152#156#152#156#152#152
+ +#186#156#152#152#186#152#152#152#152#186#152#152#152#152#152#152#152#152#152
+ +#152#152#152#152#152#148#152#152#194#198#199#198#203#202#202#203#203#202#203
+ +#206#207#202#207#202#173#207#203#207#0#0#0#160#160#160#160#160#161#160#161
+ +#160#160#156#161#156#160#156#156#156#156#156#157'x'#152'x'#152'x'#156#152't'
+ +#156#156#153#156#152#152#156#152#156#152#156#190#156#190#156#156#156#156#190
+ +#156#190#156#156#156#156#156#190#156#190#156#156#156#190#156#156#156#156#190
+ +#156#156#152#156#156#156#152#156#156#186#156#156#152#156#156#156#152#156#152
+ +#190#152#156#156#156#152#152#156#152#156#152#156#186#152#152#152#152#152#152
+ +#152#152#152#152#152#152#152#152#152#152#152#152#152#152#156#194#198#198#203
+ +#202#202#202#207#202#203#202#207#202#207#202#207#172#207#0#0#0#160#161#160
+ +#161#160#160#160#160#160#161#160#160#160#156#161#156#156#156#156'x'#152'x'
+ +#152'xu'#152'x'#156#152#152#156#152#156#156#152#156#156#190#156#156#156#156
+ +#156#190#156#190#156#156#156#190#156#190#156#190#156#156#156#190#156#190#156
+ +#156#190#152#190#156#156#186#156#190#152#190#156#190#152#156#152#190#156#186
+ +#152#190#152#156#156#152#156#186#152#152#186#156#152#186#152#152#152#152#156
+ +#152#152#152#152#152#152#152#152#152#152#152#152#152#152#152#152#152#148#152
+ +#152#156#194#199#198#198#203#202#202#202#207#202#173#202#207#173#203#207#207
+ +#0#0#0#160#160#160#160#160#161#160#161#160#160#160#160#157#160#156#156#157
+ +#156'x'#152'x'#152'yt'#152#152#157#152#152#156#156#156#156#152#156#156#156
+ +#156#156#156#190#156#190#156#156#156#156#156#190#156#156#156#190#156#156#156
+ +#190#156#156#156#152#190#156#156#156#156#190#156#156#156#190#156#156#152#156
+ +#156#190#156#152#156#156#156#156#186#152#190#152#152#156#152#156#152#156#152
+ +#156#152#152#152#152#152#152#152#152#152#152#152#152#152#152#152#152#152#152
+ +#152#152#152#152#152#152#148#152#156#194#199#202#203#202#203#206#203#202#207
+ +#203#202#207#207#169#0#0#0#160#165#160#161#160#160#160#160#160#161#160#160
+ +#160#156#160#156#156#156#156#157'xt'#152#156#156'x'#152#156#156#156#152#156
+ +#152#156#190#156#156#156#190#156#156#156#156#156#190#156#190#156#156#156#190
+ +#156#156#156#190#156#156#190#156#190#156#156#190#156#190#152#156#156#190#152
+ +#156#152#190#156#190#152#156#152#190#156#186#152#152#156#156#152#156#156#186
+ +#156#152#186#152#152#152#186#156#152#152#186#156#152#152#152#152#152#152#152
+ +#152#152#152#152#152#152#152#152#152#152#152#152#152#152#156#194#198#198#203
+ +#202#203#202#207#202#173#207#172#207#207#0#0#0#160#160#160#160#160#161#160
+ +#160#160#194#160#161#160#160#157#160#156#156'x'#156#156'xtt'#152#152#156#152
+ +#156#152#156#156#156#156#156#156#190#156#156#190#156#190#156#156#156#156#156
+ +#190#156#190#156#190#156#190#156#156#190#156#156#156#190#156#156#152#156#190
+ +#156#152#156#190#156#156#152#156#156#190#152#156#152#156#156#156#190#152#156
+ +#152#186#156#152#152#156#152#156#152#156#152#152#152#152#152#152#152#152#152
+ +#152#152#152#152#152#152#152#152#152#152#152#152#152#152#152#152#152#152#152
+ +#156#157#194#203#202#203#202#203#207#202#207#203#173#207#0#0#0#160#165#160
+ +#165#194#160#164#195#160#161#160#160#160#156#160#156#156#157#156#156'x'#157
+ ,#156#156#157#156#156#156#156#156#156#156#156#156#156#156#156#156#156#156#156
+ +#156#156#190#156#190#156#156#156#156#156#156#156#156#156#190#156#190#156#190
+ +#156#190#156#190#156#156#156#190#156#152#156#190#156#190#152#156#156#190#156
+ +#186#156#186#156#152#190#156#156#152#156#190#152#156#152#186#152#152#156#186
+ +#156#152#152#152#152#152#152#152#152#152#152#152#152#152#152#152#152#152#152
+ +#152#152#152#152#152#152#152#156#156#194#198#203#198#169#202#207#203#206#207
+ +#203#0#0#0#164#160#160#160#160#160#161#160#160#160#160#160#161#160#160#156
+ +#160#156#156#156#156#156#156#156#156#156#156#156#156#156#156#156#156#156#190
+ +#156#190#156#190#156#156#190#156#156#156#156#156#156#190#156#190#156#190#156
+ +#190#156#156#156#156#156#156#152#156#156#186#156#186#156#152#156#190#152#156
+ +#152#156#156#186#156#152#156#152#156#152#156#152#152#152#190#152#152#152#152
+ +#152#152#156#152#152#152#152#152#152#152#156#152#152#152#152#152#152#152#152
+ +#152#152#152#152#152#152#152#152#152#152#152#156#156#152#156#156#195#194#203
+ +#203#202#203#172#207#173#207#0#0#0#160#160#165#160#165#160#160#160#160#160
+ +#161#160#160#160#156#161#156#156#156#157#156#156#156#156#156#156#156#156#156
+ +#156#156#156#156#156#156#156#156#156#156#190#156#156#190#156#190#156#190#156
+ +#156#156#156#156#156#156#156#156#190#156#190#156#190#156#190#156#156#156#156
+ +#156#190#152#156#156#190#156#186#156#156#152#156#190#152#156#156#186#156#156
+ +#156#152#156#152#156#186#156#152#152#152#156#152#156#156#157#156#156#156#157
+ +#156#156#157#156#156#156#156#156#156#157#152#152#152#152#156#152#156#152#156
+ +#156#156#152#156#156#194#198#203#203#203#207#207#202#0#0#0#165#160#194#160
+ +#160#161#160#160#195#160#160#160#160#157#160#156#160#156#156#156#156#156#157
+ +#156#156#156#156#157#156#156#156#156#190#156#156#190#156#156#156#156#190#156
+ +#156#156#156#156#156#190#156#190#156#190#156#190#156#156#156#156#156#152#156
+ +#156#152#190#152#190#152#156#156#190#152#156#152#156#156#186#156#190#152#156
+ +#156#186#152#156#186#152#186#156#152#190#152#156#152#156#156#156#156#157#156
+ +#156#156#157#156#156#156#161#156#156#157#156#157#156#157#156#156#156#156#156
+ +#156#157#156#156#156#156#152#156#156#156#156#156#156#194#202#202#203#202#207
+ +#0#0#0#164#165#160#164#160#198#160#160#160#160#160#161#160#160#160#156#160
+ +#157#160#156#161#156#156#156#156#156#156#156#156#190#156#156#156#156#156#156
+ +#156#190#156#156#156#156#190#156#156#190#156#156#156#156#156#156#156#156#156
+ +#190#156#190#156#190#156#186#156#156#156#156#156#190#152#156#156#190#152#190
+ +#152#156#152#156#152#190#152#156#156#152#156#156#156#156#156#156#156#156#156
+ +#156#156#156#157#156#156#157#157#160#157#157#157#157#157#157#157#161#161#157
+ +#157#157#157#157#161#157#161#156#156#157#156#156#156#156#153#156#152#157#156
+ +#156#195#198#202#203#202#0#0#0#165#164#164#161#160#160#161#160#160#161#160
+ +#160#160#160#156#161#156#160#156#156#156#156#160#156#161#156#160#156#156#156
+ +#156#156#156#156#156#156#156#156#156#190#156#156#156#156#190#156#156#190#156
+ +#156#190#156#190#156#190#152#156#156#152#156#156#156#156#190#156#186#156#152
+ +#156#186#156#152#156#156#156#152#190#156#152#156#152#156#186#156#156#156#156
+ +#156#157#156#156#157#156#157#156#157#156#161#157#161#160#157#161#161#161#161
+ +#161#161#161#161#157#161#161#161#161#161#161#161#161#161#157#156#156#156#156
+ +#156#156#156#156#156#156#156#156#156#195#198#202#0#0#0#165#165#165#164#164
+ +#160#160#160#160#160#160#160#161#160#160#160#160#156#160#160#156#160#156#156
+ +#156#156#156#156#156#156#156#156#190#156#156#190#156#156#156#156#156#190#156
+ +#156#156#156#156#156#190#156#156#156#156#156#156#156#156#190#156#190#152#190
+ +#156#152#156#156#156#190#156#156#152#156#186#156#186#156#156#152#190#152#156
+ +#156#156#156#190#156#157#190#156#156#157#156#156#156#161#156#161#157#160#157
+ +#161#161#161#161#161#161#161#161#161#161#161#161#161#161#161#161#161#161#161
+ +#161#161#161#157#156#156#156#152#156#156#152#156#152#156#156#156#195#198#0#0
+ +#0#165#169#165#165#165#164#165#160#161#160#160#160#160#160#160#156#160#160
+ +#190#161#160#156#160#156#160#156#156#156#160#156#156#156#156#156#156#156#156
+ +#190#156#156#156#156#156#190#156#156#190#156#156#190#156#190#156#190#156#190
+ +#156#156#156#156#156#152#156#190#152#190#152#156#152#190#156#156#156#152#156
+ +#152#186#156#156#156#190#157#156#161#156#157#160#157#161#156#161#157#195#157
+ +#161#157#160#161#161#161#161#161#161#161#161#161#161#161#161#161#161#161#161
+ +#161#161#162#161#162#161#162#161#161#161#157#157#156#156#156#156#156#156#156
+ +#156#152#156#156#156#0#0#0#169#165#169#169#165#165#164#160#160#160#161#160
+ +#160#160#161#160#160#160#160#160#156#160#157#160#190#156#160#156#156#190#156
+ +#156#156#156#156#156#156#156#156#156#190#156#156#156#156#190#156#156#156#156
+ +#156#156#156#156#152#156#156#186#156#156#190#156#190#152#156#156#156#186#156
+ +#156#152#190#152#152#156#156#156#156#156#157#156#156#160#157#160#195#160#161
+ +#194#161#160#161#160#161#160#161#161#161#161#161#161#161#161#161#161#161#161
+ +#161#161#161#161#161#161#161#162#161#161#161#161#161#161#161#161#161#161#156
+ ,#157#156#156#157#152#156#152#157#156#152#156#0#0#0#169#169#170#165#165#165
+ +#165#165#164#160#160#160#161#160#160#160#161#156#160#156#160#194#156#160#157
+ +#160#190#156#160#156#160#156#156#156#156#156#156#156#156#156#156#156#190#156
+ +#156#156#156#156#190#156#190#152#190#156#156#156#190#156#156#186#156#156#152
+ +#156#156#186#156#152#156#186#156#152#156#190#156#190#156#156#191#160#161#195
+ +#161#195#161#161#161#161#161#161#195#161#161#161#161#161#157#161#161#157#161
+ +#161#161#161#161#161#161#161#161#161#161#161#161#161'}'#161#161'~'#161#162
+ +#161#162#161#161#157#157#156#156#156#156#156#156#156#156#156#156#156#0#0#0
+ +#170#133#169#169#170#169#165#165#165#165#160#160#160#160#160#160#160#160#160
+ +#160#157#160#156#160#156#156#161#156#156#156#156#156#156#190#156#156#156#156
+ +#156#190#156#156#156#190#156#156#190#156#156#156#156#156#156#152#190#156#152
+ +#156#156#156#152#156#156#190#152#156#152#190#152#156#152#156#156#157#156#157
+ +#157#160#161#161#161#161#161#161#161#161#161#195#161#161#161#161#161#161#161
+ +#161#161#157#161#161#157#161#157#161#161#161#161#161#161#161#161#161#161#161
+ +#161#161#161#161#161'}'#161#161#162'}'#161#161#157#157#156#156#156#156#156
+ +#152#156#152#156#0#0#0#170#170#170#169#169#170#169#165#165#165#165#160#161
+ +#160#161#160#160#161#156#160#160#156#160#156#160#160#156#160#160#156#156#194
+ +#156#156#156#156#156#190#156#156#156#156#156#156#156#156#156#152#190#156#156
+ +#156#190#156#156#190#156#190#152#156#156#186#156#156#156#156#156#156#186#156
+ +#156#190#156#156#156#160#195#161#161#195#165#195#165#195#165#195#161#161#161
+ +#161#161#161#161#161#161#161#161#161#161#161#160#161#161#161#157#161#161#157
+ +#161#161#161#157#161#161#161#161'}'#161#161#161'}'#161#161#161#161'}'#161'y'
+ +#157#156#157#156#156#156#157#156#156#0#0#0#170#170#170#170#170#169#170#169
+ +#170#165#165#165#164#160#160#160#160#156#160#160#156#160#157#160#190#156#160
+ +#190#156#156#160#156#156#156#156#156#156#156#156#156#156#156#190#156#156#190
+ +#156#156#156#156#186#156#156#156#152#156#156#152#156#190#152#156#152#190#152
+ +#186#152#156#156#156#156#156#156#195#161#161#161#161#199#165#161#165#161#161
+ +#161#165#161#165#161#195#161#161#161#161#161#161#161#161#156#161#157#161#157
+ +#161#161#161#156#161#161#157#161#161#161#157#161#157#161#157#161#161#161#161
+ +'}'#157'}'#161#161#157#161#157#156#157#156#156#156#156#156#0#0#0#8#170#134
+ +#170#170#134#170#169#169#169#169#165#165#165#160#161#160#160#156#157#160#160
+ +#156#160#156#160#160#156#160#156#156#156#156#156#156#156#156#156#156#156#190
+ +#156#156#156#152#156#156#190#156#156#156#156#156#186#156#156#152#156#156#152
+ +#156#156#156#152#156#156#156#156#156#157#156#161#161#161#161#199#165#199#165
+ +#195#165#195#165#195#165#195#161#195#161#161#161#199#161#161#161#161#161#161
+ +#161#161#161#161#161#157#161#157#161#161#156#161#161#161#157#161#161#161#161
+ +#161'}'#161#161'y'#161'}'#161'y'#157'}'#161'y'#157#160#156#157#156#156#156#0
+ +#0#0#170#8#170#8#170#170#170#170#170#170#169#169#165#165#165#164#161#160#160
+ +#160#156#156#160#156#160#156#157#156#156#160#156#160#157#156#156#156#156#156
+ +#156#156#156#156#156#156#156#156#156#156#152#190#152#156#152#156#152#156#190
+ +#156#186#156#152#190#152#156#152#156#157#156#191#160#195#161#195#165#199#165
+ +#165#165#166#165#165#165#165#165#161#161#165#161#165#161#161#161#161#161#195
+ +#161#161#161#161#161#161#157#160#161#160#161#161#157#161#157#156#161#161#157
+ +#161#157#161#157#161#157#161#161#157#161#157'}}'#157'y'#161'y'#157'y'#156#156
+ +#156#156#0#0#0#170#8#170#8#8#170#8#170#170#170#170#169#170#169#165#165#164
+ +#161#160#160#161#156#156#156#160#160#160#156#160#157#156#156#156#156#156#156
+ +#156#156#156#156#156#152#156#190#156#156#186#156#156#156#156#190#156#156#190
+ +#152#156#152#156#156#156#152#156#190#156#156#156#160#161#161#161#199#165#165
+ +#165#199#165#199#165#166#195#166#195#165#165#195#165#161#195#165#195#161#195
+ +#161#161#161#161#161#161#161#161#161#161#157#161#157#160#157#160#161#157#157
+ +#156#161#156#161#157#161#157#161'y'#161#161'y'#161#157#161'y'#161'y'#161'y'
+ +#161'y'#157#157#156#0#0#0#8#8#8#170#8#8#170#8#170#170#170#170#169#170#169#165
+ +#165#165#160#160#160#160#160#161#156#156#156#160#156#156#160#156#156#156#156
+ +#156#156#156#156#156#156#156#156#156#156#156#156#156#156#152#156#156#152#156
+ +#152#156#156#156#152#156#152#156#156#156#157#160#195#161#161#199#165#165#200
+ +#165#199#165#166#166#165#199#165#165#165#166#195#165#161#199#161#161#165#165
+ +#161#165#161#195#161#161#161#161#161#161#161#161#161#160#157#195#157#157#160
+ +#157#161#157#161#157#161#157#161#157#161#157'}'#161#157'}'#157#161'}'#157'y'
+ +#157'y'#157'yx'#157#0#0#0#8#170#8#8#8#170#8#8#8#170#8#170#170#170#169#169#169
+ +#165#165#165#160#160#156#156#156#156#160#156#160#156#156#156#156#156#156#156
+ +#156#156#156#156#156#156#156#152#156#156#156#152#190#156#156#152#156#156#156
+ +#156#190#152#156#190#156#156#156#157#160#161#161#165#199#165#165#200#165#169
+ +#166#166#199#165#199#166#165#166#161#195#165#162#165#161#165#165#195#161#161
+ +#195#161#165#161#161#161#161#161#161#161#160#161#157#161#160#157#160#157#156
+ ,#157#156#157#156#157#161#156#157'}'#157#161#157'y'#161'y'#161'y'#157'}'#157
+ +'yyy'#157'y'#0#0#0#8#9#170#171#170#9#170#8#170#8#170#8#170#170#170#170#170
+ +#169#169#165#165#165#160#160#160#156#157#156#156#160#156#156#156#156#156#157
+ +#156#156#156#156#156#156#156#156#156#152#156#156#156#152#156#156#156#190#152
+ +#156#152#156#156#156#156#191#160#161#195#161#199#165#165#199#166#169#199#166
+ +#199#165#166#165#166#165#165#195#166#165#161#165#196#165#195#161#161#165#161
+ +#165#161#161#161#195#161#161#161#161#161#161#160#195#156#161#156#157#156#157
+ +#156#157#157#157#156#157#157#156#157#157'y'#157#161#157#157'}'#157'}'#157'}y'
+ +#157'yyy'#0#0#0#170#8#8#8#8#8#8#171#8#171#8#8#170#8#170#170#170#170#169#170
+ +#165#165#165#160#161#160#156#156#157#156#156#157#156#156#156#156#156#156#156
+ +#156#156#156#156#156#156#156#152#156#156#156#152#190#152#156#156#156#156#156
+ +#156#157#156#161#161#161#165#166#165#199#170#165#199#166#169#200#170#199#166
+ +#199#165#166#165#165#161#165#161#165#161#161#165#165#161#161#200#161#165#195
+ +#165#161#161#161#195#161#161#195#161#160#161#157#194#157#161#156#157#156#156
+ +#157#157#156#157#157#156#157#157'y'#157'y'#157#157'y'#157'y'#157#157'y'#157
+ +'yy'#0#0#0#8#171#8#9#170#171#8#8#8#8#8#171#8#8#170#8#170#170#170#169#169#165
+ +#165#165#160#160#160#156#160#156#156#156#156#160#156#156#156#156#156#156#156
+ +#152#156#152#156#156#157#156#152#156#156#156#156#156#156#190#156#156#161#160
+ +#161#161#165#199#165#165#199#170#199#166#170#199#166#165#165#166#165#165#166
+ +#199#161#200#161#165#196#165#161#165#161#196#161#199#161#161#161#161#161#161
+ +#199#161#165#161#161#161#161#195#157#194#157#156#156#191#156#157#157#156#156
+ +#157#156#157#157#156#157#156#157#156#157'x'#157'y'#157'yyyyy'#157#0#0#0#8#8
+ +#170#8#8#8#8#8#171#8#9#170#8#170#8#170#8#170#170#170#170#169#169#165#165#165
+ +#160#160#156#156#156#156#156#156#157#156#156#156#156#156#156#156#156#156#156
+ +#156#152#156#156#156#157#156#156#156#157#156#160#161#195#161#165#165#199#166
+ +#199#200#170#199#165#170#199#165#170#199#166#200#165#200#165#166#165#161#165
+ +#161#165#161#200#161#165#161#165#161#161#165#161#199#161#165#161#161#161#161
+ +#195#161#195#161#160#161#160#190#157#156#156#190#156#156#157#157#156#157#156
+ +#157#156#157'y'#157'y'#157'y'#156'yy'#157'y'#157'yy'#0#0#0#170#9#8#171#8#8
+ +#171#8#8#170#8#8#8#171#8#171#8#8#170#170#170#170#170#169#169#165#165#161#160
+ +#160#161#156#161#156#160#156#157#156#156#156#156#156#156#156#152#156#156#156
+ +#156#156#156#156#157#156#156#161#161#161#161#165#199#165#166#165#170#165#169
+ +#166#170#199#170#200#165#166#165#165#165#166#165#161#165#165#162#165#161#161
+ +#161#161#161#161#161#165#161#161#161#161#161#195#161#165#195#161#161#161#160
+ +#195#160#191#156#161#156#157#156#157#156#157#156#156#157#156#157#156#157#156
+ +#153#156#157#152#157'y'#157#157'xyy'#156'y'#0#0#0#8#170#8#170#9#8#170#9#8#171
+ +#8#171#8#8#8#8#170#8#8#8#8#170#170#170#169#170#165#165#161#160#156#160#156
+ +#156#156#156#156#156#156#157#156#156#156#156#156#156#156#156#156#156#156#156
+ +#160#161#161#161#161#165#165#165#166#199#170#199#170#200#166#203#166#166#165
+ +#169#200#165#166#200#165#165#200#165#196#165#161#199#161#165#161#165#161#165
+ +#161#161#165#161#165#161#165#161#161#161#161#165#195#161#161#161#161#160#157
+ +#190#156#190#156#156#157#156#157#156#157#156#152#157#152#157#156#157'x'#157
+ +'x'#157'xu'#157#156'yuy'#0#0#0#8#171#8#9#170#8#9#170#8#8#8#8#8#171#8#212#8
+ +#171#170#8#170#8#170#170#170#169#169#169#165#165#160#161#156#161#156#157#156
+ +#156#156#156#156#156#157#156#156#156#156#157#160#161#161#161#161#161#165#165
+ +#199#165#199#170#200#169#166#166#169#166#169#166#165#204#166#200#165#166#199
+ +#165#166#165#165#161#165#161#165#161#166#161#161#161#161#161#161#161#161#161
+ +#161#161#161#161#165#161#165#195#161#161#195#161#194#157#194#156#157#156#157
+ +#156#156#190#156#156#156#156#157#156#156#157#152#157#152#157#152'y'#152#157
+ +'xu'#157'xy'#0#0#0#8#8#8#170#8#171#8#8#8#171#8#171#8#8#8#170#8#8#8#8#8#8#170
+ +#8#170#170#170#169#169#165#165#160#160#156#156#156#156#156#156#156#156#156
+ +#156#156#161#160#161#161#161#161#161#165#165#199#166#199#170#166#170#166#165
+ +#170#166#203#166#204#166#165#204#165#166#169#165#200#165#166#165#199#162#165
+ +#161#162#165#161#161#161#165#161#161#165#161#161#161#161#161#161#161#161#161
+ +#161#161#161#161#195#160#161#156#195#156#157#156#190#156#190#157#156#156#157
+ +#156#157#156#152#157#152#156#156#153#156'u'#156#153'yt'#157'ty'#152#0#0#0#170
+ +#9#170#9#8#8#8#171#8#170#8#8#8#171#8#171#8#171#8#212#170#8#8#170#8#170#170
+ +#170#170#169#165#165#161#161#160#157#160#161#161#161#161#161#161#161#161#161
+ +#165#161#165#165#165#165#166#165#169#166#169#204#165#204#170#199#170#166#165
+ +#166#203#166#166#199#165#200#166#165#166#165#166#165#165#195#165#199#161#161
+ +#165#161#161#161#161#161#161#161#161#161#161#161#161#161#161#161#161#195#161
+ +#161#195#160#195#156#156#190#156#156#157#156#156#157#156#156#156#156#157#156
+ +#156#157#152#157#152#156#152#153'x'#152#157't'#157'tu'#0#0#0#9#170#8#8#171#8
+ +#170#8#9#8#171#8#170#8#8#8#8#8#170#8#171#8#171#8#8#8#170#170#170#170#169#166
+ ,#165#165#165#161#161#161#161#161#165#161#165#165#165#165#165#203#165#204#170
+ +#204#170#200#170#200#170#166#170#166#166#166#166#169#200#166#166#165#166#166
+ +#166#165#165#200#165#200#165#162#165#162#161#161#165#161#161#161#165#161#161
+ +#161#161#161#161#161#161#161#161#161#161#161#161#161#161#194#161#157#160#191
+ +#156#156#191#156#190#156#156#190#156#157#156#152#156#157#152#156#156#152#157
+ +#152#157#152#153't'#152#153't'#153't'#0#0#0#170#8#8#170#8#134#9#8#170#8#8#8#9
+ +#8#171#8#171#8#171#8#8#8#170#8#171#170#8#8#170#170#170#169#165#165#165#165
+ +#165#165#165#165#166#165#170#166#204#170#170#170#170#170#170#170#170#170#170
+ +#170#170#170#166#169#200#170#199#166#165#166#199#166#199#165#165#200#166#165
+ +#165#166#165#165#161#165#165#165#161#161#165#161#161#161#161#161#161#161#161
+ +#161#161#161#161#161#161#161#161#161#195#161#156#194#156#156#190#156#156#156
+ +#156#157#156#156#156#156#190#157#156#156#156#157#152#156#152#156#152#156#152
+ +#156#153't'#152'tt'#0#0#0#8#9#170#9#8#171#170#170#8#171#170#9#170#8#8#8#8#170
+ +#8#8#171#8#171#8#8#8#8#170#8#170#170#170#170#170#170#170#170#170#170#170#170
+ +#170#170#170#170#170#204#170#170#170#170#170#170#204#170#166#204#165#204#166
+ +#170#165#166#166#166#165#166#165#166#166#166#166#165#165#166#165#161#161#166
+ +#165#161#162#161#165#161#161#161#161#161#161#161#161#161#161#161#161#161#161
+ +#161#161#194#161#161#160#195#156#157#190#156#156#156#190#152#190#156#157#156
+ +#157#156#156#152#156#157#152#156#157#156#152#157#152#153#152't'#152#153't'
+ +#153#0#0#0#170#8#170#8#170#8#8#9#8#8#8#8#171#170#9#170#9#8#171#8#8#8#8#8#171
+ +#8#171#8#170#171#8#170#170#170#170#8#170#204#170#170#170#170#170#174#170#170
+ +#170#170#170#170#204#170#170#170#170#170#166#170#166#166#165#200#165#166#199
+ +#166#165#166#165#165#165#161#165#166#161#161#166#165#161#161#161#165#161#162
+ +#161#161#161#161#161#161#161#161#161#161#161#161#161#161#161#161#161#161#160
+ +#191#156#190#156#156#156#190#156#156#156#156#156#152#190#152#156#156#157#152
+ +#156#156#156#152#157#152#156#152#156#153#156#152't'#152't'#0#0#0#8#170#9#170
+ +#9#170#170#8#170#9#170#8#8#8#170#8#8#170#8#171#8#8#171#8#8#170#8#8#8#170#8
+ +#170#8#170#170#170#8#8#8#170#8#170#174#170#175#170#8#170#213#170#170#170#170
+ +#170#166#170#166#170#165#170#166#166#166#165#166#165#166#165#166#166#165#166
+ +#161#165#166#161#161#162#165#162#161#161#165#161#165#161#161#161#161#161#161
+ +#161#161#161#161#161#161#161#161#161#161#194#157#160#157#156#190#156#156#156
+ +#186#156#190#156#190#156#156#156#156#152#190#156#152#156#153#156#152#156#153
+ +#156#152#152#152#153#152#152#152#0#0#0#170#9#170#170#8#8#9#170#9#170#8#171
+ +#170#9#8#171#8#171#8#8#170#9#170#8#171#8#171#8#171#8#8#171#170#212#8#171#170
+ +#8#170#8#170#175#8#171#170#8#204#8#170#170#170#170#204#170#170#204#170#166
+ +#204#166#165#166#165#166#165#166#165#166#165#161#166#161#165#162#161#165#165
+ +#161#161#161#165#161#161#161#161#161#161#161#161#161#161#161#161#161#161#161
+ +#161#161#161#195#160#157#194#156#190#156#156#156#186#156#156#156#152#156#152
+ +#156#186#156#156#152#156#152#157#152#156#156#152#156#152#152#156#152#157#152
+ +#152#153't'#0#0#0#8#8#170#9#170#8#170#8#170#8#9#170#8#8#170#8#170#8#8#170#9
+ +#170#171#8#8#8#8#170#8#8#8#8#8#170#8#170#8#171#8#171#8#8#170#170#8#204#8#170
+ +#170#170#170#170#170#170#166#170#166#170#166#165#166#165#166#165#166#165#162
+ +#165#161#166#165#162#165#161#165#161#162#161#165#161#161#162#161#161#161#161
+ +#161#161#161#161#161#161#161#161#161#161#161#161#161#160#157#194#157#156#156
+ +#190#156#190#156#156#152#190#156#186#156#156#156#152#186#156#156#152#156#152
+ +#156#152#153#156#153#156#153#152#152#152#152#152#152#0#0#0#170#170#8#8#170#9
+ +#170#170#9#170#8#170#9#170#9#8#9#170#171#8#8#8#8#8#170#171#8#212#170#171#170
+ +#171#8#8#8#171#8#8#170#8#170#170#171#8#170#171#170#170#170#170#170#170#170
+ +#170#170#170#166#169#170#166#166#165#166#165#166#165#165#162#165#161#161#161
+ +#162#161#161#161#161#161#162#161#161#161#161#161#161#161#161#161#161#161#161
+ +#161#161#161#161#161#161#194#161#190#161#156#156#190#156#156#152#156#152#190
+ +#156#152#156#156#152#190#152#156#156#152#152#156#152#156#152#152#156#152#152
+ +#152#156#152#152#152#153#152#152#0#0#0#8#134#170#8#170#170#9#8#170#8#8#134
+ +#170#8#170#170#8#8#8#170#212#170#8#171#8#8#170#8#8#8#8#8#170#171#170#8#170
+ +#171#8#8#171#8#170#8#170#8#170#170#170#170#170#204#170#170#200#170#166#200
+ +#165#166#200#165#166#165#161#166#165#161#165#162#165#161#165#161#162#161#161
+ +#161#161#161#161#161#161#161#161#161#161#161#161#161#161#161#161#161#161#161
+ +#161#161#161#160#191#156#190#156#190#156#190#156#156#152#190#156#152#190#152
+ +#156#186#152#156#156#152#152#156#186#156#152#152#156#152#152#152#152#157#152
+ +#152#152#152#0#0#0#134#170#8#134#8#8#170#170#9#170#170#8#171#8#8#9#170#8#170
+ +#9#170#8#8#170#8#170#212#8#170#8#171#170#212#8#8#171#8#170#8#170#8#170#212
+ +#170#8#170#170#170#170#170#170#170#170#166#169#170#169#170#166#169#165#166
+ +#165#166#165#165#162#165#162#165#161#162#161#161#161#161#161#161#161#161#161
+ +#161#161#161#161#161#161#161#161#161#161#161#161#161#161#195#161#194#157#194
+ ,#156#156#156#156#156#152#156#152#190#156#156#152#156#152#156#152#156#156#152
+ +#186#156#152#152#152#152#156#152#152#152#156#152#152#152#152#152#152#152#0#0
+ +#0#170#8#166#8#170#170#134#8#8#170#9#170#134#170#8#170#170#9#170#8#170#9#170
+ +#8#171#8#134#170#212#8#170#8#8#170#170#8#170#8#170#171#170#8#170#170#170#170
+ +#170#170#170#170#170#170#166#170#170#166#166#166#165#166#166#165#166#165#166
+ +#161#165#161#161#161#161#161#161#161#161#161#161#161#161#161#161#161#161'}'
+ +#161#161#161#161#161#161#161#161#161#161#161#161#160#157#160#157#190#156#190
+ +#156#186#156#190#156#152#156#152#190#152#156#186#156#152#186#152#156#152#190
+ +#152#156#152#152#152#152#152#152#152#152#152#152#152#152#152#0#0#0#134#170#8
+ +#170#134#8#170#170#134#170#8#170#8#8#166#9#8#170#9#170#8#170#9#170#8#170#171
+ +#8#170#170#9#170#170#171#8#170#171#170#8#170#8#170#170#8#170#170#170#170#170
+ +#170#170#170#170#166#170#203#166#169#200#165#165#166#165#165#161#166#161#165
+ +#161#162#165#161#161#161#161'}'#161#161#161'}'#161#161#161#161#161#161#161
+ +#161#161#161#161#161#161#161#161#194#157#194#156#190#156#156#152#156#156#156
+ +#152#190#156#186#156#152#190#152#156#152#156#152#156#152#152#152#152#152#152
+ +#152#152#156#152#152#152#152#152#152#152#152#152#0#0#0#170#134#170#134#170
+ +#134#8#170#8#170#134#8#166#8#8#170#8#170#170#9#170#8#170#8#170#8#170#8#9#170
+ +#170#9#170#8#8#170#8#8#170#8#170#8#170#170#170#170#170#170#170#170#170#170
+ +#170#169#166#170#170#166#165#170#166#199#166#165#165#165#161#162#165#161#161
+ +#161#161#161#161#161#161#161#161#161#161#161#161#161'}'#161#161#161#161#161
+ +#161#161#161#161#161#157#160#157#190#156#190#156#190#152#190#156#156#152#156
+ +#152#156#152#156#152#152#190#152#152#186#156#152#156#152#186#156#152#152#152
+ +#152#152#152#152#152#152#152#152#152#0#0#0#170#170#134#170#170#170#170#134
+ +#170#8#170#170#8#170#170#8#170#8#134#170#8#130#8#170#9#166#8#170#170#8#8#170
+ +#8#170#170#8#170#170#8#170#8#170#170#170#170#170#170#170#170#170#166#170#170
+ +#166#170#165#166#169#166#165#165#166#165#165#166#161#166#165#161#165#161#161
+ +#161#161#161#161#161#161#161#161#161'}'#161#161#161#157#161'}'#161#157#161
+ +#161#161#160#157#194#157#190#156#156#156#156#156#156#152#156#186#156#186#156
+ +#186#156#152#190#156#152#152#156#152#152#186#152#152#152#152#152#190#152#152
+ +#152#156#152#152#152#152#152#152#0#0#0#170#134#170#170#134#170#134#170#170
+ +#134#170#8#134#170#8#134#170#8#170#8#170#8#170#8#170#8#8#170#8#8#170#170#8
+ +#170#8#170#170#8#170#170#170#170#170#170#170#170#170#170#170#170#170#169#166
+ +#170#165#166#169#166#165#199#166#165#165#166#165#165#161#161#161#161#161#161
+ +#161#161#161#161#161#161#157'}'#161#161#157#161#161'}'#161#157#161#161#161
+ +#160#161#191#160#157#156#156#190#152#190#152#190#152#156#186#156#152#156#152
+ +#156#152#156#152#152#186#156#152#156#152#152#156#152#156#152#156#152#152#156
+ +#152#152#152#152#152#152#152#152#0#0#0#170#170#134#170#170#134#170#170#134
+ +#170#134#170#170#134#170#170#134#170#8#170#8#170#8#170#8#170#170#8#170#170#8
+ +#8#170#8#170#8#170#170#170#170#170#170#170#170#170#170#170#170#166#170#170
+ +#166#169#170#166#170#199#170#165#166#165#166#165#165#161#165#165#161#165#161
+ +#161#161#161#161#161#161#161'}'#161#157#161#161'}'#157#161#157#161#161#161
+ +#161#157#161#156#161#190#156#190#156#156#156#156#156#152#190#156#156#152#156
+ +#152#156#152#156#186#156#152#156#152#152#186#156#152#152#152#152#186#152#152
+ +#152#152#152#152#152#156#186#152#152#152#0#0#0#134#170#170#134#170#170#134
+ +#170#170#170#170#134#170#170#134#170#170#134#170#134#170#170#134#170#134#8
+ +#170#170#8#170#170#170#134#170#170#170#170#170#134#170#170#170#170#170#170
+ +#170#170#170#170#169#166#170#166#169#170#165#166#165#166#165#165#165#166#165
+ +#165#162#165#165#161#161#165#161#161#161#161#161#161#161#161#161#161#157#161
+ +#161'y'#161#157#161#161#161#161#194#161#190#157#156#156#190#152#190#156#152
+ +#156#152#190#152#156#186#156#186#152#156#152#152#186#156#152#156#152#152#190
+ +#152#156#152#156#152#152#156#186#156#152#186#152#152#152#152#152#0#0#0#170
+ +#170#134#170#170#134#170#170#134#170#134#170#170#134#170#170#134#170#170#170
+ +#170#134#170#170#170#170#170#134#170#134#170#134#170#170#134#170#170#170#170
+ +#170#170#170#170#170#170#170#169#166#169#166#170#165#170#166#165#170#165#170
+ +#199#166#165#166#165#165#165#165#161#161#165#161#161#161#161#161#161#161#161
+ +#161#161'}'#157#161#157'}'#161#161#161#161#157#161#194#157#156#156#156#190
+ +#156#152#156#156#152#190#152#156#152#152#156#152#152#156#156#186#152#156#152
+ +#152#186#152#156#152#152#152#152#186#152#152#190#152#152#152#152#156#152#152
+ +#156#152#152#0#0#0#170#130#170#134#170#134#170#134#170#134#170#170#134#170
+ +#170#134#170#170#134#170#134#170#170#170#134#170#134#170#170#170#170#170#170
+ +#170#170#170#134#170#170#170#170#170#170#170#170#170#166#170#170#170#165#170
+ +#165#166#169#166#165#165#166#165#166#165#165#162#165#161#161#165#161#161#165
+ +#161#161#161#161#161#161#161#157#161#161'}'#161#157#161#161#157#161#161#160
+ +#157#160#191#156#190#156#156#156#186#156#186#156#152#190#152#156#186#152#156
+ ,#186#152#152#156#152#156#152#152#156#152#186#152#156#152#152#156#152#152#152
+ +#152#156#152#152#152#156#186#152#156#0#0#0#170#169#170#170#166#170#170#170
+ +#170#134#170#134#170#134#170#170#170#134#170#170#170#134#170#134#170#170#170
+ +#134#170#134#170#170#134#170#170#170#170#170#170#170#170#170#170#169#166#170
+ +#170#170#165#166#170#166#169#165#166#165#166#165#165#165#165#165#165#165#165
+ +#165#165#161#165#161#161#161#161#161#161#161#161#161#161#157#161#157#161#161
+ +#157#161#161#160#157#161#190#156#156#156#156#156#186#156#156#152#156#152#156
+ +#152#152#156#156#152#152#152#156#156#152#152#186#156#152#152#152#156#152#186
+ +#156#152#186#156#152#156#152#186#156#152#186#152#152#152#152#0#0#0#130#170
+ +#130#170#134#170#247#170#170#170#170#170#166#170#134#170#134#170#134#170#134
+ +#170#170#170#134#170#170#170#170#170#134#170#170#166#134#170#170#170#166#170
+ +#170#170#166#170#170#166#169#166#170#165#169#166#166#169#165#166#165#166#165
+ +#166#165#166#161#165#161#165#161#165#161#165#161#161#161#161#161#161#161#161
+ +#161#161#161#161#157#161#161#160#157#195#160#160#157#190#156#190#152#156#156
+ +#152#190#152#156#190#152#156#186#152#152#190#156#152#152#152#190#152#156#152
+ +#156#186#152#152#152#156#152#152#156#152#186#152#156#152#152#156#152#152#156
+ +#152#152#0#0#0#169#166#170#169#166#169#170#170#247#170#130#170#134#170#170
+ +#170#170#170#170#170#170#170#134#170#170#170#134#170#134#170#170#170#170#134
+ +#170#170#170#134#170#170#170#166#170#170#166#169#166#170#169#166#166#169#165
+ +#166#165#165#165#165#165#165#165#165#165#165#165#161#165#161#161#161#161#165
+ +#161#161#161#161#161#161#161#161#161#157#161#161#157#161#161#160#157#190#156
+ +#156#156#156#156#190#152#156#152#156#152#152#156#152#156#152#156#152#152#186
+ +#156#186#152#152#152#186#152#152#156#186#156#152#186#156#152#152#156#152#186
+ +#152#156#152#152#156#186#152#152#0#0#0#166#134#169#130#170#247#170#130#170
+ +#170#170#170#170#134#170#134#170#134#170#247#170#134#170#170#170#247#170#170
+ +#166#170#170#130#170#170#170#170#170#170#165#170#165#170#169#166#169#170#165
+ +#165#166#166#169#165#166#165#166#165#166#165#165#165#165#165#161#165#161#165
+ +#161#165#161#165#161#161#161#161#161#161#161#161#161#157#161#161#160#161#160
+ +#161#194#157#194#157#156#190#156#186#156#152#156#152#190#152#156#152#190#152
+ +#152#190#152#152#152#156#152#156#152#156#152#156#152#156#152#152#152#156#152
+ +#156#186#156#152#156#156#156#186#152#190#152#152#156#152#0#0#0#170#165#166
+ +#170#165#170#170#169#170#130#169#130#170#166#170#170#166#170#170#170#170#170
+ +#170#134#170#170#170#134#170#134#170#170#170#170#166#134#166#170#170#170#170
+ +#166#166#170#166#166#170#166#169#165#166#166#165#165#165#165#165#165#166#165
+ +#161#165#165#161#165#161#161#161#161#161#161#161#161#161#161#161#161#161#161
+ +#161#157#161#161#161#161#160#157#160#156#190#156#152#156#156#152#156#186#152
+ +#156#152#186#156#152#152#156#152#152#190#152#152#152#152#152#186#152#152#152
+ +#186#156#152#156#186#156#152#156#186#156#186#152#152#156#156#152#156#152#152
+ +#156#0#0#0#165#134#165#134#166#129#166#134#165#170#170#170#133#170#129#170
+ +#134#170#134#170#134#170#166#170#170#134#166#170#170#170#165#134#166#169#170
+ +#166#169#166#170#165#170#169#166#169#170#165#165#170#166#169#165#165#166#165
+ +#166#165#166#165#165#165#165#161#165#161#165#165#161#165#161#165#161#161#161
+ +#161#161#161#161#161#161#161#161#161#161#156#195#161#160#191#156#156#190#156
+ +#152#190#152#156#156#156#152#156#152#152#156#186#156#152#152#152#156#152#190
+ +#152#156#152#156#152#156#152#152#190#152#156#186#152#156#152#156#156#190#152
+ +#186#152#156#152#156#186#152#0#0#0#166#165#166#165#170#170#169#166#170#130
+ +#169#247#170#166#170#170#165#170#166#169#166#170#134#169#130#170#170#134#165
+ +#134#170#170#170#134#166#169#170#170#165#134#166#166#169#166#165#166#170#165
+ +#165#166#165#166#165#165#165#165#165#165#161#165#165#165#161#165#161#161#165
+ +#161#161#161#161#161#161#161#161#161#161#161#161#161#161#161#161#161#161#160
+ +#190#156#156#156#152#156#156#152#156#152#186#152#156#186#152#156#152#152#152
+ +#152#156#152#152#186#152#152#186#152#152#186#152#156#152#156#152#152#156#156
+ +#186#156#186#152#152#156#156#156#186#156#186#156#152#0#0#0#165#134#165#170
+ +#129#165#130#165#134#169#166#170#166#133#170#129#170#130#170#134#170#133#166
+ +#170#170#170#169#166#170#166#170#165#170#166#169#170#130#165#170#166#169#169
+ +#166#170#165#170#165#165#166#165#165#165#166#165#165#166#165#165#165#165#161
+ +#161#165#161#161#165#161#161#161#161#161#161#161#161#161#161#161#161#161#161
+ +#161#160#161#161#160#190#157#156#156#186#156#156#186#156#156#152#156#152#156
+ +#152#156#152#190#152#152#190#152#152#152#156#152#156#152#156#152#156#156#152
+ +#156#186#152#190#156#186#152#156#152#156#156#190#152#186#156#152#152#156#152
+ +#0#0#0#165#165#166#165#166#170#165#170#165#166#169#130#169#170#166#170#170
+ +#169#170#169#166#170#170#166#133#166#134#170#169#170#165#134#165#170#166#165
+ +#170#170#165#170#166#166#165#165#166#165#165#166#165#166#165#165#165#165#165
+ +#165#165#161#165#161#165#165#161#165#161#161#161#161#161#161#161#160#161#161
+ ,#161#161#161#161#160#161#161#161#161#190#161#156#156#190#156#156#152#156#152
+ +#152#186#156#152#156#152#156#152#152#152#156#152#152#152#186#152#152#152#152
+ +#152#186#156#152#152#190#152#156#156#152#152#156#156#186#156#190#152#152#156
+ +#156#152#190#156#152#152#0#0#0#165#166#129#169#129#165#170#129#170#129#166
+ +#169#166#129#170#165#247#170#165#130#169#130#169#170#166#169#166#170#247#170
+ +#170#170#166#133#170#166#165#170#165#165#169#166#170#165#169#166#165#165#165
+ +#165#166#165#166#165#165#165#165#165#165#165#161#165#165#161#165#161#165#161
+ +#161#161#161#161#161#161#161#161#161#161#161#161#161#161#160#161#160#191#156
+ +#156#156#152#156#152#156#156#152#156#152#152#152#186#156#152#152#152#156#152
+ +#152#156#152#152#190#152#156#152#152#190#152#152#156#186#156#190#156#186#156
+ +#156#152#156#190#156#186#156#156#152#190#156#156#0#0#0#165#165#165#166#165
+ +#166#165#165#166#169#165#134#165#170#165#134#169#166#134#170#166#169#170#130
+ +#169#170#134#165#170#165#130#165#170#165#166#133#166#165#166#170#130#165#165
+ +#166#165#165#166#165#166#165#165#165#165#165#165#161#165#161#165#161#165#161
+ +#161#161#161#161#161#161#161#161#161#161#161#161#160#161#161#157#161#161#161
+ +#160#161#160#191#156#156#156#186#156#152#190#152#152#156#152#186#156#152#156
+ +#152#152#190#152#152#186#152#152#152#152#152#152#152#152#156#152#156#156#186
+ +#156#152#156#152#156#152#190#156#186#156#152#156#156#186#156#152#152#152#0#0
+ +#0#165#130#165#165#129#169#129#166#169#130#166#166#169#130#169#166#165#166
+ +#169#166#169#134#166#169#166#170#165#170#169#166#169#170#165#166#169#166#169
+ +#165#170#165#165#169#166#165#166#165#165#165#165#165#165#165#165#165#165#165
+ +#165#165#161#165#161#165#161#165#161#161#161#161#161#161#161#161#161#161#161
+ +#161#161#161#161#160#161#161#194#157#156#156#156#152#156#152#156#152#152#156
+ +#152#152#156#152#190#152#152#156#152#156#152#152#156#186#152#156#152#156#186
+ +#156#152#190#152#186#156#152#156#190#156#156#190#152#156#156#156#190#152#190
+ +#156#152#156#156#152#0#0#0#165#165#165#165#165#166#165#165#165#165#169#129
+ +#165#170#165#170#133#170#129#169#166#166#169#166#133#166#133#166#165#134#165
+ +#166#169#134#165#166#165#166#165#165#166#165#165#165#165#165#166#165#165#166
+ +#161#165#165#161#165#161#165#161#165#161#165#161#161#161#165#161#161#161#161
+ +#160#161#161#160#161#161#157#160#161#161#161#160#161#157#160#156#156#190#156
+ +#152#156#152#152#156#186#156#156#152#156#152#156#156#186#156#152#156#152#152
+ +#156#152#152#186#152#156#152#156#152#156#156#156#190#152#156#186#156#152#156
+ +#186#156#186#156#156#152#190#156#152#152#156#0#0#0#165#165#129#166#165#165
+ +#165#170#129#166#165#170#165#130#165#166#165#170#166#133#169#165#134#165#170
+ +#169#166#169#170#165#170#165#165#166#169#165#130#169#166#169#165#166#165#165
+ +#166#165#165#165#165#165#165#165#165#165#165#165#161#165#161#165#161#165#161
+ +#161#161#161#161#161#161#161#161#161#161#161#160#161#161#160#161#157#161#156
+ +#161#190#157#156#152#156#152#152#156#152#152#152#152#156#186#152#156#186#156
+ +#152#156#152#190#156#152#152#156#152#152#156#152#190#152#156#186#156#152#156
+ +#190#152#156#190#156#156#156#156#156#156#186#156#152#156#156#152#152#0#0#0
+ +#165#165#165#165#129#170#129#165#165#169#165#165#129#169#165#133#166#165#169
+ +#166#166#170#165#170#165#166#169#130#165#166#169#130#170#165#166#165#169#165
+ +#165#165#166#165#165#166#165#165#166#165#161#165#165#165#161#165#161#165#165
+ +#161#165#161#161#161#161#165#161#161#160#161#161#161#161#161#161#161#161#161
+ +#161#157#161#160#161#160#161#156#156#152#156#152#156#152#152#156#152#156#156
+ +#152#156#156#156#156#156#190#156#186#156#152#190#156#186#152#156#152#190#152
+ +#156#186#156#152#190#156#152#156#190#152#156#186#156#186#156#186#156#156#190
+ +#156#152#156#156#0#0#0#165#166#129#165#165#165#165#165#165#166#129#170#165
+ +#166#169#166#165#133#166#165#133#165#169#130#169#134#165#169#166#169#166#165
+ +#169#165#169#166#165#166#165#130#165#165#165#165#165#165#165#165#165#165#165
+ +#165#165#165#165#161#161#165#161#165#161#165#161#161#161#161#161#161#161#161
+ +#160#161#161#160#161#156#161#161#160#161#161#156#157#156#156#156#156#152#152
+ +#156#152#156#186#156#152#190#156#156#190#156#190#156#156#156#156#190#156#152
+ +#156#156#152#156#152#156#152#156#156#190#152#156#156#186#156#156#190#156#152
+ +#156#156#156#190#152#156#152#190#156#152#0#0#0#165#165#165#165#166#165#169
+ +#166#133#165#165#165#169#165#165#129#170#165#170#165#170#165#166#169#166#165
+ +#170#165#170#129#169#165#166#129#166#165#165#165#165#165#165#165#166#165#165
+ +#165#165#165#165#165#161#165#161#165#161#165#165#161#161#161#161#161#161#161
+ +#161#161#161#161#160#161#161#160#161#157#161#161#156#161#161#157#160#161#156
+ +#156#156#152#152#152#156#152#156#152#156#156#156#156#190#156#156#156#156#156
+ +#156#190#156#156#156#190#156#186#156#186#156#186#156#186#156#152#156#186#156
+ +#156#186#156#152#156#190#156#186#156#152#190#156#156#152#156#156#0#0#0#129
+ +#165#165#165#129#165#129#165#165#169#166#165#130#169#166#169#165#133#165#169
+ +#129#170#129#165#169#166#169#130#169#166#169#166#169#165#169#166#133#166#165
+ ,#165#166#165#165#165#166#165#165#165#129#165#165#165#165#165#165#161#165#161
+ +#165#161#161#165#161#161#161#160#161#161#161#161#161#161#161#160#161#161#161
+ +#157#160#161#157#160#157#156#156#156#152#156#152#156#152#156#156#190#156#156
+ +#156#190#156#190#156#190#190#156#190#156#156#156#152#156#156#152#156#152#156
+ +#156#186#156#156#156#186#156#156#190#156#186#156#152#156#190#156#156#186#156
+ +#156#186#156#0#0#0#165#165#130#165#165#165#166#165#166#129#165#169#165#165
+ +#133#165#166#169#166#165#170#165#170#165#134#165#170#165#169#165#166#133#165
+ +#166#165#165#165#165#169#165#165#129#165#165#165#165#165#165#165#165#165#165
+ +#161#165#161#165#161#165#161#165#161#161#161#160#161#161#161#161#161#160#161
+ +#160#161#161#161#156#161#160#157#161#156#161#156#157#156#152#156#152#156#186
+ +#156#190#156#156#156#190#156#156#160#156#190#156#156#156#156#190#156#190#156
+ +#190#152#156#186#156#190#152#156#152#190#152#156#152#190#152#156#156#156#190
+ +#156#152#156#186#156#156#186#156#156#0#0#0#165#165#165#165#170#165#169#129
+ +#169#165#170#129#165#170#165#166#133#165#169#247#169#165#169#166#169#165#169
+ +#166#133#166#169#165#166#169#129#169#166#165#166#165#165#166#165#165#165#165
+ +#165#165#165#161#165#161#165#165#165#161#165#161#161#161#161#160#161#161#161
+ +#161#161#160#161#161#161#161#157#160#157#161#161#157#161#160#161#157#156#156
+ +#156#152#156#152#156#156#156#156#156#156#190#160#156#190#156#190#160#156#190
+ +#156#190#156#190#156#156#156#190#156#156#156#152#156#156#190#156#156#156#190
+ +#156#156#190#152#190#156#152#156#186#156#156#186#156#156#186#0#0#0#165#130
+ +#165#165#165#129#166#165#166#165#165#170#169#129#169#165#170#165#166#169#166
+ +#133#166#133#166#169#166#169#166#169#165#170#165#165#166#165#169#165#129#165
+ +#165#165#165#165#165#165#165#165#165#165#165#165#165#161#161#165#165#161#165
+ +#161#165#161#161#161#161#160#161#161#161#160#157#160#161#161#160#161#156#161
+ +#160#157#156#160#157#156#156#156#156#156#156#156#156#156#190#156#156#156#194
+ +#156#194#156#190#156#156#194#156#156#156#156#190#156#156#186#156#186#156#186
+ +#156#152#156#186#156#152#156#186#156#156#152#156#190#156#156#190#152#156#186
+ +#156#156#0#0#0#165#165#165#130#165#165#165#169#165#134#165#165#166#169#166
+ +#133#165#133#169#165#169#166#169#165#169#166#133#165#169#166#133#165#134#165
+ +#169#165#166#169#165#170#165#169#166#165#165#165#165#165#165#165#161#165#165
+ +#165#165#161#161#165#161#161#161#161#161#161#161#161#161#160#161#161#161#161
+ +#156#161#157#160#161'y'#161#161#161#157#160#161#156#156#156#156#156#156#190
+ +#156#156#190#160#190#160#190#156#160#190#160#190#156#190#194#190#156#156#190
+ +#156#156#190#156#156#156#190#156#152#156#190#156#156#156#190#152#190#152#156
+ +#186#156#156#190#156#156#186#156#0#0#0#165#165#165#165#169#166#133#166#165
+ +#165#169#130#169#165#170#165#170#165#166#134#165#169#134#166#169#129#170#166
+ +#169#165#170#165#169#166#165#134#165#165#166#165#165#165#165#165#165#129#165
+ +#165#165#165#165#165#161#165#161#165#165#161#165#161#165#161#161#161#160#161
+ +#161#161#161#160#161#156#161'}'#156#161#156#161#156#161#156#161#160#161#164
+ +#161#160#156#156#190#156#156#190#160#190#160#190#160#194#194#156#190#160#190
+ +#160#156#156#190#190#156#156#190#156#152#190#152#156#152#190#156#152#156#186
+ +#156#152#156#156#156#190#156#156#186#156#186#156#156#156#0#0#0#165#130#165
+ +#166#129#165#165#165#133#169#166#169#165#134#165#169#169#130#169#169#169#170
+ +#165#169#169#166#169#169#169#130#169#165#170#165#169#165#165#170#165#165#165
+ +#166#165#165#166#165#165#165#165#165#165#161#165#165#165#165#161#161#161#161
+ +#161#160#161#161#161#161#161#160#161#157#161#161#161#156#161#157#161#156#161
+ +#156#161#161#161#199#165#199#164#194#160#156#160#190#160#160#190#160#194#156
+ +#194#156#194#160#190#160#190#156#190#156#156#156#190#152#156#190#156#156#156
+ +#190#156#152#156#190#156#152#156#190#156#186#156#156#186#156#156#156#156#156
+ +#186#0#0#0#165#165#165#169#165#166#169#166#165#166#129#169#166#169#165#134
+ +#166#169#170#165#134#165#170#165#134#169#166#133#166#169#166#169#165#134#165
+ +#170#165#165#169#130#169#165#165#165#165#165#165#165#165#165#165#165#165#161
+ +#165#161#165#165#161#165#161#161#161#161#161#160#161#161#160#161#160#157#160
+ +#157#161#156'|'#157#161#157#160#160#165#165#203#169#203#169#199#160#194#156
+ +#156#190#160#190#160#194#156#194#160#190#160#190#156#194#156#190#156#190#156
+ +#156#190#156#190#152#190#152#156#190#156#152#156#190#152#156#152#156#186#156
+ +#156#156#186#156#186#156#156#0#0#0#165#165#247#165#165#133#165#133#165#169
+ +#166#169#129#170#169#165#169#166#133#170#165#170#133#170#165#170#169#166#169
+ +#170#169#130#169#165#170#165#134#165#165#169#166#165#170#165#169#165#166#165
+ +#165#165#165#165#165#165#165#165#161#165#165#161#165#161#161#160#161#161#161
+ +#161#161#161#161'|'#161#160#161#157#161#156#156'}'#157#161#161#165#203#169
+ +#203#203#169#199#164#194#160#190#160#194#156#194#160#194#156#194#160#194#194
+ +#156#190#156#190#156#190#156#156#186#156#156#156#190#152#156#186#156#152#156
+ +#156#190#156#190#156#186#156#152#156#156#156#186#156#0#0#0#165#165#165#165
+ ,#170#165#166#165#170#129#169#165#170#165#130#169#134#165#170#165#170#169#166
+ +#169#134#169#166#169#130#169#166#169#170#165#169#165#169#166#169#166#165#169
+ +#129#165#166#165#165#165#165#165#165#165#165#165#165#161#165#161#165#161#161
+ +#161#165#161#161#160#161#160#161#160#157#161#157#161#156#160#157#161#157#156
+ +#157#160#161#165#165#203#169#169#203#169#203#165#198#160#194#156#194#156#194
+ +#156#194#160#190#160#190#156#194#156#190#156#156#190#152#156#156#186#156#156
+ +#156#190#156#156#190#156#186#156#152#156#152#156#156#190#156#186#156#156#156
+ +#0#0#0#165#129#170#165#129#165#169#133#165#170#165#134#165#170#169#170#165
+ +#170#169#134#169#130#169#170#166#169#134#169#170#169#170#165#166#133#166#169
+ +#166#169#129#165#169#165#166#165#165#165#165#165#165#165#165#165#165#165#161
+ +#165#165#165#161#161#165#161#161#161#161#161#161#161#161#161#161#160#161#156
+ +#161#157#161#156#156#161#156'}'#161#161#165#165#169#203#203#173#207#203#169
+ +#199#160#194#156#160#190#160#194#190#160#194#156#194#156#190#156#156#190#156
+ +#156#156#190#156#156#152#190#152#190#152#156#152#156#190#156#156#190#156#186
+ +#156#152#156#152#190#152#0#0#0#165#165#165#166#169#166#165#166#165#133#166
+ +#169#169#130#169#165#170#129#170#165#170#169#170#134#169#166#169#166#169#166
+ +#133#170#169#170#129#170#165#169#166#169#166#165#169#170#165#165#166#165#165
+ +#165#166#165#165#165#165#165#161#165#165#165#161#165#161#161#160#161#161#160
+ +#161#160#157#161#156#161'}'#156#160#157'}'#156#157#156#157#156'}'#161#165#165
+ +#169#203#169#173#207#169#199#165#160#190#160#190#160#160#190#194#160#156#190
+ +#156#190#156#156#190#156#186#156#186#156#190#156#156#156#190#156#190#152#156
+ +#186#156#152#156#156#190#156#190#156#156#190#0#0#0#166#165#165#133#165#169
+ +#130#169#166#169#165#130#169#169#166#133#170#169#133#170#165#170#165#169#170
+ +#133#170#169#134#169#166#169#166#169#170#165#134#165#169#166#169#166#165#165
+ +#170#165#169#165#166#165#165#165#165#165#165#165#165#161#165#161#165#161#165
+ +#161#161#161#161#161#161#161#160#161#161#156#157#161#157#156#157#156#161#156
+ +'}'#156#157#156#161#161#165#165#203#169#207#173#207#207#165#198#160#194#190
+ +#160#160#190#190#194#156#190#156#190#156#156#190#156#156#156#152#156#186#156
+ +#186#156#152#156#190#156#156#186#156#152#190#152#156#152#190#152#156#0#0#0
+ +#165#129#166#165#166#165#169#165#133#166#169#169#166#169#170#165#170#166#170
+ +#165#134#169#134#170#165#170#169#170#170#170#169#134#169#166#169#170#165#170
+ +#166#133#165#169#130#169#165#165#166#165#165#165#165#165#165#165#165#165#165
+ +#165#165#165#161#165#161#161#165#161#160#161#161#161#161#161#156#161#160#157
+ +#160#157#160#157'x'#157#156#157#156#157'x'#160#161#161#165#169#169#204#174
+ +#174#207#173#199#164#160#194#190#160#160#156#190#160#190#156#156#190#156#156
+ +#190#156#190#156#156#156#156#156#190#156#152#156#186#156#156#190#156#156#190
+ +#156#156#190#156#0#0#0#165#170#165#133#165#169#130#169#166#169#170#129#170
+ +#133#165#170#133#169#169#134#169#170#170#169#170#133#166#134#165#133#166#170
+ +#165#170#133#166#169#166#169#165#170#166#169#166#165#170#165#169#165#166#165
+ +#165#165#165#165#165#165#165#165#161#165#165#161#165#161#161#161#161#160#161
+ +#161#160#161#161#157#160#157'|'#157#156#157#156#157#160'y'#156#157#157'x'#157
+ +#161#161#165#169#174#208#174#207#173#207#199#198#160#160#190#190#160#190#156
+ +#156#190#156#156#190#152#156#152#156#152#190#152#190#152#156#156#190#156#156
+ +#186#156#152#190#152#156#186#156#152#0#0#0#165#165#165#166#169#166#169#165
+ +#134#169#165#170#165#170#134#169#166#170#166#169#170#166#169#130#169#170#170
+ +#169#170#170#170#169#134#169#166#169#170#133#170#166#169#169#166#165#169#165
+ +#129#166#165#169#165#166#165#165#165#165#165#165#165#165#161#165#161#165#161
+ +#165#161#161#161#160#161#161#160#157#160#157#160#157#156#161#156#157#156#157
+ +#156#157#156#156#157#156'x'#156#161#161#165#169#173#174#208#174#174#169#198
+ +#194#160#160#190#156#190#156#156#190#156#156#190#156#190#156#190#156#156#156
+ +#190#156#186#156#152#190#156#190#156#156#190#156#156#156#190#0#0#0#130#165
+ +#134#165#165#133#166#169#165#166#133#170#169#165#170#169#133#169#134#166#169
+ +#134#169#170#170#133#170#170#133#170#169#166#169#170#170#129#170#165#169#170
+ +#130#169#169#170#130#170#165#169#165#166#165#169#165#166#165#165#165#165#165
+ +#165#165#161#165#161#165#161#165#161#161#161#161#161#161#160#161#161#156#161
+ +#156#156#161#156'y'#156#157#156'y'#157#156#157#157#156#157'x'#161#161#169#174
+ +#174#246#175#211#174#203#198#194#160#190#160#190#156#156#190#156#156#156#152
+ +#156#152#190#152#190#152#156#156#190#156#156#152#156#190#152#156#186#156#152
+ +#156#0#0#0#165#169#165#165#170#165#169#130#169#169#166#169#130#170#169#166
+ +#170#170#169#170#134#169#170#134#169#166#169#170#170#166#169#134#170#129#170
+ +#169#170#170#170#165#169#166#170#165#169#165#170#165#166#169#165#166#165#165
+ +#165#165#166#165#165#165#165#165#165#165#165#161#161#165#161#161#160#161#161
+ +#161#160#157#161#157#161#157'x'#157#156#157#156'x'#156#156'y'#156'x'#157'x'
+ +#156#157'x'#161#165#170#8#246#175#8#208#169#202#198#160#190#156#190#156#156
+ ,#190#156#190#156#190#156#156#156#156#156#190#152#156#152#190#156#190#152#156
+ +#190#156#190#156#190#0#0#0#165#166#169#130#169#166#134#165#170#129#170#169
+ +#170#169#129#170#133#165#170#133#169#166#170#169#170#170#134#169#134#169#134
+ +#166#169#170#169#170#166#133#166#169#170#170#165#169#166#170#165#166#169#165
+ +#166#169#165#165#170#165#165#165#165#165#165#165#165#161#165#161#165#161#161
+ +#161#161#161#160#161#161#161#160#161#156#160#157#160#157#156#157#156#157#157
+ +#156#156#157#156#157#157'x'#157#156'y'#161#129#170#174#246#175#246#174#203
+ +#202#198#160#156#156#190#156#156#156#190#156#152#156#186#156#190#152#156#156
+ +#190#156#152#156#156#190#156#152#156#152#156#0#0#0#165#133#166#165#169#165
+ +#169#166#169#170#129#170#129#170#170#169#170#170#165#170#170#170#133#170#133
+ +#170#169#166#169#170#169#170#170#169#130#170#169#170#133#166#170#129#170#170
+ +#129#169#170#169#166#169#165#165#166#165#165#165#165#165#165#165#165#165#165
+ +#165#165#165#165#161#165#161#161#161#161#161#160#161#161#156#161#157#156#157
+ +#160'y'#156#157#156#156'x'#157'x'#157'x'#156#157#156'y'#156#157'x}'#166#8#8
+ +#175#209#174#170#203#198#198#194#156#156#190#156#156#156#190#156#156#152#156
+ +#190#156#190#152#190#156#186#156#152#190#156#190#156#190#0#0#0#165#166#169
+ +#166#133#166#169#133#166#169#170#169#170#169#129#170#169#134#170#169#134#169
+ +#170#166#170#169#134#170#170#134#166#169#134#170#169#134#170#165#170#169#169
+ +#170#165#170#170#165#166#133#166#165#170#165#169#166#165#166#169#165#166#165
+ +#165#165#165#165#165#161#165#161#165#161#165#161#161#161#161#161#160#161#160
+ +#161#161#156#157#160#157#156'y'#156#157#156#157#156#157'x'#156#156#157'x'#157
+ +#156#157'x'#161#170#8#8#209#8#174#204#164#198#194#156#156#190#156#156#156#190
+ +#156#190#156#152#156#156#156#156#156#156#190#156#156#186#156#156#156#0#0#0
+ +#170#129#165#133#166#169#166#169#169#130#169#166#169#130#170#170#165#170#169
+ +#134#169#170#133#170#133#170#170#169#170#169#170#134#169#166#170#169#166#169
+ +#170#130#170#166#169#170#165#170#169#166#169#170#165#170#166#165#169#165#165
+ +#166#165#165#166#165#165#165#165#165#165#165#161#165#161#161#165#161#161#160
+ +#161#161#161#157#156#161#156#157#156#157#156#157#156#156'y'#156#156#157#156
+ +'y'#156#156#157'x'#157#156'yx'#161#170#8#175#208#170#204#169#164#198#194#156
+ +#190#156#190#156#156#156#156#190#156#186#156#186#156#186#156#156#186#156#156
+ +#186#156#0#0#0#165#165#170#166#169#130#169#134#166#169#170#133#170#169#170
+ +#133#170#134#169#166#170#170#170#169#170#170#169#134#169#134#170#169#170#170
+ +#133#170#170#134#170#169#170#169#134#165#170#169#166#169#170#165#166#169#165
+ +#169#166#169#166#165#165#165#165#165#165#165#165#165#165#161#165#165#161#165
+ +#161#161#161#161#161#161#161#160#161#160#157#160#157#160#157#156'x'#157#156
+ +#156#157'x'#157#156#156#157'x'#156#157'x'#157#156#157'x}'#170#8#175#170#204
+ +#204#199#164#194#160#190#156#156#190#156#190#156#190#156#156#156#190#156#156
+ +#190#156#156#190#156#190#0#0#0#165#170#165#133#165#169#170#165#169#134#165
+ +#170#165#134#169#170#169#170#134#170#133#166#133#170#169#134#170#170#166#169
+ +#170#134#165#170#169#166#169#170#165#170#129#170#166#169#130#170#169#166#165
+ +#170#169#166#169#166#165#165#169#166#165#170#165#165#165#166#165#165#165#165
+ +#165#161#165#161#161#165#161#161#161#160#161#161#161#157#161#156#157#157#160
+ +#157#157#156#157'x'#157#156'x'#156'y'#156#156'y'#152#156'y'#156'x'#157#156
+ +#157'}'#170#174#8#170#170#203#164#198#160#194#156#190#156#156#156#156#156#190
+ +#156#156#190#156#156#156#190#156#156#156#0#0#0#169#129#170#165#170#129#170
+ +#170#165#170#169#134#169#170#166#133#170#169#170#169#170#170#170#134#170#165
+ +#170#134#169#170#170#169#170#134#170#170#134#169#170#169#170#169#170#169#170
+ +#165#170#133#170#165#166#169#166#169#170#166#165#169#165#165#166#165#165#165
+ +#165#165#165#165#165#165#165#165#165#161#165#161#161#161#161#160#161#160#161
+ +#161#160#157#156#156#161#156#157#156#156#157#156#157#156'y'#156#156'y'#156
+ +#156'y'#157'xy'#156#156'y'#161#170#174#170#170#204#165#198#198#160#160#194
+ +#190#156#190#156#156#190#156#156#190#156#190#156#190#156#190#0#0#0#166#169
+ +#165#134#165#170#165#133#170#133#166#169#170#133#169#170#170#130#169#170#134
+ +#169#170#169#170#134#170#169#170#134#169#170#133#170#169#134#165#170#134#166
+ +#169#130#170#166#169#170#165#170#166#169#170#129#170#165#165#165#170#165#166
+ +#169#165#165#166#165#165#166#165#165#165#165#161#165#161#165#161#161#165#161
+ +#161#161#161#161#161#160#157#160#161#161#156#157#156#157#157'x'#157#156#156
+ +#156#157'y'#156'y'#156#152#156#156#157#156'y'#156#157'y'#161#170#170#170#204
+ +#170#165#198#198#160#160#194#156#190#160#156#190#156#156#156#190#156#156#190
+ +#156#0#0#0#169#129#166#169#170#129#169#166#169#166#169#134#165#170#170#134
+ +#169#169#170#134#169#170#133#170#134#170#169#134#170#169#170#134#170#170#166
+ +#169#170#170#169#169#170#170#169#170#169#166#169#170#165#170#165#170#165#170
+ +#165#170#165#170#165#165#166#165#165#165#165#165#165#165#165#165#165#165#165
+ +#165#161#165#161#161#165#161#161#160#161#161#161#161#157#156#157#157#160#157
+ ,#160#156#157'x'#157'y'#156#156#156#156#153'x'#157'u'#156'y'#156#157'x'#156'x'
+ +#157#161#170#170#170#204#203#164#198#198#194#160#194#156#190#156#190#190#190
+ +#156#156#190#156#156#0#0#0#165#170#133#165#165#170#169#134#169#133#170#169
+ +#170#133#166#169#170#134#170#169#166#170#170#170#165#170#170#169#130#170#169
+ +#166#169#170#133#170#169#166#134#170#166#133#166#169#247#170#166#133#170#165
+ +#170#165#170#165#170#165#165#165#170#165#169#166#169#166#165#165#165#166#165
+ +#165#165#165#161#165#165#161#165#161#161#161#161#161#161#160#161#160#161#161
+ +#160#161#156#156#157#157#156#157#156#156'x'#157'x'#157'x'#156'x'#156'x'#152
+ +#157't'#156#157#157'x'#156'y'#161#170#170#170#204#169#198#164#198#194#160#194
+ +#194#160#156#156#190#156#190#160#190#0#0#0#165#165#170#169#134#165#170#165
+ +#170#165#170#130#169#170#169#134#165#170#133#170#133#170#133#170#134#169#134
+ +#170#169#134#170#133#170#170#170#170#134#169#170#169#170#170#169#170#169#169
+ +#170#165#170#170#165#170#165#170#165#170#170#165#165#166#165#165#165#165#165
+ +#166#165#165#165#165#165#165#165#165#161#165#161#165#161#161#165#161#161#161
+ +#161#161#161#160#157#161#161#157#160#157#156#157#157#156#157#156#157#156#157
+ +#156#153#156#157'x'#156#157'tx'#156#157#156#156#157#157#166#170#174#170#204
+ +#203#168#202#198#164#194#194#194#160#194#194#156#190#156#0#0#0#165#134#165
+ +#129#170#169#129#170#133#170#169#169#169#134#169#170#170#169#170#170#170#169
+ +#170#170#169#170#170#169#170#170#169#170#170#129#170#169#166#170#133#166#170
+ +#169#130#170#166#170#165#170#169#129#170#165#170#165#170#165#165#166#170#165
+ +#169#166#165#166#165#169#165#165#165#166#165#165#165#165#165#165#165#165#161
+ +#165#161#161#161#161#161#161#160#161#161#160#157#160#157#156#161#156#156#157
+ +#157#156'y'#156'x'#157'xx'#152#157't'#156#157#156'u'#156'u'#156'x'#156#156
+ +#157#166#204#174#170#204#202#168#202#198#164#194#194#194#160#194#160#190#0#0
+ +#0#169#169#165#170#169#165#170#169#170#165#133#166#134#166#169#170#133#170
+ +#133#166#133#170#134#169#170#134#165#134#170#133#170#134#169#170#169#170#134
+ +#169#170#170#133#166#169#169#170#169#134#166#169#166#170#169#166#169#166#169
+ +#166#169#165#165#166#165#170#165#165#165#166#165#165#165#165#165#165#165#161
+ +#165#161#165#161#165#161#165#161#161#161#161#161#161#160#161#161#161#161#161
+ +#156#161#157#157#156#156#157#156#157#156#157#156#157'x'#156'y'#156'u'#156'x'
+ +#156#157#156'y'#157'x'#156#161#166#170#208#170#203#202#202#202#202#198#160
+ +#194#160#194#194#0#0#0#165#166#169#133#165#134#169#165#134#169#170#169#169
+ +#169#134#169#166#169#170#169#170#170#169#130#169#170#170#169#170#170#170#165
+ +#170#134#170#165#170#170#134#165#170#170#170#134#165#170#166#169#170#170#165
+ +#134#165#170#165#170#165#166#169#166#169#165#165#169#166#165#165#166#165#165
+ +#166#165#165#165#165#165#165#161#165#161#165#161#161#165#161#165#161#161#161
+ +#161#161#160#161#156#161#156#161#160#157#157#156#157#156#157'x'#157'x'#157
+ +#152#156't'#156#152#157't'#156'u'#156#156't'#157'x'#156#161#170#246#8#208#169
+ +#202#202#202#202#198#198#160#194#0#0#0#169#129#170#165#170#165#134#169#165
+ +#134#165#170#133#170#165#170#133#170#169#170#133#170#170#169#134#169#134#170
+ +#133#165#170#134#169#166#133#170#169#166#169#170#129#170#169#166#169#170#169
+ +#166#169#165#170#165#170#165#170#165#170#165#166#169#166#165#166#165#165#166
+ +#165#165#165#165#165#165#165#165#165#165#165#165#165#165#161#165#161#161#161
+ +#161#161#161#161#161#161#161#161#161#161#161#156#157#160#157#160#157#156#157
+ +#156#156#156'x'#157'x'#157't'#157't'#157'x'#156'u'#156#157#156#157#156#157
+ +#156#161#174#175#246#174#207#202#202#202#202#198#198#0#0#0#165#169#165#129
+ +#169#169#165#170#169#169#170#169#166#170#133#170#169#170#247#169#170#169#134
+ +#169#170#166#169#170#166#170#133#169#170#169#170#170#134#169#170#170#170#169
+ +#165#170#134#165#129#170#170#166#169#166#169#170#165#166#169#166#169#166#165
+ +#170#165#169#166#169#166#165#166#165#165#166#165#165#165#165#165#165#165#165
+ +#165#165#165#165#165#161#165#161#161#161#161#161#161#161#161#161#161#161#157
+ +#161#157#157#157#157#157#157#157#157#156#157#156#157'x'#156#152'x'#153#156't'
+ +#156'u'#156'u'#156#156#157#156#199#174#175#246#174#207#202#202#202#202#0#0#0
+ +#169#134#165#169#170#129#170#133#165#134#165#133#169#133#169#170#129#169#169
+ +#170#129#170#170#165#170#169#134#169#134#169#170#166#134#166#169#166#169#170
+ +#129#170#133#166#134#170#165#170#170#170#165#133#170#165#170#165#166#169#166
+ +#169#166#165#170#165#165#166#165#165#165#165#165#166#165#165#165#165#166#165
+ +#157#190#153#186#157#186#153#186#153#186#153#186#153#186#153#186#153#186#153
+ +#186#152#187#152#186#152#186#152#186#152#186#148#186#148#152#148#152#156'u'
+ +#156'u'#156't'#156'u'#156't'#156'x'#157'x'#157#156#161#203#174#246#8#207#206
+ +#202#202#0#0#0#165#165#170#133#165#169#169#165#170#169#170#165#170#169#166
+ +#169#170#170#134#169#170#169#169#170#133#166#169#166#169#166#133#170#169#169
+ +#134#169#134#169#170#165#170#169#166#169#170#165#170#165#170#170#165#170#129
+ +#170#169#166#169#166#169#166#165#165#170#165#165#166#165#166#165#165#165#166
+ ,#165#165#165#165#153#249#249#249#249#249#249#249#249#249#249#249#249#249#249
+ +#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249
+ +#249#148#157#156't'#156#152'y'#152'x'#152'y'#152#157't'#152'x'#157#156#156
+ +#165#174#246#179#246#173#207#0#0#0#169#165#169#166#169#130#169#169#129#169
+ +#133#170#129#170#133#169#129#169#165#170#129#170#129#170#169#170#133#170#169
+ +#134#165#170#130#169#170#166#169#166#170#169#166#170#169#166#169#166#133#170
+ +#165#170#165#170#165#166#169#166#165#170#165#169#166#165#166#169#166#169#165
+ +#169#166#165#165#165#166#165#165#165#165#183#249#249#249#249#249#249#249#249
+ +#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249
+ +#249#249#249#249#249#249#249#156#157#156'y'#156'x'#152#157't'#156't'#156'y'
+ +#156'u'#156'y'#152#157#156#199#174#175#255#174#0#0#0#165#133#165#169#133#165
+ +#169#130#169#170#165#169#169#169#166#169#170#169#170#133#170#169#170#169#130
+ +#169#166#169#166#169#170#169#169#170#129#169#170#133#169#130#170#133#165#134
+ +#170#169#170#165#170#129#170#166#169#170#165#170#169#166#165#166#166#169#166
+ +#165#165#166#165#166#165#165#166#165#165#165#166#165#165#165#186#249#249#249
+ +#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249
+ +#249#249#249#249#249#249#249#249#249#249#249#148#156#157#156#157#152#157't'
+ +#156'u'#156'u'#152#152'x'#156#152'y'#156'x'#157#160#203#178#175#0#0#0#165#169
+ +#166#169#165#169#170#169#169#165#169#134#169#130#169#134#165#134#169#166#169
+ +#169#247#169#170#133#170#133#170#169#134#165#134#166#169#170#166#169#166#170
+ +#169#165#170#166#165#169#166#170#165#170#165#169#170#165#165#170#165#166#169
+ +#166#169#165#165#165#170#165#165#165#165#166#165#165#165#166#165#165#165#165
+ +#166#191#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249
+ +#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#157#157#156
+ +'x'#157'x'#152'y'#152'x'#152'xx'#153'ty'#152'x'#153#156#157#156#165#208#0#0#0
+ +#169#165#169#129#170#133#165#129#169#134#165#169#165#169#165#169#169#165#169
+ +#133#166#169#170#165#169#166#169#165#134#165#170#169#165#169#166#169#133#166
+ +#169#165#166#170#169#169#170#166#169#129#170#165#170#166#165#134#166#165#166
+ +#169#166#165#165#166#169#166#165#166#170#165#166#169#165#166#165#165#165#165
+ +#166#165#165#165#157#249#249#249#249#249#249#249#249#249#249#249#249#249#249
+ +#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#152
+ +#156#157#157#156#157#156#156'x'#153'x'#153#152'x'#156#152'x'#153#156't'#156
+ +#153#156#161#0#0#0#129#169#165#169#165#169#170#169#165#169#169#165#134#169
+ +#133#166#169#134#165#170#133#165#133#170#129#169#170#169#165#170#129#170#169
+ +#134#169#166#169#170#134#169#133#166#134#165#169#170#166#169#170#165#169#170
+ +#165#169#166#169#165#166#169#166#169#165#166#165#169#165#165#165#165#166#165
+ +#165#166#165#166#165#165#165#165#166#165#161#249#249#249#249#249#249#249#182
+ +#249#182#182#249#182#249#182#249#249#182#249#182#249#182#182#249#182#249#249
+ +#249#249#249#249#249#157#156#156#157'x'#157#156#153#156#152'x'#153#152't'#157
+ +'txt'#157'tx'#156#152#0#0#0#165#165#134#165#169#165#169#129#169#169#247#169
+ +#165#169#166#169#133#165#169#165#169#170#165#169#169#166#133#165#134#169#169
+ +#165#170#165#170#133#166#169#165#170#166#169#165#170#166#129#169#166#165#134
+ +#165#165#170#165#169#166#169#166#165#165#166#166#169#166#165#166#165#166#165
+ +#165#165#166#165#165#165#165#166#165#166#165#165#165#161#182#249#249#187#165
+ +#165#165#165#161#165#165#161#165#161#165#165#161#165#161#161#161#161#161#161
+ +#161#161#152#182#249#249#249#152#157#157#156#157#156'y'#156'x'#157'x'#156'x'
+ +#153't'#156#152#157't'#152#157't'#157#0#0#0#169#169#165#169#165#133#165#169
+ +#170#165#169#169#169#165#133#169#165#169#134#169#134#165#133#170#129#169#170
+ +#169#165#170#165#170#129#170#165#165#170#165#170#165#169#165#170#165#169#169
+ +#170#165#170#169#166#134#165#166#166#165#166#165#165#170#165#169#165#165#166
+ +#169#165#165#166#165#166#165#166#165#166#165#165#165#165#165#165#165#166#161
+ +#182#249#249#182#165#165#165#165#165#161#165#165#165#161#161#161#161#161#161
+ +#165#161#161#161#161#161#161#161#186#249#249#182#157#156#157#157#156#157#156
+ +#157#156#152#153#152't'#156#152'ut'#156#153'xt'#156#0#0#0#129#165#169#129#170
+ +#165#169#165#129#169#165#169#129#170#169#129#170#169#165#169#165#169#169#165
+ +#170#165#133#166#169#165#133#169#165#133#169#170#165#133#165#134#165#134#165
+ +#133#166#166#165#170#165#166#165#165#170#169#165#133#165#170#166#165#165#166
+ +#165#166#165#165#166#169#165#165#169#165#165#165#165#166#165#166#165#166#165
+ +#165#165#165#165#182#249#249#182#161#165#165#165#165#165#161#165#165#165#165
+ +#161#165#161#161#161#161#161#161#161#161#161#161#152#249#249#152#161#157#156
+ +#157#156#157#156'y'#156'x'#157#156#153'x'#152#156'tt'#152#157't'#0#0#0#169
+ +#165#169#165#169#165#133#169#169#165#133#165#169#165#169#165#169#129#170#165
+ +#169#130#169#169#133#165#169#169#130#169#166#169#166#165#165#133#166#169#170
+ +#165#170#165#170#165#169#169#165#166#133#169#170#165#129#166#169#166#165#165
+ ,#165#170#165#165#166#169#165#166#165#166#165#166#165#166#165#166#165#165#165
+ +#165#165#165#166#165#166#165#166#165#186#249#249#182#161#165#165#165#165#165
+ +#161#165#161#165#165#161#165#161#165#161#161#161#161#161#161#161#161#186#249
+ +#182#157#160#157#160#157#156#157#156#157#156#152'x'#156#153'x'#152#157#152't'
+ +#152#156#0#0#0#165#169#130#169#165#169#165#165#165#169#165#169#165#133#165
+ +#169#165#169#165#133#165#169#165#166#165#170#165#129#169#165#133#165#169#169
+ +#170#165#169#165#165#169#165#169#165#170#165#130#169#165#165#166#165#166#169
+ +#165#166#165#170#166#169#165#166#169#165#165#166#165#165#165#165#165#165#165
+ +#165#165#165#166#165#166#165#165#165#165#165#165#165#165#165#187#249#249#249
+ +#161#165#165#165#165#165#165#165#165#161#165#161#165#161#161#165#161#161#161
+ +#161#161#161#161#182#249#152#161#157#157#156#157#156#157#156'y'#156#157#152
+ +'x'#152#156't'#156#152'x'#152#0#0#0#169#165#169#165#133#169#165#169#133#165
+ +#169#165#169#165#169#165#133#165#169#165#169#165#133#169#169#133#165#170#169
+ +#165#166#165#134#165#129#165#165#130#169#129#170#165#134#165#165#169#166#169
+ +#166#169#165#169#165#166#165#169#165#165#165#166#165#166#165#166#165#165#170
+ +#165#166#165#166#165#165#170#165#165#165#165#165#166#165#165#166#165#165#166
+ +#165#165#187#249#249#249#157#165#165#165#166#165#165#161#165#165#165#161#161
+ +#165#161#161#161#161#161#161#161#161#161#190#161#156#157#160#161#156#157#156
+ +#157#156#157'x'#156#157#152'y'#152#153'x'#153't'#0#0#0#165#133#165#169#165
+ +#165#169#165#165#169#165#133#165#169#165#169#165#169#129#169#165#169#165#165
+ +#165#165#169#165#165#169#133#169#165#165#170#169#169#169#166#169#165#169#165
+ +#165#170#165#165#165#169#166#165#166#169#165#165#166#165#166#165#169#165#165
+ +#165#169#166#165#165#165#165#165#169#166#165#165#166#165#165#166#165#165#165
+ +#165#165#165#165#165#166#165#165#191#249#249#249#157#165#165#165#165#165#165
+ +#165#161#165#165#165#161#165#161#165#161#161#161#161#161#161#161#161#161#161
+ +#157#157#160#157#160#156#157#156#157#156'x'#156#152'x'#156#152#156#152#0#0#0
+ +#165#169#165#129#169#169#129#169#169#165#169#165#169#165#133#165#169#165#169
+ +#165#133#165#169#133#165#169#165#169#129#165#165#165#169#165#165#165#166#165
+ +#169#166#165#165#170#129#165#170#165#166#165#129#169#165#166#129#169#165#165
+ +#169#166#165#166#165#166#165#165#165#166#165#166#165#165#165#166#165#165#166
+ +#165#165#165#166#165#166#165#166#165#165#165#165#165#165#157#249#249#249#187
+ +#165#165#166#165#165#166#165#165#161#165#165#161#165#161#165#161#161#161#161
+ +#161#161#161#161#160#161#161#157#157#157#157#156#157#156#157#157#156#157#152
+ +'y'#156't'#156#0#0#0#169#165#169#169#165#165#169#165#165#129#169#165#165#169
+ +#165#169#165#165#165#169#165#169#165#165#169#165#133#165#169#165#169#129#165
+ +#169#129#169#165#133#165#165#133#166#165#165#169#165#129#169#165#170#165#165
+ +#169#165#166#165#166#165#165#165#165#165#165#165#166#165#165#165#165#165#166
+ +#165#165#165#165#165#165#166#165#165#165#169#165#165#165#166#165#166#165#165
+ +#165#195#249#249#249#187#165#165#165#165#165#165#165#165#165#161#165#161#165
+ +#161#161#165#161#161#161#161#161#161#161#161#156#161#160#157#160#157#156#157
+ +#156#156#157'x'#156#156#152#157#152#0#0#0#165#129#169#165#165#169#165#169#165
+ +#169#165#169#165#169#165#165#129#169#169#165#165#169#165#169#165#169#165#165
+ +#165#169#165#165#169#165#169#165#165#165#165#169#165#165#169#165#166#165#169
+ +#166#165#165#165#166#165#166#165#165#165#165#166#165#165#166#165#166#165#165
+ +#166#165#165#166#165#165#166#165#166#165#166#165#165#165#166#165#166#165#166
+ +#165#169#165#165#166#165#166#157#249#249#249#182#165#166#165#166#165#165#166
+ +#165#165#166#165#165#161#165#161#165#161#161#161#161#161#161#161#161#161#157
+ +#160#157#157#160#157#156#157#156#157#156#153'x'#152'x'#0#0#0#165#169#165#165
+ +#133#165#169#165#169#165#169#165#169#165#169#165#169#165#165#165#169#165#165
+ +#165#165#165#165#169#165#165#165#165#165#165#165#165#165#169#165#165#165#165
+ +#165#165#165#165#165#165#165#165#165#165#165#165#165#165#166#165#165#165#165
+ +#165#165#165#165#165#165#166#165#165#165#165#165#165#165#165#165#165#166#165
+ +#165#165#165#165#169#165#165#166#165#165#165#165#165#161#249#249#249#182#165
+ +#165#165#165#165#165#165#165#165#161#166#165#161#165#161#165#161#161#161#161
+ +#161#160#161#156#161#157#160#156#157#156#157#156#156#156#156#156#156#157#152
+ +#0#0#0#169#165#169#165#169#165#165#129#169#165#255#255#174#165#165#169#165
+ +#169#165#169#165#174#255#255#169#169#165#165#174#246#246#246#170#165#246#255
+ +#208#165#170#246#246#255#246#174#169#165#165#165#255#255#175#165#165#166#165
+ +#165#208#255#255#166#165#170#255#246#170#165#165#165#165#166#165#166#165#255
+ +#246#246#165#165#208#255#246#170#165#165#166#165#170#208#246#255#246#246#208
+ +#165#161#249#255#255#204#161#166#165#166#165#166#165#165#165#165#165#165#165
+ +#161#165#161#161#165#161#161#161#161#161#160#157#161#157#160#157#156#157#156
+ +#157#156#157#152#156#156#0#0#0#165#165#169#165#165#169#165#169#165#165#255
+ +#255#246#165#169#165#169#165#165#165#165#208#255#246#169#165#165#246#255#255
+ ,#255#255#255#174#246#255#170#169#255#255#255#255#255#255#246#170#165#165#255
+ +#255#208#165#165#165#165#165#246#246#255#165#165#208#255#246#170#165#165#165
+ +#166#165#165#165#165#255#255#246#165#165#170#255#255#170#165#165#165#208#255
+ +#255#255#255#246#255#255#170#165#195#255#255#204#249#161#165#165#165#165#165
+ +#166#165#165#161#166#161#165#161#161#165#161#161#161#161#161#157#161#160#157
+ +#160#157#156#157#156#157#156#156#156'x'#157#152#0#0#0#165#169#129#165#169#165
+ +#169#165#165#169#246#255#208#165#165#165#165#165#165#169#165#174#246#255#170
+ +#165#174#255#255#208#169#169#174#255#255#255#208#165#208#174#169#169#170#246
+ +#255#246#165#165#255#255#246#165#165#129#165#165#175#255#255#165#165#170#255
+ +#255#170#165#165#165#165#165#165#165#165#255#255#208#165#166#208#255#255#170
+ +#165#170#204#255#255#255#204#170#204#204#246#165#165#166#255#255#204#249#249
+ +#161#165#166#165#166#165#165#166#165#165#165#165#161#165#161#161#161#161#161
+ +#160#161#160#157#161#156#157#156#157#156#156#157#156#156#157#152#156#0#0#0
+ +#165#165#169#165#165#165#165#165#169#165#255#246#246#169#165#169#165#169#165
+ +#165#165#174#255#255#169#165#246#255#246#165#165#165#165#208#255#255#174#165
+ +#165#165#165#165#165#170#255#255#170#165#255#255#174#165#165#165#165#165#208
+ +#255#255#165#165#174#255#246#170#165#166#165#165#165#165#166#165#255#255#209
+ +#165#165#174#255#246#170#165#165#255#255#255#169#165#169#166#165#169#166#165
+ +#165#255#255#204#249#249#249#157#165#165#165#165#165#165#165#165#161#165#165
+ +#161#161#161#161#161#161#161#161#157#161#156#157#156#157#156#156#157#156#157
+ +#152#156#156#152#0#0#0#165#165#165#169#165#169#165#165#165#165#255#255#174
+ +#165#165#165#165#165#165#169#165#204#255#255#169#165#255#255#246#165#165#165
+ +#165#170#255#246#204#165#165#165#165#165#165#165#255#255#170#165#255#255#246
+ +#165#165#165#165#161#246#255#255#165#165#204#255#246#170#165#165#165#165#166
+ +#165#165#165#255#246#246#165#165#208#255#246#170#165#170#255#246#208#166#165
+ +#165#169#166#165#165#170#165#255#255#208#249#249#249#249#191#165#166#165#166
+ +#165#165#165#165#161#165#165#161#165#161#161#161#161#161#160#157#160#161#157
+ +#156#157#156#156#156#156#157#156#157#156#0#0#0#165#169#165#165#165#165#165
+ +#169#165#169#246#255#208#165#169#165#169#165#169#165#165#174#255#255#169#165
+ +#255#255#208#165#165#165#165#169#255#255#174#165#165#165#165#165#165#165#255
+ +#246#208#165#255#255#174#165#165#165#165#165#174#255#255#165#165#174#255#255
+ +#166#165#165#165#165#165#165#165#165#255#255#246#165#166#170#255#255#170#165
+ +#246#246#255#166#165#169#166#165#165#169#166#165#166#255#246#246#161#249#249
+ +#249#249#187#165#165#165#165#166#165#165#165#161#165#161#161#161#161#161#161
+ +#160#161#161#157#156#161#157#156#157#157#156#157#156#156't'#156#0#0#0#165#165
+ +#165#165#169#165#169#165#165#165#246#255#246#165#165#164#165#165#165#165#164
+ +#174#255#255#169#165#208#255#246#165#165#165#165#169#255#255#204#165#165#165
+ +#165#165#165#174#255#255#170#165#246#255#246#165#165#161#165#165#246#255#255
+ +#165#165#170#255#255#169#165#165#165#165#165#165#165#165#255#255#208#165#165
+ +#208#255#255#170#165#246#255#246#165#169#166#165#165#169#166#165#165#169#255
+ +#255#246#165#161#249#249#249#249#186#166#165#165#165#165#161#165#161#165#161
+ +#161#161#161#161#160#161#157#161#156#161#156#156#157#156#156#156#156#157#156
+ +#156#157#0#0#0#165#165#169#165#165#165#165#165#165#165#255#255#208#165#165
+ +#165#165#164#165#165#165#208#255#255#169#165#170#255#255#170#165#165#165#169
+ +#255#255#174#165#165#165#165#165#208#255#255#246#165#165#255#255#208#165#165
+ +#165#165#165#174#255#255#165#165#204#255#246#170#165#165#165#165#165#165#165
+ +#165#255#255#246#165#165#174#255#255#170#165#255#255#208#166#165#165#170#165
+ +#166#165#170#165#166#255#246#246#165#166#195#249#249#249#249#182#165#166#165
+ +#165#165#161#165#161#161#165#161#161#161#161#161#161#156#161#156#157#161#156
+ +#157#156#157#156#156#157#156#156#0#0#0#165#165#165#165#165#165#165#164#165
+ +#165#255#255#174#165#165#165#165#165#165#165#165#170#255#255#169#164#165#208
+ +#255#246#246#169#165#169#255#246#204#165#164#165#170#246#255#255#246#165#165
+ +#165#255#255#208#161#165#165#161#165#246#255#246#165#165#174#255#255#169#165
+ +#165#165#165#165#165#165#165#255#246#246#165#165#204#255#246#170#165#255#255
+ +#246#174#204#174#204#174#204#174#204#169#165#255#246#246#166#165#165#161#249
+ +#249#249#249#182#161#165#161#165#165#161#165#161#161#161#161#161#161#161#160
+ +#161#157#161#156#156#157#156#157#156#157#156#156#157#156#0#0#0#165#165#165
+ +#164#165#165#165#165#165#165#246#255#246#165#164#165#165#165#164#165#164#208
+ +#255#255#169#165#165#165#174#255#246#246#255#255#255#255#170#165#165#170#246
+ +#255#255#246#165#165#165#165#246#255#174#165#165#165#165#165#208#255#255#165
+ +#165#204#255#255#166#165#165#165#165#165#165#165#165#255#255#246#165#165#174
+ +#255#255#170#165#255#255#255#255#255#255#255#255#255#255#255#166#169#255#255
+ +#246#165#165#170#165#191#249#249#249#249#182#161#165#165#161#165#161#165#161
+ +#161#161#161#161#160#157#161#160#157#161#161#156#161#156#157#156#157#156#156
+ ,#156#0#0#0#165#165#165#165#165#165#165#165#165#165#246#255#208#165#165#165
+ +#164#165#165#165#165#170#246#255#165#165#165#165#165#165#170#246#246#255#255
+ +#255#208#164#170#255#255#255#170#165#164#165#165#161#246#255#246#161#165#161
+ +#165#165#208#255#255#165#165#170#246#255#169#165#165#165#165#165#165#165#165
+ +#255#255#208#165#165#208#255#255#169#165#246#246#246#208#208#208#208#174#246
+ +#255#255#165#166#255#255#246#165#170#165#166#165#187#249#249#249#249#182#161
+ +#165#161#165#161#161#161#161#161#160#161#161#161#160#157#160#157#156#156#157
+ +#156#157#156#156#157#156#157#0#0#0#165#165#165#165#165#165#164#165#164#165
+ +#255#255#246#246#246#246#246#246#174#165#164#208#255#255#169#164#165#164#161
+ +#164#165#164#165#165#255#246#170#165#208#255#255#169#164#161#165#161#164#165
+ +#255#255#208#165#165#165#161#165#208#255#246#165#165#204#255#255#246#246#246
+ +#246#246#246#166#165#165#255#246#246#165#165#170#255#246#170#165#246#255#246
+ +#165#165#165#169#166#208#255#246#165#169#255#255#255#165#165#165#165#165#165
+ +#183#249#249#249#249#182#161#165#161#161#165#161#161#161#161#161#156#161#157
+ +#161#157#160#157#161#156#157#160#157#157#156#157#156#0#0#0#165#164#165#164
+ +#165#165#165#165#165#165#255#255#255#246#246#255#255#255#208#165#165#170#255
+ +#255#165#165#164#165#165#165#164#161#165#169#255#255#204#165#255#255#208#161
+ +#165#164#165#165#161#165#255#255#246#161#165#164#165#165#246#255#246#165#165
+ +#174#255#255#255#255#246#246#246#255#169#165#165#255#255#246#165#165#208#255
+ +#246#170#165#208#255#246#170#165#166#165#165#246#246#246#166#165#255#255#255
+ +#170#166#166#165#166#165#161#182#249#249#249#249#182#161#165#161#161#161#161
+ +#161#161#161#161#161#160#157#160#157#160#157#160#157#156#156#157#156#157#156
+ +#0#0#0#165#165#165#165#165#164#165#165#164#165#246#255#246#170#204#174#169
+ +#204#170#164#164#204#255#255#165#165#165#164#165#164#161#165#164#170#255#255
+ +#169#161#246#255#208#165#164#161#164#161#164#165#246#255#255#169#165#161#165
+ +#165#255#255#246#160#165#204#255#255#208#204#204#204#204#204#165#165#165#255
+ +#255#208#165#165#170#255#255#170#165#170#255#255#170#169#165#169#170#255#255
+ +#208#165#170#246#255#255#246#165#165#165#165#165#165#161#249#249#249#249#249
+ +#182#161#165#161#161#161#161#161#161#161#160#161#161#161#157#160#157#157#160
+ +#157#161#156#157#156#157#0#0#0#165#165#165#164#165#165#165#164#165#161#255
+ +#255#208#165#160#165#161#165#164#165#165#170#246#255#169#165#160#165#165#160
+ +#165#164#165#246#255#246#165#164#208#255#246#165#161#165#165#165#165#161#246
+ +#255#255#246#165#165#165#208#255#255#208#165#165#170#246#255#165#165#165#165
+ +#165#165#165#165#165#246#255#246#165#165#208#255#255#169#165#165#208#255#246
+ +#166#165#166#208#255#246#170#170#165#255#255#246#255#246#170#170#165#166#165
+ +#166#187#249#249#249#249#249#182#161#161#161#161#161#160#161#161#161#157#160
+ +#157#160#157#157#160#157#161#156#157#156#161#156#0#0#0#165#164#165#165#165
+ +#164#165#165#165#164#255#255#174#165#165#164#165#164#165#160#165#204#255#255
+ +#165#164#165#204#246#246#208#208#255#255#255#174#161#164#165#255#255#246#246
+ +#208#246#246#160#165#255#255#246#246#255#246#246#255#255#255#165#165#165#204
+ +#255#255#169#165#165#165#165#165#165#165#165#255#255#208#165#165#174#255#246
+ +#170#165#165#170#246#246#255#174#246#255#246#209#165#165#165#255#255#170#246
+ +#255#255#246#165#165#165#165#161#182#249#249#249#249#249#186#161#161#161#161
+ +#161#161#161#160#161#161#161#161#161#160#161#157#160#157#160#157#156#157#0#0
+ +#0#165#165#164#165#165#165#160#165#165#165#255#255#246#160#165#161#164#161
+ +#164#165#164#170#255#255#165#161#164#170#246#246#246#246#246#255#208#160#165
+ +#161#164#165#246#255#255#255#246#246#165#160#255#255#208#165#246#255#246#246
+ +#255#203#165#161#164#170#255#255#199#165#161#164#165#165#165#165#165#246#246
+ +#246#165#165#204#255#255#204#165#169#165#170#246#255#255#255#255#246#169#166
+ +#169#166#255#255#204#170#255#255#208#166#165#165#165#165#161#249#249#249#249
+ +#249#249#157#161#161#161#161#161#161#161#156#161#160#157#161#157#160#161#157
+ +#160#157#161#156#157#0#0#0#165#165#165#165#160#165#165#165#160#165#246#255
+ +#208#165#160#165#161#164#161#160#164#204#246#255#165#164#160#165#165#165#170
+ +#170#170#165#164#165#160#164#161#164#161#169#169#204#169#165#160#165#246#255
+ +#208#161#164#169#204#170#165#160#165#164#165#204#255#255#169#165#165#165#165
+ +#164#165#165#165#204#208#169#165#165#174#255#246#169#165#165#165#165#165#204
+ +#208#208#170#165#170#165#165#170#208#208#170#165#165#204#170#165#165#166#161
+ +#165#161#187#249#249#249#249#249#249#161#161#161#161#160#161#161#161#161#157
+ +#161#160#161#161#157#160#157#160#157#161#156#0#0#0#165#164#161#164#165#165
+ +#165#160#165#161#246#255#208#165#160#165#164#161#164#165#165#170#246#255#165
+ +#161#165#160#160#161#164#161#164#160#160#161#164#161#160#165#160#164#161#165
+ +#160#165#160#165#255#255#208#165#164#161#164#161#164#165#165#161#165#204#246
+ +#255#165#165#165#165#165#165#165#165#165#165#165#165#165#165#204#255#255#170
+ +#165#165#165#170#165#165#166#165#165#165#165#165#166#169#166#165#166#165#166
+ ,#165#166#161#165#165#165#161#165#161#249#249#249#249#249#249#182#161#161#161
+ +#161#161#161#161#160#161#160#161#157#160#161#161#161#157#161#156#157#0#0#0
+ +#165#165#165#165#161#164#161#165#164#165#255#255#208#161#165#160#161#164#161
+ +#160#160#170#255#255#165#164#160#165#161#164#161#160#161#164#161#164#160#165
+ +#164#160#165#161#164#160#165#160#165#160#246#255#208#161#161#164#161#164#161
+ +#164#161#164#164#170#255#255#169#164#161#164#165#165#165#165#165#165#165#165
+ +#165#165#208#255#255#169#165#165#165#165#165#169#165#169#166#169#166#169#165
+ +#165#165#165#165#165#165#165#165#166#165#161#165#165#161#161#186#249#249#249
+ +#249#249#249#157#161#161#161#160#161#161#161#161#161#161#161#157#160#157#160
+ +#161#156#161#161#0#0#0#165#164#161#164#165#161#164#161#160#165#255#255#8#164
+ +#161#164#161#161#164#161#165#204#255#255#165#161#160#160#160#161#164#160#160
+ +#161#164#161#160#160#161#160#164#160#165#164#160#165#160#165#255#255#208#164
+ +#161#164#161#164#165#160#165#161#165#204#255#255#165#165#165#165#160#165#164
+ +#165#165#165#170#165#165#165#170#255#255#170#165#165#165#165#165#166#165#165
+ +#165#165#165#166#165#166#165#166#165#166#165#165#165#165#161#165#161#161#165
+ +#161#161#249#249#249#249#249#249#182#161#161#161#161#161#160#161#161#161#160
+ +#161#161#161#161#157#161#157#156#157#0#0#0#165#161#165#165#161#164#165#165
+ +#165#161#246#255#208#161#160#161#160#160#161#160#160#170#255#255#165#160#161
+ +#160#161#160#161#161#160#160#161#160#165#161#164#161#160#161#160#161#160#165
+ +#160#160#255#255#246#160#164#161#164#161#164#161#164#164#160#174#255#255#165
+ +#165#160#165#165#165#165#165#169#255#255#208#165#165#208#255#255#169#165#165
+ +#165#165#165#165#165#165#165#166#165#165#165#165#165#165#165#165#165#246#161
+ +#208#161#246#161#246#161#161#161#182#249#249#249#249#249#249#157#161#161#161
+ +#161#161#161#161#160#161#161#160#161#161#160#161#160#161#161#0#0#0#165#164
+ +#161#161#164#161#161#160#161#160#255#255#255#246#246#246#246#246#246#165#161
+ +#203#255#255#165#160#161#160#161#160#160#160#160#161#160#160#160#160#160#160
+ +#165#160#164#160#165#160#164#165#255#255#208#164#161#164#161#160#164#161#164
+ +#161#165#204#246#255#246#246#246#246#246#246#174#165#170#255#255#255#165#165
+ +#170#246#255#170#165#165#165#165#165#165#165#166#165#165#165#165#166#165#166
+ +#165#165#166#165#209#165#246#170#246#165#255#161#161#165#152#249#249#249#249
+ +#249#249#182#161#161#161#161#161#161#161#161#161#161#161#161#156#161#157#161
+ +#157#156#0#0#0#161#165#164#165#161#165#164#161#164#161#255#246#246#246#246
+ +#246#246#246#255#165#160#170#255#255#165#161#160#160#160#160#161#160#161#160
+ +#161#160#161#160#161#160#160#161#161#164#160#165#160#160#255#255#208#161#164
+ +#161#160#164#161#164#161#164#160#204#246#246#255#246#246#246#246#255#208#165
+ +#203#255#255#208#165#165#208#255#255#169#165#165#165#165#165#165#165#165#165
+ +#165#166#165#165#165#165#166#165#165#165#208#161#209#204#170#170#246#161#161
+ +#161#157#249#249#249#249#249#249#249#161#161#160#161#161#160#161#161#161#160
+ +#161#161#161#161#161#156#161#161#0#0#0#165#160'}'#164#161#160#161#165#161#160
+ +#170#170#170#170#170#170#170#170#169#161#161#170#246#255#165#160#161#160#161
+ +#160#160#161#160#160#160#161#160#160#160#161#160#160#160#161#160#160#165#160
+ +#255#255#208#160#165#164#165#165#160#164#161#165#164#165#204#204#208#204#204
+ +#204#204#204#203#161#165#169#203#199#165#165#204#246#246#203#165#165#165#165
+ +#165#165#165#165#165#165#165#165#166#165#165#161#165#165#161#209#161#208#246
+ +#161#204#208#161#161#161#161#249#249#249#249#249#249#249#156#161#161#161#161
+ +#161#161#161#161#161#161#160#161#156#161#161#156#157#0#0#0#161#165#165#161
+ +#165#161#128#160#161#161#161#160#161#160#161#160#161#160#161#161#160#160#161
+ +#160#161#160#160#161#160#157#160#160#161#160#161#160#161#160#161#160#161#160
+ +#161#160#160#161#160#160#165#160#164#161#160#160#160#160#165#160#164#160#160
+ +#165#160#165#160#164#161#165#164#165#165#165#164#165#165#165#165#165#165#165
+ +#165#165#165#165#165#165#165#165#165#165#165#165#165#165#165#161#165#165#165
+ +#161#246#8#246#174#170#161#170#170#161#161#161#161#182#249#249#249#249#249
+ +#249#153#161#161#161#161#161#161#160#161#161#161#161#161#161#161#156#161#161
+ +#0#0#0#165#164#161#160#161#160#161#161#161#160#160#161#160#161#160#161#160
+ +#161#160#160#160#161#160#161#160#160#161#160#161#160#160#161#160#160#160#160
+ +#160#161#160#160#160#160#160#160#161#160#160#165#160#160#161#164#160#165#164
+ +#165#160#165#160#165#165#160#165#160#164#161#165#164#165#194#165#164#165#161
+ +#165#165#165#165#165#165#165#165#165#165#165#165#165#165#165#165#165#165#165
+ +#165#165#165#165#165#161#165#161#165#161#161#161#161#161#161#161#161#161#161
+ +#148#249#249#249#249#249#249#182#161#161#161#161#161#161#161#161#161#161#161
+ +#161#161#160#161#161#156#0#0#0#161#161#165#161#128#161#161#160'|'#161#161#160
+ +#161#160'}'#160#161#160#157#160'}'#160#161#160#156#161#160#160#160'|'#161#160
+ +#161'|'#161#160#161#160#160#161#161#160#161#160#160#161#160#160#161#164#160
+ +#161#164#160#161#160#164#161#164#160#164#160#165#164#161#164#164#161#164#165
+ ,#161#165#165#164#165#165#164#165#165#165#165#165#165#165#165#165#165#165#165
+ +#165#165#161#165#165#161#165#161#161#165#161#161#161#161#161#161#161#161'}'
+ +#161#161#161#161#182#249#249#249#249#249#249#182#161#161#161#161#161#161#161
+ +#161#161#161#161#160#157#161#157#160#157#0#0#0#164'}'#160#161#161#160#161#161
+ +#161#160#157'|'#161#160#156#161#156'}'#160#161#160#157#160'}'#160#160'y'#160
+ +#157#160#156#160#156#161#160#160#156#161#160#160#160#160#160#161#160#160#161
+ +#160#160#161#160#164#161#164#160#165#160#164#161#164#161#164#160#161#164#161
+ +#165#164#161#164#164#160#165#165#164#165#165#165#165#165#165#165#165#161#165
+ +#165#165#165#165#161#165#165#165#161#165#165#165#161#161#161'}'#161#161#161
+ +#161#161#161#161#161#161#161#161#182#249#249#249#249#249#249#182#161#161#161
+ +#161#161#161#161#161#161#160#161#161#160#161#161#161#160#0#0#0#165#161#165
+ +#160#161#161'|'#161#160#161#160#161#160#161#160#160#161#160#156#161#156#160
+ +#161#156#160#161#160#161#160#161#160#161#160#160#157#160#161#160#161#160#161
+ +#160#161#160#160#161#160#160#161#160#161#160#160#161#160#164#161#164#160#165
+ +#160#198#165#165#164#160#164#161#164#165#161#165#164#161#165#161#164#161#165
+ +#164#165#165#165#165#165#165#161#161#156#165#165#161#165#165#161#161#161#161
+ +#161#161#161#161#161'}'#161#161#161#161#161#157#161#161#249#249#249#249#249
+ +#249#249#182#161#161#161#161#161#161#161#160#161#161#161#161#161#157#160#157
+ +#157#0#0#0#160#161#160'}'#161#160#161#160#161#160#161#160#157'|'#157#161'x'
+ +#157#160'y'#160#161'x'#160#161'x'#156#156'|'#156#161'x'#160#157#160'|'#160
+ +#156#160#160#160#161#160#160#161#160#160#161#160#160#160#160#161#164#160#165
+ +#160#160#165#160#164#165#160#160#160#165#165#160#165#161#164#164#161#165#164
+ +#165#165#165#165#161#165#165#161#165#165#161#165#182#249#157#161#165#161#161
+ +#161#161#161#161#161#161#161#161#161#157#161#161#157#161#161#161#160#161#249
+ +#249#249#249#249#249#249#182#161#161#161#161#161#161#161#161#161#161#161#161
+ +#160#161#161#161#160#0#0#0#165#160#161#161#160#161#160#161#160#161'x'#161#160
+ +#157#160#156#161#160#157#160'x'#156#160#157#156#161#160#161#156#161#156#161
+ +'x'#160#161#156#161#160#161#156#161'x'#161#160#160#161#160#160#161#160#161
+ +#160#160#161#160#160#165#160#160#165#161#160#165#164#165#194#160#165#160#164
+ +#161#161#164#161#165#160#165#160#165#165#161#165#165#161#165#161#165#157#249
+ +#249#161#161#161#161#161#161#161#161#161#161#161'}'#161#161#161#161'|'#161
+ +#161#161#161#153#249#249#249#249#249#249#249#182#161#161#161#161#160#161#161
+ +#161#161#161#160#161#157#160#157#160#157#0#0#0#161#161#160#161#160'}'#161#160
+ +'}'#160#161#156#161#156'}'#156#157'|'#156#157#160'y'#156#160'y'#156#156'|'
+ +#157'|'#160#156#161#156#160#156'|'#157#160'|'#160#160#160#161#160#160#161#160
+ +#160#161#160#161#160#160#161#160#160#165#160#160#164#160#160#161#164#165#160
+ +#164#165#161#164#165#160#165#160#165#161#165#161#160#165#161#165#165#161#165
+ +#161#165#152#249#249#161#161#161#161#161#161#161'}'#161#161#161#161'}'#157
+ +#161#161#157#160#161#161#182#249#249#249#249#249#249#249#190#160#161#161#161
+ +#161#161#161#161#161#161#161#161#160#161#161#157#160#0#0#0#161#160#161#160
+ +#161#160#156#160#161#160#157#160'y'#160#157#160'x'#157#156'|'#157#160#157'x'
+ +#160#156'}'#156#156#156#157'|'#156'|'#157#160#157#160#161#156#157#160#157#160
+ +#160#157#160#160#161#160#160#160#160#161#160#160#161#160#161#164#161#164#161
+ +#164#160#160#165#161#160#164#160#161#164#161#165#160#165#160#165#165#161#165
+ +#161#160#161#161#161#161#161#182#249#249#157#161#161#161'}'#161#161#161'y'
+ +#161#157#161#161#160#157#161#161#161#157#249#249#249#249#249#249#249#249#157
+ +#161#161#161#161#161#161#161#160#161#161#160#161#157#161#156#161#157#0#0#0
+ +#160#161#160#161#161#160#161#161#156#156'}'#156#161#156#160'x'#161#156'|'#157
+ +#156#156'x'#157#156'y'#156#157'|'#157'|'#156#160#157#156'|'#156#160#156#161
+ +#160#160#160#161#160#160#160#161#160#160#161#160#161#160#160#161#160#160#160
+ +#161#160#160#164#161#160#165#160#164#160#165#161#165#160#161#160#161#161#161
+ +#161#160#161#160#161#161#161#160#161#161#161#157#249#249#249#157#161#161#157
+ +#161#160'y'#161#160'}'#156#161'y'#161#161#161#157#182#249#249#249#249#249#249
+ +#249#249#161#161#161#161#165#161#161#161#161#161#161#161#161#161#160#161#157
+ +#160#0#0#0#161#160#161#160#160#161#160'x'#161#161#156'|'#156'y'#156#157'x'
+ +#156#157'x'#157'x'#157'x'#156#156'x'#156#156#156#157'x'#157'|'#157#160#157
+ +#156'}'#156'|'#157#160#156#161#156#161#160#161#160#160#161#160#161#160#160
+ +#161#160#161#160#161#160#161#160#161#160#161#160#161#160#160#160#161#160#161
+ +#160#161#160#161#161#161#161#161#161#161#161#161#161#160#161#157#249#249#249
+ +#152#157'}'#157'}'#157'}'#157#157'}'#156#161#157#160#161#182#249#249#249#249
+ +#249#249#249#249#186#161#161#161#160#161#161#161#161#161#161#160#161#160#157
+ +#161#156#160#157#0#0#0#160#161#160#161#161#156#161#160#156#160#157#157#160
+ +#156#161'x'#157'x'#156#156'x'#156#156'y'#156'y'#156'y'#156'y'#156#156'x'#156
+ +'x'#157'|'#156#156#161#156#160'y'#160#160#161'|'#156#160#161#160#160#160#160
+ ,#161#160#160#161#160#160#160#161#160#160#160#160#160#161#160#161#160#161#160
+ +#161#160#161#160#161#160#161#161#160#161#160#161#161#161#161#161#161#161#152
+ +#249#249#249#249#157#157#157#161#157'|'#157#161#161#161#161#153#249#249#249
+ +#249#249#249#249#249#249#249#160#161#161#161#161#161#161#161#160#161#161#161
+ +#161#161#160#161#161#157#160#0#0#0#161#160#161#160#160#161#160#157#160'y'#160
+ +#156'x'#157'x'#156#156#157'x'#157#156'y'#156#156'x'#156'x'#156'x'#156'x'#157
+ +'x'#157#156'x'#156#157'|'#156'x'#157#160#157#157#156#157#160#161#156#161#156
+ +#161#160#160#161#161#160#161#160#161#160#161#160#161#160#161#160#161#160#161
+ +#160#161#160#160#161#160#161#161#160#160#161#161#161#161#160#157#160#157'}'
+ +#156#161#148#249#249#249#249#249#152#153#156#157#157#156#153#186#249#249#249
+ +#249#249#249#249#249#249#249#249#186#161#161#161#165#161#161#161#161#161#161
+ +#160#161#160#161#161#156#161#160#157#0#0#0#160#160#161#160#161#160#157#160
+ +#161#156#156'|'#157#156#157'x'#157'x'#156'xy'#156'xxy'#156'y'#156'y'#156'y'
+ +#156#156#156'x'#156#157'x'#157#156#157'|'#156#160'|'#160#160#161#156#160#160
+ +#161#160#157#161#160#156#160#160#161#160#160#160#161#160#161#160#160#160#160
+ +#160#161#160#160#161#157#160#161#160#161#161#161#156#161#160#157#161'y'#161
+ +#156#161'y'#157#182#249#249#249#249#249#249#249#249#249#249#249#249#249#249
+ +#249#249#249#249#249#249#249#249#182#161#161#161#160#161#161#161#160#161#160
+ +#161#161#161#157#160#156#161#161#156#161#0#0#0#161#161#160#161#160#161#160'x'
+ +#156#161#156#157#160'x'#156#156'x'#156'y'#156#156'x'#157#156#156'x'#156'x'
+ +#156'x'#156'xyx'#157'x'#156'x'#156'x'#156#157'x'#157#156'y'#156'x'#161'x'#161
+ +#156#160#160#160#160#161#156#161#160#160#161#161#160#160#160#161#160#157#160
+ +#157#160#161#161#160#160#161#156#161#156#161#156#161'y'#161'|'#157#160'y'#157
+ +'y'#156'y'#157#148#249#249#249#249#249#249#249#249#249#249#249#249#249#249
+ +#249#249#249#249#249#249#182#195#161#161#161#161#161#160#161#161#161#161#161
+ +#160#161#160#161#161#161#156#161#157#0#0#0#160#160#161#160#161'x'#161#160#161
+ +'x'#160'x'#157#156'y'#156#157'x'#156'x'#157'txu'#156'y'#156't'#157'x'#157#156
+ +#152'x'#156'y'#156'y'#156'x'#157'x'#156'x'#161#156#161#156#156#161#156#161'y'
+ +#160#157#160#160#161#160#161#156#160#160#161#160#157#160#160#160#161#160#160
+ +#156#160#157#160#156#161#160#157#160#157#160#157#156#157'y'#157#156'y'#157'y'
+ +#156'y'#157#152#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249
+ +#249#249#249#182#161#160#161#160#165#161#161#161#161#161#160#161#161#161#161
+ +#161#156#161#156#161#160#160#0#0#0#161#161#160#160#161#160#160#157#160#156
+ +#161#156#160'x'#156'x'#156#156'y'#156'x'#156#156#156'x'#152'x'#157'x'#156'xx'
+ +'y'#156'y'#156'x'#156'x'#157'x'#156'y'#156#156'x'#156'}'#157'x'#160#156#160
+ +#157#160#157#160#157#160#156#161#160#157#160#157#160#161#156#161#156#161#156
+ +#161#156#160#157#160#156#157#156'y'#156'y'#156'y'#156#156'yy'#156'y'#156'yxy'
+ +'y'#156#148#249#249#249#249#249#249#249#249#249#249#249#249#249#249#249#190
+ +#161#160#161#161#165#161#161#161#160#161#160#161#161#160#161#160#161#161#160
+ +#161#160#157#161#0#0#0#160#160#160#161#156#160#157#160#156#161#156'y'#156#157
+ +#156#156#157'x'#156#156'x'#157'tyt'#156'y'#156't'#156'u'#156#156'xx'#156'u'
+ +#156'y'#156'x'#157'x'#156'y'#156'y'#156#156#160'y'#156'}'#156#161'x'#161#156
+ +#160#157#160#157#160#156#160#160#156#157#160#156#160#157#160#156#157#156#157
+ +#157#156'y'#156#157#156#157'x'#157'yy'#156'yxuy'#157'y'#156'y'#157#156#152
+ +#182#249#249#249#249#249#249#249#249#249#182#190#161#161#161#161#161#165#161
+ +#160#161#160#161#161#161#161#160#161#160#161#157#160#157#161#156#161#156#0#0
+ +#0#161#160#161#160#161#160#160#157#160'x'#156#160#156'|'#157'x'#156#157'x'
+ +#157't'#156#156#156#156'x'#152'ty'#156'xxux'#153'xx'#152'xy'#156'x'#157'y'
+ +#156'y'#156'x'#157'y'#156#161#156'}'#156#156#160'x'#161#160'y'#160#156#161
+ +#157#156'}'#160#157#160#157'x'#157#156#156'y'#156'x'#156#157'x'#156'yx'#157
+ +'x'#157'xyyyxxyxy'#156'y'#156#157#161#160#152#187#152#186#186#190#191#160#161
+ +#161#161#160#161#164#161#160#161#161#161#161#161#160#161#160#161#161#156#161
+ +#160#161#160#156#161#156#160#0#0#0#160#161#160#160#160#157#160'|'#157#160#157
+ +'x'#157#156#156#156'x'#156#156'x'#156'ytx'#153'x'#156'x'#152'x'#153'x'#156't'
+ +'x'#157'xy'#156'xy'#156'xx'#156'x'#157'x'#156'x'#157'x'#157#156'}'#157#161
+ +#156'y'#156#160#157#160'x'#160#157#156#156#156'y'#156#156#156'y'#156#156#157
+ +#156'y'#156'y'#157#156#153'xytyxtyuyxy'#157'y'#157'}'#156'y'#157#160#157#160
+ +#161#161#160#161#161#160#161#161#161#195#161#165#161#160#161#194#161#161#161
+ +#160#161#160#161#160#157#160#156#161#161#160#157#161#0#0#0#161#160#161#156'}'
+ +#160#160#157#160#156#160#156#160'x'#157'x'#157'x'#156#156'x'#156#156#156'x'
+ +#156'u'#156'xut'#156'u'#156'yt'#156'ty'#152'xyx'#157'yx'#156'y'#156'y'#156'x'
+ +#156'y'#156#156'x'#157#160#156'y'#156'y'#157#156'x'#157#157'x'#156#157'x'#157
+ +#156#156'y'#156'y'#156'y'#156'xyxytyxuuxytyxy'#156'y'#156#157#160#157#161#160
+ +#161#161#160#161#161#160#161#198#161#164#161#160#161#194#161#161#161#160#161
+ ,#160#195#160#161#156#161#160#161#161#160#156#161#160#156#0#0#0#160#160#160
+ +#161#160#160#157#160#157'|'#157#156'y'#156#156#156#156#156#157'x'#156#157'xt'
+ +#157't'#156'x'#152'x'#156'xtxt'#156'ty'#156'x'#157't'#156'tx'#156'yx'#157'x'
+ +#156'y'#157'x'#156'y'#157#156#156'y'#156#157#156#156'x'#157#156'x'#156#157'x'
+ +#157#156'xy'#156'yt'#156'ytytytyxutxytyyy'#156'y'#157'y'#160#161#157#160#161
+ +#161#160#161#161#160#161#161#161#161#161#160#165#161#161#160#161#160#161#160
+ +#161#160#161#160#161#160#161#156#160#156#161#160#156#161#0#0#0#161#156#161
+ +#160#161#156#160#156#160#156#156#160#156'y'#156'x'#157'x'#156'y'#156'x'#157
+ +#156'x'#156't'#157'x'#153'x'#153'x'#153'xu'#156'txuxyx'#157'ty'#156'x'#156'y'
+ +#157'x'#156#157'y'#156'x'#157'y'#156#157'x'#156'y'#157'x'#156'y'#157'x'#156
+ +'xy'#157#152'xy'#156'uxytytytuxyutyxyxyy'#156#156#157#157#160#161#161#160#161
+ +#161#160#161#199#160#165#160#165#161#194#161#160#195#160#161#160#195#160#161
+ +#160#157#160#157#194#161#160#161#156#161#160#156#0#0#0#160#161#160#156#160
+ +#161#156'}'#156#160'y'#156#160#156'y'#156#156#156'x'#156'x'#156'x'#152#157'x'
+ +#156't'#156'x'#152'x'#156't'#156'xt'#157'tx'#152'xuxy'#152'yux'#156'x'#157'x'
+ +'x'#156'y'#156'x'#156'yx'#157'x'#156#156'y'#156#156'x'#157'y'#156'xxy'#152'x'
+ +'uxuxuxutytuPytuyty'#156'y'#157'}'#156#161#157#160#161#160#161#160#195#160
+ +#161#161#160#161#194#161#160#161#160#161#160#195#160#160#161#194#161#160#160
+ +#161#160#156#161#156#160#156#161#160#0#0#0#160#160#161#160#161#156#160#156
+ +#160#157#160#156'y'#156#156#156'y'#156#157#156#157'x'#157'x'#156#156'y'#156
+ +'y'#152'y'#152'yx'#153'x'#157't'#156'uxu'#156't'#156'yx'#156'yxux'#157'xy'
+ +#156'y'#156'y'#156#157'x'#157'xy'#156'yx'#157'xx'#153'x'#153'xyutxtuxuxutyty'
+ +'tyytyyy'#156'x'#157#157#160#161#160#161#161#160#161#164#161#160#165#195#164
+ +#161#160#161#194#161#160#161#160#161#160#160#161#160#161#194#160#156#161#160
+ +#160#161#160#194#156#0#0#0#160#161#156#160#156'}'#156#160#157'|'#156#157#156
+ +#160#156'y'#156#156'x'#156'x'#156'x'#156'xu'#156't'#156'x'#156'xx'#152'xuxty'
+ +'t'#157'txuyt'#156'yt'#157'x'#157'xy'#156'y'#156'yx'#157'xy'#156'y'#156#157
+ +'x'#157'x'#156'uxytxttxuytutuPytytuUtyxx'#157'x'#157#161#160#161#160#161#161
+ +#160#161#161#161#161#198#161#160#161#160#195#160#161#160#194#161#160#195#156
+ +#161#160#156#160#161#156#161#160#157#160#156#161#156#161#0#0#0#160#160#160
+ +#161#160#160#161#156#160#157'x'#160'x'#157'x'#156#156'y'#156'y'#156#157#156
+ +'y'#156#156#156'y'#156'y'#156'u'#156'y'#156'x'#152'y'#156'txu'#156'xtxuxyxyx'
+ +#157'xy'#156'y'#156'yxy'#156'ytyxytxu'#156'ttyuuxuttuxuxututQytyxu'#157'x'
+ +#157#157#156#161#160#161#164#165#165#165#165#166#165#161#161#164#195#160#160
+ +#161#160#161#160#160#160#160#160#160#194#161#160#160#160#160#160#194#161#160
+ +#160#160#160#0#0#0#161#160#156#160#157#156#160'y'#160#156#161#156#160#156#160
+ +'y'#156#160#156#156'x'#156'x'#156'yx'#156'x'#157't'#156'x'#157'ty'#156'yty'
+ +#152'ytux'#153'yt'#157'tu'#156'ux'#157'xyty'#156'y'#156'y'#156'y'#156'u'#156
+ +'yuxyyttxtututtQtutyPyttytyxyxx'#161#160#161#165#165#165#199#169#203#170#171
+ +#170#165#165#161#160#161#160#160#195#160#161#194#161#160#161#160#160#160#194
+ +#161#160#157#160#156#160#157#194#157#160#0#0#0#160#157#160#161'|'#160#161#156
+ +#160#157#156'x'#157'x'#157#156#156'y'#156'y'#156#157'x'#157#156#156'y'#156'x'
+ +#157'x'#157't'#156'xu'#156'y'#156'xy'#156'xytxytxxuxyty'#156'y'#156'ytyxyxux'
+ +'yt'#156'uttytutxuxuuxutUtutyQtyuxy'#157#161#160#161#164#199#164#169#169#169
+ +#169#8#171#170#170#170#165#165#194#161#160#160#160#194#160#160#160#194#160
+ +#161#160#157#160#160#194#160#161#160#160#160#160#160#0#0#0#160#160#160#160
+ +#156#161'x'#160#157'|'#156#161#156#160#156#156'y'#156#156#156#156'x'#157#156
+ +'xy'#156'y'#156'y'#156'xy'#156'y'#156'x'#152'xu'#156't'#157't'#156'yt'#156'y'
+ +'uxy'#152'xuxyxy'#156'yx'#153'xy'#156'uxuxtytuxuututxtuxutyPutxuxy'#156'y'
+ +#160#161#165#165#169#169#169#169#169#174#8#174#8#8#171#170#166#165#160#194
+ +#160#161#160#161#160#161#160#161#160#160#160#160#156#161#160#160#160#161#156
+ +#161#156#0#0#0#161#160#157#160#161#156#161#156#160#157#160#156'y'#156'y'#160
+ +#156'x'#157'x'#157#156#156'y'#156#156'x'#157#156'x'#156#157#156'x'#157't'#157
+ +'x'#157'xxyxyt'#157'xux'#152'yty'#157'xu'#156'yyt'#157'xy'#156'uxytytytuxutx'
+ +'uxuuytuxutytyuxy'#156'y'#160#161#164#165#164#165#169#203#169#170#174#175#8
+ +#174#175#8#175#170#170#165#165#194#160#160#160#160#194#160#160#194#160#161
+ +#194#160#160#160#191#160#160#194#160#160#0#0#0#156#161#160'x'#160#160#156'}'
+ +#156#160'y'#160#156#160#156'y'#157#160'x'#157'x'#157'x'#156'y'#157#156'xy'
+ +#156'yx'#157'x'#156'yxux'#157'u'#156'u'#156'yt'#157'xyx'#153'xtyxxux'#156'yx'
+ +'uxyxy'#152'ytytytuxututxtuxutyutyttuxyx'#161#161#165#165#169#203#169#169#169
+ +#170#8#8#170#8#171#8#8#8#174#170#166#165#160#195#160#160#161#160#160#161#160
+ +#160#160#161#160#160#160#161#160#161#160#160#0#0#0#160#160#156#161#160#157
+ +#160#160#157#160#156#157'|'#157#156#160#156'x'#157#160#156'y'#156'y'#156'xy'
+ +#157#156'y'#156#157'x'#157'y'#156'y'#156#157't'#156'yx'#157'x'#157'xu'#156'u'
+ ,'xy'#157'xu'#157'xyuy'#156'y'#157't'#157'tyxytytytuxuxuuytutyttytuyxyx'#161
+ +#160#164#165#198#165#169#169#169#174#174#212#174#8#175#8#175#175#174#170#175
+ +#174#165#165#165#160#194#160#160#160#160#160#160#161#160#194#160#160#160#160
+ +#160#156#160#0#0#0#161#160#161#160#157'|'#156#157#156'|'#157#160#157#156'|'
+ +#157'x'#161#156#156'y'#156#156#157#156'y'#156#156'x'#157'xy'#156'y'#156'x'
+ +#156'yxyyx'#157'txux'#157'xyx'#157'tx'#157'xu'#156'x'#156'ytxyxyxutytytxytyt'
+ +'yxttyxuxyuxuxtyx'#161#161#165#165#165#169#169#169#173#170#8#174#8#8#175#8#8
+ +#8#170#8#8#170#174#170#170#166#165#161#194#160#195#160#160#160#160#160#161
+ +#194#160#156#194#161#160#0#0#0#160#157'|'#156#160#157#160#160#160#157#160#156
+ +'|'#157#156#160#157#156'}'#157#156#161'y'#160'y'#156#157'y'#157'x'#157#156'y'
+ +#156'y'#157'y'#156'y'#156'x'#157'xy'#157'x'#157'ty'#152'yx'#157'yt'#157'xyyu'
+ +#156'y'#157'ux'#153'x'#156'ytyxuuuxuytuyytuxutxuxuyx'#157#161#160#165#164#169
+ +#169#169#169#170#174#175#8#174#212#8#8#175#8#174#175#174#174#174#175#8#170
+ +#166#165#165#160#160#194#161#194#160#160#160#160#161#160#160#160#160#0#0#0
+ +#160#160#161#160#161#160#157'x'#161#156'}'#156#161#160'y'#156'}'#156#156'}'
+ +#156'x'#157'x'#157'yx'#156'y'#160'yx'#157'x'#156'x'#157'x'#157'y'#156'y'#156
+ +'xy'#156'y'#156'yx'#157'tx'#157'xy'#157'x'#156'yyxx'#157'xyuyxy'#152'yx'#156
+ +'t'#157'txyxtyxuxyuxuxtyxy'#160#165#165#165#203#169#169#169#170#8#8#170#175#8
+ +#175#8#175#174#8#8#174#170#8#8#174#174#174#171#166#165#161#160#160#160#161
+ +#194#160#160#160#160#160#160#160#0#0#0#160#157#160#157'|'#156#160#161#160#156
+ +#161#156'x'#157#160#157#156#157'}'#156#161'y'#160#157#160#156#157'y'#156'y'
+ +#156#157'x'#157'y'#157'x'#157'x'#156'y'#156'y'#157'xyxy'#156'yx'#157'yx'#157
+ +'xxy'#157'x'#157'y'#157'xy'#156'y'#156't'#157'yxuyyxyuxuytyxuxtytyuxy'#160
+ +#161#160#165#164#165#169#169#170#174#171#8#8#8#175#8#8#8#170#8#175#170#174#8
+ +#175#170#174#175#175#170#170#166#165#194#161#160#160#161#194#160#194#161#194
+ +#160#0#0#0#161#160#161#160#160#161#161#156#156'}'#156#156#161#160'y'#160#157
+ +'|'#156#161'y'#156#156'y'#156'y}'#156#157'x'#157'x'#157'y'#156'x'#157'y'#156
+ +'yy'#156'y'#156'y'#156'y'#156'yy'#156'yx'#157'xyy'#157'xyx'#157'xy'#157'yxyy'
+ +'yxt'#157'x'#152'yu'#156'xy'#152'yxuy'#152'yyxuxy'#156'y'#160#165#165#165#169
+ +#169#169#170#8#8#8#8#212#8#8#175#174#174#175#8#174#8#175#174#174#175#8#8#8
+ +#213#8#170#166#164#194#160#160#160#161#160#160#160#160#0#0#0#160#161'x'#160
+ +#157#160'x'#160#161#156#160'}'#156#157#160'y'#160#157'y'#157#156#161'}'#157
+ +'}'#157#156'}x'#157'y'#160'x'#156'y'#157'x'#156'y'#157'x'#157'xy'#156'y'#156
+ +'yx'#156'yy'#156'xy'#157#156'xy'#157#157'xy'#156'xx'#157'y'#156'x'#157'yxyy'
+ +#156'xy'#153'xyt'#157'xxyuxuxuxyx'#161#164#165#165#169#169#169#174#175#8#170
+ +#8#175#8#171#8#174#8#212#8#8#8#8#170#8#8#8#175#8#8#175#8#170#166#165#199#160
+ +#194#160#160#160#160#160#0#0#0#156#161#160#161#160#157#160#157'|'#157#156#161
+ +#160'y'#156#161'x'#160#157'|'#157'x'#157'x'#157'|'#157#157#161'x'#157'y'#157
+ +'y'#156'y'#157'x'#157'x'#157'x'#157'x'#157'yx'#157#157'y'#156'yy'#157'xyy'
+ +#157'xyx'#157'yy'#157'yx'#157'yyx'#157'y'#156'yy'#157'xy'#157'xyyu'#156'y'
+ +#156'yx'#157'xy'#156'y'#161#161#165#165#169#169#170#212#8#8#174#212#8#175#8#8
+ +#170#8#175#174#170#175#175#8#174#175#8#8#175#8#8#213#8#175#170#166#165#161
+ +#160#194#161#194#160#0#0#0#160#160#157#160'y'#160#161#160#157#160'}'#156'y'
+ +#161#160'y'#161#157'|'#157#160'y'#160#157'|'#157'x'#161'x'#161'x'#157'x'#161
+ +'y'#156'y'#157'x'#157'x'#157'x'#157'x'#156'yxyx'#157'x'#157'x'#157'x'#156'y'
+ +#157'x'#157'x'#157'x'#157'x'#157'x'#157'x'#157'xyy'#156'xyy'#156'xy'#156'x'
+ +#157'yxux'#153'xuxyx'#160#161#164#165#169#169#170#8#8#170#8#8#175#8#8#8#8#175
+ +#8#8#175#8#8#174#8#8#171#8#8#8#175#8#8#8#8#170#170#166#164#160#160#160#160#0
+ +#0#0#161'y'#160#161#160#161'x'#161#156#161#156#160#161#156'y'#160#157'|'#157
+ +#161'y'#161#157'}'#157'y'#161'x'#157'y'#157'|'#157'y'#156'y'#157'x'#157'y'
+ +#156'y'#157'x'#157'y'#157'y'#156#157'x'#157'x'#157'y'#157'y'#157'x'#157'y'
+ +#157'x'#157'y'#157'x'#157'y'#157'x'#157'y'#156'y'#157'y'#156'yy'#157'x'#157
+ +'yx'#157'x'#157'xyy'#156'y'#157'y'#161#165#165#169#170#8#212#170#174#212#175
+ +#8#170#175#174#175#8#8#170#8#8#170#8#175#175#8#175#8#171#8#8#8#213#8#175#175
+ +#170#166#166#165#194#160#0#0#0#160#160#160#157'|'#156#161'x'#161'|'#157'}'
+ +#157'|'#161#157'|'#157#160'y'#160'y'#160'y'#156#161'x'#161'x'#161'x'#157'|'
+ +#157'}'#156'x'#161'y'#156'y'#157'x'#157'x'#157'x'#156'yy'#157'y'#157'x'#157
+ +'x'#157'x'#157'x'#157'x'#157'x'#157'x'#157'x'#157'x'#157'x'#157'y'#156'y'#156
+ +'y'#156#157'x'#157'y'#156'y'#156'yyx'#157'xyyx'#157#160#165#165#169#170#8#8
+ +#174#170#8#8#8#8#8#212#8#8#8#174#175#8#8#8#8#8#8#8#175#8#8#175#8#8#8#8#8#174
+ +#212#170#166#165#161#0#0#0#157#160#157#160#157#160#157#160#156#161#160#156
+ +#161#157'|'#161'y'#161'y'#161'y'#161#157'}'#157'}'#157'y'#161'y'#161'y'#157
+ +'x'#157'y'#157'x'#157'y'#156'y'#157'x'#157'y'#157'y'#156'y'#156'y'#156'}'#157
+ +'y'#156'}'#157'y'#160'y'#157'y'#156'y'#157'y'#156'y'#157'y'#156'y'#157'x'#157
+ ,'yy'#156'yx'#157'y'#156'y'#156'y'#157'x'#157'x'#156'yx}'#161#165#166#170#212
+ +#174#170#8#175#171#8#8#8#8#175#8#170#8#8#174#174#8#212#8#175#8#8#175#8#8#175
+ +#8#175#175#170#174#175#8#171#170#166#0#0#0#160'y'#160'y'#160'y'#160'y'#161'x'
+ +#161'}'#156'}'#160#157#160'y'#160#157'|'#157'|'#157'|'#157'|'#157'|'#157'x'
+ +#161'|'#157'|'#161'x'#161'x'#160'y'#156'|'#157'|'#156'y'#160'y'#156'}'#156'y'
+ +#156'y'#160'y'#156'y'#156'y'#156'}'#156'y'#160'y'#156'}'#156'y'#156'y'#156'x'
+ +#157'x'#156#157'x'#157#157'x'#157'x'#157'y'#156'y'#157'x'#157'y'#156'y'#157
+ +'|'#165#170#8#8#170#174#8#8#8#8#8#175#8#8#170#174#8#8#170#8#175#8#175#8#8#175
+ +#8#175#8#8#8#8#8#174#8#8#175#8#175#8#0#0#0#156#161#156#161#156#161#156#161
+ +#156#161#157#160'y'#161#157'}'#157'}'#157'}'#157'}'#157'}'#157'}'#157'}'#157
+ +'y'#161'y'#157'y'#157'y'#157'y'#157'y'#157'y'#157'y'#157'y'#157'y'#157'y'#157
+ +'y'#157'y'#157'y'#157'y'#157'y'#157'y'#157'y'#157'y'#157'y'#157'y'#157'y'#157
+ +'y'#157'y'#157'y'#157'y'#157'x'#157'y'#157'y'#156'y'#157'x'#157'y'#156'y'#157
+ +'x'#157'}'#170#8#8#170#170#8#212#8#8#8#8#8#8#174#8#8#174#174#8#8#8#8#8#175#8
+ +#8#8#8#175#8#175#174#174#8#175#8#8#8#8#0#0#0#0#0#0#7'TButton'#8'OKButton'#4
+ +'Left'#3'<'#1#6'Height'#2#25#3'Top'#3#21#1#5'Width'#2'K'#6'Cancel'#9#7'Capti'
+ +'on'#6#2'OK'#7'OnClick'#7#13'OKButtonClick'#8'TabOrder'#2#1#0#0#0
+]);
diff --git a/components/flashfiler/sourcelaz/ffabout.pas b/components/flashfiler/sourcelaz/ffabout.pas
new file mode 100644
index 000000000..cc96666fd
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffabout.pas
@@ -0,0 +1,132 @@
+{*********************************************************}
+{* FlashFiler: About box *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffabout;
+
+interface
+
+uses
+ Windows,
+ Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
+ StdCtrls, ExtCtrls;
+
+type
+
+ { TFFAboutBox }
+
+ TFFAboutBox = class(TForm)
+ Bevel2: TBevel;
+ Panel1: TPanel;
+ Image1: TImage;
+ ProgramName: TLabel;
+ VersionNumber: TLabel;
+ Label3: TLabel;
+ lblTurboLink: TLabel;
+ Label9: TLabel;
+ Label10: TLabel;
+ Label11: TLabel;
+ Label12: TLabel;
+ OKButton: TButton;
+ Label4: TLabel;
+ lblNewsGeneral: TLabel;
+ procedure OKButtonClick(Sender: TObject);
+ procedure FormActivate(Sender: TObject);
+ procedure lblTurboLinkClick(Sender: TObject);
+ procedure lblTurboLinkMouseMove(Sender: TObject; Shift: TShiftState; X,
+ Y: Integer);
+ procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
+ Y: Integer);
+ procedure lblNewsGeneralClick(Sender: TObject);
+ private
+ { Private declarations }
+ public
+ { Public declarations }
+ IsServer : boolean;
+ end;
+
+var
+ FFAboutBox: TFFAboutBox;
+
+implementation
+
+{$R *.DFM}
+
+uses
+ ShellAPI, ffllbase;
+
+resourcestring
+ cBrowserError = 'Unable to start web browser. Make sure you have it properly setup on your system.';
+
+procedure TFFAboutBox.OKButtonClick(Sender : TObject);
+begin
+ Close;
+end;
+
+const
+ Domains : array [boolean] of string[6] = ('Client', 'Server');
+
+procedure TFFAboutBox.FormActivate(Sender: TObject);
+begin
+ VersionNumber.Caption := Format('%d-bit %s: Version %5.4f %s',
+ [
+ 32,
+ Domains[IsServer],
+ ffVersionNumber / 10000.0,
+ ffSpecialString
+ ]);
+end;
+
+procedure TFFAboutBox.lblTurboLinkClick(Sender: TObject);
+begin
+ ShellToWWW;
+end;
+
+procedure TFFAboutBox.lblTurboLinkMouseMove(Sender: TObject;
+ Shift: TShiftState; X, Y: Integer);
+begin
+ TLabel(Sender).Font.Style := [fsUnderline];
+end;
+
+procedure TFFAboutBox.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
+ Y: Integer);
+begin
+ lblTurboLink.Font.Style := [];
+ lblNewsGeneral.Font.Style := [];
+end;
+
+procedure TFFAboutBox.lblNewsGeneralClick(Sender: TObject);
+begin
+ if ShellExecute(0, 'open', 'http://sourceforge.net/forum/?group_id=72211', '',
+ '', SW_SHOWNORMAL) <= 32 then
+ ShowMessage(cBrowserError);
+end;
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffclbase.pas b/components/flashfiler/sourcelaz/ffclbase.pas
new file mode 100644
index 000000000..6a38f862d
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffclbase.pas
@@ -0,0 +1,78 @@
+{*********************************************************}
+{* FlashFiler: Client base unit *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+
+{$I ffdefine.inc}
+
+unit ffclbase;
+
+interface
+
+uses
+ ffsrbde,
+ ffllexcp,
+ ffllbase,
+ ffllprot,
+ ffsrmgr;
+
+{$R ffclcnst.res}
+
+{$I ffclcfg.inc}
+
+var
+ ffStrResClient : TffStringResource;
+
+function GetErrorStringPrim(aResult : TffResult; aStrZ : PChar) : TffResult;
+
+implementation
+
+function GetErrorStringPrim(aResult : TffResult; aStrZ : PChar) : TffResult;
+begin
+ ffStrResBDE.GetASCIIZ(aResult, aStrZ, sizeof(DBIMSG));
+ Result := DBIERR_NONE;
+end;
+
+procedure InitializeUnit;
+begin
+ ffStrResClient := nil;
+ ffStrResClient := TffStringResource.Create(hInstance, 'FF_CLIENT_STRINGS');
+end;
+
+procedure FinalizeUnit;
+begin
+ ffStrResClient.Free;
+end;
+
+initialization
+ InitializeUnit;
+
+finalization
+ FinalizeUnit;
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffclbde.pas b/components/flashfiler/sourcelaz/ffclbde.pas
new file mode 100644
index 000000000..178e6719d
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffclbde.pas
@@ -0,0 +1,287 @@
+{*********************************************************}
+{* FlashFiler: BDE consts and types for client *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+
+{Note: The following definitions are copied from BDE.PAS. The client
+ cannot have BDE in its uses list since that unit has an
+ initialization section which, when run, would pull in far too
+ much for the FF client. This also removes any requirements for
+ the BDE package when using runtime packages}
+
+{BDE.PAS source file and error codes are
+ (c) Copyright Borland International Inc, 1997}
+
+{$I ffdefine.inc}
+
+{$Z+}
+
+unit ffclbde;
+
+interface
+
+uses
+ Windows,
+ SysUtils,
+ Classes,
+ ffsrbde,
+ ffconst,
+ ffllbase;
+
+{-----------------------------------------------------------------------}
+{ DBI types }
+{-----------------------------------------------------------------------}
+const
+{ Constants }
+
+ DBIMAXNAMELEN = 31; { Name limit (table, field etc) }
+ DBIMAXTBLNAMELEN = 260; { Max table name length }
+ DBIMAXFLDSINKEY = 16; { Max fields in a key }
+ DBIMAXKEYEXPLEN = 220; { Max Key expression length }
+ DBIMAXVCHKLEN = 255; { Max val check len }
+ DBIMAXPICTLEN = 175; { Max picture len }
+ DBIMAXPATHLEN = 260; { Max path+file name len (excluding zero termination) }
+
+{============================================================================}
+{ G e n e r a l }
+{============================================================================}
+
+type
+ TIME = Longint;
+
+
+{ Handle Types }
+type
+ _hDBIObj = record end; { Dummy structure to create "typed" handles }
+ hDBIFilter = ^_hDBIObj; { Filter handle }
+
+
+{ typedefs for buffers of various common sizes: }
+ DBINAME = packed array [0..DBIMAXNAMELEN] of Char; { holds a name }
+ DBITBLNAME = packed array [0..DBIMAXTBLNAMELEN] of Char; { holds a table name }
+ DBIKEY = packed array [0..DBIMAXFLDSINKEY-1] of Word; { holds list of fields in a key }
+ DBIKEYEXP = packed array [0..DBIMAXKEYEXPLEN] of Char; { holds a key expression }
+ DBIVCHK = packed array [0..DBIMAXVCHKLEN] of Byte; { holds a validity check }
+ DBIPICT = packed array [0..DBIMAXPICTLEN] of Char; { holds a picture (Pdox) }
+ DBIPATH = packed array [0..DBIMAXPATHLEN] of Char; { holds a DOS path }
+
+{============================================================================}
+{ Cursor properties }
+{============================================================================}
+type
+ DBIShareMode = ( { Database/Table Share type }
+ dbiOPENSHARED, { Open shared (Default) }
+ dbiOPENEXCL { Open exclusive }
+ );
+
+ DBIOpenMode = ( { Database/Table Access type }
+ dbiREADWRITE, { Read + Write (Default) }
+ dbiREADONLY { Read only }
+ );
+
+ FFXLTMode = ( { Field translate mode }
+ xltNONE, { No translation (Physical Types) }
+ xltRECORD, { Record level translation (not supported) }
+ xltFIELD { Field level translation (Logical types) }
+ );
+
+{ Linear exression tree}
+{----------------------}
+type
+ pFILTERInfo = ^FILTERInfo;
+ FILTERInfo = packed record
+ iFilterId : Word; { Id for filter }
+ hFilter : hDBIFilter; { Filter handle }
+ iClientData : Longint; { Client supplied data }
+ iPriority : Word; { 1..N with 1 being highest }
+ bCanAbort : WordBool; { TRUE : pfFilter can return ABORT }
+ pfFilter : pfGENFilter; { Client filter function }
+ pCanExpr : Pointer; { Supplied expression }
+ bActive : WordBool; { TRUE : filter is active }
+ end;
+
+{pfGENFilter returns TRUE, FALSE or ABORT }
+const
+ ABORT = -2;
+
+
+{============================================================================}
+{ Field descriptor }
+{============================================================================}
+type
+ FLDVchk = ( { Field Val Check type }
+ fldvNOCHECKS, { Does not have explicit val checks }
+ fldvHASCHECKS, { One or more val checks on the field }
+ fldvUNKNOWN { Dont know at this time }
+ );
+
+type
+ FLDRights = ( { Field Rights }
+ fldrREADWRITE, { Field can be Read/Written }
+ fldrREADONLY, { Field is Read only }
+ fldrNONE, { No Rights on this field }
+ fldrUNKNOWN { Dont know at this time }
+ );
+
+type
+ pFLDDesc = ^FLDDesc;
+ FLDDesc = packed record { Field Descriptor }
+ iFldNum : Word; { Field number (1..n) }
+ szName : DBINAME; { Field name }
+ iFldType : Word; { Field type }
+ iSubType : Word; { Field subtype (if applicable) }
+ iUnits1 : SmallInt; { Number of Chars, digits etc }
+ iUnits2 : SmallInt; { Decimal places etc. }
+ iOffset : Word; { Offset in the record (computed) }
+ iLen : Word; { Length in bytes (computed) }
+ iNullOffset : Word; { For Null bits (computed) }
+ efldvVchk : FLDVchk; { Field Has vcheck (computed) }
+ efldrRights : FLDRights; { Field Rights (computed) }
+ bCalcField : WordBool; { Is Calculated field (computed) }
+ iUnUsed : packed array [0..1] of Word;
+ end;
+
+{============================================================================}
+{ Record Properties }
+{============================================================================}
+
+type
+ pRECProps = ^RECProps;
+ RECProps = packed record { Record properties }
+ iSeqNum : Longint; { When Seq# supported only }
+ iPhyRecNum : Longint; { When Phy Rec#s supported only }
+ iRecStatus : Word; { Delayed Updates Record Status }
+ bSeqNumChanged : WordBool; { Not used }
+ bDeleteFlag : WordBool; { When soft delete supported only }
+ end;
+
+{============================================================================}
+{ Index descriptor }
+{============================================================================}
+
+type
+ pIDXDesc = ^IDXDesc;
+ IDXDesc = packed record { Index description }
+ szName : DBITBLNAME; { Index name }
+ iIndexId : Word; { Index number }
+ szTagName : DBINAME; { Tag name (for dBASE) }
+ szFormat : DBINAME; { Optional format (BTREE, HASH etc) }
+ bPrimary : WordBool; { True, if primary index }
+ bUnique : WordBool; { True, if unique keys (TRI-STATE for dBASE) }
+ bDescending : WordBool; { True, for descending index }
+ bMaintained : WordBool; { True, if maintained index }
+ bSubset : WordBool; { True, if subset index }
+ bExpIdx : WordBool; { True, if expression index }
+ iCost : Word; { Not used }
+ iFldsInKey : Word; { Fields in the key (1 for Exp) }
+ iKeyLen : Word; { Phy Key length in bytes (Key only) }
+ bOutofDate : WordBool; { True, if index out of date }
+ iKeyExpType : Word; { Key type of Expression }
+ aiKeyFld : DBIKEY; { Array of field numbers in key }
+ szKeyExp : DBIKEYEXP; { Key expression }
+ szKeyCond : DBIKEYEXP; { Subset condition }
+ bCaseInsensitive : WordBool; { True, if case insensitive index }
+ iBlockSize : Word; { Block size in bytes }
+ iRestrNum : Word; { Restructure number }
+ abDescending : packed array [0..DBIMAXFLDSINKEY-1] of WordBool; { TRUE }
+ iUnUsed : packed array [0..15] of Word;
+ end;
+
+{============================================================================}
+{ Validity check, Referential integrity descriptors }
+{============================================================================}
+
+{ Subtypes for Lookup }
+
+ LKUPType = ( { Paradox Lookup type }
+ lkupNONE, { Has no lookup }
+ lkupPRIVATE, { Just Current Field + Private }
+ lkupALLCORRESP, { All Corresponding + No Help }
+ lkupHELP, { Just Current Fld + Help and Fill }
+ lkupALLCORRESPHELP { All Corresponging + Help }
+ );
+
+type
+ pVCHKDesc = ^VCHKDesc;
+ VCHKDesc = packed record { Val Check structure }
+ iFldNum : Word; { Field number }
+ bRequired : WordBool; { If True, value is required }
+ bHasMinVal : WordBool; { If True, has min value }
+ bHasMaxVal : WordBool; { If True, has max value }
+ bHasDefVal : WordBool; { If True, has default value }
+ aMinVal : DBIVCHK; { Min Value }
+ aMaxVal : DBIVCHK; { Max Value }
+ aDefVal : DBIVCHK; { Default value }
+ szPict : DBIPICT; { Picture string }
+ elkupType : LKUPType; { Lookup/Fill type }
+ szLkupTblName : DBIPATH; { Lookup Table name }
+ end;
+
+{============================================================================}
+{ Key searches }
+{============================================================================}
+
+type
+ DBISearchCond = ( { Search condition for keys }
+ keySEARCHEQ, { = }
+ keySEARCHGT, { > }
+ keySEARCHGEQ { >= }
+ );
+
+{============================================================================}
+{ Date, Time, Number Formats }
+{============================================================================}
+
+type
+ pFMTBcd = ^FMTBcd;
+ FMTBcd = packed record
+ iPrecision : Byte; { 1..64 considered valid }
+ iSignSpecialPlaces : Byte; { sign:1, special:1, places:6 }
+ iFraction : packed array [0..31] of Byte; { bcd nibbles, 00..99 per byte, high nibble 1st }
+ end;
+
+{============================================================================}
+{ Security descriptor }
+{============================================================================}
+const
+ prvUNKNOWN = $FF; { Unknown }
+
+{============================================================================}
+{ Error Categories }
+{============================================================================}
+function ErrCat(rslt: Word): Word;
+
+implementation
+
+function ErrCat(rslt: Word): Word;
+begin
+ ErrCat := rslt shr 8;
+end;
+
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffclcfg.inc b/components/flashfiler/sourcelaz/ffclcfg.inc
new file mode 100644
index 000000000..b352a49fd
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffclcfg.inc
@@ -0,0 +1,57 @@
+{*********************************************************}
+{* FlashFiler: Client configuration include file *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+
+const
+
+{ Client's retry timeout affects the amount of time that the server should
+ spend attempting to process a message which is blocked by an active
+ transaction or lock. This value is passed to the server in the message
+ header. *** Not yet used ***}
+ ffclRetryTimeout : longint = 10000;
+
+{ to specify the server name to connect to}
+ ffclServerName : TffNetAddress = '';
+
+{ to programmatically specify username and password, change these from blank}
+ ffclUsername : TffName = '';
+ ffclPassword : TffName = '';
+
+{ number of allowable client login retries}
+ ffclLoginRetries : Byte = 3;
+
+{ To select a default protocol for all apps. This protocol is used for any
+ Client Session.}
+
+ { valid choices: TffTCPIPProtocol,
+ TffNetBIOSProtocol,
+ TffIPXSPXProtocol,
+ TffSingleUserProtocol
+ TffDirectProtocol}
+ ffclProtocol : TffCommsProtocolClass = TffSingleUserProtocol;
diff --git a/components/flashfiler/sourcelaz/ffclcfg.pas b/components/flashfiler/sourcelaz/ffclcfg.pas
new file mode 100644
index 000000000..b4106ca70
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffclcfg.pas
@@ -0,0 +1,338 @@
+{*********************************************************}
+{* FlashFiler: Client network configuration definition *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+
+{NOTES:
+
+ This unit is the client API for the client network configuration for
+ FlashFiler. The default protocol and optional fixed servername to
+ connect to are stored in the registry or in a Windows INI file and all
+ FlashFiler clients share this default information.
+
+ If the protocol is missing in the client configuration (or no client
+ configuration setup) or is invalid, then the value in ffclProtocol
+ (FFCLCFG.INC) at compile-time is used. Likewise, if no value is
+ found for servername in the client configuration, then the value in
+ ffclServerName (FFCLCFG.INC) at compile-time is used.
+
+ In this manner, all apps will continue to work as before until when
+ and if the persistent client info is established on the workstation.
+}
+
+{$I ffdefine.inc}
+
+unit ffclcfg;
+
+interface
+
+uses
+ Windows,
+ {$IFDEF UseRegistryConfig}
+ Registry,
+ {$ENDIF}
+ {$IFDEF UseINIConfig}
+ INIFiles,
+ {$ENDIF}
+ SysUtils,
+ Classes,
+ ffconst,
+ ffclbase,
+ ffllbase,
+ ffllprot;
+
+function FFClientConfigGetProtocolName(aProtocol : TffCommsProtocolClass
+ ) : TffShStr;
+{- Returns the name for the given protocol }
+
+procedure FFClientConfigGetProtocolNames(aNames : TStrings);
+{- Returns a list of protocol names valid for this platform (16-bit or 32-bit)}
+
+procedure FFClientConfigOverrideProtocol(aProtocol : TffCommsProtocolClass);
+{- Overrides the protocol defined in the client configuration info for this
+ machine. Sessions created by this app will use the override protocol until
+ the override is turned off by passing in a nil parameter. }
+
+procedure FFClientConfigOverrideServerName(const aServerName : TffNetAddress);
+{- Overrides the servername defined in the client configuration info for this
+ machine. Sessions created by this app will use the override servername
+ until the override is turned off by passing in a '' parameter. }
+
+procedure FFClientConfigReadProtocol(var aProtocol : TffCommsProtocolClass;
+ var aProtocolName : TffShStr);
+{- Returns the protocol name and class defined in the client configuration
+ for this machine}
+
+function FFClientConfigReadProtocolClass : TffCommsProtocolClass;
+{- Returns the protocol class defined in the client configuration for this
+ machine}
+
+function FFClientConfigReadServerName : TffNetAddress;
+{- Returns the fixed servername defined in the client configuration for this
+ machine}
+
+procedure FFClientConfigWriteProtocolName(aProtocolName : TffShStr);
+{- Saves the protocol by name in the client configuration for this machine }
+
+procedure FFClientConfigWriteProtocolClass(aProtocol : TffCommsProtocolClass);
+{- Saves the protocol by class in the client configuration for this machine }
+
+procedure FFClientConfigWriteServerName(aServerName : TffNetAddress);
+{- Saves the fixed servername in the client configuration for this machine }
+
+const
+ ffc_SingleUser = 'Single User';
+ ffc_TCPIP = 'TCP/IP';
+ ffc_IPXSPX = 'IPX/SPX';
+
+implementation
+
+const
+ {$IFDEF UseRegistryConfig}
+ cfgRootKey = HKEY_LOCAL_MACHINE;
+ cfgRegistryKey = '\Client Configuration';
+ {$ENDIF}
+
+ {$IFDEF UseINIConfig}
+ cfgSection = 'Client Configuration';
+ {$ENDIF}
+
+ cfgServerName = 'ServerName';
+ cfgProtocol = 'Protocol';
+
+var
+ OverrideProtocol : TffCommsProtocolClass;
+ OverrideServerName : TffNetAddress;
+
+
+function FFClientConfigGetProtocolName(aProtocol : TffCommsProtocolClass
+ ): TffShStr;
+begin
+ if aProtocol = TffSingleUserProtocol then
+ Result := ffc_SingleUser
+ else
+ if aProtocol = TffTCPIPProtocol then
+ Result := ffc_TCPIP
+ else
+ if aProtocol = TffIPXSPXProtocol then
+ Result := ffc_IPXSPX
+ else
+ Result := '';
+end;
+
+{$IFDEF UseRegistryConfig}
+function GetRegistryKey : TffShStr;
+begin
+ Result := ffStrResClient[ffccREG_PRODUCT] + cfgRegistryKey;
+end;
+{$ENDIF}
+
+{$IFDEF UseINIConfig}
+function GetINIFilename : TffShStr;
+begin
+ Result := 'FF2.INI';
+end;
+{$ENDIF}
+
+procedure FFClientConfigGetProtocolNames(aNames : TStrings);
+begin
+ Assert(Assigned(aNames));
+ aNames.BeginUpdate;
+ try
+ aNames.Clear;
+ aNames.Add(ffc_SingleUser);
+ aNames.Add(ffc_TCPIP);
+ aNames.Add(ffc_IPXSPX);
+ finally
+ aNames.EndUpdate;
+ end;
+end;
+
+procedure FFClientConfigOverrideProtocol(aProtocol : TffCommsProtocolClass);
+begin
+ OverrideProtocol := aProtocol;
+end;
+
+procedure FFClientConfigOverrideServerName(const aServerName : TffNetAddress);
+begin
+ OverrideServerName := aServerName;
+end;
+
+procedure FFClientConfigReadProtocol(var aProtocol : TffCommsProtocolClass;
+ var aProtocolName : TffShStr);
+begin
+ aProtocol := nil;
+ aProtocolName := '';
+
+ if Assigned(OverrideProtocol) then begin
+ aProtocol := OverrideProtocol;
+ aProtocolName := FFClientConfigGetProtocolName(aProtocol);
+ Exit;
+ end;
+
+ {$IFDEF UseRegistryConfig}
+ with TRegistry.Create do
+ try
+ RootKey := cfgRootKey;
+ {$IFDEF DCC4OrLater}
+ OpenKeyReadOnly(GetRegistryKey);
+ {$ELSE}
+ OpenKey(GetRegistryKey, True);
+ {$ENDIF}
+ if ValueExists(cfgProtocol) then
+ aProtocolName := ReadString(cfgProtocol);
+ finally
+ Free;
+ end;
+ {$ENDIF}
+ {$IFDEF UseINIConfig}
+ with TINIFile.Create(GetINIFilename) do
+ try
+ aProtocolName := ReadString(cfgSection, cfgProtocol, '');
+ finally
+ Free;
+ end;
+ {$ENDIF}
+ if FFCmpShStrUC(aProtocolName, ffc_TCPIP, 255) = 0 then
+ aProtocol := TffTCPIPProtocol
+ else
+ if FFCmpShStrUC(aProtocolName, ffc_IPXSPX, 255) = 0 then
+ aProtocol := TffIPXSPXProtocol
+ else
+ if FFCmpShStrUC(aProtocolName, ffc_SingleUser, 255) = 0 then
+ aProtocol := TffSingleUserProtocol
+ else begin { use compiled default protocol }
+ aProtocol := ffclProtocol;
+ aProtocolName := FFClientConfigGetProtocolName(aProtocol);
+ if aProtocolName = '' then
+ aProtocol := nil;
+ end;
+end;
+
+function FFClientConfigReadProtocolClass : TffCommsProtocolClass;
+var
+ ProtocolName : TffShStr;
+begin
+ FFClientConfigReadProtocol(Result, ProtocolName);
+end;
+
+function FFClientConfigReadServerName : TffNetAddress;
+begin
+ Result := ''; {!!.01}
+ if OverrideServerName <> '' then begin
+ Result := OverrideServerName;
+ Exit;
+ end;
+
+ {$IFDEF UseRegistryConfig}
+ Result := '';
+ with TRegistry.Create do
+ try
+ RootKey := cfgRootKey;
+ {$IFDEF DCC4OrLater}
+ OpenKeyReadOnly(GetRegistryKey);
+ {$ELSE}
+ OpenKey(GetRegistryKey, True);
+ {$ENDIF}
+ if ValueExists(cfgServerName) then
+ Result := ReadString(cfgServerName);
+ finally
+ Free;
+ end;
+ {$ENDIF}
+
+ {$IFDEF UseINIConfig}
+ with TINIFile.Create(GetINIFilename) do
+ try
+ Result := ReadString(cfgSection, cfgServerName, '');
+ finally
+ Free;
+ end;
+ {$ENDIF}
+
+ { if no name given, use compiled default name }
+ if Result = '' then
+ Result := ffclServerName;
+end;
+
+procedure FFClientConfigWriteProtocolName(aProtocolName : TffShStr);
+begin
+ {$IFDEF UseRegistryConfig}
+ with TRegistry.Create do
+ try
+ RootKey := cfgRootKey;
+ OpenKey(GetRegistryKey, True);
+ WriteString(cfgProtocol, aProtocolName);
+ finally
+ Free;
+ end;
+ {$ENDIF}
+
+ {$IFDEF UseINIConfig}
+ with TINIFile.Create(GetINIFilename) do
+ try
+ WriteString(cfgSection, cfgProtocol, aProtocolName);
+ finally
+ Free;
+ end;
+ {$ENDIF}
+end;
+
+procedure FFClientConfigWriteProtocolClass(aProtocol : TffCommsProtocolClass);
+begin
+ FFClientConfigWriteProtocolName(FFClientConfigGetProtocolName(aProtocol));
+end;
+
+procedure FFClientConfigWriteServerName(aServerName : TffNetAddress);
+begin
+ {$IFDEF UseRegistryConfig}
+ with TRegistry.Create do
+ try
+ RootKey := cfgRootKey;
+ OpenKey(GetRegistryKey, True);
+ WriteString(cfgServerName, aServerName);
+ finally
+ Free;
+ end;
+ {$ENDIF}
+
+ {$IFDEF UseINIConfig}
+ with TINIFile.Create(GetINIFilename) do
+ try
+ WriteString(cfgSection, cfgServerName, aServerName);
+ finally
+ Free;
+ end;
+ {$ENDIF}
+end;
+
+initialization
+ OverrideProtocol := nil;
+ OverrideServerName := '';
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffclcnst.rc b/components/flashfiler/sourcelaz/ffclcnst.rc
new file mode 100644
index 000000000..cf029b211
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffclcnst.rc
@@ -0,0 +1,31 @@
+/*********************************************************
+ * FlashFiler: Client string table resource *
+ *********************************************************/
+
+/* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** */
+
+FF_CLIENT_STRINGS RCDATA FFCLCNST.SRM
+
diff --git a/components/flashfiler/sourcelaz/ffclcnst.res b/components/flashfiler/sourcelaz/ffclcnst.res
new file mode 100644
index 000000000..82fdb94a2
Binary files /dev/null and b/components/flashfiler/sourcelaz/ffclcnst.res differ
diff --git a/components/flashfiler/sourcelaz/ffclcnst.srm b/components/flashfiler/sourcelaz/ffclcnst.srm
new file mode 100644
index 000000000..11ffc6a78
Binary files /dev/null and b/components/flashfiler/sourcelaz/ffclcnst.srm differ
diff --git a/components/flashfiler/sourcelaz/ffclcnst.str b/components/flashfiler/sourcelaz/ffclcnst.str
new file mode 100644
index 000000000..e23f6f4e4
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffclcnst.str
@@ -0,0 +1,56 @@
+;*********************************************************
+;* FlashFiler: Client string table resource *
+;*********************************************************
+
+;* ***** BEGIN LICENSE BLOCK *****
+;* Version: MPL 1.1
+;*
+;* The contents of this file are subject to the Mozilla Public License Version
+;* 1.1 (the "License"); you may not use this file except in compliance with
+;* the License. You may obtain a copy of the License at
+;* http://www.mozilla.org/MPL/
+;*
+;* Software distributed under the License is distributed on an "AS IS" basis,
+;* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+;* for the specific language governing rights and limitations under the
+;* License.
+;*
+;* The Original Code is TurboPower FlashFiler
+;*
+;* The Initial Developer of the Original Code is
+;* TurboPower Software
+;*
+;* Portions created by the Initial Developer are Copyright (C) 1996-2002
+;* the Initial Developer. All Rights Reserved.
+;*
+;* Contributor(s):
+;*
+;* ***** END LICENSE BLOCK *****
+
+#include "ffconst.inc"
+
+ffccDupItemInColl, "Duplicate item in collection"
+ffccInvalidParameter, "Invalid Parameter"
+ffccREG_PRODUCT, "\Software\TurboPower\FlashFiler\2.0"
+
+ffccImport_NoSchemaFile, "Schema file %s not found"
+ffccImport_RECLENGTHRequired, "RECLENGTH required in schema file for this import filetype"
+ffccImport_NoMatchingFields, "No import fields match any target table fields; nothing to import"
+ffccImport_FILETYPEMissing, "FILETYPE missing in schema file"
+ffccImport_FILETYPEInvalid, "Invalid FILETYPE in schema file"
+ffccImport_BadFieldName, "Error in schema file: %s has invalid fieldname %s"
+ffccImport_BadFieldType, "Error in schema file: %s has invalid datatype %s"
+ffccImport_BadFloatSize, "Error in schema file: %s has invalid field size for FLOAT"
+ffccImport_BadIntegerSize, "Error in schema file: %s has invalid field size for INTEGER"
+ffccImport_BadUIntegerSize, "Error in schema file: %s has invalid field size for UINTEGER"
+ffccImport_BadAutoIncSize, "Error in schema file: %s has invalid field size for AUTOINC"
+ffccImport_NoFields, "No fields defined in schema file"
+ffccImport_BadOffset, "Error in schema file: %s has invalid field offset %s"
+ffccImport_BadSize, "Error in schema file: %s has invalid field size %s"
+ffccImport_BadDecPl, "Error in schema file: %s has invalid field decimal places %s"
+ffccImport_BadDateMask, "Error in schema file: %s has invalid field date/time picture mask %s"
+ffccImport_BadSchemaHeader, "Invalid section header in schema file: %s"
+
+ffccDesign_SLinkMasterSource, "The MasterSource property of ''%s'' must be linked to a DataSource"
+ffccDesign_SLinkMaster, "Unable to open the MasterSource Table"
+ffccDesign_SLinkDesigner, "Field ''%s'', from the Detail Fields list, must be linked"
diff --git a/components/flashfiler/sourcelaz/ffclcoln.dfm b/components/flashfiler/sourcelaz/ffclcoln.dfm
new file mode 100644
index 000000000..13b4d8aa7
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffclcoln.dfm
@@ -0,0 +1,30 @@
+object ffParamEditor: TffParamEditor
+ Left = 191
+ Top = 105
+ Width = 159
+ Height = 160
+ BorderIcons = [biSystemMenu]
+ Caption = 'Param Editor'
+ Color = clBtnFace
+ Font.Color = clWindowText
+ Font.Height = -11
+ Font.Name = 'MS Sans Serif'
+ Font.Style = []
+ OnClose = FormClose
+ OnCreate = FormCreate
+ OnDestroy = FormDestroy
+ OnShow = FormShow
+ PixelsPerInch = 96
+ TextHeight = 13
+ object lbItems: TListBox
+ Left = 0
+ Top = 0
+ Width = 151
+ Height = 133
+ Align = alClient
+ ItemHeight = 13
+ MultiSelect = True
+ TabOrder = 0
+ OnClick = lbItemsClick
+ end
+end
diff --git a/components/flashfiler/sourcelaz/ffclcoln.pas b/components/flashfiler/sourcelaz/ffclcoln.pas
new file mode 100644
index 000000000..f398628b9
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffclcoln.pas
@@ -0,0 +1,346 @@
+{*********************************************************}
+{* FlashFiler: Collection property editor *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffclcoln;
+
+interface
+
+uses
+ DB,
+ {$IFNDEF DCC4OrLater}
+ DBTables,
+ {$ENDIF}
+ Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
+ {$IFDEF DCC6OrLater}
+ {$ifndef fpc}DesignIntf,{$endif}
+ {$ELSE}
+ DsgnIntf,
+ {$ENDIF}
+ StdCtrls;
+
+type
+ {$ifdef fpc} //soner they have other names:
+ IDesigner = TIDesigner;
+ IDesignerSelections = TComponent; //IDesignerSelections dont exist on laz
+ TDesignerSelections = TComponent;
+ {$endif}
+
+ TffParamEditor = class(TForm)
+ lbItems: TListBox;
+ procedure FormCreate(Sender: TObject);
+ procedure FormDestroy(Sender: TObject);
+ procedure FormShow(Sender: TObject);
+ procedure FormClose(Sender: TObject; var Action: TCloseAction);
+ procedure lbItemsClick(Sender: TObject);
+ private
+ { Private declarations }
+ FParams : TParams;
+ { The collection being edited. }
+ FComponent : TComponent;
+ { The component with which this editor is associated. }
+
+ {$IFDEF DCC4OrLater}
+ FDesigner : IDesigner;
+ {$ELSE}
+ FDesigner : TDesigner;
+ {$ENDIF}
+
+ FPropName : string;
+ { The property with which this editor is associated. }
+
+ function GetParams : longInt;
+ procedure SetParams(anOrdValue : longInt);
+
+ protected
+
+ procedure FillList; virtual;
+
+
+ {$IFDEF DCC6OrLater}
+ procedure SelectComponentList(SelList : IDesignerSelections);
+ {$ELSE}
+ {$IFDEF DCC5OrLater}
+ procedure SelectComponentList(SelList : TDesignerSelectionList);
+ {$ELSE}
+ procedure SelectComponentList(SelList : TComponentList);
+ {$ENDIF}
+ {$ENDIF}
+ procedure SelectComponent(Component : TComponent);
+
+ public
+ { Public declarations }
+
+ property Collection : longInt read GetParams write SetParams;
+ {$IFDEF DCC4OrLater}
+ property CompDesigner : IDesigner read FDesigner write FDesigner;
+ {$ELSE}
+ property CompDesigner : TDesigner read FDesigner write FDesigner;
+ {$ENDIF}
+ property Component : TComponent read FComponent write FComponent;
+ property PropertyName : string read FPropName write FPropName;
+ end;
+
+{$IFDEF DCC4OrLater}
+ procedure FFShowParamEditor(aDesigner : IDesigner;
+ aComponent : TComponent;
+ aPropertyName : string;
+ aCollection : longInt);
+{$ELSE}
+ procedure FFShowParamEditor(aDesigner : TDesigner;
+ aComponent : TComponent;
+ aPropertyName : string;
+ aCollection : longInt);
+{$ENDIF}
+
+var
+ ffParamEditor: TffParamEditor;
+
+implementation
+
+{$R *.DFM}
+
+const
+ ffcEditing = 'Editing %s.%s';
+
+var
+ FFParamsEditors : TList = nil;
+ { The list of active collection editors. We need to track the active
+ collection editors because the user may go back to the Object Inspector
+ and click the property again. In that case, we want to bring up the
+ existing collection editor instead of creating a new collection editor. }
+
+{===Utility routines=================================================}
+{$IFDEF DCC4OrLater}
+procedure FFShowParamEditor(aDesigner : IDesigner;
+ aComponent : TComponent;
+ aPropertyName : string;
+ aCollection : longInt);
+{$ELSE}
+procedure FFShowParamEditor(aDesigner : TDesigner;
+ aComponent : TComponent;
+ aPropertyName : string;
+ aCollection : longInt);
+{$ENDIF}
+var
+ anEditor : TffParamEditor;
+ Index : integer;
+begin
+ { Are there any existing collection editors? }
+ if assigned(FFParamsEditors) then
+ { Yes. See if an editor was already created for this property. }
+ for Index := 0 to pred(FFParamsEditors.Count) do begin
+ anEditor := TffParamEditor(FFParamsEditors.Items[Index]);
+ with anEditor do begin
+ if (CompDesigner = aDesigner) and
+ (Component = aComponent) and
+ (Collection = aCollection) and
+ (CompareText(PropertyName, aPropertyName) = 0) then begin
+ anEditor.Show;
+ anEditor.BringToFront;
+ Exit;
+ end;
+ end;
+ end
+ else
+ FFParamsEditors := TList.Create;
+
+ { If we have reached this point, there is no collection editor for this
+ collection. Create a new collection editor. }
+ with TffParamEditor.Create(Application) do
+ try
+ Collection := aCollection;
+ Component := aComponent;
+ CompDesigner := aDesigner;
+ PropertyName := aPropertyName;
+ Show;
+ except
+ Free;
+ end;
+
+end;
+{====================================================================}
+
+{===TffParamEditor==============================================}
+procedure TffParamEditor.FormCreate(Sender: TObject);
+begin
+ FParams := nil;
+ FComponent := nil;
+ FDesigner := nil;
+ FPropName := '';
+ FFParamsEditors.Add(Self);
+end;
+{--------}
+procedure TffParamEditor.FormDestroy(Sender: TObject);
+begin
+ if assigned(FComponent) then
+ SelectComponent(FComponent);
+
+ if assigned(FFParamsEditors) then
+ FFParamsEditors.Remove(Self);
+end;
+{--------}
+procedure TffParamEditor.FormShow(Sender: TObject);
+begin
+ Caption := format(ffcEditing, [FComponent.Name, FPropName]);
+ FillList;
+end;
+{--------}
+procedure TffParamEditor.FormClose(Sender: TObject;
+ var Action: TCloseAction);
+begin
+ if assigned(FComponent) then
+ SelectComponent(FComponent);
+
+ Action := caFree;
+end;
+{--------}
+function TffParamEditor.GetParams : longInt;
+begin
+ Result := longInt(FParams);
+end;
+{--------}
+procedure TffParamEditor.SetParams(anOrdValue : longInt);
+begin
+ FParams := TParams(anOrdValue);
+end;
+{--------}
+{$IFDEF DCC6OrLater}
+procedure TffParamEditor.SelectComponentList(SelList : IDesignerSelections);
+{$ELSE}
+{$IFDEF DCC5OrLater}
+procedure TffParamEditor.SelectComponentList(SelList : TDesignerSelectionList);
+{$ELSE}
+procedure TffParamEditor.SelectComponentList(SelList : TComponentList);
+{$ENDIF}
+{$ENDIF}
+begin
+ if assigned(FDesigner) then
+ {$IFDEF DCC6OrLater}
+ {$ifdef fpc}
+ FDesigner.SelectOnlyThisComponent(SelList); //soner es gibt ken setselections
+ {$else}
+ FDesigner.SetSelections(SelList);
+ {$endif}
+ {$ELSE}
+ {$IFDEF DCC4OrLater}
+ (FDesigner as IFormDesigner).SetSelections(SelList);
+ {$ELSE}
+ (FDesigner as TFormDesigner).SetSelections(SelList);
+ {$ENDIF}
+ SelList.Free;
+ {$ENDIF}
+end;
+{--------}
+procedure TffParamEditor.SelectComponent(Component : TComponent);
+var
+ {$IFDEF DCC6OrLater}
+ SelList : IDesignerSelections;
+ {$ELSE}
+ {$IFDEF DCC5OrLater}
+ SelList : TDesignerSelectionList;
+ {$ELSE}
+ SelList : TComponentList;
+ {$ENDIF}
+ {$ENDIF}
+begin
+ {$IFDEF DCC6OrLater}
+ SelList := TDesignerSelections.Create;
+ {$ELSE}
+ {$IFDEF DCC5OrLater}
+ SelList := TDesignerSelectionList.Create;
+ {$ELSE}
+ SelList := TComponentList.Create;
+ {$ENDIF}
+ {$ENDIF}
+ SelList.Add(Component);
+ SelectComponentList(SelList);
+end;
+{--------}
+procedure TffParamEditor.FillList;
+var
+ Index : Integer;
+begin
+
+ lbItems.Clear;
+ lbItems.ItemIndex := -1;
+
+ for Index := 0 to pred(FParams.Count) do
+ lbItems.Items.AddObject(
+ IntToStr(Index) + ' - ' +
+ {$IFDEF DCC4OrLater}
+ TParam(FParams.Items[Index]).DisplayName,
+ {$ELSE}
+ TParam(FParams.Items[Index]).Name,
+ {$ENDIF}
+ FParams.Items[Index])
+
+end;
+{--------}
+procedure TffParamEditor.lbItemsClick(Sender: TObject);
+var
+ {$IFDEF DCC6OrLater}
+ SelList : IDesignerSelections;
+ {$ELSE}
+ {$IFDEF DCC5OrLater}
+ SelList : TDesignerSelectionList;
+ {$ELSE}
+ SelList : TComponentList;
+ {$ENDIF}
+ {$ENDIF}
+ Index : Integer;
+begin
+ {$IFDEF DCC6OrLater}
+ SelList := TDesignerSelections.Create;
+ {$ELSE}
+ {$IFDEF DCC5OrLater}
+ SelList := TDesignerSelectionList.Create;
+ {$ELSE}
+ SelList := TComponentList.Create;
+ {$ENDIF}
+ {$ENDIF}
+ for Index := 0 to pred(lbItems.Items.Count) do
+ if lbItems.Selected[Index] then
+ SelList.Add(TComponent(lbItems.Items.Objects[Index]));
+
+ if SelList.Count > 0 then
+ SelectComponentList(SelList)
+ else
+ SelectComponent(FComponent);
+
+end;
+{====================================================================}
+
+initialization
+
+finalization
+ FFParamsEditors.Free;
+ FFParamsEditors := nil;
+end.
diff --git a/components/flashfiler/sourcelaz/ffclconv.pas b/components/flashfiler/sourcelaz/ffclconv.pas
new file mode 100644
index 000000000..ecdb3c1d2
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffclconv.pas
@@ -0,0 +1,1072 @@
+{*********************************************************}
+{* FlashFiler: Field and Record Conversion Routines *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffclconv;
+
+interface
+
+uses
+ Windows,
+ SysUtils,
+ DB,
+ ffclbde,
+ ffsrbde,
+ ffllbase,
+ ffllexcp,
+ ffconst,
+ ffclbase;
+
+procedure GetBDEFieldDescriptor(const FFFieldDesc : TFFFieldDescriptor;
+ var BDEFldDesc : FLDDesc);
+ {-converts a FlashFiler field descriptor into a physical BDE one}
+
+procedure GetBDEIndexDescriptor(const FFIndexDesc : TFFIndexDescriptor;
+ var BDEIdxDesc : IDXDesc);
+ {-converts a FlashFiler index descriptor into a BDE one}
+
+procedure GetBDELogicalFieldDescriptor(const FFFieldDesc : FLDDesc;
+ var BDEFieldDesc : FLDDesc);
+ {-converts a FlashFiler based BDE field description to a logical one
+ NOTE: the field iOffset is not set - to be calculated later}
+
+procedure GetBDEVChkDescriptor(FFVChkDesc : TffVCheckDescriptor;
+ var BDEVChkDesc : VCHKDesc;
+ FieldNumber : longint;
+ Required : boolean);
+ {-converts a FlashFiler validity check descriptor into a BDE one}
+
+
+function GetFFSearchKeyAction(
+ const aDBISearchCond : DBISearchCond) : TffSearchKeyAction;
+ {-convert a BDE search action to the FF one}
+
+function MapBDEDataToFF(FFType : TffFieldType;
+ PhySize : integer;
+ aSource : pointer;
+ aDest : pointer) : boolean;
+ {-maps a BDE logical field value in aSource to the equivalent FF
+ value in aDest. Note that type conversion is assumed to be the
+ reverse of MapFFTypeToBDE}
+
+procedure MapBDETypeToFF(BDEType : word;
+ BDESubType : word;
+ LogSize : integer;
+ var FFType : TffFieldType;
+ var PhySize : word);
+ {-maps a BDE field type/subtype to the nearest FF type and returns
+ the physical size}
+
+function MapFFDataToBDE(FFType : TffFieldType;
+ PhySize : integer;
+ aSource : pointer;
+ aDest : pointer) : boolean;
+ {-maps a FlashFiler field value in aSource to the equivalent BDE
+ value in aDest. Note that type conversion is assumed to be the
+ same as MapFFTypeToBDE}
+
+procedure MapFFTypeToBDE(FFType : TffFieldType;
+ PhySize : integer;
+ var BDEType : word;
+ var BDESubType : word;
+ var LogSize : word);
+ {-maps a FlashFiler field type to the nearest BDE logical type/
+ subtype and returns the logical size}
+
+procedure MapVCLTypeToFF(const VCLType : TFieldType;
+ const VCLSize : integer;
+ var FFType : TffFieldType;
+ var FFSize : word);
+ {-maps a VCL field type to the nearest FF equivalent. If the specified
+ VCLType is not supported, FFType is set to fftReserved20. }
+
+function FFBDEDateEncode(aDay : word;
+ aMonth : word;
+ aYear : word) : DBIDATE;
+ {-converts day, month, year to a raw date for a field}
+
+procedure FFBDEDateDecode(aDate : DBIDATE;
+ var aDay : word;
+ var aMonth : word;
+ var aYear : word);
+ {-converts a raw date from a field to day, month, year}
+
+function FFBDETimeEncode(aHour : Word;
+ aMin : Word;
+ aMilSec : Word) : DBITIME;
+ {-converts hour, min, milsec to a raw time for a field}
+
+procedure FFBDETimeDecode(aTime : DBITIME;
+ var aHour : Word;
+ var aMin : Word;
+ var aMilSec : Word);
+ {-converts a raw time from a field to hour, min, milsec}
+
+implementation
+
+uses
+ ffstdate;
+
+{Notes on date and time formats: There are four different date formats
+ in play here in FlashFiler Client:
+ TffDBIDate : a longint being the number of days since 1/1/0100;
+ this is the BDE logical type
+ TDateTime : a double whose integral part is
+ (Delphi 1) the number of days since 1/1/0100
+ (Delphi 2+) the number of days since 1/1/1800
+ TStDate : a longint being the number of days since 1/1/1600.
+The big problem is the different definitions of TDateTime. In Delphi
+1, to convert from TffDBIDate to TDateTime is an assignment (they use
+the same base date; in later compilers, you have to add 693594 days
+(and vice versa for the inverse operation). To convert TStDates to
+TDateTimes, use the StDate routine StDateToDateTime and
+DateTimeToStDate.
+
+Times are less confusing. The BDE logical type (TffDbiTime) is the
+number of milliseconds since midnight in a longint and the conversion
+from TStTime (the seconds since midnight) is simple.
+
+Unions of dates and times are also relatively simple. The BDE logical
+type TffTimeStamp is a number of milliseconds since the standard BDE
+base date.
+
+Note that FlashFiler stores its datetimes as the Delphi 1
+TDateTime type, so the conversion between the FlashFiler physical
+value and the BDE logical value is a matter of multiplying/dividing by
+the number of milliseconds in a day.}
+
+const
+ IGNORE_OEMANSI : Boolean = True;
+ IGNORE_ANSIOEM : Boolean = True;
+ dsMaxStringSize = 8192; {copied from DB.PAS}
+
+
+{===Interfaced routines==============================================}
+procedure GetBDEFieldDescriptor(const FFFieldDesc : TFFFieldDescriptor;
+ var BDEFldDesc : FLDDesc);
+begin
+ {clear the result structure to binary zeros}
+ FillChar(BDEFldDesc, sizeof(FLDDesc), 0);
+ {fill the relevant parts of the result structure}
+ with BDEFldDesc, FFFieldDesc do begin
+ iFldNum := succ(fdNumber);
+ FFStrPCopy(szName, fdName);
+ iFldType := ord(fdType);
+ iSubType := 0;
+ iUnits1 := fdUnits;
+ iUnits2 := fdDecPl;
+ iOffset := fdOffset;
+ iLen := fdLength;
+ {iNullOffset := 0;}
+ if Assigned(fdVCheck) or fdRequired then
+ efldvVchk := fldvHASCHECKS
+ else
+ efldvVchk := fldvNOCHECKS;
+ efldrRights := fldrREADWRITE;
+ {bCalcField := False;}
+ end;
+end;
+{--------}
+procedure GetBDEIndexDescriptor(const FFIndexDesc : TFFIndexDescriptor;
+ var BDEIdxDesc : IDXDesc);
+var
+ i : Integer;
+begin
+ {clear the result structure to binary zeros}
+ FillChar(BDEIdxDesc, sizeof(IDXDesc), 0);
+ {fill the relevant parts of the result structure}
+ with FFIndexDesc, BDEidxDesc do begin
+ StrPLCopy(szName, idName, sizeof(szName) - 1);
+ iIndexId := idNumber;
+ {StrCopy(szTagName, '');}
+ StrCopy(szFormat, 'BTREE');
+ {bPrimary := false;}
+ bUnique := not idDups;
+ bDescending := not idAscend;
+ bMaintained := True; {all FF keys are maintained}
+ {bSubSet := false;}
+ {iCost := 0}
+ if (idCount = -1) then begin
+ {this is a User-defined or Seq.Access Index: we'll treat it as
+ an expression Index - see dBASE info...}
+ bExpIdx := True;
+ iFldsInKey := 0;
+ end
+ else {it's a composite index} begin
+ bExpIdx := False;
+ iFldsInKey := idCount;
+ for i := 0 to pred(iFldsInKey) do
+ aiKeyFld[i] := succ(idFields[i]); {FF fields are 0-based, BDE's are 1-based}
+ end;
+ iKeyLen := idKeyLen;
+ {bOutOfDate := false;}
+ {iKeyExpType := 0;}
+ {StrCopy(szKeyExp, '');}
+ {StrCopy(szKeyCond, '');}
+ bCaseInsensitive := idNoCase;
+ {iBlockSize := 0;}
+ {iRestrNum := 0}
+ end;
+end;
+{--------}
+procedure GetBDELogicalFieldDescriptor(const FFFieldDesc : FLDDesc;
+ var BDEFieldDesc : FLDDesc);
+begin
+ {clear the result structure to binary zeros}
+ FillChar(BDEFieldDesc, sizeof(BDEFieldDesc), 0);
+ {fill the relevant parts of the result structure}
+ with BDEFieldDesc do begin
+ iFldNum := FFFieldDesc.iFldNum;
+ StrCopy(szName, FFFieldDesc.szName);
+ MapFFTypeToBDE(TFFFieldType(FFFieldDesc.iFldType),
+ FFFieldDesc.iLen,
+ iFldType,
+ iSubType,
+ iLen);
+ if (iFldType = fldZSTRING) then
+ iUnits1 := iLen
+ else if (iFldType = fldBYTES) then
+ iUnits1 := iLen;
+ {iUnits2 := 0; - unused}
+ {iOffset := 0; - this is set later}
+ {iNullOffset := 0; - there is none in a converted desc}
+ efldvVchk := fldvNOCHECKS;
+ efldrRights := fldrREADWRITE;
+ {bCalcField := 0;}
+ end;
+end;
+{--------}
+procedure GetBDEVChkDescriptor(FFVChkDesc : TffVCheckDescriptor;
+ var BDEVChkDesc : VCHKDesc;
+ FieldNumber : longint;
+ Required : boolean);
+begin
+ {clear the result structure to binary zeros}
+ FillChar(BDEVchkDesc, sizeof(VCHKDesc), 0);
+ {fill the relevant parts of the result structure}
+ with BDEVChkDesc, FFVChkDesc do begin
+ iFldNum := FieldNumber;
+ bRequired := Required;
+ bHasMinVal := vdHasMinVal;
+ bHasMaxVal := vdHasMaxVal;
+ bHasDefVal := vdHasDefVal;
+ if vdHasMinVal then
+ Move(vdMinVal, aMinVal, 254);
+ if vdHasMaxVal then
+ Move(vdMaxVal, aMaxVal, 254);
+ if vdHasDefVal then
+ Move(vdDefVal, aDefVal, 254);
+ StrPCopy(szPict, vdPicture);
+ {elkupType := lkupNONE;}
+ {szLkupTblName[0] := #0;}
+ end;
+end;
+{--------}
+function GetFFSearchKeyAction(
+ const aDBISearchCond : DBISearchCond) : TffSearchKeyAction;
+begin
+ case aDBISearchCond of
+ keySEARCHEQ : Result := skaEqual;
+ keySEARCHGT : Result := skaGreater;
+ keySEARCHGEQ : Result := skaGreaterEqual;
+ else
+ Result := skaEqual;
+ end;
+end;
+{--------}
+function MapBDEDataToFF(FFType : TffFieldType;
+ PhySize : integer;
+ aSource : pointer;
+ aDest : pointer) : boolean;
+var
+ WorkWideChar : array [0..1] of WideChar;
+ DateValue : TStDate;
+begin
+ {WARNING: the case statement below is in ascending order of switch
+ value}
+ Result := true;
+ case FFType of
+ fftBoolean:
+ begin
+ Boolean(aDest^) := WordBool(aSource^);
+ end;
+ fftChar:
+ begin
+ Char(aDest^) := Char(aSource^); {copy one character}
+ end;
+ fftWideChar:
+ begin
+ if not IGNORE_ANSIOEM then
+ AnsiToOEM(aSource, aSource);
+ StringToWideChar(StrPas(aSource), WorkWideChar, PhySize);
+ Move(WorkWideChar[0], aDest^, sizeof(WideChar));
+ end;
+ fftByte:
+ begin
+ Byte(aDest^) := Word(aSource^);
+ end;
+ fftWord16:
+ begin
+ Word(aDest^) := Word(aSource^);
+ end;
+ fftWord32:
+ begin
+ LongInt(aDest^) := LongInt(aSource^);
+ end;
+ fftInt8:
+ begin
+ ShortInt(aDest^) := ShortInt(aSource^); {!!.07}
+ end;
+ fftInt16:
+ begin
+ SmallInt(aDest^) := SmallInt(aSource^);
+ end;
+ fftInt32:
+ begin
+ LongInt(aDest^) := LongInt(aSource^);
+ end;
+ fftAutoInc:
+ begin
+ LongInt(aDest^) := LongInt(aSource^);
+ end;
+ fftSingle:
+ begin
+ Single(aDest^) := Double(aSource^);
+ end;
+ fftDouble:
+ begin
+ Double(aDest^) := Double(aSource^);
+ end;
+ fftExtended:
+ begin
+ Extended(aDest^) := Double(aSource^);
+ end;
+ fftComp:
+ begin
+ Comp(aDest^) := Double(aSource^);
+ end;
+ fftCurrency:
+ begin
+ Currency(aDest^) := Double(aSource^);
+ end;
+ fftStDate:
+ begin
+ DateValue := DateTimeToStDate(
+ DbiDate(aSource^) - 693594.0);
+ if DateValue = BadDate then begin
+ TStDate(aDest^) := 0;
+ Result := false;
+ end
+ else
+ TStDate(aDest^) := DateValue;
+ end;
+ fftStTime:
+ begin
+ {StTimes are stored as # seconds since midnight; BDE logical
+ times as # milliseconds; to convert, divide by 1000}
+ TStTime(aDest^) := DBITime(aSource^) div 1000;
+ end;
+ fftDateTime:
+ begin
+ {FF datetimes are compatible with Delphi's TDateTime, viz:
+ .; BDE stores as # millisecs since
+ base date; to convert, divide by # millisecs/day}
+ TDateTime(aDest^) := TimeStamp(aSource^) / 86400000.0;
+ end;
+ fftBLOB,
+ fftBLOBMemo,
+ fftBLOBFmtMemo,
+ fftBLOBOLEObj,
+ fftBLOBGraphic,
+ fftBLOBDBSOLEObj,
+ fftBLOBTypedBin,
+ fftBLOBFile:
+ begin
+ {just copy over the BLOB number}
+ LongInt(aDest^) := LongInt(aSource^);
+ end;
+ fftByteArray:
+ begin
+ Move(aSource^, aDest^, PhySize);
+ end;
+ fftShortString,
+ fftShortAnsiStr:
+ begin
+ if not IGNORE_ANSIOEM then
+ AnsiToOEM(aSource, aSource);
+ TffShStr(aDest^) := StrPas(aSource);
+ end;
+ fftNullString,
+ fftNullAnsiStr:
+ begin
+ if not IGNORE_ANSIOEM then
+ AnsiToOEM(aSource, aSource);
+ StrLCopy(aDest, aSource, pred(PhySize));
+ end;
+ fftWideString:
+ begin
+ {convert this to a Pascal String}
+ if not IGNORE_ANSIOEM then
+ AnsiToOEM(aSource, aSource);
+ StringToWideChar(StrPas(aSource), PWideChar(aDest), pred(PhySize));
+ end;
+ else
+ Result := false;
+ end;
+end;
+{--------}
+procedure MapBDETypeToFF(BDEType : word;
+ BDESubType : word;
+ LogSize : integer;
+ var FFType : TffFieldType;
+ var PhySize : word);
+begin
+ {WARNING: the case statement below is in ascending order of switch
+ value}
+ case BDEType of
+ fldZSTRING:
+ begin
+ FFType := fftNullString;
+ PhySize := LogSize;
+ end;
+ fldDATE:
+ begin
+ FFType := fftStDate;
+ PhySize := sizeof(TStDate);
+ end;
+ fldBLOB:
+ begin
+ case BDESubType of
+ fldstMEMO : FFType := fftBLOBMemo;
+ fldstBINARY : FFType := fftBLOB;
+ fldstFMTMEMO : FFType := fftBLOBFmtMemo;
+ fldstOLEOBJ : FFType := fftBLOBOLEObj;
+ fldstGRAPHIC : FFType := fftBLOBGraphic;
+ fldstDBSOLEOBJ : FFType := fftBLOBDBSOLEObj;
+ fldstTYPEDBINARY : FFType := fftBLOBTypedBin;
+ fldstBFILE : FFType := fftBLOBFile;
+ else
+ FFRaiseExceptionNoData(EffClientException, ffStrResClient, ffccInvalidParameter);
+ end;
+ PhySize := sizeof(longint);
+ end;
+ fldBOOL:
+ begin
+ FFType := fftBoolean;
+ PhySize := sizeof(boolean);
+ end;
+ fldINT16:
+ begin
+ FFType := fftInt16;
+ PhySize := sizeof(smallint);
+ end;
+ fldINT32:
+ begin
+ if (BDESubType = fldstAUTOINC) then
+ FFType := fftAutoInc
+ else
+ FFType := fftInt32;
+ PhySize := sizeof(longint);
+ end;
+ fldFLOAT:
+ begin
+ if BDESubType = fldstMoney then begin
+ FFType := fftCurrency;
+ PhySize := sizeof(Currency);
+ end
+ else begin
+ FFType := fftDouble;
+ PhySize := sizeof(double);
+ end;
+ end;
+ fldBCD:
+ begin
+ FFType := fftCurrency;
+ PhySize := sizeof(Currency);
+ end;
+ fldBYTES:
+ begin
+ FFType := fftByteArray;
+ PhySize := LogSize;
+ end;
+ fldTIME:
+ begin
+ FFType := fftstTime;
+ PhySize := sizeof(TStTime);
+ end;
+ fldTIMESTAMP:
+ begin
+ FFType := fftDateTime;
+ PhySize := sizeof(TDateTime);
+ end;
+ fldUINT16:
+ begin
+ FFType := fftWord16;
+ PhySize := sizeof(word);
+ end;
+ fldUINT32:
+ begin
+ FFType := fftWord32;
+ PhySize := sizeof(TffWord32);
+ end;
+ fldFLOATIEEE:
+ begin
+ FFType := fftExtended;
+ PhySize := sizeof(Extended);
+ end;
+ fldVARBYTES:
+ begin
+ if (LogSize > 256) then
+ FFRaiseExceptionNoData(EffClientException, ffStrResClient, ffccInvalidParameter);
+ FFType := fftShortString;
+ PhySize := LogSize;
+ end;
+ else
+ FFRaiseExceptionNoData(EffClientException, ffStrResClient, ffccInvalidParameter);
+ end;
+end;
+{--------}
+function MapFFDataToBDE(FFType : TffFieldType;
+ PhySize : Integer;
+ aSource : Pointer;
+ aDest : Pointer)
+ : Boolean;
+var
+ WorkString : string;
+begin
+ {WARNING: the case statement below is in ascending order of switch
+ value}
+ Result := True;
+ case FFType of
+ fftBoolean:
+ begin
+ WordBool(aDest^) := Boolean(aSource^);
+ end;
+ fftChar:
+ begin
+ word(aDest^) := 0;
+ char(aDest^) := char(aSource^);
+ end;
+ fftWideChar:
+ begin
+ {convert this to a Pascal String}
+ WorkString := WideCharLenToString(PWideChar(aSource), 1);
+ StrPLCopy(aDest, WorkString, pred(PhySize));
+ if not IGNORE_OEMANSI then
+ OEMToAnsi(aDest, aDest);
+ end;
+ fftByte:
+ begin
+ Word(aDest^) := Byte(aSource^);
+ end;
+ fftWord16:
+ begin
+ Word(aDest^) := Word(aSource^);
+ end;
+ fftWord32:
+ begin
+ LongInt(aDest^) := LongInt(aSource^);
+ end;
+ fftInt8:
+ begin
+ {NOTE: This maps to a SmallInt because the VCL does not have
+ an 8-bit integer field type. }
+ SmallInt(aDest^) := ShortInt(aSource^);
+ end;
+ fftInt16:
+ begin
+ SmallInt(aDest^) := SmallInt(aSource^);
+ end;
+ fftInt32:
+ begin
+ LongInt(aDest^) := LongInt(aSource^);
+ end;
+ fftAutoInc:
+ begin
+ LongInt(aDest^) := LongInt(aSource^);
+ end;
+ fftSingle:
+ begin
+ Double(aDest^) := Single(aSource^);
+ end;
+ fftDouble:
+ begin
+ Double(aDest^) := Double(aSource^);
+ end;
+ fftExtended:
+ begin
+ Double(aDest^) := Extended(aSource^);
+ end;
+ fftComp:
+ begin
+ Double(aDest^) := Comp(aSource^);
+ end;
+ fftCurrency:
+ begin
+ Double(aDest^) := Currency(aSource^);
+ end;
+ fftStDate:
+ begin
+ if TStDate(aSource^) = BadDate then
+ Result := false
+ else {it's a valid StDate value} begin
+ DbiDate(aDest^) :=
+ Trunc(StDateToDateTime(TStDate(aSource^)))
+ + 693594;
+ end;
+ end;
+ fftStTime:
+ begin
+ {StTimes are stored as # seconds since midnight; BDE logical
+ times as # milliseconds; to convert, multiply by 1000}
+ if TStTime(aSource^) = BadTime then
+ Result := false
+ else {it's a valid StDate value} begin
+ DBITime(aDest^) := TStTime(aSource^) * 1000;
+ end;
+ end;
+ fftDateTime:
+ begin
+ {FF datetimes are compatible with Delphi's TDateTime, viz:
+ .; BDE stores as # millisecs since
+ base date; to convert, multiply by # millisecs/day}
+ TimeStamp(aDest^) := TDateTime(aSource^) * 86400000.0;
+ end;
+ fftBLOB,
+ fftBLOBMemo,
+ fftBLOBFmtMemo,
+ fftBLOBOLEObj,
+ fftBLOBGRAPHIC,
+ fftBLOBDBSOLEOBJ,
+ fftBLOBTypedBin,
+ fftBLOBFile:
+ begin
+ {just copy the BLOB number over}
+ longint(aDest^) := longint(aSource^);
+ end;
+ fftByteArray:
+ begin
+ Move(aSource^, aDest^, PhySize);
+ end;
+ fftShortString,
+ fftShortAnsiStr:
+ begin
+ StrPLCopy(aDest, TffShStr(aSource^), pred(PhySize));
+ if not IGNORE_OEMANSI then
+ OEMToAnsi(aDest, aDest);
+ end;
+ fftNullString,
+ fftNullAnsiStr:
+ begin
+ StrLCopy(aDest, aSource, pred(PhySize));
+ if not IGNORE_ANSIOEM then
+ AnsiToOEM(aDest, aDest);
+ end;
+ fftWideString:
+ begin
+ {convert this to a Pascal String}
+ WorkString := WideCharLenToString(PWideChar(aSource),
+ lstrlenw(PWideChar(aSource)));
+ StrPLCopy(aDest, WorkString, pred(PhySize));
+ if not IGNORE_OEMANSI then
+ OEMToAnsi(aDest, aDest);
+ end;
+ else
+ Result := false;
+ end;
+end;
+{--------}
+procedure MapFFTypeToBDE(FFType : TFFFieldType;
+ PhySize : integer;
+ var BDEType : word;
+ var BDESubType : word;
+ var LogSize : word);
+begin
+ BDESubType := 0;
+ case FFType of
+ fftBoolean: {..8-bit boolean flag}
+ begin
+ BDEType := fldBOOL;
+ LogSize := sizeof(WordBool);
+ end;
+ fftChar: {..8-bit character}
+ begin
+ BDEType := fldZString;
+ LogSize := 1;
+ end;
+ fftWideChar: {..16-bit character (UNICODE)}
+ begin
+ BDEType := fldZString;
+ LogSize := 1;
+ end;
+ fftByte: {..byte (8-bit unsigned integer)}
+ begin
+ BDEType := fldUINT16;
+ LogSize := sizeof(word);
+ end;
+ fftWord16: {..16-bit unsigned integer (aka word)}
+ begin
+ BDEType := fldUINT16;
+ LogSize := sizeof(word);
+ end;
+ fftWord32: {..32-bit unsigned integer}
+ begin
+ BDEType := fldINT32;
+ LogSize := sizeof(longint);
+ end;
+ fftInt8: {..8-bit signed integer}
+ begin
+ BDEType := fldINT16;
+ LogSize := sizeof(smallint);
+ end;
+ fftInt16: {..16-bit signed integer}
+ begin
+ BDEType := fldINT16;
+ LogSize := sizeof(smallint);
+ end;
+ fftInt32: {..32-bit signed integer}
+ begin
+ BDEType := fldINT32;
+ LogSize := sizeof(longint);
+ end;
+ fftAutoInc: {..32-bit unsigned auto-increment }
+ begin
+ BDEType := fldINT32;
+ BDESubType := fldstAUTOINC;
+ LogSize := sizeof(longint);
+ end;
+ fftSingle: {..IEEE single (4 bytes)}
+ begin
+ BDEType := fldFLOAT;
+ LogSize := sizeof(double);
+ end;
+ fftDouble: {..IEEE double (8 bytes)}
+ begin
+ BDEType := fldFLOAT;
+ LogSize := sizeof(double);
+ end;
+ fftExtended: {..IEEE extended (10 bytes)}
+ begin
+ BDEType := fldFLOAT; {BDE doesn't REALLY support 80-bit float}
+ LogSize := sizeof(double);
+ end;
+ fftComp: {..IEEE comp type (8 bytes signed integer)
+ range -2E63+1..2E63-1}
+ begin
+ BDEType := fldFLOAT;
+ LogSize := sizeof(double);
+ end;
+ fftCurrency: {..Delphi currency type (8 bytes: scaled integer)
+ range -922337203685477.5808..922337203685477.5807}
+ begin
+ BDEType := fldFloat;
+ BDESubType := fldstMONEY;
+ LogSize := sizeof(double);
+ end;
+ fftStDate: {..SysTools date type (4 bytes)}
+ begin
+ BDEType := fldDATE;
+ LogSize := sizeof(DBIDATE);
+ end;
+ fftStTime: {..SysTools time type (4 bytes)}
+ begin
+ BDEType := fldTIME;
+ LogSize := sizeof(DbiTIME);
+ end;
+ fftDateTime: {..Delphi date/time type (8 bytes)}
+ begin
+ BDEType := fldTIMESTAMP;
+ LogSize := sizeof(TIMESTAMP);
+ end;
+ fftBLOB, fftBLOBFile:
+ begin
+ BDEType := fldBLOB;
+ BDESubType := fldstBINARY;
+ LogSize := sizeof(longint);
+ end;
+ fftBLOBMemo:
+ begin
+ BDEType := fldBLOB;
+ BDESubType := fldstMEMO;
+ LogSize := sizeof(longint);
+ end;
+ fftBLOBFmtMemo:
+ begin
+ BDEType := fldBLOB;
+ BDESubType := fldstFMTMEMO;
+ LogSize := sizeof(longint);
+ end;
+ fftBLOBOLEObj:
+ begin
+ BDEType := fldBLOB;
+ BDESubType := fldstOLEOBJ;
+ LogSize := sizeof(longint);
+ end;
+ fftBLOBGRAPHIC:
+ begin
+ BDEType := fldBLOB;
+ BDESubType := fldstGRAPHIC;
+ LogSize := sizeof(longint);
+ end;
+ fftBLOBDBSOLEOBJ:
+ begin
+ BDEType := fldBLOB;
+ BDESubType := fldstDBSOLEOBJ;
+ LogSize := sizeof(longint);
+ end;
+ fftBLOBTypedBin:
+ begin
+ BDEType := fldBLOB;
+ BDESubType := fldstTYPEDBINARY;
+ LogSize := sizeof(longint);
+ end;
+ fftByteArray: {..array of bytes}
+ begin
+ BDEType := fldBYTES;
+ LogSize := PhySize;
+ end;
+ fftShortString, {..length byte string}
+ fftShortAnsiStr:
+ begin
+ BDEType := fldZSTRING;
+ LogSize := pred(PhySize);
+ end;
+ fftNullString, {..null-terminated string}
+ fftNullAnsiStr,
+ fftWideString:
+ begin
+ if (PhySize <= dsMaxStringSize) then begin
+ BDEType := fldZSTRING;
+{Begin !!.11}
+ if FFType = fftWideString then
+ LogSize := pred(PhySize div 2)
+ else
+ LogSize := pred(PhySize);
+{End !!.11}
+ end
+ else begin
+ BDEType := fldBLOB;
+ BDESubType := fldstMEMO;
+ LogSize := sizeof(longint);
+ end;
+ end;
+ else
+ FFRaiseExceptionNoData(EffClientException, ffStrResClient, ffccInvalidParameter);
+ end;
+end;
+{--------}
+procedure MapVCLTypeToFF(const VCLType : TFieldType;
+ const VCLSize : integer;
+ var FFType : TffFieldType;
+ var FFSize : word);
+begin
+ case VCLType of
+ ftString :
+ begin
+ FFType := fftNullString;
+ FFSize := VCLSize;
+ end;
+ ftSmallInt :
+ begin
+ FFType := fftInt16;
+ FFSize := SizeOf(smallInt);
+ end;
+ ftInteger :
+ begin
+ FFType := fftInt32;
+ FFSize := SizeOf(longInt);
+ end;
+ ftWord :
+ begin
+ FFType := fftWord16;
+ FFSize := SizeOf(Word);
+ end;
+ ftBoolean :
+ begin
+ FFType := fftBoolean;
+ FFSize := SizeOf(Boolean);
+ end;
+ ftFloat :
+ begin
+ FFType := fftDouble;
+ FFSize := SizeOf(Double);
+ end;
+ ftCurrency :
+ begin
+ FFType := fftCurrency;
+ FFSize := SizeOf(Currency);
+ end;
+ ftBCD :
+ begin
+ FFType := fftCurrency;
+ FFSize := SizeOf(Currency);
+ end;
+ ftDate :
+ begin
+ FFType := fftStDate;
+ FFSize := sizeof(TStDate);
+ end;
+ ftTime :
+ begin
+ FFType := fftstTime;
+ FFSize := SizeOf(TStTime);
+ end;
+ ftDateTime :
+ begin
+ FFType := fftDateTime;
+ FFSize := SizeOf(TDateTime);
+ end;
+ ftBytes :
+ begin
+ FFType := fftByteArray;
+ FFSize := VCLSize;
+ end;
+ ftVarBytes :
+ begin
+ if (VCLSize <= 256) then begin
+ FFType := fftShortString;
+ FFSize := VCLSize;
+ end else begin
+ FFType := fftReserved20;
+ FFSize := 0;
+ end;
+ end;
+ ftAutoInc :
+ begin
+ FFType := fftAutoInc;
+ FFSize := SizeOf(LongInt);
+ end;
+ ftBlob :
+ begin
+ FFType := fftBLOB;
+ FFSize := SizeOf(TffInt64); {!!.13}
+ end;
+ ftMemo :
+ begin
+ FFType := fftBLOBMemo;
+ FFSize := SizeOf(TffInt64); {!!.13}
+ end;
+ ftGraphic :
+ begin
+ FFType := fftBLOBGraphic;
+ FFSize := SizeOf(TffInt64); {!!.13}
+ end;
+ ftFmtMemo :
+ begin
+ FFType := fftBLOBFmtMemo;
+ FFSize := SizeOf(TffInt64); {!!.13}
+ end;
+ ftParadoxOLE :
+ begin
+ FFType := fftBLOBOleObj;
+ FFSize := SizeOf(TffInt64); {!!.13}
+ end;
+ ftDBaseOLE :
+ begin
+ FFType := fftBLOBDBSOleObj;
+ FFSize := SizeOf(TffInt64); {!!.13}
+ end;
+ ftTypedBinary :
+ begin
+ FFType := fftBLOBTypedBin;
+ FFSize := SizeOf(TffInt64); {!!.13}
+ end;
+ {$IFDEF DCC4OrLater}
+ ftFixedChar :
+ begin
+ FFType := fftNullString;
+ FFSize := VCLSize;
+ end;
+ ftWideString :
+ begin
+ FFType := fftWideString;
+ FFSize := VCLSize;
+ end;
+ {$ENDIF}
+ {$IFDEF DCC5OrLater}
+ ftGUID :
+ begin
+ FFType := fftNullString;
+ FFSize := VCLSize;
+ end;
+ {$ENDIF}
+ else
+ { Use this to represent an unsupported field type. }
+ FFType := fftReserved20;
+ FFSize := 0;
+ end;
+end;
+{--------}
+function FFBDEDateEncode(aDay : word;
+ aMonth : word;
+ aYear : word) : DBIDATE;
+begin
+ Result := trunc(SysUtils.EncodeDate(aYear, aMonth, aDay))
+ + 693594;
+end;
+{--------}
+procedure FFBDEDateDecode(aDate : DBIDATE;
+ var aDay : word;
+ var aMonth : word;
+ var aYear : word);
+var
+ DT : TDateTime;
+begin
+ DT := aDate - 693594.0;
+ SysUtils.DecodeDate(DT, aYear, aMonth, aDay);
+end;
+{--------}
+function FFBDETimeEncode(aHour : Word;
+ aMin : Word;
+ aMilSec : Word) : DBITIME;
+ {-converts hour, min, milsec to a raw time for a field}
+begin
+ Result := trunc(SysUtils.EncodeTime(aHour, aMin, aMilSec mod 1000,
+ aMilSec div 1000) * 86400000.0);
+end;
+{--------}
+procedure FFBDETimeDecode(aTime : DBITIME;
+ var aHour : Word;
+ var aMin : Word;
+ var aMilSec : Word);
+ {-converts a raw time from a field to hour, min, milsec}
+var
+ DT : TDateTime;
+ aSec : Word;
+begin
+ DT := aTime / 86400000.0;
+ SysUtils.DecodeTime(DT, aHour, aMin, aSec, aMilSec);
+ aMilSec := aMilSec + aSec * 1000;
+end;
+
+{====================================================================}
+
+end.
+
diff --git a/components/flashfiler/sourcelaz/ffclexps.dfm b/components/flashfiler/sourcelaz/ffclexps.dfm
new file mode 100644
index 000000000..29f4ed93e
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffclexps.dfm
@@ -0,0 +1,61 @@
+object frmSelectProtocols: TfrmSelectProtocols
+ Left = 305
+ Top = 165
+ BorderStyle = bsDialog
+ Caption = 'Select FlashFiler Protocols'
+ ClientHeight = 168
+ ClientWidth = 254
+ Color = clBtnFace
+ Font.Color = clWindowText
+ Font.Height = -10
+ Font.Name = 'MS Sans Serif'
+ Font.Style = []
+ Position = poScreenCenter
+ OnCloseQuery = FormCloseQuery
+ PixelsPerInch = 96
+ TextHeight = 13
+ object GroupBox1: TGroupBox
+ Left = 7
+ Top = 13
+ Width = 241
+ Height = 118
+ Caption = 'What protocols would you like to support?'
+ TabOrder = 0
+ object chkSU: TCheckBox
+ Left = 20
+ Top = 33
+ Width = 78
+ Height = 13
+ Caption = '&Single User'
+ Checked = True
+ State = cbChecked
+ TabOrder = 0
+ end
+ object chkIPX: TCheckBox
+ Left = 20
+ Top = 59
+ Width = 78
+ Height = 13
+ Caption = '&IPX/SPX'
+ TabOrder = 1
+ end
+ object chkTCP: TCheckBox
+ Left = 20
+ Top = 85
+ Width = 78
+ Height = 13
+ Caption = '&TCP/IP'
+ TabOrder = 2
+ end
+ end
+ object Button1: TButton
+ Left = 13
+ Top = 143
+ Width = 61
+ Height = 20
+ Caption = '&OK'
+ Default = True
+ ModalResult = 1
+ TabOrder = 1
+ end
+end
diff --git a/components/flashfiler/sourcelaz/ffclexps.pas b/components/flashfiler/sourcelaz/ffclexps.pas
new file mode 100644
index 000000000..0773906c1
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffclexps.pas
@@ -0,0 +1,79 @@
+{*********************************************************}
+{* FlashFiler: Expert Protocol Selection Dialog *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffclexps;
+
+interface
+
+uses
+ Windows,
+ Messages,
+ SysUtils,
+ Classes,
+ Graphics,
+ Controls,
+ Forms,
+ Dialogs,
+ StdCtrls;
+
+type
+ TfrmSelectProtocols = class(TForm)
+ GroupBox1: TGroupBox;
+ Button1: TButton;
+ chkSU: TCheckBox;
+ chkIPX: TCheckBox;
+ chkTCP: TCheckBox;
+ procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
+ private
+ { Private declarations }
+ public
+ { Public declarations }
+ end;
+
+var
+ frmSelectProtocols: TfrmSelectProtocols;
+
+implementation
+
+{$R *.DFM}
+
+resourcestring
+ RError = 'You must select at least one protocol before you continue.';
+
+procedure TfrmSelectProtocols.FormCloseQuery(Sender: TObject;
+ var CanClose: Boolean);
+begin
+ CanClose := chkTCP.Checked or chkIPX.Checked or chkSU.Checked;
+ if not CanClose then
+ MessageDlg(RError, mtInformation, [mbOK], 0);
+end;
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffclexpt.pas b/components/flashfiler/sourcelaz/ffclexpt.pas
new file mode 100644
index 000000000..a0f3158f2
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffclexpt.pas
@@ -0,0 +1,1058 @@
+{*********************************************************}
+{* FlashFiler: TFFEngineManager Expert *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffclexpt;
+
+interface
+
+uses
+ Windows,
+ ExptIntf;
+
+type
+ { The TFFEngineManagerWizard represents a Delphi expert that will
+ create a new TFFEngineManager module with all the appropriate
+ components set up, and appropriate methods overriden. The
+ Expert is designed to prompt the user for the specific set
+ of protocols that the server will support. This wizard is
+ compatible with Delphi 3 - Delphi 5. }
+
+ TFFEngineManagerWizard = class(TIExpert)
+ public
+ procedure Execute; override;
+ { Create a new TFFEngineManager }
+ function GetAuthor : string; override;
+ { Return the Company Name }
+ function GetComment : string; override;
+ { Return the long description of this expert }
+ function GetGlyph : HICON; override;
+ { Return the icon to use for the this wizard }
+ function GetIDString : string; override;
+ { Return a Unique identifier for this expert }
+ function GetMenuText : string; override;
+ { Return an empty string, since we don't need a menu entry }
+ function GetName : string; override;
+ { Return the name of the wizard }
+ function GetPage : string; override;
+ { Return the default object repository page for the wizard }
+ function GetState : TExpertState; override;
+ { Return the expert state }
+ function GetStyle : TExpertStyle; override;
+ { Return the expert style }
+ end;
+
+implementation
+
+uses
+ Dialogs, Classes, Controls, Forms, SysUtils,
+ {Expert specific units}
+ Proxies,
+{$WARNINGS OFF}
+ ToolIntf,
+{$WARNINGS ON}
+ IStreams,
+ {FlashFiler Units}
+ ffclexps, { The protocol selection dialog }
+ ffllbase,
+ ffllcomm,
+ fflllgcy,
+ ffllprot,
+ fflllog,
+ ffllthrd,
+ ffsqleng,
+ ffsrcmd,
+ ffsreng,
+ ffsrsec;
+
+{ The TTextStream serves as a convienient method to add lines of
+ text to a stream. This class is used to build the source code
+ for the TFFEngineManager }
+type
+ TTextStream = class(TStringStream)
+ public
+ procedure WriteLn(const Str : string);
+ { Add a line of text to a stream}
+ procedure FormatLn(const Fmt : string; Args : array of const);
+ { Format, then add a line of text to a stream }
+ procedure NewLine;
+ { Add and empty line of text to a stream }
+ end;
+
+{=== TTextStream ==========================================}
+procedure TTextStream.NewLine;
+begin
+ WriteString(#13#10);
+end;
+{-------}
+procedure TTextStream.WriteLn(const Str : string);
+begin
+ WriteString(Str);
+ NewLine;
+end;
+{-------}
+procedure TTextStream.FormatLn(const Fmt : string; Args : array of const);
+begin
+ WriteLn(Format(Fmt, Args));
+end;
+
+
+{===== TFFEngineManager Expert Implementation =================================}
+{ constants specific to the implementation of the expert }
+const
+ CICON = 'TFFENGINEMANAGERWIZARD';
+ CBaseClassName = 'TffBaseEngineManager';
+ CFormName = 'ffEngineManager';
+
+type
+ { A set type used to store the selected protocols the TFFEngineManager
+ will support }
+ TFFProtocols = set of TFFProtocolType;
+
+type
+ { A descendent of TFFThreadPool that we can use to get access to the
+ SkipInitial property. This class is only used to typecast against
+ an actual TFFThreadPool. The SkipInitial property must be set to
+ true with modifying the InitialCount property of a thread pool while
+ creating the ProxyModule, since the ComponentState will not include
+ csDesigning. If this is not set correctly the Delphi IDE will lock
+ up tight! }
+
+ THackedFFThreadPool = class(TFFThreadPool)
+ public
+ property SkipInitial;
+ end;
+
+ THackedFFBaseCommandHandler = class(TffBaseCommandHandler) {NEW !!.01}
+ public
+ property SkipInitial;
+ end;
+
+{ Create the Module Proxy that will be used to stream the persistent
+ data to a DFM file}
+function CreateModuleProxy(ModuleName : string; aProtocols : TFFProtocols) : TDataModule;
+const
+ { Constants used for the proper alignment of controls. }
+ CLeftStart = 40;
+ CTopStart = 8;
+ CHorSpacing = 112;
+ CVertSpacing = 56;
+
+var
+ DesignRect : TRect; { The default module position and size }
+ EventLog : TffEventLog;
+ SEng : TFFServerEngine;
+ SQLEng : TffSqlEngine;
+ CmdH : TFFServerCommandHandler;
+ Transport : TFFLegacyTransport;
+ ThreadPool : TffThreadPool;
+ SecMon : TffSecurityMonitor;
+ Position : LongRec; { Temp var to store the position of a
+ a non-visual component }
+ NextLeft : Integer; { Used to store the left position of
+ a TFFLegacyTransport component. }
+begin
+ Result := TDataModule.Create(nil);
+ try
+ { Change Result to a proxy class}
+ CreateSubClass(Result, ModuleName, TDataModule);
+ with Result do begin
+ { Set the properties for the module }
+ Name := CFormName;
+ DesignRect := ToolServices.GetFormBounds(btCustomModule);
+ DesignOffset := DesignRect.TopLeft;
+ end;
+
+ { Create the event log. }
+ EventLog := TffEventLog.Create(Result);
+ { Set the properties for the event log. }
+ with EventLog do begin
+ Name := 'EventLog';
+ Enabled := True;
+ FileName := 'FFServer.log';
+ end;
+ { Since TComponent doesn't publish top and left properties, we have no
+ easy access to arrange non-visual components on the data module. Despite
+ this we can type case TComponent.DesignInfo as a LongRec. In this
+ scenario LongRec.Lo becomes Left, and LongRec.Hi becomes Top. This is not
+ documented anywhere but the source for TComponent, however tests show
+ that it works reliably in all versions of Delphi. }
+ Position := LongRec(EventLog.DesignInfo);
+ Position.Lo := CLeftStart;
+ Position.Hi := CTopStart;
+ EventLog.DesignInfo := LongInt(Position);
+
+ { Create the server engine component. The owner must be the proxy object! }
+ SEng := TFFServerEngine.Create(Result);
+ { Set the properties for the server engine }
+ SEng.Name := 'ServerEngine';
+ SEng.ConfigDir := ''; {!!.06}
+ Position := LongRec(SEng.DesignInfo);
+ Position.Lo := CLeftStart + CHorSpacing;
+ Position.Hi := CTopStart;
+ SEng.DesignInfo := LongInt(Position);
+ SEng.EventLog := EventLog;
+ SEng.CollectGarbage := True;
+
+ { Create the SQL engine }
+ SQLEng := TffSqlEngine.Create(Result);
+ SQLEng.Name := 'SQLEngine';
+ Position := LongRec(SQLEng.DesignInfo);
+ Position.Lo := CLeftStart + (CHorSpacing * 2);
+ Position.Hi := CTopStart;
+ SQLEng.DesignInfo := LongInt(Position);
+ SQLEng.EventLog := EventLog;
+ SQLEng.EventLogEnabled := False;
+
+ { Attach the server engine to the SQL engine. }
+ SEng.SQLEngine := SQLEng;
+
+ { Create the command handler }
+ CmdH := TFFServerCommandHandler.Create(Result);
+ { Set the properties for the command handler }
+ CmdH.Name := 'CommandHandler';
+ Position := LongRec(CmdH.DesignInfo);
+ Position.Lo := CLeftStart + (CHorSpacing * 3);
+ Position.HI := CTopStart;
+ CmdH.DesignInfo := LongInt(Position);
+ CmdH.EventLog := EventLog;
+ CmdH.EventLogEnabled := False;
+ CmdH.ServerEngine := SEng;
+ THackedFFBaseCommandHandler(CmdH).SkipInitial := True; {BEGIN !!.01}
+ CmdH.EngineManager := TffBaseEngineManager(CmdH.Owner);
+ { Skip intitial is not reverted to False. If it was the command handler
+ would raise an AV when destroyed } {END !!.01}
+
+ { Create the security monitor }
+ SecMon := TffSecurityMonitor.Create(Result);
+ { Set the properties for the command handler }
+ SecMon.Name := 'SecurityMonitor';
+ Position := LongRec(SecMon.DesignInfo);
+ Position.Lo := CLeftStart + (CHorSpacing * 4);
+ Position.Hi := CTopStart;
+ SecMon.DesignInfo := Longint(Position);
+ SecMon.ServerEngine := SEng;
+
+ NextLeft := CLeftStart;
+
+ { Create the thread pool }
+ ThreadPool := TFFThreadPool.Create(Result);
+ { Set the properties for the thread pool }
+ ThreadPool.Name := 'ThreadPool';
+ ThreadPool.EventLog := EventLog;
+ ThreadPool.EventLogEnabled := false;
+ { We need to keep the ThreadPool from starting the InitialCount threads.
+ To do this we must set SkipInitial to True. SkipInitial is a protected
+ method since we don't want users inadvertantly setting the property. To
+ get around normal visibility rules we declare a THackedFFThreadPool class
+ to promote the SkipInitial property to public. Then, as the code below
+ shows we can typecast ThreadPool as the hacked class to set the property. }
+ THackedFFThreadPool(ThreadPool).SkipInitial := True;
+ try
+ ThreadPool.InitialCount := 5; { Arbitary number of threads. }
+
+ ThreadPool.MaxCount := 256;
+ finally
+ THackedFFThreadPool(ThreadPool).SkipInitial := False;
+ end;
+ Position := LongRec(ThreadPool.DesignInfo);
+ Position.Lo := NextLeft;
+ inc(NextLeft, CHorSpacing);
+ Position.HI := CTopStart + CVertSpacing;
+ ThreadPool.DesignInfo := LongInt(Position);
+
+ { Set the NextLeft variable. This variable will be assigned to the "left"
+ property of the control. Then incremented by CHorSpacing. This is
+ necessary to give the transport components a consistent alignment since
+ the actual transports created are decided by the developer when the
+ expert starts. }
+ if ptSingleUser in aProtocols then begin
+ { Create a transport with the SingleExe protocol selected. }
+ Transport := TFFLegacyTransport.Create(Result);
+ Transport.Name := 'SUPTransport';
+
+ { The transport is ultimately associated with the server. This means that
+ the transport must listen for requests. }
+ Transport.Mode := fftmListen;
+ Transport.Protocol := ptSingleUser;
+ Transport.RespondToBroadcasts := True;
+
+ { If multiple transports use the same LogFile, problems will occur.
+ We set the property here for completeness.}
+ Transport.EventLog := EventLog;
+ Transport.EventLogEnabled := false;
+ Transport.EventLogOptions := [fftpLogErrors];
+ Transport.CommandHandler := CmdH;
+ Transport.ThreadPool := ThreadPool;
+ Transport.Enabled := True;
+ Position := LongRec(Transport.DesignInfo);
+ Position.Lo := NextLeft;
+ Position.HI := CTopStart + CVertSpacing;
+ Inc(NextLeft, CHorSpacing);
+ Transport.DesignInfo := LongInt(Position);
+ end;
+
+ if ptIPXSPX in aProtocols then begin
+ Transport := TFFLegacyTransport.Create(Result);
+ Transport.Name := 'IPXSPXTransport';
+ Transport.Mode := fftmListen;
+ Transport.Protocol := ptIPXSPX;
+ Transport.RespondToBroadcasts := True;
+ Transport.EventLog := EventLog;
+ Transport.EventLogEnabled := false;
+ Transport.EventLogOptions := [fftpLogErrors];
+ Transport.CommandHandler := CmdH;
+ Transport.ThreadPool := ThreadPool;
+ Transport.Enabled := True;
+ Position := LongRec(Transport.DesignInfo);
+ Position.Lo := NextLeft;
+ Position.HI := CTopStart + CVertSpacing;
+ Inc(NextLeft, CHorSpacing);
+ Transport.DesignInfo := LongInt(Position);
+ end;
+
+ if ptTCPIP in aProtocols then begin
+ Transport := TFFLegacyTransport.Create(Result);
+ Transport.Name := 'TCPIPTransport';
+ Transport.Mode := fftmListen;
+ Transport.Protocol := ptTCPIP;
+ Transport.RespondToBroadcasts := True;
+ Transport.EventLog := EventLog;
+ Transport.EventLogEnabled := false;
+ Transport.EventLogOptions := [fftpLogErrors];
+ Transport.CommandHandler := CmdH;
+ Transport.ThreadPool := ThreadPool;
+ Transport.Enabled := True;
+ Position := LongRec(Transport.DesignInfo);
+ Position.Lo := NextLeft;
+ Position.HI := CTopStart + CVertSpacing;
+ Transport.DesignInfo := LongInt(Position);
+ end;
+
+ with Result do
+ { Set the size of the module. This could be dynamic, but 200x100
+ represents the size just fine. }
+ DesignSize := Point(DesignOffset.X + 400,
+ DesignOffset.Y + 100);
+ except
+ { Delphi is normally responsible for freeing the proxy class. Since
+ an error occured, we need to take care of it locally. }
+ Result.Free;
+ raise;
+ end;
+end;
+{-------}
+function AdaptStream(Stream : TStream) : TIStreamAdapter;
+begin
+ try
+ {$IFDEF DCC4OrLater}
+ Result := TIStreamAdapter.Create(Stream, soOwned);
+ {$ELSE}
+ Result := TIStreamAdapter.Create(Stream, True);
+ {$ENDIF}
+ except
+ Stream.Free;
+ raise;
+ end;
+end;
+{-------}
+function CreateModuleStream(ModuleName : string; aProtocols : TFFProtocols) : TStream;
+{ Build the DFM file for the module }
+var
+ Module : TDataModule;
+begin
+ Result := TMemoryStream.Create;
+ try
+ Module := CreateModuleProxy(ModuleName, aProtocols);
+ try
+ Result.WriteDescendentRes(Module.ClassName, Module, nil);
+ Result.Position := 0;
+ finally
+ Module.Free;
+ end;
+ except
+ Result.Free;
+ raise;
+ end;
+end;
+{Begin !!.06}
+{$IFNDEF IsDelphi}
+{-------}
+function CreateHdrStream(UnitName, ModuleName : string; aProtocols : TFFProtocols): TTextStream;
+var
+ HeaderDate : string;
+begin
+ Result := TTextStream.Create('');
+ with Result do
+ try
+ WriteLn('//---------------------------------------------------------');
+ WriteLn('// FlashFiler: Engine manager');
+ HeaderDate := DateToStr(Now);
+ FormatLn('// Generated on %s with Release %5.4f',
+ [HeaderDate, ffVersionNumber / 10000.0]);
+ WriteLn('//---------------------------------------------------------');
+ NewLine;
+ WriteLn('//---------------------------------------------------------------------------');
+ NewLine;
+ FormatLn('#ifndef %sH', [UnitName]);
+ FormatLn('#define %sH', [UnitName]);
+ WriteLn('//---------------------------------------------------------------------------');
+ WriteLn('#include ');
+ WriteLn('#include ');
+ WriteLn('#include ');
+ WriteLn('#include ');
+ WriteLn('#include "ffllbase.hpp"');
+ WriteLn('#include "ffllcomm.hpp"');
+ WriteLn('#include "ffllcomp.hpp"');
+ WriteLn('#include "fflleng.hpp"');
+ WriteLn('#include "fflllgcy.hpp"');
+ WriteLn('#include "fflllog.hpp"');
+ WriteLn('#include "ffllthrd.hpp"');
+ WriteLn('#include "ffsqlbas.hpp"');
+ WriteLn('#include "ffsqleng.hpp"');
+ WriteLn('#include "ffsrcmd.hpp"');
+ WriteLn('#include "ffsreng.hpp"');
+ WriteLn('#include "ffsrintm.hpp"');
+ WriteLn('#include "ffsrjour.hpp"');
+ WriteLn('#include "ffsrsec.hpp"');
+ WriteLn('//---------------------------------------------------------------------------');
+ FormatLn('class %s : public %s', [ModuleName, CBaseClassName]);
+ WriteLn('{');
+ WriteLn('__published: // IDE-managed Components');
+ WriteLn(' TffEventLog *EventLog;');
+ WriteLn(' TffServerEngine *ServerEngine;');
+ WriteLn(' TffSqlEngine *SQLEngine;');
+ WriteLn(' TffServerCommandHandler *CommandHandler;');
+ WriteLn(' TffSecurityMonitor *SecurityMonitor;');
+ WriteLn(' TffThreadPool *ThreadPool;');
+ if ptSingleUser in aProtocols then
+ WriteLn(' TffLegacyTransport *SUPTransport;');
+ if ptIPXSPX in aProtocols then
+ WriteLn(' TffLegacyTransport *IPXSPXTransport;');
+ if ptTCPIP in aProtocols then
+ WriteLn(' TffLegacyTransport *TCPIPTransport;');
+ WriteLn('private: // User declarations');
+ WriteLn(' TffFullFileName FScriptFile;');
+ WriteLn(' bool __fastcall GetLogEnabled(void);');
+ WriteLn(' void __fastcall SetLogEnabled(const bool aEnabled);');
+ WriteLn(' void __fastcall SetScriptFile(const TffFullFileName aFileName);');
+ WriteLn('public: // User declarations');
+ FormatLn(' __fastcall %s(TComponent* Owner);', [ModuleName]);
+ NewLine;
+ WriteLn(' void __fastcall GetServerEngines(TffList* &aServerList);');
+ WriteLn(' void __fastcall GetTransports(TffIntermediateServerEngine *aServer, TffList* &aTransList);');
+ WriteLn(' virtual void __fastcall Process(PffDataMessage Msg, bool &Handled);');
+ WriteLn(' virtual void __fastcall Restart(void);');
+ WriteLn(' virtual void __fastcall Shutdown(void);');
+ WriteLn(' virtual void __fastcall Startup(void);');
+ WriteLn(' virtual void __fastcall Stop(void);');
+ NewLine;
+ WriteLn(' __property bool EventLogEnabled={read=GetLogEnabled, write=SetLogEnabled};');
+ WriteLn(' __property TffFullFileName ScriptFile={read=FScriptFile, write=SetScriptFile};');
+ WriteLn('};');
+ WriteLn('//---------------------------------------------------------------------------');
+ FormatLn('extern PACKAGE %s *%s;', [ModuleName, copy(ModuleName, 2, Length(ModuleName) - 1)]);
+ WriteLn('//---------------------------------------------------------------------------');
+ WriteLn('#endif');
+ Position := 0;
+ except
+ Free;
+ raise;
+ end;
+end;
+{-------}
+function CreateCppStream(UnitName, ModuleName : string; aProtocols : TFFProtocols): TTextStream;
+var
+ HeaderDate : string;
+begin
+ Result := TTextStream.Create('');
+ with Result do
+ try
+ WriteLn('//---------------------------------------------------------');
+ WriteLn('// FlashFiler: Engine manager');
+ HeaderDate := DateToStr(Now);
+ FormatLn('// Generated on %s with Release %5.4f',
+ [HeaderDate, ffVersionNumber / 10000.0]);
+ WriteLn('//---------------------------------------------------------');
+ NewLine;
+ WriteLn('//---------------------------------------------------------------------------');
+ NewLine;
+ WriteLn('#include ');
+ WriteLn('#pragma hdrstop');
+ NewLine;
+ FormatLn('#include "%s.h"', [UnitName]);
+ WriteLn('//---------------------------------------------------------------------------');
+ WriteLn('#pragma package(smart_init)');
+ WriteLn('#pragma link "ffllbase"');
+ WriteLn('#pragma link "ffllcomm"');
+ WriteLn('#pragma link "ffllcomp"');
+ WriteLn('#pragma link "fflleng"');
+ WriteLn('#pragma link "fflllgcy"');
+ WriteLn('#pragma link "fflllog"');
+ WriteLn('#pragma link "ffllthrd"');
+ WriteLn('#pragma link "ffnetmsg"');
+ WriteLn('#pragma link "ffsqlbas"');
+ WriteLn('#pragma link "ffsqleng"');
+ WriteLn('#pragma link "ffsrcmd"');
+ WriteLn('#pragma link "ffsreng"');
+ WriteLn('#pragma link "ffsrintm"');
+ WriteLn('#pragma link "ffsrjour"');
+ WriteLn('#pragma link "ffsrsec"');
+ WriteLn('#pragma resource "*.dfm"');
+ FormatLn('%s *%s;', [ModuleName, copy(ModuleName, 2, Length(ModuleName) - 1)]);
+ WriteLn('//---------------------------------------------------------------------------');
+ FormatLn('__fastcall %s::%s(TComponent* Owner)', [ModuleName, ModuleName]);
+ FormatLn(' : %s(Owner)', [CBaseClassName]);
+ WriteLn('{');
+ WriteLn(' EventLog->FileName = ExtractFilePath(Application->ExeName) + "FFServer.log";');
+ WriteLn('}');
+ WriteLn('//---------------------------------------------------------------------------');
+ FormatLn('bool __fastcall %s::GetLogEnabled(void)', [ModuleName]);
+ WriteLn('{');
+ WriteLn(' int Inx;');
+ WriteLn(' bool Result;');
+ WriteLn(' TffBaseServerEngine* anEngine;');
+ NewLine;
+ WriteLn(' Result = false;');
+ WriteLn(' // Assumption: Event log is enabled if we find a server engine');
+ WriteLn(' // that is routing events to the log.');
+ WriteLn(' for (Inx = 0; Inx < ComponentCount; Inx++)');
+ WriteLn(' {');
+ WriteLn(' anEngine = dynamic_cast(Components[Inx]);');
+ WriteLn(' if (anEngine != NULL)');
+ WriteLn(' {');
+ WriteLn(' Result = anEngine->EventLogEnabled;');
+ WriteLn(' break;');
+ WriteLn(' }');
+ WriteLn(' }');
+ WriteLn(' return Result;');
+ WriteLn('}');
+ WriteLn('//---------------------------------------------------------------------------');
+ FormatLn('void __fastcall %s::SetLogEnabled(const bool aEnabled)', [ModuleName]);
+ WriteLn('{');
+ WriteLn(' int Inx;');
+ WriteLn(' TffLoggableComponent* aComponent;');
+ WriteLn(' TffBaseTransport* aTransport;');
+ NewLine;
+ WriteLn(' // Assumption: TffBaseLog is always enabled. We just control which');
+ WriteLn(' // components are issuing messages to the log.');
+ WriteLn(' for (Inx = 0; Inx < ComponentCount; Inx++)');
+ WriteLn(' {');
+ WriteLn(' aComponent = dynamic_cast(Components[Inx]);');
+ WriteLn(' aTransport = dynamic_cast(Components[Inx]);');
+ WriteLn(' if ((aComponent != NULL) && (aTransport == NULL))');
+ WriteLn(' aComponent->EventLogEnabled = aEnabled;');
+ WriteLn(' }');
+ WriteLn('}');
+ WriteLn('//---------------------------------------------------------------------------');
+ FormatLn('void __fastcall %s::SetScriptFile(const TffFullFileName aFileName)', [ModuleName]);
+ WriteLn('{');
+ WriteLn(' int Inx;');
+ WriteLn(' TffServerEngine* anEngine;');
+ NewLine;
+ WriteLn(' FScriptFile = aFileName;');
+ WriteLn(' for (Inx = 0; Inx < ComponentCount; Inx++)');
+ WriteLn(' {');
+ WriteLn(' anEngine = dynamic_cast(Components[Inx]);');
+ WriteLn(' if (anEngine != NULL)');
+ WriteLn(' anEngine->ScriptFile = aFileName;');
+ WriteLn(' }');
+ WriteLn('}');
+ WriteLn('//---------------------------------------------------------------------------');
+ FormatLn('void __fastcall %s::GetServerEngines(TffList* &aServerList)', [ModuleName]);
+ WriteLn('{');
+ WriteLn(' TffIntListItem* ServerListItem;');
+ WriteLn(' int i;');
+ WriteLn(' TffBaseServerEngine* anEngine;');
+ NewLine;
+ WriteLn(' for (i = 0; i < ComponentCount; i++)');
+ WriteLn(' {');
+ WriteLn(' anEngine = dynamic_cast(Components[i]);');
+ WriteLn(' if (anEngine != NULL)');
+ WriteLn(' {');
+ WriteLn(' ServerListItem = new TffIntListItem(int(Components[i]));');
+ WriteLn(' aServerList->Insert(ServerListItem);');
+ WriteLn(' }');
+ WriteLn(' }');
+ WriteLn('}');
+ WriteLn('//---------------------------------------------------------------------------');
+ FormatLn('void __fastcall %s::GetTransports(TffIntermediateServerEngine *aServer, TffList* &aTransList)', [ModuleName]);
+ WriteLn('{');
+ WriteLn(' TffIntListItem* TransportItem;');
+ WriteLn(' int i, k;');
+ NewLine;
+ WriteLn(' for (i = 0; i < aServer->CmdHandlerCount; i++)');
+ WriteLn(' {');
+ WriteLn(' for (k = 0; k < aServer->CmdHandler[i]->TransportCount; k++)');
+ WriteLn(' {');
+ WriteLn(' TransportItem = new TffIntListItem(int(aServer->CmdHandler[i]->Transports[k]));');
+ WriteLn(' aTransList->Insert(TransportItem);');
+ WriteLn(' }');
+ WriteLn(' }');
+ WriteLn('}');
+ WriteLn('//---------------------------------------------------------------------------');
+ FormatLn('void __fastcall %s::Process(PffDataMessage Msg, bool &Handled)', [ModuleName]);
+ WriteLn('{');
+ WriteLn(' Handled = true;');
+ WriteLn(' switch(Msg->dmMsg)');
+ WriteLn(' {');
+ WriteLn(' case ffnmServerRestart :');
+ WriteLn(' {');
+ WriteLn(' Restart();');
+ WriteLn(' break;');
+ WriteLn(' }');
+ WriteLn(' case ffnmServerShutdown :');
+ WriteLn(' {');
+ WriteLn(' Shutdown();');
+ WriteLn(' break;');
+ WriteLn(' }');
+ WriteLn(' case ffnmServerStartup :');
+ WriteLn(' {');
+ WriteLn(' Startup();');
+ WriteLn(' break;');
+ WriteLn(' }');
+ WriteLn(' case ffnmServerStop :');
+ WriteLn(' {');
+ WriteLn(' Stop();');
+ WriteLn(' break;');
+ WriteLn(' }');
+ WriteLn(' default:');
+ WriteLn(' Handled = false;');
+ WriteLn(' }');
+ WriteLn('}');
+ WriteLn('//---------------------------------------------------------------------------');
+ FormatLn('void __fastcall %s::Restart(void)', [ModuleName]);
+ WriteLn('{');
+ WriteLn(' Shutdown();');
+ WriteLn(' Startup();');
+ WriteLn('}');
+ WriteLn('//---------------------------------------------------------------------------');
+ FormatLn('void __fastcall %s::Shutdown(void)', [ModuleName]);
+ WriteLn('{');
+ WriteLn(' int Inx;');
+ WriteLn(' TffBaseServerEngine* anEngine;');
+ WriteLn(' TffBasePluginEngine* aPlugin;');
+ WriteLn(' TffStateComponent* aStateCmp;');
+ NewLine;
+ WriteLn(' for (Inx = 0; Inx < ComponentCount; Inx++)');
+ WriteLn(' {');
+ WriteLn(' anEngine = dynamic_cast(Components[Inx]);');
+ WriteLn(' aPlugin = dynamic_cast(Components[Inx]);');
+ WriteLn(' aStateCmp = dynamic_cast(Components[Inx]);');
+ NewLine;
+ WriteLn(' if ((anEngine != NULL) | (aPlugin != NULL) &&');
+ WriteLn(' ((aStateCmp->State != ffesInactive) && (aStateCmp->State != ffesStopped)))');
+ WriteLn(' aStateCmp->Shutdown();');
+ WriteLn(' }');
+ WriteLn('}');
+ WriteLn('//---------------------------------------------------------------------------');
+ FormatLn('void __fastcall %s::Startup(void)', [ModuleName]);
+ WriteLn('{');
+ WriteLn(' int Inx;');
+ WriteLn(' TffBaseServerEngine* anEngine;');
+ WriteLn(' TffBasePluginEngine* aPlugin;');
+ WriteLn(' TffStateComponent* aStateCmp;');
+ NewLine;
+ WriteLn(' for (Inx = 0; Inx < ComponentCount; Inx++)');
+ WriteLn(' {');
+ WriteLn(' anEngine = dynamic_cast(Components[Inx]);');
+ WriteLn(' aPlugin = dynamic_cast(Components[Inx]);');
+ WriteLn(' aStateCmp = dynamic_cast(Components[Inx]);');
+ NewLine;
+ WriteLn(' if ((anEngine != NULL) | (aPlugin != NULL))');
+ WriteLn(' aStateCmp->Startup();');
+ WriteLn(' }');
+ WriteLn('}');
+ WriteLn('//---------------------------------------------------------------------------');
+ FormatLn('void __fastcall %s::Stop(void)', [ModuleName]);
+ WriteLn('{');
+ WriteLn(' int Inx;');
+ WriteLn(' TffBaseServerEngine* anEngine;');
+ WriteLn(' TffBasePluginEngine* aPlugin;');
+ WriteLn(' TffStateComponent* aStateCmp;');
+ NewLine;
+ WriteLn(' for (Inx = 0; Inx < ComponentCount; Inx++)');
+ WriteLn(' {');
+ WriteLn(' anEngine = dynamic_cast(Components[Inx]);');
+ WriteLn(' aPlugin = dynamic_cast(Components[Inx]);');
+ WriteLn(' aStateCmp = dynamic_cast(Components[Inx]);');
+ NewLine;
+ WriteLn(' if ((anEngine != NULL) | (aPlugin != NULL))');
+ WriteLn(' aStateCmp->Stop();');
+ WriteLn(' }');
+ WriteLn('}');
+ WriteLn('//---------------------------------------------------------------------------');
+ Position := 0;
+ except
+ Free;
+ raise;
+ end;
+end;
+{$ENDIF}
+{End !!.06}
+{-------}
+function CreateDelphiSourceStream(UnitName, ModuleName : string; aProtocols : TFFProtocols): TTextStream;
+{ Build the source (.pas) file for the module. }
+var
+ HeaderDate, HeaderVer : string;
+begin
+ Result := TTextStream.Create('');
+ with Result do
+ try
+ WriteLn('{*********************************************************}');
+ WriteLn('{* FlashFiler: Engine manager *}');
+ HeaderDate := DateToStr(Now);
+ HeaderVer := Format('%5.4f', [ffVersionNumber / 10000.0]);
+ FormatLn('{* Generated on %s with Release %s%s*}',
+ [HeaderDate, HeaderVer,
+ StringOfChar(' ', 27 - (Length(HeaderDate) + Length(HeaderVer)))]);
+ { 27 is sum of 9 spaces + space occupied by "mm/dd/yyyy" &
+ "vv.vvvv" for version. }
+ WriteLn('{*********************************************************}');
+ NewLine;
+ WriteLn('{$I ffdefine.inc}');
+ NewLine;
+ FormatLn('unit %s;', [UnitName]);
+ NewLine;
+ WriteLn('interface');
+ NewLine;
+ WriteLn('uses');
+ WriteLn(' windows, messages, sysutils, classes, controls, forms, fflleng, ffsreng, ');
+ WriteLn(' ffllcomm, fflllgcy, fflllog, ffllthrd, ffnetmsg, ffsrintm, ffsrcmd, ffllbase,');
+ WriteLn(' ffsrsec, ffsqlbas, ffsqleng, ffllcomp, ffsrjour;');
+ NewLine;
+ WriteLn('type');
+ FormatLn(' %s = class(' + CBaseClassName + ')', [ModuleName]);
+ WriteLn(' ServerEngine : TFFServerEngine;');
+ WriteLn(' EventLog : TffEventLog;');
+ WriteLn(' CommandHandler : TFFServerCommandHandler;');
+ WriteLn(' SecurityMonitor : TFFSecurityMonitor;');
+ WriteLn(' ThreadPool : TFFThreadPool;');
+ if ptSingleUser in aProtocols then
+ WriteLn(' SUPTransport : TFFLegacyTransport;');
+ if ptIPXSPX in aProtocols then
+ WriteLn(' IPXSPXTransport : TFFLegacyTransport;');
+ if ptTCPIP in aProtocols then
+ WriteLn(' TCPIPTransport : TFFLegacyTransport;');
+ WriteLn(' SQLEngine: TffSqlEngine;');
+ WriteLn(' private');
+ WriteLn(' { private declarations }');
+ WriteLn(' protected');
+ WriteLn(' FScriptFile : TffFullFileName;');
+ WriteLn(' function GetLogEnabled : boolean;');
+ WriteLn(' procedure SetLogEnabled(const aEnabled : boolean);');
+ WriteLn(' procedure SetScriptFile(const aFileName : TffFullFileName);');
+ WriteLn(' public');
+ WriteLn(' constructor Create(Sender: TComponent); override;');
+ WriteLn(' procedure GetServerEngines(var aServerList : TffList);');
+ WriteLn(' procedure GetTransports(aServer : TffIntermediateServerEngine; var aTransList : TffList);');
+ WriteLn(' procedure Process(Msg : PffDataMessage; var Handled : Boolean); override;');
+ WriteLn(' procedure Restart; override;');
+ WriteLn(' procedure Shutdown; override;');
+ WriteLn(' procedure Startup; override;');
+ WriteLn(' procedure Stop; override;');
+ NewLine;
+ WriteLn(' { Properties }');
+ WriteLn(' property EventLogEnabled : boolean');
+ WriteLn(' read GetLogEnabled');
+ WriteLn(' write SetLogEnabled;');
+ NewLine;
+ WriteLn(' property ScriptFile : TffFullFileName');
+ WriteLn(' read FScriptFile');
+ WriteLn(' write SetScriptFile;');
+ NewLine;
+ WriteLn(' end;');
+ NewLine;
+ WriteLn('var');
+ FormatLn(' %s: %s;',
+ [copy(ModuleName, 2, Length(ModuleName) - 1),ModuleName]);
+ NewLine;
+ WriteLn('implementation');
+ NewLine;
+ WriteLn('{$R *.DFM}');
+ NewLine;
+ WriteLn('{====================================================================}');
+ FormatLn('constructor %s.Create(Sender: TComponent);', [ModuleName]);
+ WriteLn('begin');
+ WriteLn(' inherited Create(Sender);');
+ WriteLn(' EventLog.FileName := ExtractFilePath(Application.ExeName) + ''FFServer.log'';');
+ WriteLn('end;');
+ WriteLn('{--------}');
+ FormatLn('function %s.GetLogEnabled : boolean;', [ModuleName]);
+ WriteLn('var');
+ WriteLn(' Idx : Integer;');
+ WriteLn('begin');
+ WriteLn(' Result := False;');
+ WriteLn(' { Assumption: Event log is enabled if we find a server engine');
+ WriteLn(' that is routing events to the log. }');
+ WriteLn(' for Idx := 0 to Pred(ComponentCount) do');
+ WriteLn(' if (Components[Idx] is TffBaseServerEngine) then begin');
+ WriteLn(' Result := TffBaseServerEngine(Components[Idx]).EventLogEnabled;');
+ WriteLn(' break;');
+ WriteLn(' end;');
+ WriteLn('end;');
+ WriteLn('{--------}');
+ FormatLn('procedure %s.GetServerEngines(var aServerList: TffList);', [ModuleName]);
+ WriteLn('var');
+ WriteLn(' ServerListItem : TffIntListItem;');
+ WriteLn(' i : Integer;');
+ WriteLn('begin');
+ WriteLn(' for I := 0 to Pred(ComponentCount) do');
+ WriteLn(' if (Components[i] is TffBaseServerEngine) then begin');
+ WriteLn(' ServerListItem := TffIntListItem.Create(longint(Components[i]));');
+ WriteLn(' aServerList.Insert(ServerListItem);');
+ WriteLn(' end;');
+ WriteLn('end;');
+ WriteLn('{--------}');
+ FormatLn('procedure %s.GetTransports(aServer : TffIntermediateServerEngine;', [ModuleName]);
+ WriteLn(' var aTransList : TffList);');
+ WriteLn('var');
+ WriteLn(' TransportItem : TffIntListItem;');
+ WriteLn(' i, k : Integer;');
+ WriteLn('begin');
+ WriteLn(' for i := 0 to Pred(aServer.CmdHandlerCount) do begin');
+ WriteLn(' for k := 0 to Pred(aServer.CmdHandler[i].TransportCount) do begin');
+ WriteLn(' TransportItem := TffIntListItem.Create(Integer(aServer.CmdHandler[i].Transports[k]));');
+ WriteLn(' aTransList.Insert(TransportItem);');
+ WriteLn(' end;');
+ WriteLn(' end;');
+ WriteLn('end;');
+ WriteLn('{--------}');
+ FormatLn('procedure %s.Process(Msg : PffDataMessage; var Handled : Boolean);', [ModuleName]);
+ WriteLn('begin');
+ WriteLn(' Handled := True;');
+ WriteLn(' case Msg.dmMsg of');
+ WriteLn(' ffnmServerRestart : Restart;');
+ WriteLn(' ffnmServerShutdown : Shutdown;');
+ WriteLn(' ffnmServerStartUp : Startup;');
+ WriteLn(' ffnmServerStop : Stop;');
+ WriteLn(' else');
+ WriteLn(' Handled := False;');
+ WriteLn(' end;');
+ WriteLn('end;');
+ WriteLn('{--------}');
+ FormatLn('procedure %s.Restart;', [ModuleName]);
+ WriteLn('begin');
+ WriteLn(' Shutdown;');
+ WriteLn(' Startup;');
+ WriteLn('end;');
+ WriteLn('{--------}');
+ FormatLn('procedure %s.SetLogEnabled(const aEnabled : boolean);',[ModuleName]);
+ WriteLn('var');
+ WriteLn(' Idx : Integer;');
+ WriteLn('begin');
+ WriteLn(' { Assumption: TffBaseLog is always enabled. We just control which');
+ WriteLn(' components are issuing messages to the log. }');
+ WriteLn(' for Idx := 0 to Pred(ComponentCount) do');
+ WriteLn(' if (Components[Idx] is TffLoggableComponent) and');
+ WriteLn(' not (Components[Idx] is TffBaseTransport) then');
+ WriteLn(' TffLoggableComponent(Components[Idx]).EventLogEnabled := aEnabled');
+ WriteLn('end;');
+ WriteLn('{--------}');
+ FormatLn('procedure %s.SetScriptFile(const aFileName : TffFullFileName);',[ModuleName]);
+ WriteLn('var');
+ WriteLn(' Idx : Integer;');
+ WriteLn('begin');
+ WriteLn(' FScriptFile := aFileName;');
+ WriteLn(' for Idx := 0 to Pred(ComponentCount) do');
+ WriteLn(' if (Components[Idx] is TffServerEngine) then');
+ WriteLn(' TffServerEngine(Components[Idx]).ScriptFile := aFileName;');
+ WriteLn('end;');
+ WriteLn('{--------}');
+ FormatLn('procedure %s.Shutdown;', [ModuleName]);
+ WriteLn('var');
+ WriteLn(' Idx : Integer;');
+ WriteLn('begin');
+ WriteLn(' for Idx := 0 to Pred(ComponentCount) do');
+ WriteLn(' if ((Components[Idx] is TFFBaseServerEngine) or');
+ WriteLn(' (Components[Idx] is TFFBasePluginEngine)) and');
+ WriteLn(' not (TffStateComponent(Components[Idx]).State in');
+ WriteLn(' [ffesInactive, ffesStopped]) then');
+ WriteLn(' TffStateComponent(Components[Idx]).Shutdown;');
+ WriteLn('end;');
+ WriteLn('{--------}');
+ FormatLn('procedure %s.Startup;', [ModuleName]);
+ WriteLn('var');
+ WriteLn(' Idx : Integer;');
+ WriteLn('begin');
+ WriteLn(' for Idx := 0 to Pred(ComponentCount) do');
+ WriteLn(' if (Components[Idx] is TFFBaseServerEngine) or');
+ WriteLn(' (Components[Idx] is TFFBasePluginEngine) then');
+ WriteLn(' TffStateComponent(Components[Idx]).Startup;');
+ WriteLn('end;');
+ WriteLn('{--------}');
+ FormatLn('procedure %s.Stop;', [ModuleName]);
+ WriteLn('var');
+ WriteLn(' Idx : Integer;');
+ WriteLn('begin');
+ WriteLn(' for Idx := 0 to Pred(ComponentCount) do');
+ WriteLn(' if (Components[Idx] is TFFBaseServerEngine) or');
+ WriteLn(' (Components[Idx] is TFFBasePluginEngine) then');
+ WriteLn(' TffStateComponent(Components[Idx]).Stop;');
+ WriteLn('end;');
+ WriteLn('{====================================================================}');
+ NewLine;
+ WriteLn('end.');
+ Position := 0;
+ except
+ Free;
+ raise;
+ end;
+end;
+{-------}
+procedure CreateEngineManager(aProtocols : TFFProtocols);
+{ Create the new module based on the selected protocols (aProtocols) }
+var
+ UnitName, ModuleName, FileName : string;
+{$IFNDEF IsDelphi}
+ HdrAdapter,
+{$ENDIF}
+ ModuleAdapter, UnitAdapter : TIStreamAdapter;
+begin
+ ToolServices.GetNewModuleAndClassName('TFFEngineManager', UnitName,
+ ModuleName, FileName);
+ ModuleAdapter := AdaptStream(CreateModuleStream(ModuleName, aProtocols));
+ try
+{$IFDEF IsDelphi}
+ UnitAdapter := AdaptStream(CreateDelphiSourceStream(UnitName, ModuleName, aProtocols));
+ try
+ ToolServices.CreateModule(FileName, UnitAdapter, ModuleAdapter,
+ [cmAddToProject, cmShowSource, cmMarkModified,
+ cmShowForm, cmUnNamed]);
+ except
+ UnitAdapter.Free;
+ raise;
+ end;
+{$ELSE}
+ UnitAdapter := AdaptStream(CreateCppStream(UnitName, ModuleName, aProtocols));
+ HdrAdapter := AdaptStream(CreateHdrStream(UnitName, ModuleName, aProtocols));
+ try
+ ToolServices.CreateCppModule(FileName, 'formName', 'TDataModule', '',
+ HdrAdapter, UnitAdapter, ModuleAdapter,
+ [cmAddToProject, cmShowSource, cmMarkModified,
+ cmShowForm, cmUnNamed]);
+ except
+ UnitAdapter.Free;
+ HdrAdapter.Free;
+ raise;
+ end;
+{$ENDIF}
+ except
+ ModuleAdapter.Free;
+ raise;
+ end;
+end;
+{-------}
+procedure StartWizard;
+var
+ FFProtocols : TFFProtocols;
+begin
+ { Prompt the user for a set of protocols to support. }
+ with TFrmSelectProtocols.Create(nil) do
+ try
+ ShowModal; {The protocol selection form}
+
+ { Get the list of selected protocols }
+ FFProtocols := [];
+ if chkSU.Checked then
+ FFProtocols := [ptSingleUser];
+ if chkIPX.Checked then
+ FFProtocols := FFProtocols + [ptIPXSPX];
+ if chkTCP.Checked then
+ FFProtocols := FFProtocols + [ptTCPIP];
+
+ finally
+ Free; {The protocol selection form}
+ end;
+
+ { Create the module }
+ CreateEngineManager(FFProtocols);
+end;
+
+{string constants used to return information to the expert}
+resourcestring
+ RCompany = 'TurboPower Software Company';
+ RComment = 'FlashFiler 2 Engine Manager Module';
+ RName = 'FlashFiler 2 Engine Manager';
+ RPage = 'Data Modules';
+
+{=== TFFEngineManagerWizard ===============================}
+procedure TFFEngineManagerWizard.Execute;
+begin
+ StartWizard;
+end;
+{-------}
+function TFFEngineManagerWizard.GetAuthor : string;
+begin
+ Result := RCompany;
+end;
+{-------}
+function TFFEngineManagerWizard.GetComment : string;
+begin
+ Result := RComment;
+end;
+{-------}
+function TFFEngineManagerWizard.GetGlyph : HICON;
+begin
+ Result := LoadIcon(hInstance, CICON);
+end;
+{-------}
+function TFFEngineManagerWizard.GetIDString : string;
+begin
+ Result := RCompany + '.' + RName;
+end;
+{-------}
+function TFFEngineManagerWizard.GetMenuText : string;
+begin
+ Result := '';
+end;
+{-------}
+function TFFEngineManagerWizard.GetName : string;
+begin
+ Result := RName;
+end;
+{-------}
+function TFFEngineManagerWizard.GetPage : string;
+begin
+ Result := RPage;
+end;
+{-------}
+function TFFEngineManagerWizard.GetState : TExpertState;
+begin
+ Result := [esEnabled];
+end;
+{-------}
+function TFFEngineManagerWizard.GetStyle : TExpertStyle;
+begin
+ Result := esForm;
+end;
+
+end.
+
diff --git a/components/flashfiler/sourcelaz/ffclfldg.dfm b/components/flashfiler/sourcelaz/ffclfldg.dfm
new file mode 100644
index 000000000..69fbdd69c
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffclfldg.dfm
@@ -0,0 +1,144 @@
+object frmFieldLinkDesigner: TfrmFieldLinkDesigner
+ Left = 195
+ Top = 119
+ BorderIcons = [biSystemMenu]
+ BorderStyle = bsDialog
+ Caption = 'Field Link Designer'
+ ClientHeight = 263
+ ClientWidth = 350
+ Font.Color = clWindowText
+ Font.Height = -11
+ Font.Name = 'MS Sans Serif'
+ Font.Style = []
+ PixelsPerInch = 96
+ TextHeight = 13
+ object Label1: TLabel
+ Left = 8
+ Top = 12
+ Width = 83
+ Height = 13
+ Caption = 'A&vailable Indexes'
+ FocusControl = cboDetailIndexes
+ end
+ object pnlMain: TPanel
+ Left = 8
+ Top = 38
+ Width = 334
+ Height = 187
+ BevelInner = bvRaised
+ BevelOuter = bvLowered
+ TabOrder = 1
+ object Label2: TLabel
+ Left = 8
+ Top = 10
+ Width = 57
+ Height = 13
+ Caption = 'D&etail Fields'
+ FocusControl = lstDetailFields
+ end
+ object Label3: TLabel
+ Left = 215
+ Top = 8
+ Width = 62
+ Height = 13
+ Caption = '&Master Fields'
+ FocusControl = lstMasterFields
+ end
+ object Label4: TLabel
+ Left = 8
+ Top = 104
+ Width = 61
+ Height = 13
+ Caption = '&Joined Fields'
+ FocusControl = lstJoinedFields
+ end
+ object lstDetailFields: TListBox
+ Left = 8
+ Top = 26
+ Width = 110
+ Height = 73
+ ItemHeight = 13
+ TabOrder = 0
+ OnClick = EnableAddButton
+ end
+ object lstMasterFields: TListBox
+ Left = 215
+ Top = 26
+ Width = 110
+ Height = 73
+ ItemHeight = 13
+ TabOrder = 2
+ OnClick = EnableAddButton
+ end
+ object btnAdd: TButton
+ Left = 130
+ Top = 50
+ Width = 75
+ Height = 25
+ Caption = '&Add'
+ Enabled = False
+ TabOrder = 1
+ OnClick = btnAddClick
+ end
+ object lstJoinedFields: TListBox
+ Left = 8
+ Top = 120
+ Width = 235
+ Height = 57
+ ItemHeight = 13
+ TabOrder = 3
+ OnClick = lstJoinedFieldsClick
+ end
+ object btnDelete: TButton
+ Left = 250
+ Top = 120
+ Width = 75
+ Height = 25
+ Caption = '&Delete'
+ Enabled = False
+ TabOrder = 4
+ OnClick = btnDeleteClick
+ end
+ object btnClear: TButton
+ Left = 250
+ Top = 152
+ Width = 75
+ Height = 25
+ Caption = '&Clear'
+ Enabled = False
+ TabOrder = 5
+ OnClick = btnClearClick
+ end
+ end
+ object cboDetailIndexes: TComboBox
+ Left = 104
+ Top = 8
+ Width = 185
+ Height = 21
+ Style = csDropDownList
+ ItemHeight = 13
+ TabOrder = 0
+ OnClick = cboDetailIndexesClick
+ end
+ object btnOK: TButton
+ Left = 93
+ Top = 232
+ Width = 75
+ Height = 25
+ Caption = 'OK'
+ Default = True
+ Enabled = False
+ TabOrder = 2
+ OnClick = btnOKClick
+ end
+ object btnCancel: TButton
+ Left = 181
+ Top = 232
+ Width = 75
+ Height = 25
+ Cancel = True
+ Caption = 'Cancel'
+ ModalResult = 2
+ TabOrder = 3
+ end
+end
diff --git a/components/flashfiler/sourcelaz/ffclfldg.pas b/components/flashfiler/sourcelaz/ffclfldg.pas
new file mode 100644
index 000000000..2bbe69a1b
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffclfldg.pas
@@ -0,0 +1,340 @@
+{*********************************************************}
+{* FlashFiler: Field Link Designer Dialog *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.Inc}
+
+unit ffclfldg;
+
+interface
+
+uses
+ Windows,
+ Messages,
+ SysUtils,
+ Classes,
+ Graphics,
+ Controls,
+ Forms,
+ Dialogs,
+ StdCtrls,
+ ExtCtrls,
+ DB,
+ ffdb,
+ ffconst,
+ ffdbbase,
+ ffllbase;
+
+type
+ TfrmFieldLinkDesigner = class(TForm)
+ pnlMain: TPanel;
+ cboDetailIndexes: TComboBox;
+ Label1: TLabel;
+ lstDetailFields: TListBox;
+ lstMasterFields: TListBox;
+ Label2: TLabel;
+ Label3: TLabel;
+ btnAdd: TButton;
+ lstJoinedFields: TListBox;
+ btnDelete: TButton;
+ btnClear: TButton;
+ btnOK: TButton;
+ btnCancel: TButton;
+ Label4: TLabel;
+ procedure cboDetailIndexesClick(Sender: TObject);
+ procedure btnAddClick(Sender: TObject);
+ procedure btnDeleteClick(Sender: TObject);
+ procedure btnClearClick(Sender: TObject);
+ procedure lstJoinedFieldsClick(Sender: TObject);
+ procedure EnableAddButton(Sender: TObject);
+ procedure btnOKClick(Sender: TObject);
+ private
+ DetailTable: TffTable;
+ procedure EnableOKButton;
+ procedure RemoveJoinExpr(aIndex: Integer);
+ procedure ReinsertField(aList: TStrings; aFieldName: TffShStr; aFieldNo: LongInt);
+ public
+ end;
+
+function ShowFieldLinkDesigner(aMasterTable: TDataSet;
+ aDetailTable: TffTable;
+ var aDetailIndex,
+ aDetailFields,
+ aMasterFields: TffShStr): TModalResult;
+
+implementation
+
+{$R *.DFM}
+
+const
+ JoinSeparator= ' -> ';
+
+type
+ TffJoinedFieldNos = record
+ MasterFieldNo: Word; { MasterFieldNo must be stored before DetailFieldNo }
+ DetailFieldNo: Word; { to preserve numerical ordering when ReinsertField }
+ { is called by btnAddClick }
+ end;
+
+function ShowFieldLinkDesigner(aMasterTable: TDataset;
+ aDetailTable: TffTable;
+ var aDetailIndex,
+ aDetailFields,
+ aMasterFields: TffShStr): TModalResult;
+var
+ I, J, K: Integer;
+ FieldName: TffShStr;
+begin
+ J := 0;
+ with TfrmFieldLinkDesigner.Create(Application) do
+ try
+ DetailTable := aDetailTable;
+ DetailTable.FieldDefs.Update;
+ DetailTable.IndexDefs.Update;
+
+ { Populate detail indexes }
+ with cboDetailIndexes do begin
+ DetailTable.GetIndexNames(Items);
+ Items.Delete(0); { remove the seq access index }
+ ItemIndex := -1;
+ if Items.Count <> 0 then
+ ItemIndex := 0;
+ if aDetailIndex = '' then
+ if aDetailFields <> '' then
+ try
+ aDetailIndex := DetailTable.IndexDefs.FindIndexForFields(aDetailFields).Name
+ except
+ aDetailIndex := ''; {eat exceptions}
+ end;
+ if aDetailIndex <> '' then
+ ItemIndex := Items.IndexOf(aDetailIndex);
+ end;
+
+ { Populate detail fields }
+ cboDetailIndexesClick(nil);
+
+ { Populate master fields; retain field's position within the record }
+ with aMasterTable do begin
+ FieldDefs.Update;
+ for I := 0 to FieldDefs.Count - 1 do
+ with FieldDefs[I] do
+ lstMasterFields.Items.AddObject(Name, Pointer(FieldNo));
+ end;
+
+ { If an existing join is passed in, set it up }
+ while aMasterFields <> '' do begin
+ if aDetailIndex = '' then begin
+ FFShStrSplit(aDetailFields, ';', FieldName, aDetailFields);
+ if FieldName = '' then
+ Break;
+ J := lstDetailFields.Items.IndexOf(FieldName);
+ end
+ else
+ J := 0;
+
+ FFShStrSplit(aMasterFields, ';', FieldName, aMasterFields);
+ K := lstMasterFields.Items.IndexOf(FieldName);
+
+ if (J <> -1) and (K <> -1) then begin
+ lstDetailFields.ItemIndex := J;
+ lstMasterFields.ItemIndex := K;
+ btnAddClick(nil);
+ end;
+ end;
+
+ Result := ShowModal;
+ aDetailIndex := '';
+ aDetailFields := '';
+ aMasterFields := '';
+
+ if Result = mrOK then begin
+ { If all detail fields used, return the index name }
+ if lstDetailFields.Items.Count = 0 then begin
+ aDetailIndex := cboDetailIndexes.Text;
+ aDetailFields := '';
+ end
+
+ { otherwise return the detail fields used }
+ else begin
+ with lstJoinedFields.Items do
+ for I := 0 to Count - 1 do begin
+ FieldName := Copy(Strings[I], 1, Pos(JoinSeparator, Strings[I]) - 1);
+ aDetailFields := aDetailFields + FieldName;
+ if I < Count - 1 then
+ aDetailFields := aDetailFields + ';';
+ end;
+ end;
+
+ with lstJoinedFields.Items do
+ for I := 0 to Count - 1 do begin
+ FieldName := Copy(Strings[I], Pos(JoinSeparator, Strings[I]) + Length(JoinSeparator), 255);
+ aMasterFields := aMasterFields + FieldName;
+ if I < Count - 1 then
+ aMasterFields := aMasterFields + ';';
+ end;
+ end;
+ finally
+ Free;
+ end;
+end;
+
+procedure TfrmFieldLinkDesigner.cboDetailIndexesClick(Sender: TObject);
+var
+ FieldLst,
+ OneField: TffShStr;
+ P: Integer;
+begin
+ btnClearClick(Self);
+ lstDetailFields.Clear;
+
+ { Populate detail fields, retain the field's position within the index }
+ with DetailTable do begin
+ FieldLst := IndexDefs[cboDetailIndexes.ItemIndex + 1].Fields;
+ P := 1;
+ repeat
+ FFShStrSplit(FieldLst, ';', OneField, FieldLst);
+ lstDetailFields.Items.AddObject(OneField, Pointer(P));
+ Inc(P);
+ until FieldLst = '';
+ end;
+ EnableAddButton(Self);
+end;
+
+procedure TfrmFieldLinkDesigner.EnableAddButton(Sender: TObject);
+begin
+ btnAdd.Enabled := (lstDetailFields.ItemIndex <> -1) and
+ (lstMasterFields.ItemIndex <> -1);
+end;
+
+procedure TfrmFieldLinkDesigner.EnableOKButton;
+begin
+ btnOK.Enabled := lstJoinedFields.Items.Count <> 0;
+end;
+
+procedure TfrmFieldLinkDesigner.btnAddClick(Sender: TObject);
+var
+ DI, MI: Integer;
+ JoinedFieldNos: TffJoinedFieldNos;
+begin
+ with lstDetailFields do begin
+ DI := ItemIndex;
+ JoinedFieldNos.DetailFieldNo := LongInt(Items.Objects[DI]);
+ end;
+ with lstMasterFields do begin
+ MI := lstMasterFields.ItemIndex;
+ JoinedFieldNos.MasterFieldNo := LongInt(Items.Objects[MI]);
+ end;
+ ReinsertField(lstJoinedFields.Items,
+ lstDetailFields.Items[DI] + JoinSeparator + lstMasterFields.Items[MI],
+ LongInt(JoinedFieldNos));
+(*
+ with lstJoinedFields.Items do begin
+ AddObject(lstDetailFields.Items[DI] +
+ JoinSeparator +
+ lstMasterFields.Items[MI],
+ Pointer(JoinedFieldNos));
+ end;
+*)
+ lstDetailFields.Items.Delete(DI);
+ lstMasterFields.Items.Delete(MI);
+
+ btnClear.Enabled := True;
+ EnableOKButton;
+end;
+
+procedure TfrmFieldLinkDesigner.lstJoinedFieldsClick(Sender: TObject);
+begin
+ btnDelete.Enabled := True;
+end;
+
+procedure TfrmFieldLinkDesigner.btnDeleteClick(Sender: TObject);
+begin
+ with lstJoinedFields do
+ if ItemIndex <> -1 then
+ RemoveJoinExpr(ItemIndex);
+end;
+
+procedure TfrmFieldLinkDesigner.btnClearClick(Sender: TObject);
+begin
+ with lstJoinedFields do
+ while Items.Count <> 0 do
+ RemoveJoinExpr(Items.Count - 1);
+end;
+
+procedure TfrmFieldLinkDesigner.RemoveJoinExpr(aIndex: Integer);
+var
+ P: Integer;
+ JoinExpr: AnsiString;
+ JoinedFieldNos: TffJoinedFieldNos;
+begin
+ with lstJoinedFields do begin
+ JoinExpr := Items[aIndex];
+ P := Pos(JoinSeparator, JoinExpr);
+ JoinedFieldNos := TffJoinedFieldNos(Items.Objects[aIndex]);
+ ReinsertField(lstDetailFields.Items,
+ Copy(JoinExpr, 1, P - 1),
+ JoinedFieldNos.DetailFieldNo);
+ ReinsertField(lstMasterFields.Items,
+ Copy(JoinExpr, P + Length(JoinSeparator), 255),
+ JoinedFieldNos.MasterFieldNo);
+ Items.Delete(aIndex);
+ if Items.Count = 0 then begin
+ btnDelete.Enabled := False;
+ btnClear.Enabled := False;
+ end;
+ end;
+ EnableOKButton;
+end;
+
+procedure TfrmFieldLinkDesigner.ReinsertField(aList: TStrings;
+ aFieldName: TffShStr;
+ aFieldNo: LongInt);
+var
+ I: Integer;
+begin
+ for I := 0 to aList.Count - 1 do
+ if aFieldNo < LongInt(aList.Objects[I]) then begin
+ aList.InsertObject(I, aFieldName, Pointer(aFieldNo));
+ Exit;
+ end;
+ aList.AddObject(aFieldName, Pointer(aFieldNo));
+end;
+
+procedure TfrmFieldLinkDesigner.btnOKClick(Sender: TObject);
+begin
+ { Leading detail fields cannot be left unassigned. Detail fields
+ must be assigned from left to right in the index order }
+ with lstDetailFields.Items do
+ if Count <> 0 then begin
+ if LongInt(Objects[0]) < TffJoinedFieldNos(lstJoinedFields.Items.Objects[0]).DetailFieldNo then
+ raise EffDatabaseError.CreateViaCodeFmt(ffccDesign_SLinkDesigner, [Strings[0]], False); {!!.06}
+ end;
+ ModalResult := mrOK;
+end;
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffclimex.pas b/components/flashfiler/sourcelaz/ffclimex.pas
new file mode 100644
index 000000000..dbf31bce3
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffclimex.pas
@@ -0,0 +1,1603 @@
+{*********************************************************}
+{* FlashFiler: Import/Export unit *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffclimex;
+
+interface
+
+uses
+ Windows,
+ DB,
+ DBConsts,
+ Forms,
+ SysUtils,
+ Classes,
+ IniFiles,
+ TypInfo,
+ ffsrbde,
+ ffdbbase,
+ ffdb,
+ ffstdate,
+ ffconst,
+ ffclbase,
+ fflldate,
+ ffllexcp,
+ ffconvff,
+ ffclintf,
+ ffllbase,
+ fflldict;
+
+const
+ DefDateMask = 'MM/DD/YYYY';
+ DefDblDelims = False;
+ DefDelimitor = '"';
+ DefError = 'ERROR';
+ DefExt = '.SCH';
+ DefMaxLineLength = 8*1024; { Max line length assumed by ASCII import routines }
+ DefSeparator = ',';
+ DefEpoch : Integer = 1969; {!!.05}
+ DefYieldInterval = 1;
+
+type
+ TffieFileType = (ftCSV, ftASCII, ftBINARY, ftBTF, ftVARBTF);
+
+ TffieNativeFieldType = (nftUnknown,
+ nftChar,
+ nftASCIIFloat,
+ nftASCIINumber,
+ nftASCIIBool,
+ nftASCIILongInt,
+ nftASCIIAutoInc,
+ nftASCIIDate,
+ nftASCIITime,
+ nftASCIITimestamp,
+ nftInt8,
+ nftInt16,
+ nftInt32,
+ nftUInt8,
+ nftUInt16,
+ nftUInt32,
+ nftAutoInc8,
+ nftAutoInc16,
+ nftAutoInc32,
+ nftReal,
+ nftSingle,
+ nftDouble,
+ nftExtended,
+ nftComp,
+ nftCurrency,
+ nftBoolean,
+ nftDateTime1,
+ nftDateTime2,
+ nftStDate,
+ nftStTime,
+ nftLString,
+ nftZString,
+ nftUnicode,
+ nftBinary);
+
+ {===== Schema File Classes =====}
+
+ TffieFieldItem = class
+ fiTargetFieldNo: SmallInt;
+ fiFieldName: TffDictItemName;
+ fiNativeTypeDesc: string[20];
+ fiNativeType: TffieNativeFieldType;
+ fiNativeSize: SmallInt;
+ fiNativeDecPl: SmallInt;
+ fiNativeOffset: SmallInt;
+ fiDateMask: string[25];
+ end;
+
+ TffSchemaFieldList = class(TffObject)
+ private
+ FList : TList;
+ function GetCount: Integer;
+ protected
+ function GetFieldItem(aIndex: Integer): TffieFieldItem;
+ public
+ constructor Create;
+ destructor Destroy; override;
+ procedure Add(aFieldItem : TffieFieldItem);
+ property Count : Integer read GetCount;
+ property Items[aIndex: Integer]: TffieFieldItem read GetFieldItem;
+ end;
+
+ TffSchemaFile = class(TIniFile)
+ protected {private}
+ FFilename: TFileName;
+ FFields: TffSchemaFieldList;
+ FMainSection: string;
+ FRecLength: LongInt;
+ FBTFDelFlag: Boolean;
+ function GetDateMask: string;
+ function GetDblDelims: Boolean;
+ function GetDelimiter: AnsiChar;
+ function GetFileType: TffieFileType;
+ function GetSeparator: AnsiChar;
+ procedure LoadFields;
+ procedure SetDateMask(aValue: string);
+ procedure SetDblDelims(aValue: Boolean);
+ procedure SetDelimiter(aValue: AnsiChar);
+ procedure SetFileType(aValue: TffieFileType);
+ procedure SetRecLength(aValue: LongInt);
+ procedure SetSeparator(aValue: AnsiChar);
+ public
+ constructor Create(aFileName: string);
+ destructor Destroy; override;
+ procedure BindDictionary(aDictionary: TffDataDictionary);
+ function GetSourceFieldPtr(aBufPtr: Pointer; aFieldNo: Integer): Pointer;
+ procedure MakeIntoDictionary(aDictionary: TffDataDictionary);
+ property BTFDelFlag: Boolean read FBTFDelFlag;
+ property DateMask: string read GetDateMask write SetDateMask;
+ property DblDelims: Boolean read GetDblDelims write SetDblDelims;
+ property Delimiter: AnsiChar read GetDelimiter write SetDelimiter;
+ property Fields: TffSchemaFieldList read FFields;
+ property FileType: TffieFileType read GetFileType write SetFileType;
+ property RecordLength: LongInt read FRecLength write SetRecLength;
+ property Section: string read FMainSection;
+ property Separator: AnsiChar read GetSeparator write SetSeparator;
+ end;
+
+ {===== Stream Classes for File I/O =====}
+
+ TffFileStream = class(TFileStream)
+ protected
+ protected
+ function GetNumRecords: LongInt; virtual; abstract;
+ function GetPercentCompleted: Word; virtual;
+ function GetRecordLength: LongInt; virtual; abstract;
+ public
+ function Read(var Buffer; Count: LongInt): LongInt; override;
+ function ReadRec(var Rec): Boolean; virtual; abstract;
+ property NumRecords: LongInt read GetNumRecords;
+ property PercentCompleted: Word read GetPercentCompleted;
+ property RecordLength: LongInt read GetRecordLength;
+ end;
+
+ TffFixedFileStream = class(TffFileStream)
+ protected {private}
+ FRecLength: LongInt;
+ FNumRecs: LongInt;
+ protected
+ function GetNumRecords: LongInt; override;
+ function GetRecordLength: LongInt; override;
+ public
+ constructor Create(const aFileName: string; aMode: Word; aRecLength: LongInt);
+ function ReadRec(var Rec): Boolean; override;
+ end;
+
+ TffFixedASCIIStream = class(TffFixedFileStream)
+ protected {private}
+ protected
+ CRLF: Boolean;
+ public
+ function ReadRec(var Rec): Boolean; override;
+ end;
+
+ TffFixedBTFStream = class(TffFixedFileStream)
+ protected {private}
+ FNumSkipped: LongInt;
+ DelFieldAvail: Boolean;
+ protected
+ public
+ constructor Create(const aFileName: string; aMode: Word; aDelFlag: Boolean);
+ function ReadRec(var Rec): Boolean; override;
+ property NumSkipped: LongInt read FNumSkipped;
+ end;
+
+ TffVaryingFileStream = class(TffFileStream)
+ protected
+ public
+ function ReadRec(var Rec): Boolean; override;
+ end;
+
+ {===== Field Conversion Classes to Parse Records =====}
+
+ TffFieldConverter = class
+ protected { private }
+ FBuffer: Pointer;
+ FBufLen: LongInt;
+ FSchema: TffSchemaFile;
+ FDict: TffDataDictionary;
+ public
+ procedure Init(aFieldBuf: Pointer;
+ aBufLen: LongInt;
+ aSchema: TffSchemaFile;
+ aDictionary: TffDataDictionary);
+ procedure AdjustMaskAndValue(aMask, aValue: TffShStr;
+ var aDateMask, aDateValue,
+ aTimeMask, aTimeValue: TffShStr);
+ { Translates a FF date/time mask into one suitable for SysTools conversion
+ routines (expands token characters out to the correct number of digitis
+ for each element) }
+ function ConvertField(aSourcePtr: Pointer;
+ aSourceType: TffieNativeFieldType;
+ aSourceSize: Integer;
+ aTargetFFType: TffFieldType;
+ aTargetSize: Integer;
+ aDateMask: TffShStr): TffResult;
+ end;
+
+ {===== Engine Classes =====}
+
+ TffieProgressPacket = record
+ ppNumRecs: DWORD;
+ ppTotalRecs: DWORD;
+ end;
+
+ TffieYieldEvent = procedure(aProgressPacket: TffieProgressPacket) of object;
+
+ TffInOutEngine = class
+ protected {private}
+ FDataFile: TffFullFileName;
+ FLogFile: TextFile;
+ FLogFilename: TFileName;
+ FLogCount: LongInt;
+ FSchema: TffSchemaFile;
+ FStream: TffFileStream;
+ FTerminated: Boolean;
+ FYieldInterval: Word;
+ FImportFilename: TFileName;
+ FOnYield: TffieYieldEvent;
+ protected
+ public
+ constructor Create(const aFileName: TffFullFileName;
+ aMode: Word);
+ destructor Destroy; override;
+ procedure PostLog(S: string);
+ procedure Terminate;
+
+ property LogFilename: TFilename read FLogFilename;
+ property LogCount: LongInt read FLogCount;
+ property Schema: TffSchemaFile read FSchema;
+ property Stream: TffFileStream read FStream;
+ property Terminated: Boolean read FTerminated;
+ property YieldInterval: Word read FYieldInterval write FYieldInterval;
+ property OnYield: TffieYieldEvent
+ read FOnYield write FOnYield;
+ end;
+
+ TffExportEngine = class(TffInOutEngine)
+ protected
+ public
+ end;
+
+ TffImportEngine = class(TffInOutEngine)
+ protected
+ FieldConverter: TffFieldConverter;
+ public
+ constructor Create(const aFileName: TffFullFileName);
+ { Creates the import engine. aFilename is the full path and
+ filename for the file to import. }
+ destructor Destroy; override;
+
+ procedure Import(aTable: TffTable; aBlockInserts: Word);
+ { Loads the import file into the given table. Importing only works with
+ an existing table. If the import is aborted, the partially loaded
+ table remains. }
+ end;
+
+implementation
+
+function StripQuotes(S: TffShStr): TffShStr;
+begin
+ S := FFShStrTrim(S);
+ if Copy(S, 1, 1) = '"' then
+ Delete(S, 1, 1);
+ if COpy(S, Length(S), 1) = '"' then
+ Delete(S, Length(S), 1);
+ Result := S;
+end;
+
+
+{ TffSchemaFieldList }
+
+procedure TffSchemaFieldList.Add(aFieldItem: TffieFieldItem);
+begin
+ FList.Add(aFieldItem);
+end;
+
+constructor TffSchemaFieldList.Create;
+begin
+ FList := TList.Create;
+end;
+
+destructor TffSchemaFieldList.Destroy;
+begin
+ FList.Free;
+end;
+
+function TffSchemaFieldList.GetCount: Integer;
+begin
+ Result := FList.Count;
+end;
+
+function TffSchemaFieldList.GetFieldItem(aIndex: Integer): TffieFieldItem;
+begin
+ Result := TffieFieldItem(FList.Items[aIndex]);
+end;
+
+{ TffSchemaFile }
+
+constructor TffSchemaFile.Create(aFileName: string);
+var
+ Dir: string;
+ FCB: TextFile;
+ Rec: TffShStr;
+begin
+ if not FileExists(aFileName) then
+ FFRaiseException(EffClientException, ffStrResClient, ffccImport_NoSchemaFile, [aFilename]);
+
+ { TIniFile will look in the WINDOWS directory if no path is given }
+ if ExtractFilePath(aFileName) = '' then begin
+ GetDir(0, Dir);
+ aFileName := Dir + '\' + aFileName;
+ end;
+ FFileName := aFileName;
+
+ inherited Create(FFileName);
+
+
+ {FMainSection := ChangeFileExt(ExtractFileName(aFileName), '');}
+ { Get section header }
+ FMainSection := '';
+ AssignFile(FCB, FFileName);
+ Reset(FCB);
+ try
+ repeat
+ ReadLn(FCB, Rec);
+ Rec := FFShStrTrim(Rec);
+ until Rec <> '';
+ if (Length(Rec) > 2) and (Rec[1] = '[') and (Rec[Length(Rec)] = ']') then
+ FMainSection := Copy(Rec, 2, Length(Rec) - 2)
+ else
+ FFRaiseException(EffClientException, ffStrResClient, ffccImport_BadSchemaHeader, [Rec]);
+ finally
+ CloseFile(FCB);
+ end;
+
+
+ FFields := TffSchemaFieldList.Create;
+ LoadFields;
+
+ { Check to see if the first field of a BTF file is the delete flag }
+ with Fields.Items[0] do
+ FBTFDelFlag := (FileType in [ftBTF, ftVARBTF]) and
+ (Uppercase(fiFieldName) = 'DELFLAG') and
+ (fiNativeType = nftInt32);
+
+ { Get the record length of a fixed ASCII file }
+ FRecLength := 0;
+ if FileType in [ftASCII, ftBINARY] then begin
+ FRecLength := ReadInteger(FMainSection, 'RECLENGTH', 0);
+ if FRecLength = 0 then begin
+
+ { reclength required for typed binary files }
+ if FileType = ftBinary then
+ FFRaiseExceptionNoData(EffClientException, ffStrResClient, ffccImport_RECLENGTHRequired);
+
+ { For fixed ASCII, reclength defined by size and position of
+ last field with an assumed CRLF }
+ with FFields.Items[FFields.Count - 1] do
+ FRecLength := fiNativeOffset + fiNativeSize + 2;
+ end;
+ end;
+end;
+
+destructor TffSchemaFile.Destroy;
+var
+ I: Integer;
+begin
+ if Assigned(FFields) then
+ for I := 0 to FFields.Count - 1 do
+ FFields.Items[I].Free;
+
+ FFields.Free;
+ inherited Destroy;
+end;
+
+procedure TffSchemaFile.BindDictionary(aDictionary: TffDataDictionary);
+var
+ I: Integer;
+ NoMatches: Boolean;
+begin
+ NoMatches := True;
+ for I := 0 to FFields.Count - 1 do
+ if not ((I = 0) and BTFDelFlag) then
+ with FFields.Items[I] do begin
+ fiTargetFieldNo := aDictionary.GetFieldFromName(fiFieldName);
+ if fiTargetFieldNo <> -1 then NoMatches := False;
+ end;
+ if NoMatches then
+ FFRaiseExceptionNoData(EffClientException, ffStrResClient, ffccImport_NoMatchingFields);
+end;
+
+function TffSchemaFile.GetDateMask: string;
+begin
+ Result := ReadString(FMainSection, 'DATEMASK', DefDateMask);
+end;
+
+function TffSchemaFile.GetDblDelims: Boolean;
+begin
+ Result := ReadBool(FMainSection, 'DBLDELIMS', DefDblDelims);
+end;
+
+function TffSchemaFile.GetDelimiter: AnsiChar;
+begin
+ Result := ReadString(FMainSection, 'DELIMITER', DefDelimitor)[1];
+end;
+
+function TffSchemaFile.GetFileType: TffieFileType;
+var
+ S: string;
+begin
+ S := ReadString(FMainSection, 'FILETYPE', '');
+ if S = '' then
+ FFRaiseExceptionNoData(EffClientException, ffStrResClient, ffccImport_FILETYPEMissing);
+ Result := TffieFileType(GetEnumValue(TypeInfo(TffieFileType), 'ft' + S));
+ if Ord(Result) = -1 then
+ FFRaiseExceptionNoData(EffClientException, ffStrResClient, ffccImport_FILETYPEInvalid);
+end;
+
+function TffSchemaFile.GetSeparator: AnsiChar;
+begin
+ Result := ReadString(FMainSection, 'SEPARATOR', DefSeparator)[1];
+end;
+
+procedure TffSchemaFile.LoadFields;
+
+ function BuildField(FieldEntry: TffShStr): TffieFieldItem;
+ var
+ FieldID: TffShStr;
+ Temp: TffShStr;
+ begin
+
+ { Parse the FIELD string from the schema file }
+ Result := TffieFieldItem.Create;
+ with Result do begin
+ fiTargetFieldNo := -1;
+
+ { Field ID }
+ FFShStrSplit(FieldEntry, '=', Temp, FieldEntry);
+ FieldID := FFShStrTrim(Temp);
+
+ { Field name }
+ FFShStrSplit(FieldEntry, ',', Temp, FieldEntry);
+ fiFieldName := FFShStrTrim(Temp);
+ if fiFieldName = '' then
+ FFRaiseException(EffClientException, ffStrResClient, ffccImport_BadFieldName, [FieldID, fiFieldName]);
+
+ { Import datatype }
+ FFShStrSplit(FieldEntry, ',', Temp, FieldEntry);
+ fiNativeTypeDesc := Uppercase(FFShStrTrim(Temp));
+
+ { Import field size }
+ FFShStrSplit(FieldEntry, ',', Temp, FieldEntry);
+ try
+ fiNativeSize := StrToInt(FFShStrTrim(Temp));
+ except
+ FFRaiseException(EffClientException, ffStrResClient, ffccImport_BadSize, [FieldID, Temp]);
+ end;
+
+ { Import decimal places }
+ FFShStrSplit(FieldEntry, ',', Temp, FieldEntry);
+ try
+ fiNativeDecPl := StrToInt(FFShStrTrim(Temp));
+ except
+ FFRaiseException(EffClientException, ffStrResClient, ffccImport_BadDecPl, [FieldID, Temp]);
+ end;
+
+ { Import offset }
+ FFShStrSplit(FieldEntry, ',', Temp, FieldEntry);
+ try
+ fiNativeOffset := StrToInt(FFShStrTrim(Temp));
+ except
+ FFRaiseException(EffClientException, ffStrResClient, ffccImport_BadOffset, [FieldID, Temp]);
+ end;
+
+ fiDateMask := '';
+
+ { The following tokens are valid for any import filetype }
+ if fiNativeTypeDesc = 'CHAR' then
+ fiNativeType := nftChar
+ else if fiNativeTypeDesc = 'DATE' then begin
+ fiNativeType := nftASCIIDate;
+ fiDateMask := StripQuotes(FieldEntry);
+ end
+ else if fiNativeTypeDesc = 'TIME' then begin
+ fiNativeType := nftASCIITime;
+ fiDateMask := StripQuotes(FieldEntry);
+ end
+ else if fiNativeTypeDesc = 'TIMESTAMP' then begin
+ fiNativeType := nftASCIITimeStamp;
+ fiDateMask := StripQuotes(FieldEntry);
+ end
+
+ { The following tokens are valid only for ASCII import files }
+ else if FileType in [ftASCII, ftCSV] then begin
+ if fiNativeTypeDesc = 'BOOL' then
+ fiNativeType := nftASCIIBool
+ else if fiNativeTypeDesc = 'FLOAT' then
+ fiNativeType := nftASCIIFloat
+ else if fiNativeTypeDesc = 'NUMBER' then
+ fiNativeType := nftASCIINumber
+ else if fiNativeTypeDesc = 'LONGINT' then
+ fiNativeType := nftASCIILongInt
+ else if fiNativeTypeDesc = 'AUTOINC' then
+ fiNativeType := nftASCIIAutoInc
+ else
+ FFRaiseException(EffClientException, ffStrResClient, ffccImport_BadFieldtype, [FieldID, fiNativeTypeDesc]);
+ end
+
+ { The following datatype tokens only apply to Binary and BTF files }
+ else if FileType in [ftBINARY, ftBTF, ftVARBTF] then begin
+ if fiNativeTypeDesc = 'BOOL' then
+ fiNativeType := nftBoolean
+ else if fiNativeTypeDesc = 'FLOAT' then begin
+ case fiNativeSize of
+ 4: fiNativeType := nftSingle;
+ 6: fiNativeType := nftReal;
+ 8: fiNativeType := nftDouble;
+ 10: fiNativeType := nftExtended;
+ else
+ FFRaiseException(EffClientException, ffStrResClient, ffccImport_BadFloatSize, [FieldID]);
+ end;
+ end
+ else if fiNativeTypeDesc = 'INTEGER' then begin
+ case fiNativeSize of
+ 1: fiNativeType := nftInt8;
+ 2: fiNativeType := nftInt16;
+ 4: fiNativeType := nftInt32;
+ 8: fiNativeType := nftComp;
+ else
+ FFRaiseException(EffClientException, ffStrResClient, ffccImport_BadIntegerSize, [FieldID]);
+ end;
+ end
+ else if fiNativeTypeDesc = 'UINTEGER' then begin
+ case fiNativeSize of
+ 1: fiNativeType := nftUInt8;
+ 2: fiNativeType := nftUInt16;
+ 4: fiNativeType := nftUInt32;
+ else
+ FFRaiseException(EffClientException, ffStrResClient, ffccImport_BadUIntegerSize, [FieldID]);
+ end;
+ end
+ else if fiNativeTypeDesc = 'AUTOINC' then begin
+ case fiNativeSize of
+ 1: fiNativeType := nftAutoInc8;
+ 2: fiNativeType := nftAutoInc16;
+ 4: fiNativeType := nftAutoInc32;
+ else
+ FFRaiseException(EffClientException, ffStrResClient, ffccImport_BadAutoIncSize, [FieldID]);
+ end;
+ end
+ else if fiNativeTypeDesc = 'STRING' then
+ fiNativeType := nftLString
+ else if fiNativeTypeDesc = 'ASCIIZ' then
+ fiNativeType := nftZString
+ else if fiNativeTypeDesc = 'UNICODE' then
+ fiNativeType := nftUnicode
+ else if fiNativeTypeDesc = 'CURRENCY' then
+ fiNativeType := nftCurrency
+ else if fiNativeTypeDesc = 'DATETIME1' then
+ fiNativeType := nftDateTime1
+ else if fiNativeTypeDesc = 'DATETIME2' then
+ fiNativeType := nftDateTime2
+ else if fiNativeTypeDesc = 'STDATE' then
+ fiNativeType := nftStDate
+ else if fiNativeTypeDesc = 'STTIME' then
+ fiNativeType := nftStTime
+ else if fiNativeTypeDesc = 'BINARY' then
+ fiNativeType := nftBinary
+ else
+ FFRaiseException(EffClientException, ffStrResClient, ffccImport_BadFieldtype, [FieldID, fiNativeTypeDesc]);
+ end
+ else
+ FFRaiseException(EffClientException, ffStrResClient, ffccImport_BadFieldtype, [FieldID, fiNativeTypeDesc]);
+ end;
+ end;
+var
+ SchemaFields: TStringList;
+ I: Integer;
+begin
+ SchemaFields := TStringList.Create;
+ try
+
+ { Get all the field descriptors into a stringlist }
+ SchemaFields.LoadFromFile(FFileName);
+
+ { Traverse the stringlist and grab all the field descriptors in order }
+ for I := 0 to SchemaFields.Count - 1 do
+ if FFCmpShStrUC(FFShStrTrim(SchemaFields[I]), 'FIELD', 5) = 0 then
+ Fields.Add(BuildField(SchemaFields[I]));
+ finally
+ SchemaFields.Free;
+ end;
+
+ if Fields.Count = 0 then
+ FFRaiseExceptionNoData(EffClientException, ffStrResClient, ffccImport_NoFields);
+end;
+
+function TffSchemaFile.GetSourceFieldPtr(aBufPtr: Pointer; aFieldNo: Integer): Pointer;
+begin
+ Result := nil;
+ case FileType of
+ ftASCII, ftBINARY, ftBTF:
+ Result := PChar(aBufPtr) + Fields.Items[aFieldNo].fiNativeOffset;
+ ftCSV: ;
+ ftVARBTF: ;
+ end;
+end;
+
+procedure TffSchemaFile.MakeIntoDictionary(aDictionary : TffDataDictionary);
+var
+ I : Integer;
+ FieldType : TffFieldType;
+ Units, DecPl : Integer;
+begin
+ for I := 0 to Fields.Count - 1 do
+ if not ((I = 0) and BTFDelFlag) then begin
+ with Fields.Items[I] do begin
+ Units := 0;
+ DecPl := 0;
+ case fiNativeType of
+ nftChar:
+ begin
+ if fiNativeSize = 1 then begin
+ FieldType := fftChar;
+ Units := 1;
+ end
+ else begin
+ FieldType := fftShortString;
+ Units := fiNativeSize;
+ end;
+ end;
+ nftASCIIFloat:
+ begin
+ FieldType := fftDouble;
+ DecPl := fiNativeDecPl;
+ end;
+ nftASCIINumber:
+ FieldType := fftInt16;
+ nftASCIIBool:
+ FieldType := fftBoolean;
+ nftASCIILongInt:
+ FieldType := fftInt32;
+ nftASCIIAutoInc:
+ FieldType := fftAutoInc;
+ nftASCIIDate:
+ FieldType := fftDateTime;
+ nftASCIITime:
+ FieldType := fftDateTime;
+ nftASCIITimestamp:
+ FieldType := fftDateTime;
+ nftInt8:
+ FieldType := fftInt8;
+ nftInt16:
+ FieldType := fftInt16;
+ nftInt32:
+ FieldType := fftInt32;
+ nftAutoInc8,
+ nftAutoInc16,
+ nftAutoInc32:
+ FieldType := fftAutoInc;
+ nftUInt8:
+ FieldType := fftByte;
+ nftUInt16:
+ FieldType := fftWord16;
+ nftUInt32:
+ FieldType := fftWord32;
+ nftReal:
+ begin
+ FieldType := fftDouble;
+ DecPl := fiNativeDecPl;
+ end;
+ nftSingle:
+ begin
+ FieldType := fftSingle;
+ DecPl := fiNativeDecPl;
+ end;
+ nftDouble:
+ begin
+ FieldType := fftDouble;
+ DecPl := fiNativeDecPl;
+ end;
+ nftExtended:
+ begin
+ FieldType := fftExtended;
+ DecPl := fiNativeDecPl;
+ end;
+ nftComp:
+ begin
+ FieldType := fftComp;
+ DecPl := fiNativeDecPl;
+ end;
+ nftCurrency:
+ begin
+ FieldType := fftCurrency;
+ DecPl := fiNativeDecPl;
+ end;
+ nftBoolean:
+ FieldType := fftBoolean;
+ nftDateTime1,
+ nftDateTime2:
+ FieldType := fftDateTime;
+ nftLString:
+ begin
+ if fiNativeSize = 2 then
+ FieldType := fftChar
+ else if fiNativeSize <= 256 then
+ FieldType := fftShortString
+ else FieldType := fftNullString;
+ Units := fiNativeSize - 1;
+ end;
+ nftZString:
+ begin
+ FieldType := fftNullString;
+ Units := fiNativeSize - 1;
+ end;
+ nftUnicode:
+ if fiNativeSize = 2 then
+ FieldType := fftWideChar
+ else begin
+ FieldType := fftWideString;
+ Units := (fiNativeSize - 2) div 2;
+ end;
+ nftStDate:
+ FieldType := fftStDate;
+ nftStTime:
+ FieldType := fftStTime;
+ else
+ FieldType :=fftByteArray;
+ Units := fiNativeSize;
+ end;
+
+ aDictionary.AddField(fiFieldName, '', FieldType, Units, DecPl, False, nil);
+ end;
+ end;
+end;
+
+procedure TffSchemaFile.SetDateMask(aValue: string);
+begin
+ WriteString(FMainSection, 'DATEMASK', aValue);
+end;
+
+procedure TffSchemaFile.SetDblDelims(aValue: Boolean);
+begin
+ WriteBool(FMainSection, 'DBLDELIMS', aValue);
+end;
+
+procedure TffSchemaFile.SetDelimiter(aValue: AnsiChar);
+begin
+ WriteString(FMainSection, 'DELIMITER', aValue);
+end;
+
+procedure TffSchemaFile.SetFileType(aValue: TffieFileType);
+var
+ S: string;
+begin
+ S := GetEnumName(TypeInfo(TffieFileType), Integer(aValue));
+ Delete(S, 1, 2);
+ WriteString(FMainSection, 'FILETYPE', S);
+end;
+
+procedure TffSchemaFile.SetRecLength(aValue: LongInt);
+begin
+ FRecLength := aValue;
+end;
+
+procedure TffSchemaFile.SetSeparator(aValue: AnsiChar);
+begin
+ WriteString(FMainSection, 'SEPARATOR', aValue);
+end;
+
+{ TffFileStream }
+
+function TffFileStream.GetPercentCompleted: Word;
+begin
+ Result := Round(Position * 100.0 / Size);
+end;
+
+function TffFileStream.Read(var Buffer; Count: LongInt): LongInt;
+begin
+ if (Position = Size - 1) then begin
+ Result := inherited Read(Buffer, 1);
+ if Byte(Buffer) = $1A {EOF} then
+ Result := 0;
+ end
+ else
+ Result := inherited Read(Buffer, Count);
+end;
+
+{ TffFixedFileStream }
+
+constructor TffFixedFileStream.Create(const aFileName: string;
+ aMode: Word;
+ aRecLength: LongInt);
+begin
+ inherited Create(aFileName, aMode);
+
+ if aRecLength > 0 then begin
+ FRecLength := aRecLength;
+ FNumRecs := Size div RecordLength;
+ end;
+end;
+
+function TffFixedFileStream.GetNumRecords: LongInt;
+begin
+ Result := FNumRecs;
+end;
+
+function TffFixedFileStream.GetRecordLength: LongInt;
+begin
+ Result := FRecLength;
+end;
+
+function TffFixedFileStream.ReadRec(var Rec): Boolean;
+begin
+ Result := Read(Rec, RecordLength) <> 0;
+end;
+
+{ TffFixedASCIIStream }
+
+function TffFixedASCIIStream.ReadRec(var Rec): Boolean;
+var
+ Buffer: Word;
+begin
+ { Determine if we need to account for a CR+LF at the end of each record }
+ if Position = 0 then begin
+ Result := Read(Rec, RecordLength - 2) <> 0;
+ Read(Buffer, 2);
+ CRLF := Buffer = $0A0D;
+ end
+ else begin
+ if CRLF then begin
+ Result := Read(Rec, RecordLength - 2) <> 0;
+ Position := Position + 2;
+ end
+ else
+ Result := Read(Rec, RecordLength) <> 0;
+ end;
+end;
+
+{ TffFixedBTFStream }
+
+constructor TffFixedBTFStream.Create(const aFileName: string;
+ aMode: Word;
+ aDelFlag: Boolean);
+begin
+ inherited Create(aFileName, aMode, 0);
+
+ DelFieldAvail := aDelFlag;
+
+ { Absorb the BTF header record }
+ Position := 8;
+ Read(FNumRecs, SizeOf(FNumRecs));
+ Read(FRecLength, SizeOf(FRecLength));
+ Position := FRecLength;
+end;
+
+function TffFixedBTFStream.ReadRec(var Rec): Boolean;
+begin
+ repeat
+ Inc(FNumSkipped);
+ Result := inherited ReadRec(Rec);
+ { Skip deleted records}
+ until not Result or (not DelFieldAvail or (LongInt(Rec) = 0));
+ Dec(FNumSkipped);
+end;
+
+{ TffVaryingFileStream }
+
+function TffVaryingFileStream.ReadRec(var Rec): Boolean;
+begin
+ Result := False;
+end;
+
+{ TffFieldConverter }
+
+procedure TffFieldConverter.Init(aFieldBuf: Pointer;
+ aBufLen: LongInt;
+ aSchema: TffSchemaFile;
+ aDictionary: TffDataDictionary);
+begin
+ FBuffer := aFieldBuf;
+ FBufLen := aBufLen;
+ FSchema := aSchema;
+ FDict := aDictionary;
+end;
+
+procedure TffFieldConverter.AdjustMaskAndValue(aMask, aValue: TffShStr;
+ var aDateMask, aDateValue,
+ aTimeMask, aTimeValue: TffShStr);
+{ Translates a FF date/time mask into one suitable for SysTools conversion
+routines (expands token characters out to the correct number of digitis
+for each element) }
+var
+ I, J, K, N: Integer;
+ ValueIdx: Integer;
+ LastDateCharAt,
+ LastTimeCharAt,
+ FirstDateCharAt,
+ FirstTimeCharAt: SmallInt;
+ MaskStart,
+ ValueStart: Integer;
+ NewMask: string;
+ Found: Boolean;
+ NoDelimitersFound: Boolean;
+begin
+ aDateMask := '';
+ aDateValue := '';
+ aTimeMask := '';
+ aTimevalue := '';
+ NewMask := '';
+
+ { Match number of digits in the mask with number of
+ digits in the data }
+ MaskStart := 1;
+ ValueStart := 1;
+ I := 1;
+ NoDelimitersFound := True;
+ while I <= Length(aMask) do begin
+ { look for the next delimiter in the mask }
+ if Pos(aMask[I], 'DMYhmst') = 0 then begin
+ NoDelimitersFound := False;
+ if I - MaskStart = 0 then begin
+ {Error}
+ Exit;
+ end;
+
+ { aMask[I] is our delimiter; find the position of this delimiter
+ in the value }
+ ValueIdx := ValueStart;
+ Found := (aValue[ValueIdx] = aMask[I]);
+ while not Found and (ValueIdx < Length(aValue)) do begin
+ Inc(ValueIdx);
+ Found := aValue[ValueIdx] = aMask[I];
+ end;
+
+ { Count the digits in this element of the value }
+ N := ValueIdx - ValueStart;
+ if not Found or (N = 0) then begin
+ {error}
+ Exit;
+ end;
+
+ NewMask := NewMask + FFShStrRepChar(aMask[I - 1], N) + aMask[I];
+ MaskStart := I + 1;
+ ValueStart := ValueIdx + 1;
+ end;
+ Inc(I);
+ end;
+
+ if NoDelimitersFound then
+ NewMask := aMask
+ else begin
+ { Handle end-of-mask case }
+ N := Length(aValue) - ValueStart + 1;
+ NewMask := NewMask + FFShStrRepChar(aMask[Length(aMask)], N);
+ end;
+
+ {-- Special handling for "seconds" token; truncate fractional seconds --}
+ for I := 1 to Length(NewMask) do
+ { find start of "seconds" mask }
+ if NewMask[I] = 's' then begin
+ { Find the end of the "seconds" mask }
+ J := I + 1;
+ while (NewMask[J] = 's') and (J <= Length(NewMask)) do Inc(J);
+
+ { Find first nondigit character in the "seconds" data }
+ K := I;
+ while (K < J) and (Pos(aValue[K], '0123456789') <> 0) do Inc(K);
+
+ if K <> J then begin
+ { Truncate mask and data }
+ Delete(NewMask, K, J - K);
+ Delete(aValue, K, J - K);
+ end;
+ Break;
+ end;
+
+ {-- Break up the date and time components --}
+ LastDateCharAt := 0;
+ LastTimeCharAt := 0;
+ FirstDateCharAt := 0;
+ FirstTimeCharAt := 0;
+
+ { Find the bounds of each component in the mask }
+ for I := 1 to Length(NewMask) do begin
+ if Pos(NewMask[I], 'DMY') <> 0 then
+ LastDateCharAt := I;
+ if Pos(NewMask[I], 'hmst') <> 0 then
+ LastTimeCharAt := I;
+
+ J := Length(NewMask) - I + 1;
+ if Pos(NewMask[J], 'DMY') <> 0 then
+ FirstDateCharAt := J;
+ if Pos(NewMask[J], 'hmst') <> 0 then
+ FirstTimeCharAt := J;
+ end;
+
+ { Return date components }
+ if FirstDateCharAt <> 0 then begin
+ aDateMask := Copy(NewMask, FirstDateCharAt, LastDateCharAt - FirstDateCharAt + 1);
+ aDateValue := Copy(aValue, FirstDateCharAt, LastDateCharAt - FirstDateCharAt + 1);
+ end;
+
+ { Return time components }
+ if FirstTimeCharAt <> 0 then begin
+ aTimeMask := Copy(NewMask, FirstTimeCharAt, LastTimeCharAt - FirstTimeCharAt + 1);
+ aTimeValue := Copy(aValue, FirstTimeCharAt, LastTimeCharAt - FirstTimeCharAt + 1);
+ end;
+end;
+
+function TffFieldConverter.ConvertField(aSourcePtr: Pointer;
+ aSourceType: TffieNativeFieldType;
+ aSourceSize: Integer;
+ aTargetFFType: TffFieldType;
+ aTargetSize: Integer;
+ aDateMask: TffShStr): TffResult;
+var
+ I: Integer;
+ MinUnits: Integer;
+ SourceFFType: TffFieldType;
+ vFloat: Extended;
+ vDouble: Double;
+ vSmallInt: SmallInt;
+ vLongInt: LongInt;
+ vDateValue,
+ vTimeValue: TffShStr;
+ vDateMask,
+ vTimeMask: TffShStr;
+ Da, Mo, Yr: Integer;
+ Hr, Mn, Sc: Integer;
+ IsBlank: Boolean;
+
+ function ExtractAsciiField(aPtr: PChar; aSize: SmallInt): TffShStr;
+ var
+ HoldChar: Char;
+ begin
+ HoldChar := aPtr[aSize];
+ aPtr[aSize] := #0;
+ Result := FFStrPasLimit(aPtr, aSize);
+ aPtr[aSize] := HoldChar;
+ end;
+
+begin
+ FillChar(FBuffer^, FBufLen, #0);
+ Result := 0;
+
+ { ASCII import fields that are totally blank are treated as nulls }
+ if FSchema.FileType = ftASCII then begin
+ IsBlank := True;
+ for I := 0 to aSourceSize - 1 do begin
+ IsBlank := FFCmpB(PByte(LongInt(aSourcePtr) + I)^, $20) = 0;
+ if not IsBlank then Break;
+ end;
+
+ if IsBlank then begin
+ Result := DBIERR_FIELDISBLANK;
+ Exit;
+ end;
+ end;
+
+ case aSourceType of
+ nftChar:
+ begin
+ MinUnits := FFMinI(aSourceSize, aTargetSize);
+ case aTargetFFType of
+ fftChar:
+ Char(FBuffer^) := Char(aSourcePtr^);
+ fftShortString, fftShortAnsiStr:
+ TffShStr(FBuffer^) := FFShStrTrimR(ExtractAsciiField(aSourcePtr, MinUnits));
+ fftNullString, fftNullAnsiStr:
+ Move(aSourcePtr^, FBuffer^, MinUnits);
+ fftWideChar:
+ WideChar(FBuffer^) := FFCharToWideChar(Char(aSourcePtr^));
+ fftWideString:
+ begin
+ { Note: the length of a "wide" field is the number of bytes
+ it occupies, not the number of wide chars it will hold. }
+ MinUnits := FFMinI(aSourceSize - 1, (aTargetSize div SizeOf(WideChar)) - 1);
+ FFShStrLToWideStr(FFShStrTrimR(TffShStr(aSourcePtr^)), FBuffer, MinUnits);
+ end;
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ nftASCIIFloat:
+ begin
+ vFloat := {!!.02}
+ StrToFloat(Trim(ExtractAsciiField(aSourcePtr, aSourceSize))); {!!.02}
+ case aTargetFFType of
+ fftSingle:
+ Single(FBuffer^) := vFloat;
+ fftDouble:
+ Double(FBuffer^) := vFloat;
+ fftExtended:
+ Extended(FBuffer^) := vFloat;
+ fftCurrency: Comp(FBuffer^) := vFloat * 10000.0; {!!.03}
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ nftASCIINumber:
+ begin
+ vSmallInt :=
+ StrToInt(Trim(ExtractAsciiField(aSourcePtr, aSourceSize))); {!!.02}
+ case aTargetFFType of
+ fftByte, fftInt8:
+ Byte(FBuffer^) := vSmallInt;
+ fftWord16, fftInt16:
+ TffWord16(FBuffer^) := vSmallInt;
+ fftWord32, fftInt32:
+ TffWord32(FBuffer^) :=
+ StrToInt(Trim(ExtractAsciiField(aSourcePtr, aSourceSize))); {!!.02}
+ fftComp:
+ Comp(FBuffer^) :=
+ StrToInt(Trim(ExtractAsciiField(aSourcePtr, aSourceSize))); {!!.02}
+ fftCurrency: begin
+ Comp(FBuffer^) :=
+ StrToInt(Trim(ExtractAsciiField(aSourcePtr, aSourceSize))); {!!.02}
+ Comp(FBuffer^) := Comp(FBuffer^) * 10000.0;
+ end;
+ fftAutoInc:
+ TffWord32(FBuffer^) := vSmallInt;
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ nftASCIIBool:
+ if aTargetFFType = fftBoolean then
+ Boolean(FBuffer^) := (Char(aSourcePtr^) in ['T', 't', 'Y', 'y', '1'])
+ else
+ Result := DBIERR_INVALIDFLDXFORM;
+
+ nftASCIILongInt,
+ nftASCIIAutoInc:
+ begin
+ vLongInt :=
+ StrToInt(Trim(ExtractAsciiField(aSourcePtr, aSourceSize))); {!!.02}
+ case aTargetFFType of
+ fftWord32, fftInt32:
+ TffWord32(FBuffer^) := vLongInt;
+ fftComp:
+ Comp(FBuffer^) := vLongInt;
+ fftCurrency: begin
+ Comp(FBuffer^) := vLongInt;
+ Comp(FBuffer^) := Comp(FBuffer^) * 10000.0;
+ end;
+ fftAutoInc:
+ TffWord32(FBuffer^) := vLongInt;
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ nftASCIIDate:
+ begin
+ AdjustMaskAndValue(aDateMask, ExtractAsciiField(aSourcePtr, aSourceSize),
+ vDateMask, vDateValue,
+ vTimeMask, vTimeValue);
+ DateStringToDMY(vDateMask, vDateValue, Da, Mo, Yr, DefEpoch);
+ if (Yr = 0) and (Mo = 0) and (Da = 0) then begin
+ Result := DBIERR_FIELDISBLANK;
+ Exit;
+ end;
+ {if Yr < 100 then Yr := Yr + DefEpoch;} {!!.05 - Deleted}
+ Yr := ResolveEpoch(Yr, DefEpoch); {!!.05 - Added}
+ case aTargetFFType of
+ fftDateTime:
+ { TDateTime values are stored in the buffer as Delphi 1 dates }
+ TDateTime(FBuffer^) := EncodeDate(Yr, Mo, Da) + 693594.0;
+ fftStDate:
+ TStDate(FBuffer^) := DMYToStDate(Da, Mo, Yr, DefEpoch);
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ nftASCIITime:
+ begin
+ AdjustMaskAndValue(aDateMask, ExtractAsciiField(aSourcePtr, aSourceSize),
+ vDateMask, vDateValue,
+ vTimeMask, vTimeValue);
+ TimeStringToHMS(vTimeMask, vTimeValue, Hr, Mn, Sc);
+ case aTargetFFType of
+ fftDateTime:
+ TDateTime(FBuffer^) := EncodeTime(Hr, Mn, Sc, 0);
+ fftStTime:
+ TStTime(FBuffer^) := HMSToStTime(Hr, Mn, Sc);
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ nftASCIITimestamp:
+ begin
+ AdjustMaskAndValue(aDateMask, ExtractAsciiField(aSourcePtr, aSourceSize),
+ vDateMask, vDateValue,
+ vTimeMask, vTimeValue);
+ DateStringToDMY(vDateMask, vDateValue, Da, Mo, Yr, DefEpoch);
+ if (Yr = 0) and (Mo = 0) and (Da = 0) then begin
+ Result := DBIERR_FIELDISBLANK;
+ Exit;
+ end;
+ {if Yr < 100 then Yr := Yr + DefEpoch;} {!!.05 - Deleted}
+ Yr := ResolveEpoch(Yr, DefEpoch); {!!.05 - Added}
+ TimeStringToHMS(vTimeMask, vTimeValue, Hr, Mn, Sc);
+ if Hr < 0 then Hr := 0;
+ if Mn < 0 then Mn := 0;
+ if Sc < 0 then Sc := 0;
+ case aTargetFFType of
+ fftDateTime:
+ { TDateTime values are stored in the buffer as Delphi 1 dates }
+ TDateTime(FBuffer^) := EncodeDate(Yr, Mo, Da) + 693594.0 +
+ EncodeTime(Hr, Mn, Sc, 0);
+ fftStDate:
+ TStDate(FBuffer^) := DMYToStDate(Da, Mo, Yr, DefEpoch);
+ fftStTime:
+ TStTime(FBuffer^) := HMSToStTime(Hr, Mn, Sc);
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ nftReal:
+ begin
+ vDouble := Real(aSourcePtr^);
+ case aTargetFFType of
+ fftSingle:
+ Single(FBuffer^) := vDouble;
+ fftDouble:
+ Double(FBuffer^) := vDouble;
+ fftExtended:
+ Extended(FBuffer^) := vDouble;
+ fftCurrency: begin
+ Comp(FBuffer^) := vDouble;
+ Comp(FBuffer^) := Comp(FBuffer^) * 10000.0;
+ end;
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ else begin
+
+ { All remaining datatypes are native to FlashFiler. Map datatypes and
+ use the FF restructure conversion routine. }
+
+ case aSourceType of
+ nftInt8: SourceFFType := fftInt8;
+ nftInt16: SourceFFType := fftInt16;
+ nftInt32: SourceFFType := fftInt32;
+ nftUInt8: SourceFFType := fftByte;
+ nftUInt16: SourceFFType := fftWord16;
+ nftUInt32: SourceFFType := fftWord32;
+ nftAutoInc8,
+ nftAutoInc16,
+ nftAutoInc32: SourceFFType := fftAutoInc;
+ nftSingle: SourceFFType := fftSingle;
+ nftDouble: SourceFFType := fftDouble;
+ nftExtended: SourceFFType := fftExtended;
+ nftComp: SourceFFType := fftComp;
+ nftCurrency: SourceFFType := fftCurrency;
+ nftBoolean: SourceFFType := fftBoolean;
+ nftDateTime1: SourceFFType := fftDateTime;
+ nftDateTime2:
+ begin
+ SourceFFType := fftDateTime;
+ { TDateTime values must be written to the record buffer as
+ Delphi 1 values }
+ TDateTime(aSourcePtr^) := TDateTime(aSourcePtr^) + 693594.0;
+ end;
+ nftLString: SourceFFType := fftShortString;
+ nftZString: SourceFFType := fftNullString;
+ nftUnicode:
+ if aSourceSize = 2 then SourceFFType := fftWideChar
+ else SourceFFType := fftWideString;
+ nftStDate: SourceFFType := fftStDate;
+ nftStTime: SourceFFType := fftStTime;
+ else
+ SourceFFType := fftByteArray;
+ end;
+
+ Result := FFConvertSingleField(aSourcePtr,
+ FBuffer,
+ SourceFFType,
+ aTargetFFType,
+ aSourceSize,
+ aTargetSize);
+ end;
+ end;
+end;
+
+{ TffInOutEngine }
+
+constructor TffInOutEngine.Create(const aFileName: TffFullFileName;
+ aMode: Word);
+begin
+ FLogFilename := ChangeFileExt(aFilename, '.LOG');
+ DeleteFile(FLogFilename);
+ FLogCount := 0;
+ FTerminated := False;
+
+ FYieldInterval := DefYieldInterval;
+ FImportFilename := aFileName;
+ FSchema := TffSchemaFile.Create(ChangeFileExt(aFileName, DefExt));
+ case FSchema.FileType of
+ ftASCII:
+ FStream := TffFixedASCIIStream.Create(aFileName, aMode, FSchema.RecordLength);
+ ftBINARY:
+ FStream := TffFixedFileStream.Create(aFilename, aMode, FSchema.RecordLength);
+ ftBTF:
+ begin
+ FStream := TffFixedBTFStream.Create(aFileName, aMode, FSchema.BTFDelFlag);
+ FSchema.RecordLength := FStream.RecordLength;
+ end;
+ ftCSV: ;
+ ftVARBTF: ;
+ end;
+end;
+
+destructor TffInOutEngine.Destroy;
+begin
+ if FLogCount <> 0 then
+ CloseFile(FLogFile);
+
+ FStream.Free;
+ FSchema.Free;
+ inherited Destroy;
+end;
+
+procedure TffInOutEngine.PostLog(S: string);
+begin
+ if LogCount = 0 then begin
+ AssignFile(FLogFile, FLogFilename);
+ Rewrite(FLogFile);
+ end;
+ WriteLn(FLogFile, S);
+ Inc(FLogCount);
+end;
+
+procedure TffInOutEngine.Terminate;
+begin
+ FTerminated := True;
+end;
+
+{ TffImportEngine }
+
+constructor TffImportEngine.Create(const aFileName: TffFullFileName);
+begin
+ inherited Create(aFileName, fmOpenRead);
+ FieldConverter := TffFieldConverter.Create;
+end;
+
+destructor TffImportEngine.Destroy;
+begin
+ FieldConverter.Free;
+ inherited Destroy;
+end;
+
+procedure TffImportEngine.Import(aTable: TffTable; aBlockInserts: Word);
+var
+ RecBuffer: PByteArray;
+ FldBuffer: Pointer;
+ FldBufLen: LongInt;
+ FFTable: TffTable;
+ F: Integer;
+ DateMask: TffShStr;
+ ProgressPacket: TffieProgressPacket;
+ Status: TffResult;
+ IsNull: Boolean;
+ DoExplicitTrans: Boolean;
+ InTransaction: Boolean;
+ AutoIncField: Integer;
+ AutoIncHighValue: TffWord32;
+begin
+ if aTable.CursorID = 0 then
+ DatabaseError(SDataSetClosed);
+
+ if not aTable.Active then
+ DatabaseError(SDataSetClosed);
+
+ { If we only have one insert per transaction, then let the server
+ do implicit transactions; it'll be faster }
+ if aBlockInserts = 0 then aBlockInserts := 1;
+ DoExplicitTrans := (aBlockInserts > 1);
+
+ FFTable := aTable;
+ Schema.BindDictionary(FFTable.Dictionary);
+
+ { See if we'll need to deal with an autoinc field }
+ AutoIncHighValue := 0;
+ if not FFTable.Dictionary.HasAutoIncField(AutoIncField) then
+ AutoIncField := -1;
+
+ { Find the largest target field }
+ FldBufLen := 0;
+ for F := 0 to Schema.Fields.Count - 1 do
+ with Schema.Fields.Items[F] do
+ if fiTargetFieldNo <> -1 then
+ FldBufLen := FFMaxDW(FFTable.Dictionary.FieldLength[fiTargetFieldNo], FldBufLen);
+
+ { Allocate field buffer }
+ FFGetMem(FldBuffer, FldBufLen);
+ try
+
+ { Bind the field converter }
+ FieldConverter.Init(FldBuffer, FldBufLen, Schema, FFTable.Dictionary);
+
+ { Allocate record buffer }
+ FFGetMem(RecBuffer, FStream.RecordLength);
+ try
+ with ProgressPacket do begin
+ ppTotalRecs := Stream.NumRecords;
+ ppNumRecs := 0;
+ end;
+
+ InTransaction := False;
+ try
+
+ { For each record in the import file... }
+ while FStream.ReadRec(RecBuffer^) do begin
+ Inc(ProgressPacket.ppNumRecs);
+
+ { Check to see if we need to send the progress status }
+ if (ProgressPacket.ppNumRecs mod YieldInterval) = 0 then
+ if Assigned(FOnYield) then begin
+ FOnYield(ProgressPacket);
+ Application.ProcessMessages;
+
+ { Check for user termination }
+ if Terminated then begin
+ if InTransaction then
+ aTable.Database.Rollback;
+ Exit;
+ end;
+ end;
+
+ { Blocks inserts within a transaction }
+ if DoExplicitTrans and not InTransaction then begin
+ aTable.Database.StartTransaction;
+ InTransaction := True;
+ end;
+
+ aTable.Insert;
+
+ { Set all fields to default (null) values }
+ aTable.ClearFields;
+
+ { Find all fields in the import file }
+ for F := 0 to Schema.Fields.Count - 1 do begin
+ with Schema.Fields.Items[F], FFTable.Dictionary do begin
+ if fiTargetFieldNo <> - 1 then begin
+
+ { If we have an ASCII date/time field, fetch the mask }
+ DateMask := '';
+ if fiNativeType in [nftASCIIDate,
+ nftASCIITime,
+ nftASCIITimestamp] then begin
+ DateMask := fiDateMask;
+ if DateMask = '' then DateMask := Schema.DateMask;
+ end;
+
+ { Convert the field into FF datatype }
+ Status := FieldConverter.ConvertField(Schema.GetSourceFieldPtr(RecBuffer, F),
+ fiNativeType,
+ fiNativeSize,
+ FieldType[fiTargetFieldNo],
+ FieldLength[fiTargetFieldNo],
+ DateMask);
+ with FFTable.Dictionary do begin
+ if Status = 0 then begin
+
+ { All's well, save the field data to the record buffer }
+ SetRecordField(fiTargetFieldNo,
+ Pointer(aTable.ActiveBuffer),
+ FldBuffer);
+
+ { Check for AutoInc field and retain largest value observed }
+ if fiTargetFieldNo = AutoIncField then begin
+ if FFCmpDW(PffWord32(FldBuffer)^, AutoIncHighValue) > 0 then
+ AutoIncHighValue := PffWord32(FldBuffer)^;
+ end;
+ end
+ else begin
+
+ { Assign null for this field }
+ SetRecordField(fiTargetFieldNo,
+ Pointer(aTable.ActiveBuffer),
+ nil);
+ case Status of
+ DBIERR_INVALIDFLDXFORM:
+ if ProgressPacket.ppNumRecs = 1 then
+ PostLog(Format('Field %s datatype %s is incompatible ' +
+ 'with target field datatype %s',
+ [fiFieldName,
+ fiNativeTypeDesc,
+ GetEnumName(TypeInfo(TffFieldType), Ord(FieldType[fiTargetFieldNo]))
+ ]));
+ end;
+ end;
+ end;
+ end;
+ end;
+ end;
+
+ { Clean up "required" fields that are null; assign binary zero value }
+ FillChar(FldBuffer^, FldBufLen, #0);
+ with FFTable.Dictionary do begin
+ for F := 0 to FieldCount - 1 do begin
+ GetRecordField(F, Pointer(aTable.ActiveBuffer), IsNull, nil);
+ if IsNull and FieldRequired[F] then
+ if not (FieldType[F] in [fftBLOB..ffcLastBLOBType]) then
+ { set nonBLOB fields to zeros }
+ SetRecordField(F, Pointer(aTable.ActiveBuffer), FldBuffer);
+ { Required BLOB fields are going to fail if not loaded
+ by the import }
+ end;
+ end;
+
+ { Post the changes }
+ aTable.Post;
+ if AutoIncField <> -1 then
+ Check(aTable.SetTableAutoIncValue(AutoIncHighValue));
+
+ { See if it's time to commit the transaction }
+ if InTransaction and ((ProgressPacket.ppNumRecs mod aBlockInserts) = 0) then begin
+ aTable.Database.Commit;
+ InTransaction := False;
+ end;
+ end;
+
+ { Residual inserts need to be posted? }
+ if InTransaction then
+ aTable.Database.Commit;
+ except
+ on E:Exception do begin
+ if InTransaction then
+ aTable.Database.Rollback;
+ raise;
+ end;
+ end;
+
+ { Check to see if we need to send the final progress status }
+ if (ProgressPacket.ppNumRecs mod YieldInterval) <> 0 then
+ if Assigned(FOnYield) then begin
+ FOnYield(ProgressPacket);
+ Application.ProcessMessages;
+ end;
+ finally
+ FFFreeMem(RecBuffer, FStream.RecordLength);
+ end;
+ finally
+ FFFreeMem(FldBuffer, FldBufLen);
+ end;
+end;
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffclintf.pas b/components/flashfiler/sourcelaz/ffclintf.pas
new file mode 100644
index 000000000..3e5a8f8df
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffclintf.pas
@@ -0,0 +1,349 @@
+{*********************************************************}
+{* FlashFiler: Non-native BDE Client Interface Routines *}
+{*********************************************************}
+{NOTE: }
+{ The FFDbiRoutines are slowly being phased out. Their }
+{ functions have been added to the appropriate FF }
+{ components. These functions are provided for backwards }
+{ compatiblity, and may be removed in the next major }
+{ version of FlashFiler. USE AT YOUR OWN RISK! }
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffclintf;
+
+interface
+
+uses
+ ffsrbde,
+ ffllbase,
+ fflldict,
+ ffllprot,
+ ffdb,
+ ffclbase,
+ Classes;
+
+function FFDbiAddAlias(aSession : TffSession;
+ const aAlias : TffName;
+ const aPath : TffPath) : TffResult;
+ {-Add a new permanent alias}
+ {-TffSession.AddAliasEx should now be used instead}
+
+function FFDbiAddFileBLOB(aTable : TffDataSet;
+ const iField : Word;
+ const aFileName : TffFullFileName) : TffResult;
+ {-Add a file BLOB to a FlashFiler table}
+ {-TffTable.AddFileBlobEx should now be used instead}
+
+function FFDbiAddIndex(aTable : TffBaseTable;
+ const aIndexDesc : TffIndexDescriptor;
+ var aTaskID : LongInt) : TffResult;
+ {-Add an index to a FlashFiler table}
+ {-TffTable.AddIndexEx should now be used instead}
+
+function FFDbiCreateTable(aDatabase : TffDatabase;
+ const aOverWrite : Boolean;
+ const aTableName : TffTableName;
+ aDictionary : TffDataDictionary) : TffResult;
+ {-Create a FlashfFiler table}
+ {-TffDatabase.CreateTableEx should now be used instead}
+
+function FFDbiDeleteAlias(aSession : TffSession;
+ const aAlias : TffName) : TffResult;
+ {-Delete an alias permanently}
+ {-TffSession.DeleteAliasEx should now be used instead}
+
+
+function FFDbiGetRecordBatch(aTable : TffDataSet;
+ const aRequestCount : LongInt;
+ var aReturnCount : LongInt;
+ pRecBuff : Pointer) : TffResult;
+ {-get a batch of records}
+ { pRecBuff must be allocated to hold RequestCount * RecordLength recs}
+ {-TffTable.GetRecordBatch should now be used instead}
+
+function FFDbiGetRecordBatchEx(aTable : TffDataSet;
+ const aRequestCount : LongInt;
+ var aReturnCount : LongInt;
+ pRecBuff : Pointer;
+ var aError : TffResult) : TffResult;
+ {-get a batch of records}
+ { pRecBuff must be allocated to hold RequestCount * RecordLength recs}
+ {-TffTable.GetRecordBatchEx should now be used instead}
+
+function FFDbiGetServerDateTime(aSession : TffSession;
+ var aServerNow : TDateTime) : TffResult;
+ {-get the current date and time at the server}
+ { NOTE: the returned date and time is with respect to the time zone
+ of the SERVER, not the CLIENT. If the server and client are
+ in different time zones, you are responsible for any
+ conversion.}
+ {-TffSession.GetServerDateTime should now be used instead}
+
+function FFDbiGetTaskStatus(aSession : TffSession;
+ const aTaskID : LongInt;
+ var aCompleted : Boolean;
+ var aStatus : TffRebuildStatus) : TffResult;
+ {-Query the status of a given pack, reindex, or restructure operation}
+ {-TffSession.GetTaskStatus should now be used instead}
+
+function FFDbiInsertRecordBatch(aTable : TffDataSet;
+ const aCount : LongInt;
+ pRecBuff : Pointer;
+ var aErrors : PffLongIntArray) : TffResult;
+ {-insert a batch of records}
+ {Errors must be allocated to hold Count * sizeof( LongInt )}
+ {-TffTable.InsertRecordBatch should now be used instead}
+
+function FFDbiOverrideFilter(aTable : TffDataSet;
+ aExprTree : pCANExpr;
+ aTimeout : TffWord32) : TffResult;
+ {-Used internally to override a cursor's existing filter with a new filter.
+ Occurs when a locate must used a ranged dataset. }
+
+function FFDbiPackTable(aDatabase : TffDatabase;
+ const aTableName : TffTableName;
+ var aTaskID : LongInt) : TffResult;
+ {-Recover disk space occupied by deleted records in a table}
+ {-TffDatabase.PackTable or}
+ {-TffTable.PackTableEx should now be used instead}
+
+function FFDbiReindexTable(aDatabase : TffBaseDatabase;
+ const aTableName : TffTableName;
+ const aIndexNum : Integer;
+ var aTaskID : LongInt) : TffResult;
+ {-Reconstruct key values for an index on a given table}
+ {-TffDatabase.ReindexTable or}
+ {-TffTable.ReindexTableEx should now be used instead}
+
+function FFDbiRestoreFilter(aTable : TffDataSet) : TffResult;
+ {-After a locate has finished overriding the server-side filter, this
+ method is used to restore the cursor's original filter. }
+
+function FFDbiRestructureTable(aDatabase : TffDatabase;
+ const aTableName : TffTableName;
+ aDictionary : TffDataDictionary;
+ aFieldMap : TStrings;
+ var aTaskID : LongInt) : TffResult;
+ {-Change the layout of an existing FF table}
+ {-TffDatabase.RestructureTable or}
+ {-TffTable.RestructureTableEx should now be used instead}
+
+
+function FFDbiSetFailSafeTransaction(aDatabase : TffBaseDatabase;
+ const aFailSafe : Boolean) : TffResult;
+ {-Enable/disable failsafe transactions}
+ {TffDatabase.FailSafe property should now be used instead}
+
+function FFDbiSetFilter(aTable : TffDataSet;
+ aExprTree : pCANExpr;
+ const aTimeout : TffWord32) : TffResult;
+ {-set the serverside filter for this cursor}
+ {-TffTable.SetFilterEx should now be used instead}
+
+procedure FFDbiSetProtocol(aProtocol : TffCommsProtocolClass);
+ {-change the protocol type of future FlashFiler client sessions}
+
+procedure FFDbiSetLoginRetries(const aRetries : Byte);
+ {-change the allowable number of login retries by a client}
+
+procedure FFDbiSetLoginParameters(const aUser : TffName;
+ const aPassword : TffName );
+ {-change the client username and password for future FF client sessions}
+
+function FFDbiSetTableAutoIncValue(aTable : TffDataSet;
+ const aValue: TffWord32) : TffResult;
+ {-Set the autoinc seed value for a FF table}
+ {TffTable.SetTableAutoIncValue should now be used instead}
+
+implementation
+uses
+ SysUtils;
+
+function FFDbiAddAlias(aSession : TffSession;
+ const aAlias : TffName;
+ const aPath : TffPath) : TffResult;
+begin
+ Result := aSession.AddAliasEx(aAlias, aPath, False); {!!.11}
+end;
+
+function FFDbiAddFileBLOB(aTable : TffDataSet;
+ const iField : Word;
+ const aFileName : TffFullFileName) : TffResult;
+begin
+ Result := aTable.AddFileBlob(iField, aFileName);
+end;
+
+function FFDbiAddIndex(aTable : TffBaseTable;
+ const aIndexDesc : TffIndexDescriptor;
+ var aTaskID : LongInt) : TffResult;
+begin
+ Result := aTable.AddIndexEx(aIndexDesc, aTaskID);
+end;
+
+function FFDbiCreateTable(aDatabase : TffDatabase;
+ const aOverWrite : Boolean;
+ const aTableName : TffTableName;
+ aDictionary : TffDataDictionary) : TffResult;
+begin
+ Result := aDatabase.CreateTable(aOverWrite, aTableName, aDictionary);
+end;
+
+function FFDbiDeleteAlias(aSession : TffSession;
+ const aAlias : TffName) : TffResult;
+begin
+ Result := aSession.DeleteAliasEx(aAlias);
+end;
+
+function FFDbiGetRecordBatch(aTable : TffDataSet;
+ const aRequestCount : LongInt;
+ var aReturnCount : LongInt;
+ pRecBuff : Pointer) : TffResult;
+begin
+ Result := aTable.GetRecordBatch(aRequestCount,
+ aReturnCount,
+ pRecBuff);
+end;
+
+function FFDbiGetRecordBatchEx(aTable : TffDataSet;
+ const aRequestCount : LongInt;
+ var aReturnCount : LongInt;
+ pRecBuff : Pointer;
+ var aError : TffResult) : TffResult;
+begin
+ Result := aTable.GetRecordBatchEx(aRequestCount,
+ aReturnCount,
+ pRecBuff,
+ aError );
+end;
+
+function FFDbiGetServerDateTime(aSession : TffSession;
+ var aServerNow : TDateTime) : TffResult;
+begin
+ Result := aSession.GetServerDateTime(aServerNow);
+end;
+
+
+function FFDbiGetTaskStatus(aSession : TffSession;
+ const aTaskID : LongInt;
+ var aCompleted : Boolean;
+ var aStatus : TffRebuildStatus) : TffResult;
+begin
+ Result := aSession.GetTaskStatus(aTaskID, aCompleted, aStatus);
+end;
+
+function FFDbiInsertRecordBatch(aTable : TffDataSet;
+ const aCount : LongInt;
+ pRecBuff : Pointer;
+ var aErrors : PffLongIntArray) : TffResult;
+begin
+ Result := aTable.InsertRecordBatch(aCount,
+ pRecBuff,
+ aErrors);
+end;
+
+function FFDbiOverrideFilter(aTable : TffDataSet;
+ aExprTree : pCANExpr;
+ aTimeout : TffWord32) : TffResult;
+begin
+ Result := aTable.OverrideFilterEx(aExprTree, aTimeout);
+end;
+
+function FFDbiPackTable(aDatabase : TffDatabase;
+ const aTableName : TffTableName;
+ var aTaskID : LongInt) : TffResult;
+begin
+ Result := aDatabase.PackTable(aTableName, aTaskID);
+end;
+
+function FFDbiReindexTable(aDatabase : TffBaseDatabase;
+ const aTableName : TffTableName;
+ const aIndexNum : Integer;
+ var aTaskID : LongInt) : TffResult;
+begin
+ Result := aDatabase.ReIndexTable(aTableName, aIndexNum, aTaskID);
+end;
+
+function FFDbiRestoreFilter(aTable : TffDataSet) : TffResult;
+begin
+ Result := aTable.RestoreFilterEx;
+end;
+
+function FFDbiRestructureTable(aDatabase : TffDatabase;
+ const aTableName : TffTableName;
+ aDictionary : TffDataDictionary;
+ aFieldMap : TStrings;
+ var aTaskID : LongInt) : TffResult;
+begin
+ Result := aDatabase.RestructureTable(aTableName,
+ aDictionary,
+ aFieldMap,
+ aTaskID);
+end;
+
+function FFDbiSetTableAutoIncValue(aTable : TffDataSet;
+ const aValue: TffWord32) : TffResult;
+begin
+ Result := aTable.SetTableAutoIncValue(aValue);
+end;
+
+function FFDbiSetFailSafeTransaction(aDatabase : TffBaseDatabase;
+ const aFailSafe : Boolean) : TffResult;
+begin
+ aDatabase.FailSafe := aFailSafe;
+ Result := DBIERR_NONE;
+end;
+
+function FFDbiSetFilter(aTable : TffDataSet;
+ aExprTree : pCANExpr;
+ const aTimeout : TffWord32) : TffResult;
+begin
+ Result := aTable.SetFilterEx(aExprTree, aTimeout);
+end;
+
+procedure FFDbiSetProtocol(aProtocol : TffCommsProtocolClass);
+begin
+ ffclProtocol := aProtocol;
+end;
+
+procedure FFDbiSetLoginRetries(const aRetries : Byte);
+begin
+ if aRetries > 0 then
+ ffclLoginRetries := aRetries;
+end;
+
+procedure FFDbiSetLoginParameters(const aUser : TffName;
+ const aPassword : TffName );
+begin
+ ffclUsername := aUser;
+ ffclPassword := aPassword;
+end;
+
+end.
+
diff --git a/components/flashfiler/sourcelaz/ffclplug.pas b/components/flashfiler/sourcelaz/ffclplug.pas
new file mode 100644
index 000000000..462208ab4
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffclplug.pas
@@ -0,0 +1,171 @@
+{*********************************************************}
+{* FlashFiler: Client plugin engine *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit FFClPlug;
+
+interface
+
+uses
+ Classes,
+ FFDB,
+ FFLLBase,
+ FFLLComm;
+
+type
+ TffClientPluginEngine = class(TffBasePluginEngine)
+ protected
+ FSession : TffSession;
+ FTimeout : Longint;
+
+ procedure cpSetSession(aSession : TffSession);
+
+ function ProcessRequest(aMsgID : Longint;
+ aTimeout : Longint;
+ aRequestData : Pointer;
+ aRequestDataLen : Longint;
+ aRequestDataType : TffNetMsgDataType;
+ var aReply : Pointer;
+ var aReplyLen : Longint;
+ aReplyType : TffNetMsgDataType) : TffResult;
+
+ function ProcessRequestNoReply(aMsgID : Longint;
+ aTimeout : Longint;
+ aRequestData : Pointer;
+ aRequestDataLen : Longint ) : TffResult;
+ public
+
+ constructor Create(aOwner : TComponent); override;
+ destructor Destroy; override;
+
+ procedure FFNotificationEx(const aOp : Byte; aFrom : TffComponent;
+ const aData : TffWord32); override;
+ { Method used to detect loss of connection. }
+
+
+ published
+
+ property Timeout : Longint
+ read FTimeout write FTimeout default 10000;
+
+ property Session : TffSession
+ read FSession write cpSetSession;
+
+ end;
+
+implementation
+
+uses
+ SysUtils,
+ Windows,
+ FFLLReq,
+ FFSrBDE;
+
+{===TffClientPluginEngine============================================}
+constructor TffClientPluginEngine.Create(aOwner : TComponent);
+begin
+ inherited;
+ FTimeout := 10000;
+end;
+{--------}
+destructor TffClientPluginEngine.Destroy;
+begin
+ if FSession <> nil then begin
+ FSession.FFRemoveDependent(Self);
+ FSession := nil;
+ end;
+ inherited;
+end;
+{--------}
+procedure TffClientPluginEngine.cpSetSession(aSession : TffSession);
+begin
+ if FSession = aSession then
+ Exit;
+
+ FFNotifyDependents(ffn_Deactivate);
+ if Assigned(FSession) then begin
+ FSession.FFRemoveDependent(Self);
+ FSession := nil;
+ end;
+
+ FSession := aSession;
+ if Assigned(FSession) then
+ FSession.FFAddDependent(Self);
+end;
+{--------}
+procedure TffClientPluginEngine.FFNotificationEx(const aOp : Byte;
+ aFrom : TffComponent;
+ const aData : TffWord32);
+begin
+ if (aFrom = FSession) then
+ if ((aOp = ffn_Destroy) or (aOp = ffn_Remove)) then begin
+ FFNotifyDependents(ffn_Deactivate);
+ FSession := nil;
+ end else if (aOp = ffn_Deactivate) then
+ FFNotifyDependents(ffn_Deactivate);
+end;
+{----------}
+type
+ TffSessionCracker = class(TffSession);
+{----------}
+function TffClientPluginEngine.ProcessRequest(aMsgID : longInt;
+ aTimeout : longInt;
+ aRequestData : Pointer;
+ aRequestDataLen : longInt;
+ aRequestDataType : TffNetMsgDataType;
+ var aReply : Pointer;
+ var aReplyLen : longInt;
+ aReplyType : TffNetMsgDataType
+ ) : TffResult;
+begin
+ Result := TffSessionCracker(FSession).ProcessRequest(aMsgID,
+ aTimeout,
+ aRequestData,
+ aRequestDataLen,
+ aRequestDataType,
+ aReply,
+ aReplyLen,
+ aReplyType);
+end;
+{----------}
+function TffClientPluginEngine.ProcessRequestNoReply(aMsgID : Longint;
+ aTimeout : Longint;
+ aRequestData : Pointer;
+ aRequestDataLen : Longint
+ ) : TffResult;
+begin
+ Result := TffSessionCracker(FSession).ProcessRequestNoReply(aMsgID,
+ aTimeout,
+ aRequestData,
+ aRequestDataLen);
+end;
+{====================================================================}
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffclreg.dcr b/components/flashfiler/sourcelaz/ffclreg.dcr
new file mode 100644
index 000000000..2b605b766
Binary files /dev/null and b/components/flashfiler/sourcelaz/ffclreg.dcr differ
diff --git a/components/flashfiler/sourcelaz/ffclreg.pas b/components/flashfiler/sourcelaz/ffclreg.pas
new file mode 100644
index 000000000..09231f0a1
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffclreg.pas
@@ -0,0 +1,832 @@
+{*********************************************************}
+{* FlashFiler: Property Editors for FF Client Components *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffclreg;
+
+interface
+
+procedure Register;
+
+implementation
+
+uses
+ {$IFDEF Delphi3}
+ Dialogs,
+ {$ENDIF}
+ {$IFDEF CBuilder3}
+ Dialogs,
+ {$ENDIF}
+ SysUtils,
+ Classes,
+ Controls,
+ Forms,
+ DB,
+ {$IFNDEF DCC4OrLater}
+ DBTables,
+ {$ENDIF}
+ {$IFDEF DCC6OrLater}
+ {$ifdef fpc}
+ PropEdits, ComponentEditors,
+ {$else}
+ DesignIntf, DesignEditors,
+ {$endif}
+ {$ELSE}
+ DsgnIntf,
+ {$ENDIF}
+ {$ifndef fpc}ExptIntf,{$endif}
+ //soner: ffclcoln,
+ ffclreng,
+ ffclsqle,
+ ffclbase,
+ ffconst,
+ ffdbbase,
+ ffdb,
+ ffllbase,
+ ffllgrid,
+ fflllgcy,
+ fflllog,
+ ffsreng,
+ ffclfldg,
+ //soner: ffclver,
+ ffsrcmd,
+ ffsrsec,
+ ffllthrd,
+ //soner: ffclexpt,
+ fflleng,
+ ffllcomm,
+ ffsqleng,
+ ffllcomp;
+{$ifdef fpc}
+{$R ffclreg.dcr}
+{$endif}
+
+{ TffFieldLinkProperty }
+type
+ TffFieldLinkProperty = class(TStringProperty)
+ public
+ procedure Edit; override;
+ function GetAttributes: TPropertyAttributes; override;
+ end;
+
+procedure TffFieldLinkProperty.Edit;
+var
+ Table : TffTable;
+ lMasterTable : TDataset;
+ lDetailIndex : TffShStr;
+ lDetailFields : TffShStr;
+ lMasterFields : TffShStr;
+begin
+ Table := GetComponent(0) as TffTable;
+ with Table do begin
+ if not Assigned(MasterSource) then {begin !!.06}
+ {$IFDEF Delphi3}
+ begin
+ ShowMessageFmt('The MasterSource property of ''%s'' must be linked to a DataSource', [Name]);
+ Exit;
+ end;
+ {$ENDIF}
+ {$IFDEF CBuilder3}
+ begin
+ ShowMessageFmt('The MasterSource property of ''%s'' must be linked to a DataSource', [Name]);
+ Exit;
+ end;
+ {$ENDIF}
+ RaiseFFErrorObjFmt(Table, ffccDesign_SLinkMasterSource, [Name]);
+ if not Assigned(MasterSource.DataSet) then
+ {$IFDEF Delphi3}
+ begin
+ ShowMessage('Unable to open the MasterSource Table');
+ Exit;
+ end;
+ {$ENDIF}
+ {$IFDEF CBuilder3}
+ begin
+ ShowMessage('Unable to open the MasterSource Table');
+ Exit;
+ end;
+ {$ENDIF}
+ RaiseFFErrorObj(Table, ffccDesign_SLinkMaster); {end !!.06}
+ lMasterTable := MasterSource.DataSet;
+ lDetailIndex := IndexName;
+ lDetailFields := IndexFieldNames;
+ lMasterFields := GetValue;
+ end;
+ if ShowFieldLinkDesigner(lMasterTable,
+ Table,
+ lDetailIndex,
+ lDetailFields,
+ lMasterFields) = mrOK then
+ with Table do begin
+ if lDetailIndex <> '' then
+ IndexName := lDetailIndex
+ else
+ IndexFieldNames := lDetailFields;
+ SetValue(lMasterFields);
+ end;
+end;
+
+function TffFieldLinkProperty.GetAttributes: TPropertyAttributes;
+begin
+ Result := [paDialog, paRevertable];
+end;
+
+{ TffDBStringProperty }
+
+type
+ TffDBStringProperty = class(TStringProperty)
+ protected
+ procedure GetValueList(List: TStrings); virtual;
+ public
+ function GetAttributes: TPropertyAttributes; override;
+ procedure GetValues(Proc: TGetStrProc); override;
+ end;
+
+procedure TffDBStringProperty.GetValueList(List: TStrings);
+begin
+ { Do nothing - avoid compiler hint }
+end;
+
+function TffDBStringProperty.GetAttributes: TPropertyAttributes;
+begin
+ Result := [paValueList, paSortList, paMultiSelect];
+end;
+
+procedure TffDBStringProperty.GetValues(Proc: TGetStrProc);
+var
+ i : Integer;
+ Values : TStringList;
+begin
+ Values := TStringList.Create;
+ try
+ Values.BeginUpdate;
+ try
+ GetValueList(Values);
+ for i := 0 to Pred(Values.Count) do
+ Proc(Values[i]);
+ finally
+ Values.EndUpdate;
+ end;
+ finally
+ Values.Free;
+ end;
+end;
+
+{ TffClientNameProperty }
+
+type
+ TffClientNameProperty = class(TffDBStringProperty)
+ public
+ procedure GetValueList(List: TStrings); override;
+ end;
+
+procedure TffClientNameProperty.GetValueList(List: TStrings);
+begin
+ GetFFClientNames(List);
+end;
+
+{ TffSessionNameProperty }
+
+type
+ TffSessionNameProperty = class(TffDBStringProperty)
+ public
+ procedure GetValueList(List: TStrings); override;
+ end;
+
+procedure TffSessionNameProperty.GetValueList(List: TStrings);
+begin
+ GetFFSessionNames(List);
+end;
+
+{ TffDatabaseNameProperty }
+
+type
+ TffDatabaseNameProperty = class(TffDBStringProperty)
+ public
+ procedure GetValueList(List: TStrings); override;
+ end;
+
+procedure TffDatabaseNameProperty.GetValueList(List: TStrings);
+var
+ S : TffSession;
+begin
+ S := (GetComponent(0) as TffDataset).Session;
+ if Assigned(S) then
+ GetFFDatabaseNames(S, List);
+end;
+
+{ TffAliasNameProperty }
+
+type
+ TffAliasNameProperty = class(TffDBStringProperty)
+ public
+ procedure GetValueList(List: TStrings); override;
+ end;
+
+procedure TffAliasNameProperty.GetValueList(List: TStrings);
+var
+ S : TffSession;
+begin
+ S := (GetComponent(0) as TffDatabase).Session;
+ if Assigned(S) then
+ S.GetAliasNames(List);
+end;
+
+{ TffTableNameProperty }
+
+type
+ TffTableNameProperty = class(TffDBStringProperty)
+ public
+ procedure GetValueList(List: TStrings); override;
+ end;
+
+procedure TffTableNameProperty.GetValueList(List: TStrings);
+var
+ DB : TffDatabase;
+begin
+ DB := TffDatabase((GetComponent(0) as TffTable).Database);
+ if Assigned(DB) then
+ DB.GetTableNames(List);
+end;
+
+
+{ TffIndexNameProperty }
+
+type
+ TffIndexNameProperty = class(TffDBStringProperty)
+ public
+ procedure GetValueList(List: TStrings); override;
+ end;
+
+procedure TffIndexNameProperty.GetValueList(List: TStrings);
+var
+ Table : TffTable;
+begin
+ Table := GetComponent(0) as TffTable;
+ if Assigned(Table) then
+ Table.GetIndexNames(List);
+end;
+
+{ TffIndexFieldNamesProperty }
+
+type
+ TffIndexFieldNamesProperty = class(TffDBStringProperty)
+ public
+ procedure GetValueList(List: TStrings); override;
+ end;
+
+procedure TffIndexFieldNamesProperty.GetValueList(List: TStrings);
+var
+ Table : TffTable;
+ i : Integer;
+begin
+ Table := GetComponent(0) as TffTable;
+ if Assigned(Table) then
+ with Table do begin
+ IndexDefs.Update;
+ for i := 0 to Pred(IndexDefs.Count) do
+ with IndexDefs[i] do
+ if not (ixExpression in Options) then
+ List.Add(Fields);
+ end;
+end;
+
+//{ TffDataSourceProperty } {!!.06 - Deleted - Start}
+//
+//type
+// TffDataSourceProperty = class(TffDBStringProperty)
+// public
+// function GetValue : string; override;
+// procedure GetValueList(List: TStrings); override;
+// procedure SetValue(const aValue : string); override;
+// end;
+//
+//function TffDataSourceProperty.GetValue : string;
+//var
+// i, j : integer;
+// Table : TffTable;
+// MrSrc : TDataSource;
+// Cmpnt : TComponent;
+// DataModule : TDataModule;
+// Form : TForm;
+//begin
+// Result := '';
+// Table := GetComponent(0) as TffTable;
+// if (Table <> nil) and (Table.MasterSource <> nil) then begin
+// MrSrc := Table.MasterSource;
+// {is the master source on the table's form? if so just return the
+// data source's name}
+// for i := 0 to pred(Table.Owner.ComponentCount) do begin
+// if (Table.Owner.Components[i] = MrSrc) then begin
+// Result := MrSrc.Name;
+// Exit;
+// end;
+// end;
+// {is the master source on one of the project's data modules? if so
+// return the data module name, period, and the data source's name}
+// for j := 0 to pred(Screen.DataModuleCount) do begin
+// DataModule := Screen.DataModules[j];
+// for i := 0 to pred(DataModule.ComponentCount) do begin
+// Cmpnt := DataModule.Components[i];
+// if (Cmpnt = MrSrc) {and
+// Designer.IsComponentLinkable(Cmpnt)} then begin
+// Result := DataModule.Name + '.' + MrSrc.Name;
+// Exit;
+// end;
+// end;
+// end;
+// {is the master source on one of the project's forms? if so return the form
+// name, period, and the data source's name}
+// for j := 0 to pred(Screen.FormCount) do begin
+// Form := Screen.Forms[j];
+// for i := 0 to pred(Form.ComponentCount) do begin
+// Cmpnt := Form.Components[i];
+// if (Cmpnt = MrSrc) {and
+// Designer.IsComponentLinkable(Cmpnt)} then begin
+// Result := Form.Name + '.' + MrSrc.Name;
+// Exit;
+// end;
+// end;
+// end;
+//
+// end;
+//end;
+//
+//procedure TffDataSourceProperty.GetValueList(List: TStrings);
+//var
+// i, j : integer;
+// Table : TffDataset;
+// Cmpnt : TComponent;
+// DataModule : TDataModule;
+// Form : TForm;
+//begin
+// Table := GetComponent(0) as TffDataset;
+// if (Table <> nil) and (Table.Owner <> nil) then begin
+// {first add all the names of the data sources on the table's owner}
+// for i := 0 to pred(Table.Owner.ComponentCount) do begin
+// Cmpnt := Table.Owner.Components[i];
+// if (Cmpnt is TDataSource) and
+// not Table.IsLinkedTo(TDataSource(Cmpnt)) and
+// (Cmpnt.Name <> '') then
+// List.Add(Cmpnt.Name);
+// end;
+// {then add all the names of the data sources on the project's data
+// modules, at least those that can be linked; prefix with the data
+// module name plus a period}
+// for j := 0 to pred(Screen.DataModuleCount) do begin
+// DataModule := Screen.DataModules[j];
+// for i := 0 to pred(DataModule.ComponentCount) do begin
+// if DataModule = Table.Owner then
+// Continue;
+// Cmpnt := DataModule.Components[i];
+// if (Cmpnt is TDataSource) and
+// not Table.IsLinkedTo(TDataSource(Cmpnt)) and
+// Designer.IsComponentLinkable(Cmpnt) and
+// (Cmpnt.Name <> '') then begin
+// List.Add(DataModule.Name + '.' + Cmpnt.Name);
+// end;
+// end;
+// end;
+//
+// for j := 0 to pred(Screen.FormCount) do begin
+// Form := Screen.Forms[j];
+// for i := 0 to pred(Form.ComponentCount) do begin
+// if Form = Table.Owner then
+// Continue;
+// Cmpnt := Form.Components[i];
+// if (Cmpnt is TDataSource) and
+// not Table.IsLinkedTo(TDataSource(Cmpnt)) and
+// Designer.IsComponentLinkable(Cmpnt) and
+// (Cmpnt.Name <> '') then begin
+// List.Add(Form.Name + '.' + Cmpnt.Name);
+// end;
+// end;
+// end;
+//
+// end;
+//end;
+//
+//procedure TffDataSourceProperty.SetValue(const aValue : string);
+//var
+// i, j : integer;
+// PosDot: integer;
+// Table : TffTable;
+// Cmpnt : TComponent;
+// DataModule : TDataModule;
+// DataModName: string;
+// DataSrcName: string;
+//begin
+// Table := GetComponent(0) as TffTable;
+// if (Table <> nil) and (Table.Owner <> nil) then begin
+// {assume we won't find the name; set the master source property
+// to nil}
+// Table.MasterSource := nil;
+// if (aValue <> '') then begin
+// {find the period in the master source name: its presence will
+// indicate whether the component is on the same form or a
+// separate data module}
+// PosDot := Pos('.', aValue);
+// if (PosDot = 0) {there is no period} then begin
+// {find the data source on this form}
+// for i := 0 to pred(Table.Owner.ComponentCount) do begin
+// Cmpnt := Table.Owner.Components[i];
+// if (Cmpnt is TDataSource) and
+// not Table.IsLinkedTo(TDataSource(Cmpnt)) and
+// (CompareText(Cmpnt.Name, aValue) = 0) then begin
+// Table.MasterSource := TDataSource(Cmpnt);
+// Exit;
+// end;
+// end;
+// end
+// else {there is a period} begin
+// DataModName := Copy(aValue, 1, pred(PosDot));
+// DataSrcName := Copy(aValue, succ(PosDot), length(aValue));
+// for j := 0 to pred(Screen.DataModuleCount) do begin
+// DataModule := Screen.DataModules[j];
+// if (CompareText(DataModule.Name, DataModName) = 0) then begin
+// for i := 0 to pred(DataModule.ComponentCount) do begin
+// Cmpnt := DataModule.Components[i];
+// if (Cmpnt is TDataSource) and
+// not Table.IsLinkedTo(TDataSource(Cmpnt)) and
+// Designer.IsComponentLinkable(Cmpnt) and
+// (CompareText(Cmpnt.Name, DataSrcName) = 0) then begin
+// Table.MasterSource := TDataSource(Cmpnt);
+// Exit;
+// end;
+// end;
+// end;
+// end;
+// end;
+// end;
+// end;
+//end; {!!.06 - Deleted - End}
+
+{ TffServerEngineProperty}
+type
+ TffServerEngineProperty = class(TffDBStringProperty)
+ public
+ function GetValue : string; override;
+ procedure GetValueList(List: TStrings); override;
+ procedure SetValue(const aValue : string); override;
+ end;
+
+function TffServerEngineProperty.GetValue : string;
+var
+ i, j : integer;
+ Client : TffBaseClient; {!!.03}
+ SvrEng : TffBaseServerEngine;
+ Cmpnt : TComponent;
+ DataModule : TDataModule;
+ Form : TForm;
+begin
+ Result := '';
+ Client := GetComponent(0) as TffBaseClient; {!!.03}
+ if Assigned(Client) and Assigned(Client.ServerEngine) then begin
+ if Client.OwnServerEngine then
+ Exit;
+
+ SvrEng := Client.ServerEngine;
+ {is the server engine on the table's form? if so just return the
+ data source's name}
+ for i := 0 to Pred(Client.Owner.ComponentCount) do
+ if (Client.Owner.Components[i] = SvrEng) then begin
+ Result := SvrEng.Name;
+ Exit;
+ end;
+
+
+ {is the master source on one of the project's data modules? if so
+ return the data module name, period, and the data source's name}
+ for j := 0 to Pred(Screen.DataModuleCount) do begin
+ DataModule := Screen.DataModules[j];
+ for i := 0 to pred(DataModule.ComponentCount) do begin
+ Cmpnt := DataModule.Components[i];
+ if (Cmpnt = SvrEng) {and
+ Designer.IsComponentLinkable(Cmpnt)} then begin
+ Result := DataModule.Name + '.' + SvrEng.Name;
+ Exit;
+ end;
+ end;
+ end;
+
+ {is the master source on one of the project's forms? if so return the form
+ name, period, and the data source's name}
+ for j := 0 to pred(Screen.FormCount) do begin
+ Form := Screen.Forms[j];
+ for i := 0 to pred(Form.ComponentCount) do begin
+ Cmpnt := Form.Components[i];
+ if (Cmpnt = SvrEng) {and
+ Designer.IsComponentLinkable(Cmpnt)} then begin
+ Result := Form.Name + '.' + SvrEng.Name;
+ Exit;
+ end;
+ end;
+ end;
+
+ end;
+end;
+
+procedure TffServerEngineProperty.GetValueList(List: TStrings);
+var
+ i, j : integer;
+ Client : TffBaseClient;
+ Cmpnt : TComponent;
+ DataModule : TDataModule;
+begin
+ Client := GetComponent(0) as TffBaseClient;
+ if (Client <> nil) and (Client.Owner <> nil) then begin
+ {first add all the names of the data sources on the table's owner}
+ for i := 0 to pred(Client.Owner.ComponentCount) do begin
+ Cmpnt := Client.Owner.Components[i];
+ if (Cmpnt is TffBaseServerEngine) and
+ (Cmpnt.Name <> '') then
+ List.Add(Cmpnt.Name);
+ end;
+
+ {then add all the names of the data sources on the project's data
+ modules, at least those that can be linked; prefix with the data
+ module name plus a period}
+ for j := 0 to pred(Screen.DataModuleCount) do begin
+ DataModule := Screen.DataModules[j];
+ for i := 0 to pred(DataModule.ComponentCount) do begin
+ Cmpnt := DataModule.Components[i];
+ if (Cmpnt is TffBaseServerEngine) and
+ {$ifndef fpc} Designer.IsComponentLinkable(Cmpnt) and {$endif} //Soner don't exits on lazarus
+ (Cmpnt.Name <> '') then begin
+ List.Add(DataModule.Name + '.' + Cmpnt.Name);
+ end;
+ end;
+ end;
+ end;
+end;
+
+procedure TffServerEngineProperty.SetValue(const aValue : string);
+var
+ i, j : integer;
+ PosDot: integer;
+ Client : TffBaseClient;
+ Cmpnt : TComponent;
+ DataModule : TDataModule;
+ DataModName: string;
+ SvrEngName: string;
+begin
+ Client := GetComponent(0) as TffBaseClient;
+ if (Client <> nil) and (Client.Owner <> nil) then begin
+ {assume we won't find the name; set the master source property
+ to nil}
+ Client.ServerEngine := nil;
+ if (aValue <> '') then begin
+ {find the period in the master source name: its presence will
+ indicate whether the component is on the same form or a
+ separate data module}
+ PosDot := Pos('.', aValue);
+ if (PosDot = 0) {there is no period} then begin
+ {find the data source on this form}
+ for i := 0 to pred(Client.Owner.ComponentCount) do begin
+ Cmpnt := Client.Owner.Components[i];
+ if (Cmpnt is TffBaseServerEngine) and
+ (CompareText(Cmpnt.Name, aValue) = 0) then begin
+ Client.ServerEngine := TffBaseServerEngine(Cmpnt);
+ Exit;
+ end;
+ end;
+ end
+ else {there is a period} begin
+ DataModName := Copy(aValue, 1, pred(PosDot));
+ SvrEngName := Copy(aValue, succ(PosDot), length(aValue));
+ for j := 0 to pred(Screen.DataModuleCount) do begin
+ DataModule := Screen.DataModules[j];
+ if (CompareText(DataModule.Name, DataModName) = 0) then begin
+ for i := 0 to pred(DataModule.ComponentCount) do begin
+ Cmpnt := DataModule.Components[i];
+ if (Cmpnt is TffBaseServerEngine) and
+ {$ifndef fpc} Designer.IsComponentLinkable(Cmpnt) and {$endif} //Soner don't exits on lazarus
+ (CompareText(Cmpnt.Name, SvrEngName) = 0) then begin
+ Client.ServerEngine := TffBaseServerEngine(Cmpnt);
+ Exit;
+ end;
+ end;
+ end;
+ end;
+ end;
+ end;
+ end;
+end;
+
+{ TffStringListProperty }
+type
+ TffStringListProperty = class(TClassProperty)
+ public
+ procedure Edit; override;
+ function GetAttributes: TPropertyAttributes; override;
+ end;
+
+procedure TffStringListProperty.Edit;
+begin
+ with TffSQLEditor.Create(Application) do
+ try
+ SQLLines := GetOrdValue;
+ ShowModal;
+ if ModalResult = mrOK then
+ SetOrdValue(SQLLines);
+ finally
+ Free;
+ end;
+end;
+
+function TffStringListProperty.GetAttributes : TPropertyAttributes;
+begin
+ Result := [paDialog, paRevertable];
+end;
+
+{$ifndef fpc} //soner ParamEditor not converted
+{ TffCollectionProperty }
+type
+ TffCollectionProperty = class(TClassProperty)
+ public
+ procedure Edit; override;
+ function GetAttributes : TPropertyAttributes; override;
+ end;
+
+procedure TffCollectionProperty.Edit;
+begin
+ FFShowParamEditor(Designer, TComponent(GetComponent(0)), GetName, GetOrdValue);
+end;
+
+function TffCollectionProperty.GetAttributes : TPropertyAttributes;
+begin
+ Result := [paDialog];
+end;
+{$endif}
+
+{TffServerEngineComponentEditor }
+type
+ TffServerEngineComponentEditor = class(TComponentEditor)
+ function GetVerbCount: integer; override;
+ function GetVerb(Index: integer): string; override;
+ procedure ExecuteVerb(Index: integer); override;
+ end;
+
+function TffServerEngineComponentEditor.GetVerbCount: integer;
+begin
+ Result := 1;
+end;
+
+function TffServerEngineComponentEditor.GetVerb(Index: integer): string;
+begin
+ case Index of
+ 0: Result := 'Shutdown server engine';
+ else
+ Result := 'ERROR!';
+ end;
+end;
+
+procedure TffServerEngineComponentEditor.ExecuteVerb(Index: integer);
+begin
+ case Index of
+ 0: TffStateComponent(Component).Shutdown;
+ else
+ Assert(False);
+ end;
+end;
+
+(*
+{ TffDatabaseEditor }
+
+type
+ TffDatabaseEditor = class(TComponentEditor)
+ procedure ExecuteVerb(Index: integer); override;
+ function GetVerb(Index: integer): string; override;
+ function GetVerbCount: integer; override;
+ end;
+
+procedure TffDatabaseEditor.ExecuteVerb(Index: integer);
+begin
+ case Index of
+ 0: if EditDatabase(TffDatabase(Component)) then Designer.Modified;
+ 1: ExploreDatabase(TffDatabase(Component));
+ end;
+end;
+
+function TffDatabaseEditor.GetVerb(Index: integer): string;
+begin
+ case Index of
+ 0: Result := LoadStr(SDatabaseEditor);
+ 1: Result := LoadStr(SExplore);
+ end;
+end;
+
+function TffDatabaseEditor.GetVerbCount: integer;
+begin
+ Result := 2;
+end;
+*)
+
+procedure Register;
+begin
+ { Register FlashFiler Client components }
+ RegisterComponents('FlashFiler Client', [
+ TffClient,
+ TffCommsEngine,
+ TffSession,
+ TffDatabase,
+ TffTable,
+ TffQuery,
+ TffStringGrid
+ ]);
+
+ { Register FlashFiler Server components }
+ RegisterComponents('FlashFiler Server', [
+ TffServerEngine,
+ TffRemoteServerEngine,
+ TffSQLEngine,
+ TffServerCommandHandler,
+ TffLegacyTransport,
+ TffEventLog,
+ TffSecurityMonitor,
+ TffThreadPool
+ ]);
+
+ {register the experts}
+ {$ifndef fpc} //Soner: I don't know how to do with lazarus
+ RegisterCustomModule(TffBaseEngineManager, TCustomModule);
+ RegisterLibraryExpert(TffEngineManagerWizard.Create);
+ {$endif}
+ {register the property editors...}
+ {...for clients}
+ RegisterPropertyEditor(TypeInfo(AnsiString), {!!.05}
+ TffBaseClient,
+ 'ServerEngine',
+ TffServerEngineProperty);
+ {...for sessions}
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffSession, 'CommsEngineName', TffClientNameProperty);
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffSession, 'ClientName', TffClientNameProperty);
+ {...for databases}
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffDatabase, 'AliasName', TffAliasNameProperty);
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffDatabase, 'SessionName', TffSessionNameProperty);
+ {...for tables}
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffTable, 'SessionName', TffSessionNameProperty);
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffTable, 'DatabaseName', TffDatabaseNameProperty);
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffTable, 'TableName', TffTableNameProperty);
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffTable, 'IndexName', TffIndexNameProperty);
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffTable, 'IndexFieldNames', TffIndexFieldNamesProperty);
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffTable, 'MasterFields', TffFieldLinkProperty);
+// RegisterPropertyEditor(TypeInfo(TDataSource), TffTable, 'MasterSource', TffDataSourceProperty); {!!.06}
+ {...for queries}
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffQuery, 'DatabaseName', TffDatabaseNameProperty);
+ {$ifndef fpc} //don't converted
+ RegisterPropertyEditor(TypeInfo(TParams), TffQuery, 'Params', TffCollectionProperty);
+ {$endif}
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffQuery, 'SessionName', TffSessionNameProperty);
+ RegisterPropertyEditor(TypeInfo(TStrings), TffQuery, 'SQL', TffStringListProperty);
+ {..for version number property}
+ {$ifndef fpc} //don't converted
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffClient, 'Version', TffVersionProperty);
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffCommsEngine, 'Version', TffVersionProperty);
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffSession, 'Version', TffVersionProperty);
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffDatabase, 'Version', TffVersionProperty);
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffTable, 'Version', TffVersionProperty);
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffQuery, 'Version', TffVersionProperty);
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffServerEngine, 'Version', TffVersionProperty);
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffRemoteServerEngine, 'Version', TffVersionProperty);
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffSQLEngine, 'Version', TffVersionProperty);
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffServerCommandHandler, 'Version', TffVersionProperty);
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffLegacyTransport, 'Version', TffVersionProperty);
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffEventLog, 'Version', TffVersionProperty);
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffSecurityMonitor, 'Version', TffVersionProperty);
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffThreadPool, 'Version', TffVersionProperty);
+ RegisterPropertyEditor(TypeInfo(AnsiString), TffStringGrid, 'Version', TffVersionProperty);
+ {$endif}
+ {register the component editors...}
+ RegisterComponentEditor(TffServerEngine, TffServerEngineComponentEditor);
+// RegisterComponentEditor(TffDatabase, TffDatabaseEditor);
+end;
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffclreg_original.dcr b/components/flashfiler/sourcelaz/ffclreg_original.dcr
new file mode 100644
index 000000000..095d07d58
Binary files /dev/null and b/components/flashfiler/sourcelaz/ffclreg_original.dcr differ
diff --git a/components/flashfiler/sourcelaz/ffclreng.pas b/components/flashfiler/sourcelaz/ffclreng.pas
new file mode 100644
index 000000000..517d9ca0c
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffclreng.pas
@@ -0,0 +1,6751 @@
+{*********************************************************}
+{* FlashFiler: Remote Server Engine Classes *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffclreng;
+
+interface
+uses
+ Windows,
+ dialogs,
+ Classes,
+ SysUtils,
+ ffllbase,
+ fflldict,
+ ffdtmsgq,
+ ffllcomm,
+ ffllcomp,
+ fflleng,
+ ffllexcp,
+ ffllreq,
+ ffnetmsg,
+ ffsrbde,
+ ffsrintm,
+ ffdbbase;
+
+type
+ {forward declarations}
+ TFFRemoteServerEngine = class;
+ {The TffRemoteServerEngine implements the TFFBaseServerEngine abstract
+ methods. It's method calls will initiate the process that will format
+ a message request to be sent to a remote server via a transport.
+ The TffRemoteServerEngine methods sometimes pass buffers without passing
+ the buffer length. However, the length must be known in order for the
+ message to be sent.
+
+ It is also possible for the TffRemoteServerEngine to be accessed by
+ multiple threads. We want to make sure that messages for one thread don't
+ wind up with another thread.
+
+ To handle cases such as these, the TffRemoteServerEngine needs to track
+ information specific to a cursor and client, respectively. To this
+ end we have created proxy classes to hold the information. For
+ example, a TffProxyCursor holds information specific to an open cursor.
+ A TffProxyClient holds information specific to an open client.
+
+ The TffRemoteServerEngine creates an instance of a proxy class when its
+ equivalent server-side object is opened. Instead of returning the
+ server-side object's ID to the object(s) using the remote engine, the
+ remote engine returns the pointers to its proxy objects. This scheme
+ allows TffRemoteServerEngine to derive a server-side ID from its proxy
+ object and allows it to maintain information required for its operation.
+
+ In general, all calls to remote server engine wind up calling a method on
+ a TffProxy class which in turn formats a request and sends it through
+ TffProxyClient.}
+
+ TFFProxyClientList = class;
+ TFFProxySession = class;
+ TFFProxySessionList = class;
+ TFFProxyDatabase = class;
+ TFFProxyDatabaseList = class;
+ TFFProxyCursor = class;
+ TFFProxyCursorList = class;
+ TffProxySQLStmt = class;
+ TffProxySQLStmtList = class;
+ {-End forward declarations}
+
+ {Creating/destroying and ownership issues.
+ The TFFProxyClient object will be created/destroyed and owned by it's
+ parent, a TFFRemoteServerEngine. The TFFRemoteServerEngine will be
+ responsible for keeping a list of the afore mentioned object.
+
+ The TFFProxySession object, and the TFFProxyDatabase object will be
+ created/destroyed and owned by it's parent, a TFFProxyClient. The
+ TFFProxyClient will be responsible for keeping a list of all instances
+ of the afore mentioned objects.
+
+ The TFFProxyCursor object will be created/destroyed and owned by
+ it's parent, a TFFProxyDatabase. The TFFProxyDatabase will be responsible
+ for keeping a list of all instances of the afore mentioned object.
+
+ The constructor for each of the client classes is resposible for
+ contacting the server, and retrieving an ID from the server. The parent
+ class will not manipulate the ServerID directly.
+
+ The destructor for each of the client classes is resposible for
+ tellint the server to release it's associated object.
+
+ If a proxy class "owns" any other classes then any owned classes must be
+ destroyed first.
+
+ In the end there should be no manipulation of ServerID's except in the
+ objects constructor. And no way to free a parent class without first
+ freeing dependent classes. }
+
+
+ {TFFProxyClient
+ The proxy client controls interaction between the remote server engine
+ and the transport. This class contains a message queue associated with
+ a specific client. All requests for data must go through this class'
+ ProcessRequest method. Instances where a reply from the server isn't
+ necessary can use the ProcessRequestNoReply method. }
+
+
+ TFFProxyClient = class(TffObject)
+ protected
+ pcSrClientID : TffClientID;
+ {An ID pointing to the associated TFFSrClient class on the server}
+
+ pcMsgQueue : TffDataMessageQueue;
+ {The message queue used to store replies to this client. }
+
+ pcCallbackMethod : TffReplyCallback;
+ {A Method pointer that will be passed to the transport when a
+ reply is requested.}
+
+ pcCurrentSession : TffProxySession;
+ {The current session as set by the SessionSetCurrent method}
+
+ pcDatabases : TFFProxyDatabaseList;
+ {The databases that are managed by the client}
+
+ pcForceClosed : Boolean;
+
+ pcTransport : TffBaseTransport;
+ {A reference to the RemoteServerEngine's transport. Added here for
+ purposes of speed, and readability.}
+
+ pcSessions : TFFProxySessionList;
+ {The sessions that are registered with the client. }
+
+ pcTimeout : Longint;
+ {The current timeout setting for the TFFBaseConnection Class. The
+ TFFBaseConnection class is resposible for updating this object when
+ it's published timeout value is changed.}
+
+ public
+ constructor Create(aTransport : TffBaseTransport;
+ aUserName : TFFName;
+ aPasswordHash : Longint;
+ aTimeOut : Longint);
+ destructor Destroy; override;
+
+ function IsReadOnly : Boolean;
+
+ function ProcessRequest(aMsgID : Longint;
+ aTimeout : Longint;
+ aRequestData : Pointer;
+ aRequestDataLen : Longint;
+ aRequestDataType : TffNetMsgDataType;
+ var aReply : Pointer;
+ var aReplyLen : Longint;
+ aReplyType : TffNetMsgDataType) : TffResult;
+ { Use the ProxessRequest method to submit a request that is routed to the
+ transport. This method does the following:
+
+ 1. Calls TffBaseTransport.Request with transportID = 0 and cookie
+ equal to Pointer(Self). At this point, the calling thread is
+ blocked until a reply is received from the server or a timeout
+ occurs.
+ 2. When the calling thread returns to this method, the reply has
+ been received and placed in the message queue by the
+ ProxyClientCallback procedure.
+ 3. Verify the message is the type that we expected.
+ 4. Put the message into the MessageQueue and exit.}
+
+
+ function ProcessRequestNoReply(aMsgID : Longint;
+ aTimeout : Longint;
+ aRequestData : Pointer;
+ aRequestDataLen : Longint) : TffResult;
+ { Use the ProxessRequestNoReply method to submit a request that is
+ routed to the transport. This method does the following:
+
+ 1. Calls TffBaseTransport.Post with transportID = 0 and reply mode
+ to waituntilsent. At this point, the calling thread is
+ blocked until the request has been sent to the server.}
+ function DatabaseClose(aDatabase : TffProxyDatabase) : TffResult;
+ function DatabaseOpen(const aAlias : TffName;
+ aOpenMode : TffOpenMode;
+ aShareMode : TffShareMode;
+ aTimeout : Longint;
+ var aDatabaseID : TffDatabaseID) : TffResult;
+ {Add a database to the pcDatabases list. The client will take
+ care of creating}
+
+ function DatabaseOpenNoAlias(const aPath : TffPath;
+ aOpenMode : TffOpenMode;
+ aShareMode : TffShareMode;
+ aTimeout : Longint;
+ var aDatabaseID : TffDatabaseID
+ ) : TffResult;
+ function GetRebuildStatus(const aRebuildID : Longint;
+ var aIsPresent : Boolean;
+ var aStatus : TffRebuildStatus) : TffResult;
+ function SetTimeout(const aTimeout : Longint) : TffResult;
+ function SessionAdd(var aSessionID : TffSessionID;
+ const aTimeout : Longint) : TffResult;
+ {Add a session to the pcSessions list. The client will take
+ care of creating the TFFProxySession object, whose ID will
+ be returned via aSessionID.}
+
+ function SessionCloseInactiveTables : TffResult; {!!.06}
+ { Close the inactive tables on the server. }
+
+ function SessionCount : Longint;
+ {Retrieve the number of sessions the client is managing.}
+
+ function SessionGetCurrent : TffProxySession;
+ {Retrieve the current session}
+
+ function SessionRemove(aSession : TFFProxySession) : TffResult;
+ {Remove the session from the list. The client will take destroy
+ the session, and remove it from the list}
+
+ function SessionSetCurrent(aSession : TFFProxySession) : TffResult;
+ {Set the current session}
+
+ function DatabaseAddAlias(const aAlias : TffName;
+ const aPath : TffPath;
+ aCheckSpace : Boolean) {!!.11}
+ : TffResult;
+ function DatabaseAliasList(aList : TList) : TffResult;
+ function DatabaseChgAliasPath(const aAlias : TffName;
+ const aNewPath : TffPath;
+ aCheckSpace : Boolean) {!!.11}
+ : TffResult;
+ function DatabaseDeleteAlias(const aAlias : TffName) : TffResult;
+ function DatabaseGetAliasPath(const aAlias : TffName;
+ var aPath : TffPath) : TffResult;
+ function DatabaseModifyAlias(const aAlias : TffName;
+ const aNewName : TffName;
+ const aNewPath : TffPath;
+ aCheckSpace : Boolean) {!!.11}
+ : TffResult;
+
+ function GetServerDateTime(var aDateTime : TDateTime) : TffResult;
+ {begin !!.10}
+ function GetServerSystemTime(var aSystemTime : TSystemTime)
+ : TffResult;
+ function GetServerGUID(var aGUID : TGUID) : TffResult;
+ function GetServerID(var aUniqueID : TGUID) : TffResult;
+ function GetServerStatistics(var Stats : TffServerStatistics)
+ : TffResult;
+ function GetCommandHandlerStatistics(const CmdHandlerIdx : Integer;
+ var Stats : TffCommandHandlerStatistics)
+ : TffResult;
+ function GetTransportStatistics(const CmdHandlerIdx : Integer;
+ const Transportidx : Integer;
+ var Stats : TffTransportStatistics)
+ : TffResult;
+ {end !!.10}
+
+
+{Begin !!.01}
+ function RemoteRestart : TffResult;
+ { Tell the remote server to restart. }
+
+ function RemoteStart : TffResult;
+ { Tell the remote server to startup. }
+
+ function RemoteStop : TffResult;
+ { Tell the remote server to stop. }
+{End !!.01}
+
+ {ReadOnly properties for the protected fields}
+ property CurrentSession : TFFProxySession
+ read SessionGetCurrent;
+ property Databases : TFFProxyDatabaseList
+ read pcDatabases;
+ property ForceClosed : Boolean
+ read pcForceClosed
+ write pcForceClosed;
+ property MsgQueue : TFFDataMessageQueue
+ read pcMsgQueue;
+ property Sessions : TFFProxySessionList
+ read pcSessions;
+ property SrClientID : TffClientID
+ read pcSrClientID;
+ property Transport : TFFBaseTransport
+ read pcTransport;
+ property Timeout : Longint
+ read pcTimeout;
+ end;
+
+ {List containing a reference for every ProxyClient owned by
+ a TFFRemoteServerEngine component.}
+ TFFProxyClientList = class(TffThreadList);
+
+
+ {The TFFProxySession is used primarily to keep track of the
+ the current Timeout setting, and the Server CursorID.
+ Unlike the TFFSession, the ProxySession does not manage a
+ set of Databases. TFFProxyDatabases, instead, are managed by
+ the ProxyClient class}
+ TFFProxySession = class(TFFObject)
+ protected
+ psSrSessionID : TFFSessionID;
+ {An ID pointing to the TFFSrSession object on the remote server}
+
+ psClient : TFFProxyClient;
+ {A reference to the client who owns this object}
+
+ psTimeout : Longint;
+ {Local storage for the current Session timeout setting. The TFFSession
+ object is resposible for keeping this value up to date.}
+
+ public
+ constructor Create(aClient : TFFProxyClient; aTimeout : Longint);
+
+ destructor Destroy; override;
+
+ function SetTimeout(aTimeout : Longint) : TffResult;
+
+ {ReadOnly properties for the protected fields}
+ property SrSessionID : TFFSessionID
+ read psSrSessionID;
+ property Client : TFFProxyClient
+ read psClient;
+ property Timeout : LongInt
+ read psTimeout;
+ end;
+
+ {List containing a reference for every ProxySesion owned by
+ a TFFProxyClient object.}
+ TFFProxySessionList = class(TffThreadList);
+
+
+ {The TFFProxyDatabase is responsible for basic Table maintenance. It also
+ keeps track of the the current Timeout setting, and the Server CursorID.
+ TFFProxyDatabase maintains a list of TFFProxyCursor objects.}
+ TFFProxyDatabase = class(TffObject)
+ protected
+ pdSrDatabaseID : TffDatabaseID;
+ {An ID pointing to the TffSrDatabase object on the remote server}
+
+ pdClient : TFFProxyClient;
+ {A reference to the client who owns this object}
+
+ pdInTrans : Boolean;
+ {Have we instantiated a tranaction? }
+
+ pdStmts : TffProxySQLStmtList;
+ {The SQL statements managed by this database}
+
+ pdTables : TFFProxyCursorList;
+ {The tables that are managed by the database}
+
+ pdTimeout : Longint;
+ {Local storage for the current Database timeout setting. The TFFDatabase
+ object is resposible for keeping this value up to date.}
+ public
+ constructor Create(aClient : TFFProxyClient;
+ aLocation : string;
+ aOpenMode : TffOpenMode;
+ aShareMode : TffShareMode;
+ aTimeout : Longint;
+ aIsAlias : Boolean);
+ destructor Destroy; override;
+ function GetDBFreeSpace(var aFreeSpace : Longint) : TffResult;
+ function QueryOpen(aCursorID : TffCursorID;
+ aOpenMode : TffOpenMode;
+ aShareMode : TffShareMode;
+ aTimeout : longInt;
+ aStream : TStream;
+ var aFinalCursorID : TffCursorID) : TffResult;
+ function SetTimeout(const aTimeout : Longint) : TffResult;
+ function SQLAlloc(const aTimeout : longInt;
+ var aStmtID : TffSqlStmtID) : TffResult;
+ function SQLExecDirect(aQueryText : PChar;
+ aOpenMode : TffOpenMode;
+ aTimeout : longInt;
+ var aCursorID : TffCursorID;
+ aStream : TStream) : TffResult;
+ function TableExists(const aTableName : TffTableName;
+ var aExists : Boolean) : TffResult;
+ function TableList(const aMask : TffFileNameExt;
+ aList : TList) : TffResult;
+ function TableLockedExclusive(const aTableName : TffTableName;
+ var aLocked : Boolean) : TffResult;
+ function TableAddIndex(const aCursorID : TffCursorID;
+ const aTableName : TffTableName;
+ const aIndexDesc : TffIndexDescriptor) : TffResult;
+ function TableBuild(aOverWrite : Boolean;
+ const aTableName : TffTableName;
+ aForServer : Boolean;
+ aDictionary : TffDataDictionary) : TffResult;
+ function TableDelete(const aTableName : TffTableName) : TffResult;
+ function TableDropIndex(aCursorID : TffCursorID;
+ const aTableName : TffTableName;
+ const aIndexName : TffDictItemName;
+ aIndexID : longint) : TffResult;
+ function TableEmpty(aCursorID : TffCursorID;
+ const aTableName : TffTableName) : TffResult;
+ function TableGetDictionary(const aTableName : TffTableName;
+ aForServer : Boolean;
+ aStream : TStream) : TffResult;
+ function TableClose(aCursor : TFFProxyCursor) : TffResult;
+ function TableOpen(const aTableName : TffTableName;
+ aForServer : Boolean;
+ aIndexName : TffName;
+ aIndexID : Longint;
+ aOpenMode : TffOpenMode;
+ aShareMode : TffShareMode;
+ aTimeout : Longint;
+ var aCursorID : TffCursorID;
+ aStream : TStream) : TffResult;
+ function TablePack(const aTableName : TffTableName;
+ var aRebuildID : Longint) : TffResult;
+ function TableRebuildIndex(const aTableName : TffTableName;
+ const aIndexName : TffName;
+ aIndexID : Longint;
+ var aRebuildID : Longint) : TffResult;
+ function TableRename(const aOldName : TffName;
+ const aNewName : TffName) : TffResult;
+ function TableRestructure(const aTableName : TffTableName;
+ aDictionary : TffDataDictionary;
+ aFieldMap : TffStringList;
+ var aRebuildID : Longint) : TffResult;
+ function TransactionStart(aFailSafe : Boolean) : TffResult;
+{Begin !!.10}
+ function TransactionStartWith(const aFailSafe : Boolean;
+ const aCursorIDs : TffPointerList) : TffResult;
+{End !!.10}
+ function TransactionCommit : TffResult;
+ function TransactionRollback : TffResult;
+
+ property Client : TFFProxyClient
+ read pdClient;
+ property InTrans : Boolean
+ read pdInTrans;
+ property SrDatabaseID : TFFDatabaseID
+ read pdSrDatabaseID;
+ property Tables : TffProxyCursorList
+ read pdTables;
+ property Timeout : Longint
+ read pdTimeout;
+ end;
+
+ TFFProxyDatabaseList = class(TffThreadList);
+
+ TFFProxyCursor = class(TffObject)
+ protected
+ prSrCursorID : TffCursorID;
+ prClient : TFFProxyClient;
+ prForServer : Boolean;
+ prShareMode : TffShareMode;
+ prTableName : TFFTableName;
+ prTimeout : Longint;
+ prDatabase : TFFProxyDatabase;
+
+ {State Variables}
+ prDictionary : TffDataDictionary;
+ prIndexID : Longint;
+ prIndexName : string;
+ prIsSQLCursor : boolean;
+ prPhyRecSize : Longint;
+ protected
+ function prGetBookmarkSize : Longint;
+ public
+ constructor Create(aDatabase : TFFProxyDatabase;
+ aCursorID : TffCursorID; {used by CursorClone, otherwise set to 0}
+ aTableName : string;
+ aForServer : Boolean;
+ aIndexName : string;
+ aIndexID : Longint;
+ aOpenMode : TffOpenMode;
+ aShareMode : TffShareMode;
+ aTimeout : LongInt;
+ aStream : TStream);
+
+ constructor CreateSQL(aDatabase : TffProxyDatabase;
+ aCursorID : TffCursorID;
+ aOpenMode : TffOpenMode;
+ aShareMode : TffShareMode;
+ aTimeout : longInt;
+ aStream : TStream);
+ { This constructor is used to construct a proxy cursor for an executed
+ SQL statement. }
+
+ destructor Destroy; override;
+ function BlobCreate(var aBlobNr : TFFInt64) : TFFResult;
+ function BLOBDelete(aBlobNr : TFFInt64) : TffResult;
+ function BLOBFree(aBlobNr : TffInt64;
+ aReadOnly : Boolean) : TFFResult;
+ function BLOBGetLength(aBlobNr : TffInt64;
+ var aLength : Longint) : TffResult;
+{Begin !!.03}
+ function BLOBListSegments(aBLOBNr : TffInt64;
+ aStream : TStream) : TffResult;
+{End !!.03}
+ function BLOBRead(aBlobNr : TffInt64;
+ aOffset : TffWord32; {!!.06}
+ aLen : TffWord32; {!!.06}
+ var aBLOB;
+ var aBytesRead : TffWord32) {!!.06}
+ : TffResult;
+ function BLOBTruncate(aBlobNr : TffInt64;
+ aBLOBLength : Longint) : TffResult;
+ function BLOBWrite(aBlobNr : TffInt64;
+ aOffset : Longint;
+ aLen : Longint;
+ var aBLOB) : TFFResult;
+ function CursorClone(aOpenMode : TFFOpenMode;
+ var aNewCursorID : TFFCursorID) : TFFResult;
+ function CompareBookmarks(aBookmark1 : PffByteArray;
+ aBookmark2 : PffByteArray;
+ var aCompResult : Longint) : TffResult;
+ function CopyRecords(aSrcCursor : TffProxyCursor; {!!.02}
+ aCopyBLOBs : Boolean) : TffResult; {!!.02}
+ function DeleteRecords : TffResult; {!!.06}
+ function GetBookmark(aBookmark : PffByteArray) : TffResult;
+ function GetBookmarkSize(var aSize : Longint) : TffResult;
+{Begin !!.03}
+ function ListBLOBFreeSpace(const aInMemory : Boolean;
+ aStream : TStream) : TffResult;
+{End !!.03}
+ function OverrideFilter(aExpression : pCANExpr;
+ aTimeout : TffWord32) : TffResult;
+ function ResetRange : TffResult;
+ function RestoreFilter : TffResult;
+ function SetFilter(aExpression : pCANExpr;
+ aTimeout : TffWord32) : TffResult;
+ function SetRange(aDirectKey : Boolean;
+ aFieldCount1 : Longint;
+ aPartialLen1 : Longint;
+ aKeyData1 : PffByteArray;
+ aKeyIncl1 : Boolean;
+ aFieldCount2 : Longint;
+ aPartialLen2 : Longint;
+ aKeyData2 : PffByteArray;
+ aKeyIncl2 : Boolean) : TffResult;
+ function SetTimeout(aTimeout : Longint) : TffResult;
+ function SetToBegin : TffResult;
+ function SetToBookmark(aBookmark : PffByteArray) : TffResult;
+ function SetToCursor(aSourceCursor : TFFProxyCursor) : TffResult;
+ function SetToEnd : TffResult;
+ function SetToKey(aSearchAction : TffSearchKeyAction;
+ aDirectKey : Boolean;
+ aFieldCount : Longint;
+ aPartialLen : Longint;
+ aKeyData : PffByteArray) : TffResult;
+ function SwitchToIndex(aIndexName : TffDictItemName;
+ aIndexID : Longint;
+ aPosnOnRec : Boolean) : TffResult;
+ function FileBLOBAdd(const aFileName : TffFullFileName;
+ var aBlobNr : TffInt64) : TffResult;
+ function RecordDelete(aData : PffByteArray) : TffResult;
+ function RecordDeleteBatch(aBMCount : Longint;
+ aBMLen : Longint;
+ aData : PffByteArray;
+ aErrors : PffLongintArray) : TffResult;
+ function RecordExtractKey(aData : PffByteArray;
+ aKey : PffByteArray) : TffResult;
+ function RecordGet(aLockType : TffLockType;
+ aData : PffByteArray) : TffResult;
+ function RecordGetBatch(aRecCount : Longint;
+ aRecLen : Longint;
+ var aRecRead : Longint;
+ aData : PffByteArray;
+ var aError : TffResult) : TffResult;
+ function RecordGetForKey(aDirectKey : Boolean;
+ aFieldCount : Longint;
+ aPartialLen : Longint;
+ aKeyData : PffByteArray;
+ aData : PffByteArray;
+ aFirstCall : Boolean) : TffResult;
+ function RecordGetNext(aLockType : TffLockType;
+ aData : PffByteArray) : TffResult;
+ function RecordGetPrior(aLockType : TffLockType;
+ aData : PffByteArray) : TffResult;
+ function RecordInsert(aLockType : TffLockType;
+ aData : PffByteArray) : TffResult;
+ function RecordInsertBatch(aRecCount : Longint;
+ aRecLen : Longint;
+ aData : PffByteArray;
+ aErrors : PffLongintArray) : TffResult;
+ function RecordIsLocked(aLockType : TffLockType;
+ var aIsLocked : boolean) : TffResult;
+ function RecordModify(aData : PffByteArray;
+ aRelLock : Boolean) : TffResult;
+ function RecordRelLock(aAllLocks : Boolean) : TffResult;
+ function TableGetAutoInc(var aValue : TffWord32) : TffResult;
+ function TableGetRecCount(var aRecCount : Longint) : TffResult;
+ function TableGetRecCountAsync(var aTaskID : Longint) : TffResult; {!!.07}
+ function TableIsLocked(aLockType : TffLockType;
+ var aIsLocked : Boolean) : TffResult;
+ function TableLockAcquire(aLockType : TffLockType) : TffResult;
+ function TableLockRelease(aAllLocks : Boolean) : TffResult;
+ function TableSetAutoInc(aValue : TffWord32) : TffResult;
+
+ property Client : TFFProxyClient
+ read prClient;
+ property SrCursorID : TffCursorID
+ read prSrCursorID;
+ property Timeout : Longint
+ read prTimeout;
+ property BookmarkSize : longint
+ read prGetBookmarkSize;
+ property Database : TFFProxyDatabase
+ read prDatabase;
+ property Dictionary : TffDataDictionary
+ read prDictionary;
+ property IndexID : Longint
+ read prIndexID;
+ property PhysicalRecordSize : Longint
+ read prPhyRecSize;
+
+ end;
+
+ TFFProxyCursorList = class(TffThreadList);
+
+ TffProxySQLStmt = class(TffObject)
+ protected {private}
+
+ psClient : TffProxyClient;
+ { The proxy client through which requests are routed. }
+
+ psDatabase : TffProxyDatabase;
+ { The proxy database with which the SQL statement is associated. }
+
+ psSrStmtID : TffSqlStmtID;
+ { The actual statement ID. }
+
+ psTimeout : longInt;
+ { The SQL statement's timeout (in milliseconds). }
+
+ public
+ {creation/destruction}
+ constructor Create(aDatabase : TffProxyDatabase; const aTimeout : longInt);
+ destructor Destroy; override;
+
+ function Exec(aOpenMode : TffOpenMode;
+ var aCursorID : TffCursorID;
+ aStream : TStream) : TffResult;
+
+ function Prepare(aQueryText: PChar; aStream : TStream) : TffResult;
+
+ function SetParams(aNumParams : Word;
+ aParamDescs : Pointer;
+ aDataBuffer : PffByteArray;
+ aDataLen : Longint;
+ aStream : TStream) : TffResult;
+
+ property Database : TffProxyDatabase read psDatabase;
+
+ property SrStmtID : TffSqlStmtID read psSrStmtID;
+ { The statement ID returned by the server engine. }
+
+ end;
+
+ TffProxySQLStmtList = class(TffThreadList);
+
+ TFFRemoteServerEngine = class(TffIntermediateServerEngine)
+ private
+ protected {private}
+ rsClientList : TFFProxyClientList;
+ rsTimeout : TffWord32;
+ rsTransport : TffBaseTransport;
+{Begin !!.06}
+ function ProcessRequest(aClientID : TffClientID;
+ aMsgID : Longint;
+ aTimeout : Longint;
+ aRequestData : Pointer;
+ aRequestDataLen : Longint;
+ aRequestDataType : TffNetMsgDataType;
+ var aReply : Pointer;
+ var aReplyLen : Longint;
+ aReplyType : TffNetMsgDataType) : TffResult; override;
+ { Backdoor method for sending a request to a server engine.
+ Should only be implemented by remote server engines. }
+
+ function ProcessRequestNoReply(aClientID : TffClientID;
+ aMsgID : Longint;
+ aTimeout : Longint;
+ aRequestData : Pointer;
+ aRequestDataLen : Longint ) : TffResult; override;
+ { Backdoor method for sending a request, no reply expected, to a
+ server engine. Should only be implemented by remote server engines. }
+{End !!.06}
+ procedure rsSetTransport(const Value : TFFBaseTransport);
+// protected {!!.01 - Start - Made public}
+// {validation and checking}
+// function CheckClientIDAndGet(aClientID : TffClientID;
+// var aClient : TffProxyClient) : TffResult;
+// function CheckSessionIDAndGet(aClientID : TffClientID;
+// aSessionID : TffSessionID;
+// var aClient : TffProxyClient;
+// var aSession : TffProxySession) : TffResult;
+// function CheckDatabaseIDAndGet(aDatabaseID : TffDatabaseID;
+// var aDatabase : TffProxyDatabase) : TffResult;
+// {-Find the database specified by aDatabaseID. }
+//
+// function CheckCursorIDAndGet(aCursorID : TffCursorID;
+// var aCursor : TffProxyCursor) : TffResult;
+// {-Find the cursor specified by aCursorID. }
+//
+// function CheckStmtIDAndGet(aStmtID : TffSqlStmtID;
+// var aStmt : TffProxySQLStmt) : TffResult;
+// {-Find the statement specified by aStmtID. } {!!.01 - End}
+
+ protected
+ {State methods}
+ procedure scInitialize; override;
+ procedure scPrepareForShutdown; override;
+ procedure scShutdown; override;
+ procedure scStartup; override;
+ function bseGetAutoSaveCfg : Boolean; override;
+ function bseGetReadOnly : Boolean; override;
+ procedure bseSetAutoSaveCfg(aValue : Boolean); override; {!!.01}
+ procedure bseSetReadOnly(aValue : Boolean); override; {!!.01}
+ public
+{Begin !!.07}
+ { Event logging }
+ procedure Log(const aMsg : string); override;
+ {-Use this method to log a string to the event log. }
+
+ procedure LogAll(const Msgs : array of string); override;
+ {-Use this method to log multiple strings to the event log. }
+
+ procedure LogFmt(const aMsg : string; args : array of const); override;
+ {-Use this method to log a formatted string to the event log. }
+{End !!.07}
+
+{Begin !!.01 - moved from protected section}
+ {validation and checking}
+ function CheckClientIDAndGet(aClientID : TffClientID;
+ var aClient : TffProxyClient) : TffResult;
+ function CheckSessionIDAndGet(aClientID : TffClientID;
+ aSessionID : TffSessionID;
+ var aClient : TffProxyClient;
+ var aSession : TffProxySession) : TffResult;
+ function CheckDatabaseIDAndGet(aDatabaseID : TffDatabaseID;
+ var aDatabase : TffProxyDatabase) : TffResult;
+ {-Find the database specified by aDatabaseID. }
+
+ function CheckCursorIDAndGet(aCursorID : TffCursorID;
+ var aCursor : TffProxyCursor) : TffResult;
+ {-Find the cursor specified by aCursorID. }
+
+ function CheckStmtIDAndGet(aStmtID : TffSqlStmtID;
+ var aStmt : TffProxySQLStmt) : TffResult;
+ {-Find the statement specified by aStmtID. }
+{End !!.01}
+
+ {creation/destruction}
+ constructor Create(aOwner : TComponent); override;
+ destructor Destroy; override;
+ procedure FFNotificationEx(const AOp : Byte; AFrom : TffComponent;
+ const AData : TffWord32); override;
+
+ function GetDefaultClient : TFFProxyClient;
+
+ procedure GetServerNames(aList : TStrings;
+ aTimeout : Longint); override;
+
+ procedure ForceClosing(const aClientID : TffClientID);
+
+{Begin !!.01}
+ function RemoteRestart(const aClientID : TffClientID) : TffResult;
+ { Tell the remote server to shutdown and startup. }
+
+ function RemoteStart(const aClientID : TffClientID) : TffResult;
+ { Tell the remote server to startup. Only works if the remote server
+ is in a stopped state (i.e., transports & cmd handlers still
+ listening. }
+
+ function RemoteStop(const aClientID : TffClientID) : TffResult;
+ { Tell the remote server to stop. The server engine shuts down but
+ the transport and cmd handlers will still be listening. }
+{End !!.01}
+
+ {transaction tracking}
+ function TransactionCommit(const aDatabaseID : TffDatabaseID
+ ) : TffResult; override;
+ function TransactionRollback(const aDatabaseID : TffDatabaseID
+ ) : TffResult; override;
+ function TransactionStart(const aDatabaseID : TffDatabaseID;
+ const aFailSafe : Boolean
+ ) : TffResult; override;
+{Begin !!.10}
+ function TransactionStartWith(const aDatabaseID : TffDatabaseID;
+ const aFailSafe : Boolean;
+ const aCursorIDs : TffPointerList
+ ) : TffResult; override;
+{End !!.10}
+
+ {client related stuff}
+ function ClientAdd(var aClientID : TffClientID;
+ const aClientName : TffNetName;
+ const aUserID : TffName;
+ const aTimeout : Longint;
+ var aHash : TffWord32) : TffResult; override;
+{Begin !!.11}
+ function ClientAddEx(var aClientID : TffClientID;
+ const aClientName : TffNetName;
+ const aUserID : TffName;
+ const aTimeout : Longint;
+ const aClientVersion : Longint;
+ var aHash : TffWord32) : TffResult; override;
+ { Same as ClientAdd but client version is supplied via the aClientVersion
+ parameter. }
+{End !!.11}
+ function ClientRemove(aClientID : TffClientID) : TffResult; override;
+ function ClientSetTimeout(const aClientID : TffClientID;
+ const aTimeout : longInt) : TffResult; override;
+
+
+ {client session related stuff}
+ function SessionAdd(const aClientID : TffClientID;
+ const aTimeout : Longint;
+ var aSessionID : TffSessionID) : TffResult; override;
+ function SessionCloseInactiveTables(aClientID : TffClientID) : TffResult; override; {!!.06}
+ function SessionCount(aClientID : TffClientID;
+ var aCount : Longint) : TffResult; override;
+ function SessionGetCurrent(aClientID : TffClientID;
+ var aSessionID : TffSessionID
+ ) : TffResult; override;
+ function SessionRemove(aClientID : TffClientID;
+ aSessionID : TffSessionID) : TffResult; override;
+ function SessionSetTimeout(const aClientID : TffClientID;
+ const aSessionID : TffSessionID;
+ const aTimeout : Longint) : TffResult; override;
+ function SessionSetCurrent(aClientID : TffClientID;
+ aSessionID : TffSessionID
+ ) : TffResult; override;
+
+ {database related stuff}
+ function DatabaseAddAlias(const aAlias : TffName;
+ const aPath : TffPath;
+ aCheckSpace : Boolean; {!!.11}
+ const aClientID : TffClientID)
+ : TffResult; override;
+ function DatabaseAliasList(aList : TList;
+ aClientID : TffClientID)
+ : TffResult; override;
+ function RecoveryAliasList(aList : TList;
+ aClientID : TffClientID)
+ : TffResult; override;
+ function DatabaseChgAliasPath(aAlias : TffName;
+ aNewPath : TffPath;
+ aCheckSpace : Boolean; {!!.11}
+ aClientID : TffClientID)
+ : TffResult; override;
+ function DatabaseClose(aDatabaseID : TffDatabaseID) : TffResult; override;
+ function DatabaseDeleteAlias(aAlias : TffName;
+ aClientID : TffClientID) : TffResult; override;
+ function DatabaseGetAliasPath(aAlias : TffName;
+ var aPath : TffPath;
+ aClientID : TffClientID) : TffResult; override;
+ function DatabaseGetFreeSpace(const aDatabaseID : TffDatabaseID;
+ var aFreeSpace : Longint) : TffResult; override;
+ function DatabaseModifyAlias(const aClientID : TffClientID;
+ const aAlias : TffName;
+ const aNewName : TffName;
+ const aNewPath : TffPath;
+ aCheckSpace : Boolean) {!!.11}
+ : TffResult; override;
+ function DatabaseOpen(aClientID : TffClientID;
+ const aAlias : TffName;
+ const aOpenMode : TffOpenMode;
+ const aShareMode : TffShareMode;
+ const aTimeout : Longint;
+ var aDatabaseID : TffDatabaseID) : TffResult; override;
+ function DatabaseOpenNoAlias(aClientID : TffClientID;
+ const aPath : TffPath;
+ const aOpenMode : TffOpenMode;
+ const aShareMode : TffShareMode;
+ const aTimeout : Longint;
+ var aDatabaseID : TffDatabaseID
+ ) : TffResult; override;
+ function DatabaseSetTimeout(const aDatabaseID : TffDatabaseID;
+ const aTimeout : Longint) : TffResult; override;
+ function DatabaseTableExists(aDatabaseID : TffDatabaseID;
+ const aTableName : TffTableName;
+ var aExists : Boolean) : TffResult; override;
+ function DatabaseTableList(aDatabaseID : TffDatabaseID;
+ const aMask : TffFileNameExt;
+ aList : TList) : TffResult; override;
+ function DatabaseTableLockedExclusive(aDatabaseID : TffDatabaseID;
+ const aTableName : TffTableName;
+ var aLocked : Boolean) : TffResult; override;
+
+ {rebuild status related stuff}
+ function RebuildGetStatus(aRebuildID : longint;
+ const aClientID : TffClientID;
+ var aIsPresent : Boolean;
+ var aStatus : TffRebuildStatus
+ ) : TffResult; override;
+
+ {table related stuff}
+ function TableAddIndex(const aDatabaseID : TffDatabaseID;
+ const aCursorID : TffCursorID;
+ const aTableName : TffTableName;
+ const aIndexDesc : TffIndexDescriptor
+ ) : TffResult; override;
+ function TableBuild(aDatabaseID : TffDatabaseID;
+ aOverWrite : Boolean;
+ const aTableName : TffTableName;
+ aForServer : Boolean;
+ aDictionary : TffDataDictionary
+ ) : TffResult; override;
+ function TableDelete(aDatabaseID : TffDatabaseID;
+ const aTableName : TffTableName) : TffResult; override;
+ function TableDropIndex(aDatabaseID : TffDatabaseID;
+ aCursorID : TffCursorID;
+ const aTableName : TffTableName;
+ const aIndexName : TffDictItemName;
+ aIndexID : longint) : TffResult; override;
+ function TableEmpty(aDatabaseID : TffDatabaseID;
+ aCursorID : TffCursorID;
+ const aTableName : TffTableName) : TffResult; override;
+ function TableGetAutoInc(aCursorID : TffCursorID;
+ var aValue : TffWord32) : TffResult; override;
+ function TableGetDictionary(aDatabaseID : TffDatabaseID;
+ const aTableName : TffTableName;
+ aForServer : Boolean;
+ aStream : TStream) : TffResult; override;
+ function TableGetRecCount(aCursorID : TffCursorID;
+ var aRecCount : longint) : TffResult; override;
+ function TableGetRecCountAsync(aCursorID : TffCursorID; {!!.07}
+ var aTaskID : Longint) : TffResult; override; {!!.07}
+ function TableOpen(const aDatabaseID : TffDatabaseID;
+ const aTableName : TffTableName;
+ const aForServer : Boolean;
+ const aIndexName : TffName;
+ aIndexID : longint;
+ const aOpenMode : TffOpenMode;
+ aShareMode : TffShareMode;
+ const aTimeout : Longint;
+ var aCursorID : TffCursorID;
+ aStream : TStream) : TffResult; override;
+ function TablePack(aDatabaseID : TffDatabaseID;
+ const aTableName : TffTableName;
+ var aRebuildID : longint) : TffResult; override;
+ function TableRebuildIndex(aDatabaseID : TffDatabaseID;
+ const aTableName : TffTableName;
+ const aIndexName : TffName;
+ aIndexID : longint;
+ var aRebuildID : longint) : TffResult; override;
+ function TableRename(aDatabaseID : TffDatabaseID;
+ const aOldName : TffName;
+ const aNewName : TffName) : TffResult; override;
+ function TableRestructure(aDatabaseID : TffDatabaseID;
+ const aTableName : TffTableName;
+ aDictionary : TffDataDictionary;
+ aFieldMap : TffStringList;
+ var aRebuildID : longint) : TffResult; override;
+ function TableSetAutoInc(aCursorID : TffCursorID;
+ aValue : TffWord32) : TffResult; override;
+{Begin !!.11}
+ function TableVersion(aDatabaseID : TffDatabaseID;
+ const aTableName : TffTableName;
+ var aVersion : Longint) : TffResult; override;
+{End !!.11}
+
+ {table locks via cursor}
+ function TableIsLocked(aCursorID : TffCursorID;
+ aLockType : TffLockType;
+ var aIsLocked : Boolean) : TffResult; override;
+ function TableLockAcquire(aCursorID : TffCursorID;
+ aLockType : TffLockType) : TffResult; override;
+ function TableLockRelease(aCursorID : TffCursorID;
+ aAllLocks : Boolean) : TffResult; override;
+
+ {cursor stuff}
+ function CursorClone(aCursorID : TffCursorID;
+ aOpenMode : TffOpenMode;
+ var aNewCursorID : TffCursorID) : TffResult; override;
+ function CursorClose(aCursorID : TffCursorID) : TffResult; override;
+ function CursorCompareBookmarks(aCursorID : TffCursorID;
+ aBookmark1,
+ aBookmark2 : PffByteArray;
+ var aCompResult : longint) : TffResult; override;
+{Begin !!.02}
+ function CursorCopyRecords(aSrcCursorID,
+ aDestCursorID : TffCursorID;
+ aCopyBLOBs : Boolean) : TffResult; override;
+{End !!.02}
+ function CursorDeleteRecords(aCursorID : TffCursorID) : TffResult; override; {!!.06}
+ function CursorGetBookmark(aCursorID : TffCursorID;
+ aBookmark : PffByteArray) : TffResult; override;
+
+ function CursorGetBookmarkSize(aCursorID : TffCursorID;
+ var aSize : Longint) : TffResult; override;
+{Begin !!.03}
+ function CursorListBLOBFreeSpace(aCursorID : TffCursorID;
+ const aInMemory : Boolean;
+ aStream : TStream) : TffResult; override;
+{End !!.03}
+ function CursorOverrideFilter(aCursorID : Longint;
+ aExpression : pCANExpr;
+ aTimeout : TffWord32) : TffResult; override;
+ function CursorResetRange(aCursorID : TffCursorID) : TffResult; override;
+ function CursorRestoreFilter(aCursorID : longInt) : TffResult; override;
+ function CursorSetRange(aCursorID : TffCursorID;
+ aDirectKey : Boolean;
+ aFieldCount1 : Longint;
+ aPartialLen1 : Longint;
+ aKeyData1 : PffByteArray;
+ aKeyIncl1 : Boolean;
+ aFieldCount2 : Longint;
+ aPartialLen2 : Longint;
+ aKeyData2 : PffByteArray;
+ aKeyIncl2 : Boolean) : TffResult; override;
+ function CursorSetTimeout(const aCursorID : TffCursorID;
+ const aTimeout : Longint) : TffResult; override;
+ function CursorSetToBegin(aCursorID : TffCursorID) : TffResult; override;
+ function CursorSetToBookmark(aCursorID : TffCursorID;
+ aBookmark : PffByteArray
+ ) : TffResult; override;
+ function CursorSetToCursor(aDestCursorID : TffCursorID;
+ aSrcCursorID : TffCursorID
+ ) : TffResult; override;
+ function CursorSetToEnd(aCursorID : TffCursorID) : TffResult; override;
+ function CursorSetToKey(aCursorID : TffCursorID;
+ aSearchAction : TffSearchKeyAction;
+ aDirectKey : Boolean;
+ aFieldCount : Longint;
+ aPartialLen : Longint;
+ aKeyData : PffByteArray
+ ) : TffResult; override;
+ function CursorSwitchToIndex(aCursorID : TffCursorID;
+ aIndexName : TffDictItemName;
+ aIndexID : Longint;
+ aPosnOnRec : Boolean) : TffResult; override;
+ function CursorSetFilter(aCursorID : TffCursorID;
+ aExpression : pCANExpr;
+ aTimeout : TffWord32) : TffResult; override;
+
+ {record stuff}
+ function RecordDelete(aCursorID : TffCursorID;
+ aData : PffByteArray) : TffResult; override;
+ function RecordDeleteBatch(aCursorID : TffCursorID;
+ aBMCount : Longint;
+ aBMLen : Longint;
+ aData : PffByteArray;
+ aErrors : PffLongintArray) : TffResult; override;
+ function RecordExtractKey(aCursorID : TffCursorID;
+ aData : PffByteArray;
+ aKey : PffByteArray) : TffResult; override;
+ function RecordGet(aCursorID : TffCursorID;
+ aLockType : TffLockType;
+ aData : PffByteArray) : TffResult; override;
+ function RecordGetBatch(aCursorID : TffCursorID;
+ aRecCount : longint;
+ aRecLen : longint;
+ var aRecRead : longint;
+ aData : PffByteArray;
+ var aError : TffResult) : TffResult; override;
+ function RecordGetForKey(aCursorID : TffCursorID;
+ aDirectKey : Boolean;
+ aFieldCount : Longint;
+ aPartialLen : Longint;
+ aKeyData : PffByteArray;
+ aData : PffByteArray;
+ aFirstCall : Boolean
+ ) : TffResult; override;
+ function RecordGetNext(aCursorID : TffCursorID;
+ aLockType : TffLockType;
+ aData : PffByteArray) : TffResult; override;
+ function RecordGetPrior(aCursorID : TffCursorID;
+ aLockType : TffLockType;
+ aData : PffByteArray) : TffResult; override;
+ function RecordInsert(aCursorID : TffCursorID;
+ aLockType : TffLockType;
+ aData : PffByteArray) : TffResult; override;
+ function RecordInsertBatch(aCursorID : TffCursorID;
+ aRecCount : longint;
+ aRecLen : longint;
+ aData : PffByteArray;
+ aErrors : PffLongintArray) : TffResult; override;
+ function RecordIsLocked(aCursorID : TffCursorID;
+ aLockType : TffLockType;
+ var aIsLocked : boolean) : TffResult; override;
+ function RecordModify(aCursorID : TffCursorID;
+ aData : PffByteArray;
+ aRelLock : Boolean) : TffResult; override;
+ function RecordRelLock(aCursorID : TffCursorID;
+ aAllLocks : Boolean) : TffResult; override;
+
+ {BLOB stuff}
+ function BLOBCreate(aCursorID : TffCursorID;
+ var aBlobNr : TffInt64) : TffResult; override;
+ function BLOBDelete(aCursorID : TffCursorID;
+ aBlobNr : TffInt64) : TffResult; override;
+{Begin !!.03}
+ function BLOBListSegments(aCursorID : TffCursorID;
+ aBLOBNr : TffInt64;
+ aStream : TStream) : TffResult; override;
+{End !!.03}
+ function BLOBRead(aCursorID : TffCursorID;
+ aBlobNr : TffInt64;
+ aOffset : TffWord32; {!!.06}
+ aLen : TffWord32; {!!.06}
+ var aBLOB;
+ var aBytesRead : TffWord32) {!!.06}
+ : TffResult; override;
+ function BLOBFree(aCursorID : TffCursorID; aBlobNr : TffInt64;
+ readOnly : Boolean) : TffResult; override;
+ function BLOBGetLength(aCursorID : TffCursorID; aBlobNr : TffInt64;
+ var aLength : longint) : TffResult; override;
+ function BLOBTruncate(aCursorID : TffCursorID; aBlobNr : TffInt64;
+ aBLOBLength : longint) : TffResult; override;
+ function BLOBWrite(aCursorID : TffCursorID; aBlobNr : TffInt64;
+ aOffset : longint;
+ aLen : longint;
+ var aBLOB) : TffResult; override;
+ function FileBLOBAdd(aCursorID : TffCursorID;
+ const aFileName : TffFullFileName;
+ var aBlobNr : TffInt64) : TffResult; override;
+
+ {query stuff}
+ function SQLAlloc(aClientID : TffClientID;
+ aDatabaseID : TffDatabaseID;
+ aTimeout : longInt;
+ var aStmtID : TffSqlStmtID) : TffResult; override;
+ function SQLExec(aStmtID : TffSqlStmtID;
+ aOpenMode : TffOpenMode;
+ var aCursorID : TffCursorID;
+ aStream : TStream) : TffResult; override;
+ function SQLExecDirect(aClientID : TffClientID;
+ aDatabaseID : TffDatabaseID;
+ aQueryText : PChar;
+ aTimeout : longInt;
+ aOpenMode : TffOpenMode;
+ var aCursorID : TffCursorID;
+ aStream : TStream) : TffResult; override;
+ function SQLFree(aStmtID : TffSqlStmtID) : TffResult; override;
+ function SQLPrepare(aStmtID : TffSqlStmtID;
+ aQueryText : PChar;
+ aStream : TStream) : TffResult; override;
+ function SQLSetParams(aStmtID : TffSqlStmtID;
+ aNumParams : word;
+ aParamDescs : pointer;
+ aDataBuffer : PffByteArray;
+ aDataLen : Longint;
+ aStream : TStream) : TffResult; override;
+
+ {misc stuff}
+ function GetServerDateTime(var aDateTime : TDateTime
+ ) : TffResult; override;
+ {begin !!.07}
+ function GetServerSystemTime(var aSystemTime : TSystemTime) : TffResult; override;
+ function GetServerGUID(var aGUID : TGUID) : TffResult; override;
+ function GetServerID(var aUniqueID : TGUID) : TffResult; override;
+ function GetServerStatistics(var Stats : TffServerStatistics) : TffResult; override;
+ function GetCommandHandlerStatistics(const CmdHandlerIdx : Integer;
+ var Stats : TffCommandHandlerStatistics) : TffResult; override;
+ function GetTransportStatistics(const CmdHandlerIdx : Integer;
+ const TransportIdx : Integer;
+ var Stats : TffTransportStatistics) : TffResult; override;
+ {end !!.07}
+
+
+ {properties}
+ property ClientList : TFFProxyClientList
+ read rsClientList;
+
+ property TimeOut : TFFWord32
+ read rsTimeout write rsTimeout;
+
+ published
+ property Transport : TFFBaseTransport
+ read rsTransport
+ write rsSetTransport;
+
+ end;
+
+ {Callback method used by the transport to notify us when the request is
+ complete.}
+ procedure ProxyRequestCallback(aMsgID : Longint;
+ aErrorCode : TffResult;
+ aReply : Pointer;
+ aReplyLen : Longint;
+ aReplyCookie : Longint);
+
+var
+ RemoteServerEngines : TFFThreadList;
+
+implementation
+
+uses
+ ActiveX,
+ ffsqlbas;
+
+{--Internal helper routines--}
+function ResultOK(aResult : TffResult) : Boolean;
+begin
+ Result := aResult = DBIERR_NONE;
+end;
+{------------------------------------------------------------------------------}
+
+
+{--Callback routine--}
+procedure ProxyRequestCallback(aMsgID : Longint;
+ aErrorCode : TffResult;
+ aReply : Pointer;
+ aReplyLen : Longint;
+ aReplyCookie : Longint);
+var
+ Client : TFFProxyClient absolute aReplyCookie;
+begin
+ { hand-off the response from the transport to the ProxyClient }
+ Client.pcMsgQueue.Append(aMsgID,
+ aReplyCookie,
+ 0, {RequestID}
+ 0, {Timeout}
+ aErrorCode,
+ aReply,
+ aReplyLen,
+ aReplyLen);
+end;
+{------------------------------------------------------------------------------}
+
+
+
+{-TffProxyClient---------------------------------------------------------------}
+constructor TFFProxyClient.Create(aTransport : TffBaseTransport;
+ aUserName : TFFName;
+ aPasswordHash : Longint;
+ aTimeOut : Longint);
+begin
+ inherited Create;
+
+ {Initialize internals}
+ pcSrClientID := 0;
+ pcCurrentSession := nil;
+ pcForceClosed := False;
+
+ pcTransport := aTransport;
+ pcTimeout := aTimeOut;
+
+ {Create internal classes}
+ pcMsgQueue := TffDataMessageQueue.Create;
+ pcSessions := TFFProxySessionList.Create;
+ pcDatabases := TFFProxyDatabaseList.Create;
+
+ {Set the CallbackMethod that will be used by the transport to return data}
+ pcCallbackMethod := ProxyRequestCallback;
+
+ {Let the ServerEngine know that we are here. Set our SrClientID for later
+ reference, as we will need it often.}
+ Check(pcTransport.EstablishConnection(aUserName,
+ aPasswordHash,
+ pcTimeOut,
+ pcSrClientID));
+end;
+{----------}
+function TFFProxyClient.DatabaseAddAlias(const aAlias : TffName;
+ const aPath : TffPath;
+ aCheckSpace : Boolean) {!!.11}
+ : TffResult;
+var
+ Request : TffnmDatabaseAddAliasReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize the request record }
+ Request.Alias := aAlias;
+ Request.Path := aPath;
+ Request.CheckDisk := aCheckSpace; {!!.11}
+
+ Reply := nil;
+ Result := ProcessRequest(ffnmDatabaseAddAlias,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+
+ { Calling ffnmDatabaseAddAlias only returns an error code to Result. }
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyClient.DatabaseAliasList(aList: TList) : TffResult;
+var
+ Stream : TMemoryStream;
+ ReplyLen : Longint;
+ Count : Longint;
+ AliasDes : PffAliasDescriptor;
+ DesSize : Longint;
+begin
+ Stream := TMemoryStream.Create;
+ try
+ { We have no data to send. }
+ Result := ProcessRequest(ffnmDatabaseAliasList,
+ Timeout,
+ nil,
+ 0,
+ nmdByteArray,
+ Pointer(Stream),
+ ReplyLen,
+ nmdStream);
+
+ if ResultOK(Result) then begin
+ aList.Clear;
+ Stream.Position := 0;
+ DesSize := SizeOf(TffAliasDescriptor);
+
+ for Count := 1 to (ReplyLen div DesSize) do begin
+ { Move the alias data from the stream, to a PffAliasDescriptor. Each
+ descriptor will be an entry in aList. The caller must free this
+ data when it is done using it. }
+ FFGetMem(AliasDes, DesSize);
+ Stream.Read(AliasDes^, DesSize);
+ aList.Add(AliasDes);
+ end;
+ end;
+ finally
+ Stream.Free;
+ end;
+end;
+{----------}
+function TFFProxyClient.DatabaseChgAliasPath(const aAlias : TffName;
+ const aNewPath : TffPath;
+ aCheckSpace : Boolean) {!!.11}
+ : TffResult;
+var
+ Request : TffnmDatabaseChgAliasPathReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize the request record }
+ Request.Alias := aAlias;
+ Request.NewPath := aNewPath;
+ Request.CheckDisk := aCheckSpace; {!!.11}
+
+ Reply := nil;
+ Result := ProcessRequest(ffnmDatabaseChgAliasPath,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+
+ { Calling ffnmDatabaseChgAliasPath only returns an error code to Result. }
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyClient.DatabaseClose(aDatabase : TffProxyDatabase) : TffResult;
+begin
+ Result := DBIERR_NONE;
+ with pcDatabases.BeginWrite do
+ try
+ Delete(aDatabase); {!!.01}
+ finally
+ EndWrite;
+ end;
+ aDatabase.Free;
+ aDatabase := nil;
+end;
+{----------}
+function TFFProxyClient.DatabaseDeleteAlias(const aAlias : TffName) : TffResult;
+var
+ Request : TffnmDatabaseDeleteAliasReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize the request record }
+ Request.Alias := aAlias;
+
+ Reply := nil;
+ Result := ProcessRequest(ffnmDatabaseDeleteAlias,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+
+ { Calling ffnmDatabaseDeleteAlias only returns an error code to Result. }
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyClient.DatabaseGetAliasPath(const aAlias : TffName;
+ var aPath : TffPath
+ ) : TffResult;
+var
+ Request : TffnmDatabaseGetAliasPathReq;
+ Reply : PffnmDatabaseGetAliasPathRpy;
+ ReplyLen : Longint;
+begin
+ { Initialize the request record }
+ Request.Alias := aAlias;
+
+ Reply := nil;
+ Result := ProcessRequest(ffnmDatabaseGetAliasPath,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+ if ResultOK(Result) then
+ aPath := Reply^.Path;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TffProxyClient.DatabaseModifyAlias(const aAlias : TffName;
+ const aNewName : TffName;
+ const aNewPath : TffPath;
+ aCheckSpace : Boolean) {!!.11}
+ : TffResult;
+var
+ Request : TffnmDatabaseModifyAliasReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize the request record }
+ Request.ClientID := SrClientID;
+ Request.Alias := aAlias;
+ Request.NewName := aNewName;
+ Request.NewPath := aNewPath;
+ Request.CheckDisk := aCheckSpace; {!!.11}
+
+ Reply := nil;
+ Result := ProcessRequest(ffnmDatabaseModifyAlias,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyClient.DatabaseOpen(const aAlias : TffName;
+ aOpenMode : TffOpenMode;
+ aShareMode : TffShareMode;
+ aTimeout : Longint;
+ var aDatabaseID : TffDatabaseID)
+ : TffResult;
+var
+ Database : TFFProxyDatabase;
+ ListItem : TffIntListItem;
+begin
+ Database := nil;
+ Result := DBIERR_NONE;
+
+ try
+ Database := TFFProxyDatabase.Create(Self,
+ aAlias,
+ aOpenMode,
+ aShareMode,
+ aTimeout,
+ True);
+ except
+ on E:Exception do
+ if (E is EffException) or (E is EffDatabaseError) then
+ Result := EffException(E).ErrorCode;
+ end;
+
+ if ResultOK(Result) and Assigned(Database) then begin
+ {Add Database to the internal list}
+ ListItem := TffIntListItem.Create(Longint(Database));
+ with pcDatabases.BeginWrite do
+ try
+ Insert(ListItem);
+ finally
+ EndWrite;
+ end;
+
+ aDatabaseID := Longint(Database);
+ end;
+end;
+{----------}
+function TFFProxyClient.DatabaseOpenNoAlias(const aPath : TffPath;
+ aOpenMode : TffOpenMode;
+ aShareMode : TffShareMode;
+ aTimeout : Longint;
+ var aDatabaseID : TffDatabaseID
+ ) : TffResult;
+var
+ Database : TFFProxyDatabase;
+ ListItem : TffIntListItem;
+begin
+ Database := nil;
+ Result := DBIERR_NONE;
+
+ try
+ Database := TFFProxyDatabase.Create(Self,
+ aPath,
+ aOpenMode,
+ aShareMode,
+ aTimeout,
+ False);
+ except
+ on E:Exception do
+ if (E is EffException) or (E is EffDatabaseError) then
+ Result := EffException(E).ErrorCode;
+ end;
+
+ if ResultOK(Result) and Assigned(Database) then begin
+ {Add Database to the internal list}
+ ListItem := TffIntListItem.Create(Longint(Database));
+ with pcDatabases.BeginWrite do
+ try
+ Insert(ListItem);
+ finally
+ EndWrite;
+ end;
+
+ aDatabaseID := Longint(Database);
+ end;
+end;
+{----------}
+destructor TFFProxyClient.Destroy;
+{Begin !!.03}
+//var
+// Idx : Longint;
+begin
+ {Destroy managed objects}
+ pcMsgQueue.Free;
+ pcMsgQueue := nil;
+ pcSessions.Free;
+ pcSessions := nil;
+ pcDatabases.Free;
+ pcDatabases := nil;
+// with pcDatabases.BeginWrite do
+// try
+// for Idx := 0 to Pred(Count) do
+// TFFProxyDatabase(Items[Idx]).Free;
+// finally
+// EndWrite;
+// end;
+
+// with pcSessions.BeginWrite do
+// try
+// for Idx := 0 to Pred(Count) do
+// TFFProxySession(Items[Idx]).Free;
+// finally
+// EndWrite;
+// end;
+
+ {Tell the server that we are disconnecting.}
+ if not ForceClosed then
+ if SrClientID > 0 then
+ pcTransport.TerminateConnection(SrClientID, Timeout);
+
+// {Destroy internal classes}
+// pcMsgQueue.Free;
+// pcMsgQueue := nil;
+// pcSessions.Free;
+// pcSessions := nil;
+// pcDatabases.Free;
+// pcDatabases := nil;
+{End !!.03}
+
+ {Re-Initialize internals for completeness}
+ pcCurrentSession := nil;
+ pcTransport := nil;
+ pcCallbackMethod := nil;
+
+ inherited Destroy;
+end;
+{----------}
+function TffProxyClient.IsReadOnly : Boolean;
+var
+ Reply : PffnmServerIsReadOnlyRpy;
+ ReplyLen : Longint;
+ ErrorCode : TffResult;
+begin
+ Reply := nil;
+ ErrorCode := ProcessRequest(ffnmServerIsReadOnly,
+ Timeout,
+ nil,
+ 0,
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+ if ResultOK(ErrorCode) then
+ Result := Reply^.IsReadOnly
+ else
+ Result := False;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyClient.GetServerDateTime(var aDateTime : TDateTime
+ ) : TffResult;
+var
+ Reply : PffnmGetServerDateTimeRpy;
+ ReplyLen : Longint;
+begin
+ { Just in case }
+ aDateTime := Now;
+
+ { We have no data to send }
+ Reply := nil;
+ Result := ProcessRequest(ffnmGetServerDateTime,
+ Timeout,
+ nil,
+ 0,
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+ if ResultOK(Result) then
+ aDateTime := Reply^.ServerNow;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------} {begin !!.07}
+function TFFProxyClient.GetServerSystemTime(var aSystemTime : TSystemTime) : TffResult;
+var
+ Reply : PffnmGetServerSystemTimeRpy;
+ ReplyLen : Longint;
+begin
+ { Just in case }
+ GetSystemTime(aSystemTime);
+
+ { We have no data to send }
+ Reply := nil;
+ Result := ProcessRequest(ffnmGetServerSystemTime,
+ Timeout,
+ nil,
+ 0,
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+ if ResultOK(Result) then
+ aSystemTime := Reply^.ServerNow;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyClient.GetServerGUID(var aGUID : TGUID) : TffResult;
+var
+ Reply : PffnmGetServerGUIDRpy;
+ ReplyLen : Longint;
+begin
+ { Just in case }
+ CoCreateGuid(aGUID);
+
+ { We have no data to send }
+ Reply := nil;
+ Result := ProcessRequest(ffnmGetServerGUID,
+ Timeout,
+ nil,
+ 0,
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+ if ResultOK(Result) then
+ aGUID := Reply^.GUID;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyClient.GetServerID(var aUniqueID : TGUID) : TffResult;
+var
+ Reply : PffnmGetServerIDRpy;
+ ReplyLen : Longint;
+begin
+ { We have no data to send }
+ Reply := nil;
+ Result := ProcessRequest(ffnmGetServerID,
+ Timeout,
+ nil,
+ 0,
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+ if ResultOK(Result) then
+ aUniqueID := Reply^.UniqueID;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyClient.GetServerStatistics(var Stats : TffServerStatistics) : TffResult;
+var
+ Reply : PffnmServerStatisticsRpy;
+ ReplyLen : Longint;
+begin
+ { We have no data to send }
+ Reply := nil;
+ Result := ProcessRequest(ffnmServerStatistics,
+ Timeout,
+ nil,
+ 0,
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+
+ if ResultOK(Result) then
+ Stats := Reply^.Stats;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyClient.GetCommandHandlerStatistics(const CmdHandlerIdx : Integer;
+ var Stats : TffCommandHandlerStatistics) : TffResult;
+var
+ Request : TffnmCmdHandlerStatisticsReq;
+ Reply : PffnmCmdHandlerStatisticsRpy;
+ ReplyLen : Longint;
+begin
+ { Initiailize Request }
+ Request.CmdHandlerIdx := CmdHandlerIdx;
+
+ Reply := nil;
+ Result := ProcessRequest(ffnmCmdHandlerStatistics,
+ pcTimeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+
+ if ResultOK(Result) then
+ Stats := Reply^.Stats;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyClient.GetTransportStatistics(const CmdHandlerIdx : Integer;
+ const Transportidx : Integer;
+ var Stats : TffTransportStatistics) : TffResult;
+var
+ Request : TffnmTransportStatisticsReq;
+ Reply : PffnmTransportStatisticsRpy;
+ ReplyLen : Longint;
+begin
+ { Initiailize Request }
+ Request.CmdHandlerIdx := CmdHandlerIdx;
+ Request.TransportIdx := Transportidx;
+
+ Reply := nil;
+ Result := ProcessRequest(ffnmTransportStatistics,
+ pcTimeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+
+ if ResultOK(Result) then
+ Stats := Reply^.Stats;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------} {end !!.07}
+function TFFProxyClient.ProcessRequest(aMsgID : longInt;
+ aTimeout : longInt;
+ aRequestData : Pointer;
+ aRequestDataLen : longInt;
+ aRequestDataType : TffNetMsgDataType;
+ var aReply : Pointer;
+ var aReplyLen : longInt;
+ aReplyType : TffNetMsgDataType
+ ) : TffResult;
+var
+ ReplyAsStream : TStream absolute aReply;
+ ReplyMsg : PffDataMessage;
+begin
+ if ForceClosed then begin
+ Result := DBIERR_NONE;
+ aReply := nil;
+ aReplyLen := 0;
+ Exit;
+ end;
+
+ Result := DBIERR_NA;
+ {A Respose from the server is expected. This call will not return until
+ the complete reply has been sent to the transport, and the Client
+ callback method has been called.}
+
+ { Use the ProxessRequest method to submit a request that is routed to the
+ transport. This method does the following:
+
+ 1. Calls TffBaseTransport.Request with transportID = 0 and cookie
+ equal to Pointer(Self). At this point, the calling thread is
+ blocked until a reply is received from the server or a timeout
+ occurs.
+ 2. When the calling thread returns to this method, the reply has
+ been received and placed in the message queue by the
+ ProxyClientCallback procedure.
+ 3. Get the first message off the queue and verify it is what we
+ expected.
+ 4. Put the message into the Reply variables and exit.
+ }
+
+ { Is our reply already in the queue (e.g., came back as part
+ of a multi-part message? Assumption: We can get rid of any
+ replies that don't match the message we are requesting. }
+ ReplyMsg := pcMsgQueue.SoftPop;
+ while Assigned(ReplyMsg) and (ReplyMsg^.dmMsg <> aMsgID) do begin
+ FFFreeMem(ReplyMsg^.dmData, ReplyMsg^.dmDataLen);
+ FFFreeMem(ReplyMsg, SizeOf(TFFDataMessage));
+ ReplyMsg := pcMsgQueue.SoftPop;
+ end;
+
+ if not Assigned(ReplyMsg) then begin
+
+ pcTransport.Request(0, {For use by future protocols.}
+ SrClientID,
+ aMsgID,
+ aTimeout,
+ aRequestData,
+ aRequestDataLen,
+ pcCallbackMethod,
+ Longint(Self));
+
+ {Process the reply from the server. Get the reply message off the queue
+ and verify that is what we expected}
+ Assert(pcMsgQueue.Count <= 1, 'Too many messages in the queue');
+ ReplyMsg := pcMsgQueue.SoftPop;
+ end;
+
+ if Assigned(ReplyMsg) then begin
+ if (ReplyMsg^.dmMsg <> aMsgID) then begin
+ Result := DBIERR_NOTSAMESESSION;
+ FFFreeMem(ReplyMsg^.dmData, ReplyMsg^.dmDataLen); {!!.03}
+ FFFreeMem(ReplyMsg, SizeOf(TFFDataMessage));
+ Exit;
+ end;
+
+ aReplyLen := ReplyMsg^.dmDataLen;
+ if aReplyType = nmdStream then begin
+ Assert(Assigned(ReplyAsStream));
+ ReplyAsStream.Position := 0;
+ if (aReplyLen > 0) then begin
+ ReplyAsStream.Write(ReplyMsg^.dmData^, aReplyLen);
+ FFFreeMem(ReplyMsg^.dmData, aReplyLen);
+ end;
+ end else
+ aReply := ReplyMsg^.dmData;
+
+ Result := ReplyMsg^.dmErrorCode;
+
+ { Free the ReplyMsg, but leave RequestData alone.
+ The caller is responsible for releasing data.
+ We expect the caller to free the reply data.}
+ FFFreeMem(ReplyMsg, SizeOf(TFFDataMessage));
+
+ end;
+end;
+{----------}
+function TFFProxyClient.ProcessRequestNoReply(aMsgID : Longint;
+ aTimeout : Longint;
+ aRequestData : Pointer;
+ aRequestDataLen : Longint
+ ) : TffResult;
+begin
+ if ForceClosed then begin
+ Result := DBIERR_NONE;
+ Exit;
+ end;
+
+ {No response from the server is expected, so this call will return as
+ soon as the request has been sent from the transport's queue}
+
+ pcTransport.Post(0, {For use by future protocols.}
+ SrClientID,
+ aMsgID,
+ aRequestData,
+ aRequestDataLen,
+ aTimeout,
+ ffrmNoReplyWaitUntilSent);
+
+ Result := DBIERR_NONE;
+end;
+{Begin !!.01}
+{----------}
+function TffProxyClient.RemoteRestart : TffResult;
+begin
+ Result := ProcessRequestNoReply(ffnmServerRestart, Timeout, nil, 0);
+end;
+{----------}
+function TffProxyClient.RemoteStart : TffResult;
+begin
+ Result := ProcessRequestNoReply(ffnmServerStartup, Timeout, nil, 0);
+end;
+{----------}
+function TffProxyClient.RemoteStop : TffResult;
+begin
+ Result := ProcessRequestNoReply(ffnmServerStop, Timeout, nil, 0);
+end;
+{End !!.01}
+{----------}
+function TFFProxyClient.SessionAdd(var aSessionID : TffSessionID;
+ const aTimeout : Longint) : TffResult;
+var
+ Session : TFFProxySession;
+ ListItem : TffIntListItem;
+begin
+ Session := nil;
+ Result := DBIERR_NONE;
+
+ try
+ Session := TFFProxySession.Create(Self, aTimeout);
+ except
+ on E:Exception do
+ if (E is EffException) or (E is EffDatabaseError) then
+ Result := EffException(E).ErrorCode;
+ end;
+
+ if ResultOK(Result) and Assigned(Session) then begin
+ {Add Session to the internal list}
+ ListItem := TffIntListItem.Create(Longint(Session));
+ with pcSessions.BeginWrite do
+ try
+ Insert(ListItem);
+ finally
+ EndWrite;
+ end;
+
+ aSessionID := Longint(Session);
+
+ {Set the current session if it is nil}
+ if not Assigned(pcCurrentSession) then
+ pcCurrentSession := Session;
+ end;
+end;
+{Begin !!.06}
+{----------}
+function TFFProxyClient.SessionCloseInactiveTables : TffResult;
+var
+ Request : TffnmSessionCloseInactiveTblReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initiailize Request }
+ Request.SessionID := pcCurrentSession.psSrSessionID;
+
+ Reply := nil;
+ Result := ProcessRequest(ffnmSessionCloseInactTbl,
+ pcTimeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{End !!.06}
+{----------}
+function TFFProxyClient.SessionCount : Longint;
+begin
+ {Retun the number of sessions managed by the ProxyClient}
+ with pcSessions.BeginRead do
+ try
+ Result := Count;
+ finally
+ EndRead;
+ end;
+end;
+{----------}
+function TFFProxyClient.SessionGetCurrent : TffProxySession;
+begin
+ {Return the current session. This value will be nil if no sessions exist}
+ if Assigned(pcCurrentSession) then
+ Result := pcCurrentSession
+ else begin
+ if SessionCount > 0 then
+ {Return the first session in the list}
+ with pcSessions.BeginRead do
+ try
+ Result := TFFProxySession(Items[0]);
+ finally
+ EndRead;
+ end
+ else
+ {no sessions available}
+ Result := nil;
+ end;
+end;
+{----------}
+function TFFProxyClient.SessionRemove(aSession : TFFProxySession) : TffResult;
+begin
+ {Remove session from the internal list, and destroy.}
+ if not Assigned(aSession) then begin
+ {aSession parameter is invalid}
+ Result := DBIERR_INVALIDHNDL;
+ Exit;
+ end;
+
+ Result := DBIERR_NONE;
+ with pcSessions.BeginWrite do
+ try
+ Delete(aSession); {!!.01}
+ finally
+ EndWrite;
+ end;
+
+ aSession.Free;
+end;
+{----------}
+function TFFProxyClient.SessionSetCurrent(aSession : TFFProxySession
+ ) : TffResult;
+var
+ Request : TffnmSessionSetCurrentReq;
+ Reply : PffnmSessionSetCurrentReq;
+ ReplyLen : Longint;
+begin
+ {Set the Client's CurrentSession. This function will accept nil as a valid
+ option}
+ Request.SessionID := aSession.psSrSessionID;
+ Reply := nil;
+ Result := ProcessRequest(ffnmSessionSetCurrent,
+ pcTimeOut,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+
+// Result := DBIERR_NONE;
+ pcCurrentSession := aSession;
+end;
+{----------}
+function TffProxyClient.GetRebuildStatus(const aRebuildID : Longint;
+ var aIsPresent : Boolean;
+ var aStatus : TffRebuildStatus) : TffResult;
+var
+ Request : TffnmGetRebuildStatusReq;
+ Reply : PffnmGetRebuildStatusRpy;
+ ReplyLen : Longint;
+begin
+ { Initiailize Request }
+ Request.RebuildID := aRebuildID;
+
+ Reply := nil;
+ Result := ProcessRequest(ffnmGetRebuildStatus,
+ pcTimeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+
+ if ResultOK(Result) then begin
+ aIsPresent := Reply^.IsPresent;
+ aStatus := Reply^.Status;
+ end;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyClient.SetTimeout(const aTimeout : Longint) : TffResult;
+var
+ Request : TffnmClientSetTimeoutReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ Result := DBIERR_NONE;
+ if pcTimeout = aTimeout then Exit;
+
+ pcTimeout := aTimeout;
+ { Initialize request }
+ Request.Timeout := pcTimeout;
+
+ Reply := nil;
+ Result := ProcessRequest(ffnmClientSetTimeout,
+ pcTimeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+
+ { Calling ffnmClientSetTimeout only returns an error code to Result. }
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{------------------------------------------------------------------------------}
+
+
+{-TFFProxySession--------------------------------------------------------------}
+constructor TFFProxySession.Create(aClient : TFFProxyClient;
+ aTimeout : Longint);
+var
+ Request : TffnmSessionAddReq;
+ Reply : PffnmSessionAddRpy;
+ ReplyLen : Longint;
+ Result : TFFResult;
+begin
+ inherited Create;
+
+ {Initalize the object}
+ psClient := aClient;
+ psSrSessionID := 0;
+ psTimeout := aTimeout;
+
+ { Initiailize Request }
+ Request.Timeout := aTimeout;
+
+ {Create a session object, and add it to the list}
+ Reply := nil;
+ Result := psClient.ProcessRequest(ffnmSessionAdd,
+ psTimeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+
+ {Make sure that result was valid before we continue}
+ Check(Result);
+
+ psSrSessionID := Reply^.SessionID;
+
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+destructor TFFProxySession.Destroy;
+var
+ Request : TffnmSessionCloseReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ if SrSessionID > 0 then begin
+ { Initiailize Request }
+ Request.SessionID := SrSessionID;
+
+ Reply := nil;
+ Client.ProcessRequest(ffnmSessionClose,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+ end;
+
+ psClient := nil;
+
+ inherited Destroy;
+end;
+{----------}
+function TFFProxySession.SetTimeout(aTimeout : Longint) : TffResult;
+var
+ Request : TffnmSessionSetTimeoutReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ Result := DBIERR_NONE;
+ if psTimeout = aTimeout then Exit;
+
+ psTimeout := aTimeout;
+
+ { Initiailize Request }
+ Request.SessionID := psSrSessionID;
+ Request.Timeout := psTimeout;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmSessionSetTimeout,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{------------------------------------------------------------------------------}
+
+
+
+{-TFFProxyDatabase-------------------------------------------------------------}
+constructor TFFProxyDatabase.Create(aClient : TFFProxyClient;
+ aLocation : string;
+ aOpenMode : TffOpenMode;
+ aShareMode : TffShareMode;
+ aTimeout : Longint;
+ aIsAlias : Boolean);
+var
+ RequestAlias : TffnmDatabaseOpenReq;
+ RequestPath : TffnmDatabaseOpenNoAliasReq;
+ ReplyAlias : PffnmDatabaseOpenRpy;
+ ReplyPath : PffnmDatabaseOpenNoAliasRpy;
+ ReplyLen : Longint;
+ Result : TffResult;
+begin
+ inherited Create;
+
+ pdInTrans := False;
+ pdSrDatabaseID := 0;
+ pdClient := aClient;
+ pdTimeout := aTimeout;
+
+ pdStmts := TffProxySQLStmtList.Create;
+ pdTables := TFFProxyCursorList.Create;
+
+ if aIsAlias then begin
+ { Initiailize Request }
+ RequestAlias.Alias := aLocation;
+ RequestAlias.OpenMode := aOpenMode;
+ RequestAlias.ShareMode := aShareMode;
+ RequestAlias.Timeout := aTimeout;
+
+ ReplyAlias := nil;
+ Result := Client.ProcessRequest(ffnmDatabaseOpen,
+ pdTimeout,
+ @RequestAlias,
+ SizeOf(RequestAlias),
+ nmdByteArray,
+ Pointer(ReplyAlias),
+ ReplyLen,
+ nmdByteArray);
+ Check(Result);
+
+ pdSrDatabaseID := ReplyAlias^.DatabaseID;
+
+ FFFreeMem(ReplyAlias, ReplyLen);
+ end else begin
+ { Initiailize Request }
+ RequestPath.Path := aLocation;
+ RequestPath.OpenMode := aOpenMode;
+ RequestPath.ShareMode := aShareMode;
+ RequestPath.Timeout := aTimeout;
+
+ ReplyPath := nil;
+ Result := Client.ProcessRequest(ffnmDatabaseOpenNoAlias,
+ pdTimeout,
+ @RequestPath,
+ SizeOf(RequestPath),
+ nmdByteArray,
+ Pointer(ReplyPath),
+ ReplyLen,
+ nmdByteArray);
+ Check(Result);
+
+ pdSrDatabaseID := ReplyPath^.DatabaseID;
+
+ FFFreeMem(ReplyPath, ReplyLen);
+ end;
+end;
+{----------}
+destructor TFFProxyDatabase.Destroy;
+var
+// Idx : Longint; {!!.03}
+ Request : TffnmDatabaseCloseReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ {Destroy dependent objects}
+ if InTrans then
+ TransactionRollback;
+
+{Begin !!.03}
+// with pdTables.BeginWrite do
+// try
+// for Idx := 0 to Pred(Count) do
+// TFFProxyCursor(Items[Idx]).Free;
+// finally
+// EndWrite;
+// end;
+
+ pdTables.Free;
+ pdTables := nil;
+
+// with pdStmts.BeginWrite do
+// try
+// for Idx := 0 to Pred(Count) do
+// TffProxySQLStmt(Items[Idx]).Free;
+// finally
+// EndWrite;
+// end;
+{End !!.03}
+
+ pdStmts.Free;
+ pdStmts := nil;
+
+ {Let the server know that we are leaving}
+ if SrDatabaseID > 0 then begin
+ { Initiailize Request }
+ Request.DatabaseID := SrDatabaseID;
+
+ Reply := nil;
+ Client.ProcessRequest(ffnmDatabaseClose,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+ end;
+ {Reset internals}
+ pdSrDatabaseID := 0;
+ pdClient := nil;
+
+ inherited;
+end;
+{----------}
+function TffProxyDatabase.GetDbFreeSpace(var aFreeSpace : Longint) : TffResult;
+var
+ Request : TffnmDatabaseGetFreeSpaceReq;
+ Reply : PffnmDatabaseGetFreeSpaceRpy;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.DatabaseID := pdSrDatabaseID;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmDatabaseGetFreeSpace,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+ if ResultOK(Result) then
+ aFreeSpace := Reply^.FreeSpace;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TffProxyDatabase.QueryOpen(aCursorID : TffCursorID;
+ aOpenMode : TffOpenMode;
+ aShareMode : TffShareMode;
+ aTimeout : longInt;
+ aStream : TStream;
+ var aFinalCursorID : TffCursorID) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+ ListItem : TffIntListItem;
+begin
+ Cursor := nil;
+ Result := DBIERR_NONE;
+
+ try
+ Cursor := TFFProxyCursor.CreateSQL(Self, aCursorID, aOpenMode, aShareMode,
+ aTimeout, aStream);
+ except
+ on E:Exception do
+ if (E is EffException) or (E is EffDatabaseError) then
+ Result := EffException(E).ErrorCode;
+ end;
+
+ if ResultOK(Result) and Assigned(Cursor) then begin
+ ListItem := TffIntListItem.Create(Longint(Cursor));
+ ListItem.MaintainLinks := False; {!!.02}
+ with pdTables.BeginWrite do
+ try
+ Insert(ListItem);
+ finally
+ EndWrite;
+ end;
+
+ aFinalCursorID := Longint(Cursor);
+ end;
+end;
+{----------}
+function TFFProxyDatabase.SetTimeout(const aTimeout : Longint) : TffResult;
+var
+ Request : TffnmDatabaseSetTimeoutReq;
+ Reply : pointer;
+ ReplyLen : Longint;
+begin
+ Result := DBIERR_NONE;
+ if pdTimeout = aTimeout then Exit;
+
+ pdTimeout := aTimeout;
+
+ { Initialize Request }
+ Request.DatabaseID := pdSrDatabaseID;
+ Request.Timeout := aTimeout;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmDatabaseSetTimeout,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TffProxyDatabase.SQLAlloc(const aTimeout : longInt;
+ var aStmtID : TffSqlStmtID) : TffResult;
+var
+ ListItem : TffIntListItem;
+ Statement : TffProxySQLStmt;
+begin
+ Statement := nil;
+ Result := DBIERR_NONE;
+
+ try
+ Statement := TffProxySQLStmt.Create(Self, aTimeout);
+ except
+ on E:Exception do
+ if (E is EffException) or (E is EffDatabaseError) then
+ Result := EffException(E).ErrorCode;
+ end;
+
+ if ResultOK(Result) and Assigned(Statement) then begin
+ ListItem := TffIntListItem.Create(Longint(Statement));
+ with pdStmts.BeginWrite do
+ try
+ Insert(ListItem);
+ finally
+ EndWrite;
+ end;
+
+ aStmtID := Longint(Statement);
+ end;
+
+end;
+{----------}
+function TffProxyDatabase.SQLExecDirect(aQueryText : PChar;
+ aOpenMode : TffOpenMode;
+ aTimeout : longInt;
+ var aCursorID : TffCursorID;
+ aStream : TStream) : TffResult;
+var
+ QueryLen : Longint;
+ ReplyLen : Longint;
+ Request : PffnmSQLExecDirectReq;
+ ReqLen : Longint;
+ SvrCursorID : TffCursorID;
+begin
+ Assert(Assigned(aStream));
+ QueryLen := StrLen(aQueryText);
+ ReqLen := SizeOf(TffnmSQLExecDirectReq) - sizeOf(TffVarMsgField) + {!!.05}
+ QueryLen + 1; {!!.05}
+ FFGetZeroMem(Request, ReqLen);
+ try
+ { Prepare the request. }
+ Move(aQueryText^, Request^.Query, QueryLen);
+ Request^.DatabaseID := pdSrDatabaseID;
+ Request^.Timeout := aTimeout;
+ Request^.OpenMode := aOpenMode;
+
+ Result := pdClient.ProcessRequest(ffnmSQLExecDirect,
+ pdTimeout,
+ Request,
+ ReqLen,
+ nmdByteArray,
+ Pointer(aStream),
+ ReplyLen,
+ nmdStream);
+
+ { Was the execution successful? }
+ if Result = DBIERR_NONE then begin
+ { Yes. Get the cursorID from the stream & open a proxy cursor. }
+ aStream.Position := 0;
+ aStream.Read(SvrCursorID, sizeOf(SvrCursorID));
+ if SvrCursorID <> 0 then {!!.11}
+ Result := QueryOpen(SvrCursorID, aOpenMode, smShared, aTimeout,
+ aStream, aCursorID);
+ end;
+
+ { Assumption: Upper levels are responsible for Stream contents. }
+
+ finally
+ FFFreeMem(Request, ReqLen);
+ end;
+
+end;
+{----------}
+function TFFProxyDatabase.TableAddIndex(const aCursorID : TffCursorID;
+ const aTableName : TffTableName;
+ const aIndexDesc : TffIndexDescriptor
+ ) : TffResult;
+var
+ Request : TffnmAddIndexReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.DatabaseID := SrDatabaseID;
+ if aCursorID > 0 then
+ Request.CursorID := TFFProxyCursor(aCursorID).SrCursorID
+ else
+ Request.CursorID := 0;
+ Request.TableName := aTableName;
+ Request.IndexDesc := aIndexDesc;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmAddIndex,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyDatabase.TableBuild(aOverWrite : Boolean;
+ const aTableName : TffTableName;
+ aForServer : Boolean;
+ aDictionary : TffDataDictionary
+ ) : TffResult;
+var
+ Request : TMemoryStream;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request := TMemoryStream.Create;
+ try
+ Request.Write(pdSrDatabaseID, SizeOf(pdSRDatabaseID)); {!!.10}
+ Request.Write(aOverWrite, SizeOf(aOverWrite));
+ Request.Write(aTableName, SizeOf(aTableName));
+ aDictionary.WriteToStream(Request);
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmBuildTable,
+ Timeout,
+ Request.Memory,
+ Request.Size,
+ nmdStream,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+ finally
+ Request.Free;
+ end;
+end;
+{----------}
+function TFFProxyDatabase.TableClose(aCursor : TFFProxyCursor) : TffResult;
+begin
+ Result := DBIERR_NONE;
+
+ with pdTables.BeginWrite do
+ try
+ Delete(aCursor); {!!.01}
+ finally
+ EndWrite;
+ end;
+
+ aCursor.Free;
+ aCursor := nil;
+end;
+{----------}
+function TFFProxyDatabase.TableDelete(const aTableName : TffTableName
+ ) : TffResult;
+var
+ Request : TffnmDeleteTableReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.DatabaseID := SrDatabaseID;
+ Request.TableName := aTableName;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmDeleteTable,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TffProxyDatabase.TableDropIndex(aCursorID : TffCursorID;
+ const aTableName : TffTableName;
+ const aIndexName : TffDictItemName;
+ aIndexID : longint) : TffResult;
+var
+ Request : TffnmDropIndexReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.DatabaseID := SrDatabaseID;
+ if aCursorID > 0 then
+ Request.CursorID := TFFProxyCursor(aCursorID).SrCursorID
+ else
+ Request.CursorID := aCursorID;
+ Request.TableName := aTableName;
+ Request.IndexName := aIndexName;
+ Request.IndexNumber := aIndexID;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmDropIndex,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TffProxyDatabase.TableEmpty(aCursorID : TffCursorID;
+ const aTableName : TffTableName) : TffResult;
+var
+ Request : TffnmEmptyTableReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.DatabaseID := SrDatabaseID;
+ if aCursorID > 0 then
+ Request.CursorID := TFFProxyCursor(aCursorID).SrCursorID
+ else
+ Request.CursorID := aCursorID;
+ Request.TableName := aTableName;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmEmptyTable,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyDatabase.TableGetDictionary(const aTableName : TffTableName;
+ aForServer : Boolean;
+ aStream : TStream
+ ) : TffResult;
+var
+ Request : TffnmGetTableDictionaryReq;
+ ReplyLen : Longint;
+begin
+ Assert(Assigned(aStream));
+ { Initialize Request }
+ Request.DatabaseID := SrDatabaseID;
+ Request.TableName := FFExtractFileName(aTableName);
+
+ aStream.Position := 0;
+ Result := Client.ProcessRequest(ffnmGetTableDictionary,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(aStream),
+ ReplyLen,
+ nmdStream);
+end;
+{----------}
+function TffProxyDatabase.TableExists(const aTableName : TffTableName;
+ var aExists : Boolean) : TffResult;
+var
+ Request : TffnmDatabaseTableExistsReq;
+ Reply : PffnmDatabaseTableExistsRpy;
+ ReplyLen : Longint;
+begin
+ Request.DatabaseID := SrDatabaseID;
+ Request.TableName := aTableName;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmDatabaseTableExists,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+ if ResultOK(Result) then
+ aExists := Reply^.Exists;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyDatabase.TableList(const aMask : TffFileNameExt;
+ aList : TList) : TffResult;
+var
+ Request : TffnmDatabaseTableListReq;
+ ReplyLen : Longint;
+ Stream : TStream;
+ TableDescr : PffTableDescriptor;
+ Count : Longint;
+begin
+ Stream := TMemoryStream.Create;
+ try
+ { Initialize Request }
+ Request.DatabaseID := SrDatabaseID;
+ Request.Mask := aMask;
+
+ Result := Client.ProcessRequest(ffnmDatabaseTableList,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Stream),
+ ReplyLen,
+ nmdStream);
+
+ if ResultOK(Result) then begin
+ {Build the list}
+ Stream.Position := 0;
+ aList.Clear;
+
+ for Count := 1 to (Stream.Size div SizeOf(TffTableDescriptor)) do begin
+ FFGetMem(TableDescr, SizeOf(TFFTableDescriptor));
+ Stream.Read(TableDescr^, SizeOf(TffTableDescriptor));
+ aList.Add(TableDescr);
+ end;
+ end;
+ finally
+ Stream.Free;
+ end;
+end;
+function TffProxyDatabase.TableLockedExclusive(const aTableName : TffTableName;
+ var aLocked : Boolean
+ ) : TffResult;
+var
+ Request : TffnmDatabaseTableLockedExclusiveReq;
+ Reply : PffnmDatabaseTableLockedExclusiveRpy;
+ ReplyLen : Longint;
+begin
+ Request.DatabaseID := SrDatabaseID;
+ Request.TableName := aTableName;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmDatabaseTableLockedExclusive,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+ if ResultOK(Result) then
+ aLocked := Reply^.Locked;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyDatabase.TableOpen(const aTableName : TffTableName;
+ aForServer : Boolean;
+ aIndexName : TffName;
+ aIndexID : Longint;
+ aOpenMode : TffOpenMode;
+ aShareMode : TffShareMode;
+ aTimeout : Longint;
+ var aCursorID : TffCursorID;
+ aStream : TStream) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+ ListItem : TffIntListItem;
+begin
+ Assert(Assigned(aStream));
+ Cursor := nil;
+ Result := DBIERR_NONE;
+
+ try
+ Cursor := TFFProxyCursor.Create(Self,
+ 0,
+ aTableName,
+ aForServer,
+ aIndexName,
+ aIndexID,
+ aOpenMode,
+ aShareMode,
+ aTimeout,
+ aStream);
+ except
+ on E:Exception do
+ if (E is EffException) or (E is EffDatabaseError) then
+ Result := EffException(E).ErrorCode;
+ end;
+
+ if ResultOK(Result) and Assigned(Cursor) then begin
+ ListItem := TffIntListItem.Create(Longint(Cursor));
+ ListItem.MaintainLinks := False; {!!.02}
+ with pdTables.BeginWrite do
+ try
+ Insert(ListItem);
+ finally
+ EndWrite;
+ end;
+
+ aCursorID := Longint(Cursor);
+ end;
+end;
+{----------}
+function TFFProxyDatabase.TablePack(const aTableName : TffTableName;
+ var aRebuildID : Longint) : TffResult;
+var
+ Request : TffnmPackTableReq;
+ Reply : PffnmPackTableRpy;
+ ReplyLen : Longint;
+begin
+ aRebuildID := -1;
+ { Initialize Request }
+ Request.DatabaseID := SrDatabaseID;
+ Request.TableName := aTableName;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmPackTable,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+
+ if ResultOK(Result) then
+ aRebuildID := Reply^.RebuildID;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyDatabase.TableRebuildIndex(const aTableName : TffTableName;
+ const aIndexName : TffName;
+ aIndexID : Longint;
+ var aRebuildID : Longint
+ ) : TffResult;
+var
+ Request : TffnmReindexTableReq;
+ Reply : PffnmReindexTableRpy;
+ ReplyLen : Longint;
+begin
+ aRebuildID := -1;
+ { Initialize Request }
+ Request.DatabaseID := SrDatabaseID;
+ Request.TableName := aTableName;
+ Request.IndexName := aIndexName;
+ Request.IndexNumber := aIndexID;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmReindexTable,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+ if ResultOK(Result) then
+ aRebuildID := Reply^.RebuildID;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyDatabase.TableRename(const aOldName : TffName;
+ const aNewName : TffName) : TffResult;
+var
+ Request : TffnmRenameTableReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.DatabaseID := SrDatabaseID;
+ Request.OldTableName := aOldName;
+ Request.NewTableName := aNewName;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmRenameTable,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyDatabase.TableRestructure(
+ const aTableName : TffTableName;
+ aDictionary : TffDataDictionary;
+ aFieldMap : TffStringList;
+ var aRebuildID : Longint
+ ) : TffResult;
+var
+ I : Longint;
+ NullByte : Byte;
+ Request : TMemoryStream;
+ Reply : PffnmRestructureTableRpy;
+ FieldMapEntry : TffShStr;
+ ReplyLen : Longint;
+begin
+ NullByte := 0;
+ aRebuildID := -1;
+
+ { Initialize Request }
+ Request := TMemoryStream.Create;
+ try
+ Request.Write(SrDatabaseID, SizeOf(LongInt));
+ Request.Write(aTableName, SizeOf(aTableName));
+ aDictionary.WriteToStream(Request);
+ if Assigned(aFieldMap) then
+ for I := 0 to aFieldMap.Count - 1 do begin
+ FieldMapEntry := aFieldMap[I];
+ Request.Write(FieldMapEntry, Length(FieldMapEntry) + 1);
+ end;
+ Request.Write(NullByte, SizeOf(NullByte));
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmRestructureTable,
+ Timeout,
+ Request.Memory,
+ Request.Size,
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+
+ if ResultOK(Result) then
+ aRebuildID := Reply^.RebuildID;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+
+ finally
+ Request.Free;
+ end;
+end;
+{----------}
+function TFFProxyDatabase.TransactionCommit : TffResult;
+var
+ Request : TffnmEndTransactionReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.DatabaseID := SrDatabaseID;
+ Request.ToBeCommitted := True;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmEndTransaction,
+ pdTimeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyDatabase.TransactionRollback : TffResult;
+var
+ Request : TffnmEndTransactionReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.DatabaseID := SrDatabaseID;
+ Request.ToBeCommitted := False;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmEndTransaction,
+ pdTimeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyDatabase.TransactionStart(aFailSafe : Boolean) : TffResult;
+var
+ Request : TffnmStartTransactionReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.DatabaseID := SrDatabaseID;
+ Request.FailSafe := aFailSafe;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmStartTransaction,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+ Check(Result);
+end;
+
+//soner FlashBufferHack
+type
+ TBinaryObjectWriterHack = class(TBinaryObjectWriter)
+ public
+ //procedure FlushBuffer;
+ end;
+//end soner FlashBufferHack
+{Start !!.10}
+{----------}
+function TFFProxyDatabase.TransactionStartWith(const aFailSafe : Boolean;
+ const aCursorIDs : TffPointerList
+ ) : TffResult;
+var
+ Reply : Pointer;
+ Inx,
+ aCount,
+ ReplyLen : Longint;
+ Request : TMemoryStream;
+ Writer : TWriter;
+begin
+ { Initialize Request }
+ Request := TMemoryStream.Create;
+ Writer := TWriter.Create(Request, 4096);
+ try
+ Writer.WriteInteger(pdSrDatabaseID);
+ Writer.WriteBoolean(aFailSafe);
+ aCount := aCursorIDs.Count;
+ Writer.WriteInteger(aCount);
+ for Inx := 0 to Pred(aCount) do
+ { Get the cursorID of the proxy cursor. }
+ Writer.WriteInteger(TffProxyCursor(aCursorIDs[Inx]).SrCursorID);
+ {$ifdef fpc}
+ TBinaryObjectWriterHack(Writer.Driver).FlushBuffer; //soner
+ {$else}
+ Writer.FlushBuffer;
+ {$endif}
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmStartTransactionWith,
+ Timeout,
+ Request.Memory,
+ Request.Size,
+ nmdStream,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ finally
+ Writer.Free;
+ Request.Free;
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+ end;
+// Check(Result); {Deleted !!.11}
+end;
+{End !!.10}
+{------------------------------------------------------------------------------}
+
+
+
+{-TFFProxyCursor---------------------------------------------------------------}
+function TFFProxyCursor.BlobCreate(var aBlobNr : TFFInt64) : TffResult;
+var
+ Request : TffnmCreateBLOBReq;
+ Reply : PffnmCreateBLOBRpy;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmCreateBLOB,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+
+ if ResultOK(Result) then
+ aBlobNr := Reply^.BLOBNr;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyCursor.BLOBDelete(aBlobNr : TFFInt64) : TffResult;
+var
+ Request : TffnmDeleteBLOBReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+ Request.BLOBNr := aBlobNr;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmDeleteBLOB,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyCursor.BLOBFree(aBlobNr : TffInt64;
+ aReadOnly : Boolean) : TffResult;
+var
+ Request : TffnmFreeBLOBReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+ Request.BLOBNr := aBLOBNr;
+ Request.ReadOnly := aReadOnly;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmFreeBLOB,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyCursor.BLOBGetLength(aBlobNr : TffInt64;
+ var aLength : Longint) : TffResult;
+var
+ Request : TffnmGetBLOBLengthReq;
+ Reply : PffnmGetBLOBLengthRpy;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+ Request.BLOBNr := aBLOBNr;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmGetBLOBLength,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+ if ResultOK(Result) then
+ aLength := Reply^.BLOBLength;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{Begin !!.03}
+{----------}
+function TffProxyCursor.BLOBListSegments(aBLOBNr : TffInt64;
+ aStream : TStream) : TffResult;
+var
+ Request : TffnmListBLOBSegmentsReq;
+ ReplyLen : Longint;
+begin
+ Request.CursorID := SrCursorID;
+ Request.BLOBNr := aBLOBNr;
+ Result := Client.ProcessRequest(ffnmListBLOBSegments,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(aStream),
+ ReplyLen,
+ nmdStream);
+
+ if ResultOK(Result) then
+ aStream.Position := 0;
+end;
+{End !!.03}
+{----------}
+function TFFProxyCursor.BLOBRead(aBlobNr : TffInt64;
+ aOffset : TffWord32; {!!.06}
+ aLen : TffWord32; {!!.06}
+ var aBLOB;
+ var aBytesRead : TffWord32) {!!.06}
+ : TffResult;
+var
+ Request : TffnmReadBLOBReq;
+ Reply : PffnmReadBLOBRpy;
+ ReplyLen : longint;
+begin
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+ Request.BLOBNr := aBLOBNr;
+ Request.Offset := aOffset;
+ Request.Len := aLen;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmReadBLOB,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+
+ if ResultOK(Result) then begin
+ aBytesRead := Reply^.BytesRead;
+ Move(Reply^.BLOB, aBLOB, aBytesRead);
+ end;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyCursor.BLOBTruncate(aBlobNr : TffInt64;
+ aBLOBLength : Longint) : TffResult;
+var
+ Request : TffnmTruncateBLOBReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+ Request.BLOBNr := aBLOBNr;
+ Request.BLOBLength := aBLOBLength;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmTruncateBLOB,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyCursor.BLOBWrite(aBlobNr : TffInt64;
+ aOffset : Longint;
+ aLen : Longint;
+ var aBLOB) : TffResult;
+var
+ Request : PffnmWriteBLOBReq;
+ ReqLen : longint;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ ReqLen := SizeOf(TffnmWriteBLOBReq) - 2 + aLen;
+ FFGetZeroMem(Request, ReqLen);
+ try
+ { Initialize Request }
+ Request^.CursorID := SrCursorID;
+ Request^.BLOBNr := aBLOBNr;
+ Request^.Offset := aOffSet;
+ Request^.Len := aLen;
+ Move(aBLOB, Request^.BLOB, aLen);
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmWriteBLOB,
+ Timeout,
+ Request,
+ ReqLen,
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+ finally
+ FFFreeMem(Request, ReqLen);
+ end;
+end;
+{----------}
+function TFFProxyCursor.CompareBookmarks(aBookmark1 : PffByteArray;
+ aBookmark2 : PffByteArray;
+ var aCompResult : Longint) : TffResult;
+var
+ Request : PffnmCursorCompareBMsReq;
+ ReqLen : Longint;
+ Reply : PffnmCursorCompareBMsRpy;
+ pBM2 : Pointer;
+ ReplyLen : Longint;
+begin
+ ReqLen := SizeOf(TffnmCursorCompareBMsReq) - 4 + (2 * BookmarkSize);
+ FFGetZeroMem(Request, ReqLen);
+ try
+ { Initialize Request }
+ Request^.CursorID := SrCursorID;
+ Request^.BookmarkSize := BookmarkSize;
+ Move(aBookMark1^, Request^.Bookmark1, BookmarkSize);
+ pBM2 := PffByteArray(PAnsiChar(@Request^.BookMark1) + BookmarkSize);
+ Move(aBookMark2^, pBM2^, BookmarkSize);
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmCursorCompareBMs,
+ Timeout,
+ Request,
+ ReqLen,
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+ if ResultOK(Result) then
+ aCompResult := Reply^.CompareResult;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+
+ finally
+ FFFreeMem(Request, ReqLen);
+ end;
+end;
+{----------}
+constructor TFFProxyCursor.Create(aDatabase : TFFProxyDatabase;
+ aCursorID : TffCursorID;
+ aTableName : string;
+ aForServer : Boolean;
+ aIndexName : string;
+ aIndexID : Longint;
+ aOpenMode : TffOpenMode;
+ aShareMode : TffShareMode;
+ aTimeout : Longint;
+ aStream : TStream);
+var
+ Request : TffnmOpenTableReq;
+ ReplyLen : Longint;
+ Result : TffResult;
+
+begin
+ inherited Create;
+
+ prClient := aDatabase.Client;
+ prDatabase := aDatabase;
+ prSrCursorID := aCursorID;
+ prTableName := aTableName;
+ prForServer := aForServer;
+ prDictionary := TffDataDictionary.Create(4096);
+ prIndexName := aIndexName;
+ prIndexID := aIndexID;
+ prIsSQLCursor := false;
+ prShareMode := aShareMode;
+ prPhyRecSize := 0;
+ prTimeout := aTimeout;
+
+ if prSrCursorID <> 0 then Exit; {CursorClone operation, nothing more to do}
+
+ Assert(Assigned(aStream));
+
+ { Initialize Request }
+ Request.DatabaseID := Database.SrDatabaseID;
+ Request.TableName := FFExtractTableName(aTableName);
+ Request.IndexName := aIndexName;
+ Request.IndexNumber := aIndexID;
+ Request.OpenMode := aOpenMode;
+ Request.ShareMode := aShareMode;
+ Request.Timeout := prTimeout;
+
+ Result := Client.ProcessRequest(ffnmOpenTable,
+ prTimeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(aStream),
+ ReplyLen,
+ nmdStream);
+
+ Check(Result);
+
+ aStream.Position := 0;
+ aStream.Read(prSrCursorID, SizeOf(prSrCursorID));
+
+ {save the data dictionary for this table as well}
+
+ Dictionary.ReadFromStream(aStream);
+ aStream.Read(prIndexID, SizeOf(prIndexID));
+ prIndexName := prDictionary.IndexName[prIndexID];
+ prPhyRecSize := prDictionary.RecordLength;
+end;
+{----------}
+constructor TffProxyCursor.CreateSQL(aDatabase : TffProxyDatabase;
+ aCursorID : TffCursorID;
+ aOpenMode : TffOpenMode;
+ aShareMode : TffShareMode;
+ aTimeout : longInt;
+ aStream : TStream);
+begin
+ inherited Create;
+
+ Assert(Assigned(aStream));
+
+ prClient := aDatabase.Client;
+ prDatabase := aDatabase;
+ prTableName := '';
+ prForServer := false;
+ prDictionary := TffDataDictionary.Create(ffcl_64k);
+ prIsSQLCursor := True;
+ prShareMode := aShareMode;
+ prTimeout := aTimeout;
+
+ aStream.Position := 0;
+ aStream.Read(prSrCursorID, SizeOf(prSrCursorID));
+
+ { Save the data dictionary for this table. }
+
+ Dictionary.ReadFromStream(aStream);
+// aStream.Read(prIndexID, SizeOf(prIndexID)); {Deleted !!.10}
+ prIndexID := 0; {!!.10}
+ prIndexName := prDictionary.IndexName[0]; {!!.10}
+ prPhyRecSize := prDictionary.RecordLength;
+end;
+{----------}
+function TFFProxyCursor.CursorClone(aOpenMode : TFFOpenMode;
+ var aNewCursorID : TFFCursorID) : TffResult;
+var
+ Request : TffnmCursorCloneReq;
+ Reply : PffnmCursorCloneRpy;
+ ReplyLen : Longint;
+ NewCursor : TffProxyCursor;
+begin
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+ Request.OpenMode := aOpenMode;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmCursorClone,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+ if ResultOK(Result) then begin
+ {Create a new proxy cursor with the appropriate information}
+ NewCursor := TffProxyCursor.Create(prDatabase,
+ Reply^.CursorID,
+ ''{tableName},
+ False, {forserver}
+ prIndexName,
+ prIndexID,
+ aOpenMode,
+ smShared, {share mode}
+ prTimeout,
+ nil);
+ NewCursor.prDictionary.Assign(prDictionary);
+ NewCursor.prIndexName := prIndexName;
+ NewCursor.prPhyRecSize := NewCursor.prDictionary.RecordLength;
+ aNewCursorID := Longint(NewCursor);
+ end;
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+destructor TFFProxyCursor.Destroy;
+var
+ Request : TffnmCursorCloseReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ if SrCursorID > 0 then begin
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+
+ Reply := nil;
+ Client.ProcessRequest(ffnmCursorClose,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+ end;
+
+ prSrCursorID := 0;
+ prDictionary.Free;
+ prDictionary := nil;
+ prDatabase := nil;
+ prClient := nil;
+
+ inherited Destroy;
+end;
+{----------}
+function TFFProxyCursor.FileBLOBAdd(const aFileName : TffFullFileName;
+ var aBlobNr : TffInt64) : TffResult;
+var
+ Request : TffnmAddFileBLOBReq;
+ Reply : PffnmAddFileBLOBRpy;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+ Request.FileName := aFileName;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmAddFileBLOB,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+
+ if ResultOK(Result) then
+ aBlobNr := Reply^.BLOBNr;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{Begin !!.02}
+{----------}
+function TffProxyCursor.CopyRecords(aSrcCursor : TffProxyCursor;
+ aCopyBLOBs : Boolean) : TffResult;
+var
+ Request : TffnmCursorCopyRecordsReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+
+ { Initialize Request }
+ Request.SrcCursorID := aSrcCursor.SrCursorID;
+ Request.DestCursorID := SrCursorID;
+ Request.CopyBLOBs := aCopyBLOBs;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmCursorCopyRecords,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{End !!.02}
+{Begin !!.06}
+{----------}
+function TffProxyCursor.DeleteRecords : TffResult;
+var
+ Request : TffnmCursorDeleteRecordsReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmCursorDeleteRecords,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{End !!.06}
+{----------}
+function TFFProxyCursor.GetBookmark(aBookmark : PffByteArray) : TffResult;
+var
+ Request : TffnmCursorGetBookMarkReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+ Request.BookMarkSize := BookMarkSize;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmCursorGetBookMark,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+
+ if ResultOK(Result) then
+ Move(Reply^, aBookmark^, BookmarkSize); {!!.05}
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyCursor.GetBookmarkSize(var aSize : Longint) : TffResult;
+begin
+ Result := DBIERR_NONE;
+ if prIsSQLCursor then
+ aSize := ffcl_FixedBookmarkSize
+ else
+ aSize := ffcl_FixedBookmarkSize + Dictionary.IndexKeyLength[IndexID];
+end;
+{----------}
+function TFFProxyCursor.prGetBookmarkSize : Longint;
+begin
+ GetBookmarkSize(Result);
+end;
+{----------}
+function TFFProxyCursor.RecordDelete(aData : PffByteArray) : TffResult;
+var
+ Request : TffnmRecordDeleteReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+ if aData = nil then
+ Request.RecLen := 0
+ else
+ Request.RecLen := PhysicalRecordSize;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmRecordDelete,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if ((ResultOK(Result)) and {!!.06}
+ (Assigned(aData))) then {!!.06}
+ Move(Reply^, aData^, ReplyLen);
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TffProxyCursor.RecordDeleteBatch(aBMCount : Longint;
+ aBMLen : Longint;
+ aData : PffByteArray;
+ aErrors : PffLongintArray
+ ) : TffResult;
+var
+ Request : PffnmRecordDeleteBatchReq;
+ MaxRecs : LongInt;
+ ReqLen : LongInt;
+ iErr : Longint;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ MaxRecs := 65500 div aBMLen;
+ if aBMCount > MaxRecs then begin
+ Result := DBIERR_ROWFETCHLIMIT;
+ Exit;
+ end;
+ ReqLen := SizeOf(Request^) - 2 + (aBMLen * aBMCount);
+ FFGetZeroMem(Request, ReqLen);
+ try
+ { Initialize Request }
+ Request^.CursorID := SrCursorID;
+ Request^.BMLen := aBMLen;
+ Request^.BMCount := aBMCount;
+ Move(aData^, Request^.BMArray, aBMCount * aBMLen);
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmRecordDeleteBatch,
+ Timeout,
+ Request,
+ ReqLen,
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if ResultOK(Result) then begin
+ Move(Reply^, aErrors^, ReplyLen);
+ for iErr := 0 to Pred(aBMCount) do
+ if aErrors^[iErr] <> DBIERR_NONE then begin
+ Result := aErrors^[iErr];
+ Break;
+ end;
+ end;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+
+ finally
+ FFFreeMem(Request, ReqLen);
+ end;
+end;
+{----------}
+function TFFProxyCursor.RecordExtractKey(aData : PffByteArray;
+ aKey : PffByteArray) : TffResult;
+var
+ Request : PffnmRecordExtractKeyReq;
+ ReqLen : Longint;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ ReqLen := SizeOf(TffnmRecordExtractKeyReq) - 2 + PhysicalRecordSize;
+ FFGetZeroMem(Request, ReqLen);
+ try
+ { Initialize Request}
+ Request^.CursorID := SrCursorID;
+ Request^.KeyLen := Dictionary.IndexKeyLength[IndexID];
+ if aData = nil then
+ Request^.ForCurrentRecord := True
+ else begin
+ Move(aData^, Request^.Data, PhysicalRecordSize);
+ Request^.ForCurrentRecord := False;
+ end;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmRecordExtractKey,
+ Timeout,
+ Request,
+ ReqLen,
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if ((ResultOK(Result)) and {!!.06}
+ (Assigned(aKey))) then {!!.06}
+ Move(Reply^, aKey^, ReplyLen);
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+ finally
+ FFFreeMem(Request, ReqLen); {!!.06}
+ end;
+end;
+{----------}
+function TFFProxyCursor.RecordGet(aLockType : TffLockType;
+ aData : PffByteArray)
+ : TffResult;
+var
+ Request : TffnmRecordGetReq;
+ Reply : Pointer;
+ RpyLen : TffMemSize;
+begin
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+ Request.LockType := aLockType;
+ Request.RecLen := PhysicalRecordSize; {server needs it no matter what}
+ Request.BookMarkSize := BookMarkSize;
+ if (aData = nil) then
+ RpyLen := 0
+ else
+ RpyLen := Request.RecLen;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmRecordGet,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ RpyLen,
+ nmdByteArray);
+ if ((Assigned(Reply)) and {!!.06}
+ (Assigned(aData))) then begin {!!.06}
+ Move(Reply^, aData^, RpyLen);
+ FFFreeMem(Reply, RpyLen);
+ end;
+end;
+{----------}
+function TFFProxyCursor.RecordGetBatch(aRecCount : Longint;
+ aRecLen : Longint;
+ var aRecRead : Longint;
+ aData : PffByteArray;
+ var aError : TffResult) : TffResult;
+var
+ Request : TffnmRecordGetBatchReq;
+ Reply : PffnmRecordGetBatchRpy;
+ ReplyLen : LongInt;
+begin
+ aRecRead := 0;
+ ReplyLen := SizeOf(Reply^) - 2 + (aRecLen * aRecCount);
+ Request.CursorID := SrCursorID;
+ Request.RecLen := aRecLen;
+ Request.RecCount := aRecCount;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmRecordGetBatch,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+ if ResultOK(Result) then begin
+ aRecRead := Reply^.RecCount;
+ Move(Reply^.RecArray, aData^, aRecRead * aRecLen);
+ aError := Reply^.Error;
+ end;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyCursor.RecordGetForKey(aDirectKey : Boolean;
+ aFieldCount : Longint;
+ aPartialLen : Longint;
+ aKeyData : PffByteArray;
+ aData : PffByteArray;
+ aFirstCall : Boolean) : TffResult;
+var
+ Request : PffnmRecordGetForKeyReq;
+ ReqLen : longint;
+ Reply : Pointer;
+ RpyLen : longint;
+ DataLen : Longint;
+ DictRecLen : Longint;
+begin
+ DictRecLen := PhysicalRecordSize;
+ if aDirectKey then
+ DataLen := Dictionary.IndexKeyLength[IndexID]
+ else
+ DataLen := DictRecLen;
+ ReqLen := SizeOf(TffnmRecordGetForKeyReq) - 2 + DataLen;
+ FFGetZeroMem(Request, ReqLen);
+ if (aData = nil) then
+ RpyLen := 0
+ else
+ RpyLen := DictRecLen;
+ try
+ { Initialize Request }
+ Request^.CursorID := SrCursorID;
+ Request^.BookMarkSize := BookMarkSize;
+ Request^.DirectKey := aDirectKey;
+ Request^.FieldCount := aFieldCount;
+ Request^.PartialLen := aPartialLen;
+ Request^.RecLen := DictRecLen;
+ Request^.KeyDataLen := DataLen;
+ Move(aKeyData^, Request^.KeyData, DataLen);
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmRecordGetForKey,
+ Timeout,
+ Request,
+ ReqLen,
+ nmdByteArray,
+ Reply,
+ RpyLen,
+ nmdByteArray);
+
+ if ((Assigned(Reply)) and {!!.06}
+ (Assigned(aData))) then begin {!!.06}
+ Move(Reply^, aData^, RpyLen);
+ FFFreeMem(Reply, RpyLen);
+ end;
+ finally
+ FFFreeMem(Request, ReqLen);
+ end;
+end;
+{----------}
+function TFFProxyCursor.RecordGetNext(aLockType : TffLockType;
+ aData : PffByteArray) : TffResult;
+var
+ Request : TffnmRecordGetNextReq;
+ ReplyLen : Longint;
+ Reply : Pointer;
+begin
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+ Request.LockType := aLockType;
+ if (aData <> nil) then begin
+ Request.RecLen := PhysicalRecordSize;
+ Request.BookMarkSize := BookMarkSize;
+ end else begin
+ Request.RecLen := 0;
+ Request.BookMarkSize := 0;
+ end;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmRecordGetNext,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then begin
+ Move(Reply^, aData^, ReplyLen);
+ FFFreeMem(Reply, ReplyLen);
+ end;
+end;
+{----------}
+function TFFProxyCursor.RecordGetPrior(aLockType : TffLockType;
+ aData : PffByteArray) : TffResult;
+var
+ Request : TffnmRecordGetPrevReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+ Request.LockType := aLockType;
+ if (aData <> nil) then begin
+ Request.RecLen := PhysicalRecordSize;
+ Request.BookMarkSize := BookMarkSize;
+ end
+ else begin
+ Request.RecLen := 0;
+ Request.BookMarkSize := 0;
+ end;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmRecordGetPrev,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+
+ if Assigned(Reply) then begin
+ Move(Reply^, aData^, ReplyLen);
+ FFFreeMem(Reply, ReplyLen);
+ end;
+end;
+{----------}
+function TFFProxyCursor.RecordInsert(aLockType : TffLockType;
+ aData : PffByteArray) : TffResult;
+var
+ Request : PffnmRecordInsertReq;
+ ReqLen : Longint;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ ReqLen := SizeOf(Request^) - 2 + PhysicalRecordSize;
+ FFGetZeroMem(Request, ReqLen);
+ try
+ { Initialize Request }
+ Request^.CursorID := SrCursorID;
+ Request^.LockType := aLockType;
+ Request^.RecLen := PhysicalRecordSize;
+ Request^.BookMarkSize := BookMarkSize;
+ Move(aData^, Request^.Data, PhysicalRecordSize);
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmRecordInsert,
+ Timeout,
+ Request,
+ ReqLen,
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+ finally
+ FFFreeMem(Request, ReqLen);
+ end;
+end;
+{----------}
+function TFFProxyCursor.RecordInsertBatch(aRecCount : Longint;
+ aRecLen : Longint;
+ aData : PffByteArray;
+ aErrors : PffLongintArray
+ ) : TffResult;
+var
+ Request : PffnmRecordInsertBatchReq;
+ MaxRecs : LongInt;
+ ReqLen : LongInt;
+ iErr : Longint;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ MaxRecs := 65500 div aRecLen;
+ if aRecCount > MaxRecs then begin
+ Result := DBIERR_ROWFETCHLIMIT;
+ Exit;
+ end;
+ ReqLen := SizeOf(Request^) - 2 + (aRecLen * aRecCount);
+ FFGetZeroMem(Request, ReqLen);
+ try
+ { Initialize Request }
+ Request^.CursorID := SrCursorID;
+ Request^.RecLen := aRecLen;
+ Request^.RecCount := aRecCount;
+ Move(aData^, Request^.RecArray, aRecCount * aRecLen);
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmRecordInsertBatch,
+ Timeout,
+ Request,
+ ReqLen,
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if ResultOK(Result) then begin
+ Move(Reply^, aErrors^, ReplyLen);
+ for iErr := 0 to Pred(aRecCount) do
+ if aErrors^[iErr] <> DBIERR_NONE then begin
+ Result := aErrors^[iErr];
+ Break;
+ end;
+ end;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+
+ finally
+ FFFreeMem(Request, ReqLen);
+ end;
+end;
+{----------}
+function TffProxyCursor.RecordIsLocked(aLockType : TffLockType;
+ var aIsLocked : boolean) : TffResult;
+var
+ Request : TffnmRecordIsLockedReq;
+ Reply : PffnmRecordIsLockedRpy;
+ ReplyLen : Longint;
+begin
+ Request.CursorID := SrCursorID;
+ Request.LockType := aLockType;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmRecordIsLocked,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+ if ResultOK(Result) then
+ aIsLocked := Reply^.IsLocked;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyCursor.RecordModify(aData : PffByteArray;
+ aRelLock : Boolean) : TffResult;
+var
+ Request : PffnmRecordModifyReq;
+ ReqLen : Longint;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ ReqLen := SizeOf(Request^) - 2 + PhysicalRecordSize;
+ FFGetZeroMem(Request, ReqLen);
+ try
+ { Initialize Request }
+ Request^.CursorID := SrCursorID;
+ Request^.RelLock := aRelLock;
+ Request^.RecLen := PhysicalRecordSize;
+ Request^.BookMarkSize := BookMarkSize;
+ Move(aData^, Request^.Data, PhysicalRecordSize);
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmRecordModify,
+ Timeout,
+ Request,
+ ReqLen,
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+ finally
+ FFFreeMem(Request, ReqLen);
+ end;
+end;
+{----------}
+function TFFProxyCursor.RecordRelLock(aAllLocks : Boolean) : TffResult;
+var
+ Request : TffnmRecordRelLockReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+ Request.AllLocks := aAllLocks;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmRecordRelLock,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TffProxyCursor.TableGetAutoInc(var aValue : TffWord32) : TffResult;
+var
+ Request : TffnmGetTableAutoIncValueReq;
+ Reply : PffnmGetTableAutoIncValueRpy;
+ ReplyLen : Longint;
+begin
+ Request.CursorID := SrCursorID;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmGetTableAutoIncValue,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+ if ResultOK(Result) then
+ aValue := Reply^.AutoIncValue;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{Begin !!.03}
+{----------}
+function TffProxyCursor.ListBLOBFreeSpace(const aInMemory : Boolean;
+ aStream : TStream) : TffResult;
+var
+ Request : TffnmGetBLOBFreeSpaceReq;
+ ReplyLen : Longint;
+begin
+ Request.CursorID := SrCursorID;
+ Request.InMemory := aInMemory;
+ Result := Client.ProcessRequest(ffnmListBLOBFreeSpace,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(aStream),
+ ReplyLen,
+ nmdStream);
+
+ if ResultOK(Result) then
+ aStream.Position := 0;
+end;
+{End !!.03}
+{----------}
+function TffProxyCursor.OverrideFilter(aExpression : pCANExpr;
+ aTimeout : TffWord32) : TffResult;
+var
+ ReqSize : Longint;
+ Request : PffnmCursorOverrideFilterReq;
+ ExprTree : CANExpr;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+
+ if not Assigned(aExpression) then begin
+ aExpression := @ExprTree;
+ FillChar(ExprTree, SizeOf(ExprTree), 0);
+ ExprTree.iVer := CANEXPRVERSION;
+ ExprTree.iTotalSize := SizeOf(ExprTree);
+ end;
+
+ ReqSize := (SizeOf(Request^) - 2 + aExpression^.iTotalSize);
+
+ FFGetMem(Request, ReqSize);
+ try
+ { Initialize Request }
+ Request^.CursorID := SrCursorID;
+ Request^.Timeout := aTimeout;
+
+ Move(aExpression^, Request^.ExprTree, aExpression^.iTotalSize);
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmCursorOverrideFilter,
+ Timeout,
+ Pointer(Request),
+ ReqSize,
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+ finally
+ FFFreeMem(Request, ReqSize);
+ end;
+end;
+{----------}
+function TFFProxyCursor.ResetRange : TffResult;
+var
+ Request : TffnmCursorResetRangeReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmCursorResetRange,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+
+end;
+{----------}
+function TffProxyCursor.RestoreFilter : TffResult;
+var
+ Request : TffnmCursorRestoreFilterReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmCursorRestoreFilter,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+
+end;
+{----------}
+function TFFProxyCursor.SetFilter(aExpression : pCANExpr;
+ aTimeout : TffWord32) : TffResult;
+var
+ ReqSize : Longint;
+ Request : PffnmCursorSetFilterReq;
+ ExprTree : CANExpr;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ if not Assigned(aExpression) then begin
+ aExpression := @ExprTree;
+ FillChar(ExprTree, SizeOf(ExprTree), 0);
+ ExprTree.iVer := CANEXPRVERSION;
+ ExprTree.iTotalSize := SizeOf(ExprTree);
+ end;
+
+ ReqSize := (SizeOf(Request^) - 2 + aExpression^.iTotalSize);
+
+ FFGetMem(Request, ReqSize);
+ try
+ { Initialize Request }
+ Request^.CursorID := SrCursorID;
+ Request^.Timeout := aTimeout;
+
+ Move(aExpression^, Request^.ExprTree, aExpression^.iTotalSize);
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmCursorSetFilter,
+ Timeout,
+ Pointer(Request),
+ ReqSize,
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+ finally
+ FFFreeMem(Request, ReqSize);
+ end;
+end;
+{----------}
+function TFFProxyCursor.SetRange(aDirectKey : Boolean;
+ aFieldCount1 : Longint;
+ aPartialLen1 : Longint;
+ aKeyData1 : PffByteArray;
+ aKeyIncl1 : Boolean;
+ aFieldCount2 : Longint;
+ aPartialLen2 : Longint;
+ aKeyData2 : PffByteArray;
+ aKeyIncl2 : Boolean) : TffResult;
+var
+ Request : PffnmCursorSetRangeReq;
+ ReqLen : Longint;
+ KeyLen1 : Longint;
+ KeyLen2 : Longint;
+ Reply : Pointer;
+ ReplyLen : Longint;
+ ReqKeyData2 : pointer;
+begin
+ {calculate sizes}
+ if aKeyData1 = nil then
+ KeyLen1 := 0
+ else if aDirectKey then
+ KeyLen1 := Dictionary.IndexKeyLength[ IndexID ]
+ else
+ KeyLen1 := PhysicalRecordSize;
+ if aKeyData2 = nil then
+ KeyLen2 := 0
+ else if aDirectKey then
+ KeyLen2 := Dictionary.IndexKeyLength[ IndexID ]
+ else
+ KeyLen2 := PhysicalRecordSize;
+
+ {now, we know how large the Request is}
+ ReqLen := SizeOf(Request^) - 4 + KeyLen1 + KeyLen2;
+
+ {allocate and clear it}
+ FFGetZeroMem(Request, ReqLen);
+ try
+ { Initialize Request }
+ Request^.CursorID := SrCursorID;
+ Request^.DirectKey := aDirectKey;
+ Request^.FieldCount1 := aFieldCount1;
+ Request^.PartialLen1 := aPartialLen1;
+ Request^.KeyLen1 := KeyLen1;
+ Request^.KeyIncl1 := aKeyIncl1;
+ Request^.FieldCount2 := aFieldCount2;
+ Request^.PartialLen2 := aPartialLen2;
+ Request^.KeyLen2 := KeyLen2;
+ Request^.KeyIncl2 := aKeyIncl2;
+ Move(aKeyData1^, Request^.KeyData1, KeyLen1);
+ ReqKeyData2 := PffByteArray(PAnsiChar(@Request^.KeyData1) + KeyLen1);
+ Move(akeyData2^, ReqKeyData2^, KeyLen2);
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmCursorSetRange,
+ Timeout,
+ Request,
+ ReqLen,
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+ finally
+ FFFreeMem(Request, ReqLen);
+ end;
+end;
+{----------}
+function TFFProxyCursor.SetTimeout(aTimeout : Longint) : TffResult;
+var
+ Request : TffnmCursorSetTimeoutReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ Result := DBIERR_NONE;
+ if prTimeout = aTimeout then Exit;
+
+ prTimeout := aTimeout;
+
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+ Request.Timeout := prTimeout;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmCursorSetTimeout,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyCursor.SetToBegin : TffResult;
+var
+ Request : TffnmCursorSetToBeginReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmCursorSetToBegin,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyCursor.SetToBookmark(aBookmark : PffByteArray) : TffResult;
+var
+ Request : PffnmCursorSetToBookmarkReq;
+ ReqLen : Longint;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ ReqLen := SizeOf(Request^) - 2 + BookMarkSize;
+ FFGetZeroMem(Request, ReqLen);
+ try
+ { Initialize Request }
+ Request^.CursorID := SrCursorID;
+ Request^.BookmarkSize := BookMarkSize;
+ Move(aBookmark^, Request^.Bookmark, BookMarkSize);
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmCursorSetToBookmark,
+ Timeout,
+ Request,
+ ReqLen,
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+ finally
+ FFFreeMem(Request, ReqLen);
+ end;
+end;
+{----------}
+function TFFProxyCursor.SetToCursor(aSourceCursor : TFFProxyCursor
+ ) : TffResult;
+var
+ Request : TffnmCursorSetToCursorReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.DestCursorID := SrCursorID;
+ Request.SrcCursorID := aSourceCursor.SrCursorID;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmCursorSetToCursor,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyCursor.SetToEnd : TffResult;
+var
+ Request : TffnmCursorSetToEndReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmCursorSetToEnd,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyCursor.SetToKey(aSearchAction : TffSearchKeyAction;
+ aDirectKey : Boolean;
+ aFieldCount : Longint;
+ aPartialLen : Longint;
+ aKeyData : PffByteArray) : TffResult;
+var
+ Request : PffnmCursorSetToKeyReq;
+ ReqLen : Longint;
+ KeyDataLen : Longint;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ if aDirectKey then
+ KeyDataLen := Dictionary.IndexKeyLength[IndexID]
+ else
+ KeyDataLen := PhysicalRecordSize;
+ ReqLen := SizeOf(TffnmCursorSetToKeyReq) - 2 + KeyDataLen;
+ FFGetZeroMem(Request, ReqLen);
+ try
+ { Initialize Request }
+ Request^.CursorID := SrCursorID;
+ Request^.Action := aSearchAction;
+ Request^.DirectKey := aDirectKey;
+ Request^.FieldCount := aFieldCount;
+ Request^.PartialLen := aPartialLen;
+ Request^.KeyDataLen := KeyDataLen;
+ Move(aKeyData^, Request^.KeyData, KeyDataLen);
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmCursorSetToKey,
+ Timeout,
+ Pointer(Request),
+ ReqLen,
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+ finally
+ FFFreeMem(Request, ReqLen);
+ end;
+end;
+{----------}
+function TFFProxyCursor.SwitchToIndex(aIndexName : TffDictItemName;
+ aIndexID : Longint;
+ aPosnOnRec : Boolean) : TffResult;
+var
+ Request : TffnmCursorSwitchToIndexReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+ Request.IndexName := aIndexName;
+ Request.IndexNumber := aIndexID;
+ Request.PosnOnRec := aPosnOnRec;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmCursorSwitchToIndex,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+
+ if (Request.IndexName <> '') then begin
+ prIndexID := Dictionary.GetIndexFromName(Request.IndexName);
+ prIndexName := aIndexName;
+ end else begin
+ prIndexID := aIndexID;
+ prIndexName := Dictionary.IndexName[aIndexID];
+ end;
+end;
+{----------}
+function TFFProxyCursor.TableGetRecCount(var aRecCount : Longint) : TffResult;
+var
+ Request : TffnmGetTableRecCountReq;
+ Reply : PffnmGetTableRecCountRpy;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmGetTableRecCount,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+ if ResultOK(Result) then
+ aRecCount := Reply^.RecCount;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{Begin !!.07}
+{----------}
+function TFFProxyCursor.TableGetRecCountAsync(var aTaskID : Longint) : TffResult;
+var
+ Request : TffnmGetTableRecCountAsyncReq;
+ Reply : PffnmGetTableRecCountAsyncRpy;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmGetTableRecCountAsync,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+ if ResultOK(Result) then
+ aTaskID := Reply^.RebuildID;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{End !!.07}
+{----------}
+function TFFProxyCursor.TableIsLocked(aLockType : TffLockType;
+ var aIsLocked : Boolean) : TffResult;
+var
+ Request : TffnmIsTableLockedReq;
+ Reply : PffnmIsTableLockedRpy;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+ Request.LockType := aLockType;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmIsTableLocked,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+ if ResultOK(Result) then
+ aIsLocked := Reply^.IsLocked;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyCursor.TableLockAcquire(aLockType : TffLockType) : TffResult;
+var
+ Request : TffnmAcqTableLockReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialzie Request }
+ Request.CursorID := SrCursorID;
+ Request.LockType := aLockType;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmAcqTableLock,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyCursor.TableLockRelease(aAllLocks : Boolean) : TffResult;
+var
+ Request : TffnmRelTableLockReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+ Request.AllLocks := aAllLocks;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmRelTableLock,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{----------}
+function TFFProxyCursor.TableSetAutoInc(aValue : TffWord32) : TffResult;
+var
+ Request : TffnmSetTableAutoIncValueReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+ { Initialize Request }
+ Request.CursorID := SrCursorID;
+ Request.AutoIncValue := aValue;
+
+ Reply := nil;
+ Result := Client.ProcessRequest(ffnmSetTableAutoIncValue,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+end;
+{------------------------------------------------------------------------------}
+
+{-TffProxySQLStmt--------------------------------------------------------------}
+constructor TffProxySQLStmt.Create(aDatabase : TffProxyDatabase;
+ const aTimeout : longInt);
+var
+ Request : TffnmSQLAllocReq;
+ Reply : PffnmSQLAllocRpy;
+ ReplyLen : Longint;
+ Result : TffResult;
+begin
+ inherited Create;
+
+ psClient := aDatabase.Client;
+ psDatabase := aDatabase;
+ psTimeout := aTimeout;
+
+ { Initialize Request }
+ Request.DatabaseID := aDatabase.SrDatabaseID;
+ Request.Timeout := aTimeout;
+
+ Reply := nil;
+ Result := psClient.ProcessRequest(ffnmSQLAlloc,
+ psTimeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+
+ Check(Result);
+
+ psSrStmtID := Reply^.StmtID;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+
+end;
+{----------}
+destructor TffProxySQLStmt.Destroy;
+var
+ Request : TffnmSQLFreeReq;
+ Reply : Pointer;
+ ReplyLen : Longint;
+begin
+
+ if psSrStmtID > 0 then begin
+ { Initialize Request }
+ Request.StmtID := psSrStmtID;
+
+ Reply := nil;
+ psClient.ProcessRequest(ffnmSQLFree,
+ psTimeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Reply,
+ ReplyLen,
+ nmdByteArray);
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+ end;
+
+ psSrStmtID := 0;
+ psDatabase := nil;
+
+ inherited Destroy;
+end;
+{----------}
+function TffProxySQLStmt.Exec(aOpenMode : TffOpenMode;
+ var aCursorID : TffCursorID;
+ aStream : TStream) : TffResult;
+var
+ Request : TffnmSQLExecReq;
+ ReplyLen : Longint;
+ SvrCursorID : TffCursorID;
+begin
+ Assert(Assigned(aStream));
+ { Initialize Request }
+ Request.StmtID := psSrStmtID;
+ Request.OpenMode := aOpenMode;
+
+ Result := psClient.ProcessRequest(ffnmSQLExec,
+ psTimeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(aStream),
+ ReplyLen,
+ nmdStream);
+
+ { Was the execution successful? }
+ if Result = DBIERR_NONE then begin
+ { Yes. Get the cursorID from the stream & open a proxy cursor. }
+ aStream.Position := 0;
+ aStream.Read(SvrCursorID, sizeOf(SvrCursorID));
+ aCursorID := SvrCursorID;
+ if aCursorID <> 0 then
+ Result := psDatabase.QueryOpen(SvrCursorID, aOpenMode, smShared, psTimeout,
+ aStream, aCursorID);
+ end;
+
+ { Assumption: If an error occurs then the TffQuery component is responsible
+ for displaying the error message returned from the server. }
+
+end;
+{----------}
+function TffProxySQLStmt.Prepare(aQueryText: PChar;
+ aStream : TStream) : TffResult;
+var
+ QueryLen : Longint;
+ ReqLen : Longint;
+ Request : PffnmSQLPrepareReq;
+ ReplyLen : Longint;
+begin
+ Assert(Assigned(aStream));
+
+ QueryLen := StrLen(aQueryText);
+ ReqLen := SizeOf(TffnmSQLPrepareReq) - SizeOf(TffVarMsgField) + QueryLen + 1;
+ FFGetZeroMem(Request, ReqLen);
+ try
+ { Prepare the request. }
+ Request.StmtID := psSrStmtID;
+ Move(aQueryText^, Request^.Query, QueryLen);
+
+ Result := psClient.ProcessRequest(ffnmSQLPrepare,
+ psTimeout,
+ Request,
+ ReqLen,
+ nmdByteArray,
+ Pointer(aStream),
+ ReplyLen,
+ nmdStream);
+
+ { Assumption: Upper levels are responsible for Stream contents. }
+
+ finally
+ FFFreeMem(Request, ReqLen);
+ end;
+
+end;
+{----------}
+function TffProxySQLStmt.SetParams(aNumParams : word;
+ aParamDescs : pointer;
+ aDataBuffer : PffByteArray;
+ aDataLen : Longint;
+ aStream : TStream) : TffResult;
+var
+ ReplyLen : Longint;
+ Stream : TMemoryStream;
+begin
+ Assert(Assigned(aStream));
+{ Output stream is expected to be:
+ StmtID (longint)
+ NumParams (word)
+ ParamList (array of TffSqlParamInfo)
+ BufLen (longint; size of DataBuffer)
+ DataBuffer (data buffer)
+}
+ Stream := TMemoryStream.Create;
+ try
+ Stream.Write(psSrStmtID, SizeOf(psSrStmtID));
+ Stream.Write(aNumParams, SizeOf(aNumParams));
+ Stream.Write(aParamDescs^, aNumParams * SizeOf(TffSqlParamInfo));
+ Stream.Write(aDataLen, sizeOf(aDataLen));
+ Stream.Write(aDataBuffer^, aDataLen);
+ Stream.Position := 0;
+
+ Result := psClient.ProcessRequest(ffnmSQLSetParams,
+ psTimeout,
+ Stream.Memory,
+ Stream.Size,
+ nmdStream,
+ Pointer(aStream),
+ ReplyLen,
+ nmdStream);
+ finally
+ Stream.Free;
+ end;
+
+end;
+{------------------------------------------------------------------------------}
+
+{-TFFRemoteServerEngine--------------------------------------------------------}
+function TFFRemoteServerEngine.BLOBCreate(aCursorID : TffCursorID;
+ var aBlobNr : TffInt64) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.BlobCreate(aBlobNr);
+end;
+{----------}
+function TFFRemoteServerEngine.BLOBDelete(aCursorID : TffCursorID;
+ aBlobNr : TffInt64) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.BLOBDelete(aBlobNr);
+end;
+{----------}
+function TFFRemoteServerEngine.BLOBFree(aCursorID : TffCursorID;
+ aBlobNr : TffInt64;
+ readOnly : Boolean) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.BLOBFree(aBlobNr,
+ ReadOnly);
+end;
+{----------}
+function TFFRemoteServerEngine.BLOBGetLength(aCursorID : TffCursorID;
+ aBlobNr : TffInt64;
+ var aLength : Longint) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.BLOBGetLength(aBlobNr,
+ aLength);
+end;
+{Begin !!.03}
+{----------}
+function TffRemoteServerEngine.BLOBListSegments(aCursorID : TffCursorID;
+ aBLOBNr : TffInt64;
+ aStream : TStream) : TffResult;
+var
+ Cursor : TffProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.BLOBListSegments(aBLOBNr, aStream);
+end;
+{End !!.03}
+{----------}
+function TFFRemoteServerEngine.BLOBRead(aCursorID : TffCursorID;
+ aBlobNr : TffInt64;
+ aOffset : TffWord32; {!!.06}
+ aLen : TffWord32; {!!.06}
+ var aBLOB;
+ var aBytesRead : TffWord32) {!!.06}
+ : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.BLOBRead(aBlobNr,
+ aOffset,
+ aLen,
+ aBLOB,
+ aBytesRead);
+end;
+{----------}
+function TFFRemoteServerEngine.BLOBTruncate(aCursorID : TffCursorID;
+ aBlobNr : TffInt64;
+ aBLOBLength : Longint) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.BLOBTruncate(aBlobNr,
+ aBLOBLength);
+end;
+{----------}
+function TFFRemoteServerEngine.BLOBWrite(aCursorID : TffCursorID;
+ aBlobNr : TffInt64;
+ aOffset : Longint;
+ aLen : Longint;
+ var aBLOB) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.BLOBWrite(aBlobNr,
+ aOffset,
+ aLen,
+ aBLOB);
+end;
+{Begin !!.01}
+{----------}
+function TffRemoteServerEngine.RemoteRestart(const aClientID : TffClientID) : TffResult;
+var
+ Client : TFFProxyClient;
+begin
+ Result := CheckClientIDAndGet(aClientID, Client);
+ if ResultOK(Result) then
+ Result := Client.RemoteRestart;
+end;
+{----------}
+function TffRemoteServerEngine.RemoteStart(const aClientID : TffClientID) : TffResult;
+var
+ Client : TFFProxyClient;
+begin
+ Result := CheckClientIDAndGet(aClientID, Client);
+ if ResultOK(Result) then
+ Result := Client.RemoteStart;
+end;
+{----------}
+function TffRemoteServerEngine.RemoteStop(const aClientID : TffClientID) : TffResult;
+var
+ Client : TFFProxyClient;
+begin
+ Result := CheckClientIDAndGet(aClientID, Client);
+ if ResultOK(Result) then
+ Result := Client.RemoteStop;
+end;
+{End !!.01}
+{----------}
+procedure TFFRemoteServerEngine.scInitialize;
+begin
+ { do nothing }
+end;
+{----------}
+procedure TffRemoteServerEngine.scPrepareForShutdown;
+begin
+ { do nothing }
+end;
+{----------}
+procedure TffRemoteServerEngine.scShutdown;
+begin
+ { do nothing }
+end;
+{----------}
+procedure TffRemoteServerEngine.scStartup;
+begin
+ { do nothing }
+end;
+{----------}
+function TffRemoteServerEngine.bseGetAutoSaveCfg : Boolean;
+begin
+ {This is here to kill warnings. Clients shouldn't care about the
+ RSE's NoAutoSaveCfg setting.}
+ Result := False;
+end;
+{----------}
+function TFFRemoteServerEngine.bseGetReadOnly : Boolean;
+var
+ Client : TffProxyClient;
+begin
+ Client := GetDefaultClient;
+ if Assigned(Client) then
+ Result := Client.IsReadOnly
+ else
+ Result := False;
+end;
+{--------}
+procedure TFFRemoteServerEngine.bseSetAutoSaveCfg(aValue : Boolean); {!!.01 - Start}
+begin
+ {do nothing}
+end;
+{--------}
+procedure TFFRemoteServerEngine.bseSetReadOnly(aValue : Boolean);
+begin
+ {do nothing}
+end;
+{--------} {!!.01 - End}
+procedure TFFRemoteServerEngine.FFNotificationEx(const AOp : Byte;
+ AFrom : TffComponent;
+ const AData : TffWord32);
+var
+ CL : TFFProxyClient;
+ ClIdx : Longint;
+ ClFound : Boolean;
+begin
+ inherited; {!!.11}
+ if (AFrom = Transport) then
+ if ((AOp = ffn_Destroy) or (AOp = ffn_Remove)) then begin
+ FFNotifyDependents(ffn_Deactivate);
+ rsTransport := nil;
+ end else if (AOp = ffn_Deactivate) then
+ FFNotifyDependents(ffn_Deactivate)
+ else if (AOp = ffn_ConnectionLost) then begin
+ { If we manage this client, then notify depenents that connection is
+ lost. It is up to the baseclient dependents to check the data
+ parameter to see if this notification affects them.}
+ CL := nil;
+ ClFound := False;
+ with ClientList.BeginRead do
+ try
+ for ClIdx := 0 to Pred(ClientList.Count) do begin
+ CL := TFFProxyClient(ClientList[ClIdx].Key^);
+ if CL.pcSrClientID = AData then begin
+ ClFound := True;
+ Break;
+ end;
+ end;
+ finally
+ EndRead;
+ end;
+ if CLFound then begin
+ ForceClosing(Longint(CL));
+ ClientRemove(Longint(CL));
+ FFNotifyDependentsEx(ffn_ConnectionLost, Longint(CL))
+ end;
+ end;
+end;
+{Begin !!.07}
+{--------}
+procedure TffRemoteServerEngine.Log(const aMsg : string);
+begin
+ FEventLog.WriteString(aMsg);
+end;
+{--------}
+procedure TffRemoteServerEngine.LogAll(const Msgs : array of string);
+begin
+ FEventLog.WriteStrings(Msgs);
+end;
+{--------}
+procedure TffRemoteServerEngine.LogFmt(const aMsg : string; args : array of const);
+begin
+ FEventLog.WriteString(format(aMsg, args));
+end;
+{End !!.07}
+{--------}
+function TFFRemoteServerEngine.CheckClientIDAndGet(aClientID : TffClientID;
+ var aClient : TffProxyClient
+ ) : TffResult;
+begin
+ Result := DBIERR_INVALIDHNDL;
+
+ aClient := nil;
+ try
+ if (TObject(aClientID) is TFFProxyClient) then begin
+ aClient := TffProxyClient(aClientID);
+ Result := DBIERR_NONE;
+ end;
+ except
+ { An exception may be raised if the ID is bogus. Swallow the exception.}
+ end;
+end;
+{----------}
+function TFFRemoteServerEngine.CheckCursorIDAndGet(aCursorID : TffCursorID;
+ var aCursor : TffProxyCursor
+ ) : TffResult;
+begin
+ Result := DBIERR_INVALIDHNDL;
+
+ aCursor := nil;
+ try
+ if (TObject(aCursorID) is TFFProxyCursor) then begin
+ aCursor := TffProxyCursor(aCursorID);
+ Result := DBIERR_NONE;
+ end;
+ except
+ { An exception may be raised if the ID is bogus. Swallow the exception.}
+ end;
+end;
+{----------}
+function TffRemoteServerEngine.CheckStmtIDAndGet(aStmtID : TffSqlStmtID;
+ var aStmt : TffProxySQLStmt) : TffResult;
+begin
+ Result := DBIERR_INVALIDHNDL;
+
+ aStmt := nil;
+ try
+ if (TObject(aStmtID) is TffProxySQLStmt) then begin
+ aStmt := TffProxySQLStmt(aStmtID);
+ Result := DBIERR_NONE;
+ end;
+ except
+ { An exception may be raised if the ID is bogus. Swallow the exception.}
+ end;
+end;
+{----------}
+function TFFRemoteServerEngine.CheckDatabaseIDAndGet(
+ aDatabaseID : TffDatabaseID;
+ var aDatabase : TffProxyDatabase
+ ) : TffResult;
+begin
+ Result := DBIERR_INVALIDHNDL;
+
+ aDatabase := nil;
+ try
+ if (TObject(aDatabaseID) is TFFProxyDatabase) then begin
+ aDatabase := TffProxyDatabase(aDatabaseID);
+ Result := DBIERR_NONE;
+ end;
+ except
+ { An exception may be raised if the ID is bogus. Swallow the exception.}
+ end;
+end;
+{----------}
+function TFFRemoteServerEngine.CheckSessionIDAndGet(aClientID : TffClientID;
+ aSessionID : TffSessionID;
+ var aClient : TffProxyClient;
+ var aSession : TffProxySession
+ ) : TffResult;
+begin
+ aSession := nil;
+ aClient := nil;
+
+ Result := CheckClientIDAndGet(aClientID, aClient);
+ if (Result = DBIERR_NONE) then begin
+ try
+ if (TObject(aSessionID) is TFFProxySession) then begin
+ aSession := TffProxySession(aSessionID)
+ end;
+ except
+ { An exception may be raised if the ID is bogus. Swallow the exception.}
+ end;
+ end;
+end;
+{----------}
+function TFFRemoteServerEngine.ClientAdd(var aClientID : TffClientID;
+ const aClientName : TffNetName;
+ const aUserID : TffName;
+ const aTimeout : Longint;
+ var aHash : TffWord32
+ ) : TffResult;
+var
+ Client : TFFProxyClient;
+ ListItem : TffIntListItem;
+
+begin
+ Result := DBIERR_NONE;
+ Client := nil;
+
+ {Create client object}
+ try
+ Client := TFFProxyClient.Create(rsTransport, aUserID, aHash, aTimeOut);
+ except
+ on E:Exception do
+ if (E is EffException) or
+ (E is EffDatabaseError) or
+ (E is EffServerComponentError) then
+ Result := EffException(E).ErrorCode;
+ end;
+
+ if ResultOK(Result) and Assigned(Client) then begin
+ {Add to the internal list}
+ ListItem := TffIntListItem.Create(Longint(Client));
+ with rsClientList.BeginWrite do
+ try
+ Insert(ListItem);
+ finally
+ EndWrite;
+ end;
+
+ {Set the return value}
+ aClientID := Longint(Client);
+ end;
+end;
+{Begin !!.11}
+function TffRemoteServerEngine.ClientAddEx(var aClientID : TffClientID;
+ const aClientName : TffNetName;
+ const aUserID : TffName;
+ const aTimeout : Longint;
+ const aClientVersion : Longint;
+ var aHash : TffWord32) : TffResult;
+begin
+ Result := ClientAdd(aClientID, aClientName, aUserID, aTimeout, aHash);
+end;
+{End !!.11}
+{----------}
+function TFFRemoteServerEngine.ClientRemove(aClientID : TffClientID
+ ) : TffResult;
+var
+ Client : TFFProxyClient;
+begin
+ Result := CheckClientIDAndGet(aClientID, Client);
+ if ResultOK(Result) then
+ {Remove from the internal list, and free}
+ with rsClientList.BeginWrite do
+ try
+ Delete(Client); {!!.01}
+ Client.Free;
+ finally
+ EndWrite;
+ end;
+end;
+{----------}
+function TFFRemoteServerEngine.ClientSetTimeout(const aClientID : TffClientID;
+ const aTimeout : Longint
+ ) : TffResult;
+var
+ Client : TFFProxyClient;
+begin
+ Result := CheckClientIDAndGet(aClientID, Client);
+ if ResultOK(Result) then
+ Result := Client.SetTimeout(aTimeout);
+end;
+{----------}
+constructor TFFRemoteServerEngine.Create(aOwner : TComponent);
+begin
+ inherited Create(aOwner);
+
+ rsClientList := TFFProxyClientList.Create;
+ rsTimeout := 0;
+ rsTransport := nil;
+
+ with RemoteServerEngines.BeginWrite do
+ try
+ Insert(TffIntListItem.Create(Longint(Self)));
+ finally
+ EndWrite;
+ end;
+end;
+{----------}
+function TFFRemoteServerEngine.CursorClone(aCursorID : TffCursorID;
+ aOpenMode : TffOpenMode;
+ var aNewCursorID : TffCursorID
+ ) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.CursorClone(aOpenMode,
+ aNewCursorID);
+end;
+{----------}
+function TFFRemoteServerEngine.CursorClose(aCursorID : TffCursorID) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+ Database : TFFProxyDatabase;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then begin
+ Database := Cursor.Database;
+ Result := Database.TableClose(Cursor);
+ end;
+end;
+{----------}
+function TFFRemoteServerEngine.CursorCompareBookmarks(
+ aCursorID : TffCursorID;
+ aBookmark1 : PffByteArray;
+ aBookmark2 : PffByteArray;
+ var aCompResult : Longint
+ ) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.CompareBookmarks(aBookmark1,
+ aBookmark2,
+ aCompResult);
+end;
+{Begin !!.02}
+{----------}
+function TffRemoteServerEngine.CursorCopyRecords(aSrcCursorID,
+ aDestCursorID : TffCursorID;
+ aCopyBLOBs : Boolean) : TffResult;
+var
+ DestCursor, SrcCursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aDestCursorID, DestCursor);
+ if ResultOK(Result) then begin
+ Result := CheckCursorIDAndGet(aSrcCursorID, SrcCursor);
+ if ResultOK(Result) then
+ Result := DestCursor.CopyRecords(SrcCursor, aCopyBLOBs);
+ end;
+end;
+{End !!.02}
+{Begin !!.06}
+{----------}
+function TffRemoteServerEngine.CursorDeleteRecords(aCursorID : TffCursorID) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.DeleteRecords;
+end;
+{End !!.06}
+{----------}
+function TFFRemoteServerEngine.CursorGetBookmark(aCursorID : TffCursorID;
+ aBookmark : PffByteArray
+ ) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.GetBookmark(aBookmark);
+end;
+{Begin !!.03}
+{----------}
+function TffRemoteServerEngine.CursorListBLOBFreeSpace(aCursorID : TffCursorID;
+ const aInMemory : Boolean;
+ aStream : TStream) : TffResult;
+var
+ Cursor : TffProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.ListBLOBFreeSpace(aInMemory, aStream);
+end;
+{End !!.03}
+{----------}
+function TffRemoteServerEngine.CursorOverrideFilter(aCursorID : longint;
+ aExpression : pCANExpr;
+ aTimeout : TffWord32) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.OverrideFilter(aExpression, aTimeout);
+end;
+{----------}
+function TffRemoteServerEngine.CursorRestoreFilter(aCursorID : longInt) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.RestoreFilter;
+end;
+{----------}
+function TFFRemoteServerEngine.CursorGetBookmarkSize(aCursorID : TffCursorID;
+ var aSize : Longint
+ ) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.GetBookmarkSize(aSize);
+end;
+{----------}
+function TFFRemoteServerEngine.CursorResetRange(aCursorID : TffCursorID
+ ) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.ResetRange;
+end;
+{----------}
+function TFFRemoteServerEngine.CursorSetFilter(aCursorID : TffCursorID;
+ aExpression : pCANExpr;
+ aTimeout : TffWord32
+ ) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.SetFilter(aExpression,
+ aTimeout);
+end;
+{----------}
+function TFFRemoteServerEngine.CursorSetRange(aCursorID : TffCursorID;
+ aDirectKey : Boolean;
+ aFieldCount1 : Longint;
+ aPartialLen1 : Longint;
+ aKeyData1 : PffByteArray;
+ aKeyIncl1 : Boolean;
+ aFieldCount2 : Longint;
+ aPartialLen2 : Longint;
+ aKeyData2 : PffByteArray;
+ aKeyIncl2 : Boolean
+ ) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.SetRange(aDirectKey,
+ aFieldCount1,
+ aPartialLen1,
+ aKeyData1,
+ aKeyIncl1,
+ aFieldCount2,
+ aPartialLen2,
+ aKeyData2,
+ aKeyIncl2);
+end;
+{----------}
+function TFFRemoteServerEngine.CursorSetTimeout(const aCursorID : TffCursorID;
+ const aTimeout : Longint
+ ) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.SetTimeout(aTimeout);
+end;
+{----------}
+function TFFRemoteServerEngine.CursorSetToBegin(aCursorID : TffCursorID
+ ) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.SetToBegin;
+end;
+{----------}
+function TFFRemoteServerEngine.CursorSetToBookmark(aCursorID : TffCursorID;
+ aBookmark : PffByteArray
+ ) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.SetToBookmark(aBookmark);
+end;
+{----------}
+function TFFRemoteServerEngine.CursorSetToCursor(aDestCursorID : TffCursorID;
+ aSrcCursorID : TffCursorID
+ ) : TffResult;
+var
+ DestCursor : TFFProxyCursor;
+ SourceCursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aDestCursorID, DestCursor);
+ if ResultOK(Result) then
+ Result := CheckCursorIDAndGet(aSrcCursorID, SourceCursor);
+ if ResultOK(Result) then
+ Result := DestCursor.SetToCursor(SourceCursor);
+end;
+{----------}
+function TFFRemoteServerEngine.CursorSetToEnd(aCursorID : TffCursorID
+ ) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.SetToEnd;
+end;
+{----------}
+function TFFRemoteServerEngine.CursorSetToKey(
+ aCursorID : TffCursorID;
+ aSearchAction : TffSearchKeyAction;
+ aDirectKey : Boolean;
+ aFieldCount : Longint;
+ aPartialLen : Longint;
+ aKeyData : PffByteArray
+ ) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.SetToKey(aSearchAction,
+ aDirectKey,
+ aFieldCount,
+ aPartialLen,
+ aKeyData);
+end;
+{----------}
+function TFFRemoteServerEngine.CursorSwitchToIndex(aCursorID : TffCursorID;
+ aIndexName : TffDictItemName;
+ aIndexID : Longint;
+ aPosnOnRec : Boolean
+ ) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.SwitchToIndex(aIndexName,
+ aIndexID,
+ aPosnOnRec);
+end;
+{----------}
+function TFFRemoteServerEngine.DatabaseAddAlias(const aAlias : TffName;
+ const aPath : TffPath;
+ aCheckSpace : Boolean; {!!.11}
+ const aClientID : TffClientID)
+ : TffResult;
+var
+ Client : TffProxyClient;
+begin
+ Result := CheckClientIDAndGet(aClientID, Client);
+ if ResultOK(Result) then
+ Result := Client.DatabaseAddAlias(aAlias, aPath, aCheckSpace); {!!.11}
+end;
+{----------}
+function TFFRemoteServerEngine.DatabaseAliasList(aList : TList;
+ aClientID : TffClientID)
+ : TffResult;
+var
+ Client : TffProxyClient;
+begin
+ Result := CheckClientIDAndGet(aClientID, Client);
+ if ResultOK(Result) then
+ Result := Client.DatabaseAliasList(aList);
+end;
+{----------}
+function TFFRemoteServerEngine.RecoveryAliasList(aList : TList;
+ aClientID : TffClientID)
+ : TffResult;
+begin
+ Assert(False, 'RecoveryAliasList unsupported for TffRemoteServerEngine.');
+ Result := DBIERR_NOTSUPPORTED;
+end;
+{----------}
+function TFFRemoteServerEngine.DatabaseChgAliasPath(aAlias : TffName;
+ aNewPath : TffPath;
+ aCheckSpace : Boolean; {!!.11}
+ aClientID : TffClientID)
+ : TffResult;
+var
+ Client : TffProxyClient;
+begin
+ Result := CheckClientIDAndGet(aClientID, Client);
+ if ResultOK(Result) then
+ Result := Client.DatabaseChgAliasPath(aAlias,
+ aNewPath,
+ aCheckSpace) {!!.11}
+end;
+{----------}
+function TFFRemoteServerEngine.DatabaseClose(aDatabaseID : TffDatabaseID
+ ) : TffResult;
+var
+ Database : TFFProxyDatabase;
+ Client : TFFProxyClient;
+begin
+ Result := CheckDatabaseIDAndGet(aDatabaseID, Database);
+ if ResultOK(Result) then begin
+ Client := Database.Client;
+ Result := Client.DatabaseClose(Database);
+ end;
+end;
+{----------}
+function TFFRemoteServerEngine.DatabaseDeleteAlias(aAlias : TffName;
+ aClientID : TffClientID
+ ) : TffResult;
+var
+ Client : TFFProxyClient;
+begin
+ Result := CheckClientIDAndGet(aClientID, Client);
+ if ResultOK(Result) then
+ Result := Client.DatabaseDeleteAlias(aAlias)
+end;
+{----------}
+function TFFRemoteServerEngine.DatabaseGetAliasPath(aAlias : TffName;
+ var aPath : TffPath;
+ aClientID : TffClientID
+ ) : TffResult;
+var
+ Client : TFFProxyClient;
+begin
+ Result := CheckClientIDAndGet(aClientID, Client);
+ if ResultOK(Result) then
+ Result := Client.DatabaseGetAliasPath(aAlias, aPath)
+end;
+{----------}
+function TFFRemoteServerEngine.DatabaseGetFreeSpace(const aDatabaseID : TffDatabaseID;
+ var aFreeSpace : Longint
+ ) : TffResult;
+var
+ Database : TFFProxyDatabase;
+begin
+ Result := CheckDatabaseIDAndGet(aDatabaseID, Database);
+ if ResultOK(Result) then
+ Result := Database.GetDbFreeSpace(aFreeSpace);
+end;
+{----------}
+function TffRemoteServerEngine.DatabaseModifyAlias(const aClientID : TffClientID;
+ const aAlias : TffName;
+ const aNewName : TffName;
+ const aNewPath : TffPath;
+ aCheckSpace : Boolean) {!!.11}
+ : TffResult;
+var
+ Client : TFFProxyClient;
+begin
+ Result := CheckClientIDAndGet(aClientID, Client);
+ if ResultOK(Result) then
+ Result := Client.DatabaseModifyAlias(aAlias,
+ aNewName,
+ aNewPath,
+ aCheckSpace) {!!.11}
+end;
+{----------}
+function TFFRemoteServerEngine.DatabaseOpen(aClientID : TffClientID;
+ const aAlias : TffName;
+ const aOpenMode : TffOpenMode;
+ const aShareMode : TffShareMode;
+ const aTimeout : Longint;
+ var aDatabaseID : TffDatabaseID
+ ) : TffResult;
+var
+ Client : TFFProxyClient;
+begin
+ Result := CheckClientIDAndGet(aClientID, Client);
+ if ResultOK(Result) then
+ Result := Client.DatabaseOpen(aAlias,
+ aOpenMode,
+ aShareMode,
+ aTimeout,
+ aDatabaseID);
+end;
+{----------}
+function TFFRemoteServerEngine.DatabaseOpenNoAlias(aClientID : TffClientID;
+ const aPath : TffPath;
+ const aOpenMode : TffOpenMode;
+ const aShareMode : TffShareMode;
+ const aTimeout : Longint;
+ var aDatabaseID : TffDatabaseID
+ ) : TffResult;
+var
+ Client : TFFProxyClient;
+begin
+ Result := CheckClientIDAndGet(aClientID, Client);
+ if ResultOK(Result) then
+ Result := Client.DatabaseOpenNoAlias(aPath,
+ aOpenMode,
+ aShareMode,
+ aTimeout,
+ aDatabaseID);
+end;
+{----------}
+function TFFRemoteServerEngine.DatabaseSetTimeout(
+ const aDatabaseID : TffDatabaseID;
+ const aTimeout : Longint
+ ) : TffResult;
+var
+ Database : TFFProxyDatabase;
+begin
+ Result := CheckDatabaseIDAndGet(aDatabaseID, Database);
+ if ResultOK(Result) then
+ Result := Database.SetTimeout(aTimeout);
+end;
+{----------}
+function TffRemoteServerEngine.DatabaseTableExists(aDatabaseID : TffDatabaseID;
+ const aTableName : TffTableName;
+ var aExists : Boolean
+ ) : TffResult;
+var
+ Database : TFFProxyDatabase;
+begin
+ Result := CheckDatabaseIDAndGet(aDatabaseID, Database);
+ if ResultOK(Result) then
+ Result := Database.TableExists(aTableName, aExists);
+end;
+{----------}
+function TFFRemoteServerEngine.DatabaseTableList(aDatabaseID : TffDatabaseID;
+ const aMask : TffFileNameExt;
+ aList : TList
+ ) : TffResult;
+var
+ Database : TFFProxyDatabase;
+begin
+ Result := CheckDatabaseIDAndGet(aDatabaseID, Database);
+ if ResultOK(Result) then
+ Result := Database.TableList(aMask,
+ aList);
+end;
+{----------}
+function TffRemoteServerEngine.DatabaseTableLockedExclusive(
+ aDatabaseID : TffDatabaseID;
+ const aTableName : TffTableName;
+ var aLocked : Boolean
+ ) : TffResult;
+var
+ Database : TFFProxyDatabase;
+begin
+ Result := CheckDatabaseIDAndGet(aDatabaseID, Database);
+ if ResultOK(Result) then
+ Result := Database.TableLockedExclusive(aTableName,
+ aLocked);
+
+end;
+{----------}
+destructor TFFRemoteServerEngine.Destroy;
+//var {!!.03}
+// Idx : Longint; {!!.03}
+begin
+ FFNotifyDependents(ffn_Destroy);
+
+ { Make sure we are shutdown. }
+ State := ffesInactive;
+
+{Begin !!.03}
+// {Free dependent objects}
+// with rsClientList.BeginWrite do
+// try
+// for Idx := 0 to Pred(Count) do
+// TFFProxyClient(Items[Idx]).Free;
+// finally
+// EndWrite;
+// end;
+{End !!.03}
+
+ with RemoteServerEngines.BeginWrite do
+ try
+ Delete(Longint(Self)); {!!.01}
+ finally
+ EndWrite;
+ end;
+
+ {Free and nil internal lists}
+ rsClientList.Free;
+ rsClientList := nil;
+
+ {Clear the transport}
+ Transport := nil;
+
+ inherited Destroy;
+end;
+{----------}
+function TFFRemoteServerEngine.FileBLOBAdd(aCursorID : TffCursorID;
+ const aFileName : TffFullFileName;
+ var aBlobNr : TffInt64) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.FileBLOBAdd(aFileName,
+ aBlobNr);
+end;
+{----------}
+function TFFRemoteServerEngine.GetDefaultClient: TFFProxyClient;
+begin
+ Result := nil;
+ with rsClientList.BeginRead do
+ try
+ if Count > 0 then
+ Result := TFFProxyClient(TffIntListItem(Items[0]).KeyAsInt); {!!.01}
+ finally
+ EndRead;
+ end;
+end;
+{----------}
+function TFFRemoteServerEngine.GetServerDateTime(var aDateTime : TDateTime
+ ) : TffResult;
+begin
+ if (GetDefaultClient <> nil) then
+ Result := GetDefaultClient.GetServerDateTime(aDateTime)
+ else
+ Result := DBIERR_INVALIDHNDL;
+end;
+{----------}
+function TFFRemoteServerEngine.GetServerSystemTime(var aSystemTime : TSystemTime) : TffResult;
+begin
+ if (GetDefaultClient <> nil) then
+ Result := GetDefaultClient.GetServerSystemTime(aSystemTime)
+ else
+ Result := DBIERR_INVALIDHNDL;
+end;
+{----------}
+function TFFRemoteServerEngine.GetServerGUID(var aGUID : TGUID) : TffResult;
+begin
+ if (GetDefaultClient <> nil) then
+ Result := GetDefaultClient.GetServerGUID(aGUID)
+ else
+ Result := DBIERR_INVALIDHNDL;
+end;
+{----------}
+function TFFRemoteServerEngine.GetServerID(var aUniqueID : TGUID) : TffResult;
+begin
+ if (GetDefaultClient <> nil) then
+ Result := GetDefaultClient.GetServerID(aUniqueID)
+ else
+ Result := DBIERR_INVALIDHNDL;
+end;
+{----------}
+function TFFRemoteServerEngine.GetServerStatistics(var Stats : TffServerStatistics) : TffResult;
+begin;
+ if (GetDefaultClient <> nil) then
+ Result := GetDefaultClient.GetServerStatistics(Stats)
+ else
+ Result := DBIERR_INVALIDHNDL;
+end;
+{----------}
+function TFFRemoteServerEngine.GetCommandHandlerStatistics(const CmdHandlerIdx : Integer;
+ var Stats : TffCommandHandlerStatistics) : TffResult;
+begin
+ if (GetDefaultClient <> nil) then
+ Result := GetDefaultClient.GetCommandHandlerStatistics(CmdHandlerIdx,
+ Stats)
+ else
+ Result := DBIERR_INVALIDHNDL;
+end;
+{----------}
+function TFFRemoteServerEngine.GetTransportStatistics(const CmdHandlerIdx : Integer;
+ const TransportIdx : Integer;
+ var Stats : TffTransportStatistics) : TffResult;
+begin
+ if (GetDefaultClient <> nil) then
+ Result := GetDefaultClient.GetTransportStatistics(CmdHandlerIdx,
+ TransportIdx,
+ Stats)
+ else
+ Result := DBIERR_INVALIDHNDL;
+end;
+{----------} {end !!.07}
+procedure TFFRemoteServerEngine.GetServerNames(aList: TStrings;
+ aTimeout : Longint);
+begin
+ Transport.GetServerNames(aList, aTimeout);
+end;
+{----------}
+procedure TFFRemoteServerEngine.ForceClosing(const aClientID : TffClientID);
+var
+ Client : TFFProxyClient;
+begin
+ if CheckClientIDAndGet(aClientID, Client) = DBIERR_NONE then
+ Client.ForceClosed := True;
+end;
+{Begin !!.06}
+{--------}
+function TffRemoteServerEngine.ProcessRequest(aClientID : TffClientID;
+ aMsgID : Longint;
+ aTimeout : Longint;
+ aRequestData : Pointer;
+ aRequestDataLen : Longint;
+ aRequestDataType : TffNetMsgDataType;
+ var aReply : Pointer;
+ var aReplyLen : Longint;
+ aReplyType : TffNetMsgDataType) : TffResult;
+var
+ Client : TFFProxyClient;
+begin
+ Result := CheckClientIDAndGet(aClientID, Client);
+ if ResultOK(Result) then
+ Result := Client.ProcessRequest(aMsgID, aTimeout, aRequestData,
+ aRequestDataLen, aRequestDataType,
+ aReply, aReplyLen, aReplyType);
+end;
+{--------}
+function TffRemoteServerEngine.ProcessRequestNoReply(aClientID : TffClientID;
+ aMsgID : Longint;
+ aTimeout : Longint;
+ aRequestData : Pointer;
+ aRequestDataLen : Longint ) : TffResult;
+var
+ Client : TFFProxyClient;
+begin
+ Result := CheckClientIDAndGet(aClientID, Client);
+ if ResultOK(Result) then
+ Result := Client.ProcessRequestNoReply(aMsgID, aTimeout, aRequestData,
+ aRequestDataLen);
+end;
+{End !!.06}
+{----------}
+function TFFRemoteServerEngine.RebuildGetStatus(aRebuildID : Longint;
+ const aClientID : TffClientID;
+ var aIsPresent : Boolean;
+ var aStatus : TffRebuildStatus
+ ) : TffResult;
+var
+ Client : TFFProxyClient;
+begin
+ Result := CheckClientIDAndGet(aClientID, Client);
+ if ResultOK(Result) then
+ Result := Client.GetRebuildStatus(aRebuildID,
+ aIsPresent,
+ aStatus);
+end;
+{----------}
+function TFFRemoteServerEngine.RecordDelete(aCursorID : TffCursorID;
+ aData : PffByteArray
+ ) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.RecordDelete(aData);
+end;
+{----------}
+function TffRemoteServerEngine.RecordDeleteBatch(aCursorID : TffCursorID;
+ aBMCount : Longint;
+ aBMLen : Longint;
+ aData : PffByteArray;
+ aErrors : PffLongintArray
+ ) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.RecordDeleteBatch(aBMCount,
+ aBMLen,
+ aData,
+ aErrors);
+end;
+{----------}
+function TFFRemoteServerEngine.RecordExtractKey(aCursorID : TffCursorID;
+ aData : PffByteArray;
+ aKey : PffByteArray
+ ) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.RecordExtractKey(aData,
+ aKey);
+end;
+{----------}
+function TFFRemoteServerEngine.RecordGet(aCursorID : TffCursorID;
+ aLockType : TffLockType;
+ aData : PffByteArray) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.RecordGet(aLockType,
+ aData);
+end;
+{----------}
+function TFFRemoteServerEngine.RecordGetBatch(aCursorID : TffCursorID;
+ aRecCount : Longint;
+ aRecLen : Longint;
+ var aRecRead : Longint;
+ aData : PffByteArray;
+ var aError : TffResult
+ ) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.RecordGetBatch(aRecCount,
+ aRecLen,
+ aRecRead,
+ aData,
+ aError);
+end;
+{----------}
+function TFFRemoteServerEngine.RecordGetForKey(aCursorID : TffCursorID;
+ aDirectKey : Boolean;
+ aFieldCount : Longint;
+ aPartialLen : Longint;
+ aKeyData : PffByteArray;
+ aData : PffByteArray;
+ aFirstCall : Boolean
+ ) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.RecordGetForKey(aDirectKey,
+ aFieldCount,
+ aPartialLen,
+ aKeyData,
+ aData,
+ aFirstCall);
+end;
+{----------}
+function TFFRemoteServerEngine.RecordGetNext(aCursorID : TffCursorID;
+ aLockType : TffLockType;
+ aData : PffByteArray
+ ) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.RecordGetNext(aLockType,
+ aData);
+end;
+{----------}
+function TFFRemoteServerEngine.RecordGetPrior(aCursorID : TffCursorID;
+ aLockType : TffLockType;
+ aData : PffByteArray
+ ) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.RecordGetPrior(aLockType,
+ aData);
+end;
+{----------}
+function TFFRemoteServerEngine.RecordInsert(aCursorID : TffCursorID;
+ aLockType : TffLockType;
+ aData : PffByteArray
+ ) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.RecordInsert(aLockType,
+ aData);
+end;
+{----------}
+function TFFRemoteServerEngine.RecordInsertBatch(aCursorID : TffCursorID;
+ aRecCount : Longint;
+ aRecLen : Longint;
+ aData : PffByteArray;
+ aErrors : PffLongintArray
+ ) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.RecordInsertBatch(aRecCount,
+ aRecLen,
+ aData,
+ aErrors);
+end;
+{----------}
+function TffRemoteServerEngine.RecordIsLocked(aCursorID : TffCursorID;
+ aLockType : TffLockType;
+ var aIsLocked : boolean) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.RecordIsLocked(aLockType,
+ aIsLocked);
+end;
+{----------}
+function TFFRemoteServerEngine.RecordModify(aCursorID : TffCursorID;
+ aData : PffByteArray;
+ aRelLock : Boolean) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.RecordModify(aData,
+ aRelLock);
+end;
+{----------}
+function TFFRemoteServerEngine.RecordRelLock(aCursorID : TffCursorID;
+ aAllLocks : Boolean) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.RecordRelLock(aAllLocks);
+end;
+{----------}
+procedure TFFRemoteServerEngine.rsSetTransport(const Value : TFFBaseTransport);
+begin
+ if rsTransport = Value then
+ Exit;
+
+ FFNotifyDependents(ffn_Deactivate);
+ if Assigned(rsTransport) then
+ rsTransport.FFRemoveDependent(Self);
+
+ rsTransport := Value;
+ if Assigned(rsTransport) then
+ rsTransport.FFAddDependent(Self);
+end;
+{----------}
+function TFFRemoteServerEngine.SessionAdd(const aClientID : TffClientID;
+ const aTimeout : Longint;
+ var aSessionID : TffSessionID
+ ) : TffResult;
+var
+ Client : TFFProxyClient;
+begin
+ Result := CheckClientIDAndGet(aClientID, Client);
+ if ResultOK(Result) then
+ Result := Client.SessionAdd(aSessionID, aTimeout);
+end;
+{----------}
+function TFFRemoteServerEngine.SessionCount(aClientID : TffClientID;
+ var aCount : Longint) : TffResult;
+var
+ Client : TFFProxyClient;
+begin
+ Result := CheckClientIDAndGet(aClientID, Client);
+ if ResultOK(Result) then
+ aCount := Client.SessionCount;
+end;
+{----------}
+function TFFRemoteServerEngine.SessionGetCurrent(aClientID : TffClientID;
+ var aSessionID : TffSessionID
+ ) : TffResult;
+var
+ Client : TFFProxyClient;
+ Session : TFFProxySession;
+begin
+ Result := CheckClientIDAndGet(aClientID, Client);
+ if ResultOK(Result) then begin
+ Session := Client.CurrentSession;
+ aSessionID := Longint(Session);
+ end;
+end;
+{Begin !!.06}
+{----------}
+function TFFRemoteServerEngine.SessionCloseInactiveTables(aClientID : TffClientID) : TffResult;
+var
+ Client : TFFProxyClient;
+begin
+ Result := CheckClientIDAndGet(aClientID, Client);
+ if ResultOK(Result) then
+ Client.SessionCloseInactiveTables;
+end;
+{End !!.06}
+{----------}
+function TFFRemoteServerEngine.SessionRemove(aClientID : TffClientID;
+ aSessionID : TffSessionID
+ ) : TffResult;
+var
+ Client : TFFProxyClient;
+ Session : TFFProxySession;
+begin
+ Result := CheckSessionIDAndGet(aClientID, aSessionID, Client, Session);
+ if ResultOK(Result) then
+ Client.SessionRemove(Session);
+end;
+{----------}
+function TFFRemoteServerEngine.SessionSetCurrent(aClientID : TffClientID;
+ aSessionID : TffSessionID
+ ) : TffResult;
+var
+ Client : TFFProxyClient;
+ Session : TFFProxySession;
+begin
+ Result := CheckSessionIDAndGet(aClientID, aSessionID, Client, Session);
+ if ResultOK(Result) then
+ Client.SessionSetCurrent(Session);
+end;
+{----------}
+function TFFRemoteServerEngine.SessionSetTimeout(
+ const aClientID : TffClientID;
+ const aSessionID : TffSessionID;
+ const aTimeout : Longint
+ ) : TffResult;
+var
+ Client : TFFProxyClient;
+ Session : TFFProxySession;
+begin
+ Result := CheckSessionIDAndGet(aClientID, aSessionID, Client, Session);
+ if ResultOK(Result) then
+ Result := Session.SetTimeout(aTimeout);
+end;
+{----------}
+function TFFRemoteServerEngine.SQLAlloc(aClientID : TffClientID;
+ aDatabaseID : TffDatabaseID;
+ aTimeout : longInt;
+ var aStmtID : TffSqlStmtID) : TffResult;
+var
+ Database : TffProxyDatabase;
+begin
+ Result := CheckDatabaseIDAndGet(aDatabaseID, Database);
+ if ResultOK(Result) then
+ Result := Database.SQLAlloc(aTimeout, aStmtID);
+end;
+{----------}
+function TFFRemoteServerEngine.SQLExec(aStmtID : TffSqlStmtID;
+ aOpenMode : TffOpenMode;
+ var aCursorID : TffCursorID;
+ aStream : TStream) : TffResult;
+var
+ Statement : TffProxySQLStmt;
+begin
+ Assert(Assigned(aStream));
+ Result := CheckStmtIDAndGet(aStmtID, Statement);
+ if ResultOK(Result) then
+ Result := Statement.Exec(aOpenMode, aCursorID, aStream);
+end;
+{----------}
+function TFFRemoteServerEngine.SQLExecDirect(aClientID : TffClientID;
+ aDatabaseID : TffDatabaseID;
+ aQueryText : PChar;
+ aTimeout : longInt;
+ aOpenMode : TffOpenMode;
+ var aCursorID : TffCursorID;
+ aStream : TStream) : TffResult;
+var
+ Database : TffProxyDatabase;
+begin
+ Assert(Assigned(aStream));
+ Result := CheckDatabaseIDAndGet(aDatabaseID, Database);
+ if ResultOK(Result) then
+ Result := Database.SQLExecDirect(aQueryText, aOpenMode, aTimeout,
+ aCursorID, aStream);
+end;
+{----------}
+function TFFRemoteServerEngine.SQLFree(aStmtID : TffSqlStmtID) : TffResult;
+var
+ Statement : TffProxySQLStmt;
+begin
+ { Assumption: The cursor associated with the SQL statement has already been
+ closed. }
+ Result := CheckStmtIDAndGet(aStmtID, Statement);
+ if Result = DBIERR_NONE then
+ Statement.Free;
+end;
+{----------}
+function TFFRemoteServerEngine.SQLPrepare(aStmtID : TffSqlStmtID;
+ aQueryText : PChar;
+ aStream : TStream) : TffResult;
+var
+ Statement : TffProxySQLStmt;
+begin
+ Assert(Assigned(aStream));
+ Result := CheckStmtIDAndGet(aStmtID, Statement);
+ if Result = DBIERR_NONE then
+ Result := Statement.Prepare(aQueryText, aStream);
+end;
+{----------}
+function TFFRemoteServerEngine.SQLSetParams(aStmtID : TffSqlStmtID;
+ aNumParams : word;
+ aParamDescs : pointer;
+ aDataBuffer : PffByteArray;
+ aDataLen : Longint;
+ aStream : TStream
+ ) : TffResult;
+var
+ Statement : TffProxySQLStmt;
+begin
+ Assert(Assigned(aStream));
+ Result := CheckStmtIDAndGet(aStmtID, Statement);
+ if Result = DBIERR_NONE then
+ Result := Statement.SetParams(aNumParams, aParamDescs, aDataBuffer, aDataLen, aStream);
+end;
+{----------}
+function TFFRemoteServerEngine.TableAddIndex(
+ const aDatabaseID : TffDatabaseID;
+ const aCursorID : TffCursorID;
+ const aTableName : TffTableName;
+ const aIndexDesc: TffIndexDescriptor
+ ) : TffResult;
+var
+ Database : TFFProxyDatabase;
+begin
+ Result := CheckDatabaseIDAndGet(aDatabaseID, Database);
+ if ResultOK(Result) then
+ Result := Database.TableAddIndex(aCursorID,
+ aTableName,
+ aIndexDesc);
+end;
+{----------}
+function TFFRemoteServerEngine.TableBuild(aDatabaseID : TffDatabaseID;
+ aOverWrite : Boolean;
+ const aTableName : TffTableName;
+ aForServer : Boolean;
+ aDictionary : TffDataDictionary
+ ) : TffResult;
+var
+ Database : TFFProxyDatabase;
+begin
+ Result := CheckDatabaseIDAndGet(aDatabaseID, Database);
+ if ResultOK(Result) then
+ Result := Database.TableBuild(aOverWrite,
+ aTableName,
+ aForServer,
+ aDictionary);
+end;
+{----------}
+function TFFRemoteServerEngine.TableDelete(aDatabaseID : TffDatabaseID;
+ const aTableName : TffTableName
+ ) : TffResult;
+var
+ Database : TFFProxyDatabase;
+begin
+ Result := CheckDatabaseIDAndGet(aDatabaseID, Database);
+ if ResultOK(Result) then
+ Result := Database.TableDelete(aTableName);
+end;
+{----------}
+function TFFRemoteServerEngine.TableDropIndex(aDatabaseID : TffDatabaseID;
+ aCursorID : TffCursorID;
+ const aTableName : TffTableName;
+ const aIndexName : TffDictItemName;
+ aIndexID : Longint
+ ) : TffResult;
+var
+ Database : TFFProxyDatabase;
+begin
+ Result := CheckDatabaseIDAndGet(aDatabaseID, Database);
+ if ResultOK(Result) then
+ Result := Database.TableDropIndex(aCursorID,
+ aTablename,
+ aIndexName,
+ aIndexID);
+end;
+{----------}
+function TFFRemoteServerEngine.TableEmpty(aDatabaseID : TffDatabaseID;
+ aCursorID : TffCursorID;
+ const aTableName : TffTableName
+ ) : TffResult;
+var
+ Database : TFFProxyDatabase;
+begin
+ Result := CheckDatabaseIDAndGet(aDatabaseID, Database);
+ if ResultOK(Result) then
+ Result := Database.TableEmpty(aCursorID,
+ aTableName);
+end;
+{----------}
+function TffRemoteServerEngine.TableGetAutoInc(aCursorID : TffCursorID;
+ var aValue : TffWord32) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.TableGetAutoInc(aValue);
+end;
+{----------}
+function TFFRemoteServerEngine.TableGetDictionary(aDatabaseID : TffDatabaseID;
+ const aTableName : TffTableName;
+ aForServer : Boolean;
+ aStream : TStream
+ ) : TffResult;
+var
+ Database : TFFProxyDatabase;
+begin
+ Assert(Assigned(aStream));
+ Result := CheckDatabaseIDAndGet(aDatabaseID, Database);
+ if ResultOK(Result) then
+ Result := Database.TableGetDictionary(aTableName,
+ aForServer,
+ aStream);
+end;
+{----------}
+function TFFRemoteServerEngine.TableGetRecCount(aCursorID : TffCursorID;
+ var aRecCount : Longint
+ ) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.TableGetRecCount(aRecCount);
+end;
+{Begin !!.07}
+{----------}
+function TFFRemoteServerEngine.TableGetRecCountAsync(aCursorID : TffCursorID;
+ var aTaskID : Longint) : TffResult;
+var
+ Cursor : TffProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.TableGetRecCountAsync(aTaskID);
+end;
+{End !!.07}
+{----------}
+function TFFRemoteServerEngine.TableIsLocked(aCursorID : TffCursorID;
+ aLockType : TffLockType;
+ var aIsLocked : Boolean) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.TableIsLocked(aLockType,
+ aIsLocked);
+end;
+{----------}
+function TFFRemoteServerEngine.TableLockAcquire(aCursorID : TffCursorID;
+ aLockType : TffLockType
+ ) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.TableLockAcquire(aLockType);
+end;
+{----------}
+function TFFRemoteServerEngine.TableLockRelease(aCursorID : TffCursorID;
+ aAllLocks : Boolean
+ ) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.TableLockRelease(aAllLocks);
+end;
+{----------}
+function TFFRemoteServerEngine.TableOpen(const aDatabaseID : TffDatabaseID;
+ const aTableName : TffTableName;
+ const aForServer : Boolean;
+ const aIndexName : TffName;
+ aIndexID : Longint;
+ const aOpenMode : TffOpenMode;
+ aShareMode : TffShareMode;
+ const aTimeout : Longint;
+ var aCursorID : TffCursorID;
+ aStream : TStream) : TffResult;
+var
+ Database : TFFProxyDatabase;
+begin
+ Assert(Assigned(aStream));
+ Result := CheckDatabaseIDAndGet(aDatabaseID, Database);
+ if ResultOK(Result) then
+ Result := Database.TableOpen(aTableName,
+ aForServer,
+ aIndexName,
+ aIndexID,
+ aOpenMode,
+ aShareMode,
+ aTimeout,
+ aCursorID,
+ aStream);
+end;
+{----------}
+function TFFRemoteServerEngine.TablePack(aDatabaseID : TffDatabaseID;
+ const aTableName : TffTableName;
+ var aRebuildID : Longint) : TffResult;
+var
+ Database : TFFProxyDatabase;
+begin
+ Result := CheckDatabaseIDAndGet(aDatabaseID, Database);
+ if ResultOK(Result) then
+ Result := Database.TablePack(aTableName,
+ aRebuildID);
+end;
+{----------}
+function TFFRemoteServerEngine.TableRebuildIndex(aDatabaseID : TffDatabaseID;
+ const aTableName : TffTableName;
+ const aIndexName : TffName;
+ aIndexID : Longint;
+ var aRebuildID : Longint
+ ) : TffResult;
+var
+ Database : TFFProxyDatabase;
+begin
+ Result := CheckDatabaseIDAndGet(aDatabaseID, Database);
+ if ResultOK(Result) then
+ Result := Database.TableRebuildIndex(aTableName,
+ aIndexName,
+ aIndexID,
+ aRebuildID);
+end;
+{----------}
+function TFFRemoteServerEngine.TableRename(aDatabaseID : TffDatabaseID;
+ const aOldName : TffName;
+ const aNewName : TffName) : TffResult;
+var
+ Database : TFFProxyDatabase;
+begin
+ Result := CheckDatabaseIDAndGet(aDatabaseID, Database);
+ if ResultOK(Result) then
+ Result := Database.TableRename(aOldName,
+ aNewName);
+end;
+{----------}
+function TFFRemoteServerEngine.TableRestructure(aDatabaseID : TffDatabaseID;
+ const aTableName : TffTableName;
+ aDictionary : TffDataDictionary;
+ aFieldMap : TffStringList;
+ var aRebuildID : Longint
+ ) : TffResult;
+var
+ Database : TFFProxyDatabase;
+begin
+ Result := CheckDatabaseIDAndGet(aDatabaseID, Database);
+ if ResultOK(Result) then
+ Result := Database.TableRestructure(aTableName,
+ aDictionary,
+ aFieldMap,
+ aRebuildID);
+end;
+{----------}
+function TFFRemoteServerEngine.TableSetAutoInc(aCursorID : TffCursorID;
+ aValue : TffWord32
+ ) : TffResult;
+var
+ Cursor : TFFProxyCursor;
+begin
+ Result := CheckCursorIDAndGet(aCursorID, Cursor);
+ if ResultOK(Result) then
+ Result := Cursor.TableSetAutoInc(aValue);
+end;
+{Begin !!.11}
+{----------}
+function TFFRemoteServerEngine.TableVersion(aDatabaseID : TffDatabaseID;
+ const aTableName : TffTableName;
+ var aVersion : Longint) : TffResult;
+var
+ Database : TFFProxyDatabase;
+ Request : TffnmGetTableVersionReq;
+ Reply : PffnmGetTableVersionRpy;
+ ReplyLen : Longint;
+begin
+ Result := CheckDatabaseIDAndGet(aDatabaseID, Database);
+ if ResultOK(Result) then begin
+ aVersion := 0;
+ { Initialize Request }
+ Request.DatabaseID := Database.SrDatabaseID;
+ Request.TableName := aTableName;
+
+ Reply := nil;
+ Result := Database.pdClient.ProcessRequest(ffnmGetTableVersion,
+ Timeout,
+ @Request,
+ SizeOf(Request),
+ nmdByteArray,
+ Pointer(Reply),
+ ReplyLen,
+ nmdByteArray);
+
+ if ResultOK(Result) then
+ aVersion := Reply^.Version;
+
+ if Assigned(Reply) then
+ FFFreeMem(Reply, ReplyLen);
+ end; { if }
+end;
+{End !!.11}
+{----------}
+function TFFRemoteServerEngine.TransactionCommit(
+ const aDatabaseID : TffDatabaseID
+ ) : TffResult;
+var
+ Database : TFFProxyDatabase;
+begin
+ Result := CheckDatabaseIDAndGet(aDatabaseID, Database);
+ if ResultOK(Result) then
+ Result := Database.TransactionCommit;
+end;
+{----------}
+function TFFRemoteServerEngine.TransactionRollback(
+ const aDatabaseID : TffDatabaseID
+ ) : TffResult;
+var
+ Database : TFFProxyDatabase;
+begin
+ Result := CheckDatabaseIDAndGet(aDatabaseID, Database);
+ if ResultOK(Result) then
+ Result := Database.TransactionRollback;
+end;
+{----------}
+function TFFRemoteServerEngine.TransactionStart(
+ const aDatabaseID : TffDatabaseID;
+ const aFailSafe : Boolean
+ ) : TffResult;
+var
+ Database : TFFProxyDatabase;
+begin
+ Result := CheckDatabaseIDAndGet(aDatabaseID, Database);
+ if ResultOK(Result) then
+ Result := Database.TransactionStart(aFailSafe);
+end;
+{Begin !!.10}
+{----------}
+function TFFRemoteServerEngine.TransactionStartWith(
+ const aDatabaseID : TffDatabaseID;
+ const aFailSafe : Boolean;
+ const aCursorIDs : TffPointerList
+ ) : TffResult;
+var
+ Database : TFFProxyDatabase;
+begin
+ Result := CheckDatabaseIDAndGet(aDatabaseID, Database);
+ if ResultOK(Result) then
+ Result := Database.TransactionStartWith(aFailSafe, aCursorIDs);
+end;
+{End !!.10}
+{----------}
+
+initialization
+ RemoteServerEngines := TffThreadList.Create;
+
+finalization
+ RemoteServerEngines.Free;
+ RemoteServerEngines := nil;
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffclsqle.dfm b/components/flashfiler/sourcelaz/ffclsqle.dfm
new file mode 100644
index 000000000..9328a60b6
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffclsqle.dfm
@@ -0,0 +1,335 @@
+object ffSqlEditor: TffSqlEditor
+ Left = 282
+ Top = 132
+ ActiveControl = memSQL
+ BorderIcons = [biSystemMenu]
+ BorderStyle = bsSingle
+ Caption = 'SQL Editor'
+ ClientHeight = 297
+ ClientWidth = 527
+ Color = clBtnFace
+ Font.Color = clWindowText
+ Font.Height = -11
+ Font.Name = 'MS Sans Serif'
+ Font.Style = []
+ KeyPreview = True
+ Menu = mnuMain
+ Position = poScreenCenter
+ OnKeyDown = FormKeyDown
+ OnShow = FormShow
+ PixelsPerInch = 96
+ TextHeight = 13
+ object pnlBottom: TPanel
+ Left = 0
+ Top = 263
+ Width = 527
+ Height = 34
+ Align = alBottom
+ BevelOuter = bvNone
+ TabOrder = 0
+ object lblStatus: TLabel
+ Left = 8
+ Top = 11
+ Width = 42
+ Height = 13
+ Caption = '%d Lines'
+ end
+ object pbCancel: TButton
+ Left = 448
+ Top = 5
+ Width = 75
+ Height = 25
+ Cancel = True
+ Caption = '&Cancel'
+ ModalResult = 2
+ TabOrder = 0
+ end
+ object pbOK: TButton
+ Left = 368
+ Top = 5
+ Width = 75
+ Height = 25
+ Caption = '&OK'
+ Default = True
+ ModalResult = 1
+ TabOrder = 1
+ end
+ end
+ object ToolBar1: TToolBar
+ Left = 0
+ Top = 0
+ Width = 527
+ Height = 25
+ ButtonHeight = 24
+ ButtonWidth = 26
+ EdgeBorders = [ebTop, ebBottom]
+ Flat = True
+ Images = imgToolbar
+ TabOrder = 1
+ object tbLoad: TToolButton
+ Left = 0
+ Top = 0
+ Hint = 'Open file'
+ Caption = 'Load'
+ ImageIndex = 0
+ ParentShowHint = False
+ ShowHint = True
+ OnClick = tbLoadClick
+ end
+ object tbSave: TToolButton
+ Left = 26
+ Top = 0
+ Hint = 'Save to file'
+ Caption = 'Save'
+ ImageIndex = 2
+ ParentShowHint = False
+ ShowHint = True
+ OnClick = tbSaveClick
+ end
+ end
+ object memSQL: TMemo
+ Left = 0
+ Top = 25
+ Width = 527
+ Height = 238
+ Align = alClient
+ Lines.Strings = (
+ ''
+ )
+ ScrollBars = ssVertical
+ TabOrder = 2
+ OnChange = memSQLChange
+ OnMouseDown = memSQLMouseDown
+ end
+ object imgToolbar: TImageList
+ Height = 18
+ Width = 18
+ Left = 8
+ Top = 40
+ Bitmap = {
+ 494C010104000500040012001200FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600
+ 0000000000003600000028000000480000002400000001001000000000004014
+ 000000000000000000000000000000000000F75EF75EF75EF75EF75EF75EF75E
+ F75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75E
+ F75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75E
+ F75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75E
+ F75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75E
+ F75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75E
+ F75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75EEF3D0000
+ F75EF75EF75EF75EF75E0000F75EF75EF75EF75EF75EF75EF75EF75E0000F75E
+ F75EF75E0000F75EF75EF75E0000F75E0000F75EF75EF75E0000F75E0000F75E
+ F75E0000F75EF75E0000F75EF75EF75EF75E0000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00000000000000000000000000000000000000000000F75EF75EF75EF75EF75E
+ F75E0000FB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7F
+ FB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7F
+ FB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7F
+ FB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7F
+ FB7FFB7F0000F75EF75EF75EF75EF75EF75E0000FB7FFC7FFB7FFB7FFB7FFC7F
+ FB7FFB7FFB7FFC7FFB7FFB7FFB7FFC7FFB7FFB7FFB7FFC7FFB7FFB7FFB7FFC7F
+ FB7FFB7FFB7FFC7FFB7FFB7FFB7FFC7F00000000FB7FFC7FFB7FFB7FFB7FFC7F
+ FB7FFB7FFB7FFC7FFB7FFB7FFB7FFC7FFB7FFB7FFB7FFC7FFB7FFB7FFB7FFC7F
+ FB7FFB7FFB7FFC7FFB7FFB7FFB7FFC7FFB7FFB7F0000F75EF75E00000000F75E
+ F75EFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7F
+ FB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7F
+ FB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7FFB7F
+ FB7FFB7FFB7FFB7F0000F75EF75EF75EF75EF75EF75EF75EF75EF75EF75EF75E
+ F75EF75EF75E0000FB7FFC7FFB7FFB7FFB7F0000FB7FFC7F0000FB7FFB7FFC7F
+ 0000FB7FFB7FFC7FFB7F0000000000000000FB7FFB7FFC7F0000FB7FFB7FFC7F
+ 0000FB7FFB7F0000000000000000FB7FFB7FFC7F0000FB7FFB7FFC7F0000FB7F
+ FB7FFC7FFB7FFB7F0000FC7FFB7FFB7F00000000FB7FFC7F0000000000000000
+ 0000F75E0000F75EF75EF75E0000F75E0000F75EF75E0000FB7FFB7FFB7FFB7F
+ FB7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFB7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFB7F0000FB7F0000FB7FFB7FFB7F0000
+ FB7FF75EF75E0000FB7FFB7FFB7FFC7F0000FF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FF75E0000F75EF75E0000F75E
+ 0000F75EF75EFF7FFF7FFF7FFF7FFF7FFF7FFB7F0000FF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F00000000FF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F000000000000
+ 00000000000000000000000000000000000000000000FF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7F000000000000000000000000FF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7F0000FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ 000000000000000000000000000000000000FF7FFF7FFF7F1042104210421042
+ 10421042104210421042104210421042104210420000FF7FFF7FFF7FFF7FFF7F
+ FF7F000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000000000000000000000FF7FFF7FFF7FFF7FFF7FFF7FFF7F
+ FF7F0000FF7FFF7FFF7FFF7FFF7FFF7FFF7F0000000000000000000000000000
+ 0000FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F00000000000000000000FF7FFF7F
+ FF7FFF7F00000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000000000000000000000E07F1863E07F1863E07F18631042
+ 00000000000000000000EF3D000000000000FF7F000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00000000EF3DEF3DEF3DEF3DEF3DEF3DEF3DEF3DEF3DEF3DEF3DEF3DEF3D0000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000000000000000000F000F000000F75E0F000F00F75EF75E
+ F75E00000F000F0000000000000000000000EF3DEF3DEF3DEF3DF75EFF7FFF7F
+ F75EF75EF75EEF3DEF3DEF3DEF3D00000000000000000000EF3DEF3DEF3DEF3D
+ EF3DEF3DEF3DEF3DEF3DEF3DEF3DEF3D000000000000000000000000EF3DEF3D
+ EF3DEF3DEF3DEF3DEF3DEF3DEF3DEF3DEF3DEF3DEF3D00000000000000000000
+ 0F000F000000F75E0F000F00F75EF75EF75E00000F000F000000000000000000
+ 0000EF3DEF3DEF3DEF3DF75EFF7FFF7FF75EF75EF75EEF3DEF3DEF3DEF3D0000
+ 0000000000000000EF3DFF7FE07FF75EE07FF75EE07FF75EE07FF75EE07FEF3D
+ 000000000000000000000000EF3DFF7FFF7FF75EFF7FF75EFF7FF75EFF7FF75E
+ FF7FEF3DEF3D000000000000000000000F000F000000F75E0F000F00F75EF75E
+ F75E00000F000F0000000000000000000000EF3DEF3DEF3DEF3DF75EFF7FFF7F
+ F75EF75EF75EEF3DEF3DEF3DEF3D0000000000000000EF3DFF7FE07FF75EE07F
+ F75EE07FF75EE07FF75EE07FF75E0000EF3D0000000000000000EF3DFF7FFF7F
+ F75EFF7FF75EFF7FF75EFF7FF75EFF7FF75EEF3DEF3D00000000000000000000
+ 0F000F000F00F75EF75EF75EF75EF75EF75E0F000F000F000000000000000000
+ 0000EF3DEF3DEF3DEF3DF75EF75EF75EF75EF75EF75EEF3DEF3DEF3DEF3D0000
+ 000000000000EF3DFF7FF75EE07FF75EE07FF75EE07FF75EE07FF75EEF3D0000
+ EF3D0000000000000000EF3DFF7FF75EFF7FF75EFF7FF75EFF7FF75EFF7FF75E
+ EF3DF75EEF3D000000000000000000000F000F000F000F000F000F000F000F00
+ 0F000F000F000F0000000000000000000000EF3DEF3DEF3DEF3DEF3DEF3DEF3D
+ EF3DEF3DEF3DEF3DEF3DEF3DEF3D000000000000EF3DFF7FF75EE07FF75EE07F
+ F75EE07FF75EE07FF75EE07F0000EF3DEF3D000000000000EF3DFF7FF75EFF7F
+ F75EFF7FF75EFF7FF75EFF7FF75EFF7FEF3DFF7FEF3D00000000000000000000
+ 0F000F00000000000000000000000000000000000F000F000000000000000000
+ 0000EF3DEF3DEF3DEF3DEF3DEF3DEF3DEF3DEF3DEF3DEF3DEF3DEF3DEF3D0000
+ 00000000EF3DFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FEF3D0000F75E
+ EF3D000000000000EF3DFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FEF3D
+ FF7FF75EEF3D000000000000000000000F000000FF7FFF7FFF7FFF7FFF7FFF7F
+ FF7FFF7F00000F0000000000000000000000EF3DEF3DEF3DFF7FFF7FFF7FFF7F
+ FF7FFF7FFF7FFF7FEF3DEF3DEF3D000000000000EF3DEF3DEF3DEF3DEF3DEF3D
+ EF3DEF3DEF3DEF3DEF3DEF3DEF3DE07FEF3D000000000000EF3DEF3DEF3DEF3D
+ EF3DEF3DEF3DEF3DEF3DEF3DEF3DEF3DF75EFF7FEF3D00000000000000000000
+ 0F000000FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F00000F000000000000000000
+ 0000EF3DEF3DEF3DFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FEF3DEF3DEF3D0000
+ 0000000000000000EF3DFF7FE07FF75EE07FF75EE07FF75EE07FF75EE07FF75E
+ EF3D00000000000000000000EF3DFF7FFF7FF75EFF7FF75EFF7FF75EFF7FF75E
+ FF7FF75EEF3D000000000000000000000F000000FF7FEF3DEF3DEF3DEF3DEF3D
+ EF3DFF7F00000F0000000000000000000000EF3DEF3DEF3DFF7FEF3DEF3DEF3D
+ EF3DEF3DEF3DFF7FEF3DEF3DEF3D00000000000000000000EF3DFF7FF75EE07F
+ F75EE07FF75EFF7FFF7FFF7FFF7FFF7FEF3D00000000000000000000EF3DFF7F
+ F75EFF7FF75EFF7FF75EFF7FFF7FFF7FFF7FFF7FEF3D00000000000000000000
+ 0F000000FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F00000F000000000000000000
+ 0000EF3DEF3DEF3DFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FEF3DEF3DEF3D0000
+ 0000000000000000EF3DFF7FE07FF75EE07FF75EFF7FEF3DEF3DEF3DEF3DEF3D
+ EF3D00000000000000000000EF3DFF7FFF7FF75EFF7FF75EFF7FEF3DEF3DEF3D
+ EF3DEF3D000000000000000000000000F75E0000FF7FEF3DEF3DEF3DEF3DEF3D
+ EF3DFF7F0000000000000000000000000000EF3DF75EEF3DFF7FEF3DEF3DEF3D
+ EF3DEF3DEF3DFF7FEF3DEF3DEF3D000000000000000000000000EF3DFF7FFF7F
+ FF7FFF7FEF3D000000000000000000000000000000000000000000000000EF3D
+ FF7FFF7FFF7FFF7FEF3D00000000000000000000000000000000000000000000
+ 0F000000FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F00000F000000000000000000
+ 0000EF3DEF3DEF3DFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FEF3DEF3DEF3D0000
+ 000000000000000000000000EF3DEF3DEF3DEF3D000000000000000000000000
+ 00000000000000000000000000000000EF3DEF3DEF3DEF3D0000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000000000000000000000EF3DEF3DEF3DEF3DEF3DEF3DEF3D
+ EF3DEF3DEF3DEF3DEF3DEF3DEF3D000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000000000000000000000424D3E000000000000003E000000
+ 2800000048000000240000000100010000000000B00100000000000000000000
+ 000000000000000000000000FFFFFF0000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000FFFFFFFFFFFFFFFFFF000000FFFFFFFFFFFFFFFFFF000000
+ FFFFFFFFFE000F8003000000F0007FFFFC000F0003000000E00078003C000F00
+ 03000000E00078003C000F0003000000C00070003C000F0003000000C0007000
+ 3C000F0003000000800060003C000F0003000000800060003C000F0003000000
+ 800060003C000F0003000000E00078003C000F0003000000E00078003C000F00
+ 03000000E000F8007C000F0003000000F03FFC0FFC000F0003000000F87FFE1F
+ FC000F0003000000FFFFFFFFFFFFFFFFFF000000FFFFFFFFFFFFFFFFFF000000
+ 00000000000000000000000000000000000000000000
+ }
+ end
+ object pmMain: TPopupMenu
+ Left = 80
+ Top = 40
+ object pmMainLoad: TMenuItem
+ Caption = '&Open file...'
+ OnClick = tbLoadClick
+ end
+ object pmMainSave: TMenuItem
+ Caption = '&Save file...'
+ OnClick = tbSaveClick
+ end
+ end
+ object dlgOpen: TOpenDialog
+ Filter = 'SQL scripts (*.SQL)|*.SQL|Text files (*.TXT)|*.TXT|Any files (*.*)|*.*'
+ Title = 'Open SQL statement'
+ Left = 128
+ Top = 40
+ end
+ object dlgSave: TSaveDialog
+ Filter = 'SQL scripts (*.SQL)|*.SQL|Text files (*.TXT)|*.TXT|Any files (*.*)|*.*'
+ Title = 'Save SQL statement'
+ Left = 160
+ Top = 40
+ end
+ object mnuMain: TMainMenu
+ Left = 48
+ Top = 40
+ object mnuMainFile: TMenuItem
+ Caption = '&File'
+ ShortCut = 16460
+ object mnuMainLoad: TMenuItem
+ Caption = '&Open...'
+ ShortCut = 16463
+ OnClick = tbLoadClick
+ end
+ object mnuMainSave: TMenuItem
+ Caption = '&Save As..'
+ ShortCut = 16467
+ OnClick = tbSaveClick
+ end
+ end
+ end
+end
diff --git a/components/flashfiler/sourcelaz/ffclsqle.pas b/components/flashfiler/sourcelaz/ffclsqle.pas
new file mode 100644
index 000000000..74ef53be0
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffclsqle.pas
@@ -0,0 +1,178 @@
+{*********************************************************}
+{* Design-time SQL Editor *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffclsqle;
+
+interface
+
+uses
+ Windows,
+ Messages,
+ SysUtils,
+ Classes,
+ Graphics,
+ Controls,
+ Forms,
+ Dialogs,
+ ComCtrls,
+ ToolWin,
+ ExtCtrls,
+ StdCtrls,
+ {$IFDEF DCC4OrLater}
+ ImgList,
+ {$ENDIF}
+ Menus;
+
+
+type
+ TffSqlEditor = class(TForm)
+ pnlBottom: TPanel;
+ ToolBar1: TToolBar;
+ imgToolbar: TImageList;
+ tbLoad: TToolButton;
+ tbSave: TToolButton;
+ memSQL: TMemo;
+ lblStatus: TLabel;
+ pbCancel: TButton;
+ pbOK: TButton;
+ pmMain: TPopupMenu;
+ pmMainLoad: TMenuItem;
+ pmMainSave: TMenuItem;
+ dlgOpen: TOpenDialog;
+ dlgSave: TSaveDialog;
+ mnuMain: TMainMenu;
+ mnuMainFile: TMenuItem;
+ mnuMainSave: TMenuItem;
+ mnuMainLoad: TMenuItem;
+ procedure memSQLChange(Sender: TObject);
+ procedure tbLoadClick(Sender: TObject);
+ procedure tbSaveClick(Sender: TObject);
+ procedure FormShow(Sender: TObject);
+ procedure memSQLMouseDown(Sender: TObject; Button: TMouseButton;
+ Shift: TShiftState; X, Y: Integer);
+ procedure FormKeyDown(Sender: TObject; var Key: Word;
+ Shift: TShiftState);
+ private
+ { Private declarations }
+ function GetLines : longInt;
+ procedure SetLines(anOrdValue : longInt);
+
+ public
+ { Public declarations }
+ property SQLLines : longint read GetLines write SetLines;
+ end;
+
+var
+ ffSqlEditor: TffSqlEditor;
+
+implementation
+
+uses
+ ffllbase;
+
+{$R *.DFM}
+
+const
+ ffcLine : string = '%d line';
+ ffcLines : string = '%d lines';
+
+{===TffSqlEditor=====================================================}
+procedure TffSqlEditor.memSQLChange(Sender: TObject);
+var
+ aCount : integer;
+begin
+ aCount := memSQL.Lines.Count;
+ if aCount = 1 then
+ lblStatus.Caption := format(ffcLine, [aCount])
+ else
+ lblStatus.Caption := format(ffcLines, [aCount]);
+end;
+{--------}
+procedure TffSqlEditor.tbLoadClick(Sender: TObject);
+begin
+ if dlgOpen.Execute then begin
+ dlgOpen.InitialDir := ExtractFilePath(dlgOpen.FileName);
+ memSQL.Lines.LoadFromFile(dlgOpen.FileName);
+ end;
+end;
+{--------}
+procedure TffSqlEditor.tbSaveClick(Sender: TObject);
+begin
+ { Do we have a filename from the last save? }
+ if dlgSave.FileName = '' then
+ { No. Use the one from the open dialog. }
+ dlgSave.FileName := dlgOpen.FileName;
+
+ if dlgSave.InitialDir = '' then
+ dlgSave.InitialDir := dlgOpen.InitialDir;
+
+ if dlgSave.Execute then begin
+ dlgSave.InitialDir := ExtractFilePath(dlgSave.FileName);
+ memSQL.Lines.SaveToFile(dlgSave.FileName);
+ end;
+end;
+{--------}
+procedure TffSqlEditor.FormShow(Sender: TObject);
+begin
+ { Set default file extensions. }
+ dlgOpen.DefaultExt := ffc_ExtForSQL;
+ dlgSave.DefaultExt := dlgOpen.DefaultExt;
+end;
+{--------}
+function TffSqlEditor.GetLines : longInt;
+begin
+ Result := longInt(memSQL.Lines);
+end;
+{--------}
+procedure TffSqlEditor.SetLines(anOrdValue : longInt);
+begin
+ memSQL.Lines := TStrings(anOrdValue);
+end;
+{--------}
+procedure TffSqlEditor.memSQLMouseDown(Sender: TObject;
+ Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
+var
+ MousePos : TPoint;
+begin
+ if Button = mbRight then begin
+ MousePos := memSQL.ClientToScreen(Point(X, Y));
+ pmMain.Popup(MousePos.X, MousePos.Y);
+ end;
+end;
+{====================================================================}
+procedure TffSqlEditor.FormKeyDown(Sender: TObject; var Key: Word;
+ Shift: TShiftState);
+begin
+ if Key = VK_ESCAPE then
+ Close;
+end;
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffcltbrg.pas b/components/flashfiler/sourcelaz/ffcltbrg.pas
new file mode 100644
index 000000000..bec9adebb
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffcltbrg.pas
@@ -0,0 +1,227 @@
+{*********************************************************}
+{* FlashFiler: Range support for Client Tables *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffcltbrg;
+
+interface
+
+uses
+ ffllbase;
+
+type
+ TffTableRangeStack = class
+ private
+ trsStack : pointer;
+ trsSavedRequest : pffByteArray;
+ trsSavedReqLen : integer;
+ protected
+
+ function GetSavedRequest : boolean;
+
+ public
+ constructor Create;
+ destructor Destroy; override;
+
+ procedure Clear;
+ procedure ClearSaved;
+ { Use this method to clear out the saved request bucket. }
+ function IsEmpty : boolean;
+ procedure Pop(var aRequestPacket : PffByteArray;
+ var aPacketLen : integer);
+
+ procedure PopSavedRequest(var aRequestPacket : PffByteArray;
+ var aPacketLen : integer);
+ { Use this method to pop the top of the stack into the
+ saved request bucket. This method also returns the
+ request and its length so that the caller may resend
+ the request to the server. However, the caller must not
+ free this request because it is still in the saved
+ bucket. }
+
+ procedure Push(aRequestPacket : PffByteArray;
+ aPacketLen : integer);
+
+
+ procedure PushSavedRequest;
+ { Use this method to push the last saved request onto the
+ range stack. After it is pushed onto the stack, the last
+ saved request is removed from the save bucket. }
+
+ procedure SaveLastRequest(aRequestPacket : PffByteArray;
+ aPacketLen : integer);
+ { This method is used as a bucket to hold the last range
+ request. If a request is already in the bucket, we dispose
+ of it prior to saving the new request.
+ @param aRequestPacket The setRange message sent to the
+ server.
+ @param aPacketLen The length of the setRange message sent
+ to the server. }
+
+ property SavedRequest : boolean read GetSavedRequest;
+ { Returns True if a setRange request is in the saved bucket. }
+
+ end;
+
+implementation
+
+type
+ PStackNode = ^TStackNode;
+ TStackNode = packed record
+ snNext : PStackNode;
+ snReq : PffByteArray;
+ snLen : integer;
+ end;
+
+{===TffTableRangeStack===============================================}
+constructor TffTableRangeStack.Create;
+begin
+ inherited Create;
+ trsStack := nil; {this means the stack is empty}
+ trsSavedRequest := nil;
+ trsSavedReqLen := -1;
+end;
+{--------}
+destructor TffTableRangeStack.Destroy;
+begin
+ Clear;
+ inherited Destroy;
+end;
+{--------}
+procedure TffTableRangeStack.Clear;
+var
+ Req : PffByteArray;
+ Len : integer;
+begin
+ while not IsEmpty do begin
+ Pop(Req, Len);
+ FreeMem(Req, Len);
+ end;
+ ClearSaved;
+end;
+{--------}
+procedure TffTableRangeStack.ClearSaved;
+begin
+ if assigned(trsSavedRequest) then begin
+ FFFreeMem(trsSavedRequest, trsSavedReqLen);
+ trsSavedRequest := nil;
+ trsSavedReqLen := -1;
+ end;
+end;
+{--------}
+function TffTableRangeStack.getSavedRequest : boolean;
+begin
+ result := assigned(trsSavedRequest);
+end;
+{--------}
+function TffTableRangeStack.IsEmpty : boolean;
+begin
+ Result := trsStack = nil;
+end;
+{--------}
+procedure TffTableRangeStack.Pop(var aRequestPacket : PffByteArray;
+ var aPacketLen : integer);
+var
+ Temp : PStackNode;
+begin
+ Temp := trsStack;
+ if (Temp <> nil) then begin
+ aRequestPacket := Temp^.snReq;
+ aPacketLen := Temp^.snLen;
+ trsStack := Temp^.snNext;
+ Dispose(Temp);
+ end
+ else begin
+ aRequestPacket := nil;
+ aPacketLen := 0;
+ end;
+end;
+{--------}
+procedure TffTableRangeStack.PopSavedRequest
+ (var aRequestPacket : PffByteArray;
+ var aPacketLen : integer);
+var
+ Temp : PStackNode;
+begin
+ Temp := trsStack;
+ if (Temp <> nil) then begin
+ aRequestPacket := Temp^.snReq;
+ aPacketLen := Temp^.snLen;
+ trsSavedRequest := aRequestPacket;
+ trsSavedReqLen := aPacketLen;
+ trsStack := Temp^.snNext;
+ Dispose(Temp);
+ end
+ else begin
+ aRequestPacket := nil;
+ aPacketLen := 0;
+ end;
+end;
+{--------}
+procedure TffTableRangeStack.Push(aRequestPacket : PffByteArray;
+ aPacketLen : integer);
+var
+ Temp : PStackNode;
+begin
+ New(Temp);
+ Temp^.snNext := trsStack;
+ Temp^.snReq := aRequestPacket;
+ Temp^.snLen := aPacketLen;
+ trsStack := Temp;
+end;
+{--------}
+procedure TffTableRangeStack.PushSavedRequest;
+var
+ Temp : PStackNode;
+begin
+ New(Temp);
+ Temp^.snNext := trsStack;
+ Temp^.snReq := trsSavedRequest;
+ Temp^.snLen := trsSavedReqLen;
+ trsStack := Temp;
+ trsSavedRequest := nil;
+ trsSavedReqLen := -1;
+end;
+{--------}
+procedure TffTableRangeStack.SaveLastRequest
+ (aRequestPacket : PffByteArray;
+ aPacketLen : integer);
+begin
+
+ if assigned(trsSavedRequest) then
+ FFFreeMem(trsSavedRequest, trsSavedReqLen);
+
+ trsSavedRequest := aRequestPacket;
+ trsSavedReqLen := aPacketLen;
+
+end;
+{====================================================================}
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffclver.pas b/components/flashfiler/sourcelaz/ffclver.pas
new file mode 100644
index 000000000..b1be00117
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffclver.pas
@@ -0,0 +1,81 @@
+{*********************************************************}
+{* FlashFiler: Component Version Property Editor *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffclver;
+
+interface
+
+uses
+ SysUtils,
+ Classes,
+ Controls,
+ {$IFDEF DCC6OrLater}
+ DesignIntf,
+ DesignEditors;
+ {$ELSE}
+ DsgnIntf;
+ {$ENDIF}
+
+type
+ TffVersionProperty = class(TStringProperty)
+ public
+ function GetAttributes: TPropertyAttributes; override;
+ procedure Edit; override;
+ end;
+
+implementation
+
+uses
+ Forms,
+ ffabout;
+
+{===TffVersionProperty===============================================}
+function TffVersionProperty.GetAttributes: TPropertyAttributes;
+begin
+ Result := [paDialog, paReadOnly];
+end;
+{--------}
+procedure TffVersionProperty.Edit;
+var
+ AboutBox : TFFAboutBox;
+begin
+ AboutBox := TFFAboutBox.Create(Application);
+ try
+ AboutBox.Caption := 'About FlashFiler Components';
+ AboutBox.ProgramName.Caption := 'FlashFiler 2';
+ AboutBox.ShowModal;
+ finally
+ AboutBox.Free;
+ end;
+end;
+{====================================================================}
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffcomms/ffcomms.dpr b/components/flashfiler/sourcelaz/ffcomms/ffcomms.dpr
new file mode 100644
index 000000000..97142b96b
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffcomms/ffcomms.dpr
@@ -0,0 +1,46 @@
+{*********************************************************}
+{* Project source file *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+program FFComms;
+
+uses
+ {$IFDEF USETeDEBUG}
+ TeDebug,
+ {$ENDIF}
+ Forms,
+ uFFComms in 'uFFComms.pas' {frmMain};
+
+{$R *.RES}
+
+begin
+ Application.Initialize;
+ Application.Title := 'FlashFiler Client Communications Utility';
+ Application.CreateForm(TfrmFFCommsMain, frmFFCommsMain);
+ Application.Run;
+end.
diff --git a/components/flashfiler/sourcelaz/ffcomms/ffcomms.rc b/components/flashfiler/sourcelaz/ffcomms/ffcomms.rc
new file mode 100644
index 000000000..62701ce3e
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffcomms/ffcomms.rc
@@ -0,0 +1,112 @@
+/*********************************************************
+ * Main program icon resource *
+ *********************************************************/
+
+/* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** */
+
+#define VERSIONINFO_1 1
+MAINICON ICON
+{
+ '00 00 01 00 01 00 20 20 10 00 00 00 00 00 E8 02'
+ '00 00 16 00 00 00 28 00 00 00 20 00 00 00 40 00'
+ '00 00 01 00 04 00 00 00 00 00 80 02 00 00 00 00'
+ '00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00'
+ '00 00 00 00 80 00 00 80 00 00 00 80 80 00 80 00'
+ '00 00 80 00 80 00 80 80 00 00 C0 C0 C0 00 80 80'
+ '80 00 00 00 FF 00 00 FF 00 00 00 FF FF 00 FF 00'
+ '00 00 FF 00 FF 00 FF FF 00 00 FF FF FF 00 00 00'
+ '00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00'
+ '00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00'
+ '00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00'
+ '00 FF FF FF 00 00 00 00 FF FF FF 00 00 00 00 00'
+ '00 FF FF FF 0B BB BB B0 FF FF FF 00 00 00 00 00'
+ '00 00 00 00 00 0B B0 00 00 00 00 00 00 00 00 00'
+ '00 00 88 00 00 0B B0 00 00 88 00 00 00 00 00 00'
+ '00 00 88 00 00 0B B0 00 00 88 00 00 00 00 00 00'
+ '00 00 00 00 00 0B B0 00 00 00 00 00 00 00 00 00'
+ '00 00 00 00 00 0B B0 00 00 00 00 00 00 00 00 00'
+ '00 00 00 00 00 0B B0 00 00 00 00 00 00 00 00 00'
+ '00 FF FF FF 00 0B B0 00 FF FF FF 00 00 00 00 00'
+ '00 FF FF FF 0B BB BB B0 FF FF FF 00 00 00 00 00'
+ '00 00 00 00 00 0B B0 00 00 00 00 00 00 00 00 00'
+ '00 00 88 00 00 0B B0 00 00 88 00 00 00 00 00 00'
+ '00 00 88 00 00 0B B0 00 00 88 00 00 00 00 00 00'
+ '00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00'
+ '00 00 00 00 0F FF FF F0 00 00 00 00 00 00 00 00'
+ '00 00 00 00 00 00 FF F0 00 00 00 00 00 00 00 99'
+ '99 90 00 99 99 90 00 00 00 00 00 00 00 00 00 09'
+ '90 00 00 09 90 00 80 00 00 00 00 00 00 00 00 09'
+ '90 00 00 09 90 08 80 00 00 00 00 00 00 00 00 09'
+ '90 00 00 09 90 00 00 00 00 00 00 00 00 00 00 09'
+ '90 00 90 09 90 00 90 00 00 00 00 00 00 00 00 09'
+ '99 99 90 09 99 99 90 00 00 00 00 00 00 00 00 09'
+ '90 00 90 09 90 00 90 00 00 00 00 00 00 00 00 09'
+ '90 00 00 09 90 00 00 00 00 00 00 00 00 00 00 09'
+ '90 00 09 09 90 00 09 00 00 00 00 00 00 00 00 09'
+ '90 00 99 09 90 00 99 00 00 00 00 00 00 00 00 99'
+ '99 99 99 99 99 99 99 00 00 00 00 00 00 00 00 00'
+ '00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00'
+ '00 00 00 00 00 00 00 00 00 00 00 00 00 00 FF FF'
+ 'FF FF FF FF FF FF F8 07 E0 1F F8 07 E0 1F F8 00'
+ '00 1F F8 06 60 1F FE 1E 78 7F FE 1E 78 7F FE 1E'
+ '78 7F FF FE 7F FF F8 06 60 1F F8 06 60 1F F8 00'
+ '00 1F F8 06 60 1F FE 1E 78 7F FE 1E 78 7F FE 10'
+ '08 7F FF F0 0F FF FF FF 0F FF C1 C1 0F FF E7 E7'
+ '3F FF E7 E4 3F FF E7 E4 3F FF E7 67 7F FF E0 60'
+ '7F FF E7 67 7F FF E7 E7 FF FF E7 A7 BF FF E7 27'
+ '3F FF C0 00 3F FF FF FF FF FF FF FF FF FF'
+}
+
+
+VERSIONINFO_1 VERSIONINFO
+FILEVERSION 2, 1, 3, 0
+PRODUCTVERSION 2, 1, 0, 1
+FILEOS VOS__WINDOWS32
+FILETYPE VFT_APP
+{
+ BLOCK "StringFileInfo"
+ {
+ BLOCK "040904E4"
+ {
+ VALUE "CompanyName", "TurboPower Software Company\000\000"
+ VALUE "FileDescription", "FlashFiler Client Configuration Utility\000"
+ VALUE "FileVersion", "2.1.3.0\000"
+ VALUE "InternalName", "FFCOMMS\000"
+ VALUE "LegalCopyright", "Copyright (c) TurboPower Software Co. 1996-2002\000\000"
+ VALUE "OriginalFilename", "FFCOMMS.EXE\000"
+ VALUE "ProductName", "FlashFiler (Delphi Edition)\000"
+ VALUE "ProductVersion", "2.1.3.0\000"
+ }
+
+ }
+
+ BLOCK "VarFileInfo"
+ {
+ VALUE "Translation", 0x409, 1252
+ }
+
+}
+
diff --git a/components/flashfiler/sourcelaz/ffcomms/ffcomms.res b/components/flashfiler/sourcelaz/ffcomms/ffcomms.res
new file mode 100644
index 000000000..043426327
Binary files /dev/null and b/components/flashfiler/sourcelaz/ffcomms/ffcomms.res differ
diff --git a/components/flashfiler/sourcelaz/ffcomms/uffcomms.dfm b/components/flashfiler/sourcelaz/ffcomms/uffcomms.dfm
new file mode 100644
index 000000000..4b2d84a9c
Binary files /dev/null and b/components/flashfiler/sourcelaz/ffcomms/uffcomms.dfm differ
diff --git a/components/flashfiler/sourcelaz/ffcomms/uffcomms.pas b/components/flashfiler/sourcelaz/ffcomms/uffcomms.pas
new file mode 100644
index 000000000..5e5f4bbfb
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffcomms/uffcomms.pas
@@ -0,0 +1,272 @@
+{*********************************************************}
+{* Main dialog unit *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+unit uFFComms;
+
+interface
+
+{$I FFDEFINE.INC}
+
+uses
+ Messages,
+ SysUtils,
+ Classes,
+ Graphics,
+ Controls,
+ Forms,
+ Dialogs,
+ StdCtrls,
+ FFCLCfg,
+ FFConst,
+ FFLLBase,
+ FFLLProt,
+ FFCLBase,
+ Mask,
+ Windows,
+ ffllwsck, {!!.11}
+ Registry; {!!.06}
+
+type
+ TfrmFFCommsMain = class(TForm)
+ cboProtocol: TComboBox;
+ lblTransport: TLabel;
+ lblServerName: TLabel;
+ efServerName: TEdit;
+ lblTitle: TLabel;
+ btnOK: TButton;
+ btnCancel: TButton;
+ efServerAddress: TMaskEdit;
+ lblServerAddress: TLabel;
+ chkAsHostName: TCheckBox;
+ procedure FormCreate(Sender: TObject);
+ procedure btnCancelClick(Sender: TObject);
+ procedure btnOKClick(Sender: TObject);
+ procedure cboProtocolClick(Sender: TObject);
+ procedure cboProtocolChange(Sender: TObject);
+ procedure Button1Click(Sender: TObject);
+ procedure chkAsHostNameClick(Sender: TObject);
+ private
+ procedure SetCtrlStates;
+ public
+ Protocol: TffCommsProtocolClass;
+ end;
+
+var
+ frmFFCommsMain: TfrmFFCommsMain;
+
+implementation
+
+uses
+ FFUtil;
+
+{$R *.DFM}
+
+function NormalizeIPAddress(const Addr : string) : string;
+var
+ Idx : Integer;
+ StartOctet : Boolean;
+begin
+ StartOctet := True;
+ for Idx := 1 to Length(Addr) do
+ if Addr[Idx] = '.' then begin
+ if Length(Result) = 0 then
+ Result := Result + '0'
+ else if Result[Length(Result)] = '.' then
+ Result := Result + '0';
+ Result := Result + Addr[Idx];
+ StartOctet := True;
+ Continue;
+ end else if Addr[Idx] = '0' then begin
+ if StartOctet then
+ Continue
+ else
+ Result := Result + Addr[Idx];
+ end else begin
+ StartOctet := False;
+ Result := Result + Addr[Idx];
+ end;
+ if Result[Length(Result)] = '.' then
+ Result := Result + '0';
+end;
+
+procedure TfrmFFCommsMain.FormCreate(Sender: TObject);
+var
+ ProtocolName: TffShStr;
+ ServerAddress : string;
+ ServerName : string;
+ Reg : TRegistry; {!!.06}
+begin
+
+ { Load the protocol combo box dropdown list. }
+ FFClientConfigGetProtocolNames(cboProtocol.Items);
+
+ { Get the current protocol setting. }
+ FFClientConfigReadProtocol(Protocol, ProtocolName);
+ with cboProtocol do
+ ItemIndex := Items.IndexOf(ProtocolName);
+ btnOK.Enabled := cboProtocol.ItemIndex <> -1;
+
+ SetCtrlStates;
+
+ { Get the current Server name & address. }
+ FFSeparateAddress(FFClientConfigReadServerName,
+ ServerName, ServerAddress);
+ efServerName.Text := ServerName;
+
+ Reg := TRegistry.Create;
+ try
+ if Reg.OpenKey('Software\TurboPower\FlashFiler\2.0\FFComms', False) then
+ chkAsHostName.Checked := Reg.ReadBool('ServerAddressAsText');
+ finally
+ Reg.Free;
+ end;
+
+ if chkAsHostName.Checked then {begin !!.06}
+ efServerAddress.EditMask := ''
+ else
+ efServerAddress.EditMask := '999.999.999.999;1'; {end !!.06}
+
+ efServerAddress.Text := ServerAddress;
+end;
+
+procedure TfrmFFCommsMain.cboProtocolClick(Sender: TObject);
+begin
+ btnOK.Enabled := cboProtocol.ItemIndex <> -1;
+end;
+
+procedure TfrmFFCommsMain.btnOKClick(Sender: TObject);
+var {begin !!.01}
+ Addr : string;
+ Idx : Integer;
+ Reg : TRegistry; {!!.06}
+begin
+ Addr := efServerAddress.Text;
+
+ {Strip spaces if tcp/ip}
+ if (cboProtocol.Items[cboProtocol.ItemIndex] = ffc_TCPIP) then
+ for Idx := Length(Addr) downto 1 do
+ if Addr[Idx] = ' ' then
+ Delete(Addr, Idx, 1); {!!.01}
+
+ {Strip unnecessary 0's }
+ if not chkAsHostName.Checked then
+ Addr := NormalizeIPAddress(Addr);
+ {end !!.01}
+ FFClientConfigWriteProtocolName(cboProtocol.Items[cboProtocol.ItemIndex]);
+ if (Addr = '...') or (Addr = ' - - - - - ') then {!!.02}
+ FFClientConfigWriteServerName('') {!!.02}
+ else {!!.02}
+ if chkAsHostName.Checked then {!!.11}
+ FFClientConfigWriteServerName(efServerName.Text + '@' + Addr) {!!.02}
+ else if FFWSInstalled then {!!.11}
+ if WinsockRoutines.inet_addr(PChar(Addr)) <> INADDR_NONE then {!!.11}
+ FFClientConfigWriteServerName(efServerName.Text + '@' + Addr) {!!.02}
+ else begin {!!.11}
+ ModalResult := mrNone; {!!.11}
+ raise Exception.Create('Invalid IP address in Server Address');{!!.11}
+ end {!!.11}
+ else {!!.11}
+ FFClientConfigWriteServerName(efServerName.Text + '@' + Addr); {!!.11}
+
+ Reg := TRegistry.Create;
+ try
+ if Reg.OpenKey('Software\TurboPower\FlashFiler\2.0\FFComms', True) then
+ Reg.WriteBool('ServerAddressAsText', chkAsHostName.Checked);
+ finally
+ Reg.Free;
+ end;
+
+ Close;
+ { to ensure that we can get the correct exit state
+ when displaying form from FFE }
+ ModalResult := mrOK; {!!.07}
+end;
+
+procedure TfrmFFCommsMain.btnCancelClick(Sender: TObject);
+begin
+ Close;
+end;
+
+procedure TfrmFFCommsMain.SetCtrlStates;
+var
+ IsSingleUserOrNil : boolean;
+begin
+ { Update UI based upon chosen protocol. }
+ { Has user chosen SUP or has not chosen anything at all? }
+ IsSingleUserOrNil :=
+ (cboProtocol.ItemIndex = -1) or
+ (cboProtocol.Items[cboProtocol.ItemIndex] = ffc_SingleUser);
+
+ efServerName.Enabled := (not IsSingleUserOrNil);
+ efServerAddress.Enabled := efServerName.Enabled;
+ chkAsHostName.Enabled := cboProtocol.Items[cboProtocol.ItemIndex] = ffc_TCPIP;
+ lblServerName.Enabled := efServerName.Enabled;
+ lblServerAddress.Enabled := efServerName.Enabled;
+
+ { Set server address edit mask. }
+ if (cboProtocol.Items[cboProtocol.ItemIndex] = ffc_IPXSPX) then {Start !!.01}
+ efServerAddress.EditMask := 'AA-AA-AA-AA-AA-AA;1'
+ else if (cboProtocol.Items[cboProtocol.ItemIndex] = ffc_TCPIP) then
+ if chkAsHostName.Checked then {begin !!.06}
+ efServerAddress.EditMask := ''
+ else
+ efServerAddress.EditMask := '999.999.999.999;1' {end !!.06}
+
+ { We know that the transport is SingleUser, but we still want to
+ display any old server address correctly.}
+ else if (efServerAddress.Text <> '') and
+ not (efServerAddress.Text[1] in ['0'..'9']) then
+ efServerAddress.EditMask := 'AA-AA-AA-AA-AA-AA;1'
+ else
+ if chkAsHostName.Checked then {begin !!.06}
+ efServerAddress.EditMask := ''
+ else
+ efServerAddress.EditMask := '999.999.999.999;1'; {end !!.06}
+end;
+
+procedure TfrmFFCommsMain.cboProtocolChange(Sender: TObject);
+begin
+ SetCtrlStates;
+end;
+
+procedure TfrmFFCommsMain.Button1Click(Sender: TObject);
+begin
+ efServerAddress.Enabled := not efServerAddress.Enabled;
+end;
+
+procedure TfrmFFCommsMain.chkAsHostNameClick(Sender: TObject); {begin !!.06}
+begin
+ efServerAddress.Text := '';
+ if chkAsHostName.Checked then
+ efServerAddress.EditMask := ''
+ else
+ efServerAddress.EditMask := '999.999.999.999;1';
+end; {end !!.06}
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffconst.inc b/components/flashfiler/sourcelaz/ffconst.inc
new file mode 100644
index 000000000..6006d64b5
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffconst.inc
@@ -0,0 +1,429 @@
+{*********************************************************}
+{* FlashFiler: Stringtable constants *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{Note:
+
+ The actual strings are found in the following resource scripts:
+
+ FFSRCNST.STR - server strings
+ Range: $00 - $C4 (0 - 196)
+
+ FFLLCNST.STR - General strings that can be used both client-side &
+ server-side.
+ Range: $100 - $1C3 (256 - 451)
+
+ FFCLCNST.STR - Client strings.
+ Range: $3F0 - $452 (1,008 - 1,106)
+
+ FFDBCNST.STR - BDE-like strings & FF-specific client-side strings.
+ BDE Range: $2101 - $351A (8,449 - 13,549)
+ FF Range: $3C00 - $3CD2 (15,360 - 15,521)
+
+ FFDSCNST.STR - TDataSet descendant error strings.
+ Range: $D500 - $D53A (54,528 - 54,586)
+
+}
+
+const
+
+ { Constants for string resource range boundaries }
+
+ ffSRCNSTLow = $00;
+ ffSRCNSTHigh = $FF;
+
+ ffLLCNSTLow = $100;
+ ffLLCNSTHigh = $1FF;
+
+ ffCLCNSTLow = $3F0;
+ ffCLCNSTHigh = $4FF;
+
+ ffDBCNSTLow = $2101;
+ ffDBCNSTHigh = $3D00;
+
+ ffDSCNSTLow = $D500;
+ ffDSCNSTHigh = $D5FF;
+
+{--- FFSRCNST ---}
+
+ { Basic file I/O }
+ fferrBadStruct = $00;
+ fferrOpenFailed = $01;
+ fferrOpenNoMem = $02;
+ fferrCloseFailed = $03;
+ fferrReadFailed = $04;
+ fferrReadExact = $05;
+ fferrWriteFailed = $06;
+ fferrWriteExact = $07;
+ fferrSeekFailed = $08;
+ fferrFlushFailed = $09;
+ fferrSetEOFFailed = $0A;
+
+ { Low-level FF Server errors }
+ fferrNotAnFFFile = $20;
+ fferrBadBlockNr = $21;
+ fferrEncrypted = $22;
+ fferrRecDeleted = $23;
+ fferrBadRefNr = $24;
+ fferrBadDataBlock = $25;
+
+ fferrBlobDeleted = $30;
+ fferrBadBlobNr = $31;
+ fferrBadBlobBlock = $32;
+ fferrBadBlobSeg = $33;
+ fferrLenMismatch = $34;
+ fferrOfsNotInBlob = $35;
+ fferrFileBlobWrite = $36;
+
+ fferrBadStreamBlock = $40;
+ fferrBadStreamOrigin = $41;
+ fferrStreamSeekError = $42;
+
+ fferrBadInxBlock = $50;
+ fferrBadIndex = $51;
+ fferrMaxIndexes = $52;
+ fferrBadMergeCall = $53;
+ fferrKeyNotFound = $54;
+ fferrKeyPresent = $55;
+ fferrNoKeys = $56;
+ fferrNoSeqAccess = $57;
+ fferrBadApproxPos = $58;
+
+ fferrBadServerName = $70;
+ fferrFFV1File = $71;
+ fferrIncompatDict = $72;
+ fferrBLOBTooBig = $73;
+
+ { Errors to indicate unknown handles, IDs, etc }
+ fferrUnknownClient = $90;
+ fferrUnknownSession = $91;
+ fferrUnknownAlias = $92;
+ fferrUnknownPath = $93;
+ fferrUnknownDB = $94;
+ fferrUnknownTable = $95;
+ fferrUnknownIndex = $96;
+ fferrUnknownCursor = $97;
+ fferrUnknownTrans = $98;
+ fferrUnknownMsg = $99; { Unknown message type received from client }
+
+ { Misc. server errors as a result of client messages }
+ fferrDBExclusive = $A0;
+ fferrDBReadOnly = $A1;
+ fferrTableExclusive = $A2;
+ fferrCursorReadOnly = $A3;
+ fferrWriteLocked = $A4;
+ fferrReadLocked = $A5;
+ fferrCannotUnlock = $A6;
+ fferrTableLocked = $A7;
+ fferrRecLocked = $A8;
+ fferrNoCurrentRec = $A9;
+ fferrDynamicLink = $AA;
+ fferrResolveTableLinks = $AB;
+ fferrTableMismatch = $AC;
+ fferrNoNextRecord = $AD;
+ fferrNoPriorRecord = $AE;
+ fferrTableExists = $AF;
+ fferrDBInTrans = $B0;
+ fferrAliasExists = $B1;
+ fferrCannotCompare = $B2;
+ fferrBadFieldXform = $B3;
+ fferrNoTransaction = $B4;
+ fferrBadBookmark = $B6;
+ fferrTransactionFailed = $B7;
+ fferrTableFull = $B8;
+ fferrInvalidSqlStmtHandle = $B9;
+ fferrDeadlock = $BA;
+ fferrLockTimeout = $BB;
+ fferrLockRejected = $BC;
+ fferrTableLockTimeout = $BD;
+ fferrGeneralTimeout = $BE;
+ fferrNoSQLEngine = $BF;
+ fferrIndexNotSupported = $C0;
+ fferrInvalidTableName = $C1;
+ fferrRangeNotSupported = $C2;
+ fferrTableOpen = $C3;
+ fferrSameTable = $C4;
+ fferrSortFail = $C5;
+ fferrBadDistinctField = $C6;
+ fferrDiskFull = $C7; {!!.11}
+ fferrTableVersion = $C8; {!!.11}
+
+{--- FFLLCNST ---}
+
+ {temporary storage errors}
+ fferrTmpStoreCreateFail = $100;
+ fferrTmpStoreFull = $101;
+ fferrMapFileCreateFail = $102;
+ fferrMapFileHandleFail = $103;
+ fferrMapFileViewFail = $104;
+
+ fferrCopyFile = $110;
+ fferrDeleteFile = $111;
+ fferrRenameFile = $112;
+
+ {low level client errors}
+ fferrReplyTimeout = $120;
+ fferrWaitFailed = $121;
+ fferrInvalidProtocol = $122;
+ fferrProtStartupFail = $123;
+ fferrConnectionLost = $124;
+ fferrTransportFail = $125;
+ fferrPortalTimeout = $126;
+
+ {dictionary errors}
+ fferrOutOfBounds = $140;
+ fferrDictPresent = $141;
+ fferrNotADict = $142;
+ fferrNoFields = $143;
+ fferrBadFieldRef = $144;
+ fferrBadFieldType = $145;
+ fferrRecTooLong = $146;
+ fferrDiffBlockSize = $147;
+ fferrDictReadOnly = $148;
+ fferrDictMissing = $149;
+ fferrBLOBFileDefd = $14A;
+ fferrBaseFile = $14B;
+ fferrBadFileNumber = $14C;
+ fferrBadBaseName = $14D;
+ fferrBadExtension = $14E;
+ fferrDupExtension = $14F;
+ fferrDataFileDefd = $150;
+ fferrNoFieldsInKey = $151;
+ fferrBadParameter = $152;
+ fferrBadBlockSize = $153;
+ fferrKeyTooLong = $154;
+ fferrDupFieldName = $155;
+ fferrDupIndexName = $156;
+ fferrIxHlprRegistered = $157;
+ fferrIxHlprNotReg = $158;
+ fferrIxHlprNotSupp = $159;
+ fferrFileInUse = $160;
+ fferrFieldInUse = $161;
+
+ {General comms errors}
+ fferrCommsNoWinRes = $170;
+ fferrCommsCannotCall = $171;
+ fferrCommsCantListen = $172;
+
+ {Winsock errors}
+ fferrWinsock = $180;
+ fferrWSNoWinsock = $181;
+ fferrWSNoSocket = $182;
+ fferrWSNoLocalAddr = $183;
+
+ {dialog errors}
+ fferrInvalidServerName = $1A0;
+ fferrInvalidNameorPath = $1A1;
+ fferrDuplicateAliasName = $1A2;
+ fferrEmptyValuesNotAllowed = $1A3;
+
+ {miscellaneous constants}
+ ffscSeqAccessIndexName = $1B0;
+ ffscMainTableFileDesc = $1B1;
+ ffscRegistryMainKey = $1B2;
+
+ ffscRebuildPlaceHolder = $1C0;
+ ffscRestructPlaceHolder = $1C1;
+ ffscImportPlaceHolder = $1C2;
+ ffscExportPlaceHolder = $1C3;
+
+{--- FFCLCNST ---}
+
+ {client miscellaneous constants}
+ ffccInvalidParameter = $3F0;
+ ffccREG_PRODUCT = $3F1;
+ ffccDupItemInColl = $3F2;
+
+ { Import constants }
+ ffccImport_NoSchemaFile = $400;
+ ffccImport_RECLENGTHRequired = $401;
+ ffccImport_NoMatchingFields = $402;
+ ffccImport_FILETYPEMissing = $403;
+ ffccImport_FILETYPEInvalid = $404;
+ ffccImport_BadFieldName = $405;
+ ffccImport_BadFieldType = $406;
+ ffccImport_BadFloatSize = $407;
+ ffccImport_BadIntegerSize = $408;
+ ffccImport_BadUIntegerSize = $409;
+ ffccImport_NoFields = $40A;
+ ffccImport_BadOffset = $40B;
+ ffccImport_BadSize = $40C;
+ ffccImport_BadDecPl = $40D;
+ ffccImport_BadDateMask = $40E;
+ ffccImport_BadAutoIncSize = $40F;
+ ffccImport_BadSchemaHeader = $410;
+
+ ffccDesign_SLinkMasterSource = $450;
+ ffccDesign_SLinkMaster = $451;
+ ffccDesign_SLinkDesigner = $452;
+
+{--- FFDBCNST ---}
+
+ {pseudo-BDE errors for server exceptions}
+ ERRCAT_FLASHFILER = $3C;
+ ERRBASE_FLASHFILER = $3C00;
+
+ ERRCODE_FF_BadStruct = 0;
+ ERRCODE_FF_OpenFailed = 1;
+ ERRCODE_FF_OpenNoMem = 2;
+ ERRCODE_FF_CloseFailed = 3;
+ { Use me please = 4;
+ Use me please = 5;
+ }
+ ERRCODE_FF_ReadFailed = 6;
+ ERRCODE_FF_ReadExact = 7;
+ ERRCODE_FF_WriteFailed = 8;
+ ERRCODE_FF_WriteExact = 9;
+ ERRCODE_FF_SeekFailed = $0A;
+ ERRCODE_FF_FlushFailed = $0B;
+ ERRCODE_FF_SetEOFFailed = $0C;
+ ERRCODE_FF_TempStorageFull = $13;
+ ERRCODE_FF_CopyFile = $20;
+ ERRCODE_FF_DeleteFile = $21;
+ ERRCODE_FF_RenameFile = $22;
+ ERRCODE_FF_BadBlockNr = $31;
+ ERRCODE_FF_RecDeleted = $33;
+ ERRCODE_FF_BadRefNr = $34;
+ ERRCODE_FF_BadDataBlock = $35;
+ ERRCODE_FF_BadStreamBlock = $3D;
+ ERRCODE_FF_BadStreamOrigin = $3E;
+ ERRCODE_FF_StreamSeekError = $3F;
+ ERRCODE_FF_BadInxBlock = $40;
+ ERRCODE_FF_BadIndex = $41;
+ ERRCODE_FF_MaxIndexes = $42;
+ ERRCODE_FF_BadMergeCall = $43;
+ ERRCODE_FF_KeyNotFound = $44;
+ ERRCODE_FF_KeyPresent = $45;
+ ERRCODE_FF_NoKeys = $46;
+ ERRCODE_FF_NoSeqAccess = $47;
+ ERRCODE_FF_BadApproxPos = $48;
+ ERRCODE_FF_BadServerName = $49;
+ ERRCODE_FF_FileBLOBOpen = $50;
+ ERRCODE_FF_FileBLOBRead = $51;
+ ERRCODE_FF_FileBLOBClose = $52;
+ ERRCODE_FF_CorruptTrans = $53;
+ ERRCODE_FF_FilterTimeout = $54;
+ ERRCODE_FF_ReplyTimeout = $55;
+ ERRCODE_FF_WaitFailed = $56;
+ ERRCODE_FF_ClientIDFail = $57;
+ ERRCODE_FF_NoAddHandler = $58;
+ ERRCODE_FF_NoRemHandler = $59;
+ ERRCODE_FF_Deadlock = $60;
+ ERRCODE_FF_Timeout = $61;
+ ERRCODE_FF_LockRejected = $62;
+ ERRCODE_FF_ServerUnavail = $63;
+ ERRCODE_FF_V1File = $64;
+ ERRCODE_FF_GeneralTimeout = $65;
+ ERRCODE_FF_NoSQLEngine = $66;
+ ERRCODE_FF_TableVersion = $67; {!!.11}
+ ERRCODE_FF_IxHlprRegistered= $77;
+ ERRCODE_FF_IxHlprNotReg = $78;
+ ERRCODE_FF_IxHlprNotSupp = $79;
+ ERRCODE_FF_IncompatDict = $80; {!!.06}
+ ERRCODE_FF_SameTable = $81; {!!.06}
+ ERRCODE_FF_UnknownClient = $90;
+ ERRCODE_FF_UnknownSession = $91;
+ ERRCODE_FF_UnknownDB = $94;
+ ERRCODE_FF_UnknownCursor = $97;
+ ERRCODE_FF_Unknown = $A0;
+ ERRCODE_FF_UnknownExcp = $A1;
+ ERRCODE_FF_UnknownMsg = $A2;
+ ERRCODE_FF_RangeNotSupported = $D2;
+
+ DBIERR_FF_BadStruct = $3C00; {ERRBASE_FLASHFILER + ERRCODE_FF_BadStruct;}
+ DBIERR_FF_OpenFailed = $3C01; {ERRBASE_FLASHFILER + ERRCODE_FF_OpenFailed;}
+ DBIERR_FF_OpenNoMem = $3C02; {ERRBASE_FLASHFILER + ERRCODE_FF_OpenNoMem;}
+ DBIERR_FF_CloseFailed = $3C03; {ERRBASE_FLASHFILER + ERRCODE_FF_CloseFailed;}
+ DBIERR_FF_ReadFailed = $3C06; {ERRBASE_FLASHFILER + ERRCODE_FF_ReadFailed;}
+ DBIERR_FF_ReadExact = $3C07; {ERRBASE_FLASHFILER + ERRCODE_FF_ReadExact;}
+ DBIERR_FF_WriteFailed = $3C08; {ERRBASE_FLASHFILER + ERRCODE_FF_WriteFailed;}
+ DBIERR_FF_WriteExact = $3C09; {ERRBASE_FLASHFILER + ERRCODE_FF_WriteExact;}
+ DBIERR_FF_SeekFailed = $3C0A; {ERRBASE_FLASHFILER + ERRCODE_FF_SeekFailed;}
+ DBIERR_FF_FlushFailed = $3C0B; {ERRBASE_FLASHFILER + ERRCODE_FF_FlushFailed;}
+ DBIERR_FF_SetEOFFailed = $3C0C; {ERRBASE_FLASHFILER + ERRCODE_FF_SetEOFFailed;}
+ DBIERR_FF_TempStorageFull = $3C13; {ERRBASE_FLASHFILER + ERRCODE_FF_TempStorageFull;}
+ DBIERR_FF_CopyFile = $3C20; {ERRBASE_FLASHFILER + ERRCODE_FF_CopyFile;}
+ DBIERR_FF_DeleteFile = $3C21; {ERRBASE_FLASHFILER + ERRCODE_FF_DeleteFile;}
+ DBIERR_FF_RenameFile = $3C22; {ERRBASE_FLASHFILER + ERRCODE_FF_RenameFile;}
+ DBIERR_FF_BadBlockNr = $3C31; {ERRBASE_FLASHFILER + ERRCODE_FF_BadBlockNr;}
+ DBIERR_FF_RecDeleted = $3C33; {ERRBASE_FLASHFILER + ERRCODE_FF_RecDeleted;}
+ DBIERR_FF_BadRefNr = $3C34; {ERRBASE_FLASHFILER + ERRCODE_FF_BadRefNr;}
+ DBIERR_FF_BadDataBlock = $3C35; {ERRBASE_FLASHFILER + ERRCODE_FF_BadDataBlock;}
+ DBIERR_FF_BadStreamBlock = $3C3D; {ERRBASE_FLASHFILER + ERRCODE_FF_BadStreamBlock;}
+ DBIERR_FF_BadStreamOrigin = $3C3E; {ERRBASE_FLASHFILER + ERRCODE_FF_BadStreamOrigin;}
+ DBIERR_FF_StreamSeekError = $3C3F; {ERRBASE_FLASHFILER + ERRCODE_FF_StreamSeekError;}
+ DBIERR_FF_BadInxBlock = $3C40; {ERRBASE_FLASHFILER + ERRCODE_FF_BadInxBlock;}
+ DBIERR_FF_BadIndex = $3C41; {ERRBASE_FLASHFILER + ERRCODE_FF_BadIndex;}
+ DBIERR_FF_MaxIndexes = $3C42; {ERRBASE_FLASHFILER + ERRCODE_FF_MaxIndexes;}
+ DBIERR_FF_BadMergeCall = $3C43; {ERRBASE_FLASHFILER + ERRCODE_FF_BadMergeCall;}
+ DBIERR_FF_KeyNotFound = $3C44; {ERRBASE_FLASHFILER + ERRCODE_FF_KeyNotFound;}
+ DBIERR_FF_KeyPresent = $3C45; {ERRBASE_FLASHFILER + ERRCODE_FF_KeyPresent;}
+ DBIERR_FF_NoKeys = $3C46; {ERRBASE_FLASHFILER + ERRCODE_FF_NoKeys;}
+ DBIERR_FF_NoSeqAccess = $3C47; {ERRBASE_FLASHFILER + ERRCODE_FF_NoSeqAccess;}
+ DBIERR_FF_BadApproxPos = $3C48; {ERRBASE_FLASHFILER + ERRCODE_FF_BadApproxPos;}
+ DBIERR_FF_BadServerName = $3C49; {ERRBASE_FLASHFILER + ERRCODE_FF_BadServerName;}
+ DBIERR_FF_FileBLOBOpen = $3C50; {ERRBASE_FLASHFILER + ERRCODE_FF_FileBLOBOpen;}
+ DBIERR_FF_FileBLOBRead = $3C51; {ERRBASE_FLASHFILER + ERRCODE_FF_FileBLOBRead;}
+ DBIERR_FF_FileBLOBClose = $3C52; {ERRBASE_FLASHFILER + ERRCODE_FF_FileBLOBClose;}
+ DBIERR_FF_CorruptTrans = $3C53; {ERRBASE_FLASHFILER + ERRCODE_FF_CorrupTrans;}
+
+ DBIERR_FF_FilterTimeout = $3C54; {ERRBASE_FLASHFILER + ERRCODE_FF_FilterTimeout;}
+ DBIERR_FF_ReplyTimeout = $3C55; {ERRBASE_FLASHFILER + ERRCODE_FF_ReplyTimeout;}
+ DBIERR_FF_WaitFailed = $3C56; {ERRBASE_FLASHFILER + ERRCODE_FF_WaitFailed;}
+ DBIERR_FF_ClientIDFail = $3C57; {ERRBASE_FLASHFILER + ERRCODE_FF_ClientIDFail;}
+ DBIERR_FF_NoAddHandler = $3C58; {ERRBASE_FLASHFILER + ERRCODE_FF_NoAddHandler;}
+ DBIERR_FF_NoRemHandler = $3C59; {ERRBASE_FLASHFILER + ERRCODE_FF_NoRemHandler;}
+
+ DBIERR_FF_Deadlock = $3C60; {ERRBASE_FLASHFILER + ERRCODE_FF_Deadlock;}
+ DBIERR_FF_Timeout = $3C61; {ERRBASE_FLASHFILER + ERRCODE_FF_Timeout;}
+ DBIERR_FF_LockRejected = $3C62; {ERRBASE_FLASHFILER + ERRCODE_FF_LockRejected;}
+
+ DBIERR_FF_ServerUnavail = $3C63; {ERRBASE_FLASHFILER + ERRCODE_FF_ServerUnavail;}
+ DBIERR_FF_V1File = $3C64; {ERRBASE_FLASHFILER + ERRCODE_FF_V1Table;}
+ DBIERR_FF_GeneralTimeout = $3C65; {ERRBASE_FLASHFILER + ERRCODE_FF_GeneralTimeout;}
+ DBIERR_FF_NoSQLEngine = $3C66; {ERRBASE_FLASHFILER + ERRCODE_FF_NoSQLEngine;}
+ DBIERR_FF_TableVersion = $3C67; {ERRBASE_FLASHFILER + ERRCODE_FF_TableVersion;} {!!.11}
+
+ DBIERR_FF_IxHlprRegistered= $3C77; {ERRBASE_FLASHFILER + ERRCODE_FF_IxHlprRegistered;}
+ DBIERR_FF_IxHlprNotReg = $3C78; {ERRBASE_FLASHFILER + ERRCODE_FF_IxHlprNotReg;}
+ DBIERR_FF_IxHlprNotSupp = $3C79; {ERRBASE_FLASHFILER + ERRCODE_FF_IxHlprNotSupp;}
+ DBIERR_FF_IncompatDict = $3C80; {ERRBASE_FLASHFILER + ERRCODE_FF_IncompatDict;} {!!.06}
+ DBIERR_FF_SameTable = $3C81; {ERRBASE_FLASHFILER + ERRCODE_FF_SameTable;} {!!.06}
+
+ DBIERR_FF_UnknownClient = $3C90; {ERRBASE_FLASHFILER + ERRCODE_FF_UnknownClient;}
+ DBIERR_FF_UnknownSession = $3C91; {ERRBASE_FLASHFILER + ERRCODE_FF_UnknownSession;}
+ DBIERR_FF_UnknownDB = $3C94; {ERRBASE_FLASHFILER + ERRCODE_FF_UnknownDB;}
+ DBIERR_FF_UnknownCursor = $3C97; {ERRBASE_FLASHFILER + ERRCODE_FF_UnknownCursor;}
+ DBIERR_FF_BLOBTooBig = $3C9A; {ERRBASE_FLASHFILER + BLOB Size Exceeds Max}
+
+ DBIERR_FF_Unknown = $3CA0; {ERRBASE_FLASHFILER + ERRCODE_FF_Unknown;}
+ DBIERR_FF_UnknownExcp = $3CA1; {ERRBASE_FLASHFILER + ERRCODE_FF_UnknownExcp;}
+ DBIERR_FF_UnknownMsg = $3CA2; {ERRBASE_FLASHFILER + ERRCODE_FF_UnknownMsg;}
+
+ DBIERR_FF_RangeNotSupported = $3CD2; {ERRBASE_FLASHFILER + ERRCODE_FF_RangeNotSupported;}
+
diff --git a/components/flashfiler/sourcelaz/ffconst.pas b/components/flashfiler/sourcelaz/ffconst.pas
new file mode 100644
index 000000000..582cd71c5
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffconst.pas
@@ -0,0 +1,40 @@
+{*********************************************************}
+{* FlashFiler: Stringtable constants *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffconst;
+
+interface
+
+{$I ffconst.inc}
+
+implementation
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffconvff.pas b/components/flashfiler/sourcelaz/ffconvff.pas
new file mode 100644
index 000000000..1bcd6b6ca
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffconvff.pas
@@ -0,0 +1,959 @@
+{*********************************************************}
+{* FlashFiler: Field conversion for server *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffconvff;
+
+interface
+
+uses
+ ffllbase,
+ fflldict,
+ ffsrbde,
+ ffstdate,
+ SysUtils;
+
+function FFConvertSingleField(aSourceValue,
+ aTargetValue: Pointer;
+ aSourceType,
+ aTargetType: TffFieldType;
+ aSourceLength,
+ aTargetLength: Integer): TffResult;
+
+{ This is the low-level data conversion routine for converting one FlashFiler
+ datatype to another. This is primarily used by the table restructure
+ operation. This routine accepts an input and output field specification
+ and determines if the input field can be converted to the output field.
+ If so, it copies and translates the input field data into the output
+ field.
+
+ This routine serves two purposes for table restructuring:
+
+ 1) when the records are read, it does the data conversion between
+ the input fields and the output fields;
+
+ 2) when the field map is initially validated (before the data is read/
+ written), it is used to determine if each field map entry is legal
+ (without actually moving any data around).
+
+ By serving double-duty like this, we centralize this fairly detailed
+ logic and reduce the likelihood of mistakes in updating it. Specifically,
+ when used for situation #2, nil is passed in for the field pointers and
+ the logic checks for this in the case statement. This lets the
+ logic flow through the case statement to find the correct datatype
+ matches, but stops short of actually copying any data.
+
+ Note on BLOB Conversions: BLOB-to-BLOB and ByteArray-to-BLOB conversions
+ are legal and this routine validates that fact (when called with nil value
+ pointers), but does not actually copy to/from BLOB fields. The caller
+ is responsible for detecting a BLOB target field and handling the data
+ conversion. All this routine does it tell you that such a conversion is
+ legal.
+
+ Note on null field values: This routine assumes it will not see a null
+ input value (that is, it assumes null input values are captured by the
+ caller and handled at that level). After all, if the input value is null,
+ the output value will always be null regardless of the datatypes involved.
+
+ It is intended that this routine could be compiled into both a server app
+ and a client app. Specifically, this routine is used by FF Explorer to
+ perform real time validation of table restructure field assignments
+ without waiting for the whole restructure package to be sent to the
+ server and subsequently fail if the user selected incompatible datatypes.
+
+
+ Parameters:
+
+ aSourceValue and aTargetValue point to the input and output field values
+ (that is, the start position within the record buffers where these values
+ can be found). If both are nil, then only an assignment compatabiliy
+ check is performed, no data is actually moved.
+
+ aSourceType and aTargetType indicate the FlashFiler datatype of the
+ fields.
+
+ aSourceLength and aTargetLength are the maximum lengths, in bytes, of
+ each data field (ignored if only doing assignment compatability check).
+}
+
+implementation
+
+uses
+ typinfo,
+ ffconst,
+ ffllexcp;
+
+function FFRemoveThousandSeparator(const str : string): string;
+begin
+ Result := str;
+ while pos(ThousandSeparator, Result)>0 do
+ Delete(Result, pos(ThousandSeparator, Result), 1);
+end;
+
+function FFConvertSingleField(aSourceValue,
+ aTargetValue: Pointer;
+ aSourceType,
+ aTargetType: TffFieldType;
+ aSourceLength,
+ aTargetLength: Integer): TffResult;
+var
+ MinLength: Integer;
+ srcBoolean: ^Boolean absolute aSourceValue;
+ WorkString: String[11]; {!!.10}
+ { workspacelength equals Length(IntToStr(Low(Integer))),
+ used for converting various int-types to string }
+ {Begin !!.13}
+ aCode,
+ intRes: Integer;
+ wordRes: TffWord32;
+ {End !!.13}
+begin
+ Result := DBIERR_NONE;
+
+ MinLength := FFMinI(aSourceLength, aTargetLength);
+
+ case aSourceType of
+ fftBoolean: begin
+ { Booleans can be translated into char or string fields (Y or N), or
+ integer numeric fields (ordinal value, 0 - false, 1 - true) }
+
+ case aTargetType of
+ fftBoolean:
+ if Assigned(aTargetValue) then
+ Boolean(aTargetValue^) := srcBoolean^;
+ fftChar:
+ if Assigned(aTargetValue) then
+ if srcBoolean^ then Char(aTargetValue^) := 'Y'
+ else Char(aTargetValue^) := 'N';
+ fftByte, fftInt8:
+ if Assigned(aTargetValue) then
+ Byte(aTargetValue^) := Ord(srcBoolean^);
+ fftWord16, fftInt16:
+ if Assigned(aTargetValue) then
+ Word(aTargetValue^) := Ord(srcBoolean^);
+ fftWord32, fftInt32:
+ if Assigned(aTargetValue) then
+ LongInt(aTargetValue^) := Ord(srcBoolean^);
+ fftShortString, fftShortAnsiStr:
+ if Assigned(aTargetValue) then
+ if srcBoolean^ then TffShStr(aTargetValue^) := 'Y'
+ else TffShStr(aTargetValue^) := 'N';
+ fftNullString, fftNullAnsiStr:
+ if Assigned(aTargetValue) then
+ if srcBoolean^ then FFStrPCopy(aTargetValue, 'Y')
+ else FFStrPCopy(aTargetValue, 'N');
+ fftWideChar:
+ if Assigned(aTargetValue) then
+ if srcBoolean^ then WideChar(aTargetValue^) := FFCharToWideChar('Y')
+ else WideChar(aTargetValue^) := FFCharToWideChar('N');
+ fftWideString:
+ if Assigned(aTargetValue) then
+ if srcBoolean^ then FFShStrLToWideStr('Y', aTargetValue, 1)
+ else FFShStrLToWideStr('N', aTargetValue, 1);
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ fftChar: begin
+ case aTargetType of
+ fftChar:
+ if Assigned(aTargetValue) then
+ Char(aTargetValue^) := Char(aSourceValue^);
+ fftShortString, fftShortAnsiStr:
+ if Assigned(aTargetValue) then
+ TffShStr(aTargetValue^) := Char(aSourceValue^);
+ fftNullString, fftNullAnsiStr:
+ if Assigned(aTargetValue) then
+ FFStrPCopy(aTargetValue, Char(aSourceValue^));
+ fftWideChar:
+ if Assigned(aTargetValue) then
+ WideChar(aTargetValue^) := FFCharToWideChar(Char(aSourceValue^));
+ fftWideString:
+ if Assigned(aTargetValue) then
+ FFShStrLToWideStr(Char(aSourceValue^), aTargetValue, 1);
+ fftBLOB..ffcLastBLOBType: ;
+ { Validate only; do not actually move BLOB data around. }
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ fftWideChar: begin
+ case aTargetType of
+ fftChar:
+ if Assigned(aTargetValue) then
+ Char(aTargetValue^) := FFWideCharToChar(WideChar(aSourceValue^));
+ fftShortString, fftShortAnsiStr:
+ if Assigned(aTargetValue) then
+ TffShStr(aTargetValue^) := FFWideCharToChar(WideChar(aSourceValue^));
+ fftNullString, fftNullAnsiStr:
+ if Assigned(aTargetValue) then
+ FFStrPCopy(aTargetValue, FFWideCharToChar(WideChar(aSourceValue^)));
+ fftWideChar:
+ if Assigned(aTargetValue) then
+ WideChar(aTargetValue^) := WideChar(aSourceValue^);
+ fftWideString:
+ if Assigned(aTargetValue) then begin
+ PWideChar(aTargetValue)^ := WideChar(aSourceValue^);
+ PWideChar(LongInt(aTargetValue) + SizeOf(WideChar))^ := WideChar(#0);
+ end;
+ fftBLOB..ffcLastBLOBType: ;
+ { Validate only; do not actually move BLOB data around. }
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ fftByte: begin
+ case aTargetType of
+ fftByte:
+ if Assigned(aTargetValue) then
+ Byte(aTargetValue^) := Byte(aSourceValue^);
+ fftWord16, fftInt16:
+ if Assigned(aTargetValue) then
+ TffWord16(aTargetValue^) := Byte(aSourceValue^);
+ fftWord32, fftInt32, fftAutoInc:
+ if Assigned(aTargetValue) then
+ TffWord32(aTargetValue^) := Byte(aSourceValue^);
+ fftSingle:
+ if Assigned(aTargetValue) then
+ Single(aTargetValue^) := Byte(aSourceValue^);
+ fftDouble:
+ if Assigned(aTargetValue) then
+ Double(aTargetValue^) := Byte(aSourceValue^);
+ fftExtended:
+ if Assigned(aTargetValue) then
+ Extended(aTargetValue^) := Byte(aSourceValue^);
+ fftComp:
+ if Assigned(aTargetValue) then
+ Comp(aTargetValue^) := Byte(aSourceValue^);
+ fftCurrency:
+ if Assigned(aTargetValue) then begin
+ Comp(aTargetValue^) := Byte(aSourceValue^);
+ Comp(aTargetValue^) := Comp(aTargetValue^) * 10000.0;
+ end;
+ {Begin !!.10}
+ fftShortString, fftShortAnsiStr:
+ if Assigned(aTargetValue) then begin
+ WorkString := IntToStr(Byte(aSourceValue^));
+ if Length(WorkString)>aTargetLength-1 then
+ Result := DBIERR_INVALIDFLDXFORM
+ else
+ TffShStr(aTargetValue^) := WorkString;
+ end;
+ fftNullString, fftNullAnsiStr:
+ if Assigned(aTargetValue) then begin
+ WorkString := IntToStr(Byte(aSourceValue^));
+ if Length(WorkString)>aTargetLength-1 then
+ Result := DBIERR_INVALIDFLDXFORM
+ else
+ FFStrPCopy(aTargetValue, WorkString);
+ end;
+ fftWideString:
+ if Assigned(aTargetValue) then begin
+ { Note: the length of a "wide" field is the number of bytes
+ it occupies, not the number of wide chars it will hold. }
+ WorkString := IntToStr(Byte(aSourceValue^));
+ if Length(WorkString)>(aTargetLength div SizeOf(WideChar))-1 then
+ Result := DBIERR_INVALIDFLDXFORM
+ else
+ FFShStrLToWideStr(WorkString, aTargetValue, Length(WorkString));
+ end;
+ {End !!.10}
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ fftWord16: begin
+ case aTargetType of
+ fftWord16:
+ if Assigned(aTargetValue) then
+ TffWord16(aTargetValue^) := TffWord16(aSourceValue^);
+ fftWord32, fftInt32, fftAutoInc:
+ if Assigned(aTargetValue) then
+ TffWord32(aTargetValue^) := TffWord16(aSourceValue^);
+ fftSingle:
+ if Assigned(aTargetValue) then
+ Single(aTargetValue^) := TffWord16(aSourceValue^);
+ fftDouble:
+ if Assigned(aTargetValue) then
+ Double(aTargetValue^) := TffWord16(aSourceValue^);
+ fftExtended:
+ if Assigned(aTargetValue) then
+ Extended(aTargetValue^) := TffWord16(aSourceValue^);
+ fftComp:
+ if Assigned(aTargetValue) then
+ Comp(aTargetValue^) := TffWord16(aSourceValue^);
+ fftCurrency:
+ if Assigned(aTargetValue) then begin
+ Comp(aTargetValue^) := TffWord16(aSourceValue^);
+ Comp(aTargetValue^) := Comp(aTargetValue^) * 10000.0;
+ end;
+ {Begin !!.10}
+ fftShortString, fftShortAnsiStr:
+ if Assigned(aTargetValue) then begin
+ WorkString := IntToStr(TffWord16(aSourceValue^));
+ if Length(WorkString)>aTargetLength-1 then
+ Result := DBIERR_INVALIDFLDXFORM
+ else
+ TffShStr(aTargetValue^) := WorkString;
+ end;
+ fftNullString, fftNullAnsiStr:
+ if Assigned(aTargetValue) then begin
+ WorkString := IntToStr(TffWord16(aSourceValue^));
+ if Length(WorkString)>aTargetLength-1 then
+ Result := DBIERR_INVALIDFLDXFORM
+ else
+ FFStrPCopy(aTargetValue, WorkString);
+ end;
+ fftWideString:
+ if Assigned(aTargetValue) then begin
+ { Note: the length of a "wide" field is the number of bytes
+ it occupies, not the number of wide chars it will hold. }
+ WorkString := IntToStr(TffWord16(aSourceValue^));
+ if Length(WorkString)>(aTargetLength div SizeOf(WideChar))-1 then
+ Result := DBIERR_INVALIDFLDXFORM
+ else
+ FFShStrLToWideStr(WorkString, aTargetValue, Length(WorkString));
+ end;
+ {End !!.10}
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ fftWord32,
+ fftAutoInc: begin
+ case aTargetType of
+ fftWord32,
+ fftAutoInc:
+ if Assigned(aTargetValue) then
+ TffWord32(aTargetValue^) := TffWord32(aSourceValue^);
+ fftSingle:
+ if Assigned(aTargetValue) then
+ Single(aTargetValue^) := TffWord32(aSourceValue^);
+ fftDouble:
+ if Assigned(aTargetValue) then
+ Double(aTargetValue^) := TffWord32(aSourceValue^);
+ fftExtended:
+ if Assigned(aTargetValue) then
+ Extended(aTargetValue^) := TffWord32(aSourceValue^);
+ fftComp:
+ if Assigned(aTargetValue) then
+ Comp(aTargetValue^) := TffWord32(aSourceValue^);
+ fftCurrency:
+ if Assigned(aTargetValue) then begin
+ Comp(aTargetValue^) := TffWord32(aSourceValue^);
+ Comp(aTargetValue^) := Comp(aTargetValue^) * 10000.0;
+ end;
+ {Begin !!.10}
+ fftShortString, fftShortAnsiStr:
+ if Assigned(aTargetValue) then begin
+ WorkString := IntToStr(TffWord32(aSourceValue^));
+ if Length(WorkString)>aTargetLength-1 then
+ Result := DBIERR_INVALIDFLDXFORM
+ else
+ TffShStr(aTargetValue^) := WorkString;
+ end;
+ fftNullString, fftNullAnsiStr:
+ if Assigned(aTargetValue) then begin
+ WorkString := IntToStr(TffWord32(aSourceValue^));
+ if Length(WorkString)>aTargetLength-1 then
+ Result := DBIERR_INVALIDFLDXFORM
+ else
+ FFStrPCopy(aTargetValue, WorkString);
+ end;
+ fftWideString:
+ if Assigned(aTargetValue) then begin
+ { Note: the length of a "wide" field is the number of bytes
+ it occupies, not the number of wide chars it will hold. }
+ WorkString := IntToStr(TffWord32(aSourceValue^));
+ if Length(WorkString)>(aTargetLength div SizeOf(WideChar))-1 then
+ Result := DBIERR_INVALIDFLDXFORM
+ else
+ FFShStrLToWideStr(WorkString, aTargetValue, Length(WorkString));
+ end;
+ {End !!.10}
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ fftInt8: begin
+ case aTargetType of
+ fftInt8:
+ if Assigned(aTargetValue) then
+ ShortInt(aTargetValue^) := ShortInt(aSourceValue^);
+ fftInt16:
+ if Assigned(aTargetValue) then
+ SmallInt(aTargetValue^) := ShortInt(aSourceValue^);
+ fftInt32:
+ if Assigned(aTargetValue) then
+ LongInt(aTargetValue^) := ShortInt(aSourceValue^);
+ {Begin !!.10}
+ fftWord32, fftAutoInc:
+ if Assigned(aTargetValue) then begin
+ if ShortInt(aSourceValue^)<0 then
+ Result := DBIERR_INVALIDFLDXFORM
+ else
+ TffWord32(aTargetValue^) := ShortInt(aSourceValue^);
+ end;
+ {End !!.10}
+ fftSingle:
+ if Assigned(aTargetValue) then
+ Single(aTargetValue^) := ShortInt(aSourceValue^);
+ fftDouble:
+ if Assigned(aTargetValue) then
+ Double(aTargetValue^) := ShortInt(aSourceValue^);
+ fftExtended:
+ if Assigned(aTargetValue) then
+ Extended(aTargetValue^) := ShortInt(aSourceValue^);
+ fftComp:
+ if Assigned(aTargetValue) then
+ Comp(aTargetValue^) := ShortInt(aSourceValue^);
+ fftCurrency:
+ if Assigned(aTargetValue) then begin
+ Comp(aTargetValue^) := ShortInt(aSourceValue^);
+ Comp(aTargetValue^) := Comp(aTargetValue^) * 10000.0;
+ end;
+ {Begin !!.10}
+ fftShortString, fftShortAnsiStr:
+ if Assigned(aTargetValue) then begin
+ WorkString := IntToStr(ShortInt(aSourceValue^));
+ if Length(WorkString)>aTargetLength-1 then
+ Result := DBIERR_INVALIDFLDXFORM
+ else
+ TffShStr(aTargetValue^) := WorkString;
+ end;
+ fftNullString, fftNullAnsiStr:
+ if Assigned(aTargetValue) then begin
+ WorkString := IntToStr(ShortInt(aSourceValue^));
+ if Length(WorkString)>aTargetLength-1 then
+ Result := DBIERR_INVALIDFLDXFORM
+ else
+ FFStrPCopy(aTargetValue, WorkString);
+ end;
+ fftWideString:
+ if Assigned(aTargetValue) then begin
+ { Note: the length of a "wide" field is the number of bytes
+ it occupies, not the number of wide chars it will hold. }
+ WorkString := IntToStr(ShortInt(aSourceValue^));
+ if Length(WorkString)>(aTargetLength div SizeOf(WideChar))-1 then
+ Result := DBIERR_INVALIDFLDXFORM
+ else
+ FFShStrLToWideStr(WorkString, aTargetValue, Length(WorkString));
+ end;
+ {End !!.10}
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ fftInt16: begin
+ case aTargetType of
+ fftInt16:
+ if Assigned(aTargetValue) then
+ SmallInt(aTargetValue^) := SmallInt(aSourceValue^);
+ fftInt32:
+ if Assigned(aTargetValue) then
+ LongInt(aTargetValue^) := SmallInt(aSourceValue^);
+ {Begin !!.10}
+ fftWord32, fftAutoInc:
+ if Assigned(aTargetValue) then begin
+ if SmallInt(aSourceValue^)<0 then
+ Result := DBIERR_INVALIDFLDXFORM
+ else
+ TffWord32(aTargetValue^) := SmallInt(aSourceValue^);
+ end;
+ {End !!.10}
+ fftSingle:
+ if Assigned(aTargetValue) then
+ Single(aTargetValue^) := SmallInt(aSourceValue^);
+ fftDouble:
+ if Assigned(aTargetValue) then
+ Double(aTargetValue^) := SmallInt(aSourceValue^);
+ fftExtended:
+ if Assigned(aTargetValue) then
+ Extended(aTargetValue^) := SmallInt(aSourceValue^);
+ fftComp:
+ if Assigned(aTargetValue) then
+ Comp(aTargetValue^) := SmallInt(aSourceValue^);
+ fftCurrency:
+ if Assigned(aTargetValue) then begin
+ Comp(aTargetValue^) := SmallInt(aSourceValue^);
+ Comp(aTargetValue^) := Comp(aTargetValue^) * 10000.0;
+ end;
+ {Begin !!.10}
+ fftShortString, fftShortAnsiStr:
+ if Assigned(aTargetValue) then begin
+ WorkString := IntToStr(SmallInt(aSourceValue^));
+ if Length(WorkString)>aTargetLength-1 then
+ Result := DBIERR_INVALIDFLDXFORM
+ else
+ TffShStr(aTargetValue^) := WorkString;
+ end;
+ fftNullString, fftNullAnsiStr:
+ if Assigned(aTargetValue) then begin
+ WorkString := IntToStr(SmallInt(aSourceValue^));
+ if Length(WorkString)>aTargetLength-1 then
+ Result := DBIERR_INVALIDFLDXFORM
+ else
+ FFStrPCopy(aTargetValue, WorkString);
+ end;
+ fftWideString:
+ if Assigned(aTargetValue) then begin
+ { Note: the length of a "wide" field is the number of bytes
+ it occupies, not the number of wide chars it will hold. }
+ WorkString := IntToStr(SmallInt(aSourceValue^));
+ if Length(WorkString)>(aTargetLength div SizeOf(WideChar))-1 then
+ Result := DBIERR_INVALIDFLDXFORM
+ else
+ FFShStrLToWideStr(WorkString, aTargetValue, Length(WorkString));
+ end;
+ {End !!.10}
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ fftInt32: begin
+ case aTargetType of
+ fftInt32:
+ if Assigned(aTargetValue) then
+ LongInt(aTargetValue^) := LongInt(aSourceValue^);
+ {Begin !!.10}
+ fftWord32, fftAutoInc:
+ if Assigned(aTargetValue) then begin
+ if LongInt(aSourceValue^)<0 then
+ Result := DBIERR_INVALIDFLDXFORM
+ else
+ TffWord32(aTargetValue^) := LongInt(aSourceValue^);
+ end;
+ {End !!.10}
+ fftSingle:
+ if Assigned(aTargetValue) then
+ Single(aTargetValue^) := LongInt(aSourceValue^);
+ fftDouble:
+ if Assigned(aTargetValue) then
+ Double(aTargetValue^) := LongInt(aSourceValue^);
+ fftExtended:
+ if Assigned(aTargetValue) then
+ Extended(aTargetValue^) := LongInt(aSourceValue^);
+ fftComp:
+ if Assigned(aTargetValue) then
+ Comp(aTargetValue^) := LongInt(aSourceValue^);
+ fftCurrency:
+ if Assigned(aTargetValue) then begin
+ Comp(aTargetValue^) := LongInt(aSourceValue^);
+ Comp(aTargetValue^) := Comp(aTargetValue^) * 10000.0;
+ end;
+ {Begin !!.10}
+ fftShortString, fftShortAnsiStr:
+ if Assigned(aTargetValue) then begin
+ WorkString := IntToStr(LongInt(aSourceValue^));
+ if Length(WorkString)>aTargetLength-1 then
+ Result := DBIERR_INVALIDFLDXFORM
+ else
+ TffShStr(aTargetValue^) := WorkString;
+ end;
+ fftNullString, fftNullAnsiStr:
+ if Assigned(aTargetValue) then begin
+ WorkString := IntToStr(LongInt(aSourceValue^));
+ if Length(WorkString)>aTargetLength-1 then
+ Result := DBIERR_INVALIDFLDXFORM
+ else
+ FFStrPCopy(aTargetValue, WorkString);
+ end;
+ fftWideString:
+ if Assigned(aTargetValue) then begin
+ { Note: the length of a "wide" field is the number of bytes
+ it occupies, not the number of wide chars it will hold. }
+ WorkString := IntToStr(LongInt(aSourceValue^));
+ if Length(WorkString)>(aTargetLength div SizeOf(WideChar))-1 then
+ Result := DBIERR_INVALIDFLDXFORM
+ else
+ FFShStrLToWideStr(WorkString, aTargetValue, Length(WorkString));
+ end;
+ {End !!.10}
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ fftSingle: begin
+ case aTargetType of
+ fftSingle:
+ if Assigned(aTargetValue) then
+ Single(aTargetValue^) := Single(aSourceValue^);
+ fftDouble:
+ if Assigned(aTargetValue) then
+ Double(aTargetValue^) := Single(aSourceValue^);
+ fftExtended:
+ if Assigned(aTargetValue) then
+ Extended(aTargetValue^) := Single(aSourceValue^);
+ fftCurrency:
+ if Assigned(aTargetValue) then begin
+ Comp(aTargetValue^) := Single(aSourceValue^) * 10000.0; {!!.10}
+// Comp(aTargetValue^) := Comp(aTargetValue^) * 10000.0;
+ end;
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ fftDouble: begin
+ case aTargetType of
+ fftDouble:
+ if Assigned(aTargetValue) then
+ Double(aTargetValue^) := Double(aSourceValue^);
+ fftExtended:
+ if Assigned(aTargetValue) then
+ Extended(aTargetValue^) := Double(aSourceValue^);
+ fftCurrency:
+ if Assigned(aTargetValue) then begin
+ Comp(aTargetValue^) := Double(aSourceValue^) * 10000.0; {!!.10}
+// Comp(aTargetValue^) := Comp(aTargetValue^) * 10000.0;
+ end;
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ fftExtended: begin
+ case aTargetType of
+ fftExtended:
+ if Assigned(aTargetValue) then
+ Extended(aTargetValue^) := Extended(aSourceValue^);
+ fftCurrency:
+ if Assigned(aTargetValue) then begin
+ Comp(aTargetValue^) := Extended(aSourceValue^);
+ Comp(aTargetValue^) := Comp(aTargetValue^) * 10000.0;
+ end;
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ fftComp:
+ case aTargetType of
+ fftComp:
+ if Assigned(aTargetValue) then
+ Comp(aTargetValue^) := Comp(aSourceValue^);
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+
+ fftCurrency: begin
+ case aTargetType of
+ fftCurrency:
+ if Assigned(aTargetValue) then
+ Comp(aTargetValue^) := Comp(aSourceValue^);
+ {Begin !!.10}
+ fftSingle:
+ if Assigned(aTargetValue) then begin
+ Single(aTargetValue^) := Comp(aSourceValue^);
+ Single(aTargetValue^) := Single(aTargetValue^) / 10000.0;
+ end;
+ fftDouble:
+ if Assigned(aTargetValue) then begin
+ Double(aTargetValue^) := Comp(aSourceValue^);
+ Double(aTargetValue^) := Double(aTargetValue^) / 10000.0;
+ end;
+ {End !!.10}
+ fftExtended:
+ if Assigned(aTargetValue) then begin
+ Extended(aTargetValue^) := Comp(aSourceValue^);
+ Extended(aTargetValue^) := Extended(aTargetValue^) / 10000.0;
+ end;
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ fftStDate: begin
+ case aTargetType of
+ fftStDate:
+ if Assigned(aTargetValue) then
+ LongInt(aTargetValue^) := LongInt(aSourceValue^);
+ fftDateTime:
+ if Assigned(aTargetValue) then
+
+ TDateTime(aTargetValue^) :=
+ StDateToDateTime(LongInt(aSourceValue^))
+ + 693594.0; {TDateTime's are stored as Delphi 1 values}
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ fftStTime: begin
+ case aTargetType of
+ fftStTime:
+ if Assigned(aTargetValue) then
+ LongInt(aTargetValue^) := LongInt(aSourceValue^);
+ fftDateTime:
+ if Assigned(aTargetValue) then
+ TDateTime(aTargetValue^) := StTimeToDateTime(LongInt(aSourceValue^));
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ fftDateTime: begin
+ case aTargetType of
+ fftDateTime:
+ if Assigned(aTargetValue) then
+ TDateTime(aTargetValue^) := TDateTime(aSourceValue^);
+ fftStDate:
+ if Assigned(aTargetValue) then
+ LongInt(aTargetValue^) := DateTimeToStDate(TDateTime(aSourceValue^)
+ - 693594.0); { TDateTime's are stored as Delphi 1 values }
+ fftStTime:
+ if Assigned(aTargetValue) then
+ LongInt(aTargetValue^) := DateTimeToStTime(TDateTime(aSourceValue^));
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ fftBLOB..ffcLastBLOBType:
+ if not (aTargetType in [fftBLOB..ffcLastBLOBType]) then
+ Result := DBIERR_INVALIDFLDXFORM;
+ { Validate only; do not actually move BLOB data around. }
+
+ fftByteArray: begin
+ case aTargetType of
+ fftByteArray:
+ if Assigned(aTargetValue) then
+ Move(aSourceValue^, aTargetValue^, MinLength);
+ fftBLOB..ffcLastBLOBType: ;
+ { Validate only; do not move BLOB data around. }
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ fftShortString, fftShortAnsiStr: begin
+ case aTargetType of
+ fftChar:
+ if Assigned(aTargetValue) then
+ Char(aTargetValue^) := TffShStr(aSourceValue^)[1];
+ fftShortString, fftShortAnsiStr:
+ if Assigned(aTargetValue) then
+ TffShStr(aTargetValue^) := Copy(TffShStr(aSourceValue^), 1, MinLength - 1);
+ fftNullString, fftNullAnsiStr:
+ if Assigned(aTargetValue) then
+ FFStrPCopy(aTargetValue, Copy(TffShStr(aSourceValue^), 1, MinLength - 1));
+ fftWideChar:
+ if Assigned(aTargetValue) then
+ WideChar(aTargetValue^) := FFCharToWideChar(TffShStr(aSourceValue^)[1]);
+ fftWideString:
+ if Assigned(aTargetValue) then begin
+ { Note: the length of a "wide" field is the number of bytes
+ it occupies, not the number of wide chars it will hold. }
+ MinLength := FFMinI(aSourceLength - 1, (aTargetLength div SizeOf(WideChar)) - 1);
+ FFShStrLToWideStr(TffShStr(aSourceValue^), aTargetValue, MinLength);
+ end;
+ fftBLOB..ffcLastBLOBType: ;
+ { Validate only; do not actually move BLOB data around. }
+
+ {Begin !!.13}
+ fftByte:
+ if Assigned(aTargetValue) then begin
+ Val(FFRemoveThousandSeparator(TffShStr(aSourceValue^)), intRes, aCode);
+ if (aCode=0) and (intRes>=Low(Byte)) and (intRes<=High(Byte)) then
+ Byte(aTargetValue^) := intRes
+ else
+ Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ fftWord16:
+ if Assigned(aTargetValue) then begin
+ Val(FFRemoveThousandSeparator(TffShStr(aSourceValue^)), wordRes, aCode);
+ if (aCode=0) then
+ TffWord16(aTargetValue^) := wordRes
+ else
+ Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ fftInt16:
+ if Assigned(aTargetValue) then begin
+ Val(FFRemoveThousandSeparator(TffShStr(aSourceValue^)), intRes, aCode);
+ if (aCode=0) and (intRes>=Low(SmallInt)) and (intRes<=High(SmallInt)) then
+ Smallint(aTargetValue^) := intRes
+ else
+ Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ fftWord32, fftAutoInc:
+ if Assigned(aTargetValue) then begin
+ Val(FFRemoveThousandSeparator(TffShStr(aSourceValue^)), wordRes, aCode);
+ if (aCode=0) then
+ TffWord32(aTargetValue^) := wordRes
+ else
+ Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ fftInt32:
+ if Assigned(aTargetValue) then begin
+ Val(FFRemoveThousandSeparator(TffShStr(aSourceValue^)), intRes, aCode);
+ if (aCode=0) then
+ Integer(aTargetValue^) := intRes
+ else
+ Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ fftSingle:
+ if Assigned(aTargetValue) then
+ Single(aTargetValue^) := StrToFloat(FFRemoveThousandSeparator(TffShStr(aSourceValue^)));
+ fftDouble:
+ if Assigned(aTargetValue) then
+ Double(aTargetValue^) := StrToFloat(FFRemoveThousandSeparator(TffShStr(aSourceValue^)));
+ fftExtended:
+ if Assigned(aTargetValue) then
+ Extended(aTargetValue^) := StrToFloat(FFRemoveThousandSeparator(TffShStr(aSourceValue^)));
+ fftComp:
+ if Assigned(aTargetValue) then
+ Comp(aTargetValue^) := StrToFloat(FFRemoveThousandSeparator(TffShStr(aSourceValue^)));
+ fftCurrency:
+ if Assigned(aTargetValue) then begin
+ Comp(aTargetValue^) := StrToFloat(FFRemoveThousandSeparator(TffShStr(aSourceValue^)));
+ Comp(aTargetValue^) := Comp(aTargetValue^) * 10000.0;
+ end;
+ {End !!.13}
+
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ fftNullString, fftNullAnsiStr: begin
+ case aTargetType of
+ fftChar:
+ if Assigned(aTargetValue) then
+ Char(aTargetValue^) := FFStrPas(aSourceValue)[1];
+ fftShortString, fftShortAnsiStr:
+ if Assigned(aTargetValue) then
+ TffShStr(aTargetValue^) := Copy(FFStrPas(aSourceValue), 1, MinLength - 1);
+ fftNullString, fftNullAnsiStr:
+ if Assigned(aTargetValue) then
+ StrLCopy(aTargetValue, aSourceValue, MinLength - 1);
+ fftWideChar:
+ if Assigned(aTargetValue) then
+ WideChar(aTargetValue^) := FFCharToWideChar(Char(aSourceValue^));
+ fftWideString:
+ if Assigned(aTargetValue) then begin
+ { Note: the length of a "wide" field is the number of bytes
+ it occupies, not the number of wide chars it will hold. }
+ MinLength := FFMinI(aSourceLength - 1, (aTargetLength div SizeOf(WideChar)) - 1);
+ FFNullStrLToWideStr(aSourceValue, aTargetValue, MinLength);
+ end;
+ fftBLOB..ffcLastBLOBType: ;
+ { Validate only; do not actually move BLOB data around. }
+
+ {Begin !!.13}
+ fftByte:
+ if Assigned(aTargetValue) then begin
+ Val(FFRemoveThousandSeparator(PChar(aSourceValue)), intRes, aCode);
+ if (aCode=0) and (intRes>=Low(Byte)) and (intRes<=High(Byte)) then
+ Byte(aTargetValue^) := intRes
+ else
+ Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ fftWord16:
+ if Assigned(aTargetValue) then begin
+ Val(FFRemoveThousandSeparator(PChar(aSourceValue)), wordRes, aCode);
+ if (aCode=0) then
+ TffWord16(aTargetValue^) := wordRes
+ else
+ Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ fftInt16:
+ if Assigned(aTargetValue) then begin
+ Val(FFRemoveThousandSeparator(PChar(aSourceValue)), intRes, aCode);
+ if (aCode=0) and (intRes>=Low(SmallInt)) and (intRes<=High(SmallInt)) then
+ Smallint(aTargetValue^) := intRes
+ else
+ Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ fftWord32, fftAutoInc:
+ if Assigned(aTargetValue) then begin
+ Val(FFRemoveThousandSeparator(PChar(aSourceValue)), wordRes, aCode);
+ if (aCode=0) then
+ TffWord32(aTargetValue^) := wordRes
+ else
+ Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ fftInt32:
+ if Assigned(aTargetValue) then begin
+ Val(FFRemoveThousandSeparator(PChar(aSourceValue)), intRes, aCode);
+ if (aCode=0) then
+ Integer(aTargetValue^) := intRes
+ else
+ Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ fftSingle:
+ if Assigned(aTargetValue) then
+ Single(aTargetValue^) := StrToFloat(FFRemoveThousandSeparator(PChar(aSourceValue)));
+ fftDouble:
+ if Assigned(aTargetValue) then
+ Double(aTargetValue^) := StrToFloat(FFRemoveThousandSeparator(PChar(aSourceValue)));
+ fftExtended:
+ if Assigned(aTargetValue) then
+ Extended(aTargetValue^) := StrToFloat(FFRemoveThousandSeparator(PChar(aSourceValue)));
+ fftComp:
+ if Assigned(aTargetValue) then
+ Comp(aTargetValue^) := StrToFloat(FFRemoveThousandSeparator(PChar(aSourceValue)));
+ fftCurrency:
+ if Assigned(aTargetValue) then begin
+ Comp(aTargetValue^) := StrToFloat(FFRemoveThousandSeparator(PChar(aSourceValue)));
+ Comp(aTargetValue^) := Comp(aTargetValue^) * 10000.0;
+ end;
+ {End !!.13}
+
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+
+ fftWideString: begin
+ case aTargetType of
+ fftChar:
+ if Assigned(aTargetValue) then
+ Char(aTargetValue^) := FFWideCharToChar(WideChar(aSourceValue^));
+ fftShortString, fftShortAnsiStr:
+ if Assigned(aTargetValue) then begin
+ { Note: the length of a "wide" field is the number of bytes
+ it occupies, not the number of wide chars it will hold. }
+ MinLength := FFMinI(aTargetLength - 1, (aSourceLength div SizeOf(WideChar)) - 1);
+ TffShStr(aTargetValue^) := FFWideStrLToShStr(aSourceValue, MinLength);
+ end;
+ fftNullString, fftNullAnsiStr:
+ if Assigned(aTargetValue) then begin
+ { Note: the length of a "wide" field is the number of bytes
+ it occupies, not the number of wide chars it will hold. }
+ MinLength := FFMinI(aTargetLength - 1, (aSourceLength div SizeOf(WideChar)) - 1);
+ FFWideStrLToNullStr(aSourceValue, aTargetValue, MinLength);
+ end;
+ fftWideChar:
+ if Assigned(aTargetValue) then
+ WideChar(aTargetValue^) := WideChar(aSourceValue^);
+ fftWideString:
+ if Assigned(aTargetValue) then
+ FFWideStrLToWideStr(aSourceValue, aTargetValue, FFMinI(aSourceLength, aTargetLength) - 1);
+ fftBLOB..ffcLastBLOBType: ;
+ { Validate only; do not actually move BLOB data around. }
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+ end;
+ else Result := DBIERR_INVALIDFLDXFORM;
+ end;
+end;
+
+
+end.
+
diff --git a/components/flashfiler/sourcelaz/ffdb.pas b/components/flashfiler/sourcelaz/ffdb.pas
new file mode 100644
index 000000000..f87b70f3f
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffdb.pas
@@ -0,0 +1,10350 @@
+{*********************************************************}
+{* FlashFiler: Data Access Components for Delphi 3+ *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+{ Uncomment the following define in order to have the automatic transports
+ log all activity to a file named FFAUTOTRANS.LOG. }
+{.$DEFINE AutoLog}
+
+{ Comment out the following define to disable raising of "Bookmarks do not
+ match table" exceptions for invalid bookmarks in TffDataSet.CompareBookmarks.
+ Disabling this behavior is appropriate for certain data-aware controls
+ such as the InfoPower DBTreeView and the VCL DBGrid. }
+{$DEFINE RaiseBookmarksExcept}
+
+unit ffdb;
+
+interface
+
+uses
+ {$IFDEF DCC6OrLater}
+ Variants,
+ {$ENDIF}
+ Windows,
+ Classes,
+ {$IFNDEF DCC4OrLater}
+ DBTables,
+ {$ENDIF}
+ ComCtrls,
+ Controls,
+ SysUtils,
+ DB,
+ {$IFDEF UsesBDE}
+ bde,
+ {$ENDIF}
+ ffsrbde,
+ ffclbde,
+ ffllcomp,
+ fflleng,
+ ffclbase,
+ fflogdlg,
+ ffllbase,
+ ffllcomm,
+ ffclcfg,
+ ffllprot,
+ fflldict,
+ ffcltbrg,
+ ffdbbase,
+ {$ifndef fpc}
+ DBCommon,
+ {$endif}
+ ffsrvdlg,
+ ffstdate,
+ ffllcoll,
+ ffhash,
+ ffnetmsg,
+ ffclreng,
+ fflllgcy,
+ Messages,
+ ffllthrd,
+{Begin !!.02}
+ ffsqlbas
+ {$IFDEF SingleEXE}
+ , ffsreng
+ {$ENDIF}
+ ;
+{End !!.02}
+
+const
+ DefaultTimeOut = 10 * 1000; { 10 Seconds } {!!.01}
+ AutoObjName = '[automatic]';
+
+type
+ //soner
+ {$ifdef fpc}
+ TBookmark = Pointer;
+ {$endif}
+
+ TffConnectionLostEvent = procedure (aSource : TObject;
+ aStarting : Boolean;
+ var aRetry : Boolean) of object;
+ {-an event triggered once when the conneciton to the server is lost, and
+ onceafter code to retry, or clear associated components is complete. By
+ default aRetry is set to False. If this is set to true then the client
+ will try to reestablish the connection, and associated components. }
+
+ TffLoginEvent = procedure (aSource : TObject;
+ var aUserName : TffName;
+ var aPassword : TffName;
+ var aResult : Boolean) of object;
+ {-an event to get a user name and password for login purposes}
+
+ TffChooseServerEvent = procedure (aSource : TObject;
+ aServerNames : TStrings;
+ var aServerName : TffNetAddress;
+ var aResult : Boolean) of object;
+ {-an event to choose server name to attach to}
+
+ TffFindServersEvent = procedure (aSource : TObject;
+ aStarting : Boolean) of object;
+ {-an event to enable a 'waiting...' dialog or splash screen to be
+ shown whilst finding server names}
+
+type
+ TffKeyEditType = ( {Types of key to edit and store..}
+ ketNormal, {..normal search key}
+ ketRangeStart, {..range start key}
+ ketRangeEnd, {..range end key}
+ ketCurRangeStart,{..current range start key}
+ ketCurRangeEnd, {..current range end key}
+ ketSaved); {..saved key (for rollback)}
+
+type
+ TffCursorProps = packed record { Virtual Table properties }
+ TableName : string; { Table name}
+ FileNameSize : Word; { Full file name size }
+ FieldsCount : Word; { No of fields in Table }
+ RecordSize : Word; { Record size (logical record) }
+ RecordBufferSize : Word; { Record size (physical record) }
+ KeySize : Word; { Key size }
+ IndexCount : Word; { Number of indexes }
+ ValChecks : Word; { Number of val checks }
+ BookMarkSize : Word; { Bookmark size }
+ BookMarkStable : Boolean; { Stable book marks }
+ OpenMode : TffOpenMode; { ReadOnly / RW }
+ ShareMode : TffShareMode; { Excl / Share }
+ Indexed : Boolean; { Index is in use }
+ XltMode : FFXLTMode; { Translate Mode }
+ TblRights : Word; { Table rights }
+ Filters : Word; { Number of filters }
+ end;
+
+type
+ PffNodeValue = ^TffNodeValue;
+ TffNodeValue = packed record
+ nvType : Word;
+ nvSize : Word;
+ nvValue : Pointer;
+ nvIsNull : Boolean;
+ nvIsConst : Boolean;
+ end;
+
+ PffFilterNode = ^TffFilterNode;
+ TffFilterNode = packed record
+ Case Integer of
+ 1:(fnHdr : CANHdr);
+ 2:(fnUnary : CANUnary);
+ 3:(fnBinary : CANBinary);
+ 4:(fnField : CANField);
+ 5:(fnConst : CANConst);
+ 7:(fnContinue : CANContinue);
+ 8:(fnCompare : CANCompare);
+ end;
+
+ TffFilterListItem = class(TffCollectionItem)
+ protected {private}
+ fliActive : Boolean;
+ fliCanAbort : Boolean;
+ fliExpression : pCANExpr;
+ fliExprSize : Word;
+ fliFilterFunc : pfGENFilter;
+ fliClientData : Longint;
+ fliOwner : TObject;
+ fliPriority : Integer;
+
+ protected
+ function fliGetLiteralPtr(aoffset : Word) : Pointer;
+ function fliGetNodePtr(aoffset : Word) : PffFilterNode;
+
+ function fliEvaluateBinaryNode(aNode : PffFilterNode;
+ aRecBuf : Pointer;
+ aNoCase : Boolean;
+ aPartial: Word) : Boolean;
+ function fliEvaluateConstNode(aNode : PffFilterNode;
+ aValue : PffNodeValue;
+ aRecBuf : Pointer) : Boolean;
+ function fliEvaluateFieldNode(aNode : PffFilterNode;
+ aValue : PffNodeValue;
+ aRecBuf : Pointer) : Boolean;
+ function fliEvaluateLogicalNode(aNode : PffFilterNode;
+ aRecBuf : Pointer) : Boolean;
+ function fliEvaluateNode(aNode : PffFilterNode;
+ aValue : PffNodeValue;
+ aRecBuf : Pointer) : Boolean;
+ function fliEvaluateUnaryNode(aNode : PffFilterNode;
+ aRecBuf : Pointer) : Boolean;
+
+ function fliCompareValues(var aCompareResult : Integer;
+ var aFirst : TffNodeValue;
+ var aSecond : TffNodeValue;
+ aIgnoreCase : Boolean;
+ aPartLen : Integer) : Boolean;
+
+ public
+ constructor Create(aContainer : TffCollection;
+ aOwner : TObject;
+ aClientData: Longint;
+ aPriority : Integer;
+ aCanAbort : Boolean;
+ aExprTree : pCANExpr;
+ aFiltFunc : pfGENFilter);
+ destructor Destroy; override;
+
+ function MatchesRecord(aRecBuf : Pointer) : Boolean;
+ procedure GetFilterInfo(Index : Word; var FilterInfo : FilterInfo);
+
+ property Active : Boolean
+ read fliActive
+ write fliActive;
+ end;
+
+type
+ TffBaseClient = class;
+ TffClient = class;
+ TffCommsEngine = class;
+ TffClientList = class;
+ TffSession = class;
+ TffSessionList = class;
+ TffBaseTable = class;
+ TffBaseDatabase = class;
+ TffDatabase = class;
+ TffDatabaseList = class;
+ TffTableProxy = class;
+ TffTableProxyList = class;
+ TffDataSet = class;
+ TffTable = class;
+
+ TffBaseClient = class(TffDBListItem)
+ protected {private}
+ bcAutoClientName : Boolean;
+ bcBeepOnLoginError : Boolean; {!!.06}
+ bcOwnServerEngine : Boolean;
+ bcClientID : TffClientID;
+ bcIsDefault : Boolean;
+ bcOnConnectionLost : TffConnectionLostEvent;
+ bcPasswordRetries : Integer;
+ bcServerEngine : TffBaseServerEngine;
+ bcTimeOut : Longint;
+ bcUserName : TffNetName;
+ bcPassword : string; {!!.06}
+ {bcPassword is only used to store the last password at design-time.
+ It is not used at run-time.}
+ function dbliCreateOwnedList : TffDBList; override;
+ procedure dbliClosePrim; override;
+ procedure dbliDBItemAdded(aItem : TffDBListItem); override;
+ procedure dbliDBItemDeleted(aItem : TffDBListItem); override;
+ procedure dbliMustBeClosedError; override;
+ procedure dbliMustBeOpenError; override;
+
+ function bcGetServerEngine : TffBaseServerEngine;
+ function bcGetUserName : string; {!!.10}
+ procedure bcSetAutoClientName(const Value : Boolean);
+ procedure bcSetClientName(const aName : string);
+ procedure bcSetIsDefault(const Value : Boolean);
+ procedure bcSetUserName(const Value : string);
+ procedure bcSetServerEngine(Value : TffBaseServerEngine);
+ procedure bcSetTimeout(const Value : Longint);
+ function bcGetSession(aInx : Integer) : TffSession;
+ function bcGetSessionCount : Integer;
+
+ function bcGetDefaultSession : TffSession;
+ procedure bcMakeSessionDefault(aSession : TffSession;
+ aValue : Boolean);
+ procedure OpenConnection(aSession : TffSession); virtual; abstract;
+
+ procedure bcDoConnectionLost; dynamic;
+ function bcReinstateDependents : Boolean;
+ procedure bcClearDependents;
+
+ function ProcessRequest(aMsgID : Longint;
+ aTimeout : Longint;
+ aRequestData : Pointer;
+ aRequestDataLen : Longint;
+ aRequestDataType : TffNetMsgDataType;
+ var aReply : Pointer;
+ var aReplyLen : Longint;
+ aReplyType : TffNetMsgDataType) : TffResult; virtual;
+ { Backdoor method for sending a request to a server engine.
+ Should only be implemented by remote server engines. }
+
+
+ function ProcessRequestNoReply(aMsgID : Longint;
+ aTimeout : Longint;
+ aRequestData : Pointer;
+ aRequestDataLen : Longint) : TffResult; virtual;
+ { Backdoor method for sending a request, no reply expected, to a
+ server engine. Should only be implemented by remote server engines. }
+
+ public
+ constructor Create(aOwner : TComponent); override;
+ destructor Destroy; override;
+ procedure IDEConnectionLost(aSource : TObject;
+ aStarting : Boolean;
+ var aRetry : Boolean);
+ procedure FFNotificationEx(const AOp : Byte; AFrom : TffComponent;
+ const AData : TffWord32); override;
+
+ procedure GetServerNames(aServerNames : TStrings); virtual; {!!.01}
+ function IsConnected : Boolean; virtual;
+
+ property AutoClientName : Boolean
+ read bcAutoClientName
+ write bcSetAutoClientName
+ default False;
+
+ property BeepOnLoginError : Boolean {!!.06}
+ read bcBeepOnLoginError
+ write bcBeepOnLoginError
+ default True;
+
+ property ClientID : TffClientID
+ read bcClientID;
+
+ property ClientName : string
+ read dbliDBName
+ write bcSetClientName;
+
+ property CommsEngineName : string
+ read dbliDBName
+ write bcSetClientName;
+
+ property IsDefault : Boolean
+ read bcIsDefault
+ write bcSetIsDefault
+ default False;
+
+ property OnConnectionLost : TffConnectionLostEvent
+ read bcOnConnectionLost
+ write bcOnConnectionLost;
+
+ property OwnServerEngine : Boolean
+ read bcOwnServerEngine
+ stored False;
+
+ property PasswordRetries : Integer
+ read bcPasswordRetries
+ write bcPasswordRetries
+ default 3;
+
+ property ServerEngine : TffBaseServerEngine
+ read bcGetServerEngine
+ write bcSetServerEngine;
+
+ property SessionCount : Integer
+ read bcGetSessionCount
+ stored False;
+
+ property Sessions[aInx : Integer] : TffSession
+ read bcGetSession;
+
+ property TimeOut : Longint
+ read bcTimeOut
+ write bcSetTimeOut
+ default DefaultTimeout;
+ { Timeout specified in milliseconds }
+
+ property UserName : string {!!.10}
+ read bcGetUserName
+ write bcSetUserName;
+
+ end;
+
+ TffClient = class(TffBaseClient)
+ public
+ procedure OpenConnection (aSession : TffSession); override;
+ property ClientID;
+ property SessionCount;
+ property Sessions;
+ published
+ property Active;
+ property AutoClientName;
+ property BeepOnLoginError; {!!.06}
+ property ClientName;
+ property IsDefault;
+ property OnConnectionLost;
+ property PasswordRetries;
+ property ServerEngine;
+ property TimeOut;
+ property UserName;
+ end;
+
+ TffCommsEngine = class(TffBaseClient)
+ protected {private}
+ FServerName : TffNetName;
+ ceProtocol : TffProtocolType;
+ ceRegProt : TffCommsProtocolClass;
+ ceRegProtRead : Boolean;
+ ceServerName : TffNetAddress;
+
+ protected
+ procedure ceSetProtocol(const Value : TffProtocolType);
+ procedure ceSetServerName(const Value : string); {!!.10}
+ function ceGetServerName : string; {!!.10}
+ procedure ceReadRegistryProtocol;
+ public
+ constructor Create(aOwner : TComponent); override;
+
+ procedure GetServerNames(aServerNames : TStrings); override; {!! .01}
+ procedure OpenConnection (aSession : TffSession); override;
+ function ProtocolClass : TffCommsProtocolClass; dynamic;
+
+ property ClientID;
+ property SessionCount;
+ property Sessions;
+
+ published
+ property Active;
+ property AutoClientName;
+ property BeepOnLoginError; {!!.06}
+ property CommsEngineName;
+ property IsDefault;
+ property OnConnectionLost;
+ property PasswordRetries;
+ property ServerEngine;
+ property TimeOut;
+ property UserName;
+
+ property Protocol : TffProtocolType
+ read ceProtocol
+ write ceSetProtocol
+ default ptSingleUser;
+
+ property ServerName : string {!!.10}
+ read ceGetServerName
+ write ceSetServerName;
+ end;
+
+ TffClientList = class(TffDBStandaloneList)
+ protected {private}
+ function clGetItem(aInx : Integer) : TffBaseClient;
+ public
+ property Clients[aInx : Integer] : TffBaseClient
+ read clGetItem; default;
+ property CommsEngines[aInx : Integer] : TffBaseClient
+ read clGetItem;
+ end;
+
+
+ TffSession = class(TffDBListItem)
+ protected {private}
+ scAutoSessionName : Boolean;
+ scSessionID : TffSessionID;
+ scIsDefault : Boolean;
+
+ scOnStartup : TNotifyEvent;
+ scChooseServer : TffChooseServerEvent;
+ scFindServers : TffFindServersEvent;
+ scLogin : TffLoginEvent;
+ scServerEngine : TffBaseServerEngine;
+ scTimeout : Longint;
+ protected
+ function scGetClient : TffBaseClient;
+ function scGetDatabase(aInx : Integer) : TffBaseDatabase;
+ function scGetDatabaseCount : Integer;
+ function scGetIsDefault : Boolean;
+ function scGetServerEngine : TffBaseServerEngine;
+ procedure scRefreshTimeout; {!!.11}
+ procedure scSetAutoSessionName(const Value : Boolean);
+ procedure scSetIsDefault(const Value : Boolean);
+ procedure scSetSessionName(const aName : string);
+ procedure scSetTimeout(const Value : Longint);
+
+ function dbliCreateOwnedList : TffDBList; override;
+ procedure dbliClosePrim; override;
+ function dbliFindDBOwner(const aName : string)
+ : TffDBListItem; override;
+ procedure dbliMustBeClosedError; override;
+ procedure dbliMustBeOpenError; override;
+ procedure dbliOpenPrim; override;
+ procedure DoStartup; virtual;
+ procedure ChooseServer(var aServerName : TffNetAddress);
+ procedure FindServers(aStarting : Boolean);
+ procedure DoLogin(var aUserName : TffName;
+ var aPassword : TffName;
+ var aResult : Boolean);
+
+ function ProcessRequest(aMsgID : Longint;
+ aTimeout : Longint;
+ aRequestData : Pointer;
+ aRequestDataLen : Longint;
+ aRequestDataType : TffNetMsgDataType;
+ var aReply : Pointer;
+ var aReplyLen : Longint;
+ aReplyType : TffNetMsgDataType)
+ : TffResult; virtual;
+ { Backdoor method for sending a request to a server engine.
+ Should only be implemented by remote server engines. }
+
+
+ function ProcessRequestNoReply(aMsgID : Longint;
+ aTimeout : Longint;
+ aRequestData : Pointer;
+ aRequestDataLen : Longint)
+ : TffResult; virtual;
+ { Backdoor method for sending a request, no reply expected, to a
+ server engine. Should only be implemented by remote server engines. }
+
+ public
+ constructor Create(aOwner : TComponent); override;
+ destructor Destroy; override;
+
+ procedure AddAlias(const aName : string;
+ const aPath : string;
+ aCheckSpace : Boolean {!!.11}
+ {$IFDEF DCC4OrLater} {!!.11}
+ = False {!!.11}
+ {$ENDIF}); {!!.11}
+ function AddAliasEx(const aName : string;
+ const aPath : string;
+ aCheckSpace : Boolean {!!.11}
+ {$IFDEF DCC4OrLater} {!!.11}
+ = False {!!.11}
+ {$ENDIF}) {!!.11}
+ : TffResult;
+ procedure CloseDatabase(aDatabase : TffBaseDatabase);
+ procedure CloseInactiveTables; {!!.06}
+ procedure DeleteAlias(const aName : string);
+ function DeleteAliasEx(const aName : string) : TffResult;
+ function FindDatabase(const aName : string) : TffBaseDatabase;
+ procedure GetAliasNames(aList : TStrings);
+ function GetAliasNamesEx(aList : TStrings;
+ const aEmptyList : Boolean)
+ : TffResult;
+ procedure GetAliasPath(const aName : string;
+ var aPath : string);
+ procedure GetDatabaseNames(aList : TStrings);
+ function GetServerDateTime(var aServerNow : TDateTime) : TffResult;
+ {begin !!.10}
+ function GetServerSystemTime(var aServerNow : TSystemTime) : TffResult;
+ function GetServerGUID(var aGUID : TGUID) : TffResult;
+ function GetServerID(var aUniqueID : TGUID) : TffResult;
+ function GetServerStatistics(var aStats : TffServerStatistics)
+ : TffResult;
+ function GetCommandHandlerStatistics(const aCmdHandlerIdx : Integer;
+ var aStats : TffCommandHandlerStatistics)
+ : TffResult;
+ function GetTransportStatistics(const aCmdHandlerIdx : Integer;
+ const aTransportIdx : Integer;
+ var aStats : TffTransportStatistics)
+ : TffResult;
+ {End !!.10}
+ procedure GetTableNames(const aDatabaseName : string;
+ const aPattern : string;
+ aExtensions : Boolean;
+ aSystemTables : Boolean;
+ aList : TStrings);
+ function GetTaskStatus(const aTaskID : Longint;
+ var aCompleted : Boolean;
+ var aStatus : TffRebuildStatus) : TffResult;
+ function GetTimeout : Longint;
+ function IsAlias(const aName : string) : Boolean;
+ function ModifyAlias(const aName : string;
+ const aNewName : string;
+ const aNewPath : string;
+ aCheckSpace : Boolean {!!.11}
+ {$IFDEF DCC4OrLater} {!!.11}
+ = False {!!.11}
+ {$ENDIF}) {!!.11}
+ : TffResult;
+ function OpenDatabase(const aName : string) : TffBaseDatabase;
+ procedure SetLoginRetries(const aRetries : Integer);
+ procedure SetLoginParameters(const aName : TffName; aPassword : TffName);
+
+ property Client : TffBaseClient
+ read scGetClient;
+
+ property CommsEngine : TffBaseClient
+ read scGetClient;
+
+ property DatabaseCount : Integer
+ read scGetDatabaseCount;
+ { TODO:: This functionality assumes that all dependents are databases.
+ This is not the case when a plugin engine attaches itself to the
+ session in order to re-use the connection. }
+
+ property Databases[aInx : Integer] : TffBaseDatabase
+ read scGetDatabase;
+ { TODO:: This functionality assumes that all dependents are databases.
+ This is not the case when a plugin engine attaches itself to the
+ session in order to re-use the connection. }
+
+ property ServerEngine : TffBaseServerEngine
+ read scGetServerEngine;
+
+ property SessionID : TffSessionID
+ read scSessionID;
+
+ published
+ property Active;
+
+ property AutoSessionName : Boolean
+ read scAutoSessionName
+ write scSetAutoSessionName
+ default False;
+
+ property ClientName : string
+ read dbligetDBOwnerName
+ write dbliSetDBOwnerName;
+
+ property CommsEngineName : string
+ read dbliGetDBOwnerName
+ write dbliSetDBOwnerName
+ stored False;
+ {Since the ClientName, and CommsEngine name
+ are mirrod, we only need to store the ClientName.}
+
+ property IsDefault : Boolean
+ read scGetIsDefault
+ write scSetIsDefault
+ default False;
+
+ property SessionName : string
+ read dbliDBName
+ write scSetSessionName;
+
+ property OnStartup : TNotifyEvent
+ read scOnStartup
+ write scOnStartup;
+
+ property OnChooseServer : TffChooseServerEvent
+ read scChooseServer
+ write scChooseServer;
+
+ property OnFindServers : TffFindServersEvent
+ read scFindServers
+ write scFindServers;
+
+ property OnLogin : TffLoginEvent
+ read scLogin
+ write scLogin;
+
+ property TimeOut : Longint
+ read scTimeout
+ write scSetTimeout
+ default -1;
+ { Timeout specified in milliseconds }
+ end;
+
+ TffSessionList = class(TffDBList)
+ protected {private}
+ slCurrSess : TffSession;
+ protected
+ function slGetCurrSess : TffSession;
+ function slGetItem(aInx : Integer) : TffSession;
+ procedure slSetCurrSess(CS : TffSession);
+ public
+ property CurrentSession : TffSession
+ read slGetCurrSess
+ write slSetCurrSess;
+
+ property Sessions[aInx : Integer] : TffSession
+ read slGetItem; default;
+ end;
+
+
+ TffServerFilterTimeoutEvent = procedure(Sender : TffDataSet;
+ var Cancel : Boolean) of object;
+ TffFilterEvaluationType = (ffeLocal, ffeServer);
+ { If ffeLocal then filter statement is evaluated local to client.
+ If ffeServer then filter statement is evaluated on server. }
+
+
+ TffFieldDescItem = class(TffCollectionItem)
+ protected {private}
+ fdiPhyDesc : pFLDDesc;
+ fdiLogDesc : pFLDDesc;
+ fdiFieldNum: Integer;
+
+ public
+ constructor Create(aContainer : TffCollection; const FD : FLDDesc);
+ destructor Destroy; override;
+
+ property LogDesc : pFLDDesc
+ read fdiLogDesc;
+
+ property PhyDesc : pFLDDesc
+ read fdiPhyDesc;
+
+ property FieldNumber : Integer
+ read fdiFieldNum;
+ end;
+
+ TTableState =(TblClosed, TblOpened);
+
+ TffDataSet = class(TDataSet)
+ protected {private}
+ dsBookmarkOfs : Integer;{offset to bookmark in TDataSet record Buffer}
+ dsBlobOpenMode : TffOpenMode;
+ dsCalcFldOfs : Integer;{offset to calcfields in TDataSet record Buffer}
+ dsClosing : Boolean;
+ dsCurRecBuf : Pointer;
+ dsCursorID : TffCursorID;
+ dsDictionary : TffDataDictionary;
+ dsExclusive : Boolean;
+ dsExprFilter : hDBIFilter;
+ dsFieldDescs : TffCollection;
+ dsFilterActive : Boolean;
+ dsFilterEval : TffFilterEvaluationType;
+ dsFilterResync : Boolean;
+ dsFilters : TffCollection;
+ dsFilterTimeout : TffWord32;
+ dsFuncFilter : hDBIFilter;
+ dsOldValuesBuffer : PChar;
+ dsOpenMode : TffOpenMode;
+ dsPhyRecSize : Integer; {FlashFiler physical record size}
+ dsProxy : TffTableProxy;
+ dsReadOnly : Boolean;
+ dsRecBufSize : Integer; {TDataSet record Buffer size}
+ dsRecInfoOfs : Integer; {offset to rec info in TDataSet record Buffer}
+ dsRecordToFilter : Pointer;
+ dsServerEngine : TffBaseServerEngine;
+ dsShareMode : TffShareMode;
+ dsTableState : TTableState;
+ dsTimeout : Longint;
+ { If you need a timeout value, use the Timeout property. Do not
+ directly access this property as it may be set to -1. The Timeout
+ property takes this into account. }
+ dsXltMode : FFXltMode;
+ dsOnServerFilterTimeout : TffServerFilterTimeoutEvent;
+ protected
+ {---Property access methods---}
+ function dsGetDatabase : TffBaseDatabase;
+ function dsGetDatabaseName : string;
+ function dsGetServerEngine : TffBaseServerEngine; virtual;
+ function dsGetSession : TffSession;
+ function dsGetSessionName : string;
+ function dsGetTableName : string;
+ function dsGetVersion : string;
+ procedure dsRefreshTimeout; {!!.11}
+ procedure dsSetDatabaseName(const aValue : string);
+ procedure dsSetExclusive(const aValue : Boolean);
+ procedure dsSetReadOnly(const aValue : Boolean);
+ procedure dsSetSessionName(const aValue : string);
+ procedure dsSetTableLock(LockType: TffLockType; Lock: Boolean);
+ procedure dsSetTableName(const aValue : string); virtual;
+ function dsGetTimeout : Longint;
+ procedure dsSetTimeout(const Value : Longint);
+ procedure dsSetVersion(const aValue : string);
+
+ {---Filtering---}
+ function dsActivateFilter(hFilter : hDBIFilter) : TffResult;
+ procedure dsAddExprFilter(const aText : string;
+ const aOpts : TFilterOptions);
+ function dsAddFilter(iClientData : Longint;
+ iPriority : Word;
+ bCanAbort : Bool;
+ pCANExpr : pCANExpr;
+ pffilter : pfGENFilter;
+ var hFilter : hDBIFilter) : TffResult;
+ procedure dsAddFuncFilter(aFilterFunc : pfGENFilter);
+ function dsCancelServerFilter: Boolean; virtual;
+ procedure dsClearServerSideFilter;
+ function dsCreateLookupFilter(aFields : TList;
+ const aValues : Variant;
+ aOptions : TLocateOptions): HDBIFilter;
+ function dsDeactivateFilter(hFilter : hDBIFilter) : TffResult;
+ procedure dsActivateFilters; virtual; {!!.03}
+ procedure dsDeactivateFilters; virtual; {!!.03}
+ function dsDropFilter(hFilter : hDBIFilter) : TffResult;
+ procedure dsDropFilters;
+ function dsMatchesFilter(pRecBuff : Pointer) : Boolean;
+ function dsOnFilterRecordCallback({ulClientData = Self}
+ pRecBuf : Pointer;
+ iPhyRecNum : Longint
+ ): SmallInt stdcall;
+
+ procedure dsSetFilterEval(const aMode : TffFilterEvaluationType);
+ procedure dsSetFilterTextAndOptions(const aText : string;
+ const aOpts : TFilterOptions;
+ const aMode : TffFilterEvaluationType;
+ const atimeOut : TffWord32);
+ procedure dsSetServerSideFilter(const aText : string;
+ const aOpts : TFilterOptions;
+ aTimeout : TffWord32);
+ procedure dsSetFilterTimeout(const numMS : TffWord32);
+ procedure dsUpdateFilterStatus;
+
+ {---Record and key Buffer management---}
+ function GetActiveRecBuf(var aRecBuf : PChar): Boolean; virtual;
+ function GetCursorProps(var aProps : TffCursorProps) : TffResult; virtual;
+ function dsGetNextRecord(eLock : TffLockType;
+ pRecBuff : Pointer;
+ RecProps : pRECProps) : TffResult;
+ function dsGetNextRecordPrim(aCursorID : TffCursorID;
+ eLock : TffLockType;
+ pRecBuff : Pointer;
+ RecProps : pRECProps) : TffResult;
+ function dsGetPhyRecSize : Integer;
+ function dsGetPriorRecord(eLock : TffLockType;
+ pRecBuff : Pointer;
+ RecProps : pRECProps) : TffResult;
+ function dsGetPriorRecordPrim(eLock : TffLockType;
+ pRecBuff : Pointer;
+ RecProps : pRECProps) : TffResult;
+ function dsGetRecord(eLock : TffLockType;
+ pRecBuff : Pointer;
+ RecProps : pRECProps) : TffResult;
+ function dsGetRecordCountPrim(var iRecCount : Longint) : TffResult;
+ function dsGetRecordPrim(eLock : TffLockType;
+ pRecBuff : Pointer;
+ RecProps : pRECProps) : TffResult;
+ procedure dsGetRecordInfo(aReadProps : Boolean); virtual;
+ function dsModifyRecord(aBuffer : Pointer; aRelLock : Boolean) : TffResult;
+
+ {---Field management---}
+ procedure dsAddFieldDesc(aFieldDesc : PffFieldDescriptor;
+ aFieldNo : Integer);
+ function dsGetFieldDescItem(iField : Integer;
+ var FDI : TffFieldDescItem) : Boolean;
+ function dsGetFieldNumber(FieldName : PChar) : Integer;
+ procedure dsReadFieldDescs;
+ function dsTranslateCmp(var aFirst : TffNodeValue;
+ var aSecond : TffNodeValue;
+ aIgnoreCase : Boolean;
+ aPartLen : Integer) : Integer;
+ function dsTranslateGet(FDI : TffFieldDescItem;
+ pRecBuff : Pointer;
+ pDest : Pointer;
+ var bBlank : Boolean) : TffResult;
+ function dsTranslatePut(FDI : TffFieldDescItem;
+ pRecBuff : Pointer;
+ pSrc : Pointer) : TffResult;
+
+ {---Handle stuff---}
+ function dsCreateHandle : TffCursorID;
+ procedure DestroyHandle(aHandle : TffCursorID); virtual;
+ function GetCursorHandle(aIndexName : string) : TffCursorID; virtual;
+
+ {---Stuff required for descendent dataset's. Empty stubs it this class}
+ procedure dsGetIndexInfo; virtual;
+ procedure dsAllocKeyBuffers; virtual;
+ procedure dsCheckMasterRange; virtual;
+
+ {---Modes---}
+ procedure dsEnsureDatabaseOpen(aValue : Boolean);
+
+ {---Blob stuff---}
+ function dsCheckBLOBHandle(pRecBuf : Pointer;
+ iField : Integer;
+ var aIsNull : Boolean;
+ var aBLOBNr : TffInt64) : TffResult;
+ function dsEnsureBLOBHandle(pRecBuf : Pointer;
+ iField : Integer;
+ var aBLOBNr : TffInt64) : TffResult;
+
+ {$IFDEF ResizePersistFields}
+ procedure ReSizePersistentFields;
+ {$ENDIF}
+
+ {---TDataSet method overrides---}
+ {Opening, initializing and closing}
+ procedure CloseCursor; override;
+ procedure InitFieldDefs; override;
+ procedure InternalClose; override;
+ procedure InternalOpen; override;
+ procedure InternalInitFieldDefs; override;
+ function IsCursorOpen : Boolean; override;
+ procedure OpenCursor(aInfoQuery : Boolean); override;
+
+ {Bookmark management and use}
+ procedure GetBookmarkData(aBuffer : PChar; aData : Pointer); override;
+ function GetBookmarkFlag(aBuffer : PChar): TBookmarkFlag; override;
+ procedure InternalGotoBookmark(aBookmark : TBookmark); override;
+ procedure SetBookmarkData(aBuffer : PChar; aData : Pointer); override;
+ procedure SetBookmarkFlag(aBuffer : PChar;
+ aValue : TBookmarkFlag); override;
+
+ {Record Buffer allocation and disposal}
+ function AllocRecordBuffer : PChar; override;
+ procedure FreeRecordBuffer(var aBuffer : PChar); override;
+ function GetRecordSize : Word; override;
+
+ {Field access and update}
+ procedure ClearCalcFields(aBuffer : PChar); override;
+ procedure CloseBlob(aField : TField); override;
+ procedure InternalInitRecord(aBuffer : PChar); override;
+ procedure SetFieldData(aField : TField; aBuffer : Pointer); override;
+ function FreeBlob( { Free the blob }
+ pRecBuf : Pointer; { Record Buffer }
+ iField : Word { Field number of blob(1..n) }
+ ) : TffResult;
+
+ {Record access and update}
+ function FindRecord(aRestart, aGoForward : Boolean) : Boolean; override;
+ function GetRecNo: Integer; override;
+ function GetRecord(aBuffer : PChar;
+ aGetMode : TGetMode;
+ aDoCheck : Boolean): TGetResult; override;
+ procedure InternalAddRecord(aBuffer : Pointer;
+ aAppend : Boolean); override;
+ procedure InternalCancel; override;
+ procedure InternalDelete; override;
+ procedure InternalEdit; override;
+ procedure InternalFirst; override;
+ procedure InternalLast; override;
+ procedure InternalPost; override;
+ procedure InternalSetToRecord(aBuffer : PChar); override;
+
+ {information}
+ function GetCanModify : Boolean; override;
+ function GetRecordCount : Integer; override;
+ procedure InternalHandleException; override;
+ procedure SetName(const NewName : TComponentName); override;
+
+ {filtering}
+ procedure SetFiltered(Value : Boolean); override;
+ procedure SetFilterOptions(Value : TFilterOptions); override;
+ procedure SetFilterText(const Value : string); override;
+ procedure SetOnFilterRecord(const Value : TFilterRecordEvent); override;
+
+ procedure dsCloseViaProxy; virtual;
+
+ property Exclusive : Boolean
+ read dsExclusive
+ write dsSetExclusive
+ default False;
+
+ property FieldDescs : TffCollection
+ read dsFieldDescs;
+
+ property FilterActive : Boolean
+ read dsFilterActive;
+
+ property Filters : TffCollection
+ read dsFilters;
+
+ property OpenMode : TffOpenMode
+ read dsOpenMode;
+
+ property PhysicalRecordSize : Integer
+ read dsGetPhyRecSize;
+
+ property ReadOnly : Boolean
+ read dsReadOnly
+ write dsSetReadOnly
+ default False;
+
+ property ShareMode : TffShareMode
+ read dsShareMode;
+
+ property TableState : TTableState
+ read dsTableState
+ write dsTableState;
+
+ property XltMode : FFXltMode
+ read dsXltMode;
+
+ property TableName : string
+ read dsGetTableName
+ write dsSetTableName;
+
+ public
+ constructor Create(aOwner : TComponent); override;
+ destructor Destroy; override;
+
+ function AddFileBlob(const aField : Word;
+ const aFileName : TffFullFileName) : TffResult;
+ function BookmarkValid(aBookmark : TBookmark) : Boolean; override;
+ function CompareBookmarks(Bookmark1,
+ Bookmark2 : TBookmark) : Integer; override;
+ procedure CopyRecords(aSrcTable : TffDataset; aCopyBLOBs : Boolean); {!!.06}
+ function CreateBlobStream(aField : TField;
+ aMode : TBlobStreamMode) : TStream; override;
+ procedure DeleteTable;
+ procedure EmptyTable;
+ function GetCurrentRecord(aBuffer : PChar) : Boolean; override;
+ function GetFieldData(aField : TField;
+ aBuffer : Pointer): Boolean; override;
+ function GetRecordBatch(
+ RequestCount : Longint;
+ var ReturnCount : Longint;
+ pRecBuff : Pointer) : TffResult;
+ function GetRecordBatchEx(
+ RequestCount : Longint;
+ var ReturnCount : Longint;
+ pRecBuff : Pointer;
+ var Error : TffResult) : TffResult;
+ procedure GotoCurrent(aDataSet : TffDataSet);
+ function InsertRecordBatch(
+ Count : Longint;
+ pRecBuff : Pointer;
+ Errors : PffLongintArray) : TffResult;
+ procedure Loaded; override;
+ procedure LockTable(LockType: TffLockType);
+ function OverrideFilterEx(aExprTree : ffSrBDE.pCANExpr;
+ const aTimeout : TffWord32) : TffResult;
+ function PackTable(var aTaskID : LongInt) : TffResult;
+ procedure RecordCountAsync(var TaskID : Longint); {!!.07}
+ procedure RenameTable(const aNewTableName: string);
+ function RestoreFilterEx : TffResult;
+ function RestructureTable(aDictionary : TffDataDictionary;
+ aFieldMap : TStrings;
+ var aTaskID : LongInt) : TffResult;
+ function SetFilterEx(aExprTree : ffSrBDE.pCANExpr;
+ const aTimeout : TffWord32) : TffResult;
+ function SetTableAutoIncValue(const aValue: TffWord32) : TffResult;
+ function Exists : Boolean;
+ function TruncateBlob(pRecBuf : pointer;
+ iField : Word;
+ iLen : Longint) : TffResult;
+ procedure UnlockTable(LockType: TffLockType);
+ procedure UnlockTableAll;
+
+ function IsSequenced : Boolean; override;
+
+ property Session : TffSession
+ read dsGetSession;
+
+ property CursorID : TffCursorID
+ read dsCursorID;
+
+ property Database : TffBaseDatabase
+ read dsGetDatabase;
+
+ property Dictionary : TffDataDictionary
+ read dsDictionary
+ write dsDictionary;
+
+ property ServerEngine : TffBaseServerEngine
+ read dsGetServerEngine;
+
+ property DatabaseName : string
+ read dsGetDatabaseName
+ write dsSetDatabaseName;
+
+ property FilterEval : TffFilterEvaluationType
+ read dsFilterEval
+ write dsSetFilterEval
+ default ffeServer;
+ { This property determines where the filter is evaluated. For best
+ performance, evaluate the filter on the server by setting this
+ property to ffeServer. Otherwise, setting this property to
+ ffeLocal causes the filter to be evaluated on the client. }
+
+ property FilterResync : Boolean
+ read dsFilterResync
+ write dsFilterResync
+ default True;
+ { When this property is set to True, changing the Filter or the
+ FilterEval properties causes the server to refresh the dataset.
+ Set this property to False when you don't want the server to
+ refresh the dataset. For example, if you have created a cache
+ table that inherits from TffTable and the cache table must set to
+ the beginning of the dataset anyway, set this property to False
+ so that the server does not filter the dataset twice. }
+
+ property FilterTimeout : TffWord32
+ read dsFilterTimeOut
+ write dsSetFilterTimeOut
+ default 500;
+ { When retrieving a filtered dataset from the server, the
+ number of milliseconds in which the server has to
+ respond. If the server does not respond within the
+ specified milliseconds, the OnServerFilterTimeout event
+ is raised. }
+
+ property OnServerFilterTimeout: TffServerFilterTimeoutEvent
+ read dsOnServerFilterTimeout
+ write dsOnServerFilterTimeout;
+
+ property SessionName : string
+ read dsGetSessionName
+ write dsSetSessionName;
+
+ property Timeout : Longint
+ read dsTimeout {!!.06}
+ write dsSetTimeout
+ default -1; {!!.01}
+ { Timeout specified in milliseconds }
+
+ property Version : string
+ read dsGetVersion
+ write dsSetVersion
+ stored False;
+
+ { The following properties will be published by descendent classes,
+ they are included here to reduce duplicity of documentation }
+ property BeforeOpen;
+ property AfterOpen;
+ property BeforeClose;
+ property AfterClose;
+ property BeforeInsert;
+ property AfterInsert;
+ property BeforeEdit;
+ property AfterEdit;
+ property BeforePost;
+ property AfterPost;
+ property BeforeCancel;
+ property AfterCancel;
+ property BeforeDelete;
+ property AfterDelete;
+ property BeforeScroll;
+ property AfterScroll;
+ {$IFDEF DCC5OrLater}
+ property BeforeRefresh;
+ property AfterRefresh;
+ {$ENDIF}
+ property OnCalcFields;
+ property OnDeleteError;
+ property OnEditError;
+ property OnFilterRecord;
+ property OnNewRecord;
+ property OnPostError;
+ end;
+
+
+ TffBaseTable = class(TffDataSet)
+ protected {private}
+ btFieldsInIndex : array [0..(ffcl_MaxIndexFlds-1)] of Integer; //soner better (ffcl_MaxIndexFlds-1) original:array [0..pred(ffcl_MaxIndexFlds)] of Integer;
+ {fields in key for current index}
+ btIndexByName : Boolean;
+ {True if index specified by name, False, by fields}
+ btIndexDefs : TIndexDefs; {index definitions}
+ btIndexFieldCount : Integer;
+ {count of fields in key for current index}
+ btIndexFieldStr : string;
+ {list of field names in index, sep by semicolons}
+ btIndexID : Word; {index ID}
+ btIndexName : string; {index name}
+ btKeyBuffer : Pointer; {current key Buffer being edited}
+ btKeyBuffers : Pointer; {all Buffers for editing keys}
+ btKeyBufSize : Integer; {key Buffer length}
+ btKeyInfoOfs : Integer; {offset to key info in key Buffer}
+ btKeyLength : Integer; {key length for current index}
+ btLookupCursorID : TffCursorID; {lookup cursor}
+ btLookupIndexID : Integer; {lookup index ID}
+ btLookupIndexName : string; {lookup index name}
+ btLookupKeyFields : string; {key fields for lookup cursor}
+ btLookupNoCase : Boolean; {case insens. lookup cursor}
+ btMasterLink : TMasterDataLink; {link to the master table}
+ btNoCaseIndex : Boolean; {True=case insensitive index}
+ btRangeStack : TffTableRangeStack;
+ btIgnoreDataEvents: Boolean; {!!.06}
+ protected
+ {---Property access methods---}
+ function btGetFFVersion : string; {!!.11}
+ function btGetIndexField(aInx : Integer): TField;
+ function btGetIndexFieldNames : string;
+ function btGetIndexName : string;
+ function btGetKeyExclusive : Boolean;
+ function btGetKeyFieldCount : Integer;
+ function btGetMasterFields : string;
+ function btGetMasterSource : TDataSource;
+ procedure btSetKeyExclusive(const aValue : Boolean);
+ procedure btSetKeyFieldCount(const aValue : Integer);
+ procedure btSetIndexField(aInx : Integer; const aValue : TField);
+ procedure btSetIndexFieldNames(const aValue : string);
+ procedure btSetIndexName(const aValue : string);
+ procedure btSetMasterFields(const aValue : string);
+ procedure btSetMasterSource(const aValue : TDataSource);
+ procedure dsSetTableName(const aValue : string); override;
+ procedure btSetIndexDefs(Value : TIndexDefs); {!!.06}
+ function btIndexDefsStored : Boolean; {!!.06}
+
+
+ {---Record and key Buffer management---}
+ procedure dsAllocKeyBuffers; override;
+ procedure btEndKeyBufferEdit(aCommit : Boolean);
+ procedure btFreeKeyBuffers;
+ function GetActiveRecBuf(var aRecBuf : PChar): Boolean; override;
+ function btGetRecordForKey(aCursorID : TffCursorID;
+ bDirectKey : Boolean;
+ iFields : Word;
+ iLen : Word;
+ pKey : Pointer;
+ pRecBuff : Pointer
+ ) : TffResult;
+ procedure btInitKeyBuffer(aBuf : Pointer);
+ procedure btSetKeyBuffer(aInx : TffKeyEditType; aMustClear : Boolean);
+ procedure btSetKeyFields(aInx : TffKeyEditType;
+ const aValues : array of const);
+
+
+ {---Record access---}
+ function btLocateRecord(const aKeyFields : string;
+ const aKeyValues : Variant;
+ aOptions : TLocateOptions;
+ aSyncCursor: Boolean): Boolean;
+ function GetCursorProps(var aProps : TffCursorProps) : TffResult; override;
+
+ {---Field management---}
+ function btDoFldsMapToCurIdx(aFields : TList;
+ aNoCase : Boolean) : Boolean;
+
+ {---Index and key management---}
+ procedure btDecodeIndexDesc(const aIndexDesc : IDXDesc;
+ var aName, aFields : string;
+ var aOptions : TIndexOptions);
+ procedure btDestroyLookupCursor;
+ procedure dsGetIndexInfo; override;
+ function btGetIndexDesc(iIndexSeqNo : Word;
+ var idxDesc : IDXDesc) : TffResult;
+ function btGetIndexDescs(Desc : pIDXDesc) : TffResult;
+ function btGetLookupCursor(const aKeyFields : string;
+ aNoCase : Boolean): TffCursorID;
+ function btResetRange(aCursorID : TffCursorID;
+ SwallowSeqAccessError : Boolean) : Boolean; virtual;
+ procedure btResetRangePrim(aCursorID : TffCursorID;
+ SwallowSeqAccessError : Boolean);
+ procedure btRetrieveIndexName(const aNameOrFields : string;
+ aIndexByName : Boolean;
+ var aIndexName : string);
+ procedure btSetIndexTo(const aParam : string; aIndexByName : Boolean);
+ function btSetRange : Boolean;
+ function btSetRangePrim(aCursorID : TffCursorID;
+ bKeyItself : Boolean;
+ iFields1 : Word;
+ iLen1 : Word;
+ pKey1 : Pointer;
+ bKey1Incl : Boolean;
+ iFields2 : Word;
+ iLen2 : Word;
+ pKey2 : Pointer;
+ bKey2Incl : Boolean) : TffResult;
+ procedure btSwitchToIndex(const aIndexName : string);
+ function btSwitchToIndexEx(aCursorID : TffCursorID;
+ const aIndexName : string;
+ const aIndexID : Integer;
+ const aCurrRec : Boolean) : TffResult;
+
+ {---Modes---}
+ procedure btCheckKeyEditMode;
+
+ {---Master/detail stuff---}
+ procedure dsCheckMasterRange; override;
+ procedure btMasterChanged(Sender : TObject);
+ procedure btMasterDisabled(Sender : TObject);
+ procedure btSetLinkRange(aMasterFields : TList);
+
+ {---Handle stuff---}
+ procedure btChangeHandleIndex;
+ procedure DestroyHandle(aHandle : TffCursorID); override;
+ function GetCursorHandle(aIndexName : string) : TffCursorID; override;
+
+ {---TDataSet method overrides---}
+ {Opening, initializing and closing}
+ procedure InternalClose; override;
+ procedure InternalOpen; override;
+
+ function GetIsIndexField(Field : TField): Boolean; override;
+
+ {Record access and update}
+ procedure DoOnNewRecord; override;
+
+ {field access and update}
+ procedure SetFieldData(aField : TField; aBuffer : Pointer); override;
+
+ {filtering}
+ procedure SetFiltered(Value : Boolean); override;
+ procedure dsActivateFilters; override; {!!.03}
+ procedure dsDeactivateFilters; override; {!!.03}
+
+ {information}
+ procedure DataEvent(aEvent: db.TDataEvent; aInfo: Longint); override;//soner added: db.
+
+ {indexes - such that they exist at TDataSet level}
+ procedure UpdateIndexDefs; override;
+
+ {$IFDEF ProvidesDatasource}
+ function GetDataSource: TDataSource; override;
+ {$ENDIF}
+
+ property IndexDefs : TIndexDefs
+ read btIndexDefs
+ write btSetIndexDefs {!!.06}
+ stored btIndexDefsStored; {!!.06}
+
+ property IndexFields[aIndex: Integer]: TField
+ read btGetIndexField
+ write btSetIndexField;
+
+ property IndexFieldCount : Integer
+ read btIndexFieldCount;
+
+ property IndexID : Word
+ read btIndexID;
+
+ property KeyExclusive : Boolean
+ read btGetKeyExclusive
+ write btSetKeyExclusive;
+
+ property KeyFieldCount : Integer
+ read btGetKeyFieldCount
+ write btSetKeyFieldCount;
+
+ property KeySize : Integer
+ read btKeyLength;
+
+ property IndexFieldNames : string
+ read btGetIndexFieldNames
+ write btSetIndexFieldNames;
+
+ property IndexName : string
+ read btGetIndexName
+ write btSetIndexName;
+
+ property MasterFields : string
+ read btGetMasterFields
+ write btSetMasterFields;
+
+ property MasterSource : TDataSource
+ read btGetMasterSource
+ write btSetMasterSource;
+
+{Begin !!.11}
+ property FFVersion : string
+ read btGetFFVersion;
+ { Returns a formatted string (e.g., "2.1300") identifying the version
+ of FlashFiler with which the table was created. }
+{End !!.11}
+ public
+ constructor Create(aOwner : TComponent); override;
+ destructor Destroy; override;
+
+ procedure AddIndex(const aName, aFields : string;
+ aOptions : TIndexOptions);
+ function AddIndexEx(const aIndexDesc : TffIndexDescriptor;
+ var aTaskID : LongInt) : TffResult;
+ procedure ApplyRange;
+ procedure Cancel; override;
+ procedure CancelRange;
+// procedure CopyRecords(aSrcTable : TffTable; aCopyBLOBs : Boolean); {!!.06}
+ procedure CreateTable;
+ procedure CreateTableEx(const aBlockSize : Integer); {!!.05}
+ procedure DeleteIndex(const aIndexName : string);
+ procedure DeleteRecords; {!!.06}
+ procedure EditKey;
+ procedure EditRangeEnd;
+ procedure EditRangeStart;
+ function FindKey(const aKeyValues : array of const) : Boolean;
+ procedure FindNearest(const aKeyValues : array of const);
+ procedure GetIndexNames(aList : TStrings);
+ function GotoKey : Boolean;
+ procedure GotoNearest;
+ function Locate(const aKeyFields : string;
+ const aKeyValues : Variant;
+ aOptions : TLocateOptions) : Boolean; override;
+ function Lookup(const aKeyFields : string;
+ const aKeyValues : Variant;
+ const aResultFields : string) : Variant; override;
+ procedure Post; override;
+ function ReIndexTable(const aIndexNum : Integer;
+ var aTaskID : Longint) : TffResult;
+ procedure SetKey;
+ procedure SetRange(const aStartValues, aEndValues : array of const);
+ procedure SetRangeEnd;
+ procedure SetRangeStart;
+ end;
+
+ TffBaseDatabase = class(TffDBListItem)
+ protected {private}
+ bdAutoDBName : Boolean;
+ bdInTransaction : Boolean;
+ bdDatabaseID : TffDatabaseID;
+ bdTransactionCorrupted : Boolean;
+ bdExclusive : Boolean;
+ bdFailSafe : Boolean;
+ bdReadOnly : Boolean;
+ bdServerEngine : TffBaseServerEngine;
+// bdTemporary : Boolean; {Deleted !!.01}
+ bdTimeout : Longint;
+ protected
+ function bdGetDataSet(aInx : Integer) : TffDataSet;
+ function bdGetDataSetCount : Integer;
+ function bdGetDatabaseID : TffDatabaseID;
+ function bdGetSession : TffSession;
+ function bdGetServerEngine : TffBaseServerEngine;
+ procedure bdRefreshTimeout; {!!.11}
+ procedure bdSetAutoDBName(const Value : Boolean);
+ procedure bdSetDatabaseName(const aName : string);
+ procedure bdSetExclusive(aValue : Boolean);
+ procedure bdSetReadOnly(aValue : Boolean);
+ procedure bdSetTimeout(const Value : Longint);
+
+ function dbliCreateOwnedList : TffDBList; override;
+ function dbliFindDBOwner(const aName : string) : TffDBListItem; override;
+ procedure bdInformTablesAboutDestruction;
+ procedure dbliMustBeClosedError; override;
+ procedure dbliMustBeOpenError; override;
+ procedure dbliOpenPrim; override;
+
+ property AutoDatabaseName : Boolean
+ read bdAutoDBName
+ write bdSetAutoDBName
+ default False;
+
+ property DatabaseID : TffDatabaseID
+ read bdGetDatabaseID;
+
+ property DataSetCount : Integer
+ read bdGetDataSetCount;
+
+ property DataSets[aInx : Integer] : TffDataSet
+ read bdGetDataSet;
+
+ property ServerEngine : TffBaseServerEngine
+ read bdGetServerEngine;
+
+ property Session : TffSession
+ read bdGetSession;
+
+{Begin !!.01}
+// property Temporary : Boolean
+// read bdTemporary
+// write bdTemporary;
+{End !!.01}
+
+ property Connected;
+
+ property DatabaseName : string
+ read dbliDBName
+ write bdSetDatabaseName;
+
+ property Exclusive : Boolean
+ read bdExclusive
+ write bdSetExclusive
+ default False;
+
+ property ReadOnly : Boolean
+ read bdReadOnly
+ write bdSetReadOnly
+ default False;
+
+ property SessionName : string
+ read dbliGetDBOwnerName
+ write dbliSetDBOwnerName;
+
+ property Timeout : Longint
+ read bdTimeout
+ write bdSetTimeout
+ default -1;
+ { Timeout specified in milliseconds }
+ public
+ constructor Create(aOwner : TComponent); override;
+ destructor Destroy; override;
+
+ function GetFreeDiskSpace (var aFreeSpace : Longint) : TffResult;
+ function GetTimeout : Longint;
+ procedure CloseDataSets;
+ function IsSQLBased : Boolean;
+ function PackTable(const aTableName : TffTableName;
+ var aTaskID : LongInt) : TffResult;
+ procedure Commit;
+ function ReIndexTable(const aTableName : TffTableName;
+ const aIndexNum : Integer;
+ var aTaskID : Longint) : TffResult;
+ procedure Rollback;
+ procedure StartTransaction;
+ function StartTransactionWith(const aTables: array of TffBaseTable) : TffResult; {!!.10}
+ { Start a transaction, but only if an exclusive lock is obtained
+ for the specified tables. }
+ function TryStartTransaction : Boolean;
+ procedure TransactionCorrupted;
+ function TableExists(const aTableName : TffTableName) : Boolean;
+
+ {---Miscellaneous---}
+ function GetFFDataDictionary( { return a FlashFiler DD}
+ const TableName : TffTableName;
+ Stream : TStream
+ ) : TffResult;
+
+ property FailSafe : Boolean
+ read bdFailSafe
+ write bdFailSafe
+ default False;
+
+ property InTransaction : Boolean
+ read bdInTransaction;
+ end;
+
+ TffDatabase = class(TffBaseDatabase)
+ protected {private}
+ dcAliasName : string;
+ protected
+ procedure dcSetAliasName(const aName : string);
+
+ procedure dbliClosePrim; override;
+ procedure dbliOpenPrim; override;
+ public
+ function CreateTable(const aOverWrite : Boolean;
+ const aTableName : TffTableName;
+ aDictionary : TffDataDictionary) : TffResult;
+
+ procedure GetTableNames(aList : TStrings);
+
+ function RestructureTable(const aTableName : TffTableName;
+ aDictionary : TffDataDictionary;
+ aFieldMap : TStrings;
+ var aTaskID : LongInt) : TffResult;
+
+ property DatabaseID;
+ property DataSetCount;
+ property DataSets;
+ property ServerEngine;
+ property Session;
+ property Temporary;
+ published
+ property AliasName : string
+ read dcAliasName
+ write dcSetAliasName;
+
+ property AutoDatabaseName;
+ property Connected;
+ property DatabaseName;
+ property Exclusive;
+ property FailSafe;
+ property ReadOnly;
+ property SessionName;
+ property Timeout;
+ end;
+
+ TffDatabaseList = class(TffDBList)
+ protected {private}
+ function dlGetItem(aInx : Integer) : TffBaseDatabase;
+ public
+ property Databases[aInx : Integer] : TffBaseDatabase
+ read dlGetItem; default;
+ end;
+
+ TffTableProxy = class(TffDBListItem)
+ protected {private}
+ tpClosing : Boolean;
+ tpCursorID : TffCursorID;
+ tpDBGone : Boolean;
+ tpffTable : TffDataSet;
+ tpServerEngine: TffBaseServerEngine;
+ tpSession : TffSession;
+ tpSessionName : string;
+
+ protected
+ function tpGetCursorID : TffCursorID;
+ function tpGetDatabase : TffBaseDatabase;
+ function tpGetSession : TffSession;
+ function tpGetSessionName : string;
+ function tpGetServerEngine : TffBaseServerEngine;
+ procedure tpSetSessionName(aValue : string);
+
+ procedure dbliClosePrim; override;
+ function dbliFindDBOwner(const aName : string) : TffDBListItem; override;
+ procedure dbliLoaded; override;
+ procedure dbliMustBeClosedError; override;
+ procedure dbliMustBeOpenError; override;
+ procedure dbliOpenPrim; override;
+ procedure dbliDBOwnerChanged; override;
+
+ procedure tpDatabaseIsDestroyed;
+ procedure tpResolveSession;
+
+ property ffTable : TffDataSet
+ read tpffTable
+ write tpffTable;
+ public
+ constructor Create(aOwner : TComponent); override;
+
+ property CursorID : TffCursorID
+ read tpGetCursorID;
+
+ property Database : TffBaseDatabase
+ read tpGetDatabase;
+
+ property Session : TffSession
+ read tpGetSession;
+
+ property Active;
+
+ property DatabaseName : string
+ read dbliGetDBOwnerName
+ write dbliSetDBOwnerName;
+
+ property SessionName : string
+ read tpGetSessionName
+ write tpSetSessionName;
+
+ property ServerEngine : TffBaseServerEngine
+ read tpGetServerEngine;
+
+ property TableName : string
+ read dbliDBName
+ write dbliSetDBName;
+ end;
+
+ TffTableProxyList = class(TffDBList)
+ protected {private}
+ procedure dblFreeItem(aItem : TffDBListItem); override;
+ function tlGetItem(aInx : Integer) : TffTableProxy;
+ public
+ property Tables[aInx : Integer] : TffTableProxy
+ read tlGetItem; default;
+ end;
+
+
+ TffTable = class(TffBaseTable)
+ public
+ property CursorID;
+ property Database;
+ property Dictionary;
+ property FFVersion; {!!.11}
+ {$IFDEF Delphi3} {!!.01}
+ property IndexDefs;
+ {$ENDIF} {!!.01}
+ property IndexFields;
+ property IndexFieldCount;
+ property KeyExclusive;
+ property KeyFieldCount;
+ property KeySize;
+ published
+ property Active;
+ property AutoCalcFields;
+ property DatabaseName;
+ property Exclusive;
+{Begin !!.01}
+ {$IFDEF CBuilder3}
+ property FieldDefs;
+ {$ENDIF}
+ {$IFDEF Dcc4orLater}
+ property FieldDefs;
+ {$ENDIF}
+{End !!.01}
+ property Filter;
+ property Filtered;
+ property FilterEval;
+ property FilterOptions;
+ property FilterResync;
+ property FilterTimeout;
+{Begin !!.01}
+ {$IFDEF CBuilder3}
+ property IndexDefs;
+ {$ENDIF}
+ {$IFDEF Dcc4orLater}
+ property IndexDefs;
+ {$ENDIF}
+{End !!.01}
+ property IndexFieldNames;
+ property IndexName;
+ property MasterFields;
+ property MasterSource;
+ property ReadOnly;
+ property SessionName;
+ property TableName;
+ property Timeout;
+ property Version;
+
+ property BeforeOpen;
+ property AfterOpen;
+ property BeforeClose;
+ property AfterClose;
+ property BeforeInsert;
+ property AfterInsert;
+ property BeforeEdit;
+ property AfterEdit;
+ property BeforePost;
+ property AfterPost;
+ property BeforeCancel;
+ property AfterCancel;
+ property BeforeDelete;
+ property AfterDelete;
+ property BeforeScroll;
+ property AfterScroll;
+ {$IFDEF DCC5OrLater}
+ property BeforeRefresh;
+ property AfterRefresh;
+ {$ENDIF}
+ property OnCalcFields;
+ property OnDeleteError;
+ property OnEditError;
+ property OnFilterRecord;
+ property OnNewRecord;
+ property OnPostError;
+ property OnServerFilterTimeout;
+ end;
+
+ TffBlobStream = class(TStream)
+ private
+ bsRecBuf : PChar;
+ bsTable : TffDataSet;
+ bsField : TBlobField;
+ bsFieldNo : Integer;
+ bsMode : TBlobStreamMode;
+ bsModified : Boolean;
+ bsOpened : Boolean;
+ bsPosition : Longint;
+ bsChunkSize : Longint;
+ bsCancel : Boolean;
+
+ protected
+ function bsGetBlobSize : Longint;
+
+ public
+ constructor Create(aField : TBlobField; aMode : TBlobStreamMode);
+ destructor Destroy; override;
+
+ function Read(var aBuffer;
+ aCount : Longint)
+ : Longint; override;
+ function Write(const aBuffer; aCount: Longint) : Longint; override;
+ function Seek(aoffset : Longint; aOrigin : Word) : Longint; override;
+ procedure Truncate;
+
+ property CurrPosition : Longint
+ read bsPosition;
+
+ property CurrSize : Longint
+ read bsGetBlobSize;
+
+ property ChunkSize : Longint
+ read bsChunkSize
+ write bsChunkSize;
+
+ property CancelTransfer : Boolean
+ write bsCancel;
+ end;
+
+ TffQuery = class; { forward declaration }
+
+ {$IFDEF DCC4OrLater}
+ TffQueryDataLink = class(TDetailDataLink)
+ {$ELSE}
+ TffQueryDataLink = class(TDataLink)
+ {$ENDIF}
+ protected {private}
+ FQuery: TffQuery;
+ protected
+ procedure ActiveChanged; override;
+ procedure RecordChanged(Field: TField); override;
+ {$IFDEF DCC4OrLater}
+ function GetDetailDataSet: TDataSet; override;
+ {$ENDIF}
+ procedure CheckBrowseMode; override;
+ public
+ constructor Create(aQuery: TffQuery);
+ end;
+
+
+ TffQuery = class(TffDataSet)
+ protected {private}
+ FCanModify : Boolean; {!!.10}
+ FDataLink : TDataLink;
+ FExecuted : boolean;
+ { Set to True if statement has been executed. }
+ FParamCheck : boolean;
+ FParams : TParams;
+ FPrepared : boolean;
+ FRequestLive : boolean;
+ FRowsAffected : Integer; {!!.10}
+ FRecordsRead : Integer; {!!.10}
+ FSQL : TStrings;
+ FStmtID : TffSqlStmtID;
+ FText : string;
+
+ {$IFDEF DCC4OrLater}
+ procedure DefineProperties(Filer : TFiler); override;
+ {$ENDIF}
+ procedure DestroyHandle(aHandle : TffCursorID); override;
+ procedure dsCloseViaProxy; override;
+ function dsGetServerEngine : TffBaseServerEngine; override;
+ function GetCanModify : Boolean; override;
+ function GetCursorHandle(aIndexName : string) : TffCursorID; override;
+ function GetCursorProps(var aProps : TffCursorProps) : TffResult; override;
+ procedure InternalClose; override;
+ procedure quBuildParams(var ParamsList : PffSqlParamInfoList;
+ var ParamsData : PffByteArray;
+ var ParamsDataLen : integer);
+ {-Constructs the parameter data sent to the server. }
+ procedure quDisconnect;
+ procedure quExecSQLStmt(const aOpenMode : TffOpenMode;
+ var aCursorID : TffCursorID);
+ procedure quFreeStmt;
+ function quGetDataSource : TDataSource;
+ function quGetParamCount : Word;
+ function quGetRowsAffected : Integer; {!!.10}
+{Begin !!.01}
+ function quLocateRecord(const aKeyFields : string;
+ const aKeyValues : Variant;
+ aOptions : TLocateOptions;
+ aSyncCursor: Boolean): Boolean;
+{End !!.01}
+ function quParseSQL(aStmt : string; createParams : boolean;
+ aParams : TParams) : string;
+ procedure quPreparePrim(prepare : boolean);
+ {$IFDEF DCC4OrLater}
+ procedure quReadParams(Reader : TReader);
+ {$ENDIF}
+ procedure quRefreshParams;
+ procedure quSetDataSource(aSrc : TDataSource);
+ procedure quSetParams(aParamList : TParams);
+ procedure quSetParamsFromCursor;
+ procedure quSetPrepared(aFlag : boolean);
+ procedure quSetRequestLive(aFlag : boolean);
+ procedure quSetSQL(aValue : TStrings);
+ procedure quSQLChanged(Sender : TObject);
+ {-Called when the SQL property changes. Allows us to update the
+ Params property. }
+ {$IFDEF DCC4OrLater}
+ procedure quWriteParams(Writer : TWriter);
+ {$ENDIF}
+
+ property DataLink : TDataLink
+ read FDataLink;
+
+ public
+ constructor Create(aOwner : TComponent); override;
+ destructor Destroy; override;
+ procedure ExecSQL; {!!.10}
+{Begin !!.01}
+ function Locate(const aKeyFields : string;
+ const aKeyValues : Variant;
+ aOptions : TLocateOptions) : Boolean; override;
+{End !!.01}
+ function Lookup(const aKeyFields : string;
+ const aKeyValues : Variant;
+ const aResultFields : string) : Variant; override;
+
+ function ParamByName(const aName : string) : TParam;
+ procedure Prepare;
+ procedure Unprepare;
+
+ property Prepared : boolean
+ read FPrepared
+ write quSetPrepared;
+ property RowsAffected : Integer {!!.10}
+ read quGetRowsAffected;
+ property RecordsRead: Integer read FRecordsRead; {!!.10}
+ property Text : string
+ read FText;
+
+ published
+ property Active;
+ property AutoCalcFields;
+ property DatabaseName;
+ property DataSource : TDataSource
+ read quGetDataSource
+ write quSetDataSource;
+ property Filter;
+ property Filtered;
+ property FilterEval;
+ property FilterOptions;
+ property FilterResync;
+ property FilterTimeout;
+ property ParamCheck : boolean
+ read FParamCheck
+ write FParamCheck
+ default True;
+ property ParamCount : Word
+ read quGetParamCount;
+ property Params : TParams
+ read FParams
+ write quSetParams
+ stored False;
+ property RequestLive : boolean
+ read FRequestLive
+ write quSetRequestLive
+ default False;
+ property SessionName;
+ property SQL : TStrings
+ read FSQL
+ write quSetSQL;
+ property StmtHandle : TffSqlStmtID
+ read FStmtID;
+ property Timeout;
+ property Version;
+
+ { Events }
+ property BeforeOpen;
+ property AfterOpen;
+ property BeforeClose;
+ property AfterClose;
+ property BeforeInsert;
+ property AfterInsert;
+ property BeforeEdit;
+ property AfterEdit;
+ property BeforePost;
+ property AfterPost;
+ property BeforeCancel;
+ property AfterCancel;
+ property BeforeDelete;
+ property AfterDelete;
+ property BeforeScroll;
+ property AfterScroll;
+ {$IFDEF DCC5OrLater}
+ property BeforeRefresh;
+ property AfterRefresh;
+ {$ENDIF}
+ property OnCalcFields;
+ property OnDeleteError;
+ property OnEditError;
+ property OnFilterRecord;
+ property OnNewRecord;
+ property OnPostError;
+ property OnServerFilterTimeout;
+ end;
+
+
+{---Helper routines---}
+function FindAutoFFClient : TffBaseClient;
+{ Find the automatically created client component}
+
+function FindDefaultFFClient : TffBaseClient;
+{ Find the default Client component }
+
+function FindDefaultFFSession : TffSession;
+{ Find the default session }
+
+function FindFFClientName(const aName : string) : TffBaseClient;
+{ Find a client by name}
+
+function FindFFSessionName(const aName : string) : TffSession;
+{ Find a session object by name }
+
+function FindFFDatabaseName(aSession : TffSession;
+ const aName : string;
+ const aCreate : Boolean) : TffBaseDatabase;
+{ Find a database object by name}
+
+function GetDefaultFFClient : TffBaseClient;
+{ Return the default client. If one doesn't exist, raise
+ an exception}
+
+function GetDefaultFFSession : TffSession;
+{ Return the default session. If one does not exist, raise
+ an exception}
+
+procedure GetFFClientNames(aList : TStrings);
+{ Populate a list with the names of all TffBaseClient instances}
+
+procedure GetFFSessionNames(aList : TStrings);
+{ Populate a list with the names of all TffSession instances}
+
+procedure GetFFDatabaseNames(aSession : TffSession; aList : TStrings);
+
+{ Populate a list with all TffBaseDatabase instances }
+
+function Session : TffSession;
+{ Return the default session component}
+
+function FFSession : TffSession;
+{ Return the default session component. Included to ease confusion
+ when writing applications that use both the BDE and FlashFiler}
+
+const
+ { 0 means do not limit "chunk" sizes, any other value determines }
+ { the maximum number of bytes read/written to the server at once}
+ ffMaxBlobChunk : Integer = 64000;
+
+{---Global variables---}
+var
+ Clients : TffClientList;
+
+implementation
+
+{Notes: A record Buffer is in the following format
+ - physical record Buffer
+ (offset 0, length RecordSize)
+ - calculated fields Buffer
+ (offset dsCalcFldOfs, length CalcFieldSize)
+ - bookmark data
+ (offset dsBookmarkOfs, length BookmarkSize)
+ - TDataSetRecInfo data
+ (offset dsRecInfoOfs, length sizeof(TDataSetRecInfo))
+ A key Buffer is in the following format
+ - physical record Buffer
+ (offset 0, length RecordSize)
+ - TKeyRecInfo data
+ (offset btKeyInfoOfs, length sizeof(TKeyRecInfo))
+ TDataSet maintains an array of record Buffers.
+ TffTable maintains an array of key Buffers, one for each of
+ the TffKeyEditType enum values}
+
+uses
+ Forms,
+ TypInfo,
+ {$IFDEF HasNonComVariant}
+ Variant,
+ {$ENDIF}
+ ffconst,
+ ffllexcp,
+ ffclconv,
+ ffclintf,
+{$IFDEF AutoLog} {!!.01}
+ fflllog, {!!.01}
+{$ENDIF} {!!.01}
+ Dialogs,
+ ffutil
+ {$ifdef fpc}{$ifndef DONTUSEDELPHIUNIT},lazcommon{lazffdelphi1}{$endif}{$endif} //soner added: lazffdelphi1
+ ;
+
+//soner von unten hierhin:
+resourcestring
+ cMsg = 'The connection to the server has been lost. Reconnect?';
+
+{$UNDEF DeclareMissingIdentifiers}
+{$IFDEF DCC5OrLater} {!!.11}
+{$DEFINE DeclareMissingIdentifiers}
+{$ENDIF}
+
+{$IFDEF DeclareMissingIdentifiers}
+{Note: In Delphi 3, 4 and C++Builder 3, 4, the following constants
+ were defined in DBCOMMON.PAS and were available to third-party
+ database engine developers. In Delphi 5, they were moved to
+ DBTABLES.PAS which, because of the initialization section
+ cannot be used as a unit in ffDB. Hence these definitions are
+ copied here from Delphi 5's DBTABLES.PAS. A bug report has been
+ filed with Borland.}
+const
+
+ {$IFNDEF DCC6OrLater}
+ FldTypeMap: TFieldMap = (
+ fldUNKNOWN, fldZSTRING, fldINT16, fldINT32, fldUINT16, fldBOOL,
+ fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,
+ fldVARBYTES, fldINT32, fldBLOB, fldBLOB, fldBLOB, fldBLOB, fldBLOB,
+ fldBLOB, fldBLOB, fldCURSOR, fldZSTRING, fldZSTRING, fldINT64, fldADT,
+ fldArray, fldREF, fldTABLE, fldBLOB, fldBLOB, fldUNKNOWN, fldUNKNOWN,
+ fldUNKNOWN, fldZSTRING);
+
+ DataTypeMap: array[0..MAXLOGFLDTYPES - 1] of TFieldType = (
+ ftUnknown, ftString, ftDate, ftBlob, ftBoolean, ftSmallint,
+ ftInteger, ftFloat, ftBCD, ftBytes, ftTime, ftDateTime,
+ ftWord, ftInteger, ftUnknown, ftVarBytes, ftUnknown, ftUnknown,
+ ftLargeInt, ftLargeInt, ftADT, ftArray, ftReference, ftDataSet);
+
+ {$ELSE}
+ FldTypeMap: TFieldMap = (
+ fldUNKNOWN, fldZSTRING, fldINT16, fldINT32, fldUINT16, fldBOOL,
+ fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,
+ fldVARBYTES, fldINT32, fldBLOB, fldBLOB, fldBLOB, fldBLOB, fldBLOB,
+ fldBLOB, fldBLOB, fldCURSOR, fldZSTRING, fldZSTRING, fldINT64, fldADT,
+ fldArray, fldREF, fldTABLE, fldBLOB, fldBLOB, fldUNKNOWN, fldUNKNOWN,
+ fldUNKNOWN, fldZSTRING, fldTIMESTAMP, fldBCD,
+ fldZSTRING, fldBLOB //soner für: ftFixedWideChar, ftWideMemo // von fpc.db.pas
+ );
+
+ DataTypeMap: array[0..MAXLOGFLDTYPES - 1] of TFieldType = (
+ ftUnknown, ftString, ftDate, ftBlob, ftBoolean, ftSmallint,
+ ftInteger, ftFloat, ftBCD, ftBytes, ftTime, ftDateTime,
+ ftWord, ftInteger, ftUnknown, ftVarBytes, ftUnknown, ftUnknown,
+ ftLargeInt, ftLargeInt, ftADT, ftArray, ftReference, ftDataSet,
+ ftTimeStamp, ftFMTBCD);
+
+ {$ENDIF}
+
+ BlobTypeMap: array[fldstMEMO..fldstBFILE] of TFieldType = (
+ ftMemo, ftBlob, ftFmtMemo, ftParadoxOle, ftGraphic, ftDBaseOle,
+ ftTypedBinary, ftBlob, ftBlob, ftBlob, ftBlob, ftOraClob, ftOraBlob,
+ ftBlob, ftBlob);
+{$ENDIF}
+
+const
+ ffcClientName = 'ClientName';
+ ffcDatabaseName = 'DatabaseName';
+ ffcSessionName = 'SessionName';
+ ffcTableName = 'TableName';
+ {$IFDEF AutoLog}
+ ffcAutoLogfile = 'FFAutoTrans.log';
+ {$ENDIF}
+
+type
+ PffFLDDescArray = ^TffFLDDescArray;
+ TffFLDDescArray = array [0..($ffE0 div sizeof(FLDDesc))] of FLDDesc;
+
+ PffIDXDescArray = ^TffIDXDescArray;
+ TffIDXDescArray = array [0..($ffE0 div sizeof(IDXDesc))] of IDXDesc;
+
+ PffVCHKDescArray = ^TffVCHKDescArray;
+ TffVCHKDescArray = array [0..($ff00 div sizeof(VCHKDesc))] of VCHKDesc;
+
+
+type
+ PDataSetRecInfo = ^TDataSetRecInfo;
+ TDataSetRecInfo = packed record
+ riBookmarkFlag : TBookmarkFlag;
+ riRecNo : TffWord32;
+ end;
+
+ PKeyRecInfo = ^TKeyRecInfo;
+ TKeyRecInfo = packed record
+ kriFieldCount : Integer; {for the KeyFieldCount property}
+ kriExclusive : Boolean; {for the KeyExclusive property}
+ kriModified : Boolean; {data in Buffer has been modified}
+ end;
+
+ PKeyBuffers = ^TKeyBuffers;
+ TKeyBuffers = array [TffKeyEditType] of Pointer;
+
+{$IFDEF SingleEXE}
+var
+ ServerEngine : TffServerEngine;
+{$ENDIF}
+
+{== Database object search routines ==================================}
+function IsFFAliasName(aSession : TffSession;
+ aName : string)
+ : Boolean;
+var
+ i : Integer;
+ AliasList : TStringList;
+begin
+ if (aSession = nil) or (aName = '') then begin
+ Result := False;
+ Exit;
+ end;
+ Result := True;
+ AliasList := TStringList.Create;
+ try
+ aSession.GetAliasNamesEx(AliasList, False);
+ for i := 0 to pred(AliasList.Count) do
+ if (FFAnsiCompareText(AliasList[i], aName) = 0) then {!!.10}
+ Exit;
+ finally
+ AliasList.Free;
+ end;{try..finally}
+ Result := False;
+end;
+{--------}
+function IsFFDatabaseName(aSession : TffSession;
+ aName : string)
+ : Boolean;
+var
+ DB : TffDbListItem;
+begin
+ if (aSession = nil) or (aName = '') then
+ Result := False
+ else
+ Result := aSession.OwnedDBItems.FindItem(aName, DB);
+end;
+{--------}
+function FindAutoffClient : TffBaseClient;
+begin
+ Result := FindFFClientName(AutoObjName);
+end;
+{--------}
+function FindDefaultFFClient : TffBaseClient;
+var
+ Inx : Integer;
+begin
+ Assert(Assigned(Clients));
+ Clients.BeginRead; {!!.02}
+ try {!!.02}
+ for Inx := 0 to Pred(Clients.Count) do begin
+ Result := TffBaseClient(Clients[Inx]);
+ if Result.IsDefault then
+ Exit;
+ end;
+ finally {!!.02}
+ Clients.EndRead; {!!.02}
+ end; {!!.02}
+ Result := nil;
+end;
+{--------}
+function FindDefaultFFSession : TffSession;
+var
+ CL : TffBaseClient;
+begin
+ CL := FindDefaultFFClient;
+ if Assigned(CL) then
+ Result := CL.bcGetDefaultSession
+ else
+ Result := nil;
+end;
+{--------}
+function FindFFClientName(const aName : string) : TffBaseClient;
+begin
+ Assert(Assigned(Clients));
+ if aName = '' then
+ Result := nil
+ else
+ if not Clients.FindItem(aName, TffDBListItem(Result)) then
+ Result := nil;
+end;
+{--------}
+function FindFFSessionName(const aName : string) : TffSession;
+var
+ CEInx : Integer;
+begin
+ Assert(Assigned(Clients));
+ if aName = '' then
+ Result := nil
+ else begin
+ Clients.BeginRead; {!!.02}
+ try {!!.02}
+ for CEInx := 0 to pred(Clients.Count) do begin
+ if (Clients[CEInx]).
+ OwnedDBItems.
+ FindItem(aName, TffDBListItem(Result)) then
+ Exit;
+ end;
+ finally {!!.02}
+ Clients.EndRead; {!!.02}
+ end; {!!.02}
+ Result := nil;
+ end;
+end;
+{--------}
+function FindFFDatabaseName(aSession : TffSession;
+ const aName : string;
+ const aCreate : Boolean) : TffBaseDatabase;
+var
+ i : Integer;
+ AliasList : TStringList;
+begin
+ if (aName = '') or (aSession = nil) then begin
+ Result := nil;
+ Exit;
+ end;
+ { if the database is found, set result and exit}
+ if aSession.OwnedDBItems.FindItem(aName, TffDBListItem(Result)) then
+ Exit;
+ if aCreate then begin
+ AliasList := TStringList.Create;
+ try
+ aSession.GetAliasNamesEx(AliasList, False);
+ { if the alias is valid, create the database and exit }
+ for i := 0 to pred(AliasList.Count) do
+ if (FFAnsiCompareText(AliasList[i], aName) = 0) then begin {!!.07}
+ Result := TffDatabase.Create(nil);
+ Result.dbliSwitchOwnerTo(aSession); {!!.01}
+// Result.SessionName := aSession.SessionName; {Deleted !!.01}
+ Result.DatabaseName := aName;
+ Result.Temporary := True;
+ Exit;
+ end;
+ finally
+ AliasList.Free;
+ end;
+ end;
+ { the database was not found, or the alias did not exist }
+ Result := nil;
+end;
+{--------}
+function GetDefaultFFClient : TffBaseClient;
+begin
+ Result := FindDefaultFFClient;
+ if (Result = nil) then
+ raise EffDatabaseError.Create(ffStrResDataSet[ffdse_NoDefaultCL]);
+end;
+{--------}
+function GetDefaultFFSession : TffSession;
+begin
+ Result := GetDefaultFFClient.bcGetDefaultSession;
+ if (Result = nil) then
+ raise EffDatabaseError.Create(ffStrResDataSet[ffdse_NoSessions]);
+end;
+{--------}
+procedure GetFFDatabaseNames(aSession : TffSession; aList : TStrings);
+begin
+ Assert(Assigned(aList));
+ Assert(Assigned(aSession));
+ aList.BeginUpdate;
+ try
+ aList.Clear;
+ aSession.OwnedDBItems.GetItemNames(aList);
+ aSession.GetAliasNamesEx(aList, False);
+ finally
+ aList.EndUpdate;
+ end;
+end;
+{--------}
+function FFSession : TffSession;
+begin
+ Result := GetDefaultffSession;
+end;
+{--------}
+function Session : TffSession;
+begin
+ Result := FFSession;
+end;
+
+{====================================================================}
+
+
+{===Database object name lists=======================================}
+procedure GetFFClientNames(aList : TStrings);
+begin
+ Assert(Assigned(Clients));
+ Assert(Assigned(aList));
+ aList.BeginUpdate;
+ try
+ aList.Clear;
+ Clients.GetItemNames(aList);
+ finally
+ aList.EndUpdate;
+ end;
+end;
+{--------}
+procedure GetFFSessionNames(aList : TStrings);
+var
+ Inx : Integer;
+begin
+ Assert(Assigned(Clients));
+ Assert(Assigned(aList));
+ Clients.BeginRead; {!!.02}
+ try {!!.02}
+ for Inx := 0 to Pred(Clients.Count) do
+ Clients[Inx].OwnedDBItems.GetItemNames(aList);
+ finally {!!.02}
+ Clients.EndRead; {!!.02}
+ end; {!!.02}
+end;
+{====================================================================}
+
+{===TffFilterListItem==================================================}
+constructor TffFilterListItem.Create(aContainer : TffCollection;
+ aOwner : TObject;
+ aClientData: Longint;
+ aPriority : Integer;
+ aCanAbort : Boolean;
+ aExprTree : pCANExpr;
+ aFiltFunc : pfGENFilter);
+begin
+ inherited Create(nil, aContainer);
+
+ fliOwner := aOwner;
+ fliClientData := aClientData;
+ fliPriority := aPriority;
+ fliCanAbort := aCanAbort;
+ if Assigned(aExprTree) then begin
+ fliExprSize := pCANExpr(aExprTree)^.iTotalSize;
+ if (fliExprSize > 0) then begin
+ FFGetMem(fliExpression, fliExprSize);
+ Move(aExprTree^, fliExpression^, fliExprSize);
+ end;
+ end;
+ fliFilterFunc := aFiltFunc;
+ fliActive := False;
+end;
+{--------}
+destructor TffFilterListItem.Destroy;
+begin
+ if (fliExprSize > 0) and Assigned(fliExpression) then
+ FFFreeMem(fliExpression, fliExprSize);
+
+ inherited Destroy;
+end;
+{--------}
+function TffFilterListItem.fliGetLiteralPtr(aoffset : Word) : Pointer;
+var
+ i : Word;
+begin
+ i := fliExpression^.iLiteralStart + aoffset;
+ Result := @PByteArray(fliExpression)^[i];
+end;
+{--------}
+function TffFilterListItem.fliGetNodePtr(aoffset : Word) : PffFilterNode;
+var
+ i : Word;
+begin
+ i := fliExpression^.iNodeStart + aoffset;
+ Result := PffFilterNode(@PByteArray(fliExpression)^[i]);
+end;
+{--------}
+procedure TffFilterListItem.GetFilterInfo(Index : Word;
+ var FilterInfo : FilterInfo);
+begin
+ {Initialize}
+ FillChar(FilterInfo, sizeof(FilterInfo), 0);
+
+ {Set info}
+ FilterInfo.iFilterId := Index;
+ FilterInfo.hFilter := @Self;
+ FilterInfo.iClientData := fliClientData;
+ FilterInfo.iPriority := fliPriority;
+ FilterInfo.bCanAbort := fliCanAbort;
+ FilterInfo.pffilter := fliFilterFunc;
+ FilterInfo.pCanExpr := fliExpression;
+ FilterInfo.bActive := fliActive;
+end;
+{--------}
+function TffFilterListItem.MatchesRecord(aRecBuf : Pointer) : Boolean;
+var
+ FiltFuncResult : Integer;
+ Root : PffFilterNode;
+begin
+ {inactive filters match all records, ie, no filtering takes place}
+ if not Active then
+ Result := True
+ {otherwise, with active filters we must do some work}
+ else begin
+ {call the filter function first}
+ if Assigned(fliFilterFunc) then begin
+ FiltFuncResult := fliFilterFunc(fliClientData, aRecBuf, 0);
+ if fliCanAbort and (FiltFuncResult = FFClBDE.ABORT) then begin
+ Result := False;
+ Exit;
+ end;
+ Result := FiltFuncResult <> 0;
+ end
+ else {there is no filter function, ergo it matches}
+ Result := True;
+
+ {if the record matches so far, run it through the filter tree}
+ if Result and Assigned(fliExpression) then begin
+ Root := fliGetNodePtr(0);
+ Result := fliEvaluateNode(Root, nil, aRecBuf);
+ end;
+ end;
+end;
+{--------}
+function TffFilterListItem.fliEvaluateNode(aNode : PffFilterNode;
+ aValue : PffNodeValue;
+ aRecBuf : Pointer) : Boolean;
+begin
+ if (aValue <> nil) then
+ FillChar(aValue^, sizeof(aValue^), 0);
+ case aNode^.fnHdr.NodeClass of
+ FFSrBDE.nodeUNARY:
+ Result := fliEvaluateUnaryNode(aNode, aRecBuf);
+ FFSrBDE.nodeBINARY:
+ if (aNode^.fnHdr.CANOp in [canAND, canOR]) then
+ Result := fliEvaluateLogicalNode(aNode, aRecBuf)
+ else
+ Result := fliEvaluateBinaryNode(aNode, aRecBuf, False, 0);
+ FFSrBDE.nodeCOMPARE:
+ Result := fliEvaluateBinaryNode(aNode, aRecBuf,
+ aNode^.fnCompare.bCaseInsensitive,
+ aNode^.fnCompare.iPartialLen);
+ FFSrBDE.nodeFIELD:
+ Result := fliEvaluateFieldNode(aNode, aValue, aRecBuf);
+ FFSrBDE.nodeCONST:
+ Result := fliEvaluateConstNode(aNode, aValue, aRecBuf);
+ FFSrBDE.nodeCONTINUE:
+ Result := aNode^.fnContinue.iContOperand <> 0;
+ else
+ {all other node classes cause the node match to fail}
+ Result := False;
+ end;{case}
+end;
+{--------}
+function TffFilterListItem.fliEvaluateUnaryNode(aNode : PffFilterNode;
+ aRecBuf : Pointer) : Boolean;
+var
+ OperandNode : PffFilterNode;
+ NodeValue : TffNodeValue;
+begin
+ OperandNode := fliGetNodePtr(aNode^.fnUnary.iOperand1);
+ if fliEvaluateNode(OperandNode, @NodeValue, aRecBuf) then
+ case aNode^.fnHdr.CANOp of
+ canISBLANK:
+ Result := NodeValue.nvIsNull;
+ canNOTBLANK:
+ Result := not NodeValue.nvIsNull;
+ else
+ Result := False;
+ end {case}
+ else { the node didn't match }
+ Result := aNode^.fnHdr.CANOp = canNOT;
+end;
+{--------}
+function TffFilterListItem.fliEvaluateLogicalNode(aNode : PffFilterNode;
+ aRecBuf : Pointer) : Boolean;
+var
+ LeftNode : PffFilterNode;
+ RightNode : PffFilterNode;
+begin
+ LeftNode := fliGetNodePtr(aNode^.fnBINARY.iOperand1);
+ RightNode := fliGetNodePtr(aNode^.fnBINARY.iOperand2);
+ case aNode^.fnHdr.CANOp of
+ canAND : Result := fliEvaluateNode(LeftNode, nil, aRecBuf) and
+ fliEvaluateNode(RightNode, nil, aRecBuf);
+ canOR : Result := fliEvaluateNode(LeftNode, nil, aRecBuf) or
+ fliEvaluateNode(RightNode, nil, aRecBuf);
+ else
+ {anything else fails}
+ Result := False;
+ end;{case}
+end;
+{--------}
+function TffFilterListItem.fliEvaluateBinaryNode(aNode : PffFilterNode;
+ aRecBuf : Pointer;
+ aNoCase : Boolean;
+ aPartial: Word) : Boolean;
+var
+ LeftNode : PffFilterNode;
+ RightNode : PffFilterNode;
+ LeftValue : TffNodeValue;
+ RightValue : TffNodeValue;
+ CompareResult : Integer;
+begin
+ Result := False;
+ if (aNode^.fnHdr.NodeClass = FFSrBDE.nodeCOMPARE) then begin
+ LeftNode := fliGetNodePtr(aNode^.fnCompare.iOperand1);
+ RightNode := fliGetNodePtr(aNode^.fnCompare.iOperand2);
+ end else begin
+ LeftNode := fliGetNodePtr(aNode^.fnBINARY.iOperand1);
+ RightNode := fliGetNodePtr(aNode^.fnBINARY.iOperand2);
+ end;
+ if not fliEvaluateNode(LeftNode, @LeftValue, aRecBuf) then
+ Exit;
+ if not fliEvaluateNode(RightNode, @RightValue, aRecBuf) then
+ Exit;
+ if not fliCompareValues(CompareResult, LeftValue, RightValue,
+ aNoCase, aPartial) then
+ Exit;
+ case aNode^.fnHdr.CANOp of
+ canEQ : Result := CompareResult = 0;
+ canNE : Result := CompareResult <> 0;
+ canGT : Result := CompareResult > 0;
+ canLT : Result := CompareResult < 0;
+ canGE : Result := CompareResult >= 0;
+ canLE : Result := CompareResult <= 0;
+ else
+ {anything else fails}
+ Result := False;
+ end;{case}
+end;
+{--------}
+function TffFilterListItem.fliEvaluateConstNode(aNode : PffFilterNode;
+ aValue : PffNodeValue;
+ aRecBuf : Pointer) : Boolean;
+begin
+ aValue^.nvType := aNode^.fnConst.iType;
+ aValue^.nvSize := aNode^.fnConst.iSize;
+ aValue^.nvValue := fliGetLiteralPtr(aNode^.fnConst.ioffset);
+ aValue^.nvIsNull := False;
+ aValue^.nvIsConst := True;
+ Result := True;
+end;
+{--------}
+function TffFilterListItem.fliEvaluateFieldNode(aNode : PffFilterNode;
+ aValue : PffNodeValue;
+ aRecBuf : Pointer) : Boolean;
+var
+ FieldDesc : TffFieldDescItem;
+ RecBufAsBytes : PByteArray absolute aRecBuf;
+ FilterFldName : PChar;
+begin
+ TffDataSet(fliOwner).dsGetFieldDescItem(aNode^.fnFIELD.iFieldNum, FieldDesc);
+
+ {get round InfoPower filter bug}
+ {the bug is this: the iFieldNum field of the node is supposed to be
+ the field number of the field we are interested in (field 1 being
+ the first field in the record, 2 the second field); InfoPower's
+ filter parsing code sets it to a field count instead, starting at 1
+ and incrementing for every field encountered in the filter string.
+ We'll patch the filter binary block the first time through since
+ GetFieldNumber is relatively slow.}
+ FilterFldName := fliGetLiteralPtr(aNode^.fnFIELD.iNameoffset);
+ if (FFAnsiStrIComp(FilterFldName, FieldDesc.PhyDesc^.szName) <> 0) then begin {!!.06, !!.07}
+ {patch the filter block, so we don't keep on doing this}
+ aNode^.fnFIELD.iFieldNum :=
+ TffDataSet(fliOwner).dsGetFieldNumber(FilterFldName);
+ TffDataSet(fliOwner).dsGetFieldDescItem(aNode^.fnFIELD.iFieldNum, FieldDesc);
+ end;
+
+ aValue^.nvType := FieldDesc.PhyDesc^.iFldType;
+ aValue^.nvSize := FieldDesc.PhyDesc^.iLen;
+ aValue^.nvValue := @RecBufAsBytes^[FieldDesc.PhyDesc^.ioffset];
+ aValue^.nvIsConst := False;
+ TffDataSet(fliOwner).dsTranslateGet(FieldDesc, aRecBuf, nil, aValue^.nvIsNull);
+
+ Result := True;
+end;
+{--------}
+function TffFilterListItem.fliCompareValues(var aCompareResult : Integer;
+ var aFirst : TffNodeValue;
+ var aSecond : TffNodeValue;
+ aIgnoreCase : Boolean;
+ aPartLen : Integer): Boolean;
+begin
+ Result := True;
+ {Deal with nulls first, we don't have to ask the table to do it
+ since null < any value, except null}
+ if aFirst.nvIsNull then
+ if aSecond.nvIsNull then begin
+ aCompareResult := 0;
+ Exit;
+ end else begin
+ aCompareResult := -1;
+ Exit;
+ end
+ else {aFirst is not null} if aSecond.nvIsNull then begin
+ aCompareResult := 1;
+ Exit;
+ end;
+ {Otherwise let the table deal with it since some translation may be
+ required}
+ aCompareResult := TffDataSet(fliOwner).dsTranslateCmp(aFirst,
+ aSecond,
+ aIgnoreCase,
+ aPartLen);
+end;
+
+
+{===TffBaseClient===================================================}
+constructor TffBaseClient.Create(aOwner : TComponent);
+begin
+ inherited Create(aOwner);
+
+ dbliReqPropName := ffcClientName;
+ bcAutoClientName := False;
+ bcBeepOnLoginError := True; {!!.06}
+ bcOwnServerEngine := False;
+ bcServerEngine := nil;
+ bcClientID := 0;
+ bcPasswordRetries := ffclLoginRetries;
+ bcUserName := ffclUserName;
+ bcTimeOut := DefaultTimeOut;
+ dbliNeedsNoOwner := True;
+ {add ourselves to the global comms engine list}
+ Clients.AddItem(Self);
+ dbliLoadPriority := 1;
+
+ bcOnConnectionLost := IDEConnectionLost;
+end;
+{--------}
+destructor TffBaseClient.Destroy;
+begin
+ FFNotifyDependents(ffn_Destroy);
+
+ Close;
+
+ if bcOwnServerEngine then begin
+ if ServerEngine is TffRemoteServerEngine then
+ TffRemoteServerEngine(ServerEngine).Transport.Free;
+ ServerEngine.Free;
+ ServerEngine := nil;
+ bcOwnServerEngine := False; {!!.06}
+ end;
+
+ if Assigned(ServerEngine) then
+ ServerEngine.FFRemoveDependent(Self);
+
+ {make sure we're no longer the default}
+ if IsDefault then
+ IsDefault := False;
+
+ {remove ourselves from the global comms engine list}
+ if Assigned(Clients) then
+ Clients.DeleteItem(Self);
+
+ inherited Destroy;
+end;
+{--------}
+procedure TffBaseClient.IDEConnectionLost(aSource : TObject;
+ aStarting : Boolean;
+ var aRetry : Boolean);
+begin
+ if aStarting then begin
+ aRetry := MessageDlg(cMsg, mtError, [mbYes, mbNo], 0) = mrYes
+ end else
+ if aRetry and (aSource is TffBaseClient) then
+ if TffBaseClient(aSource).ClientID <= 0 then begin
+ MessageDlg('Reconnect was unsuccessful', mtInformation, [mbOK], 0);
+ end;
+end;
+{Begin !!.06}
+{--------}
+type
+ TffServerCracker = class(TffBaseServerEngine);
+{--------}
+function TffBaseClient.ProcessRequest(aMsgID : Longint;
+ aTimeout : Longint;
+ aRequestData : Pointer;
+ aRequestDataLen : Longint;
+ aRequestDataType : TffNetMsgDataType;
+ var aReply : Pointer;
+ var aReplyLen : Longint;
+ aReplyType : TffNetMsgDataType) : TffResult;
+begin
+ Result := TffServerCracker(bcServerEngine).ProcessRequest(bcClientID,
+ aMsgID,
+ aTimeout,
+ aRequestData,
+ aRequestDataLen,
+ aRequestDataType,
+ aReply,
+ aReplyLen,
+ aReplyType);
+end;
+{--------}
+function TffBaseClient.ProcessRequestNoReply(aMsgID : Longint;
+ aTimeout : Longint;
+ aRequestData : Pointer;
+ aRequestDataLen : Longint ) : TffResult;
+begin
+ Result := TffServerCracker(bcServerEngine).ProcessRequestNoReply(bcClientID,
+ aMsgID,
+ aTimeout,
+ aRequestData,
+ aRequestDataLen);
+end;
+{End !!.06}
+{====================================================================}
+
+
+{===TffCommsEngine===================================================}
+constructor TffCommsEngine.Create(aOwner : TComponent);
+begin
+ inherited Create(aOwner);
+
+ Protocol := ptSingleUser;
+end;
+{--------}
+function TffBaseClient.bcGetDefaultSession : TffSession;
+var
+ Inx : Integer;
+begin
+ for Inx := 0 to pred(OwnedDBItems.Count) do begin
+ Result := TffSession(OwnedDBItems[Inx]);
+ if Result.IsDefault then
+ Exit;
+ end;
+ if (OwnedDBItems.Count = 0) then
+ Result := nil
+ else begin
+ Result := TffSession(OwnedDBItems[0]);
+ Result.scIsDefault := True;
+ end;
+end;
+{--------}
+function TffBaseClient.bcGetSession(aInx : Integer) : TffSession;
+begin
+ Result := TffSession(OwnedDBItems[aInx])
+end;
+{--------}
+function TffBaseClient.bcGetSessionCount : Integer;
+begin
+ Result := OwnedDBItems.Count;
+end;
+{--------}
+procedure TffBaseClient.bcMakeSessionDefault(aSession : TffSession;
+ aValue : Boolean);
+var
+ Inx : Integer;
+ Sess : TffSession;
+ NeedDefault : Boolean;
+
+begin
+ Assert(Assigned(aSession));
+ if aValue then begin
+ for Inx := 0 to pred(OwnedDBItems.Count) do
+ TffSession(OwnedDBItems[Inx]).scIsDefault := False;
+ aSession.scIsDefault := True
+ end else begin
+ NeedDefault := aSession.scIsDefault;
+ aSession.scIsDefault := False;
+ if NeedDefault then begin
+ for Inx := 0 to pred(OwnedDBItems.Count) do begin
+ Sess := TffSession(OwnedDBItems[Inx]);
+ if (aSession <> Sess) then begin
+ Sess.scIsDefault := True;
+ Exit;
+ end;
+ end;
+ if (OwnedDBItems.Count > 0) then
+ TffSession(OwnedDBItems[0]).scIsDefault := True;
+ end;
+ end;
+end;
+{--------}
+procedure TffBaseClient.bcDoConnectionLost;
+var
+ Retry : Boolean;
+ RetrySuccess : Boolean;
+begin
+ Retry := False;
+ if Assigned(bcOnConnectionLost) then begin
+ bcOnConnectionLost(Self, True, Retry);
+ end else begin
+ if csDesigning in ComponentState then begin
+ IDEConnectionLost(Self, True, Retry);
+ end else
+ end;
+
+ RetrySuccess := False;
+ if Retry and dbliActive then begin
+ try
+ Open;
+ RetrySuccess := True;
+ except
+ { Any exception will cause us to assume the retry was unsuccessful}
+ end;
+ end;
+
+
+ { Clear the client's internals manually }
+ dbliActive := False;
+ bcClientID := 0;
+
+ if RetrySuccess then
+ { If retry for client was successful, reinstate all dependents }
+ RetrySuccess := bcReinstateDependents;
+
+ if not RetrySuccess then begin
+ { If retry was not successful clear all dependents components }
+ TffRemoteServerEngine(ServerEngine).Transport.Shutdown; {!!.06}
+ bcClearDependents;
+ end;
+
+ if Assigned(bcOnConnectionLost) then
+ bcOnConnectionLost(Self, False, Retry)
+ else
+ if csDesigning in ComponentState then
+ IDEConnectionLost(Self, True, Retry);
+end;
+{--------}
+function TffBaseClient.bcReinstateDependents : Boolean;
+var
+ SessIdx : Integer;
+ Sess : TffSession;
+
+ DBIdx : Integer;
+ OwnedCmp : TffComponent; {!!.12}
+ DB : TffBaseDatabase;
+
+ DSIdx : Integer;
+ DS : TffDataSet;
+
+ WasActive : Boolean;
+ WasPrepared : Boolean;
+begin
+ Result := False;
+ try
+ for SessIdx := 0 to Pred(SessionCount) do begin
+ Sess := Sessions[SessIdx];
+ WasActive := Sess.dbliActive;
+ Sess.dbliActive := False;
+ Sess.scSessionID := 0;
+ Sess.scServerEngine := nil;
+ if WasActive then
+ Sess.Open;
+
+ for DBIdx := 0 to Pred(Sess.OwnedDBItems.Count) do begin {!!.12}
+ OwnedCmp := Sess.OwnedDBItems[DBIdx]; {!!.12}
+ if OwnedCmp is TffBasePluginEngine then begin {!!.12}
+ TffBasePluginEngine(OwnedCmp).Shutdown; {!!.12}
+ TffBasePluginEngine(OwnedCmp).Startup; {!!.12}
+ end {!!.12}
+ else if OwnedCmp is TffBaseDatabase then begin {!!.12}
+ DB := Sess.Databases[DBIdx];
+ WasActive := DB.dbliActive;
+ DB.dbliActive := False;
+ DB.bdDatabaseID := 0;
+ DB.bdServerEngine := nil;
+ if WasActive then
+ DB.Open;
+
+ for DSIdx := 0 to Pred(DB.DataSetCount) do begin
+ DS := DB.DataSets[DSIdx];
+ WasActive := DS.dsProxy.dbliActive;
+ WasPrepared := False;
+ DS.dsProxy.dbliActive := False;
+ DS.dsProxy.tpServerEngine := nil;
+ DS.TableState := TblClosed;
+ DS.dsCursorID := 0;
+ DS.Close;
+ if DS is TffBaseTable then
+ with TffBaseTable(DS) do begin
+ btLookupCursorID := 0;
+ btLookupKeyFields := '';
+ btLookupNoCase := False;
+ btRangeStack.Clear;
+ end
+ else if DS is TffQuery then
+ with TffQuery(DS) do begin
+ WasPrepared := FPrepared;
+ FPrepared := False;
+ FStmtID := 0;
+ end;
+{Begin !!.13}
+ if (DS is TffQuery) and
+ (WasPrepared) then
+ TffQuery(DS).Prepare;
+ if WasActive then
+ DS.Open;
+{End !!.13}
+ end; { for }
+ end; { if }
+ end; { if } {!!.12}
+ end;
+ Result := True;
+ except
+ { if any exceptions occur, we assume that the connection cannot be reinstated }
+ end;
+end;
+{--------}
+procedure TffBaseClient.bcClearDependents;
+var
+ SessIdx : Integer;
+ Sess : TffSession;
+
+ DBIdx : Integer;
+ OwnedCmp : TffComponent; {!!.12}
+ DB : TffBaseDatabase;
+
+ DSIdx : Integer;
+ DS : TffDataSet;
+begin
+ for SessIdx := 0 to Pred(SessionCount) do begin
+ Sess := Sessions[SessIdx];
+ Sess.dbliActive := False;
+ Sess.scSessionID := 0;
+ Sess.scServerEngine := nil;
+
+ for DBIdx := 0 to Pred(Sess.OwnedDBItems.Count) do begin {!!.12}
+ OwnedCmp := Sess.OwnedDBItems[DBIdx]; {!!.12}
+ if OwnedCmp is TffBasePluginEngine then {!!.12}
+ TffBasePluginEngine(OwnedCmp).Shutdown {!!.12}
+ else if OwnedCmp is TffBaseDatabase then begin {!!.12}
+ DB := Sess.Databases[DBIdx];
+ DB.dbliActive := False;
+ DB.bdDatabaseID := 0;
+ DB.bdServerEngine := nil;
+
+ for DSIdx := 0 to Pred(DB.DataSetCount) do begin
+ DS := DB.DataSets[DSIdx];
+ if DS is TffBaseTable then {!!.06}
+ TffBaseTable(DS).btIgnoreDataEvents := True; {!!.06}
+ DS.dsProxy.dbliActive := False;
+ DS.dsProxy.tpServerEngine := nil;
+ DS.TableState := TblClosed;
+ DS.dsCursorID := 0;
+ DS.Close;
+ if DS is TffBaseTable then
+ with TffBaseTable(DS) do begin
+ btLookupCursorID := 0;
+ btLookupKeyFields := '';
+ btLookupNoCase := False;
+ btRangeStack.Clear;
+ end
+ else if DS is TffQuery then
+ with TffQuery(DS) do begin
+ FStmtID := 0;
+ end;
+ end; { for }
+ end; { if } {!!.12}
+ end;
+ end;
+end;
+{--------}
+procedure TffBaseClient.FFNotificationEx(const AOp : Byte; AFrom : TffComponent;
+ const AData : TffWord32);
+begin
+ if (AFrom = bcServerEngine) then
+ if ((AOp = ffn_Destroy) or (AOp = ffn_Remove) ) then begin
+ FFNotifyDependents(ffn_Deactivate);
+ Close;
+ bcServerEngine := nil;
+ end else if (AOp = ffn_Deactivate) then begin
+ FFNotifyDependents(ffn_Deactivate);
+ Close;
+ end else if (AOp = ffn_ConnectionLost) then begin
+ if (Active) and (bcClientID = AData) then begin
+ bcDoConnectionLost;
+ end;
+ end;
+end;
+{--------}
+procedure TffCommsEngine.ceReadRegistryProtocol;
+var
+ ProtName : TffShStr;
+begin
+ if not ceRegProtRead then begin
+ ffClientConfigReadProtocol(ceRegProt, ProtName);
+ ceRegProtRead := True;
+ end;
+end;
+{--------}
+function TffBaseClient.bcGetServerEngine : TffBaseServerEngine;
+begin
+ Result := bcServerEngine;
+end;
+{--------}
+procedure TffBaseClient.bcSetAutoClientName(const Value : Boolean);
+begin
+ if Value = bcAutoClientName then
+ Exit;
+
+ if Value then begin
+ CheckInactive(False);
+ ClientName := 'FFClient_' + IntToStr(Longint(Self));
+ end;
+
+ bcAutoClientName := Value;
+end;
+{--------}
+procedure TffBaseClient.bcSetClientName(const aName : string);
+{Rewritten !!.11}
+var
+ CL : TffBaseClient;
+ Counter : Integer;
+ TmpName : string;
+begin
+ if DBName = aName then
+ Exit;
+
+ CheckInactive(False);
+ TmpName := aName;
+ CL := FindFFClientName(TmpName);
+ if (CL <> nil) then
+ if bcAutoClientName then begin
+ { Generate a unique name. }
+ Counter := 0;
+ repeat
+ TmpName := aName + IntToStr(Counter);
+ inc(Counter);
+ until FindFFClientName(TmpName) = nil;
+ end
+ else
+ { Allow case changes to existing name }
+ if not (AnsiUpperCase(TmpName) = AnsiUpperCase(DBName)) then
+ raise EffDatabaseError.Create(
+ Format(ffStrResDataSet[ffdse_CLNameExists], [TmpName]));
+ DBName := TmpName;
+end;
+{--------}
+procedure TffBaseClient.bcSetIsDefault(const Value : Boolean);
+var
+ CurDefCL : TffBaseClient;
+ CurDefSess : TffSession;
+begin
+ if (Value = bcIsDefault) then
+ Exit;
+
+ if Value then begin {making it the default}
+ {find the current default engine, and make sure it's no longer
+ the default}
+ CurDefCL := FindDefaultFFClient;
+ if Assigned(CurDefCL) then
+ CurDefCL.bcIsDefault := False;
+ {we're now the default}
+ bcIsDefault := True;
+ {make sure we have a default session}
+ if (OwnedDBItems.Count > 0) then begin
+ CurDefSess := bcGetDefaultSession;
+ if (CurDefSess = nil) then
+ bcMakeSessionDefault(TffSession(OwnedDBItems[0]), True);
+ end;
+ end else {it's no longer the default} begin
+ {we're no longer the default}
+ bcIsDefault := False;
+ {make the automatically created engine the default}
+ CurDefCL := FindAutoFFClient;
+ if Assigned(CurDefCL) then
+ CurDefCL.IsDefault := True;
+ end;
+end;
+{--------}
+procedure TffCommsEngine.ceSetProtocol(const Value : TffProtocolType);
+begin
+ CheckInactive(csDesigning in ComponentState);
+ ceProtocol := Value;
+end;
+{--------}
+function TffCommsEngine.ceGetServerName : string; {!!.10}
+begin
+ Result := ceServerName;
+end;
+{--------}
+procedure TffCommsEngine.ceSetServerName(const Value : string); {!!.10}
+begin
+ CheckInactive(False);
+ ceServerName := Value;
+end;
+{--------}
+procedure TffBaseClient.bcSetUserName(const Value : string);
+begin
+ CheckInactive(False);
+ bcUserName := Value;
+end;
+{--------}
+function TffBaseClient.bcGetUserName : string;
+begin
+ Result := bcUserName;
+end;
+{--------}
+procedure TffBaseClient.bcSetServerEngine(Value : TffBaseServerEngine);
+begin
+ if bcServerEngine = Value then
+ Exit;
+
+ CheckInactive(False);
+
+{Begin !!.02}
+ if Assigned(bcServerEngine) then begin
+ bcServerEngine.FFRemoveDependent(Self);
+ if bcOwnServerEngine then begin
+ if ServerEngine is TffRemoteServerEngine then
+ TffRemoteServerEngine(ServerEngine).Transport.Free;
+ bcServerEngine.Free;
+ bcOwnServerEngine := False; {!!.06}
+ end;
+ end;
+{End !!.02}
+
+ bcServerEngine := Value;
+ if Assigned(bcServerEngine) then
+ bcServerEngine.FFAddDependent(Self);
+end;
+{--------}
+procedure TffBaseClient.bcSetTimeout(const Value : Longint);
+var
+ Idx : Integer; {!!.11}
+begin
+ if bcTimeout = Value then
+ Exit;
+
+ bcTimeout := Value;
+ if bcClientID <> 0 then
+ if Assigned(ServerEngine) then begin
+ Check(ServerEngine.ClientSetTimeout(bcClientID, Value));
+ { Inform children of timeout change }
+ for Idx := 0 to Pred(OwnedDBItems.Count) do
+ TffSession(OwnedDBItems[Idx]).scRefreshTimeout;
+ end;
+end;
+{--------}
+procedure TffBaseClient.dbliClosePrim;
+begin
+ inherited dbliClosePrim;
+
+ if bcClientID <> 0 then
+ if Assigned(ServerEngine) then begin
+ Check(ServerEngine.ClientRemove(bcClientID));
+ if bcOwnServerEngine and (ServerEngine is TffRemoteServerEngine) then
+ TffRemoteServerEngine(ServerEngine).Transport.State := ffesInactive;
+ end;
+ bcClientID := 0;
+end;
+{--------}
+function TffBaseClient.dbliCreateOwnedList : TffDBList;
+begin
+ Result := TffDBList(TffSessionList.Create(Self));
+end;
+{--------}
+procedure TffBaseClient.dbliDBItemAdded(aItem : TffDBListItem);
+var
+ Sess : TffSession absolute aItem;
+begin
+ Assert(Assigned(aItem));
+ if (OwnedDBItems.Count = 1) then
+ Sess.scIsDefault := True;
+end;
+{--------}
+procedure TffBaseClient.dbliDBItemDeleted(aItem : TffDBListItem);
+var
+ Sess : TffSession absolute aItem;
+begin
+ Assert(Assigned(aItem));
+ if Sess.scIsDefault then
+ bcMakeSessionDefault(Sess, False);
+end;
+{--------}
+procedure TffBaseClient.dbliMustBeClosedError;
+begin
+ RaiseFFErrorObj(Self, ffdse_CLMustBeClosed);
+end;
+{--------}
+procedure TffBaseClient.dbliMustBeOpenError;
+begin
+ RaiseFFErrorObj(Self, ffdse_CLMustBeOpen);
+end;
+{--------}
+procedure TffBaseClient.GetServerNames(aServerNames : TStrings);
+{$IFNDEF SingleEXE} {Moved !!.02}
+var {Begin !!.01}
+ Prot : TffCommsProtocolClass;
+ ProtName : TffShStr;
+ RSE : TffRemoteServerEngine; { for convenient access}
+ LTrans : TffBaseTransport; { for convenient access} {Moved !!.02}
+{$ENDIF}
+ {End !!.01}
+begin
+ Assert(Assigned(aServerNames));
+ CheckActive;
+ if IsConnected then begin {Begin !!.01}
+ Assert(Assigned(ServerEngine));
+ ServerEngine.GetServerNames(aServerNames, bcTimeout);
+ end else begin
+ if Assigned(ServerEngine) then
+ ServerEngine.GetServerNames(aServerNames, bcTimeout)
+ else begin
+ { Since no ServerEngine is available we must create one here to
+ retrieve the server names. }
+ {$IFDEF SingleEXE}
+ aServerNames.Add('Local server');
+ {$ELSE}
+
+ {Get the protocol from the registry}
+ FFClientConfigReadProtocol(Prot, ProtName);
+
+ { We must create our own remote server engine, transport, etc. }
+ RSE := TffRemoteServerEngine.Create(Self);
+ try
+ RSE.TimeOut := Timeout;
+ LTrans := TffLegacyTransport.Create(RSE);
+ try
+ LTrans.Mode := fftmSend;
+ TffLegacyTransport(LTrans).Protocol := FFGetProtocolType(ProtName);
+ LTrans.ServerName := FFClientConfigReadServerName;
+ RSE.Transport := LTrans;
+
+ { Get the list }
+ RSE.GetServerNames(aServerNames, bcTimeout);
+
+ finally
+ LTrans.Free;
+ end;
+ finally
+ RSE.Free;
+ end;
+ {$ENDIF}
+ end;
+ end; {End !!.01}
+end;
+{--------}
+function TffCommsEngine.ProtocolClass : TffCommsProtocolClass;
+begin
+ if (Protocol <> ptRegistry) then
+ case Protocol of
+ ptSingleUser : Result := TffSingleUserProtocol;
+ ptTCPIP : Result := TffTCPIPProtocol;
+ ptIPXSPX : Result := TffIPXSPXProtocol;
+ else
+ Result := TffSingleUserProtocol;
+ end
+ else begin
+ ceReadRegistryProtocol;
+ Result := ceRegProt;
+ end;
+end;
+{--------}
+function TffBaseClient.IsConnected : Boolean;
+begin
+ Result := ClientID <> 0;
+end;
+{--------}
+procedure TffClient.OpenConnection(aSession : TffSession);
+var
+ aUserName : TffName;
+ aPassword : TffName;
+ aPWHash : TffWord32;
+ aServerPWHash: TffWord32;
+ aClickedOK : Boolean;
+ {$IFNDEF SingleEXE}
+ aProt : TffCommsProtocolClass;
+ aProtName : TffShStr;
+ aRSE : TffRemoteServerEngine; { for convenient access}
+ {$ENDIF}
+ aLTrans : TffBaseTransport; { for convenient access}
+ aServerName : TffNetAddress;
+ aStatus : TffResult;
+ aRetryCount : Integer;
+begin
+ Assert(Assigned(aSession));
+
+ { Each time a session is made active, this method will be called. Since
+ we may serve multiple sessions, we must check to see if we are already
+ connected to a server }
+ if IsConnected then
+ Exit;
+
+ if (bcServerEngine = nil) then begin
+ {$IFDEF SingleEXE}
+ if (FFDB.ServerEngine = nil) then
+ FFDB.ServerEngine := TffServerEngine.Create(nil);
+ bcServerEngine := FFDB.ServerEngine;
+ bcServerEngine.FFAddDependent(Self); {!!.01}
+ {$ELSE}
+ {Get the protocol from the registry}
+ FFClientConfigReadProtocol(aProt, aProtName);
+
+ { We must create our own remote server engine, transport, etc. }
+ aRSE := TffRemoteServerEngine.Create(Self);
+ bcOwnServerEngine := True;
+ aRSE.TimeOut := Timeout;
+ aLTrans := TffLegacyTransport.Create(aRSE);
+{Begin !!.01}
+ {$IFDEF AutoLog}
+ aLTrans.EventLog := TffEventLog.Create(aLTrans);
+ aLTrans.EventLog.Enabled := True;
+ aLTrans.EventLog.FileName := ffcAutoLogFile;
+ aLTrans.EventLogEnabled := True;
+ aLTrans.EventLogOptions := [fftpLogErrors, fftpLogRequests, fftpLogReplies];
+ {$ENDIF}
+ aLTrans.Mode := fftmSend;
+ TffLegacyTransport(aLTrans).Protocol := FFGetProtocolType(aProtName);
+ aLTrans.ServerName := FFClientConfigReadServerName;
+ {$IFDEF AutoLog}
+ aLTrans.EventLog.WriteStringFmt('Automatic transport serverName: %s',
+ [aLTrans.ServerName]);
+ {$ENDIF}
+{End !!.01}
+ aRSE.Transport := aLTrans;
+ bcServerEngine := aRSE;
+ bcServerEngine.FFAddDependent(Self); {!!.01}
+ {$ENDIF}
+ end;
+
+ if Assigned(bcServerEngine) then begin
+ { Let the server engine know we are here. }
+ if ServerEngine is TffRemoteServerEngine then begin
+ aLTrans := TffRemoteServerEngine(ServerEngine).Transport;
+ if Assigned(aLTrans) then begin
+ if aLTrans.State = ffesInactive then begin {!!.05}
+ aLTrans.Enabled := True;
+ { Select the appropriate server if necessary }
+ if (aLTrans is TffLegacyTransport) then {!!.13}
+ if TffLegacyTransport(aLTrans).Protocol = ptRegistry then {!!.13}
+ aLTrans.ServerName := FFClientConfigReadServerName; {!!.13}
+ if aLTrans.ServerName = '' then begin
+ aSession.ChooseServer(aServerName);
+ if aServerName = '' then
+ Check(DBIERR_SERVERNOTFOUND);
+ aLTrans.ServerName := aServerName;
+ end;
+ aLTrans.State := ffesStarted;
+ end;
+ end else begin {!!.05}
+ Check(ffdse_RSENeedsTransport) {!!.05}
+ end; {!!.05}
+ end;
+ if ServerEngine.State in [ffesInactive, ffesStopped] then
+ ServerEngine.State := ffesStarted;
+ aRetryCount := 0;
+ if bcUserName <> '' then
+ aUserName := bcUserName
+ else
+ aUserName := ffclUserName;
+ aPassword := ffclPassword;
+ if (csDesigning in ComponentState) and (bcPassword <> '') then
+ aPassword := bcPassword; {!!.06}
+ aPWHash := FFCalcShStrELFHash(aPassword);
+ aServerPWHash := aPWHash; {!!.06}
+ aStatus := ServerEngine.ClientAdd(bcClientID, aUserName, aUserName, bcTimeOut, aServerPWHash);
+ { Make sure the password was correct }
+ if aStatus = DBIERR_NONE then {!!.06}
+ if aPWHash <> aServerPWHash then {!!.06}
+ aStatus := DBIERR_INVALIDUSRPASS; {!!.06}
+ while (aRetryCount < bcPasswordRetries) and
+ (aStatus = DBIERR_INVALIDUSRPASS) do begin
+ if bcBeepOnLoginError then {!!.06}
+ MessageBeep(0);
+
+ aSession.DoLogin(aUserName, aPassword, aClickedOK);
+ if not aClickedOK then
+ Break
+ else begin
+ inc(aRetryCount);
+ aPWHash := FFCalcShStrELFHash(aPassword);
+ aServerPWHash := aPWHash; {!!.06}
+ aStatus := ServerEngine.ClientAdd(bcClientID, aUserName, aUserName, bcTimeout, aPWHash);
+
+ { Make sure the password was correct }
+ if aStatus = DBIERR_NONE then {!!.06}
+ if aPWHash <> aServerPWHash then {!!.06}
+ aStatus := DBIERR_INVALIDUSRPASS; {!!.06}
+ if aStatus = fferrReplyTimeout then {!!.06}
+ aStatus := DBIERR_INVALIDUSRPASS; {!!.06}
+ end;
+ end;
+ Check(aStatus);
+ { store login in the client component}
+
+ bcUserName := aUserName; {!!.06}
+ if csDesigning in ComponentState then
+ bcPassword := aPassword; {!!.06}
+ end else begin
+ { There is no ServerEngine, so raise an exception }
+ Check(DBIERR_FF_OpenNoMem)
+ end;
+end;
+{--------} {!!BEGIN .01}
+procedure TffCommsEngine.GetServerNames(aServerNames : TStrings);
+{$IFNDEF SingleEXE} {Moved !!.02}
+var
+ Prot : TffCommsProtocolClass;
+ ProtName : TffShStr;
+ RSE : TffRemoteServerEngine; { for convenient access}
+ LTrans : TffBaseTransport; { for convenient access} {Moved !!.02}
+{$ENDIF}
+begin
+ Assert(Assigned(aServerNames));
+ CheckActive;
+ if IsConnected then begin
+ Assert(Assigned(ServerEngine));
+ ServerEngine.GetServerNames(aServerNames, bcTimeout);
+ end else begin
+ if Assigned(ServerEngine) then
+ ServerEngine.GetServerNames(aServerNames, bcTimeout)
+ else begin
+ { Since no ServerEngine is available we must create one here to
+ retrieve the server names. }
+ {$IFDEF SingleEXE}
+ aServerNames.Add('Local server');
+ {$ELSE}
+
+ LTrans := nil;
+ RSE := TffRemoteServerEngine.Create(nil);
+ try
+ LTrans := TffLegacyTransport.Create(nil);
+ RSE.TimeOut := Timeout;
+ LTrans.Mode := fftmSend;
+ RSE.Transport := LTrans;
+ if (Protocol = ptRegistry) then begin
+ {Get the protocol from the registry}
+ FFClientConfigReadProtocol(Prot, ProtName);
+ TffLegacyTransport(LTrans).Protocol := FFGetProtocolType(ProtName);
+ LTrans.ServerName := FFClientConfigReadServerName;
+ end else begin
+ TffLegacyTransport(LTrans).Protocol := Protocol;
+ LTrans.ServerName := ServerName;
+ end;
+ { Get the list }
+ RSE.GetServerNames(aServerNames, bcTimeout);
+ finally
+ LTrans.Free;
+ RSE.Free;
+ end;
+ {$ENDIF}
+ end;
+ end;
+end; {!!END .01}
+{--------}
+procedure TffCommsEngine.OpenConnection(aSession : TffSession);
+var
+ aUserName : TffName;
+ aPassword : TffName;
+ aPWHash : TffWord32;
+ aServerPWHash : TFfWord32;
+ aClickedOK : Boolean;
+ {$IFNDEF SingleEXE}
+ aProt : TffCommsProtocolClass;
+ aProtName : TffShStr;
+ aRSE : TffRemoteServerEngine; { for convenient access}
+ {$ENDIF}
+ aLTrans : TffBaseTransport; { for convenient access}
+ aServerName : TffNetAddress;
+ aRetryCount : Integer;
+ aStatus : TffResult;
+begin
+ Assert(Assigned(aSession));
+
+ if IsConnected then
+ Exit;
+
+ {$IFDEF SingleEXE}
+ if (FFDB.ServerEngine = nil) then
+ FFDB.ServerEngine := TffServerEngine.Create(nil);
+ bcServerEngine := FFDB.ServerEngine;
+ bcServerEngine.FFAddDependent(Self); {!!.01}
+ {$ELSE}
+
+ if (Protocol = ptRegistry) then begin
+ {Get the protocol from the registry}
+ FFClientConfigReadProtocol(aProt, aProtName);
+
+ { We must create our own remote server engine, transport, etc. }
+ aRSE := TffRemoteServerEngine.Create(Self);
+ bcOwnServerEngine := True;
+ aRSE.TimeOut := Timeout;
+ aLTrans := TffLegacyTransport.Create(aRSE);
+{Begin !!.01}
+ {$IFDEF AutoLog}
+ aLTrans.EventLog := TffEventLog.Create(aLTrans);
+ aLTrans.EventLog.Enabled := True;
+ aLTrans.EventLog.FileName := ffcAutoLogFile;
+ aLTrans.EventLogEnabled := True;
+ aLTrans.EventLogOptions := [fftpLogErrors, fftpLogRequests, fftpLogReplies];
+ {$ENDIF}
+ aLTrans.Mode := fftmSend;
+ TffLegacyTransport(aLTrans).Protocol := FFGetProtocolType(aProtName);
+ aLTrans.ServerName := FFClientConfigReadServerName;
+ {$IFDEF AutoLog}
+ aLTrans.EventLog.WriteStringFmt('Automatic CommsEngine serverName: %s',
+ [aLTrans.ServerName]);
+ {$ENDIF}
+{End !!.01}
+ aRSE.Transport := aLTrans;
+ bcServerEngine := aRSE;
+ bcServerEngine.FFAddDependent(Self); {!!.01}
+ end else if not Assigned(ServerEngine) then begin
+ { The server engine property is not Assigned, so we need to create one }
+ { We must create our own remote server engine, transport, etc. }
+ aRSE := TffRemoteServerEngine.Create(Self);
+ bcOwnServerEngine := True;
+ aRSE.TimeOut := Timeout;
+ aLTrans := TffLegacyTransport.Create(aRSE);
+{Begin !!.01}
+ {$IFDEF AutoLog}
+ aLTrans.EventLog := TffEventLog.Create(aLTrans);
+ aLTrans.EventLog.Enabled := True;
+ aLTrans.EventLog.FileName := ffcAutoLogFile;
+ aLTrans.EventLogEnabled := True;
+ aLTrans.EventLogOptions := [fftpLogErrors, fftpLogRequests, fftpLogReplies];
+ {$ENDIF}
+ aLTrans.Mode := fftmSend;
+ TffLegacyTransport(aLTrans).Protocol := Protocol;
+ aLTrans.ServerName := ServerName;
+ {$IFDEF AutoLog}
+ aLTrans.EventLog.WriteStringFmt('Automatic CommsEngine serverName: %s',
+ [aLTrans.ServerName]);
+ {$ENDIF}
+{End !!.01}
+ aRSE.Transport := aLTrans;
+ bcServerEngine := aRSE;
+ bcServerEngine.FFAddDependent(Self); {!!.01}
+ end;
+ {$ENDIF}
+ if Assigned(ServerEngine) then begin
+ { Let the server engine know we are here. }
+ if ServerEngine is TffRemoteServerEngine then begin
+ aLTrans := TffRemoteServerEngine(ServerEngine).Transport;
+ if Assigned(aLTrans) then begin {!!.05}
+ aLTrans.Enabled := True;
+ { Select the appropriate server if necessary }
+ if (aLTrans is TffLegacyTransport) then {!!.13}
+ if TffLegacyTransport(aLTrans).Protocol = ptRegistry then {!!.13}
+ aLTrans.ServerName := FFClientConfigReadServerName; {!!.13}
+ if aLTrans.ServerName = '' then begin
+ aSession.ChooseServer(aServerName);
+ if aServerName = '' then
+ Check(DBIERR_SERVERNOTFOUND);
+ aLTrans.ServerName := aServerName;
+ end;
+ aLTrans.State := ffesStarted;
+ end else begin {!!.05}
+ Check(ffdse_RSENeedsTransport); {!!.05}
+ end; {!!.05}
+ end;
+ ServerEngine.State := ffesStarted;
+
+ aRetryCount := 0;
+ if bcUserName <> '' then
+ aUserName := bcUserName
+ else
+ aUserName := ffclUserName;
+ aPassword := ffclPassword;
+ if (csDesigning in ComponentState) and (bcPassword <> '') then
+ aPassword := bcPassword; {!!.06}
+ aPWHash := FFCalcShStrELFHash(aPassword);
+ aServerPWHash := aPWHash;
+ aStatus := ServerEngine.ClientAdd(bcClientID, aUserName, aUserName,
+ bcTimeOut, aPWHash);
+ { Make sure the password was correct }
+ if aStatus = DBIERR_NONE then {!!.06}
+ if aPWHash <> aServerPWHash then {!!.06}
+ aStatus := DBIERR_INVALIDUSRPASS; {!!.06}
+ while (aRetryCount < bcPasswordRetries) and
+ (aStatus = DBIERR_INVALIDUSRPASS) do begin
+ if aRetryCount > 0 then
+ if bcBeepOnLoginError then {!!.06}
+ MessageBeep(0);
+
+ aSession.DoLogin(aUserName, aPassword, aClickedOK);
+ if not aClickedOK then
+ Break
+ else begin
+ inc(aRetryCount);
+ aPWHash := FFCalcShStrELFHash(aPassword);
+ aServerPWHash := aPWHash; {!!.06}
+ aStatus := ServerEngine.ClientAdd(bcClientID, aUserName, aUserName,
+ bcTimeout, aPWHash);
+
+ { Make sure the password was correct }
+ if aStatus = DBIERR_NONE then {!!.06}
+ if aPWHash <> aServerPWHash then {!!.06}
+ aStatus := DBIERR_INVALIDUSRPASS; {!!.06}
+ if aStatus = fferrReplyTimeout then {!!.06}
+ aStatus := DBIERR_INVALIDUSRPASS; {!!.06}
+ end;
+ end; { while }
+ Check(aStatus);
+ { store user name in the client component}
+ bcUserName := aUserName; {!!.06}
+ if csDesigning in ComponentState then
+ bcPassword := aPassword; {!!.06}
+ end else begin
+ { There is no ServerEngine, so raise an exception }
+ Check(DBIERR_FF_OpenNoMem)
+ end;
+end;
+{====================================================================}
+
+
+{===TffCommsEngineList===============================================}
+function TffClientList.clGetItem(aInx : Integer) : TffBaseClient;
+begin
+ Result := TffBaseClient(dblGetItem(aInx));
+end;
+{====================================================================}
+
+
+{===TffSession=======================================================}
+constructor TffSession.Create(aOwner : TComponent);
+begin
+ inherited Create(aOwner);
+
+ dbliReqPropName := ffcSessionName;
+ scAutoSessionName := False;
+ scSessionID := 0;
+ scTimeout := -1;
+ scServerEngine := nil;
+
+ {attach ourselves to the default comms engine}
+ ClientName := GetDefaultffClient.ClientName;
+ dbliLoadPriority := 2;
+
+end;
+{--------}
+destructor TffSession.Destroy;
+begin
+ dbliFreeTemporaryDependents; {!!.01}
+ FFNotifyDependents(ffn_Destroy);
+
+ Close; {!!.01}
+
+ {make sure we're no longer the default session}
+ if IsDefault then
+ IsDefault := False;
+ {if we're still the default, make sure our comms engine is no longer
+ the default}
+ if IsDefault and (Client <> nil) then begin
+ if Client.IsDefault then
+ Client.IsDefault := False;
+ if IsDefault then
+ IsDefault := False;
+ end;
+
+ inherited Destroy;
+end;
+{--------}
+procedure TffSession.AddAlias(const aName : string;
+ const aPath : string;
+ aCheckSpace : Boolean); {!!.11}
+begin
+ Check(AddAliasEx(aName, aPath, aCheckSpace)); {!!.11}
+end;
+{--------}
+function TffSession.AddAliasEx(const aName : string;
+ const aPath : string;
+ aCheckSpace : Boolean) {!!.11}
+ : TffResult;
+begin
+ Assert(aName <> '');
+ Assert(aPath <> '');
+ CheckActive;
+ Result := ServerEngine.DatabaseAddAlias(aName,
+ aPath,
+ aCheckSpace, {!!.11}
+ Client.ClientID);
+end;
+{--------}
+procedure TffSession.CloseDatabase(aDatabase : TffBaseDatabase);
+begin
+ if (aDatabase <> nil) then begin
+ aDatabase.Active := False; {decrement open reference count}
+ if (not aDatabase.Active) and aDatabase.Temporary then
+ aDatabase.Free;
+ end;
+end;
+{Begin !!.06}
+{--------}
+procedure TffSession.CloseInactiveTables;
+begin
+ CheckActive;
+ Check(ServerEngine.SessionCloseInactiveTables(Client.ClientID)); {!!.06}
+end;
+{End !!.06}
+{--------}
+procedure TffSession.dbliClosePrim;
+begin
+ inherited dbliClosePrim;
+
+ if scSessionID <> 0 then
+ if Assigned(ServerEngine) then
+ Check(ServerEngine.SessionRemove(Client.ClientID, SessionID));
+ scSessionID := 0;
+ scServerEngine := nil;
+end;
+{--------}
+function TffSession.dbliCreateOwnedList : TffDBList;
+begin
+ Result := TffDBList(TffDatabaseList.Create(Self));
+end;
+{--------}
+function TffSession.dbliFindDBOwner(const aName : string) : TffDBListItem;
+begin
+ if (aName = '') then
+ Result := FindDefaultFFClient
+ else
+ Result := FindFFClientName(aName);
+end;
+{--------}
+procedure TffSession.dbliMustBeClosedError;
+begin
+ RaiseFFErrorObj(Self, ffdse_SessMustBeClosed);
+end;
+{--------}
+procedure TffSession.dbliMustBeOpenError;
+begin
+ RaiseFFErrorObj(Self, ffdse_SessMustBeOpen);
+end;
+{--------}
+procedure TffSession.dbliOpenPrim;
+begin
+ scServerEngine := Client.ServerEngine;
+ DoStartup;
+ Assert(Assigned(ServerEngine), 'ServerEngine has not been Assigned');
+ {The TfffServerEngine creates a default session for every client. If there
+ is not a session already in the client list, then we must create another one.}
+ if Client.SessionCount = 0 then
+ Check(ServerEngine.SessionGetCurrent(Client.ClientID, scSessionID))
+ else
+ Check(ServerEngine.SessionAdd(Client.bcClientID, GetTimeOut,
+ scSessionID));
+end;
+{--------}
+procedure TffSession.DeleteAlias(const aName : string);
+begin
+ Check(DeleteAliasEx(aName));
+end;
+{--------}
+function TffSession.DeleteAliasEx(const aName : string) : TffResult;
+begin
+ Assert(aName <> '');
+ CheckActive;
+ Result := ServerEngine.DatabaseDeleteAlias(aName,
+ Client.ClientID);
+end;
+{--------}
+function TffSession.FindDatabase(const aName : string) : TffBaseDatabase;
+begin
+ Result := FindFFDatabaseName(Self, aName, False);
+end;
+{--------}
+procedure TffSession.GetAliasNames(aList : TStrings);
+begin
+ GetAliasNamesEx(aList, True);
+end;
+{--------}
+function TffSession.GetAliasNamesEx(aList : TStrings;
+ const aEmptyList : Boolean) : TffResult;
+var
+ WasActive : Boolean;
+ CEWasActive : Boolean;
+ TmpList : TList;
+ I : Integer;
+ PItem : PffAliasDescriptor;
+begin
+ Assert(Assigned(aList));
+ if aEmptyList then
+ aList.Clear;
+ CEWasActive := Client.Active;
+ WasActive := Active;
+ if not WasActive then
+ Active := True;
+ try
+ TmpList := TList.Create;
+ try
+ aList.BeginUpdate;
+ try
+ Result := ServerEngine.DatabaseAliasList(TmpList, Client.ClientID);
+ if Result = DBIERR_NONE then
+ for I := 0 to Pred(TmpList.Count) do begin
+ PItem := PffAliasDescriptor(TmpList.Items[i]);
+ if (aList.IndexOf(PItem^.adAlias) = -1) then {New !!.01}
+ aList.Add(PItem^.adAlias);
+ end;
+ finally
+ aList.EndUpdate;
+ end;
+ finally
+ for I := Pred(TmpList.Count) downto 0 do begin
+ PItem := PffAliasDescriptor(TmpList.Items[i]);
+ FFFreeMem(PItem, SizeOf(PItem^));
+ end;
+ TmpList.Free;
+ end;
+ finally
+ if not WasActive then
+ Active := False;
+ if not CEWasActive then
+ Client.Active := False;
+ end;{try..finally}
+end;
+{--------}
+procedure TffSession.GetAliasPath(const aName : string;
+ var aPath : string);
+ {rewritten !!.11}
+var
+ ffPath : TffPath;
+ WasActive : Boolean;
+ CEWasActive : Boolean;
+begin
+ Assert(aName <> '');
+ if not IsAlias(aName) then
+ aPath := ''
+ else begin
+ WasActive := Active;
+ CEWasActive := Client.Active;
+ try
+ if not WasActive then
+ Open;
+ Check(ServerEngine.DatabaseGetAliasPath(AName,
+ ffPath,
+ Client.ClientID));
+ aPath := ffPath;
+ finally
+ if not WasActive then
+ Close;
+ if not CEWasActive then
+ Client.Close;
+ end;
+ end;
+end;
+{--------}
+procedure TffSession.GetDatabaseNames(aList : TStrings);
+begin
+ GetFFDatabaseNames(Self, aList);
+end;
+{--------}
+function TffSession.GetServerDateTime(var aServerNow : TDateTime) : TffResult;
+begin
+ Result := ServerEngine.GetServerDateTime(aServerNow);
+
+ if Result <> DBIERR_NONE then
+ {Just is case something bad happened to aServerNow, we will reset it
+ to the local machines date time}
+ aServerNow := Now;
+end;
+{--------} {begin !!.07}
+function TffSession.GetServerSystemTime(var aServerNow : TSystemTime) : TffResult;
+begin
+ Result := ServerEngine.GetServerSystemTime(aServerNow);
+end;
+{--------}
+function TffSession.GetServerGUID(var aGUID : TGUID) : TffResult;
+begin
+ Result := ServerEngine.GetServerGUID(aGUID);
+end;
+{--------}
+function TffSession.GetServerID(var aUniqueID : TGUID) : TffResult;
+begin
+ Result := ServerEngine.GetServerID(aUniqueID);
+end;
+{--------}
+function TffSession.GetServerStatistics(var aStats : TffServerStatistics) : TffResult;
+begin
+ Result := ServerEngine.GetServerStatistics(aStats);
+end;
+{--------}
+function TffSession.GetCommandHandlerStatistics(const aCmdHandlerIdx : Integer;
+ var aStats : TffCommandHandlerStatistics) : TffResult;
+begin
+ Result := ServerEngine.GetCommandHandlerStatistics(aCmdHandlerIdx, aStats);
+end;
+{--------}
+function TffSession.GetTransportStatistics(const aCmdHandlerIdx : Integer;
+ const aTransportIdx : Integer;
+ var aStats : TffTransportStatistics) : TffResult;
+begin
+ Result := ServerEngine.GetTransportStatistics(aCmdHandlerIdx, aTransportIdx, aStats);
+end;
+{--------} {end !!.07}
+procedure TffSession.GetTableNames(const aDatabaseName : string;
+ const aPattern : string;
+ aExtensions : Boolean;
+ aSystemTables : Boolean;
+ aList : TStrings);
+var
+ DB : TffBaseDatabase;
+ TmpList : TList;
+ I : Integer;
+ PItem : PffTableDescriptor;
+ WasActive : Boolean; {!!.01}
+begin
+ Assert(Assigned(aList));
+ aList.BeginUpdate;
+ try
+ aList.Clear;
+ if (aDatabaseName <> '') then begin
+ DB := FindFFDatabaseName(Self, aDatabaseName, True); {!!.01}
+ if Assigned(DB) then begin {!!.01}
+ WasActive := DB.Active; {!!.01}
+ DB.Active := True; {!!.01}
+ try
+ TmpList := TList.Create;
+ try
+ Check(ServerEngine.DatabaseTableList(DB.DatabaseID,
+ PChar(aPattern),
+ TmpList));
+ for I := 0 to Pred(TmpList.Count) do begin
+ PItem := PffTableDescriptor(TmpList.Items[I]);
+ if aExtensions then
+ aList.Add(PItem^.tdTableName + '.' + PItem^.tdExt)
+ else
+ aList.Add(PItem^.tdTableName);
+ end;
+ finally
+ for I := Pred(TmpList.Count) downto 0 do begin
+ PItem := PffTableDescriptor(TmpList.Items[I]);
+ FFFreeMem(PItem, SizeOf(PItem^));
+ end;
+ TmpList.Free;
+ end;
+ finally
+ if not WasActive then {!!.01}
+ CloseDatabase(DB);
+ end;{try..finally}
+ end;
+ end;
+ finally
+ aList.EndUpdate;
+ end;{try..finally}
+end;
+{--------}
+function TffSession.GetTaskStatus(
+ const aTaskID : Longint;
+ var aCompleted : Boolean;
+ var aStatus : TffRebuildStatus) : TffResult;
+var
+ IsPresent : Boolean;
+begin
+ Result := DBIERR_NONE;
+
+ if (aTaskID = -1) then begin
+ {TaskID of -1 means no task was created, so pretend it has been
+ completed - there's no need to call the server on this one}
+ aCompleted := True;
+ FillChar(aStatus, SizeOf(aStatus), 0);
+ aStatus.rsFinished := True;
+ Exit;
+ end;
+
+ Result := ServerEngine.RebuildGetStatus(aTaskID,
+ Client.ClientID,
+ IsPresent,
+ aStatus);
+ if IsPresent then begin
+ aCompleted := aStatus.rsFinished;
+ end else
+ Result := DBIERR_OBJNOTFOUND;
+end;
+{--------}
+function TffSession.IsAlias(const aName : string) : Boolean;
+begin
+ Result := IsFFAliasName(Self, aName);
+end;
+{--------}
+function TffSession.ModifyAlias(const aName : string;
+ const aNewName : string;
+ const aNewPath : string;
+ aCheckSpace : Boolean) {!!.11}
+ : TffResult;
+begin
+ Assert(aName <> '');
+ Assert((aNewName <> '') or (ANewPath <> ''));
+ CheckActive;
+ Result := ServerEngine.DatabaseModifyAlias(Client.ClientID,
+ aName,
+ aNewName,
+ aNewPath,
+ aCheckSpace); {!!.11}
+end;
+
+{--------}
+function TffSession.OpenDatabase(const aName : string)
+ : TffBaseDatabase;
+begin
+ Result := FindFFDatabaseName(Self, aName, True);
+ if Assigned(Result) then
+ Result.Active := True;
+end;
+{Begin !!.06}
+{--------}
+function TffSession.ProcessRequest(aMsgID : Longint;
+ aTimeout : Longint;
+ aRequestData : Pointer;
+ aRequestDataLen : Longint;
+ aRequestDataType : TffNetMsgDataType;
+ var aReply : Pointer;
+ var aReplyLen : Longint;
+ aReplyType : TffNetMsgDataType) : TffResult;
+begin
+ Result := scGetClient.ProcessRequest(aMsgID,
+ aTimeout,
+ aRequestData,
+ aRequestDataLen,
+ aRequestDataType,
+ aReply,
+ aReplyLen,
+ aReplyType);
+end;
+{--------}
+function TffSession.ProcessRequestNoReply(aMsgID : Longint;
+ aTimeout : Longint;
+ aRequestData : Pointer;
+ aRequestDataLen : Longint ) : TffResult;
+begin
+ Result := scGetClient.ProcessRequestNoReply(aMsgID,
+ aTimeout,
+ aRequestData,
+ aRequestDataLen);
+end;
+{End !!.06}
+{--------}
+procedure TffSession.SetLoginParameters(const aName : TffName; aPassword : TffName);
+begin
+ if Assigned(Client) then
+ Client.UserName := aName
+ else
+ ffclUsername := aName;
+ ffclPassword := aPassword;
+end;
+{--------}
+procedure TffSession.SetLoginRetries(const aRetries : Integer);
+begin
+ if Assigned(Client) then
+ Client.PasswordRetries := aRetries
+ else
+ ffclLoginRetries := aRetries;
+end;
+{--------}
+function TffSession.scGetClient : TffBaseClient;
+begin
+ Result := TffBaseClient(DBOwner);
+end;
+{--------}
+function TffSession.scGetDatabase(aInx : Integer) : TffBaseDatabase;
+begin
+ Result := TffBaseDatabase(OwnedDBItems[aInx]);
+end;
+{--------}
+function TffSession.scGetDatabaseCount : Integer;
+begin
+ Result := OwnedDBItems.Count;
+end;
+{--------}
+function TffSession.scGetIsDefault : Boolean;
+begin
+ if (DBOwner = nil) then
+ Result := False
+ else
+ Result := TffBaseClient(DBOwner).IsDefault and scIsDefault;
+end;
+{--------}
+function TffSession.scGetServerEngine : TffBaseServerEngine;
+begin
+ if Assigned(scServerEngine) and Active then
+ Result := scServerEngine
+ else
+ Result := Client.ServerEngine;
+end;
+{--------}
+procedure TffSession.scRefreshTimeout; {new !!.11}
+var
+ Idx : Integer;
+begin
+ if Active then begin
+ Check(ServerEngine.SessionSetTimeout(Client.bcClientID, scSessionID, GetTimeout));
+ for Idx :=0 to Pred(OwnedDBItems.Count) do
+ TffBaseDatabase(OwnedDBItems[Idx]).bdRefreshTimeout;
+ end;
+end;
+{--------}
+procedure TffSession.scSetAutoSessionName(const Value : Boolean);
+begin
+ if Value <> scAutoSessionName then begin
+ if Value then begin
+ CheckInactive(False);
+ SessionName := 'FFSession_' + IntToStr(Longint(Self));
+ end;
+ scAutoSessionName := Value;
+ end;
+end;
+{--------}
+procedure TffSession.scSetIsDefault(const Value : Boolean);
+begin
+ if (Value <> scIsDefault) then begin
+ if (DBOwner = nil) then
+ scIsDefault := False
+ else
+ TffBaseClient(DBOwner).bcMakeSessionDefault(Self, Value);
+ end;
+end;
+{--------}
+procedure TffSession.scSetSessionName(const aName : string);
+{Rewritten !!.11}
+var
+ S : TffSession;
+ Counter : Integer;
+ TmpName : string;
+begin
+ if DBName = aName then Exit;
+
+ TmpName := aName;
+ S := FindFFSessionName(TmpName);
+ if (S <> nil) then
+ if scAutoSessionName then begin
+ { Generate a unique name. }
+ Counter := 0;
+ repeat
+ TmpName := aName + IntToStr(Counter);
+ inc(Counter);
+ until FindFFSessionName(TmpName) = nil;
+ end
+ else
+ { Allow case changes to existing name }
+ if not (AnsiUpperCase(TmpName) = AnsiUpperCase(DBName)) then
+ RaiseFFErrorObjFmt(Self, ffdse_SessNameExists, [TmpName]);
+ DBName := TmpName;
+end;
+{--------}
+function TffSession.GetTimeout : Longint;
+begin
+ if (scTimeOut = -1) and assigned(Client) then
+ Result := Client.Timeout
+ else
+ Result := scTimeout;
+end;
+{--------}
+procedure TffSession.scSetTimeout(const Value : Longint);
+begin
+ if scTimeout = Value then Exit;
+ scTimeout := Value;
+
+(* removed !!.11
+ if Active then
+ Check(ServerEngine.SessionSetTimeout(Client.bcClientID, scSessionID, GetTimeout)); {!!.06}*)
+ scRefreshTimeout;
+end;
+{--------}
+procedure TffSession.DoStartup;
+begin
+ { Fire the OnStartup event if necessary }
+ if Assigned(scOnStartup) then
+ scOnStartup(Self);
+
+ { ask the client to open the connection to the server }
+ Client.OpenConnection(Self);
+end;
+{--------}
+procedure TffSession.ChooseServer(var aServerName : TffNetAddress);
+var
+ Names : TStringList;
+// OurServerName : TffNetAddress; {!!.01}
+ ChoseOne : boolean;
+begin
+ aServerName := '';
+ Names := TStringList.Create;
+ try
+ Names.Sorted := true;
+ FindServers(true);
+ try
+ Client.GetServerNames(Names);
+ finally
+ FindServers(false);
+ end;
+ if (Names.Count = 1) then
+ aServerName := Names[0]
+ else if (Names.Count > 1) then begin
+ if Assigned(scChooseServer) then
+ scChooseServer(Self, Names, aServerName, ChoseOne)
+ else
+ with TFFPickServerDlg.Create(nil) do
+ try
+ CBNames.Items.Assign(Names);
+ CBNames.ItemIndex := 0;
+ ShowModal;
+ if (ModalResult = mrOk) then begin
+ aServerName := CBNames.Text;
+ ChoseOne := true;
+ end;
+ finally
+ Free;
+ end;
+ if not ChoseOne then {!!.01}
+// aServerName := OurServerName {!!.01}
+// else {!!.01}
+ aServerName := Names[0];
+ end;
+ finally
+ Names.Free;
+ end;
+end;
+{--------}
+procedure TffSession.FindServers(aStarting : Boolean);
+begin
+ if Assigned(scFindServers) then
+ scFindServers(Self, aStarting);
+end;
+{--------}
+procedure TffSession.DoLogin(var aUserName : TffName;
+ var aPassword : TffName;
+ var aResult : Boolean);
+var
+ FFLoginDialog : TFFLoginDialog;
+begin
+ if Assigned(scLogin) then
+ scLogin(Self, aUserName, aPassword, aResult)
+ else begin
+ FFLoginDialog := TFFLoginDialog.Create(nil);
+ try
+ with FFLoginDialog do begin
+ UserName := aUserName;
+ Password := aPassword;
+ ShowModal;
+ aResult := ModalResult = mrOK;
+ if aResult then begin
+ aUserName := UserName;
+ aPassword := Password;
+ end;
+ end;
+ finally
+ FFLoginDialog.Free;
+ end;
+ end;
+end;
+{====================================================================}
+
+
+{===TffSessionList===================================================}
+function TffSessionList.slGetCurrSess : TffSession;
+begin
+ Result := slCurrSess;
+end;
+{--------}
+function TffSessionList.slGetItem(aInx : Integer) : TffSession;
+begin
+ Result := TffSession(dblGetItem(aInx));
+end;
+{--------}
+procedure TffSessionList.slSetCurrSess(CS : TffSession);
+begin
+ slCurrSess := CS;
+end;
+{====================================================================}
+
+
+{===TffDatabase======================================================}
+constructor TffBaseDatabase.Create(aOwner : TComponent);
+var
+ DefSess : TffSession;
+begin
+ inherited Create(aOwner);
+
+ dbliReqPropName := ffcDatabaseName;
+ bdAutoDBName := False;
+ bdDatabaseID := 0;
+ bdInTransaction := False;
+ bdTimeout := -1;
+ bdServerEngine := nil;
+
+ dbliLoadPriority := 3;
+ {attach ourselves to the default session}
+ DefSess := FindDefaultFFSession;
+ if DefSess <> nil then
+ SessionName := DefSess.SessionName;
+end;
+{--------}
+destructor TffBaseDatabase.Destroy;
+begin
+ FFNotifyDependents(ffn_Destroy);
+
+ Close; {!!.01}
+
+ bdInformTablesAboutDestruction;
+
+ inherited Destroy;
+end;
+{--------}
+function TffBaseDatabase.GetFreeDiskSpace(var aFreeSpace : Longint) : TffResult;
+begin
+ CheckActive;
+ Result := ServerEngine.DatabaseGetFreeSpace(DatabaseID, aFreeSpace);
+end;
+{--------}
+function TffBaseDatabase.GetTimeout : Longint;
+begin
+ if (bdTimeout = -1) and assigned(Session) then
+ Result := Session.GetTimeout
+ else
+ Result := bdTimeout;
+end;
+{--------}
+procedure TffBaseDatabase.CloseDataSets;
+begin
+ inherited dbliClosePrim;
+end;
+{--------}
+function TffDatabase.CreateTable(
+ const aOverWrite : Boolean;
+ const aTableName : TffTableName;
+ aDictionary : TffDataDictionary) : TffResult;
+begin
+ Assert(aTableName <> '');
+ Assert(Assigned(aDictionary));
+ Result := ServerEngine.TableBuild(DatabaseID,
+ aOverWrite,
+ aTableName,
+ False,
+ aDictionary);
+end;
+{--------}
+procedure TffBaseDatabase.Commit;
+begin
+ if bdTransactionCorrupted then
+ Check(DBIERR_FF_CorruptTrans);
+
+ CheckActive;
+ Check(ServerEngine.TransactionCommit(DatabaseID));
+
+ bdInTransaction := False;
+ bdTransactionCorrupted := False;
+end;
+{--------}
+function TffBaseDatabase.ReIndexTable(const aTableName : TffTableName;
+ const aIndexNum : Integer;
+ var aTaskID : Longint) : TffResult;
+begin
+ Assert(aTableName <> '');
+ aTaskID := -1;
+
+ Result := ServerEngine.TableRebuildIndex(DatabaseID,
+ aTableName,
+ '',
+ aIndexNum,
+ aTaskID);
+ if Result <> DBIERR_NONE then
+ aTaskID := -1;
+end;
+{--------}
+function TffDatabase.RestructureTable(
+ const aTableName : TffTableName;
+ aDictionary : TffDataDictionary;
+ aFieldMap : TStrings;
+ var aTaskID : LongInt) : TffResult;
+var
+ I : Integer;
+ FieldMapEntry : TffShStr;
+ TmpTableName : TffTableName;
+ TmpFieldMap : TffStringList;
+begin
+ Assert(aTableName <> '');
+ Assert(Assigned(aDictionary));
+ aTaskID := -1;
+ TmpTableName := ffExtractFileName(aTableName);
+
+ TmpFieldMap := TffStringList.Create;
+ try
+ if Assigned(aFieldMap) then
+ for I := 0 to aFieldMap.Count - 1 do begin
+ FieldMapEntry := aFieldMap[I];
+ TmpFieldMap.Insert(FieldMapEntry);
+ end;
+
+ Result := ServerEngine.TableRestructure(DatabaseID,
+ TmpTableName,
+ aDictionary,
+ TmpFieldMap,
+ aTaskID);
+ finally
+ TmpFieldMap.Free;
+ end;
+
+ if Result <> DBIERR_NONE then
+ aTaskID := -1;
+end;
+{--------}
+procedure TffDatabase.dbliClosePrim;
+begin
+ inherited dbliClosePrim;
+
+ if (bdDatabaseID > 0) then
+ if Assigned(ServerEngine) then
+ Check(ServerEngine.DatabaseClose(bdDatabaseID));
+ bdDatabaseID := 0;
+ bdServerEngine := nil;
+end;
+{--------}
+function TffBaseDatabase.dbliCreateOwnedList : TffDBList;
+begin
+ Result := TffDBList(TffTableProxyList.Create(Self));
+end;
+{--------}
+function TffBaseDatabase.dbliFindDBOwner(const aName : string) : TffDBListItem;
+begin
+ if (aName = '') then
+ Result := FindDefaultFFSession
+ else
+ Result := FindFFSessionName(aName);
+end;
+{--------}
+procedure TffBaseDatabase.dbliMustBeClosedError;
+begin
+ RaiseFFErrorObj(Self, ffdse_DBMustBeClosed);
+end;
+{--------}
+procedure TffBaseDatabase.dbliMustBeOpenError;
+begin
+ RaiseFFErrorObj(Self, ffdse_DBMustBeOpen);
+end;
+{--------}
+procedure TffBaseDatabase.dbliOpenPrim;
+begin
+ inherited dbliOpenPrim;
+
+ bdServerEngine := Session.ServerEngine;
+end;
+{--------}
+procedure TffDatabase.dbliOpenPrim;
+var
+ Alias : string;
+begin
+ if (AliasName <> '') then
+ Alias := AliasName
+ else
+ Alias := DatabaseName;
+
+ Check(ServerEngine.SessionSetCurrent(Session.Client.ClientID,
+ Session.SessionID));
+
+ if not IsPath(Alias) then begin
+ Check(ServerEngine.DatabaseOpen(Session.Client.ClientID,
+ Alias,
+ TffOpenMode(not ReadOnly),
+ TffShareMode(not Exclusive),
+ GetTimeOut,
+ bdDatabaseID));
+ end else begin
+ { Alias is a specified as a path }
+ Check(ServerEngine.DatabaseOpenNoAlias(Session.Client.ClientID,
+ Alias,
+ TffOpenMode(not ReadOnly),
+ TFFShareMode(not Exclusive),
+ GetTimeOut,
+ bdDatabaseID));
+ end;
+end;
+{--------}
+procedure TffBaseDatabase.bdSetAutoDBName(const Value : Boolean);
+begin
+ if Value = bdAutoDBName then
+ Exit;
+
+ if Value then begin
+ CheckInactive(False);
+ DatabaseName := 'FFDB_' + IntToStr(Longint(Self));
+ end;
+
+ bdAutoDBName := Value;
+end;
+{--------}
+function TffBaseDatabase.bdGetDataSetCount : Integer;
+begin
+ Result := OwnedDBItems.Count;
+end;
+{--------}
+function TffBaseDatabase.bdGetDataSet(aInx : Integer) : TffDataSet;
+begin
+ Result := TffTableProxy(OwnedDBItems[aInx]).ffTable;
+end;
+{--------}
+function TffBaseDatabase.bdGetDatabaseID : TffDatabaseID;
+begin
+ if not Active then
+ Active := True;
+ Result := bdDatabaseID;
+end;
+{--------}
+function TffBaseDatabase.bdGetSession : TffSession;
+begin
+ Result := TffSession(DBOwner);
+ if (Result = nil) then
+ RaiseFFErrorObjFmt(Self, ffdse_DBNoOwningSess, [DatabaseName]);
+end;
+{--------}
+procedure TffBaseDatabase.bdInformTablesAboutDestruction;
+var
+ Inx : Integer;
+begin
+ for Inx := Pred(DataSetCount) downto 0 do
+ TffTableProxyList(OwnedDBItems)[Inx].tpDatabaseIsDestroyed;
+end;
+{--------}
+procedure TffDatabase.dcSetAliasName(const aName : string);
+begin
+ CheckInactive(False);
+ dcAliasName := aName;
+end;
+{--------}
+procedure TffBaseDatabase.bdSetDatabaseName(const aName : string);
+{Rewritten !!.11}
+var
+ Counter : Integer;
+ TmpName : string;
+begin
+ if DBName = aName then Exit;
+
+ TmpName := aName;
+ if not (csReading in ComponentState) then begin
+ if (Owner <> nil) and IsffAliasName(Session, TmpName) then
+ RaiseFFErrorObjFmt(Self, ffdse_MatchesAlias, [TmpName]);
+ if IsffDatabaseName(Session, TmpName) then
+ if bdAutoDBName then begin
+ { Generate a unique name. }
+ Counter := 0;
+ repeat
+ TmpName := aName + IntToStr(Counter);
+ inc(Counter);
+ until not IsFFDatabaseName(Session, TmpName);
+ end
+ else
+ { Allow case changes to existing name }
+ if not (AnsiUpperCase(TmpName) = AnsiUpperCase(DBName)) then
+ RaiseFFErrorObjFmt(Self, ffdse_DBNameExists, [TmpName]);
+ end;
+ dbliSetDBName(TmpName);
+end;
+{--------}
+procedure TffBaseDatabase.bdSetExclusive(aValue : Boolean);
+var
+ Inx : Integer;
+begin
+ CheckInactive(False);
+ bdExclusive := aValue;
+ if aValue then
+ for Inx := pred(DataSetCount) downto 0 do
+ TffTableProxyList(OwnedDBItems)[Inx].ffTable.Exclusive := True;
+end;
+{--------}
+procedure TffBaseDatabase.bdSetReadOnly(aValue : Boolean);
+var
+ Inx : Integer;
+begin
+ CheckInactive(False);
+ bdReadOnly := aValue;
+ if aValue then
+ for Inx := pred(DataSetCount) downto 0 do
+ TffTableProxyList(OwnedDBItems)[Inx].ffTable.ReadOnly := True;
+end;
+{--------}
+procedure TffBaseDatabase.bdSetTimeout(const Value : Longint);
+begin
+ if bdTimeout = Value then Exit;
+ bdTimeout := Value;
+
+(* removed !!.11
+ if Active then begin
+ Check(ServerEngine.DatabaseSetTimeout(bdDatabaseID, GetTimeout)); {!!.06}
+ end; *)
+ bdRefreshTimeout;
+end;
+{--------}
+procedure TffDatabase.GetTableNames(aList : TStrings);
+var
+ CEWasActive : Boolean;
+ SSWasActive : Boolean;
+ WasActive : Boolean;
+ TmpList : TList;
+ I : Integer;
+ PItem : PffTableDescriptor;
+
+begin
+ Assert(Assigned(aList));
+
+ CEWasActive := Session.Client.Active;
+ SSWasActive := Session.Active;
+ WasActive := Active;
+ if not WasActive then
+ Active := True;
+ try
+ aList.BeginUpdate;
+ try
+ TmpList := TList.Create;
+ try
+ Check(ServerEngine.DatabaseTableList(DatabaseID,
+ '',
+ TmpList));
+ for I := 0 to Pred (TmpList.Count) do begin
+ PItem := PffTableDescriptor(TmpList.Items[I]);
+ aList.Add(PItem^.tdTableName);
+ end;
+ finally
+ for I := Pred(TmpList.Count) downto 0 do begin
+ PItem := PffTableDescriptor(TmpList.Items[I]);
+ FFFreeMem(PItem, SizeOf(PItem^));
+ end;
+ TmpList.Free;
+ end;
+ finally
+ aList.EndUpdate;
+ end;{try..finally}
+ finally
+ if not WasActive then
+ Active := False;
+ if not SSWasActive then
+ Session.Active := False;
+ if not CEWasActive then
+ Session.Client.Active := False;
+ end;{try..finally}
+end;
+{--------}
+function TffBaseDatabase.PackTable(const aTableName : TffTableName;
+ var aTaskID : LongInt) : TffResult;
+begin
+ Assert(aTableName <> '');
+ aTaskID := -1;
+
+ Result := ServerEngine.TablePack(DatabaseID,
+ aTableName,
+ aTaskID);
+ if Result <> DBIERR_NONE then
+ aTaskID := -1;
+end;
+{--------}
+function TffBaseDatabase.IsSQLBased : Boolean;
+begin
+ Result := False;
+end;
+{--------}
+procedure TffBaseDatabase.Rollback;
+begin
+ CheckActive;
+ Check(ServerEngine.TransactionRollback(DatabaseID));
+
+ bdInTransaction := False;
+ bdTransactionCorrupted := False;
+end;
+{--------}
+procedure TffBaseDatabase.StartTransaction;
+begin
+ CheckActive;
+ if bdInTransaction then
+ Check(DBIERR_ACTIVETRAN);
+
+ Check(ServerEngine.TransactionStart(bdDatabaseID,
+ bdFailSafe));
+ bdInTransaction := True;
+ bdTransactionCorrupted := False;
+end;
+{Begin !!.10}
+{--------}
+function TffBaseDatabase.StartTransactionWith(const aTables: array of TffBaseTable) : TffResult;
+var
+ CursorIDList : TffPointerList;
+ Inx : Integer;
+begin
+ CheckActive;
+ if bdInTransaction then
+ Check(DBIERR_ACTIVETRAN);
+
+ CursorIDList := TffPointerList.Create;
+ try
+ for Inx := Low(aTables) to High(aTables) do begin
+ if not aTables[Inx].Active then
+ RaiseFFErrorObjFmt(Self, ffdse_StartTranTblActive,
+ [aTables[Inx].TableName]);
+ CursorIDList.Append(Pointer(aTables[Inx].CursorID));
+ end; { for }
+
+ Result := ServerEngine.TransactionStartWith(bdDatabaseID,
+ bdFailSafe,
+ CursorIDList);
+ if Result = DBIERR_NONE then begin
+ bdInTransaction := True;
+ bdTransactionCorrupted := False;
+ end;
+
+ finally
+ CursorIDList.Free;
+ end;
+end;
+{End !!.10}
+{--------}
+function TffBaseDatabase.TryStartTransaction;
+begin
+ Result := not InTransaction;
+ if Result then
+ StartTransaction;
+end;
+{--------}
+procedure TffBaseDatabase.TransactionCorrupted;
+begin
+ bdTransactionCorrupted := True;
+end;
+{--------}
+function TffBaseDatabase.TableExists(const aTableName : TffTableName) : Boolean;
+ {rewritten !!.11}
+var
+ SSWasActive : Boolean;
+ CEWasActive : Boolean;
+ WasActive : Boolean;
+begin
+ Assert(aTableName <> '');
+ SSWasActive := Session.Active;
+ CEWasActive := Session.Client.Active;
+ WasActive := Active;
+ try
+ if not WasActive then
+ Open;
+ Check(ServerEngine.DatabaseTableExists(DatabaseID,
+ aTableName,
+ Result));
+ finally
+ if not WasActive then
+ Close;
+ if not SSWasActive then
+ Session.Close;
+ if not CEWasActive then
+ Session.Client.Close;
+ end;
+end;
+{--------}
+function TffBaseDatabase.GetFFDataDictionary(const TableName : TffTableName;
+ Stream : TStream) : TffResult;
+begin
+ Assert(TableName <> '');
+ Assert(Assigned(Stream));
+ Result := ServerEngine.TableGetDictionary(DatabaseID,
+ FFExtractFileName(TableName),
+ False,
+ Stream);
+end;
+{====================================================================}
+
+
+{====================================================================}
+function TffDatabaseList.dlGetItem(aInx : Integer) : TffBaseDatabase;
+begin
+ Result := TffBaseDatabase(dblGetItem(aInx));
+end;
+{====================================================================}
+
+
+{===TffTableProxyList================================================}
+procedure TffTableProxyList.dblFreeItem(aItem : TffDBListItem);
+var
+ Inx : Integer;
+ TableProxy : TffTableProxy;
+begin
+ Inx := IndexOfItem(aItem);
+ if (Inx <> -1) then begin
+ TableProxy := Tables[Inx];
+ TableProxy.ffTable.Free;
+ TableProxy.ffTable := nil;
+ end;
+end;
+{--------}
+function TffTableProxyList.tlGetItem(aInx : Integer) : TffTableProxy;
+begin
+ Result := TffTableProxy(dblGetItem(aInx));
+end;
+{====================================================================}
+
+
+{===TffTableProxy====================================================}
+constructor TffTableProxy.Create(aOwner : TComponent);
+var
+ DefSess : TffSession;
+begin
+ inherited Create(aOwner);
+
+ dbliReqPropName := ffcTableName;
+ tpServerEngine := nil;
+ dbliLoadPriority := 4;
+ {make us have the default session as our session}
+ DefSess := FindDefaulTffSession;
+ if (DefSess <> nil) then
+ SessionName := DefSess.SessionName;
+end;
+{--------}
+procedure TffTableProxy.dbliClosePrim;
+begin
+ if not tpClosing then begin
+ tpClosing := True;
+ {close the real table}
+ if (ffTable <> nil) then
+ ffTable.dsCloseViaProxy;
+ {let our ancestor do its stuff}
+
+ tpServerEngine := nil;
+ inherited dbliClosePrim;
+
+ tpClosing := False;
+ end;
+end;
+{--------}
+function TffTableProxy.dbliFindDBOwner(const aName : string) : TffDBListItem;
+var
+ i : Integer;
+ DB : TffDatabase;
+begin
+ if (tpSession = nil) then
+ Result := nil
+ else begin
+ try
+ Result := FindffDatabaseName(tpSession, aName, (not FixingFromStream)); {!!.05}
+
+ {if not found just look on the same form}
+ if (Result = nil) and
+ (aName <>'') and
+ (ffTable <> nil) and
+ (ffTable.Owner <> nil) then begin
+ for i := 0 to pred(ffTable.Owner.ComponentCount) do
+ if ffTable.Owner.Components[i] is TffDatabase then begin
+ DB := TffDatabase(ffTable.Owner.Components[i]);
+ if (DB.SessionName = SessionName) and
+ (DB.DatabaseName = aName) then begin
+ Result := DB;
+ Exit;
+ end;
+ end;
+ end;
+
+ except
+ Result := nil;
+ end;
+ end;
+end;
+{--------}
+procedure TffTableProxy.dbliLoaded;
+var
+ StreamName : string;
+begin
+ try
+ if (tpSessionName <> '') then begin
+ StreamName := tpSessionName;
+ tpSessionName := '';
+ SessionName := StreamName;
+ end;
+ except
+ if (csDesigning in ComponentState) then
+ Application.HandleException(Self)
+ else
+ raise;
+ end;{try..except}
+ if (Session <> nil) and Session.LoadActiveFailed then
+ dbliMakeActive := False;
+
+ inherited dbliLoaded;
+end;
+{--------}
+procedure TffTableProxy.dbliMustBeClosedError;
+begin
+ RaiseFFErrorObj(Self, ffdse_TblMustBeClosed);
+end;
+{--------}
+procedure TffTableProxy.dbliMustBeOpenError;
+begin
+ RaiseFFErrorObj(Self, ffdse_TblMustBeOpen);
+end;
+{--------}
+procedure TffTableProxy.dbliOpenPrim;
+begin
+ tpServerEngine := Session.ServerEngine;
+end;
+{--------}
+procedure TffTableProxy.dbliDBOwnerChanged;
+begin
+ inherited;
+
+ SessionName := Database.SessionName;
+end;
+{--------}
+procedure TffTableProxy.tpDatabaseIsDestroyed;
+begin
+ tpDBGone := True;
+end;
+{--------}
+function TffTableProxy.tpGetCursorID : TffCursorID;
+begin
+ if not Active then
+ Active := True;
+ Result := tpCursorID;
+end;
+{--------}
+function TffTableProxy.tpGetDatabase : TffBaseDatabase;
+begin
+ Result := TffBaseDatabase(DBOwner);
+end;
+{--------}
+function TffTableProxy.tpGetSession : TffSession;
+begin
+ if (tpSession = nil) then
+ tpResolveSession;
+ Result := tpSession;
+end;
+{--------}
+function TffTableProxy.tpGetSessionName : string;
+begin
+ if (tpSession <> nil) then
+ tpSessionName := tpSession.SessionName;
+ Result := tpSessionName;
+end;
+{--------}
+procedure TffTableProxy.tpResolveSession;
+begin
+ tpSession := FindffSessionName(tpSessionName);
+end;
+{--------}
+procedure TffTableProxy.tpSetSessionName(aValue : string);
+begin
+ CheckInactive(True);
+ if (csReading in ComponentState) or LoadingFromStream then begin
+ tpSessionName := aValue;
+ tpSession := nil;
+ end
+ else
+ if (FFAnsiCompareText(aValue, SessionName) <> 0) then begin {!!.07}
+ tpSession := FindffSessionName(aValue);
+ if (tpSession <> nil) then
+ tpSessionName := tpSession.SessionName
+ else
+ tpSessionName := aValue;
+ if (not FixingFromStream) then begin
+ {if we're changing session, we should invalidate our database}
+ { Our owner may have had it's session changed, so we first need
+ to see if our database is in this new session }
+ if Assigned(dbliDbOwner) then
+ if Database.dbliDBOwner = tpSession then
+ {our database's session changed too, leave the internal database field alNone }
+ else
+ //dbliDBOwner := nil; {!!.12}
+ dbliSetDBOwner(nil); {!!.12}
+ end;
+ end;
+end;
+{====================================================================}
+
+
+{===TffFieldDescItem=================================================}
+constructor TffFieldDescItem.Create(aContainer : TffCollection;
+ const FD : FLDDesc);
+begin
+ inherited Create(nil, aContainer);
+
+ FFGetMem(fdiPhyDesc, sizeof(FLDDesc));
+ Move(FD, fdiPhyDesc^, sizeof(FLDDesc));
+ FFGetMem(fdiLogDesc, sizeof(FLDDesc));
+ GetBDELogicalFieldDescriptor(fdiPhyDesc^, fdiLogDesc^);
+ fdiFieldNum := succ(Identifier);
+end;
+{--------}
+destructor TffFieldDescItem.Destroy;
+begin
+ if (fdiPhyDesc <> nil) then
+ FFFreeMem(fdiPhyDesc, sizeof(FLDDesc));
+ if (fdiLogDesc <> nil) then
+ FFFreeMem(fdiLogDesc, sizeof(FLDDesc));
+
+ inherited Destroy;
+end;
+{====================================================================}
+
+
+{===TffTable=========================================================}
+{--------}
+destructor TffDataSet.Destroy;
+begin
+ dsDictionary.Free;
+ dsDictionary := nil;
+ dsFilters.Free;
+ dsFilters := nil;
+ dsFieldDescs.Free;
+ dsFieldDescs := nil;
+
+ {destroy our proxy}
+ dsProxy.Free;
+ dsProxy := nil;
+
+ inherited Destroy;
+end;
+{--------}
+constructor TffDataSet.Create(aOwner : TComponent);
+begin
+ inherited Create(aOwner);
+ dsCursorID := 0;
+ dsTimeout := -1;
+ dsXltMode := xltFIELD;
+ dsCurRecBuf := nil;
+ dsFilterTimeOut := 500;
+ dsFilterEval := ffeServer;
+ dsFilterResync := True;
+ dsServerEngine := nil;
+
+ dsFieldDescs := TffCollection.Create;
+ dsFilters := TffCollection.Create;
+
+ {create our proxy}
+ dsProxy := TffTableProxy.Create(Self);
+ dsProxy.ffTable := Self;
+
+ dsDictionary := TffDataDictionary.Create(4096);
+
+end;
+{--------}
+constructor TffBaseTable.Create(aOwner : TComponent);
+begin
+ inherited Create(aOwner);
+
+ btLookupCursorID := 0;
+ btIgnoreDataEvents := False; {!!.06}
+
+ {create the index definitions}
+ btIndexDefs := TIndexDefs.Create(Self);
+ {set up a master table link, if needed}
+ btMasterLink := TMasterDataLink.Create(Self);
+ btMasterLink.OnMasterChange := btMasterChanged;
+ btMasterLink.OnMasterDisable := btMasterDisabled;
+ btRangeStack := TffTableRangeStack.Create;
+end;
+{--------}
+destructor TffBaseTable.Destroy;
+begin
+ Close;
+
+ btRangeStack.Free;
+ btRangeStack := nil;
+ btMasterLink.Free;
+ btMasterLink := nil;
+ btIndexDefs.Free;
+ btIndexDefs := nil;
+
+ inherited Destroy;
+end;
+{--------}
+function TffDataSet.AddFileBlob(const aField : Word;
+ const aFileName : TffFullFileName) : TffResult;
+var
+ IsNull : Boolean;
+ BLOBNr : TffInt64;
+ aData : Pointer;
+begin
+ Assert(aFileName <> '');
+ aData := ActiveBuffer;
+ if not (Dictionary.FieldType[Pred(aField)] in
+ [fftBLOB..ffcLastBLOBType]) then begin
+ Result := DBIERR_NOTABLOB;
+ Exit;
+ end;
+
+ Result := DBIERR_NONE;
+ {if the BLOB exists, we need to delete it}
+ Dictionary.GetRecordField(Pred(aField),
+ aData,
+ IsNull,
+ @BLOBNr);
+ if not IsNull then begin
+ {truncate it to 0}
+ Result := TruncateBLOB(ActiveBuffer, aField, 0);
+ {and now Free it}
+ if Result = DBIERR_NONE then
+ Result := FreeBLOB(ActiveBuffer, aField);
+ end;
+
+ if Result <> DBIERR_NONE then
+ Exit;
+
+ {now, there's no BLOB there - Add the fileBLOB}
+ Result := ServerEngine.FileBLOBAdd(CursorID,
+ aFileName,
+ BLOBNr);
+ if Result = DBIERR_NONE then
+ Dictionary.SetRecordField(Pred(aField),
+ aData,
+ @BLOBNr);
+end;
+
+{--------}
+procedure TffBaseTable.AddIndex(const aName, aFields : string;
+ aOptions : TIndexOptions);
+var
+ IndexDesc : TffIndexDescriptor;
+ EFNPOS : Integer;
+ Fld : string;
+ FldsInKey : Integer;
+ FldList : TffFieldList;
+ TaskID : Longint;
+ Done : Boolean;
+ TaskStatus : TffRebuildStatus;
+ Stream : TMemoryStream;
+ WasActive : Boolean;
+ Bookmark : TBookmark;
+ RangeSaved : Boolean;
+ Request : PffnmCursorSetRangeReq;
+ SetRangeReqLen : Integer;
+begin
+ WasActive := Active;
+ {ensure the field definitions are updated}
+ FieldDefs.Update;
+
+ {encode the index descriptor}
+ IndexDesc.idNumber := 0;
+ IndexDesc.idName := aName;
+ IndexDesc.idDesc := '';
+ IndexDesc.idFile := 0;
+ IndexDesc.idKeyLen := 0;
+ FillChar(IndexDesc.idFieldIHlprs, SizeOf(IndexDesc.idFieldIHlprs), 0);
+ IndexDesc.idDups := not (ixUnique in aOptions);
+ IndexDesc.idAscend := not (ixDescending in aOptions);
+ IndexDesc.idNoCase := ixCaseInsensitive in aOptions;
+ EFNPOS := 0;
+ FldsInKey := 0;
+
+ while (EFNPos <= Length(aFields)) and
+ (FldsInKey < DBIMAXFLDSINKEY) do begin
+ Fld:= ExtractFieldName(aFields, EFNPos);
+ if (Fld <> '') and (Fld[length(Fld)] = ';') then
+ System.Delete(Fld, length(Fld), 1);
+ FldList[FldsInKey] := Pred(FieldDefs.Find(Fld).FieldNo);
+ Inc(FldsInKey);
+ end;
+
+ IndexDesc.idCount := FldsInKey;
+ IndexDesc.idFields := FldList;
+
+ {if the table is open, make sure it's in browse mode and then add
+ the index}
+
+ if WasActive then begin
+ { We need to restore the position of the cursor when we are done. }
+ Bookmark := GetBookmark;
+ { If a range is active then push it onto the range stack.
+ We will restore the range when we are done. }
+ RangeSaved := False;
+ if btRangeStack.SavedRequest then begin
+ btRangeStack.PushSavedRequest;
+ RangeSaved := True;
+ end;
+
+ { The table must be closed before an index can be added. }
+ CheckBrowseMode;
+ CursorPosChanged;
+ Check(ServerEngine.CursorClose(CursorID));
+ try
+ Check(ServerEngine.TableAddIndex(Database.DatabaseID,
+ 0,
+ TableName,
+ IndexDesc));
+ Check(ServerEngine.TableRebuildIndex(Database.DatabaseID,
+ TableName,
+ IndexDesc.idName,
+ IndexDesc.idNumber,
+ TaskID));
+
+ { OK, now wait until the re-index is complete ... }
+ Done := False;
+ while not Done do begin
+ Sleep(250);
+ Check(Session.GetTaskStatus(TaskID, Done, TaskStatus));
+ end;
+ finally
+ { Re-open the table. }
+ dsCursorID := GetCursorHandle(IndexName);
+ { Do we need to restore a prior range? }
+ if rangeSaved then begin
+ btRangeStack.popSavedRequest(PffByteArray(Request), SetRangeReqLen);
+ { Send the request. Assume that if it fails we should
+ continue operation anyway. }
+
+ ServerEngine.CursorSetRange(Request^.CursorID,
+ Request^.DirectKey,
+ Request^.FieldCount1,
+ Request^.PartialLen1,
+ PffByteArray(@Request^.KeyData1),
+ Request^.KeyIncl1,
+ Request^.FieldCount2,
+ Request^.PartialLen2,
+ PffByteArray(@Request^.KeyData2),
+ Request^.KeyIncl2);
+
+ end;
+ {reset the record position}
+ if (Bookmark <> nil) then begin
+ Check(ServerEngine.CursorSetToBookmark(CursorID,
+ Bookmark));
+ FreeBookmark(Bookmark);
+ end;
+ end;
+
+ end else begin
+ {otherwise use our database to add the index}
+ dsEnsureDatabaseOpen(True);
+ try
+ Check(ServerEngine.TableAddIndex(Database.DatabaseID,
+ CursorID,
+ TableName,
+ IndexDesc));
+ Check(ServerEngine.TableRebuildIndex(Database.DatabaseID,
+ TableName,
+ IndexDesc.idName,
+ IndexDesc.idNumber,
+ TaskID));
+
+ { OK, now wait until the re-index is complete ... }
+ Done := False;
+ while not Done do begin
+ Sleep(250);
+ Check(Session.GetTaskStatus(TaskID, Done, TaskStatus));
+ end;
+
+ finally
+ dsEnsureDatabaseOpen(False);
+ end;
+
+ { re-fetch data dictionary }
+ Stream := TMemoryStream.Create;
+ try
+ if Database.GetFFDataDictionary(TableName, Stream) = DBIERR_NONE then begin
+ Stream.Position:= 0;
+ Dictionary.ReadFromStream(Stream);
+ end;
+ finally
+ Stream.Free;
+ end;
+
+ end;
+
+ { Make sure the index definitions are updated when required. }
+ btIndexDefs.Updated := False;
+end;
+{--------}
+function TffBaseTable.AddIndexEx(const aIndexDesc : TffIndexDescriptor;
+ var aTaskID : LongInt) : TffResult;
+begin
+ CheckInactive;
+ Result := ServerEngine.TableAddIndex(Database.DatabaseID,
+ CursorID,
+ TableName,
+ aIndexDesc);
+ if Result = DBIERR_NONE then
+ Result := ServerEngine.TableRebuildIndex(Database.DatabaseID,
+ TableName,
+ aIndexDesc.idName,
+ aIndexDesc.idNumber,
+ aTaskID);
+ if Result <> DBIERR_NONE then
+ aTaskID := -1;
+end;
+{--------}
+function TffDataSet.AllocRecordBuffer : PChar;
+begin
+ FFGetZeroMem(Result, dsRecBufSize);
+ Assert(Assigned(Result), 'Rec Buf not Assigned');
+end;
+{--------}
+procedure TffBaseTable.ApplyRange;
+begin
+ CheckBrowseMode;
+ if btSetRange then
+ First;
+end;
+{--------}
+function TffDataSet.BookmarkValid(aBookmark : TBookmark) : Boolean;
+begin
+ if (dsCursorID = 0) or not Assigned(aBookmark) then
+ Result := False
+ else begin
+ CursorPosChanged;
+ Result := ServerEngine.CursorSetToBookmark(CursorID,
+ aBookmark) = DBIERR_NONE;
+ if Result then
+ Result := dsGetRecord(ffltNoLock, nil, nil) = DBIERR_NONE;
+ end;
+end;
+{--------}
+procedure TffBaseTable.Cancel;
+begin
+ inherited Cancel;
+
+ if (State = dsSetKey) then
+ btEndKeyBufferEdit(False);
+end;
+{--------}
+procedure TffBaseTable.CancelRange;
+begin
+ CheckBrowseMode;
+ UpdateCursorPos;
+ if btResetRange(CursorID, False) then
+ Resync([]);
+end;
+{--------}
+procedure TffDataSet.ClearCalcFields(aBuffer : PChar);
+begin
+ FillChar(aBuffer[dsCalcFldOfs], CalcFieldsSize, 0);
+end;
+{--------}
+procedure TffDataSet.CloseBlob(aField : TField);
+begin
+ FreeBlob(ActiveBuffer, aField.FieldNo);
+end;
+{--------}
+procedure TffDataSet.CloseCursor;
+begin
+{Begin !!.05}
+ try
+ {call our ancestor (who'll call InternalClose)}
+ inherited CloseCursor;
+
+ {if we have a handle destroy it}
+ if (dsCursorID > 0) then
+ try
+ DestroyHandle(dsCursorID);
+ finally
+ dsCursorID := 0;
+ end;
+ finally
+ {close our table proxy}
+ if (dsProxy <> nil) then begin
+ dsClosing := True;
+ dsProxy.Close;
+ dsClosing := False;
+ end;
+ end;
+{End !!.05}
+end;
+{--------}
+function TffDataSet.CompareBookmarks(Bookmark1,
+ Bookmark2 : TBookmark) : Integer;
+{Begin !!.02}
+{$IFNDEF RaiseBookmarksExcept}
+var
+ aResult : TffResult;
+{$ENDIF}
+{End !!.02}
+begin
+ if (BookMark1 = nil) or (Bookmark2 = nil) then begin
+ if (Bookmark1 = nil) then
+ if (Bookmark2 = nil) then
+ Result := 0
+ else
+ Result := 1
+ else
+ Result := -1;
+ Exit;
+ end;
+
+ CheckActive;
+{Begin !!.02}
+{$IFDEF RaiseBookmarksExcept}
+ Check(ServerEngine.CursorCompareBookmarks(CursorID,
+ Bookmark1,
+ Bookmark2,
+ Result));
+{$ELSE}
+ aResult := ServerEngine.CursorCompareBookmarks(CursorID,
+ Bookmark1,
+ Bookmark2,
+ Result);
+ if aResult <> DBIERR_NONE then
+ Result := aResult;
+{$ENDIF}
+{End !!.02}
+end;
+{--------}
+function TffDataSet.CreateBlobStream(aField : TField;
+ aMode : TBlobStreamMode) : TStream;
+begin
+ Assert(Assigned(aField));
+ Result := TffBlobStream.Create(aField as TBlobField, aMode);
+end;
+{Begin !!.02}
+{--------}
+procedure TffDataset.CopyRecords(aSrcTable : TffDataset; aCopyBLOBs : Boolean); {!!.06}
+var
+ WasOpen : Boolean;
+begin
+ CheckBrowseMode;
+ { Make sure the source table is open. }
+ WasOpen := aSrcTable.Active;
+ if not WasOpen then
+ aSrcTable.Open;
+ try
+ Check(ServerEngine.CursorCopyRecords(aSrcTable.CursorID, CursorID, aCopyBLOBs));
+ finally
+ if not WasOpen then
+ aSrcTable.Close;
+ end;
+end;
+{--------}
+procedure TffBaseTable.CreateTable; {!!.05}
+begin {!!.05}
+ Assert(Assigned(Dictionary)); {!!.10}
+ CreateTableEx(Dictionary.BlockSize); {!!.10}
+end; {!!.05}
+{--------}
+procedure TffBaseTable.CreateTableEx(const aBlockSize : Integer); {!!.05}
+var
+ Dict : TffDataDictionary;
+ EFNPOS : Integer;
+ Fld : string;
+ FldList : TffFieldList;
+ FldIHList : TffFieldIHList;
+ FldType : TffFieldType;
+ FldsInKey : Integer;
+ i : integer;
+ FldPhysSize : word;
+ SeqAccessName : TffShStr;
+begin
+ {the table can't be open}
+ dsProxy.CheckInactive(true);
+ {make sure we have defined all fields within our object}
+ if (FieldDefs.Count = 0) then
+ for i := 0 to pred(FieldCount) do
+ if (Fields[i].FieldKind = fkData) then
+ FieldDefs.Add(Fields[i].FieldName,
+ Fields[i].DataType,
+ Fields[i].Size,
+ Fields[i].Required);
+ {now fill in the descriptor fields}
+ dsEnsureDatabaseOpen(true);
+ try
+ Dict := TffDataDictionary.Create(aBlockSize); {!!.05}
+ try
+ for i := 0 to pred(FieldDefs.Count) do
+ with FieldDefs[i] do begin
+ MapVCLTypeToFF(DataType, Size, FldType, FldPhysSize);
+ if FldType <> fftReserved20 then begin
+ Dict.AddField(Name, '', FldType, FldPhysSize, Precision, Required, nil)
+ end else
+ RaiseFFErrorObjFmt(Self, ffdse_InvalidFieldType,
+ [GetEnumName(TypeInfo(TFieldType), ord(DataType)),
+ Name]);
+ end;
+
+ SeqAccessName := uppercase(ffStrResGeneral[ffscSeqAccessIndexName]);
+ for i := 0 to pred(IndexDefs.Count) do
+ with IndexDefs[i] do
+ if (UpperCase(Name) <> SeqAccessName) then begin
+ { Get Field List }
+ EFNPOS := 0;
+ FldsInKey := 0;
+ while (EFNPos <= Length(Fields)) and
+ (FldsInKey < DBIMAXFLDSINKEY) do begin
+ Fld:= ExtractFieldName(Fields, EFNPos);
+ if (Fld<>'') and
+ (Fld[length(Fld)]=';') then
+ System.delete(Fld, length(Fld), 1);
+ FldList[FldsInKey] := pred(FieldDefs.Find(Fld).FieldNo);
+ FldIHLIst[FldsInKey] := '';
+ Inc(FldsInKey);
+ end;
+ Dict.AddIndex(Name,
+ '',
+ 0,
+ FldsInKey,
+ FldList,
+ FldIHList,
+ not (ixUnique in Options),
+ not (ixDescending in Options),
+ ixCaseInsensitive in Options);
+ end;
+
+ TffDatabase(Database).CreateTable(True, TableName, Dict);
+ finally
+ Dict.Free;
+ end;
+ finally
+ dsEnsureDatabaseOpen(false);
+ end;
+end;
+{--------}
+procedure TffBaseTable.DataEvent(aEvent: db.TDataEvent; aInfo: Longint);
+begin
+ if btIgnoreDataEvents then {!!.06}
+ Exit; {!!.06}
+ if (aEvent = dePropertyChange) then
+ IndexDefs.Updated := False;
+
+ inherited DataEvent(aEvent, aInfo);
+
+ if aEvent = deUpdateState then
+ if State = dsEdit then begin
+ FreeRecordBuffer(dsOldValuesBuffer);
+ dsOldValuesBuffer := AllocRecordBuffer;
+ Move(ActiveBuffer^, dsOldValuesBuffer^, dsRecBufSize);
+ end else begin
+ FreeRecordBuffer(dsOldValuesBuffer);
+ dsOldValuesBuffer := nil;
+ end;
+end;
+{--------}
+procedure TffBaseTable.DeleteIndex(const aIndexName : string);
+var
+ VerifiedName : string;
+begin
+ btRetrieveIndexName(aIndexName, True, VerifiedName);
+ if Active then begin
+ CheckBrowseMode;
+ Check(ServerEngine.TableDropIndex(Database.DatabaseID,
+ CursorID,
+ TableName,
+ VerifiedName,
+ 0));
+ end else begin
+ dsEnsureDatabaseOpen(True);
+ try
+ Check(ServerEngine.TableDropIndex(Database.DatabaseID,
+ 0,
+ TableName,
+ VerifiedName,
+ 0));
+ finally
+ dsEnsureDatabaseOpen(False);
+ end;
+ end;
+ btIndexDefs.Updated := False;
+end;
+{Begin !!.06}
+{--------}
+procedure TffBaseTable.DeleteRecords;
+begin
+ CheckActive;
+ if State in [dsInsert, dsSetKey] then Cancel else
+ begin
+ DataEvent(deCheckBrowseMode, 0);
+ DoBeforeDelete;
+ DoBeforeScroll;
+ Check(ServerEngine.CursorDeleteRecords(CursorID));
+ FreeFieldBuffers;
+ SetState(dsBrowse);
+ Resync([]);
+ DoAfterDelete;
+ DoAfterScroll;
+ end;
+end;
+{End !!.06}
+{--------}
+procedure TffDataSet.DeleteTable;
+begin
+ dsProxy.CheckInactive(True);
+ dsEnsureDatabaseOpen(True);
+ try
+ Check(ServerEngine.TableDelete(Database.DatabaseID,
+ TableName));
+ finally
+ dsEnsureDatabaseOpen(False);
+ end;
+end;
+{--------}
+procedure TffBaseTable.DoOnNewRecord;
+var
+ i : Integer;
+begin
+ if btMasterLink.Active and (btMasterLink.Fields.Count > 0) then
+ for i := 0 to pred(btMasterLink.Fields.Count) do
+ IndexFields[i] := TField(btMasterLink.Fields[i]);
+
+ inherited DoOnNewRecord;
+end;
+{--------}
+procedure TffBaseTable.EditKey;
+begin
+ btSetKeyBuffer(ketNormal, False);
+end;
+{--------}
+procedure TffBaseTable.EditRangeEnd;
+begin
+ btSetKeyBuffer(ketRangeEnd, False);
+end;
+{--------}
+procedure TffBaseTable.EditRangeStart;
+begin
+ btSetKeyBuffer(ketRangeStart, False);
+end;
+{--------}
+procedure TffDataSet.EmptyTable;
+
+begin
+ if Active then begin
+ CheckBrowseMode;
+ Active := False;
+ Check(ServerEngine.TableEmpty(Database.DatabaseID,
+ 0,
+ TableName));
+ Active := True;
+ end else begin
+ dsEnsureDatabaseOpen(True);
+ try
+ Check(ServerEngine.TableEmpty(Database.DatabaseID,
+ 0,
+ TableName));
+ finally
+ dsEnsureDatabaseOpen(False);
+ end;
+ end;
+end;
+{--------}
+function TffBaseTable.FindKey(const aKeyValues: array of const): Boolean;
+begin
+ CheckBrowseMode;
+ btSetKeyFields(ketNormal, aKeyValues);
+ Result := GotoKey;
+end;
+{--------}
+procedure TffBaseTable.FindNearest(const aKeyValues : array of const);
+begin
+ CheckBrowseMode;
+ btSetKeyFields(ketNormal, aKeyValues);
+ GotoNearest;
+end;
+{--------}
+function TffDataSet.FreeBlob( { Free the blob }
+ pRecBuf : Pointer; { Record Buffer }
+ iField : Word { Field number of blob(1..n) }
+ ) : TffResult;
+var
+ BLOBNr : TffInt64;
+ IsNull : Boolean;
+begin
+ Result := dsCheckBLOBHandle(pRecBuf, iField, IsNull, BLOBNr);
+ if (Result = DBIERR_NONE) and (not IsNull) then begin
+ Result := ServerEngine.BLOBFree(CursorID,
+ BLOBNr,
+ dsBlobOpenMode = omREADONLY);
+ if (Result = DBIERR_BLOBMODIFIED) then begin
+ {DBIERR_BLOBMODIFIED is a special ff 'error' when received here:
+ it means that the BLOB was empty and so the BLOB number has
+ been deleted at the server; the client must set the BLOB field
+ to null}
+ Dictionary.SetRecordField(pred(iField), pRecBuf, nil);
+ dsModifyRecord(pRecBuf, False);
+ end;
+ end;
+end;
+{--------}
+function TffDataSet.FindRecord(aRestart, aGoForward : Boolean) : Boolean;
+begin
+ {Note: this method is called by FindFirst/Last/Next/Prior; for each
+ possibility the parameters are TT / TF / FT / ff }
+ CheckBrowseMode;
+ DoBeforeScroll;
+ SetFound(False);
+ UpdateCursorPos;
+ CursorPosChanged;
+ if not Filtered then
+ dsActivateFilters;
+ try
+ if aGoForward then begin
+ if aRestart then
+ InternalFirst;
+ Result := (dsGetNextRecord(ffltNoLock, nil, nil) = DBIERR_NONE);
+ end else begin
+ if aRestart then
+ Check(ServerEngine.CursorSetToEnd(CursorID));
+ Result := (dsGetPriorRecord(ffltNoLock, nil, nil) = DBIERR_NONE);{!!.01}
+ end;
+ finally
+ if not Filtered then
+ dsDeactivateFilters;
+ end;
+ if Result then begin
+ Resync([rmExact, rmCenter]);
+ SetFound(True);
+ DoAfterScroll;
+ end;
+ Result := Found;
+end;
+{--------}
+procedure TffDataSet.FreeRecordBuffer(var aBuffer : PChar);
+begin
+ if Assigned(aBuffer) then begin
+ FFFreeMem(aBuffer, dsRecBufSize);
+ aBuffer := nil;
+ end;
+end;
+{--------}
+procedure TffDataSet.GetBookmarkData(aBuffer : PChar; aData : Pointer);
+begin
+ Move(aBuffer[dsBookmarkOfs], aData^, BookmarkSize);
+end;
+{--------}
+function TffDataSet.GetBookmarkFlag(aBuffer : PChar): TBookmarkFlag;
+begin
+ Result := PDataSetRecInfo(aBuffer + dsRecInfoOfs)^.riBookmarkFlag
+end;
+{--------}
+function TffDataSet.GetCanModify : Boolean;
+begin
+ {the TffTable can be modified if it is open, and in readwrite mode}
+ Result := Active and (not ReadOnly);
+end;
+{--------}
+function TffDataSet.GetCurrentRecord(aBuffer : PChar) : Boolean;
+begin
+ if (not IsEmpty) and (GetBookmarkFlag(ActiveBuffer) = bfCurrent) then begin
+ UpdateCursorPos;
+ Result := dsGetRecord(ffltNoLock, aBuffer, nil) = DBIERR_NONE;
+ end else
+ Result := False;
+end;
+{--------}
+{$IFDEF ProvidesDatasource}
+function TffBaseTable.GetDataSource: TDataSource;
+begin
+ Result := MasterSource;
+end;
+{$ENDIF}
+{--------}
+function TffDataSet.GetFieldData(aField : TField; aBuffer : Pointer): Boolean;
+var
+ IsBlank : Boolean;
+ RecBuf : PChar;
+ FDI : TffFieldDescItem;
+ Status : TffResult;
+begin
+ Result := False;
+ if not GetActiveRecBuf(RecBuf) then
+ Exit;
+ if aField.FieldNo > 0 then begin
+ if dsCursorID <> 0 then begin
+ if (RecBuf = nil) then
+ Status := DBIERR_INVALIDPARAM
+ else begin
+ if dsGetFieldDescItem(aField.FieldNo, FDI) then
+ Status := dsTranslateGet(FDI, RecBuf, aBuffer, IsBlank)
+ else
+ Status := DBIERR_OUTOFRANGE;
+ end;
+ Check(Status);
+ end;
+ Result := not IsBlank;
+ end
+ else {FieldNo <= 0} begin
+ if State in [dsBrowse, dsEdit, dsInsert, dsCalcFields] then begin
+ Inc(RecBuf, dsCalcFldOfs + aField.offset);
+ Result := Boolean(RecBuf[0]);
+ if Result and (aBuffer <> nil) then
+ Move(RecBuf[1], aBuffer^, aField.DataSize);
+ end;
+ end;
+end;
+{--------}
+procedure TffBaseTable.GetIndexNames(aList : TStrings);
+var
+ i : Integer;
+begin
+ UpdateIndexDefs;
+ aList.BeginUpdate;
+ try
+ aList.Clear;
+ for i := 0 to pred(btIndexDefs.Count) do
+ if (btIndexDefs[i].Name <> '') then
+ aList.Add(btIndexDefs[i].Name);
+ finally
+ aList.EndUpdate;
+ end;
+end;
+{--------}
+function TffBaseTable.GetIsIndexField(Field : TField): Boolean;
+var
+ i : Integer;
+begin
+ Result := True;
+ for i := 0 to pred(IndexFieldCount) do
+ if (Field.FieldNo = btFieldsInIndex[i]) then
+ Exit;
+ Result := False;
+end;
+{--------}
+function TffDataSet.GetRecNo: Integer;
+begin
+ Result := -1;
+end;
+{--------}
+function TffDataSet.GetRecord(aBuffer : PChar;
+ aGetMode : TGetMode;
+ aDoCheck : Boolean): TGetResult;
+var
+ Status : TffResult;
+ Buff : Pointer;
+begin
+ {read the current, next or prior record; no locks placed}
+ case aGetMode of
+ gmCurrent :
+ (*if Assigned(dsCurRecBuf) then begin {removed !!.03}
+ Move(dsCurRecBuf^,aBuffer^,dsPhyRecSize);
+ Status := DBIERR_NONE;
+ end else*)
+ Status := dsGetRecord(ffltNoLock, aBuffer, nil);
+ gmNext :
+ begin
+ Status := dsGetNextRecord(ffltNoLock, Pointer(aBuffer), nil);
+ end;
+ gmPrior :
+ begin
+ Status := dsGetPriorRecord(ffltNoLock, Pointer(aBuffer), nil);
+ end;
+ else
+ Status := DBIERR_NONE;
+ end;
+ {check the status}
+ {..for success, set the record info fields, and get the bookmark}
+ {..for EOF and BOF, set the bookmark status}
+ {..for anything else, return an error}
+ case Status of
+ DBIERR_NONE :
+ begin
+ with PDataSetRecInfo(aBuffer + dsRecInfoOfs)^ do begin
+ riBookmarkFlag := bfCurrent;
+ riRecNo := 0;
+ end;
+ Buff := aBuffer + dsBookmarkOfs;
+ Check(ServerEngine.CursorGetBookmark(CursorID,
+ Buff));
+ GetCalcFields(aBuffer);
+ Result := grOK;
+ end;
+ DBIERR_BOF :
+ Result := grBOF;
+ DBIERR_EOF :
+ Result := grEOF;
+ else
+ Result := grError;
+ if aDoCheck then
+ Check(Status);
+ end;
+end;
+{--------}
+function TffDataSet.GetRecordBatch(RequestCount : Longint;
+ var ReturnCount : Longint;
+ pRecBuff : Pointer): TffResult;
+var
+ aError : TffResult;
+begin
+ CheckActive;
+ ReturnCount := 0;
+ Result := ServerEngine.RecordGetBatch(CursorID,
+ RequestCount,
+ PhysicalRecordSize,
+ ReturnCount,
+ pRecBuff,
+ aError);
+end;
+{------}
+function TffDataSet.GetRecordBatchEx(RequestCount : Longint;
+ var ReturnCount : Longint;
+ pRecBuff : Pointer;
+ var Error : TffResult): TffResult;
+begin
+ CheckActive;
+ ReturnCount := 0;
+ Result := ServerEngine.RecordGetBatch(CursorID,
+ RequestCount,
+ PhysicalRecordSize,
+ ReturnCount,
+ pRecBuff,
+ Error);
+end;
+{------}
+function TffDataSet.GetRecordCount : Integer;
+begin
+ CheckActive;
+ Check(dsGetRecordCountPrim(Result));
+end;
+{--------}
+function TffDataSet.GetRecordSize : Word;
+begin
+ Result := dsPhyRecSize;
+end;
+{--------}
+function TffDataset.dsGetTimeout : Longint;
+begin
+ if (dsTimeout = -1) and assigned(Database) then
+ Result := Database.GetTimeout
+ else
+ Result := dsTimeout;
+end;
+{--------}
+procedure TffDataSet.GotoCurrent(aDataSet : TffDataSet);
+begin
+ if (FFAnsiCompareText(DatabaseName, aDataSet.DatabaseName) <> 0) or {!!.07}
+ (FFAnsiCompareText(TableName, aDataSet.TableName) <> 0) then {!!.07}
+ RaiseFFErrorObj(Self, ffdse_NotSameTbl);
+ CheckBrowseMode;
+ aDataSet.CheckBrowseMode;
+ aDataSet.UpdateCursorPos;
+ Check(ServerEngine.CursorSetToCursor(CursorID,
+ aDataSet.CursorID));
+ DoBeforeScroll;
+ Resync([rmExact, rmCenter]);
+ DoAfterScroll;
+end;
+{--------}
+function TffBaseTable.GotoKey : Boolean;
+var
+ KeyRecInfo : PKeyRecInfo;
+ KeyRecBuffer : PChar;
+begin
+ CheckBrowseMode;
+ DoBeforeScroll;
+ CursorPosChanged;
+ KeyRecBuffer := PKeyBuffers(btKeyBuffers)^[ketNormal];
+ KeyRecInfo := PKeyRecInfo(KeyRecBuffer + btKeyInfoOfs);
+ ffGetMem(dsCurRecBuf,dsPhyRecSize);
+ try
+ Result := btGetRecordForKey(CursorID, False,
+ KeyRecInfo^.kriFieldCount,
+ 0,
+ KeyRecBuffer,
+ dsCurRecBuf) = DBIERR_NONE;
+ if Result then begin
+ Resync([rmExact, rmCenter]);
+ DoAfterScroll;
+ end;
+ finally
+ FFFreeMem(dsCurRecBuf,dsPhyRecSize);
+ dsCurRecBuf := nil;
+ end;
+end;
+{--------}
+procedure TffBaseTable.GotoNearest;
+var
+ SearchCond : TffSearchKeyAction;
+ KeyRecInfo : PKeyRecInfo;
+ KeyRecBuffer : PChar;
+ Status : TffResult;
+begin
+ CheckBrowseMode;
+ CursorPosChanged;
+ KeyRecBuffer := PKeyBuffers(btKeyBuffers)^[ketNormal];
+ KeyRecInfo := PKeyRecInfo(KeyRecBuffer + btKeyInfoOfs);
+ if KeyRecInfo^.kriExclusive then
+ SearchCond := skaGreater
+ else
+ SearchCond := skaGreaterEqual;
+ Status := ServerEngine.CursorSetToKey(CursorID,
+ SearchCond,
+ False,
+ KeyRecInfo^.kriFieldCount,
+ 0,
+ Pointer(KeyRecBuffer));
+ if Status = DBIERR_ff_FilterTimeout then
+ if not dsCancelServerFilter then
+ Status := dsGetNextRecordPrim(CursorID, ffltNOLOCK, nil, nil);
+ Check(Status);
+ Resync([rmCenter]);
+end;
+{--------}
+procedure TffDataSet.InitFieldDefs;
+var
+ SaveHandle : TffCursorID;
+begin
+ dsEnsureDatabaseOpen(True);
+ try
+ if (TableName = '') then
+ RaiseFFErrorObj(Self, ffdse_UnnamedTblNoFlds);
+ SaveHandle := cursorID;
+ if (SaveHandle = 0) then
+{Begin !!.03}
+ OpenCursor(True);
+// dsCursorID := GetCursorHandle('');
+ try
+ InternalInitFieldDefs;
+ finally
+ if (SaveHandle = 0) then begin
+ CloseCursor;
+// DestroyHandle(dsCursorID);
+// dsCursorID := 0;
+{End !!.03}
+ end;
+ end;
+ finally
+ dsEnsureDatabaseOpen(False);
+ end;{try..finally}
+end;
+{--------}
+function TffDataSet.InsertRecordBatch(Count : Longint;
+ pRecBuff : Pointer;
+ Errors : PffLongintArray) : TffResult;
+var
+ iErr : Integer;
+begin
+ if not Assigned(pRecBuff) or not Assigned(Errors) then begin
+ Result := DBIERR_INVALIDHNDL;
+ Exit;
+ end;
+ CheckBrowseMode;
+ Result := ServerEngine.RecordInsertBatch(CursorID,
+ Count,
+ PhysicalRecordSize,
+ pRecBuff,
+ Errors);
+ if Result = DBIERR_NONE then begin
+ for iErr := 0 to pred(Count) do
+ if Errors^[iErr] <> DBIERR_NONE then begin
+ Result := Errors^[iErr];
+ Break;
+ end;
+ end;
+end;
+{------}
+procedure TffDataSet.InternalAddRecord(aBuffer : Pointer; aAppend : Boolean);
+begin
+ if aAppend then
+ Check(ServerEngine.CursorSetToEnd(CursorID));
+ Check(ServerEngine.RecordInsert(CursorID,
+ ffltWriteLock,
+ aBuffer));
+end;
+{--------}
+procedure TffDataSet.InternalCancel;
+begin
+ if (State = dsEdit) or (State = dsInsert) then
+ Check(ServerEngine.RecordRelLock(CursorID,
+ False));
+end;
+{--------}
+procedure TffDataSet.InternalClose;
+begin
+{Begin !!.05}
+ try
+ {deactivate filters}
+ if Filtered then
+ dsDeactivateFilters;
+ finally
+ {drop filters}
+ dsDropFilters;
+ {clear up the fields}
+ BindFields(False);
+ if DefaultFields then
+ DestroyFields;
+ dsServerEngine := nil;
+ end;
+{End !!.05}
+end;
+{--------}
+procedure TffBaseTable.InternalClose;
+begin
+ inherited InternalClose;
+ {free our key Buffers}
+ btFreeKeyBuffers;
+
+ {reset important variables}
+ btIndexFieldCount := 0;
+ btKeyLength := 0;
+ btNoCaseIndex := False;
+end;
+{--------}
+procedure TffDataSet.InternalDelete;
+var
+ Result : TffResult;
+begin
+ {delete the record}
+ Result := ServerEngine.RecordDelete(CursorID,
+ nil);
+ {apart from success, we allow not found type errors; check others}
+ if (Result <> DBIERR_NONE) and
+ (ErrCat(Result) <> ERRCAT_NOTFOUND) then
+ Check(Result);
+end;
+{--------}
+procedure TffDataSet.InternalEdit;
+begin
+ {get the record, placing a lock for the duration of the edit}
+ Check(ServerEngine.RecordGet(CursorID,
+ ffltWriteLock,
+ Pointer(ActiveBuffer)));
+end;
+{--------}
+procedure TffDataSet.InternalFirst;
+begin
+ Check(ServerEngine.CursorSetToBegin(CursorID));
+end;
+{--------}
+procedure TffDataSet.InternalGotoBookmark(aBookmark : TBookmark);
+begin
+ if not Assigned(aBookmark) then
+ Check(DBIERR_INVALIDHNDL);
+
+ Check(ServerEngine.CursorSetToBookmark(CursorID,
+ aBookmark));
+end;
+{--------}
+procedure TffDataSet.InternalHandleException;
+begin
+ Application.HandleException(Self);
+end;
+{--------}
+procedure TffDataSet.InternalInitFieldDefs;
+var
+ ffFldDesc : PffFieldDescriptor;
+ i : Integer;
+begin
+ FieldDefs.Clear;
+ with Dictionary do
+ for i := 0 to pred(FieldCount) do begin
+ ffFldDesc := FieldDescriptor[i];
+ dsAddFieldDesc(ffFldDesc, succ(i));
+ end;
+end;
+{--------}
+procedure TffDataSet.InternalInitRecord(aBuffer : PChar);
+begin
+ Dictionary.InitRecord(Pointer(aBuffer));
+ Dictionary.SetDefaultFieldValues(Pointer(aBuffer));
+ with PDataSetRecInfo(aBuffer + dsRecInfoOfs)^ do begin
+ riRecNo := 0;
+ end;
+end;
+{--------}
+procedure TffDataSet.InternalLast;
+begin
+ Check(ServerEngine.CursorSetToEnd(CursorID));
+end;
+{$IFDEF ResizePersistFields}
+{--------}
+procedure TffDataSet.ReSizePersistentFields;
+var
+ I, FieldIndex: Integer;
+ aFieldDef: TFieldDef; //soner renamed from: FieldDef
+begin
+ for I := 0 to Fields.Count - 1 do
+ with Fields[I] do begin
+ if FieldKind = fkData then begin
+ {$ifdef fpc} //soner todo FieldDefList
+ FieldIndex := FieldDefs.IndexOf(FieldName); //soner ist eigentlich FullName aber das gibts bei fpc nicht! But it's working :-)
+ {$else}
+ FieldIndex := FieldDefList.IndexOf(FullName);
+ {$endif}
+ if FieldIndex <> -1 then begin
+ {$ifdef fpc} //soner todo FieldDefList, it's it looks like Delphi.FieldDefList=Fpc.FieldDefs
+ aFieldDef := FieldDefs.Items[FieldIndex];
+ {$else}
+ aFieldDef := FieldDefList[FieldIndex];
+ {$endif}
+ if (DataType = ftString) and (Size <> aFieldDef.Size) then
+ Size := aFieldDef.Size;
+ end;
+ end;
+ end;
+end;
+{$ENDIF}
+{--------}
+procedure TffDataset.InternalOpen;
+var
+ CursorProps : TffCursorProps;
+begin
+ dsServerEngine := Session.ServerEngine;
+ {Note: by the time this method gets called, the FlashFiler table has
+ been physically opened and tcHandle is valid.}
+ GetCursorProps(CursorProps);
+ dsPhyRecSize := CursorProps.RecordBufferSize;
+ BookmarkSize := CursorProps.BookmarkSize;
+ InternalInitFieldDefs;
+ dsGetIndexInfo;
+ if DefaultFields then
+ CreateFields;
+{$IFDEF ResizePersistFields}
+ ReSizePersistentFields;
+{$ENDIF}
+
+ BindFields(True);
+ dsGetRecordInfo(False);
+ dsAllocKeyBuffers;
+ InternalFirst;
+ dsCheckMasterRange;
+ if (FilterEval = ffeLocal) and (Filter <> '') then
+ dsAddExprFilter(Filter, FilterOptions);
+ if Assigned(OnFilterRecord) then
+ dsAddFuncFilter(@TffBaseTable.dsOnFilterRecordCallback);
+ if Filtered then
+ dsActivateFilters;
+end;
+{--------}
+procedure TffDataSet.InternalPost;
+begin
+ {$IFDEF DCC6OrLater} {!!.05}
+ inherited InternalPost; {!!.05}
+ {$ENDIF} {!!.05}
+
+ {if we're editing a record, modify the record & remove lock}
+ if (State = dsEdit) then
+ Check(dsModifyRecord(Pointer(ActiveBuffer), True))
+ {if we're inserting a record, do it & don't place lock}
+ else if (State = dsInsert) then
+ Check(ServerEngine.RecordInsert(CursorID,
+ ffltWriteLock,
+ Pointer(ActiveBuffer)));
+end;
+{--------}
+procedure TffDataSet.InternalSetToRecord(aBuffer: PChar);
+begin
+ InternalGotoBookmark(aBuffer + dsBookmarkOfs);
+end;
+{--------}
+function TffDataSet.IsCursorOpen : Boolean;
+begin
+ Result := (CursorID > 0);
+end;
+{--------}
+function TffDataSet.IsSequenced : Boolean;
+begin
+ Result := False;
+end;
+{--------}
+procedure TffDataSet.Loaded;
+begin
+ dsProxy.Loaded;
+
+ inherited Loaded;
+end;
+{--------}
+function TffBaseTable.Locate(const aKeyFields : string;
+ const aKeyValues : Variant;
+ aOptions : TLocateOptions) : Boolean;
+begin
+ DoBeforeScroll;
+ Result := btLocateRecord(aKeyFields, aKeyValues, aOptions, True);
+ if Result then begin
+ Resync([rmExact, rmCenter]);
+ DoAfterScroll;
+ end;
+end;
+{--------}
+procedure TffDataSet.LockTable(LockType: TffLockType);
+
+begin
+ dsSetTableLock(LockType, True);
+end;
+{--------}
+function TffBaseTable.Lookup(const aKeyFields : string;
+ const aKeyValues : Variant;
+ const aResultFields : string) : Variant;
+begin
+ Result := Null;
+ if btLocateRecord(aKeyFields, aKeyValues, [], False) then begin
+ SetTempState(dsCalcFields);
+ try
+ CalculateFields(TempBuffer);
+ Result := FieldValues[aResultFields];
+ finally
+ RestoreState(dsBrowse);
+ end;{try..finally}
+ end;
+end;
+{--------}
+function TffDataSet.PackTable(var aTaskID : LongInt) : TffResult;
+begin
+ Result := Database.PackTable(TableName, aTaskID);
+end;
+{--------}
+procedure TffDataSet.OpenCursor(aInfoQuery : Boolean);
+begin
+ {make sure our database is open first}
+ dsEnsureDatabaseOpen(True);
+ {open our proxy table}
+ dsProxy.Open;
+ {create the cursor handle}
+ dsCursorID := dsCreateHandle;
+ if (CursorID = 0) then
+ RaiseFFErrorObj(Self, ffdse_CantGetTblHandle);
+ {call our ancestor (who'll call InternalOpen, where the rest of the
+ open process happens)}
+
+ inherited OpenCursor(aInfoQuery);
+end;
+{--------}
+procedure TffBaseTable.InternalOpen;
+begin
+ btChangeHandleIndex;
+ btIgnoreDataEvents := False; {!!.06}
+
+ inherited InternalOpen;
+end;
+{--------}
+function TffDataSet.OverrideFilterEx(aExprTree : ffSrBDE.pCANExpr;
+ const aTimeout : TffWord32) : TffResult;
+var
+ ExprTree : CANExpr;
+begin
+ if not Assigned(aExprTree) then begin
+ aExprTree := @ExprTree;
+ FillChar(ExprTree, SizeOf(ExprTree), 0);
+ ExprTree.iVer := CANEXPRVERSION;
+ ExprTree.iTotalSize := SizeOf(ExprTree);
+ end;
+
+ Result := ServerEngine.CursorOverrideFilter(CursorID,
+ aExprTree,
+ aTimeout);
+end;
+{--------}
+procedure TffBaseTable.Post;
+begin
+ inherited Post;
+
+ if (State = dsSetKey) then begin {!!.03}
+ btEndKeyBufferEdit(True);
+ Resync([]); {!!.03}
+ end; {!!.03}
+end;
+{--------}
+function TffBaseTable.ReIndexTable(const aIndexNum : Integer;
+ var aTaskID : Longint) : TffResult;
+begin
+ Result := Database.ReIndexTable(TableName, aIndexNum, aTaskID);
+end;
+{--------}
+procedure TffDataSet.RenameTable(const aNewTableName : string);
+begin
+ dsProxy.CheckInactive(True);
+ dsEnsureDatabaseOpen(True);
+ try
+ Check(ServerEngine.TableRename(Database.DatabaseID,
+ TableName,
+ aNewTableName));
+ finally
+ dsEnsureDatabaseOpen(False);
+ end;
+ TableName := aNewTableName;
+end;
+{Begin !!.07}
+{--------}
+procedure TffDataSet.RecordCountAsync(var TaskID : Longint);
+begin
+ CheckActive;
+ Check(ServerEngine.TableGetRecCountAsync(CursorID, TaskID));
+end;
+{End !!.07}
+{--------}
+function TffDataSet.RestoreFilterEx : TffResult;
+begin
+ Result := ServerEngine.CursorRestoreFilter(CursorID);
+end;
+{--------}
+function TffDataSet.RestructureTable(aDictionary : TffDataDictionary;
+ aFieldMap : TStrings;
+ var aTaskID : LongInt) : TffResult;
+begin
+ CheckInactive;
+ Result := TffDatabase(Database).RestructureTable(TableName,
+ aDictionary,
+ aFieldMap,
+ aTaskID);
+end;
+{--------}
+function TffDataSet.SetFilterEx(aExprTree : ffSrBDE.pCANExpr;
+ const aTimeout : TffWord32) : TffResult;
+var
+ ExprTree : CANExpr;
+begin
+ if not Assigned(aExprTree) then begin
+ aExprTree := @ExprTree;
+ FillChar(ExprTree, SizeOf(ExprTree), 0);
+ ExprTree.iVer := CANEXPRVERSION;
+ ExprTree.iTotalSize := SizeOf(ExprTree);
+ end;
+
+ Result := ServerEngine.CursorSetFilter(CursorID,
+ aExprTree,
+ aTimeout);
+end;
+{--------}
+procedure TffDataSet.SetBookmarkData(aBuffer : PChar; aData : Pointer);
+begin
+ Move(aData^, aBuffer[dsBookmarkOfs], BookmarkSize);
+end;
+{--------}
+procedure TffDataSet.SetBookmarkFlag(aBuffer : PChar; aValue : TBookmarkFlag);
+begin
+ PDataSetRecInfo(aBuffer + dsRecInfoOfs).riBookmarkFlag := aValue;
+end;
+{--------}
+procedure TffDataSet.SetFieldData(aField : TField; aBuffer : Pointer);
+var
+ RecBuf : PChar;
+ FDI : TffFieldDescItem;
+ Status : TffResult;
+begin
+ with aField do begin
+ if not (State in dsWriteModes) then
+ RaiseFFErrorObj(Self, ffdse_TblNotEditing);
+ if not GetActiveRecBuf(RecBuf) then
+ RaiseFFErrorObj(Self, ffdse_TblCantGetBuf);
+ if (FieldNo > 0) then begin
+ if (State = dsCalcFields) then
+ RaiseFFErrorObj(Self, ffdse_TblCalcFlds);
+ if ReadOnly and
+ (not (State in [dsSetKey, dsFilter])) then
+ RaiseFFErrorObj(Self, ffdse_TblReadOnlyEdit);
+ Validate(aBuffer);
+ if (FieldKind <> fkInternalCalc) then begin
+ if (RecBuf = nil) then
+ Status := DBIERR_INVALIDPARAM
+ else begin
+ if dsGetFieldDescItem(FieldNo, FDI) then
+ Status := dsTranslatePut(FDI, RecBuf, aBuffer)
+ else
+ Status := DBIERR_OUTOFRANGE;
+ end;
+ Check(Status);
+ end;
+ end
+ else {FieldNo = 0; ie fkCalculated, fkLookup} begin
+ inc(RecBuf, dsCalcFldOfs + offset);
+ Boolean(RecBuf[0]) := LongBool(aBuffer);
+ if Boolean(RecBuf[0]) then
+ Move(aBuffer^, RecBuf[1], DataSize);
+ end;
+ if not (State in [dsCalcFields, dsFilter, dsNewValue]) then
+ DataEvent(deFieldChange, Longint(aField));
+ end;
+end;
+{--------}
+procedure TffBaseTable.SetFieldData(aField : TField; aBuffer : Pointer);
+begin
+ with aField do begin
+ if (State = dsSetKey) and
+ ((FieldNo < 0) or
+ (IndexFieldCount > 0) and (not IsIndexField)) then
+ RaiseFFErrorObj(Self, ffdse_TblFldNotInIndex);
+ end;
+ inherited SetFieldData(aField, aBuffer);
+end;
+{--------}
+procedure TffDataSet.SetFiltered(Value : Boolean);
+begin
+ if not Active then
+ inherited SetFiltered(Value)
+ else begin
+ CheckBrowseMode;
+ if (Filtered <> Value) then begin
+ if (not Value) or dsFilterResync then
+ InternalFirst;
+ if Value then
+ dsActivateFilters
+ else
+ dsDeactivateFilters;
+ inherited SetFiltered(Value);
+ if (not Value) or dsFilterResync then
+ First;
+ end;
+ end;
+end;
+{--------}
+procedure TffBaseTable.SetFiltered(Value : Boolean);
+begin
+ if not Active then
+ inherited SetFiltered(Value)
+ else begin
+ CheckBrowseMode;
+ if (Filtered <> Value) then begin
+ btDestroyLookupCursor;
+ inherited SetFiltered(Value);
+ end;
+ end;
+end;
+{Begin !!.03}
+{--------}
+procedure TffBaseTable.dsActivateFilters;
+begin
+ inherited;
+ btDestroyLookupCursor;
+end;
+{--------}
+procedure TffBaseTable.dsDeactivateFilters;
+begin
+ inherited;
+ btDestroyLookupCursor;
+end;
+{End !!.03}
+{--------}
+procedure TffDataSet.SetFilterOptions(Value : TFilterOptions);
+begin
+ dsSetFilterTextAndOptions(Filter, Value, dsFilterEval,
+ dsFilterTimeOut);
+end;
+{--------}
+procedure TffDataSet.SetFilterText(const Value : string);
+begin
+ dsSetFilterTextAndOptions(Value, FilterOptions, dsFilterEval,
+ dsFilterTimeOut);
+ { If the new filter string is blank, we may need to reset the Filtered flag }
+ if (Value = '') and Filtered then
+ Filtered := False;
+end;
+{--------}
+procedure TffBaseTable.SetKey;
+begin
+ btSetKeyBuffer(ketNormal, True);
+end;
+{--------}
+procedure TffDataSet.SetName(const NewName : TComponentName);
+begin
+ inherited SetName(NewName);
+
+ dsProxy.Name := NewName + '_Proxy';
+end;
+{--------}
+procedure TffDataSet.SetOnFilterRecord(const Value : TFilterRecordEvent);
+begin
+ {if there is no change there's nothing to do}
+ if (@Value = @OnFilterRecord) then
+ Exit;
+ {if the table is active...}
+ if Active then begin
+ CheckBrowseMode;
+ {firstly drop the current function filter}
+ if (dsFuncFilter <> nil) then begin
+ Check(dsDropFilter(dsFuncFilter));
+ dsFuncFilter := nil;
+ end;
+ {if the filter function is not nil...}
+ if Assigned(Value) then begin
+ {add the new function}
+ dsAddFuncFilter(@TffBaseTable.dsOnFilterRecordCallback);
+ {activate it}
+ if Filtered then
+ Check(dsActivateFilter(dsFuncFilter));
+ end;
+
+ {call our ancestor}
+ inherited SetOnFilterRecord(Value);
+
+ {if the table is being filtered, go to the start}
+ if Filtered then
+ First;
+ end
+ else {table is not active} begin
+ {call our ancestor}
+ inherited SetOnFilterRecord(Value);
+ end;
+end;
+{--------}
+procedure TffBaseTable.SetRange(const aStartValues, aEndValues: array of const);
+begin
+ CheckBrowseMode;
+ btSetKeyFields(ketRangeStart, aStartValues);
+ btSetKeyFields(ketRangeEnd, aEndValues);
+ ApplyRange;
+end;
+{--------}
+procedure TffBaseTable.SetRangeEnd;
+begin
+ btSetKeyBuffer(ketRangeEnd, True);
+end;
+{--------}
+procedure TffBaseTable.SetRangeStart;
+begin
+ btSetKeyBuffer(ketRangeStart, True);
+end;
+{--------}
+function TffDataSet.SetTableAutoIncValue(const aValue: TffWord32) : TffResult;
+begin
+ Result := ServerEngine.TableSetAutoInc(CursorID,
+ aValue);
+end;
+{--------}
+function TffDataset.Exists : Boolean;
+begin
+ Result := Active;
+ if Result or (TableName = '') then Exit;
+
+ dsEnsureDatabaseOpen(True); {!!.11}
+ Result := Database.TableExists(TableName);
+end;
+{--------}
+procedure TffDataSet.dsActivateFilters;
+begin
+ {activate the server side filter}
+ if (dsFilterEval = ffeServer) then
+ dsSetServerSideFilter(Filter, FilterOptions, dsFilterTimeOut);
+
+ {activate the expression filter}
+ if (dsExprFilter <> nil) then begin
+ Check(dsActivateFilter(dsExprFilter));
+ end;
+
+ {activate the function filter}
+ if (dsFuncFilter <> nil) then begin
+ Check(dsActivateFilter(dsFuncFilter));
+ end;
+end;
+{--------}
+procedure TffDataSet.dsAddExprFilter(const aText : string;
+ const aOpts : TFilterOptions);
+{$ifdef DONTUSEDELPHIUNIT} //soner
+begin
+ raise Exception.Create('In this version [dsCreateLookupFilter] not supperted!');
+end;
+{$else}
+var
+ Parser : TExprParser;
+begin
+ {$IFDEF ExprParserType1}
+ Parser := TExprParser.Create(Self, aText, aOpts);
+ {$ENDIF}
+ {$IFDEF ExprParserType2}
+ Parser := TExprParser.Create(Self, aText, aOpts, [], '', nil);
+ {$ENDIF}
+ {$IFDEF ExprParserType3}
+ {$ifdef fpc}
+ Parser := TExprParser.Create(Self, aText, aOpts, [poExtSyntax], '', nil, FldTypeMap);
+ {$else}
+ Parser := TExprParser.Create(Self, aText, aOpts, [], '', nil, FldTypeMap);
+ {$endif}
+ {$ENDIF}
+ try
+ Check(dsAddFilter(0, 0, False,
+ PCANExpr(Parser.FilterData),
+ nil, dsExprFilter));
+ finally
+ Parser.Free;
+ end;
+end;
+{$endif}
+{--------}
+procedure TffDataSet.dsAddFieldDesc(aFieldDesc : PffFieldDescriptor;
+ aFieldNo : Integer);
+var
+ BDEType : Word;
+ BDESubType : Word;
+ BDESize : Word;
+ VCLType : TFieldType;
+ {$IFDEF CBuilder3}
+ FieldDef : TFieldDef;
+ {$ENDIF}
+begin
+ with aFieldDesc^ do begin
+ {convert the ff type to the nearest BDE logical one}
+ MapffTypeToBDE(fdType, fdLength, BDEType, BDESubType, BDESize);
+ {convert the BDE logical type to a VCL type}
+ VCLType := DataTypeMap[BDEType];
+ {qualify the VCL type, if required}
+ case VCLType of
+ ftInteger :
+ if (BDESubType = fldstAUTOINC) then
+ VCLType := ftAutoInc;
+ ftFloat :
+ if (BDESubType = fldstMONEY) then
+ VCLType := ftCurrency;
+ ftBLOB :
+ VCLType := BlobTypeMap[BDESubType];
+ end;
+ {create the new field definition}
+ if (VCLType <> ftUnknown) then begin
+ if (VCLType <> ftString) and
+ (VCLType <> ftBytes) and
+ (VCLType <> ftBCD) then
+ BDESize := 0;
+ {$IFDEF CBuilder3}
+ FieldDef := TFieldDef.Create(FieldDefs);
+ FieldDef.Name := fdName;
+ FieldDef.DataType := VCLType;
+ FieldDef.Size := BDESize;
+ FieldDef.Required := fdRequired;
+ FieldDef.FieldNo := aFieldNo;
+ {$ELSE}
+ TFieldDef.Create(FieldDefs,
+ fdName,
+ VCLType,
+ BDESize,
+ fdRequired,
+ aFieldNo);
+ {$ENDIF}
+ end;
+ end;
+end;
+{--------}
+procedure TffDataSet.dsAddFuncFilter(aFilterFunc : pfGENFilter);
+begin
+ Check(dsAddFilter(Integer(Self), 0, False, nil, aFilterFunc, dsFuncFilter));
+end;
+{--------}
+function TffDataSet.dsCancelServerFilter: Boolean;
+begin
+ Result := False;
+ if Assigned(dsOnServerFilterTimeout) then
+ dsOnServerFilterTimeout(Self, Result);
+end;
+{------}
+procedure TffBaseTable.dsAllocKeyBuffers;
+var
+ i : TffKeyEditType;
+begin
+ FFGetMem(btKeyBuffers, sizeof(Pointer) * succ(ord(High(TffKeyEditType))));
+ for i := Low(TffKeyEditType) to High(TffKeyEditType) do begin
+ FFGetMem(PKeyBuffers(btKeyBuffers)^[i], btKeyBufSize);
+ btInitKeyBuffer(PKeyBuffers(btKeyBuffers)^[i]);
+ end;
+end;
+{--------}
+procedure TffBaseTable.btFreeKeyBuffers;
+var
+ i : TffKeyEditType;
+begin
+ if (btKeyBuffers <> nil) then begin
+ for i := Low(TffKeyEditType) to High(TffKeyEditType) do begin
+ if (PKeyBuffers(btKeyBuffers)^[i] <> nil) then
+ FFFreeMem(PKeyBuffers(btKeyBuffers)^[i], btKeyBufSize);
+ end;
+ FFFreeMem(btKeyBuffers, sizeof(Pointer) * succ(ord(High(TffKeyEditType))));
+ btKeyBuffers := nil;
+ end;
+ btKeyBuffer := nil;
+end;
+{--------}
+procedure TffBaseTable.btChangeHandleIndex;
+var
+ IdxName : string;
+begin
+ IndexDefs.Updated := False;
+ if btIndexByName then
+ btRetrieveIndexName(btIndexName, True, IdxName)
+ else
+ btRetrieveIndexName(btIndexFieldStr, False, IdxName);
+ if (IdxName <> '') then begin
+ try
+ btSwitchToIndexEx(CursorID, IdxName, btIndexID, False);
+ except
+ Check(ServerEngine.CursorClose(CursorID));
+ TableState := TblClosed;
+ dsCursorID := 0;
+ btRangeStack.Clear;
+ raise;
+ end;
+ end;
+end;
+{--------}
+procedure TffBaseTable.btCheckKeyEditMode;
+begin
+ if (State <> dsSetKey) then
+ RaiseFFErrorObj(Self, ffdse_TblChkKeyNoEdit)
+end;
+{--------}
+procedure TffBaseTable.dsCheckMasterRange;
+begin
+ if btMasterLink.Active and (btMasterLink.Fields.Count > 0) then begin //soner it could be cause error: if btMasterLink not assigned!
+ btSetLinkRange(btMasterLink.Fields);
+ btSetRange;
+ end;
+end;
+{--------}
+procedure TffDataSet.dsClearServerSideFilter;
+begin
+ SetFilterEx(nil, 0);
+end;
+{--------}
+procedure TffDataSet.dsCloseViaProxy;
+begin
+ if not dsClosing then
+ Close;
+end;
+{--------}
+function TffDataSet.dsCreateHandle : TffCursorID;
+begin
+ if (TableName = '') then
+ RaiseFFErrorObj(Self, ffdse_TblNoName);
+ Result := GetCursorHandle('');
+end;
+{--------}
+function TffDataSet.dsCreateLookupFilter(aFields : TList;
+ const aValues : Variant;
+ aOptions : TLocateOptions): HDBIFilter;
+{$ifdef DONTUSEDELPHIUNIT}
+begin
+ raise Exception.Create('In this version [dsCreateLookupFilter] not supperted!');
+end;
+{$else}
+var
+ i : Integer;
+ Filter: TFilterExpr;
+ Tree : PExprNode;
+ Node : PExprNode;
+ FilterOptions: TFilterOptions;
+begin
+ {calculate the filter options}
+ if (loCaseInsensitive in aOptions) then
+ FilterOptions := [foNoPartialCompare, foCaseInsensitive]
+ else
+ FilterOptions := [foNoPartialCompare];
+ {create the filter expression tree}
+
+ {$IFDEF ExprParserType1}
+ Filter := TFilterExpr.Create(Self, FilterOptions);
+ {$ENDIF}
+ {$IFDEF ExprParserType2}
+ Filter := TFilterExpr.Create(Self, FilterOptions, [], '', nil);
+ {$ENDIF}
+ {$IFDEF ExprParserType3}
+ Filter := TFilterExpr.Create(Self, FilterOptions, [], '', nil, FldTypeMap);
+ {$ENDIF}
+
+ try
+ {add the nodes}
+ {if there's just one field value, do it separately}
+ if (aFields.Count = 1) then begin
+ {$IFDEF ExprParserType3}
+ Node := Filter.NewCompareNode(TField(aFields[0]), coEQ, aValues);
+ {$ELSE}
+ {$IFDEF UsesBDE}
+ Node := Filter.NewCompareNode(TField(aFields[0]), BDE.canEQ, aValues);
+ {$ELSE}
+ Node := Filter.NewCompareNode(TField(aFields[0]), canEQ, aValues);
+ {$ENDIF}
+ {$ENDIF}
+ Tree := Node;
+ end
+ {if there are more than one, create a properly linked tree}
+ else begin
+ {$IFDEF ExprParserType3}
+ Node := Filter.NewCompareNode(TField(aFields[0]), coEQ, aValues[0]);
+ {$ELSE}
+ {$IFDEF UsesBDE}
+ Node := Filter.NewCompareNode(TField(aFields[0]), BDE.canEQ, aValues[0]);
+ {$ELSE}
+ Node := Filter.NewCompareNode(TField(aFields[0]), canEQ, aValues[0]);
+ {$ENDIF}
+ {$ENDIF}
+ Tree := Node;
+ for i := 1 to pred(aFields.Count) do begin
+ {$IFDEF ExprParserType3}
+ Node := Filter.NewCompareNode(TField(aFields[i]), coEQ, aValues[i]);
+ Tree := Filter.NewNode(enOperator, coAND, UnAssigned, Tree, Node);
+ {$ELSE}
+ {$IFDEF UsesBDE}
+ Node := Filter.NewCompareNode(TField(aFields[i]), BDE.canEQ, aValues[i]);
+ Tree := Filter.NewNode(enOperator, BDE.CanAND, UnAssigned, Tree, Node);
+ {$ELSE}
+ Node := Filter.NewCompareNode(TField(aFields[i]), canEQ, aValues[i]);
+ Tree := Filter.NewNode(enOperator, canAND, UnAssigned, Tree, Node);
+ {$ENDIF}
+ {$ENDIF}
+ end;
+ end;
+ {if we have a partial match make sure the final node agrees}
+ if (loPartialKey in aOptions) then
+ Node^.FPartial := True;
+
+ {add the filter}
+ if FilterEval = ffeServer then
+ Check(OverrideFilterEx(ffSrBDE.pCANExpr(Filter.GetFilterData(Tree)),
+ FilterTimeOut))
+ else begin
+ Check(dsAddFilter(0, 0, false,
+ PCANExpr(Filter.GetFilterData(Tree)),
+ nil, Result));
+ dsActivateFilter(Result);
+ end;
+
+ finally
+ Filter.Free;
+ end;{try..finally}
+end;
+{$endif}
+{--------}
+procedure TffDataset.dsDeactivateFilters;
+begin
+ {deactivate the server side filter}
+ if (dsFilterEval = ffeServer) then
+ dsClearServerSideFilter;
+
+ {deactivate the expression filter}
+ if (dsExprFilter <> nil) then begin
+ Check(dsDeactivateFilter(dsExprFilter));
+ end;
+ {deactivate the function filter}
+ if (dsFuncFilter <> nil) then begin
+ Check(dsDeactivateFilter(dsFuncFilter));
+ end;
+end;
+{--------}
+procedure TffBaseTable.btDecodeIndexDesc(const aIndexDesc : IDXDesc;
+ var aName, aFields : string;
+ var aOptions : TIndexOptions);
+var
+ IndexOptions : TIndexOptions;
+ i : Integer;
+begin
+ with aIndexDesc do begin
+ {get name}
+ aName := szName;
+ {get index options - use local variable for speed}
+ IndexOptions := [];
+ if bPrimary then
+ Include(IndexOptions, ixPrimary);
+ if bUnique then
+ Include(IndexOptions, ixUnique);
+ if bDescending then
+ Include(IndexOptions, ixDescending);
+ if bCaseInsensitive then
+ Include(IndexOptions, ixCaseInsensitive);
+ if bExpIdx or (iFldsInKey = 0) then
+ Include(IndexOptions, ixExpression);
+ aOptions := IndexOptions;
+ {get index fields}
+ if (iFldsInKey = 0) then
+ aFields := ''
+ else {more than one field in index key} begin
+ aFields := FieldDefs[pred(aiKeyFld[0])].Name;
+ for i := 1 to pred(iFldsInKey) do
+ aFields := aFields + ';' +
+ FieldDefs[pred(aiKeyFld[i])].Name;
+ end;
+ end;
+end;
+{--------}
+procedure TffDataSet.DestroyHandle(aHandle : TffCursorID);
+begin
+ {release record lock, ignore errors}
+ Check(ServerEngine.RecordRelLock(CursorID,
+ False));
+ {close the cursor handle, ignore errors}
+ Check(ServerEngine.CursorClose(CursorID));
+ TableState := TblClosed;
+ dsCursorID := 0;
+end;
+{--------}
+procedure TffBaseTable.DestroyHandle(aHandle : TffCursorID);
+begin
+ {destroy the lookup cursor (if there is one)}
+ btDestroyLookupCursor;
+
+ inherited DestroyHandle(aHandle);
+
+ btRangeStack.Clear;
+end;
+{--------}
+procedure TffBaseTable.btDestroyLookupCursor;
+begin
+ if (btLookupCursorID > 0) then begin
+ Check(ServerEngine.CursorClose(btLookupCursorID));
+ btLookupCursorID := 0;
+ btLookupKeyFields := '';
+ btLookupNoCase := False;
+ end;
+end;
+{--------}
+function TffBaseTable.btDoFldsMapToCurIdx(aFields : TList;
+ aNoCase : Boolean) : Boolean;
+var
+ i : Integer;
+begin
+ {returns whether the field list matches the current index fields}
+ {assume not}
+ Result := False;
+
+ {if the case sensitivity doesn't match, exit}
+ if (aNoCase <> btNoCaseIndex) then
+ Exit;
+ {if the field count is larger than the index's, exit}
+ if (aFields.Count > btIndexFieldCount) then
+ Exit;
+ {check that all fields match}
+ for i := 0 to pred(aFields.Count) do
+ if (TField(aFields[i]).FieldNo <> btFieldsInIndex[i]) then
+ Exit;
+ {if we got this far, the field list is the same as the index's}
+ Result := True;
+end;
+{--------}
+function TffDataSet.dsGetFieldDescItem(iField : Integer;
+ var FDI : TffFieldDescItem) : Boolean;
+begin
+ if (FieldDescs.Count = 0) then
+ dsReadFieldDescs;
+ if (0 < iField) and (iField <= FieldDescs.Count) then begin
+ Result := True;
+ FDI := TffFieldDescItem(FieldDescs[pred(iField)]);
+ end
+ else {iField is out of range} begin
+ Result := False;
+ FDI := nil;
+ end;
+end;
+{--------}
+function TffDataSet.dsGetFieldNumber(FieldName : PChar) : Integer;
+var
+ i : Integer;
+ FDI : TffFieldDescItem;
+begin
+ Result := 0;
+ if (FieldDescs.Count <> 0) then begin
+ for i := 0 to pred(FieldDescs.Count) do begin
+ FDI := TffFieldDescItem(FieldDescs.Items[i]);
+ if (FFAnsiStrIComp(FieldName, FDI.PhyDesc^.szName) = 0) then begin {!!.06, !!.07}
+ Result := FDI.FieldNumber;
+ Exit;
+ end;
+ end;
+ end;
+end;
+{--------}
+procedure TffDataSet.dsReadFieldDescs;
+var
+ ffFieldDesc : PffFieldDescriptor;
+ BDEPhyDesc : FLDDesc;
+ i : Integer;
+ offset : Integer;
+begin
+ {destroy any existing field desc items}
+ for i := Pred(FieldDescs.Count) downto 0 do
+ TffFieldDescItem(FieldDescs.Items[i]).Free;
+
+ {create a bunch of field desc items}
+ for i := 0 to pred(Dictionary.FieldCount) do begin
+ ffFieldDesc := Dictionary.FieldDescriptor[i];
+ GetBDEFieldDescriptor(ffFieldDesc^, BDEPhyDesc);
+ {note: the line below adds the new item automatically to the
+ collection}
+ TffFieldDescItem.Create(FieldDescs, BDEPhyDesc);
+ end;
+ {Now patch up the offsets for the logical field descs}
+ offset := 0;
+ for i := 0 to pred(Dictionary.FieldCount) do begin
+ with TffFieldDescItem(FieldDescs[i]).LogDesc^ do begin
+ ioffset := offset;
+ inc(offset, iLen);
+ end;
+ end;
+end;
+{--------}
+function TffDataSet.dsTranslateCmp(var aFirst : TffNodeValue;
+ var aSecond : TffNodeValue;
+ aIgnoreCase : Boolean;
+ aPartLen : Integer) : Integer;
+ {------}
+ function ConvertIntValue(var aNode : TffNodeValue; var C : comp) : Boolean;
+ begin
+ Result := True;
+ with aNode do begin
+ if nvIsConst then begin
+ case nvType of
+ fldINT16 : C := smallint(nvValue^);
+ fldINT32 : C := Longint(nvValue^);
+ fldUINT16 : C := Word(nvValue^);
+ fldUINT32 : begin
+ C := Longint(nvValue^);
+ if (C < 0) then
+ C := C + $80000000;
+ end;
+ else
+ Result := False;
+ end;{case}
+ end
+ else begin
+ case TffFieldType(nvType) of
+ fftByte : C := byte(nvValue^);
+ fftWord16 : C := Word(nvValue^);
+ fftWord32 : begin
+ C := Longint(nvValue^);
+ if (C < 0) then
+ C := C + $80000000;
+ end;
+ fftInt8 : C := shortint(nvValue^);
+ fftInt16 : C := smallint(nvValue^);
+ fftInt32 : C := Longint(nvValue^);
+ fftAutoInc: begin
+ C := Longint(nvValue^);
+ if (C < 0) then
+ C := C + $80000000;
+ end;
+ fftComp : C := comp(nvValue^);
+ else
+ Result := False;
+ end;{case}
+ end;
+ end;
+ end;
+ {------}
+ function ConvertDateTimeValue(var aNode : TffNodeValue;
+ var DT : TDateTime) : Boolean;
+ begin
+ Result := True;
+ with aNode do begin
+ if nvIsConst then begin
+ case nvType of
+ fldDATE : DT := DbiDate(nvValue^);
+ fldTIME : DT := FFClBDE.Time(nvValue^) / 86400000.0;
+ fldTIMESTAMP : DT := TimeStamp(nvValue^) / 86400000.0;
+ else
+ Result := False;
+ end;{case}
+ end
+ else begin
+ case TffFieldType(nvType) of
+ fftStDate : DT := StDateToDateTime(TStDate(nvValue^))
+ + 693594;
+ fftStTime : DT := StTimeToDateTime(TStTime(nvValue^));
+ fftDateTime : DT := TDateTime(nvValue^);
+ else
+ Result := False;
+ end;{case}
+ end;
+ end;
+ end;
+ {------}
+ function ConvertFloatValue(var aNode : TffNodeValue;
+ var F : extended) : Boolean;
+ begin
+ Result := True;
+ with aNode do begin
+ if nvIsConst then begin
+ case nvType of
+ fldFLOAT : F := double(nvValue^);
+ fldFLOATIEEE : F := extended(nvValue^);
+ else
+ Result := False;
+ end;{case}
+ end
+ else begin
+ case TffFieldType(nvType) of
+ fftSingle : F := single(nvValue^);
+ fftDouble : F := double(nvValue^);
+ fftExtended : F := extended(nvValue^);
+ fftCurrency : F := currency(nvValue^);
+ else
+ Result := False;
+ end;{case}
+ end;
+ end;
+ end;
+ {------}
+ function ConvertBooleanValue(var aNode : TffNodeValue;
+ var B : Boolean) : Boolean;
+ begin
+ Result := True;
+ with aNode do begin
+ if nvIsConst then begin
+ case nvType of
+ fldBOOL : B := WordBool(nvValue^);
+ else
+ Result := False;
+ end;{case}
+ end
+ else begin
+ case TffFieldType(nvType) of
+ fftBoolean : B := Boolean(nvValue^);
+ else
+ Result := False;
+ end;{case}
+ end;
+ end;
+ end;
+ {------}
+ function ConvertStringValue(var aNode : TffNodeValue;
+ var P : PChar) : Boolean;
+ var
+ StrZ : TffStringZ;
+ begin
+ Result := True;
+ with aNode do begin
+ if nvIsConst then begin
+ case nvType of
+ fldZSTRING : P := nvValue;
+ else
+ Result := False;
+ end;{case}
+ end
+ else begin
+ case TffFieldType(nvType) of
+ fftChar :
+ begin
+ P := StrAlloc(2);
+ P[0] := char(nvValue^);
+ P[1] := #0;
+ end;
+ fftShortString,
+ fftShortAnsiStr :
+ begin
+ P := StrNew(StrPCopy(StrZ, ShortString(nvValue^)));
+ end;
+ fftNullString,
+ fftNullAnsiStr :
+ begin
+ P := StrNew(nvValue);
+ end;
+ else
+ Result := False;
+ end;{case}
+ end;
+ end;
+ end;
+ {------}
+var
+ Bool1, Bool2 : Boolean;
+ Comp1, Comp2 : comp;
+ PChar1, PChar2 : PAnsiChar;
+ DT1, DT2 : TDateTime;
+ Ext1, Ext2 : extended;
+begin
+ {Note: there are two types of things to compare: constants and
+ fields. In neither case will this routine be called with null
+ values - the caller takes care of this}
+ {Note: this routine doesn't have to worry about comparing dissimilar
+ types (eg dates and strings); this is illegal and will have
+ been already excluded by the filter parser; similarly with
+ fields that can't be compared (eg, BLOBs)}
+ {Note: constant values are stored as logical types, field values as
+ physical types}
+
+ {Deal with Integer types first}
+ if ConvertIntValue(aFirst, Comp1) then begin
+ ConvertIntValue(aSecond, Comp2);
+ if (Comp1 < Comp2) then Result := -1
+ else if (Comp1 = Comp2) then Result := 0
+ else Result := 1;
+ Exit;
+ end;
+
+ {Deal with floating point types next}
+ if ConvertFloatValue(aFirst, Ext1) then begin
+ ConvertFloatValue(aSecond, Ext2);
+ if (Ext1 < Ext2) then Result := -1
+ else if (Ext1 = Ext2) then Result := 0
+ else Result := 1;
+ Exit;
+ end;
+
+ {Deal with date/time types next}
+ if ConvertDateTimeValue(aFirst, DT1) then begin
+ ConvertDateTimeValue(aSecond, DT2);
+ if (DT1 < DT2) then Result := -1
+ else if (DT1 = DT2) then Result := 0
+ else Result := 1;
+ Exit;
+ end;
+
+ {Deal with Boolean types next; False < True}
+ if ConvertBooleanValue(aFirst, Bool1) then begin
+ ConvertBooleanValue(aSecond, Bool2);
+ if Bool1 then
+ if Bool2 then Result := 0
+ else Result := 1
+ else {Bool1 is False}
+ if Bool2 then Result := -1
+ else Result := 0;
+ Exit;
+ end;
+
+ {Deal with strings next}
+ if ConvertStringValue(aFirst, PChar1) then begin
+ ConvertStringValue(aSecond, PChar2);
+ if aIgnoreCase then
+ if (aPartLen = 0) then
+ Result := FFAnsiStrIComp(PChar1, PChar2) {!!.06}{!!.07}
+ else
+ Result := FFAnsiStrLIComp(PChar1, PChar2, aPartLen) {!!.06}{!!.07}
+ else
+ if (aPartLen = 0) then
+ Result := AnsiStrComp(PChar1, PChar2) {!!.06}
+ else
+ Result := AnsiStrLComp(PChar1, PChar2, aPartLen); {!!.06}
+ if not aFirst.nvIsConst then
+ StrDispose(PChar1);
+ if not aSecond.nvIsConst then
+ StrDispose(PChar2);
+ Exit;
+ end;
+
+ {otherwise just compare the bytes}
+ Result := ffCmpBytes(PffByteArray(aFirst.nvValue),
+ PffByteArray(aSecond.nvValue),
+ ffMinI(aFirst.nvSize, aSecond.nvSize));
+end;
+{------}
+function TffDataSet.dsTranslateGet(FDI : TffFieldDescItem;
+ pRecBuff : Pointer;
+ pDest : Pointer;
+ var bBlank : Boolean) : TffResult;
+begin
+ Result := DBIERR_NONE;
+ if (pRecBuff = nil) then
+ Result := DBIERR_INVALIDPARAM
+ else {pRecBuff is non-nil} begin
+ bBlank := Dictionary.IsRecordFieldNull(pred(FDI.FieldNumber), pRecBuff);
+ if (pDest = nil) then
+ Result := DBIERR_NONE
+ else {there is somewhere to xlat data into, if needed} begin
+ if bBlank then begin
+ Result := DBIERR_NONE;
+ if (XltMode = xltField) then
+ FillChar(pDest^, FDI.LogDesc^.iLen, 0)
+ else {no translation}
+ FillChar(pDest^, FDI.PhyDesc^.iLen, 0)
+ end
+ else {field is not blank} begin
+ if (XltMode <> xltField) {no translation} then begin
+ with FDI.PhyDesc^ do
+ Move(PffByteArray(pRecBuff)^[ioffset], pDest^, iLen);
+ end
+ else {field must be translated} begin
+ with FDI.PhyDesc^ do begin
+ inc(PAnsiChar(pRecBuff), ioffset);
+ if MapffDataToBDE(TffFieldType(iFldType),
+ iLen,
+ pRecBuff,
+ pDest) then
+ Result := DBIERR_NONE
+ else
+ Result := DBIERR_INVALIDXLATION;
+ end;
+ end;
+ end;
+ end;
+ end;
+end;
+{--------}
+function TffDataSet.dsTranslatePut(FDI : TffFieldDescItem;
+ pRecBuff : Pointer;
+ pSrc : Pointer) : TffResult;
+begin
+ if (pRecBuff = nil) then
+ Result := DBIERR_INVALIDPARAM
+ else {pRecBuff is non-nil} begin
+ if (pSrc = nil) {this means set field to null} then begin
+ Dictionary.SetRecordFieldNull(pred(FDI.FieldNumber), pRecBuff, True);
+ Result := DBIERR_NONE;
+ end
+ else {pSrc is non-nil} begin
+ Dictionary.SetRecordFieldNull(pred(FDI.FieldNumber), pRecBuff, False);
+ if (XltMode <> xltField) {no translation} then begin
+ with FDI.PhyDesc^ do
+ Move(pSrc^, PffByteArray(pRecBuff)^[ioffset], iLen);
+ Result := DBIERR_NONE;
+ end
+ else {field must be translated} begin
+ with FDI.PhyDesc^ do begin
+ inc(PAnsiChar(pRecBuff), ioffset);
+ if MapBDEDataToff(TffFieldType(iFldType), iLen, pSrc, pRecBuff) then
+ Result := DBIERR_NONE
+ else
+ Result := DBIERR_INVALIDXLATION;
+ end;
+ end;
+ end;
+ end;
+end;
+{--------}
+procedure TffDataSet.dsDropFilters;
+begin
+ {drop the expression filter}
+ if (dsExprFilter <> nil) then begin
+ Check(dsDropFilter(dsExprFilter));
+ dsExprFilter := nil;
+ end;
+ {drop the function filter}
+ if (dsFuncFilter <> nil) then begin
+ Check(dsDropFilter(dsFuncFilter));
+ dsFuncFilter := nil;
+ end;
+end;
+{--------}
+function TffDataSet.dsMatchesFilter(pRecBuff : Pointer) : Boolean;
+var
+ i : Integer;
+ Filt : TffFilterListItem;
+begin
+ Result := False;
+ if (pRecBuff = nil) then
+ Exit;
+ if dsFilterActive then begin
+ for i := 0 to pred(dsFilters.Count) do begin
+ Filt := TffFilterListItem(dsFilters.Items[i]);
+ if (Filt <> nil) then
+ if not Filt.MatchesRecord(pRecBuff) then
+ Exit;
+ end;
+ end;
+ Result := True;
+end;
+{--------}
+procedure TffBaseTable.btEndKeyBufferEdit(aCommit : Boolean);
+begin
+ DataEvent(deCheckBrowseMode, 0);
+ if aCommit then
+ PKeyRecInfo(PChar(btKeyBuffer) + btKeyInfoOfs)^.kriModified := Modified
+ else {rollback}
+ Move(PKeyBuffers(btKeyBuffers)^[ketSaved]^, btKeyBuffer^, btKeyBufSize);
+ SetState(dsBrowse);
+ DataEvent(deDataSetChange, 0);
+end;
+{--------}
+procedure TffDataSet.dsEnsureDatabaseOpen(aValue : Boolean);
+ {Note: this routine exists in order that the table object can ensure
+ that it's database parent is open before something happens
+ that requires it open. For example, you can get an index list
+ for a table before opening it - to do this requires that the
+ database is opened automatically first. }
+var
+ DB : TffDatabase;
+begin
+ if (dsProxy.Session = nil) then
+ dsProxy.tpResolveSession;
+ DB := TffDatabase(Database);
+ if (DB = nil) then
+ RaiseFFErrorObj(Self, ffdse_TblBadDBName);
+ if aValue then
+ DB.Active := True;
+end;
+{--------}
+function TffDataSet.GetCursorProps(var aProps : TffCursorProps) : TffResult;
+var
+ i : Integer;
+begin
+ FillChar(aProps, SizeOf(TffCursorProps), 0);
+ aProps.TableName := TableName;
+ aProps.FileNameSize :=ffcl_Path + 1 + ffcl_FileName + 1 + ffcl_Extension;
+ aProps.FieldsCount := Dictionary.FieldCount;
+ { Record size (logical record) }
+ if (XltMode = xltField) then
+ with TffFieldDescItem(FieldDescs[pred(FieldDescs.Count)]).LogDesc^ do
+ aProps.RecordSize := ioffset + iLen
+ else
+ aProps.RecordSize := PhysicalRecordSize;
+ { Record size (physical record) }
+ aProps.RecordBufferSize := PhysicalRecordSize;
+ aprops.ValChecks := 0;
+ with Dictionary do begin
+ for i := 0 to pred(FieldCount) do
+ if FieldRequired[i] or (FieldVCheck[i] <> nil) then
+ inc(aProps.ValChecks);
+ end;
+ aProps.BookMarkSize := Dictionary.BookmarkSize[0];
+ aProps.BookMarkStable := True;
+ aProps.OpenMode := OpenMode;
+ aProps.ShareMode := ShareMode;
+ aProps.Indexed := True;
+ aProps.xltMode := XltMode;
+ aProps.TblRights := prvUNKNOWN;
+ aProps.Filters := Filters.Count;
+ Result := DBIERR_NONE;
+end;
+{--------}
+function TffBaseTable.GetCursorProps(var aProps : TffCursorProps) : TffResult;
+begin
+ Result := inherited GetCursorProps(aProps);
+ aProps.KeySize := Dictionary.IndexKeyLength[IndexID];
+ aProps.IndexCount := Dictionary.IndexCount;
+ aProps.BookMarkSize := Dictionary.BookmarkSize[IndexID];
+end;
+{--------}
+
+function TffDataSet.dsGetNextRecord(eLock : TffLockType;
+ pRecBuff : Pointer;
+ RecProps : pRECProps) : TffResult;
+var
+ FoundNext : Boolean;
+ CreatedBuffer : Boolean;
+begin
+ if (pRecBuff <> nil) then
+ CreatedBuffer := False
+ else begin
+ FFGetMem(pRecBuff, PhysicalRecordSize);
+ CreatedBuffer := True;
+ end;
+ FoundNext := False;
+ Result := dsGetNextRecordPrim(CursorID, ffltNOLOCK, pRecBuff, RecProps);
+ while (Result = DBIERR_NONE) and (not FoundNext) do begin
+ if dsMatchesFilter(pRecBuff) then begin
+ FoundNext := True;
+ if (eLock <> ffltNOLOCK) then
+ Result := dsGetRecordPrim(eLock, nil, nil);
+ end
+ else
+ Result := dsGetNextRecordPrim(CursorID, ffltNOLOCK, pRecBuff, RecProps);
+ end;
+ if CreatedBuffer then
+ FFFreeMem(pRecBuff, PhysicalRecordSize);
+end;
+{--------}
+function TffDataSet.dsGetNextRecordPrim(aCursorID : TffCursorID;
+ eLock : TffLockType;
+ pRecBuff : Pointer;
+ RecProps : pRECProps) : TffResult;
+begin
+ repeat
+ Result := ServerEngine.RecordGetNext(aCursorID,
+ eLock,
+ pRecBuff);
+ if Result = DBIERR_ff_FilterTimeout then begin
+ if dsCancelServerFilter then
+ break;
+ end else
+ break;
+ until False;
+ if (RecProps <> nil) then
+ FillChar(RecProps^, sizeof(RECProps), 0);
+end;
+{------}
+function TffDataSet.GetActiveRecBuf(var aRecBuf : PChar): Boolean;
+begin
+ Result := True;
+ case State of
+ dsBrowse :
+ if IsEmpty then begin
+ aRecBuf := nil;
+ Result := False;
+ end
+ else
+ aRecBuf := ActiveBuffer;
+ dsEdit,
+ dsInsert :
+ aRecBuf := ActiveBuffer;
+ dsCalcFields :
+ aRecBuf := CalcBuffer;
+ dsFilter :
+ aRecBuf := dsRecordToFilter;
+ dsOldValue :
+ begin
+ aRecBuf := dsOldValuesBuffer;
+ Result := Assigned(aRecBuf);
+ end;
+ else
+ aRecBuf := nil;
+ Result := False;
+ end;
+end;
+{--------}
+function TffBaseTable.GetActiveRecBuf(var aRecBuf : PChar): Boolean;
+begin
+ Result := True;
+ case State of
+ dsSetKey :
+ aRecBuf := PChar(btKeyBuffer);
+ else
+ Result := inherited GetActiveRecBuf(aRecBuf);
+ end;
+end;
+{--------}
+function TffDataSet.GetCursorHandle(aIndexName : string) : TffCursorID;
+var
+ RetCode : TffResult;
+ Stream : TStream;
+ OpenCursorID : Longint;
+ OpenIndexID : Longint;
+begin
+ {try to open the table}
+ Stream := TMemoryStream.Create;
+ try
+ RetCode := ServerEngine.TableOpen(Database.DatabaseID,
+ TableName,
+ False,
+ '', { IndexName}
+ 0,
+ TffOpenMode(not ReadOnly),
+ TffShareMode(not Exclusive),
+ dsGetTimeOut,
+ Result,
+ Stream);
+ if RetCode = DBIERR_NONE then begin
+ Stream.Position := 0;
+ Stream.Read(OpenCursorID, SizeOf(OpenCursorID));
+ {save the data dictionary for this table as well}
+ Dictionary.ReadFromStream(Stream);
+ Stream.Read(OpenIndexID, SizeOf(OpenIndexID));
+ dsReadFieldDescs;
+ end else
+ Result := 0;
+ finally
+ Stream.Free;
+ end;
+
+ {if we failed, but the error was 'table is readonly', try to open
+ the table in that mode; switch the internal ReadOnly flag}
+ if (RetCode = DBIERR_TABLEREADONLY) then begin
+ if dsReadOnly then
+ RaiseFFErrorObj(Self, ffdse_TblBadReadOnly);
+ dsReadOnly := True;
+ Result := GetCursorHandle(aIndexName);
+ RetCode := DBIERR_NONE;
+ end;
+ {finally check the return code}
+ Check(RetCode);
+end;
+{--------}
+function TffBaseTable.GetCursorHandle(aIndexName : string) : TffCursorID;
+var
+ RetCode : TffResult;
+ Stream : TStream;
+ OpenCursorID : Longint;
+ OpenIndexID : Longint;
+begin
+ {try to open the table}
+ Stream := TMemoryStream.Create;
+ try
+ RetCode := ServerEngine.TableOpen(Database.DatabaseID,
+ TableName,
+ False,
+ IndexName,
+ 0,
+ TffOpenMode(not ReadOnly),
+ TffShareMode(not Exclusive),
+ dsGetTimeOut,
+ Result,
+ Stream);
+ if RetCode = DBIERR_NONE then begin
+ Stream.Position := 0;
+ Stream.Read(OpenCursorID, SizeOf(OpenCursorID));
+ {save the data dictionary for this table as well}
+ Dictionary.ReadFromStream(Stream);
+ Stream.Read(OpenIndexID, SizeOf(OpenIndexID));
+ btIndexID := OpenIndexID;
+ btIndexName := Dictionary.IndexName[OpenIndexID];
+ dsReadFieldDescs;
+ end else
+ Result := 0;
+ finally
+ Stream.Free;
+ end;
+ {if we failed, but the error was 'table is readonly', try to open
+ the table in that mode; switch the internal ReadOnly flag}
+ if (RetCode = DBIERR_TABLEREADONLY) then begin
+ if dsReadOnly then
+ RaiseFFErrorObj(Self, ffdse_TblBadReadOnly);
+ dsReadOnly := True;
+ Result := GetCursorHandle(aIndexName);
+ RetCode := DBIERR_NONE;
+ end;
+ {finally check the return code}
+ Check(RetCode);
+end;
+{--------}
+function TffDataSet.dsGetDatabase : TffBaseDatabase;
+begin
+ Result := dsProxy.Database;
+end;
+{--------}
+function TffDataSet.dsGetDatabaseName : string;
+begin
+ Result := dsProxy.DatabaseName;
+end;
+{Begin !!.11}
+{--------}
+function TffBaseTable.btGetFFVersion : string;
+var
+ Version : Longint;
+begin
+ Check(ServerEngine.TableVersion(Database.DatabaseID,
+ dsGetTableName, Version));
+ Result := Format('%5.4f', [Version / 10000.0]);
+end;
+{End !!.11}
+{--------}
+function TffBaseTable.btGetIndexField(aInx : Integer) : TField;
+var
+ FieldNo : Integer;
+begin
+ if (aInx < 0) or (aInx >= IndexFieldCount) then
+ RaiseFFErrorObj(Self, ffdse_TblIdxFldRange);
+ FieldNo := btFieldsInIndex[aInx];
+ Result := FieldByNumber(FieldNo);
+ if (Result = nil) then
+ RaiseFFErrorObj(Self, ffdse_TblIdxFldMissing);
+end;
+{--------}
+function TffBaseTable.btGetIndexFieldNames : string;
+begin
+ if btIndexByName then
+ Result := ''
+ else
+ Result := btIndexFieldStr;
+end;
+{--------}
+procedure TffDataset.dsGetIndexInfo;
+begin
+ { do nothing }
+end;
+{--------}
+procedure TffDataset.dsAllocKeyBuffers;
+begin
+ { do nothing }
+end;
+{--------}
+procedure TffDataset.dsCheckMasterRange;
+begin
+ { do nothing }
+end;
+{--------}
+procedure TffBaseTable.dsGetIndexInfo;
+var
+ i : Integer;
+ IndexDesc : IDXDesc;
+begin
+ if (btGetIndexDesc(0, IndexDesc) = DBIERR_NONE) then begin
+ btNoCaseIndex := IndexDesc.bCaseInsensitive;
+ btIndexFieldCount := IndexDesc.iFldsInKey;
+ FillChar(btFieldsInIndex, sizeof(btFieldsInIndex), 0);
+ //for i := 0 to pred(IndexDesc.iFldsInKey) do //soner IndexDesc.iFldsInKey is Word. In fpc pred(IndexDesc.iFldsInKey) is not -1 it is 0 and this loop getting endless!
+ for i := 0 to IndexDesc.iFldsInKey-1 do //<-soner better
+ btFieldsInIndex[i] := IndexDesc.aiKeyFld[i];
+ btKeyLength := IndexDesc.iKeyLen;
+ btKeyInfoOfs := dsPhyRecSize;
+ btKeyBufSize := btKeyInfoOfs + sizeof(TKeyRecInfo);
+ end;
+end;
+{--------}
+function TffBaseTable.btGetIndexDesc(iIndexSeqNo : Word;
+ var idxDesc : IDXDesc) : TffResult;
+begin
+ FillChar(idxDesc, sizeof(idxDesc), 0);
+
+ {note: BDE index sequence numbers are 1-based, 0 means 'current
+ index'}
+ if (iIndexSeqNo = 0) then
+ iIndexSeqNo := IndexID
+ else
+ dec(iIndexSeqNo);
+
+ {check to be sure it is a valid index id}
+ if iIndexSeqNo >= Dictionary.IndexCount then
+ Result := DBIERR_NOSUCHINDEX
+ else begin
+ GetBDEIndexDescriptor(Dictionary.IndexDescriptor[iIndexSeqNo]^, idxDesc);
+ Result := DBIERR_NONE;
+ end;
+end;
+{--------}
+function TffBaseTable.btGetIndexDescs(Desc : pIDXDesc) : TffResult;
+var
+ IDA : PffIDXDescArray absolute Desc;
+ Props : TffCursorProps;
+ i : Word;
+begin
+ Result := GetCursorProps(Props);
+ if (Result = DBIERR_NONE) then begin
+ for i := 1 to Props.IndexCount do begin
+ Result := btGetIndexDesc(i, IDA^[pred(i)]);
+ if not (Result = DBIERR_NONE) then begin
+ Exit;
+ end;
+ end;
+ end;
+end;
+{--------}
+function TffBaseTable.btGetIndexName : string;
+begin
+ if btIndexByName then
+ Result := btIndexName
+ else
+ Result := '';
+end;
+{--------}
+function TffBaseTable.btGetKeyExclusive : Boolean;
+begin
+ btCheckKeyEditMode;
+ Result := PKeyRecInfo(PChar(btKeyBuffer) + btKeyInfoOfs)^.kriExclusive;
+end;
+{--------}
+function TffBaseTable.btGetKeyFieldCount : Integer;
+begin
+ btCheckKeyEditMode;
+ Result := PKeyRecInfo(PChar(btKeyBuffer) + btKeyInfoOfs)^.kriFieldCount;
+end;
+{--------}
+function TffBaseTable.btGetLookupCursor(const aKeyFields : string;
+ aNoCase : Boolean) : TffCursorID;
+var
+ KeyIndex : TIndexDef;
+ RangeStart : PChar;
+ RangeEnd : PChar;
+ RangeStartInfo : PKeyRecInfo;
+ RangeEndInfo : PKeyRecInfo;
+ TmpInt : Integer;
+ TmpStr : string;
+begin
+ {create a new cursor only if something has changed}
+ if (aKeyFields <> btLookupKeyFields) or
+ (aNoCase <> btLookupNoCase) then begin
+ {destroy the old cursor}
+ btDestroyLookupCursor;
+
+
+ (*Note: Case sensitivity should not matter when just interested in integer
+ key fields *)
+ { If a range is active then do not create a cursor. We will handle it
+ via a lookup filter. }
+ RangeStart := PKeyBuffers(btKeyBuffers)^[ketCurRangeStart];
+ RangeStartInfo := PKeyRecInfo(RangeStart + btKeyInfoOfs);
+ RangeEnd := PKeyBuffers(btKeyBuffers)^[ketCurRangeEnd];
+ RangeEndInfo := PKeyRecInfo(RangeEnd + btKeyInfoOfs);
+ if (not RangeStartInfo^.kriModified) and
+ (not RangeEndInfo^.kriModified) then begin
+ {get the index definition for the field names}
+ KeyIndex := IndexDefs.GetIndexForFields(aKeyFields, aNoCase);
+ {if there was one...}
+ if (KeyIndex <> nil) then begin
+ {clone our handle and switch indexes}
+ Check(ServerEngine.CursorClone(CursorID,
+ omReadOnly,
+ btLookupCursorID));
+ TmpInt := 0;
+ TmpStr := KeyIndex.Name;
+ Check(btSwitchToIndexEx(btLookupCursorID, TmpStr, TmpInt, False));
+ {save the parameters for next time} {!!.01}
+ btLookupKeyFields := aKeyFields; {!!.01}
+ btLookupNoCase := aNoCase; {!!.01}
+ end;
+{Begin !!.01}
+ {save the parameters for next time}
+// btLookupKeyFields := aKeyFields;
+// btLookupNoCase := aNoCase;
+{End !!.01}
+ end;
+ end;
+ Result := btLookupCursorID;
+end;
+{--------}
+function TffBaseTable.btGetMasterFields : string;
+begin
+ Result := btMasterLink.FieldNames;
+end;
+{--------}
+function TffBaseTable.btGetMasterSource : TDataSource;
+begin
+ Result := btMasterLink.DataSource;
+end;
+{--------}
+procedure TffDataSet.dsGetRecordInfo(aReadProps : Boolean);
+var
+ CursorProps : TffCursorProps;
+begin
+ if aReadProps then begin
+ Check(GetCursorProps(CursorProps));
+ BookmarkSize := CursorProps.BookmarkSize;
+ dsPhyRecSize := CursorProps.RecordBufferSize;
+ end;
+ dsCalcFldOfs := dsPhyRecSize;
+ dsBookmarkOfs := dsCalcFldOfs + CalcFieldsSize;
+ dsRecInfoOfs := dsBookmarkOfs + BookmarkSize;
+ dsRecBufSize := dsRecInfoOfs + SizeOf(TDataSetRecInfo);
+end;
+{--------}
+function TffDataSet.dsGetSession : TffSession;
+begin
+ Result := dsProxy.Session;
+end;
+{--------}
+function TffDataSet.dsGetSessionName : string;
+begin
+ Result := dsProxy.SessionName;
+end;
+{--------}
+function TffDataSet.dsGetTableName : string;
+begin
+ Result := dsProxy.TableName;
+end;
+{--------}
+function TffDataSet.dsGetVersion : string;
+begin
+ Result := dsProxy.Version;
+end;
+{--------}
+procedure TffDataSet.dsRefreshTimeout; {new !!.11}
+begin
+ if Active then
+ Check(ServerEngine.CursorSetTimeout(CursorID, dsGetTimeout));
+end;
+{--------}
+procedure TffBaseTable.btInitKeyBuffer(aBuf : Pointer);
+begin
+ FillChar(PKeyRecInfo(PChar(aBuf) + btKeyInfoOfs)^, sizeof(TKeyRecInfo), 0);
+ Dictionary.InitRecord(aBuf);
+ Dictionary.SetDefaultFieldValues(aBuf);
+end;
+{--------}
+function TffDataSet.dsModifyRecord(aBuffer : Pointer; aRelLock : Boolean) : TffResult;
+begin
+ Result := ServerEngine.RecordModify(CursorID,
+ aBuffer,
+ aRelLock);
+end;
+{--------}
+function TffBaseTable.btLocateRecord(const aKeyFields : string;
+ const aKeyValues : Variant;
+ aOptions : TLocateOptions;
+ aSyncCursor: Boolean): Boolean;
+var
+ i, FieldCount, PartialLength : Integer;
+ OurBuffer : PChar;
+ OurFields : TList;
+ LookupCursor : TffCursorID;
+ FilterHandle : HDBIFilter;
+ Status : TffResult;
+ NoCase : Boolean;
+begin
+ {make sure we're in browse mode}
+ CheckBrowseMode;
+ CursorPosChanged;
+ {get a temporary record Buffer}
+ OurBuffer := TempBuffer;
+ {create list of fields}
+ OurFields := TList.Create;
+ try
+ {get the actual fields in the parameter aKeyFields}
+ GetFieldList(OurFields, aKeyFields);
+ {see whether we can use an index to rapidly lookup the record}
+ NoCase := loCaseInsensitive in aOptions;
+ if btDoFldsMapToCurIdx(OurFields, NoCase) then
+ LookupCursor := CursorID
+ else
+ LookupCursor := btGetLookupCursor(aKeyFields, NoCase);
+ {if we have no lookup cursor, locate the record via a filter}
+ if (LookupCursor = 0) then begin
+ InternalFirst;
+ FilterHandle := dsCreateLookupFilter(OurFields, aKeyValues, aOptions);
+ Status := dsGetNextRecord(ffltNoLock, OurBuffer, nil);
+ if FilterEval = ffeServer then
+ RestoreFilterEx
+ else
+ dsDropFilter(FilterHandle);
+ end
+ {otherwise if we do have a lookup cursor, use it}
+ else begin
+ {temporarily move into the filter state - this fools the field
+ setting logic to fill the filter Buffer (ie, the temp Buffer)}
+ SetTempState(dsFilter);
+ dsRecordToFilter := OurBuffer;
+ try
+ {initialize the Buffer we're using}
+ Dictionary.InitRecord(PffByteArray(OurBuffer));
+ Dictionary.SetDefaultFieldValues(PffByteArray(OurBuffer));
+ {set up the field values in the Buffer}
+ FieldCount := OurFields.Count;
+ //original: if FieldCount = 1 then
+ if (FieldCount = 1){$ifdef fpc}and (not VarIsArray(aKeyValues)){$endif} then //soner solved:EVariantError : Invalid variant type cast
+ TField(OurFields[0]).Value := aKeyValues
+ else begin
+ for i := 0 to pred(FieldCount) do
+ TField(OurFields[i]).Value := aKeyValues[i];
+ end;
+ {calculate any partial length - only counts if the last field
+ is a string field}
+ PartialLength := 0;
+ if (loPartialKey in aOptions) and
+ (TField(OurFields.Last).DataType = ftString) then begin
+ dec(FieldCount);
+ PartialLength := length(TField(OurFields.Last).AsString);
+ end;
+ {get the record for the given key in the Buffer}
+ Status := btGetRecordForKey(LookupCursor, False,
+ FieldCount,
+ PartialLength,
+ OurBuffer,
+ OurBuffer);
+ finally
+ {reset the state to browse mode}
+ RestoreState(dsBrowse);
+ end;{try..finally}
+ {if we have to sync up, then do so}
+ if (Status = DBIERR_NONE) and
+ aSyncCursor and
+ (LookupCursor <> CursorID) then
+ Status := ServerEngine.CursorSetToCursor(CursorID,
+ btLookupCursorID);
+ end;
+ finally
+ OurFields.Free;
+ end;{try..finally}
+
+ { check the result, raise an error if a timeout occurred } {begin !!.11}
+ case Status of
+ DBIERR_FF_FilterTimeout,
+ DBIERR_FF_ReplyTimeout,
+ DBIERR_FF_Timeout,
+ DBIERR_FF_GeneralTimeout :
+ begin
+ Result := False; //needed to avoid compiler warning
+ Check(Status);
+ end;
+ else
+ Result := (Status = DBIERR_NONE);
+ end; {end !!.11}
+end;
+{--------}
+procedure TffBaseTable.btMasterChanged(Sender : TObject);
+begin
+ CheckBrowseMode;
+ btSetLinkRange(btMasterLink.Fields);
+ ApplyRange;
+end;
+{--------}
+procedure TffBaseTable.btMasterDisabled(Sender : TObject);
+begin
+ CancelRange;
+end;
+{--------}
+function TffDataSet.dsOnFilterRecordCallback({ulClientData = Self}
+ pRecBuf : Pointer;
+ iPhyRecNum : Longint): SmallInt;
+var
+ Accept : Boolean;
+ SaveState : TDataSetState;
+begin
+ SaveState := SetTempState(dsFilter);
+ try
+ Accept := True;
+ Result := Ord(Accept);
+ dsRecordToFilter := pRecBuf;
+ try
+ if Assigned(OnFilterRecord) then
+ OnFilterRecord(Self, Accept);
+ Result := Ord(Accept);
+ except
+ raise;
+ end;
+ dsRecordToFilter := nil;
+ finally
+ RestoreState(SaveState);
+ end;
+end;
+{--------}
+function TffBaseTable.btResetRange(aCursorID : TffCursorID;
+ SwallowSeqAccessError : Boolean) : Boolean;
+var
+ RangeStart : PChar;
+ RangeEnd : PChar;
+ RangeStartInfo : PKeyRecInfo;
+ RangeEndInfo : PKeyRecInfo;
+begin
+ RangeStart := PKeyBuffers(btKeyBuffers)^[ketCurRangeStart];
+ RangeStartInfo := PKeyRecInfo(RangeStart + btKeyInfoOfs);
+ RangeEnd := PKeyBuffers(btKeyBuffers)^[ketCurRangeEnd];
+ RangeEndInfo := PKeyRecInfo(RangeEnd + btKeyInfoOfs);
+ if (not RangeStartInfo^.kriModified) and
+ (not RangeEndInfo^.kriModified) then
+ Result := False
+ else begin
+ btResetRangePrim(aCursorID, SwallowSeqAccessError);
+ btInitKeyBuffer(RangeStart);
+ btInitKeyBuffer(RangeEnd);
+ btDestroyLookupCursor;
+ Result := True;
+ end;
+end;
+{--------}
+procedure TffBaseTable.btResetRangePrim(aCursorID : TffCursorID;
+ SwallowSeqAccessError : Boolean);
+var
+ Status : TffResult;
+begin
+ Status := ServerEngine.CursorResetRange(aCursorID);
+ if (Status <> DBIERR_NONE) then begin
+ if (Status <> DBIERR_NOASSOCINDEX) or
+ (not SwallowSeqAccessError) then
+ Check(Status);
+ end else begin
+ btRangeStack.ClearSaved;
+ end;
+end;
+{--------}
+procedure TffBaseTable.btRetrieveIndexName(const aNameOrFields : string;
+ aIndexByName : Boolean;
+ var aIndexName : string);
+var
+ Inx : Integer;
+begin
+ if (aNameOrFields <> '') then begin
+ UpdateIndexDefs;
+ if aIndexByName then begin
+ Inx := IndexDefs.IndexOf(aNameOrFields);
+ if (Inx = -1) then
+ Check(DBIERR_NOSUCHINDEX);
+ aIndexName := aNameOrFields;
+ end
+ else begin
+ aIndexName := IndexDefs.FindIndexForFields(aNameOrFields).Name;
+ end;
+ end;
+end;
+{--------}
+procedure TffDataSet.dsSetDatabaseName(const aValue : string);
+begin
+ if (csReading in ComponentState) then
+ dsProxy.LoadingFromStream := True;
+ dsProxy.DatabaseName := aValue;
+ if Active then
+ DataEvent(dePropertyChange, 0);
+end;
+{--------}
+procedure TffDataSet.dsSetExclusive(const aValue : Boolean);
+begin
+ dsProxy.CheckInactive(True);
+
+ if (csLoading in ComponentState) then begin
+ dsExclusive := aValue;
+ Exit;
+ end;
+
+ if (dsProxy.Database <> nil) and dsProxy.Database.Exclusive then
+ dsExclusive := True
+ else
+ dsExclusive := aValue;
+end;
+{--------}
+procedure TffDataSet.dsSetFilterEval(const aMode : TffFilterEvaluationType);
+
+begin
+ dsSetFilterTextAndOptions(Filter, FilterOptions, aMode,
+ dsFilterTimeOut);
+end;
+{--------}
+procedure TffDataSet.dsSetFilterTextAndOptions(const aText : string;
+ const aOpts : TFilterOptions;
+ const aMode : TffFilterEvaluationType;
+ const atimeOut : TffWord32);
+begin
+ {if there is no change there's nothing to do}
+ if (Filter = aText) and (FilterOptions = aOpts) and
+ (dsFilterEval = aMode) and (dsFilterTimeOut = atimeOut) then
+ Exit;
+
+ {if the table is active...}
+ if Active then begin
+ CheckBrowseMode;
+
+ { Determine whether or not we have to clear an existing filter. }
+ case dsFilterEval of
+ ffeLocal :
+ {firstly drop the current expression filter}
+ if (dsExprFilter <> nil) then begin
+ Check(dsDropFilter(dsExprFilter));
+ dsExprFilter := nil;
+ end;
+ ffeServer :
+ if aMode = ffeLocal then begin
+ dsClearServerSideFilter;
+ end;
+ end; { case }
+
+ dsFilterEval := aMode;
+ dsFilterTimeOut := atimeOut;
+
+ {call our ancestor}
+ inherited SetFilterText(aText);
+
+ { If a filter is being set then create the new filter based upon where
+ it is to be evaluated. }
+ if (aText <> '') then begin
+ if aMode = ffeLocal then begin
+ {add the new expression & activate it}
+ dsAddExprFilter(aText, aOpts);
+ if Filtered then
+ dsActivateFilter(dsExprFilter);
+ end
+ else if Filtered then
+ dsActivateFilters;
+ end; { If have filter text }
+
+ {call our ancestor}
+ inherited SetFilterOptions(aOpts);
+
+ {if the table is being filtered, go to the start}
+ if Filtered then
+ First;
+ end
+ else {table is not active} begin
+
+ {call our ancestor}
+ inherited SetFilterText(aText);
+ inherited SetFilterOptions(aOpts);
+
+ dsFilterEval := aMode;
+ dsFilterTimeOut := atimeOut;
+ end;
+end;
+{--------}
+function TffDataSet.dsAddFilter(iClientData : Longint;
+ iPriority : Word;
+ bCanAbort : Bool;
+ pCANExpr : pCANExpr;
+ pffilter : pfGENFilter;
+ var hFilter : hDBIFilter) : TffResult;
+var
+ Filter : TffFilterListItem;
+begin
+ Filter := TffFilterListItem.Create(dsFilters, Self,
+ iClientData, iPriority, bCanAbort,
+ pCANExpr, pffilter);
+ hFilter := hDBIFilter(Filter);
+ dsUpdateFilterStatus;
+ Result := DBIERR_NONE;
+end;
+{--------}
+function TffDataSet.dsActivateFilter(hFilter : hDBIFilter) : TffResult;
+var
+ i : Integer;
+ Filter : TffFilterListItem;
+begin
+ Result := DBIERR_NONE;
+ if (hFilter = nil) then begin
+ for i := 0 to Pred(dsFilters.Count) do begin
+ Filter := TffFilterListItem(dsFilters.Items[i]);
+ if (Filter <> nil) then begin
+ Filter.Active := True;
+ dsFilterActive := True;
+ end;
+ end;
+ end
+ else {hFilter is an actual handle} begin
+ Filter := TffFilterListItem(hFilter);
+ if (dsFilters.IndexOf(Filter) <> -1) then begin
+ Filter.Active := True;
+ dsFilterActive := True;
+ end
+ else
+ Result := DBIERR_NOSUCHFILTER;
+ end;
+end;
+{--------}
+function TffDataSet.dsDeactivateFilter(hFilter : hDBIFilter) : TffResult;
+var
+ i : Integer;
+ Filter : TffFilterListItem;
+begin
+ Result := DBIERR_NONE;
+ if (hFilter = nil) then begin
+ for i := 0 to Pred(dsFilters.Count) do begin
+ Filter := TffFilterListItem(dsFilters.Items[i]);
+ if (Filter <> nil) then
+ Filter.Active := False;
+ end;
+ dsFilterActive := False;
+ end
+ else begin
+ Filter := TffFilterListItem(hFilter);
+ if (dsFilters.IndexOf(Filter) <> -1) then begin
+ if Filter.Active then begin
+ Filter.Active := False;
+ dsUpdateFilterStatus;
+ end
+ else {filter wasn't active}
+ Result := DBIERR_NA;
+ end
+ else {filter not found}
+ Result := DBIERR_NOSUCHFILTER;
+ end;
+end;
+{--------}
+procedure TffDataSet.dsSetFilterTimeout(const numMS : TffWord32);
+begin
+ dsSetFilterTextAndOptions(Filter, FilterOptions, dsFilterEval,
+ numMS);
+end;
+
+{--------}
+procedure TffBaseTable.btSetIndexField(aInx : Integer; const aValue : TField);
+begin
+ btGetIndexField(aInx).Assign(aValue);
+end;
+{--------}
+procedure TffBaseTable.btSetIndexFieldNames(const aValue : string);
+begin
+ btSetIndexTo(aValue, aValue = '');
+end;
+{--------}
+procedure TffBaseTable.btSetIndexName(const aValue : string);
+begin
+ btSetIndexTo(aValue, True);
+end;
+{--------}
+procedure TffBaseTable.btSetIndexTo(const aParam : string; aIndexByName : Boolean);
+var
+ IndexName : string;
+begin
+ if (aIndexByName <> btIndexByName) or
+ (aIndexByName and (aParam <> btIndexName)) or
+ ((not aIndexByName) and (aParam <> btIndexFieldStr)) then begin
+ if Active then begin
+ CheckBrowseMode;
+ btRetrieveIndexName(aParam, aIndexByName, IndexName);
+ btSwitchToIndex(IndexName);
+ dsCheckMasterRange;
+ end;
+ if aIndexByName then
+ btIndexName := aParam
+ else {indexing by list of field names} begin
+ btIndexName := IndexName;
+ btIndexFieldStr := aParam;
+ end;
+ btIndexByName := aIndexByName;
+ if Active then
+ Resync([]);
+ end;
+end;
+{--------}
+procedure TffBaseTable.btSetKeyBuffer(aInx : TffKeyEditType; aMustClear : Boolean);
+begin
+ {if the current index is not composite, raise error}
+ CheckBrowseMode;
+ btKeyBuffer := PKeyBuffers(btKeyBuffers)^[aInx];
+ Move(btKeyBuffer^, PKeyBuffers(btKeyBuffers)^[ketSaved]^, btKeyBufSize);
+ if aMustClear then
+ btInitKeyBuffer(btKeyBuffer);
+ SetState(dsSetKey);
+ SetModified(PKeyRecInfo(PChar(btKeyBuffer) + btKeyInfoOfs)^.kriModified);
+ DataEvent(deDataSetChange, 0);
+end;
+{--------}
+procedure TffBaseTable.btSetKeyFields(aInx : TffKeyEditType;
+ const aValues : array of const);
+var
+ OldState : TDataSetState;
+ i : Integer;
+begin
+ { if the current index is not composite, raise error} {!!.10}
+ if Dictionary.IndexType[btIndexID] = itUserDefined then {!!.10}
+ raise EffDatabaseError.Create(ffStrResDataSet[ffdse_TblIdxFldMissing]); {!!.10}
+ OldState := SetTempState(dsSetKey);
+ try
+ btKeyBuffer := PKeyBuffers(btKeyBuffers)^[aInx];
+ btInitKeyBuffer(btKeyBuffer);
+ for i := 0 to High(aValues) do
+ btGetIndexField(i).AssignValue(aValues[i]);
+ with PKeyRecInfo(PChar(btKeyBuffer) + btKeyInfoOfs)^ do begin
+ kriFieldCount := High(aValues) + 1;
+ kriExclusive := False;
+ kriModified := Modified;
+ end;
+ finally
+ RestoreState(OldState);
+ end;{try..finally}
+end;
+{--------}
+function TffDataSet.dsGetPhyRecSize : Integer;
+begin
+ Result := Dictionary.RecordLength;
+end;
+{--------}
+function TffDataSet.dsGetPriorRecord(eLock : TffLockType;
+ pRecBuff : Pointer;
+ RecProps : pRECProps) : TffResult;
+var
+ FoundPrior : Boolean;
+ CreatedBuffer : Boolean;
+begin
+ if (pRecBuff <> nil) then
+ CreatedBuffer := False
+ else begin
+ FFGetMem(pRecBuff, PhysicalRecordSize);
+ CreatedBuffer := True;
+ end;
+ FoundPrior := False;
+ Result := dsGetPriorRecordPrim(ffltNOLOCK, pRecBuff, RecProps);
+ while (Result = DBIERR_NONE) and (not FoundPrior) do begin
+ if dsMatchesFilter(pRecBuff) then begin
+ FoundPrior := True;
+ if (eLock <> ffltNOLOCK) then
+ Result := dsGetRecordPrim(eLock, nil, nil);
+ end
+ else
+ Result := dsGetPriorRecordPrim(ffltNOLOCK, pRecBuff, RecProps);
+ end;
+ if CreatedBuffer then
+ FFFreeMem(pRecBuff, PhysicalRecordSize);
+end;
+{--------}
+function TffDataSet.dsGetPriorRecordPrim(eLock : TffLockType;
+ pRecBuff : Pointer;
+ RecProps : pRECProps) : TffResult;
+begin
+ repeat
+ Result := ServerEngine.RecordGetPrior(CursorID,
+ eLock,
+ pRecBuff);
+ if Result = DBIERR_ff_FilterTimeout then begin
+ if dsCancelServerFilter then
+ break;
+ end else
+ break;
+ until False;
+ if (RecProps <> nil) then
+ FillChar(RecProps^, sizeof(RECProps), 0);
+end;
+{------}
+function TffDataSet.dsGetRecord(eLock : TffLockType;
+ pRecBuff : Pointer;
+ RecProps : pRECProps) : TffResult;
+var
+ CreatedBuffer : Boolean;
+begin
+ if (pRecBuff <> nil) then
+ CreatedBuffer := False
+ else begin
+ FFGetMem(pRecBuff, PhysicalRecordSize);
+ CreatedBuffer := True;
+ end;
+ Result := dsGetRecordPrim(eLock, pRecBuff, RecProps);
+ if (Result = DBIERR_NONE) then begin
+ if (not dsMatchesFilter(pRecBuff)) then begin
+ if (eLock <> ffltNOLOCK) then
+ Check(ServerEngine.RecordRelLock(CursorID,
+ False));
+ Result := DBIERR_RECNOTFOUND;
+ end;
+ end;
+ if CreatedBuffer then
+ FFFreeMem(pRecBuff, PhysicalRecordSize);
+end;
+{--------}
+function TffDataSet.dsGetRecordCountPrim(var iRecCount : Longint) : TffResult;
+var
+ BM : pointer;
+ Buff : pointer;
+ Marked : Boolean;
+
+begin
+ if not FilterActive then begin
+ { Query the server engine for the exact record count}
+ Result := ServerEngine.TableGetRecCount(CursorID,
+ iRecCount);
+ end else begin
+ { We will manually count the records at the client. }
+ {This can take some time, and consume copious amounts of }
+ {bandwitdth. It is recommended that a record count }
+ {only be requested when absolutely necessary when }
+ {filters are active! }
+ iRecCount := 0;
+ FFGetMem(Buff, PhysicalRecordSize);
+ try
+ DisableControls;
+ try
+ { Retrieve a bookmark so we can reset the cursor when we are done}
+ BM := GetBookMark;
+ try
+ Marked := Assigned(BM);
+ try
+ InternalFirst;
+ Result := dsGetNextRecord(ffltNOLOCK, Buff, nil);
+ while (Result = DBIERR_NONE) do begin
+ Inc(iRecCount);
+ Result := dsGetNextRecord(ffltNOLOCK, Buff, nil);
+ end;
+ finally
+ { if an error occured, we need to make sure the cursor is set}
+ {properly!}
+ if Marked then
+ InternalGotoBookmark(BM);
+ end;
+ finally
+ FreeBookmark(BM);
+ end;
+ finally
+ EnableControls;
+ end;
+ finally
+ FFFreeMem(Buff, PhysicalRecordSize);
+ end;
+ end;
+
+ { If an unexpected error occurs set RecordCount to 0} {!!.01 - Start}
+ if (Result <> DBIERR_NONE) then begin
+ if (Result = DBIERR_EOF) then
+ Result := DBIERR_NONE
+ else
+ iRecCount := 0;
+ end; {!!.01 - End}
+end;
+{------}
+function TffDataSet.dsGetRecordPrim(eLock : TffLockType;
+ pRecBuff : Pointer;
+ RecProps : pRECProps) : TffResult;
+begin
+ Result := ServerEngine.RecordGet(CursorID,
+ eLock,
+ pRecBuff);
+ if (RecProps <> nil) then
+ FillChar(RecProps^, sizeof(RECProps), 0);
+end;
+{------}
+function TffBaseTable.btGetRecordForKey(aCursorID : TffCursorID;
+ bDirectKey : Boolean;
+ iFields : Word;
+ iLen : Word;
+ pKey : Pointer;
+ pRecBuff : Pointer
+ ) : TffResult;
+var
+ FoundNext : Boolean;
+ Bookmark : Pointer;
+ CreatedBuffer : Boolean;
+ FuncResult : TffResult;
+ RangeSaved : Boolean;
+ Request : PffnmCursorSetRangeReq;
+ SetRangeReqLen : Integer;
+ FirstCall : Boolean;
+begin
+ if (aCursorID = CursorID) then begin {Begin !!.03}
+ if (not bDirectKey) and (btIndexID = 0) then begin
+ Result := DBIERR_INVALIDINDEXTYPE;
+ Exit;
+ end;
+ end else begin
+ if (not bDirectKey) and (btLookupIndexID = 0) then begin
+ Result := DBIERR_INVALIDINDEXTYPE;
+ Exit;
+ end;
+ end; {END !!.03}
+
+ if FilterActive then begin
+
+ RangeSaved := False;
+
+ { If a range is active then push it onto the range stack.
+ We will restore the range when we are done. }
+ if btRangeStack.SavedRequest then begin
+ btRangeStack.PushSavedRequest;
+ RangeSaved := True;
+ end;
+
+ Bookmark := nil;
+ FuncResult := DBIERR_NONE;
+ {set the range for this key}
+ Result := btSetRangePrim(aCursorID,
+ bDirectKey,
+ iFields,
+ iLen,
+ pKey,
+ True,
+ iFields,
+ iLen,
+ pKey,
+ True);
+ if (Result = DBIERR_NONE) then begin
+ {create a record Buffer if one wasn't passed in}
+ CreatedBuffer := False;
+ if (pRecBuff = nil) then begin
+ CreatedBuffer := True;
+ FFGetMem(pRecBuff, PhysicalRecordSize);
+ end;
+ {search for valid record in range}
+ FoundNext := False;
+ Result := dsGetNextRecordPrim(aCursorID, ffltNoLock, pRecBuff, nil);
+ while (Result = DBIERR_NONE) and (not FoundNext) do begin
+ if dsMatchesFilter(pRecBuff) then begin
+ FoundNext := True;
+ end else
+ Result := dsGetNextRecordPrim(aCursorID, ffltNoLock, pRecBuff, nil);
+ end;
+ {if we succeeded in finding a record in range, get its bookmark}
+ {because the reset range in a moment will lose the record}
+ {position}
+ if not (Result = DBIERR_NONE) then
+ FuncResult := DBIERR_RECNOTFOUND
+ else begin
+// if BookmarkAvailable then begin {!!.06}
+ GetMem(Bookmark, BookmarkSize); {!!.03}
+ Check(ServerEngine.CursorGetBookmark(aCursorID, Bookmark)); {!!.03}
+// end; {!!.06}
+ end;
+ {reset the range}
+ btResetRangePrim(aCursorID, True);
+
+ { Do we need to restore a prior range? }
+ if rangeSaved then begin
+ btRangeStack.popSavedRequest(PffByteArray(Request), SetRangeReqLen);
+ { Send the request. Assume that if it fails we should
+ continue operation anyway. }
+
+ Result :=ServerEngine.CursorSetRange(Request^.CursorID,
+ Request^.DirectKey,
+ Request^.FieldCount1,
+ Request^.PartialLen1,
+ PffByteArray(@Request^.KeyData1),
+ Request^.KeyIncl1,
+ Request^.FieldCount2,
+ Request^.PartialLen2,
+{Begin !!.06}
+ PffByteArray(PAnsiChar(@Request^.KeyData1) +
+ Request^.KeyLen1),
+{End !!.06}
+ Request^.KeyIncl2);
+
+ end;
+ {reset the record position}
+ if (Bookmark <> nil) and
+ BookmarkValid(Bookmark) then begin {!!.06}
+ Check(ServerEngine.CursorSetToBookmark(aCursorID,
+ Bookmark));
+ FreeBookmark(Bookmark);
+ end;
+ if CreatedBuffer then
+ FFFreeMem(pRecBuff, PhysicalRecordSize);
+ end;
+ if (Result = DBIERR_NONE) then
+ Result := FuncResult;
+ end else begin
+ FirstCall := True;
+ repeat
+ Result := ServerEngine.RecordGetForKey(aCursorID,
+ bDirectKey,
+ iFields,
+ iLen,
+ pKey,
+ pRecBuff,
+ FirstCall);
+ if Result = DBIERR_FF_FILTERTimeout then begin
+ if dsCancelServerFilter then
+ Break
+ else
+ FirstCall := False;
+ end else
+ Break;
+ until False;
+ end;
+end;
+{------}
+procedure TffBaseTable.btSetKeyExclusive(const aValue : Boolean);
+begin
+ btCheckKeyEditMode;
+ PKeyRecInfo(PChar(btKeyBuffer) + btKeyInfoOfs)^.kriExclusive := aValue;
+end;
+{--------}
+procedure TffBaseTable.btSetKeyFieldCount(const aValue : Integer);
+begin
+ btCheckKeyEditMode;
+ PKeyRecInfo(PChar(btKeyBuffer) + btKeyInfoOfs)^.kriFieldCount := aValue;
+end;
+{--------}
+procedure TffBaseTable.btSetLinkRange(aMasterFields : TList);
+var
+ i : Integer;
+ SaveState : TDataSetState;
+ RangeStart : PChar;
+ RangeStartInfo : PKeyRecInfo;
+begin
+ {temporarily change the DataSet state so we can modify the key
+ range when we modify field values}
+ SaveState := SetTempState(dsSetKey);
+ try
+ {set up the Buffer to modify the the start of the range, and then
+ set it to the current record in the master}
+ RangeStart := PKeyBuffers(btKeyBuffers)^[ketRangeStart];
+ btKeyBuffer := RangeStart;
+ RangeStartInfo := PKeyRecInfo(RangeStart + btKeyInfoOfs);
+ btInitKeyBuffer(RangeStart);
+ RangeStartInfo^.kriModified := True;
+ for i := 0 to Pred(aMasterFields.Count) do
+ btGetIndexField(i).Assign(TField(aMasterFields[i]));
+ RangeStartInfo^.kriFieldCount := aMasterFields.Count;
+ finally
+ RestoreState(SaveState);
+ end;
+ {make the range end equal to the range start}
+ Move(PKeyBuffers(btKeyBuffers)^[ketRangeStart]^,
+ PKeyBuffers(btKeyBuffers)^[ketRangeEnd]^,
+ btKeyBufSize);
+end;
+{--------}
+procedure TffBaseTable.btSetMasterFields(const aValue : string);
+begin
+ btMasterLink.FieldNames := aValue;
+end;
+{--------}
+procedure TffBaseTable.btSetMasterSource(const aValue : TDataSource);
+begin
+ if IsLinkedTo(aValue) then
+ RaiseFFErrorObjFmt(Self, ffdse_TblCircDataLink, [aValue.Name]);
+ btMasterLink.DataSource := aValue;
+end;
+{--------}
+procedure TffBaseTable.dsSetTableName(const aValue : string);
+begin
+ inherited dsSetTableName(aValue);
+
+ IndexDefs.Updated := False;
+end;
+{--------}
+procedure TffBaseTable.btSetIndexDefs(Value : TIndexDefs); {!!.06}
+begin
+ IndexDefs.Assign(Value);
+end;
+{--------}
+function TffBaseTable.btIndexDefsStored : Boolean; {!!.06}
+begin
+ Result := IndexDefs.Count > 0;
+end;
+{--------}
+function TffBaseTable.btSetRange : Boolean;
+var
+ RangeStart : PChar;
+ RangeEnd : PChar;
+ StartKeyOrRec : PChar;
+ EndKeyOrRec : PChar;
+ RangeStartInfo : PKeyRecInfo;
+ RangeEndInfo : PKeyRecInfo;
+begin
+ { Assume we don't set the range. }
+ Result := False;
+
+ { If range is the same, exit now. }
+ if (BuffersEqual(PKeyBuffers(btKeyBuffers)^[ketRangeStart],
+ PKeyBuffers(btKeyBuffers)^[ketCurRangeStart],
+ btKeyBufSize) and
+ BuffersEqual(PKeyBuffers(btKeyBuffers)^[ketRangeEnd],
+ PKeyBuffers(btKeyBuffers)^[ketCurRangeEnd],
+ btKeyBufSize)) then
+ Exit;
+
+ { Determine what to use for the setrange call. }
+ RangeStart := PKeyBuffers(btKeyBuffers)^[ketRangeStart];
+ RangeStartInfo := PKeyRecInfo(RangeStart + btKeyInfoOfs);
+ if RangeStartInfo^.kriModified then {ie, some key fields are set}
+ StartKeyOrRec := RangeStart
+ else
+ StartKeyOrRec := nil;
+
+ RangeEnd := PKeyBuffers(btKeyBuffers)^[ketRangeEnd];
+ RangeEndInfo := PKeyRecInfo(RangeEnd + btKeyInfoOfs);
+ if RangeEndInfo^.kriModified then {ie, some key fields are set}
+ EndKeyOrRec := RangeEnd
+ else
+ EndKeyOrRec := nil;
+ {set the range}
+ Check(btSetRangePrim(CursorID, False,
+ RangeStartInfo^.kriFieldCount,
+ 0,
+ StartKeyOrRec,
+ not RangeStartInfo^.kriExclusive,
+ RangeEndInfo^.kriFieldCount,
+ 0,
+ EndKeyOrRec,
+ not RangeEndInfo^.kriExclusive));
+ {save the new current range}
+ Move(RangeStart^,
+ PKeyBuffers(btKeyBuffers)^[ketCurRangeStart]^,
+ btKeyBufSize);
+ Move(RangeEnd^,
+ PKeyBuffers(btKeyBuffers)^[ketCurRangeEnd]^,
+ btKeyBufSize);
+ btDestroyLookupCursor;
+ {we succeeded}
+ Result := True;
+end;
+{--------}
+function TffBaseTable.btSetRangePrim(aCursorID : TffCursorID;
+ bKeyItself : Boolean;
+ iFields1 : Word;
+ iLen1 : Word;
+ pKey1 : Pointer;
+ bKey1Incl : Boolean;
+ iFields2 : Word;
+ iLen2 : Word;
+ pKey2 : Pointer;
+ bKey2Incl : Boolean) : TffResult;
+var
+ Request : PffnmCursorSetRangeReq;
+ ReqLen : Integer;
+ KeyLen1, KeyLen2 : Integer;
+ pKeyData2 : pointer;
+begin
+ Result := DBIERR_NOMEMORY;
+ {calculate sizes}
+ if pKey1 = nil then
+ KeyLen1 := 0
+ else if bKeyItself then
+ KeyLen1 := Dictionary.IndexKeyLength[ IndexID ]
+ else
+ KeyLen1 := PhysicalRecordSize;
+ if pKey2 = nil then
+ KeyLen2 := 0
+ else if bKeyItself then
+ KeyLen2 := Dictionary.IndexKeyLength[ IndexID ]
+ else
+ KeyLen2 := PhysicalRecordSize;
+ {now, we know how large the Request is}
+ ReqLen := sizeof(TffnmCursorSetRangeReq) - 4 + KeyLen1 + KeyLen2;
+ {allocate and clear it}
+ ffGetZeroMem(Request, ReqLen);
+ try
+ {fill the request}
+ Request^.CursorID := aCursorID;
+ Request^.DirectKey := bKeyItself;
+ Request^.FieldCount1 := iFields1;
+ Request^.PartialLen1 := iLen1;
+ Request^.KeyLen1 := KeyLen1;
+ Request^.KeyIncl1 := bKey1Incl;
+ Request^.FieldCount2 := iFields2;
+ Request^.PartialLen2 := iLen2;
+ Request^.KeyLen2 := KeyLen2;
+ Request^.KeyIncl2 := bKey2Incl;
+ Move(pKey1^, Request^.KeyData1, KeyLen1);
+ pKeyData2 := PffByteArray(PAnsiChar(@Request^.KeyData1) + KeyLen1);
+ Move(pKey2^, pKeyData2^, KeyLen2);
+
+ Result := ServerEngine.CursorSetRange(aCursorID, bKeyItself,
+ iFields1, iLen1, pKey1, bKey1Incl,
+ iFields2, iLen2, pKey2, bKey2Incl);
+ finally
+ if (Result = DBIERR_NONE) then
+ btRangeStack.SaveLastRequest(PffByteArray(Request), ReqLen)
+ else
+ FFFreeMem(Request, ReqLen);
+ end;
+end;
+{------}
+function TffDataSet.dsCheckBLOBHandle(pRecBuf : Pointer;
+ iField : Integer;
+ var aIsNull : Boolean;
+ var aBLOBNr : TffInt64) : TffResult;
+var
+ TempI64 : TffInt64;
+begin
+ TempI64.iLow := 0;
+ TempI64.iHigh := 0;
+ Dictionary.GetRecordField(Pred(iField), pRecBuf, aIsNull, @aBLOBNr);
+ if (not aIsNull) and (ffCmpI64(aBLOBNr, TempI64) = 0) then
+ Result := DBIERR_INVALIDBLOBHANDLE
+ else
+ Result := DBIERR_NONE;
+end;
+{------}
+function TffDataSet.dsEnsureBlobHandle(pRecBuf : Pointer;
+ iField : Integer;
+ var aBLOBNr : TffInt64) : TffResult;
+var
+ IsNull : Boolean;
+ TempI64 : TffInt64;
+begin
+ TempI64.iLow := 0;
+ TempI64.iHigh := 0;
+ Dictionary.GetRecordField(Pred(iField), pRecBuf, IsNull, @aBLOBNr);
+ if IsNull then begin
+ Result := ServerEngine.BLOBCreate(CursorID,
+ aBLOBNr);
+ if (Result = DBIERR_NONE) then begin
+ Dictionary.SetRecordField(Pred(iField), pRecBuf, @aBLOBNr);
+ end;
+ end
+ else if (ffCmpI64(aBLOBNr, TempI64) = 0) then
+ Result := DBIERR_INVALIDBLOBHANDLE
+ else
+ Result := DBIERR_NONE;
+end;
+{--------}
+function TffDataSet.TruncateBlob(pRecBuf : Pointer;
+ iField : Word;
+ iLen : Longint) : TffResult;
+var
+ BLOBNr : TffInt64;
+ IsNull : boolean;
+begin
+ Result := dsCheckBLOBHandle(pRecBuf, iField, IsNull, BLOBNr);
+ if (Result = DBIERR_NONE) then begin
+ if IsNull then begin
+ if (iLen <> 0) then
+ Result := DBIERR_INVALIDBLOBoffset
+ else
+ Result := DBIERR_NONE;
+ end else begin
+ {BLOB field was not null}
+ {tell the server the new length}
+ Result := ServerEngine.BLOBTruncate(CursorID,
+ BLOBNr,
+ iLen);
+ end;
+ end;
+end;
+{------}
+procedure TffDataSet.dsSetReadOnly(const aValue : Boolean);
+begin
+ dsProxy.CheckInactive(False); {!!.06}
+
+ if (csLoading in ComponentState) then begin
+ dsReadOnly := aValue; {!!.01}
+ Exit;
+ end;
+
+ if (dsProxy.Database <> nil) and dsProxy.Database.ReadOnly then
+ dsReadOnly := True
+ else
+ dsReadOnly := aValue;
+end;
+{--------}
+procedure TffDataSet.dsSetServerSideFilter(const aText : string;
+ const aOpts : TFilterOptions;
+ aTimeout : TffWord32);
+{$ifdef DONTUSEDELPHIUNIT} //soner
+begin
+ raise Exception.Create('In this version [dsCreateLookupFilter] not supperted!');
+end;
+{$else}
+var
+ Parser : TExprParser;
+begin
+ if (aText <> '') then begin
+ {$IFDEF ExprParserType1}
+ Parser := TExprParser.Create(Self, aText, aOpts);
+ {$ENDIF}
+ {$IFDEF ExprParserType2}
+ Parser := TExprParser.Create(Self, aText, aOpts, [], '', nil);
+ {$ENDIF}
+ {$IFDEF ExprParserType3}
+ {$ifdef fpc}
+ Parser := TExprParser.Create(Self, aText, aOpts, [poExtSyntax], '', nil, FldTypeMap);
+ {$else}
+ Parser := TExprParser.Create(Self, aText, aOpts, [], '', nil, FldTypeMap);
+ {$endif}
+ {$ENDIF}
+ try
+ Check(SetFilterEx(ffSrBDE.pCANExpr(Parser.FilterData), aTimeout));
+ finally
+ Parser.Free;
+ end;
+ end
+ else
+ dsClearServerSideFilter;
+end;
+{$endif}
+{--------}
+procedure TffDataSet.dsUpdateFilterStatus;
+var
+ Filt : TffFilterListItem;
+ i : Integer;
+begin
+ for i := 0 to Pred(dsFilters.Count) do begin
+ Filt := TffFilterListItem(dsFilters.Items[i]);
+ if (Filt <> nil) and (Filt.Active) then begin
+ dsFilterActive := True;
+ Exit;
+ end;
+ end;
+ dsFilterActive := False;
+end;
+{--------}
+function TffDataSEt.dsDropFilter(hFilter : hDBIFilter) : TffResult;
+var
+ Inx : Integer;
+ Filter : TffFilterListItem;
+begin
+ if (hFilter = nil) then begin
+ dsFilters.FreeAll;
+ Result := DBIERR_NONE;
+ end
+ else begin
+ Filter := TffFilterListItem(hFilter);
+ Inx := dsFilters.IndexOf(Filter);
+ if (Inx = -1) then
+ Result := DBIERR_NOSUCHFILTER
+ else begin
+ Filter.Free;
+ dsUpdateFilterStatus;
+ Result := DBIERR_NONE;
+ end;
+ end;
+end;
+{--------}
+procedure TffDataSet.dsSetSessionName(const aValue : string);
+begin
+ if (csReading in ComponentState) then
+ dsProxy.LoadingFromStream := True;
+ dsProxy.SessionName := aValue;
+ if Active then
+ DataEvent(dePropertyChange, 0);
+end;
+{--------}
+procedure TffDataSEt.dsSetTableLock(LockType: TffLockType; Lock: Boolean);
+
+begin
+ CheckActive;
+ if Lock then
+ Check(ServerEngine.TableLockAcquire(CursorID,
+ LockType))
+ else
+ Check(ServerEngine.TableLockRelease(CursorID,
+ False));
+end;
+{--------}
+procedure TffDataSet.dsSetTableName(const aValue : string);
+begin
+ if (csReading in ComponentState) then
+ dsProxy.LoadingFromStream := True;
+ dsProxy.TableName := ffExtractTableName(aValue);
+ if Active then
+ DataEvent(dePropertyChange, 0);
+end;
+{--------}
+procedure TffDataset.dsSetTimeout(const Value : Longint);
+begin
+ if dsTimeout = Value then Exit;
+ dsTimeout := Value;
+ if Active then
+ Check(ServerEngine.CursorSetTimeout(CursorID, dsGetTimeout));
+end;
+{--------}
+procedure TffDataSet.dsSetVersion(const aValue : string);
+begin
+ {do nothing}
+end;
+{--------}
+procedure TffBaseTable.btSwitchToIndex(const aIndexName : string);
+var
+ Status : TffResult;
+ aIndexID : Integer;
+begin
+ btResetRange(CursorID, True);
+ UpdateCursorPos;
+ {switch to the new index by name, try and keep on the current record}
+ aIndexID := 0;
+ Status := btSwitchToIndexEx(CursorID,
+ aIndexName,
+ aIndexID,
+ True);
+ {if the new index existed, but there was no current record, try
+ again without keeping the current record current}
+ if (Status = DBIERR_NOCURRREC) or (Status = DBIERR_FF_RecDeleted) then {!!.11}
+ Status := btSwitchToIndexEx(CursorID,
+ aIndexName,
+ aIndexID,
+ False);
+ {check we did OK}
+ Check(Status);
+
+ btKeyLength := 0;
+ btNoCaseIndex := False;
+ btIndexFieldCount := 0;
+ {destroy our record Buffers - the bookmark stuff has changed}
+ SetBufListSize(0);
+ dsGetRecordInfo(True);
+ try
+ {get new record Buffers}
+ SetBufListSize(BufferCount + 1);
+ except
+ {if we're out of memory - or worse - bail out}
+ SetState(dsInactive);
+ CloseCursor;
+ raise;
+ end;
+ {get the new index information}
+ dsGetIndexInfo;
+end;
+{--------}
+function TffBaseTable.btSwitchToIndexEx(aCursorID : TffCursorID;
+ const aIndexName : string;
+ const aIndexID : Integer;
+ const aCurrRec : Boolean) : TffResult;
+var
+ Stream : TStream;
+ TempDict : TffDataDictionary;
+begin
+ Result := ServerEngine.CursorSwitchToIndex(aCursorID,
+ aIndexName,
+ aIndexID,
+ aCurrRec);
+ if (aCursorID = CursorID) and (Result = DBIERR_NONE) then begin {!!.03}
+ if (aIndexName <> '') then begin
+ btIndexID := Dictionary.GetIndexFromName(aIndexName);
+ btIndexName := aIndexName;
+ btRangeStack.Clear;
+ end else begin
+ btIndexName := Dictionary.IndexName[aIndexID];
+ btIndexID := aIndexID;
+ end;
+ end else begin
+ { fetch data dictionary }
+ TempDict := TffDataDictionary.Create(4096);
+ try
+ Stream := TMemoryStream.Create;
+ try
+ if Database.GetFFDataDictionary(TableName, Stream) = DBIERR_NONE then begin
+ Stream.Position:= 0;
+ TempDict.ReadFromStream(Stream);
+ end;
+ finally
+ Stream.Free;
+ end;
+ if (aCursorID = btLookupCursorID) and (Result = DBIERR_NONE) then begin
+ if (aIndexName <> '') then begin
+ btLookupIndexID := TempDict.GetIndexFromName(aIndexName);
+ btLookupIndexName := aIndexName;
+ end else begin
+ btIndexID := aIndexID;
+ btIndexName := TempDict.IndexName[aIndexID];
+ end;
+ end;
+ finally
+ TempDict.Free;
+ end;
+ end;
+end;
+{--------}
+procedure TffBaseTable.UpdateIndexDefs;
+var
+ i : Integer;
+ SaveHandle : TffCursorID;
+ IndexCount : Integer;
+ IndexArray : PffIDXDescArray;
+ Options : TIndexOptions;
+ Name : string;
+ FieldsStr : string;
+ CursorProps : TffCursorProps;
+begin
+ {if the indexes are not up to date, go get info on them...}
+ if not IndexDefs.Updated then begin
+ dsEnsureDatabaseOpen(True);
+ try
+ SaveHandle := CursorID;
+ if (SaveHandle = 0) then
+ dsCursorID := GetCursorHandle('');
+ FieldDefs.Update;
+ try
+ GetCursorProps(CursorProps);
+ IndexCount := CursorProps.IndexCount;
+ FFGetMem(IndexArray, IndexCount * sizeof(IDXDesc));
+ try
+ IndexDefs.Clear;
+ btGetIndexDescs(PIDXDesc(IndexArray));
+ for i := 0 to Pred(IndexCount) do begin
+ btDecodeIndexDesc(IndexArray^[i], Name, FieldsStr, Options);
+ IndexDefs.Add(Name, FieldsStr, Options);
+ end;
+ IndexDefs.Updated := True;
+ finally
+ FFFreeMem(IndexArray, IndexCount * sizeof(IDXDesc));
+ end;{try..finally}
+ finally
+ if (SaveHandle = 0) then begin
+ DestroyHandle(CursorID);
+ dsCursorID := 0;
+ end;
+ end;{try..finally}
+ finally
+ dsEnsureDatabaseOpen(False);
+ end;{try..finally}
+ end;
+end;
+{--------}
+procedure TffDataSet.UnlockTable(LockType: TffLockType);
+
+begin
+ dsSetTableLock(LockType, False);
+end;
+{--------}
+procedure TffDataSet.UnlockTableAll;
+
+begin
+ CheckActive;
+ Check(ServerEngine.TableLockRelease(CursorID,
+ True));
+end;
+{====================================================================}
+
+
+{===TffBlobStream====================================================}
+constructor TffBlobStream.Create(aField : TBlobField; aMode : TBlobStreamMode);
+var
+ OpenMode : TffOpenMode;
+begin
+ inherited Create;
+
+ bsMode := aMode;
+ bsField := aField;
+ bsTable := bsField.DataSet as TffDataSet;
+ bsFieldNo := bsField.FieldNo;
+ bsChunkSize := ffMaxBlobChunk;
+ if not bsTable.GetActiveRecBuf(bsRecBuf) then
+ Exit;
+ if (bsTable.State = dsFilter) then
+ RaiseFFErrorObj(aField, ffdse_BLOBFltNoFldAccess);
+ if not bsField.Modified then begin
+ if (aMode = bmRead) then
+ OpenMode := omReadOnly
+ else {BLOB stream mode is not readonly} begin
+ if aField.ReadOnly then
+ RaiseFFErrorObj(aField, ffdse_BLOBAccessNoMatch);
+ if not (bsTable.State in [dsEdit, dsInsert]) then
+ RaiseFFErrorObj(aField, ffdse_BLOBTblNoEdit);
+ OpenMode := omReadWrite;
+ end;
+ bsTable.dsBlobOpenMode := OpenMode;
+ end;
+ bsOpened := True;
+ if (aMode = bmWrite) then
+ Truncate;
+end;
+{--------}
+destructor TffBlobStream.Destroy;
+begin
+ if bsOpened then begin
+ if bsModified then
+ bsField.Modified := True;
+ if not bsField.Modified then
+ bsTable.FreeBlob(bsRecBuf, bsFieldNo);
+ end;
+ if bsModified then begin
+ try
+ bsTable.DataEvent(deFieldChange, Longint(bsField));
+ except
+ raise;
+ end;
+ end;
+
+ inherited Destroy;
+end;
+{--------}
+function TffBlobStream.bsGetBlobSize : Longint;
+var
+ Status : TffResult;
+ IsNull : Boolean;
+ BLOBNr : TffInt64;
+begin
+ Result := 0;
+ if bsOpened then begin
+ Status := bsTable.dsCheckBLOBHandle(bsRecBuf,
+ bsFieldNo,
+ IsNull,
+ BLOBNr);
+ if (Status = DBIERR_NONE) and (not IsNull) then begin
+ Status := bsTable.ServerEngine.BLOBGetLength(bsTable.CursorID,
+ BLOBNr,
+ Result);
+ end;
+ Check(Status);
+ end;
+end;
+{--------}
+function TffBlobStream.Read(var aBuffer; aCount : Longint) : Longint;
+var
+ Status : TffResult;
+ T,N : Integer;
+ IsNull : Boolean;
+ BLOBNr : TffInt64;
+ Dest : Pointer;
+ BytesRead : TffWord32; {!!.06}
+begin
+ Result := 0;
+ if bsOpened then begin
+ T := 0;
+ bsCancel := False;
+ while aCount > 0 do begin
+ if bsChunkSize = 0 then
+ N := aCount
+ else if aCount > bsChunkSize then
+ N := bsChunkSize
+ else
+ N := aCount;
+ Result := 0;
+ Status := bsTable.dsCheckBLOBHandle(bsRecBuf, bsFieldNo, ISNull, BLOBNr);
+ if (Status = DBIERR_NONE) and (not IsNull) then begin
+ Dest := @PChar(@aBuffer)[T];
+ Status := bsTable.ServerEngine.BLOBRead(bsTable.CursorID,
+ BLOBNr,
+ bsPosition,
+ N,
+ Dest^,
+ BytesRead); {!!.06}
+ Result := BytesRead; {!!.06}
+ end;
+ case Status of
+ DBIERR_NONE,
+ DBIERR_ENDOFBLOB:
+ inc(bsPosition, Result);
+ DBIERR_INVALIDBLOBoffset:
+ Result := 0;
+ else
+ RaiseffErrorCode(Status);
+ end;{case}
+ if bsCancel then RaiseffErrorCode(DBIERR_ENDOFBLOB);
+ dec(aCount,Result);
+ Inc(T,Result);
+
+ { If fewer bytes were returned than requested then
+ we have reached the end of the BLOB. }
+ if Result < N then
+ break;
+
+ end;
+ Result := T;
+ end;
+end;
+{--------}
+function TffBlobStream.Write(const aBuffer; aCount : Longint) : Longint;
+var
+ T,N : Integer;
+ BLOBNr : TffInt64;
+ Status : TffResult;
+ Src : Pointer;
+begin
+ Result := 0;
+ if bsOpened then begin
+ T := 0;
+ bsCancel := False;
+ while aCount > 0 do begin
+ if bsChunkSize = 0 then
+ N := aCount
+ else if aCount > bsChunkSize then
+ N := bsChunkSize
+ else
+ N := aCount;
+
+ Status := bsTable.dsEnsureBLOBHandle(bsRecBuf, bsFieldNo, BLOBNr);
+ if (Status = DBIERR_NONE) then begin
+ Src := @PChar(@aBuffer)[T];
+ Status := bsTable.ServerEngine.BLOBWrite(bsTable.CursorID,
+ BLOBNr,
+ bsPosition,
+ N,
+ Src^);
+ end;
+ Check(Status);
+ inc(bsPosition, N);
+ inc(T,N);
+ Dec(aCount,N);
+ if bsCancel then RaiseffErrorCode(DBIERR_ENDOFBLOB)
+ end;
+ Result := T;
+ bsModified := True;
+ end;
+end;
+{--------}
+function TffBlobStream.Seek(aoffset : Longint; aOrigin : Word) : Longint;
+begin
+ case aOrigin of
+ soFromBeginning : bsPosition := aoffset;
+ soFromCurrent : inc(bsPosition, aoffset);
+ soFromEnd : bsPosition := bsGetBlobSize + aoffset;
+ end;
+ Result := bsPosition;
+end;
+{--------}
+procedure TffBlobStream.Truncate;
+begin
+ if bsOpened then begin
+ Check(bsTable.TruncateBlob(bsRecBuf, bsFieldNo, bsPosition));
+ bsModified := true;
+ end;
+
+end;
+{====================================================================}
+
+function TffDataSet.dsGetServerEngine: TffBaseServerEngine;
+begin
+ if Assigned(dsServerEngine) and Active then
+ Result := dsServerEngine
+ else
+ Result := Session.ServerEngine;
+end;
+{--------}
+function TffBaseDatabase.bdGetServerEngine: TffBaseServerEngine;
+begin
+ if Assigned(bdServerEngine) and Active then
+ Result := bdServerEngine
+ else
+ Result := Session.ServerEngine;
+end;
+{--------}
+procedure TffBaseDatabase.bdRefreshTimeout; {new !!.11}
+var
+ Idx : Integer;
+begin
+ if Active then begin
+ Check(ServerEngine.DatabaseSetTimeout(bdDatabaseID, GetTimeout));
+ for Idx := 0 to Pred(OwnedDBItems.Count) do
+ TffTableProxyList(OwnedDBItems)[Idx].ffTable.dsRefreshTimeout;
+ end;
+end;
+{--------}
+function TffTableProxy.tpGetServerEngine: TffBaseServerEngine;
+begin
+ if Assigned(tpServerEngine) and Active then
+ Result := tpServerEngine
+ else
+ Result := Session.ServerEngine;
+end;
+{====================================================================}
+
+{===TffQueryDataLink=================================================}
+constructor TffQueryDataLink.Create(aQuery: TffQuery);
+begin
+ inherited Create;
+ FQuery := aQuery;
+end;
+
+procedure TffQueryDataLink.ActiveChanged;
+begin
+ if FQuery.Active then FQuery.quRefreshParams;
+end;
+
+{$IFDEF DCC4OrLater}
+function TffQueryDataLink.GetDetailDataSet: TDataSet;
+begin
+ Result := FQuery;
+end;
+{$ENDIF}
+
+procedure TffQueryDataLink.RecordChanged(Field: TField);
+begin
+ if (Field = nil) and FQuery.Active then FQuery.quRefreshParams;
+end;
+
+procedure TffQueryDataLink.CheckBrowseMode;
+begin
+ if FQuery.Active then FQuery.CheckBrowseMode;
+end;
+{=====================================================================}
+
+{== TffQuery =========================================================}
+constructor TffQuery.Create(aOwner : TComponent);
+begin
+ inherited Create(aOwner);
+ { We must give dsProxy a unique name. }
+ dsProxy.DBName := intToStr(GetCurrentThreadID) + intToStr(GetTickCount);
+ FDataLink := TffQueryDataLink.Create(Self);
+ FExecuted := True;
+ FParamCheck := True;
+ {$IFDEF DCC4OrLater}
+ FParams := TParams.Create(Self);
+ {$ELSE}
+ FParams := TParams.Create;
+ {$ENDIF}
+ FPrepared := False;
+ FSQL := TStringList.Create;
+ TStringList(FSQL).OnChange := quSQLChanged;
+ FStmtID := 0;
+ FRowsAffected := -1; {!!.10}
+ FCanModify := False; {!!.10}
+end;
+{--------}
+destructor TffQuery.Destroy;
+begin
+ quDisconnect;
+ FDataLink.Free;
+ FParams.Free;
+ FSQL.Free;
+ inherited Destroy;
+end;
+{--------} {begin !!.10}
+procedure TffQuery.ExecSQL;
+var
+ Dummy : TffCursorID;
+begin
+ CheckInactive;
+
+ quExecSQLStmt(omReadOnly, Dummy);
+end;
+{--------}
+procedure TffQuery.quExecSQLStmt(const aOpenMode : TffOpenMode;
+ var aCursorID : TffCursorID);
+var
+ Msg : string;
+ MsgLen : integer;
+ OpenCursorID : Longint;
+ ParamsData : PffByteArray;
+ ParamsDataLen : integer;
+ ParamsList : PffSqlParamInfoList;
+ SQLResult : TffResult;
+ Stream : TStream;
+ OpenCanModify : Boolean; {!!.10}
+ OpenRowsAffected : Integer; {!!.10}
+
+begin
+ Msg := '';
+ MsgLen := 0;
+ FRowsAffected := -1; {!!.10}
+ FRecordsRead := 0; {!!.10}
+
+ { Do we have a SQL statement? }
+ if FSQL.Count > 0 then begin
+ { Yes. Prepare the statement. }
+ ParamsData := nil;
+ ParamsDataLen := 0;
+ ParamsList := nil;
+ { Allocate & prepare the SQL statement. }
+ quPreparePrim(True);
+
+ { Are we linked to a datasource? }
+ if assigned(FDataLink.DataSource) then
+ quSetParamsFromCursor;
+
+ { Do we have parameters? }
+ if FParams.Count > 0 then begin
+ { Yes. Send them to the server. }
+ quBuildParams(ParamsList, ParamsData, ParamsDataLen);
+ Stream := TMemoryStream.Create;
+ try
+ SQLResult := ServerEngine.SQLSetParams(FStmtID, FParams.Count,
+ pointer(ParamsList),
+ ParamsData, ParamsDataLen,
+ Stream);
+ { Was the set parameters successful? }
+ if SQLResult <> DBIERR_NONE then begin
+ { No. Raise an error. }
+ Stream.Position := 0;
+ Stream.Read(MsgLen, sizeOf(MsgLen));
+ if MsgLen > 0 then begin
+ SetLength(Msg, MsgLen);
+ Stream.Read(Msg[1], MsgLen);
+ RaiseFFErrorObjFmt(Self, ffdse_QuerySetParamsFail, [#13#10, Msg]);
+ end
+ else
+ Check(SQLResult);
+ end;
+ finally
+ Stream.Free;
+ end;
+ end;
+
+ { Execute the query. }
+ Stream := TMemoryStream.Create;
+ try
+ SQLResult := ServerEngine.SQLExec(FStmtID, aOpenMode, aCursorID, Stream);
+ { Was the execution successful? }
+ if SQLResult <> DBIERR_NONE then begin
+ { No. Raise an error. }
+ if Stream.Size > 0 then begin
+ Stream.Position := 0;
+ Stream.Read(MsgLen, sizeOf(MsgLen));
+ end;
+ if MsgLen > 0 then begin
+ SetLength(Msg, MsgLen);
+ Stream.Read(Msg[1], MsgLen);
+ RaiseFFErrorObjFmt(Self, ffdse_QueryExecFail, [#13#10, Msg]);
+ end
+ else
+ Check(SQLResult);
+ end;
+
+ { Load the data dictionary, if necessary. }
+ Stream.Position := 0;
+ Stream.Read(OpenCursorID, SizeOf(OpenCursorID));
+ aCursorID := OpenCursorID;
+
+ if aCursorID <> 0 then begin {begin !!.10}
+ Dictionary.ReadFromStream(Stream);
+ Stream.Read(OpenCanModify, SizeOf(OpenCanModify));
+ Stream.Read(FRecordsRead, SizeOf(FRecordsRead));
+ end else begin
+ {get rows affected}
+ Stream.Read(OpenRowsAffected, SizeOf(OpenRowsAffected));
+ FRowsAffected := OpenRowsAffected;
+ Stream.Read(FRecordsRead, SizeOf(FRecordsRead));
+ end; {end !!.10}
+
+ finally
+ Stream.Free;
+ if assigned(ParamsData) then
+ FFFreemem(ParamsData, ParamsDataLen);
+ if assigned(ParamsList) then
+ FFFreemem(ParamsList, SizeOf(TffSQLParamInfo) * FParams.Count);
+ end;
+ end else
+ RaiseFFErrorObj(Self, ffdse_EmptySQLStatement);
+end;
+{--------} {end !!.10}
+{$IFDEF DCC4OrLater}
+procedure TffQuery.DefineProperties(Filer : TFiler);
+
+ function HasData : boolean;
+ begin
+ { We have data to write if our parameters are different than our ancestor
+ class or, if we have no ancestor class, we have 1 or more parameters. }
+ if assigned(Filer.Ancestor) then
+ Result := not FParams.IsEqual(TffQuery(Filer.Ancestor).FParams)
+ else
+ Result := (FParams.Count > 0);
+ end;
+
+begin
+ inherited DefineProperties(Filer);
+ Filer.DefineProperty('ParamData', quReadParams, quWriteParams, HasData);
+end;
+{$ENDIF}
+{--------}
+procedure TffQuery.DestroyHandle(aHandle : TffCursorID);
+begin
+ { Release any existing record locks. }
+ Check(ServerEngine.RecordRelLock(dsCursorID, False));
+
+ { Close the cursor handle, ignore errors. }
+ Check(ServerEngine.CursorClose(dsCursorID));
+ dsCursorID := 0;
+end;
+{--------}
+procedure TffQuery.dsCloseViaProxy;
+begin
+ inherited dsCloseViaProxy;
+
+ Unprepare;
+end;
+{--------}
+function TffQuery.dsGetServerEngine: TffBaseServerEngine;
+begin
+ if Assigned(dsServerEngine) then
+ Result := dsServerEngine
+ else
+ Result := Session.ServerEngine;
+end;
+{--------}
+function TffQuery.GetCanModify : Boolean;
+begin
+ Result := FCanModify; {!!.10}
+end;
+{--------}
+function TffQuery.GetCursorHandle(aIndexName : string) : TffCursorID;
+var
+ Msg : string;
+ MsgLen : integer;
+ OpenCursorID : Longint;
+ OpenMode : TffOpenMode; {!!.10}
+ OpenCanModify : Boolean; {!!.10}
+ ParamsData : PffByteArray;
+ ParamsDataLen : integer;
+ ParamsList : PffSqlParamInfoList;
+ SQLResult : TffResult;
+ Stream : TStream;
+ OpenRowsAffected : Integer; {!!.11}
+begin
+ Result := 0;
+ FExecuted := False;
+ Msg := '';
+ MsgLen := 0;
+
+ { Do we have a SQL statement? }
+ if FSQL.Count > 0 then begin
+ { Yes. Prepare the statement. }
+ ParamsData := nil;
+ ParamsDataLen := 0;
+ ParamsList := nil;
+ { Allocate & prepare the SQL statement. }
+ quPreparePrim(True);
+
+ { Are we linked to a datasource? }
+ if assigned(FDataLink.DataSource) then
+ quSetParamsFromCursor;
+
+ { Do we have parameters? }
+ if FParams.Count > 0 then begin
+ { Yes. Send them to the server. }
+ quBuildParams(ParamsList, ParamsData, ParamsDataLen);
+ Stream := TMemoryStream.Create;
+ try
+ SQLResult := ServerEngine.SQLSetParams(FStmtID, FParams.Count,
+ pointer(ParamsList),
+ ParamsData, ParamsDataLen,
+ Stream);
+ { Was the set parameters successful? }
+ if SQLResult <> DBIERR_NONE then begin
+ { No. Raise an error. }
+ Stream.Position := 0;
+ Stream.Read(MsgLen, sizeOf(MsgLen));
+ if MsgLen > 0 then begin
+ SetLength(Msg, MsgLen);
+ Stream.Read(Msg[1], MsgLen);
+ RaiseFFErrorObjFmt(Self, ffdse_QuerySetParamsFail, [#13#10, Msg]);
+ end
+ else
+ Check(SQLResult);
+ end;
+ finally
+ Stream.Free;
+ end;
+ end;
+
+ { Execute the query. }
+ if FRequestLive then
+ OpenMode := omReadWrite
+ else
+ OpenMode := omReadOnly;
+ Stream := TMemoryStream.Create;
+ try
+ SQLResult := ServerEngine.SQLExec(FStmtID, OpenMode, dsCursorID, Stream);
+ { Was the execution successful? }
+ if SQLResult <> DBIERR_NONE then begin
+ { No. Raise an error. }
+ if Stream.Size > 0 then begin
+ Stream.Position := 0;
+ Stream.Read(MsgLen, sizeOf(MsgLen));
+ end;
+ if MsgLen > 0 then begin
+ SetLength(Msg, MsgLen);
+ Stream.Read(Msg[1], MsgLen);
+ RaiseFFErrorObjFmt(Self, ffdse_QueryExecFail, [#13#10, Msg]);
+ end
+ else
+ Check(SQLResult);
+ end;
+
+ { Load the data dictionary. }
+{Begin !!.11}
+ FCanModify := False;
+ Stream.Position := 0;
+ Stream.Read(OpenCursorID, SizeOf(OpenCursorID));
+ if dsCursorID <> 0 then begin
+ Dictionary.ReadFromStream(Stream);
+ Stream.Read(OpenCanModify, SizeOf(OpenCanModify));
+ Stream.Read(FRecordsRead, SizeOf(FRecordsRead));
+ if RequestLive then
+ FCanModify := OpenCanModify;
+ end
+ else begin
+ Stream.Read(OpenRowsAffected, SizeOf(OpenRowsAffected));
+ FRowsAffected := OpenRowsAffected;
+ Stream.Read(FRecordsRead, SizeOf(FRecordsRead));
+ end;
+{End !!.11}
+ dsReadFieldDescs;
+ Result := dsCursorID;
+ FExecuted := True;
+ finally
+ Stream.Free;
+ if assigned(ParamsData) then
+ FFFreemem(ParamsData, ParamsDataLen);
+ if assigned(ParamsList) then
+ FFFreemem(ParamsList, SizeOf(TffSQLParamInfo) * FParams.Count);
+ end;
+ end
+ else
+ RaiseFFErrorObj(Self, ffdse_EmptySQLStatement);
+
+end;
+{--------}
+function TffQuery.GetCursorProps(var aProps : TffCursorProps) : TffResult;
+begin
+ Result := inherited GetCursorProps(aProps);
+ aProps.KeySize := 0;
+ aProps.IndexCount := 0;
+ {aProps.BookMarkSize := ffcl_FixedBookmarkSize;} {!!.10}
+end;
+{--------}
+procedure TffQuery.InternalClose;
+begin
+ FExecuted := False;
+ {deactivate filters}
+ if Filtered then
+ dsDeactivateFilters;
+ {drop filters}
+ dsDropFilters;
+ {clear up the fields}
+ BindFields(False);
+ if DefaultFields then
+ DestroyFields;
+ dsServerEngine := nil; {!!.11}
+end;
+{Begin !!.01}
+{--------}
+function TffQuery.Locate(const aKeyFields : string;
+ const aKeyValues : Variant;
+ aOptions : TLocateOptions) : Boolean;
+begin
+ DoBeforeScroll;
+ Result := quLocateRecord(aKeyFields, aKeyValues, aOptions, True);
+ if Result then begin
+ Resync([rmExact, rmCenter]);
+ DoAfterScroll;
+ end;
+end;
+{End !!.01}
+{--------}
+function TffQuery.Lookup(const aKeyFields : string;
+ const aKeyValues : Variant;
+ const aResultFields : string) : Variant;
+var
+ OurBuffer : PChar;
+ OurFields : TList;
+ FilterHandle : HDBIFilter;
+begin
+ Result := Null;
+
+ {make sure we're in browse mode}
+ CheckBrowseMode;
+ CursorPosChanged;
+ {get a temporary record Buffer}
+ OurBuffer := TempBuffer;
+ {create list of fields}
+ OurFields := TList.Create;
+ try
+ {get the actual fields in the parameter aKeyFields}
+ GetFieldList(OurFields, aKeyFields);
+ InternalFirst;
+ FilterHandle := dsCreateLookupFilter(OurFields, aKeyValues, []);
+ if dsGetNextRecord(ffltNoLock, OurBuffer, nil) = 0 then begin
+ if FilterEval = ffeServer then
+ RestoreFilterEx
+ else
+ dsDropFilter(FilterHandle);
+ SetTempState(dsCalcFields);
+ try
+ CalculateFields(TempBuffer);
+ Result := FieldValues[aResultFields];
+ finally
+ RestoreState(dsBrowse);
+ end;{try..finally}
+ end;
+ finally
+ OurFields.Free;
+ end;{try..finally}
+end;
+{--------}
+function TffQuery.ParamByName(const aName : string) : TParam;
+begin
+ Result := FParams.ParamByName(aName);
+end;
+{--------}
+procedure TffQuery.Prepare;
+begin
+ quPreparePrim(True);
+end;
+{--------}
+procedure TffQuery.quBuildParams(var ParamsList : PffSqlParamInfoList;
+ var ParamsData : PffByteArray;
+ var ParamsDataLen : integer);
+var
+ aParam : TParam;
+ aSrcBuffer : pointer;
+ aTgtBuffer : pointer;
+ Index : integer;
+ Offset : integer;
+ PSqlParamInfo : PffSqlParamInfo;
+begin
+ { Get memory for the params list. }
+ FFGetMem(ParamsList, sizeOf(TffSqlParamInfo) * FParams.Count);
+
+ Offset := 0;
+ ParamsDataLen := 0;
+
+ { Fill in the parameter list. }
+ for Index := 0 to Pred(FParams.Count) do begin
+ aParam := FParams.Items[Index];
+ PSqlParamInfo := @ParamsList^[Index];
+ with PSqlParamInfo^ do begin
+ piNum := Succ(Index);
+ { parameter number, base 1 }
+ piName := aParam.Name;
+ { parameter name }
+ MapVCLTypeToFF(aParam.DataType, aParam.GetDataSize, piType, piLength);
+{Begin !!.13}
+ { If this is a BLOB then we must obtain the actual size of the data. }
+ if piType in [fftBLOB..fftBLOBTypedBin] then
+ piLength := aParam.GetDataSize;
+{End !!.13}
+
+ { data type & length }
+ piOffset := Offset;
+ { offset in data buffer }
+
+ inc(Offset, piLength);
+ inc(ParamsDataLen, piLength);
+
+ end;
+ end;
+
+ { Allocate memory for the parameter data buffer. }
+ FFGetMem(ParamsData, ParamsDataLen);
+
+ { Fill the parameter data buffer. }
+ for Index := 0 to Pred(FParams.Count) do begin
+ aParam := FParams.Items[Index];
+ PSqlParamInfo := @ParamsList^[Index];
+ { Convert the data into FF format and store it in the buffer. }
+ with PSqlParamInfo^ do begin
+{Begin !!.13}
+ aTgtBuffer := @ParamsData^[piOffset];
+ if piType in [fftBLOB..fftBLOBTypedBin] then begin
+ if piLength > 0 then
+ aParam.GetData(aTgtBuffer);
+ end
+ else begin
+ FFGetmem(aSrcBuffer, aParam.GetDataSize);
+ try
+ aParam.GetData(aSrcBuffer);
+ MapBDEDataToFF(piType, aParam.GetDataSize, aSrcBuffer, aTgtBuffer);
+ finally
+ FFFreemem(aSrcBuffer, aParam.GetDataSize);
+ end;
+ end; { if..else }
+{End !!.13}
+ end; { with }
+ end; { for }
+
+end;
+{--------}
+procedure TffQuery.quDisconnect;
+begin
+ Close;
+ Unprepare;
+end;
+{--------}
+procedure TffQuery.quFreeStmt;
+var
+ Result : TffResult;
+begin
+ if FStmtID > 0 then begin
+ Result := ServerEngine.SQLFree(FStmtID);
+ FStmtID := 0;
+ if not (csDestroying in ComponentState) then
+ Check(Result);
+ end;
+end;
+{--------}
+function TffQuery.quGetDataSource : TDataSource;
+begin
+ Result := FDataLink.DataSource;
+end;
+{Begin !!.01}
+{--------}
+function TffQuery.quLocateRecord(const aKeyFields : string;
+ const aKeyValues : Variant;
+ aOptions : TLocateOptions;
+ aSyncCursor: Boolean): Boolean;
+var
+ OurBuffer : PChar;
+ OurFields : TList;
+ FilterHandle : HDBIFilter;
+ Status : TffResult;
+begin
+ { Make sure we're in browse mode. }
+ CheckBrowseMode;
+ CursorPosChanged;
+ { Get a temporary record buffer. }
+ OurBuffer := TempBuffer;
+ { Create list of fields. }
+ OurFields := TList.Create;
+ try
+ { Get the actual fields in the parameter aKeyFields. }
+ GetFieldList(OurFields, aKeyFields);
+
+ { Locate the record via a filter. }
+ InternalFirst;
+ FilterHandle := dsCreateLookupFilter(OurFields, aKeyValues, aOptions);
+ Status := dsGetNextRecord(ffltNoLock, OurBuffer, nil);
+ if FilterEval = ffeServer then
+ RestoreFilterEx
+ else
+ dsDropFilter(FilterHandle);
+ finally
+ OurFields.Free;
+ end;{try..finally}
+ Result := (Status = DBIERR_NONE);
+end;
+{End !!.01}
+{--------}
+function TffQuery.quGetParamCount : Word;
+begin
+ Result := FParams.Count;
+end;
+{--------} {begin !!.10}
+function TffQuery.quGetRowsAffected : Integer;
+begin
+ Result := FRowsAffected;
+end;
+{--------} {end !!.10}
+function TffQuery.quParseSQL(aStmt : string; createParams : boolean;
+ aParams : TParams) : string;
+const
+ MaxNest = 5;
+ ParamNameTerminators = [#9, #10, #13, ' ', ',', ';', ')', '=', {!!.11}
+ '>', '<']; {!!.11}
+ StringDelims = ['''', '"', '`'];
+ { Things that delimit a string. }
+var
+ CurPos, EndPos, NameEndPos, NameStartPos, StartPos : integer;
+ DelimStackTop : integer;
+ DelimStack : array[1..MaxNest] of char;
+ aLen : integer;
+begin
+ { Parameter format:
+ :
+ :"" (i.e., for multiword param names)
+
+ Excluded:
+ double colons
+ a colon occuring within double or single quotes
+ }
+
+ if aStmt = '' then
+ Exit;
+
+ Result := aStmt;
+
+ CurPos := 1;
+ DelimStackTop := 0;
+
+ repeat
+
+ { Skip past the leading bytes of multi-byte character set. }
+ while Result[CurPos] in LeadBytes do inc(CurPos);
+
+ { Is this the start of a literal? }
+ if Result[CurPos] in StringDelims then begin
+ { Yes. Skip to the end of the literal. Note that we can have nested
+ delimiters. }
+ inc(DelimStackTop);
+ DelimStack[DelimStackTop] := Result[CurPos];
+
+ repeat
+
+ inc(CurPos);
+ aLen := Length(Result);
+
+ while (CurPos < aLen) and
+ (not (Result[CurPos] in StringDelims)) do begin
+ { Skip past leading bytes of MBCS. }
+ while Result[CurPos] in LeadBytes do inc(CurPos);
+ { Skip this char. }
+ inc(CurPos);
+ end;
+
+ if CurPos > aLen then
+ break;
+
+ { Does this delimiter match the beginning delimiter? }
+ if Result[CurPos] = DelimStack[DelimStackTop] then
+ { Yes. Decrement the stack. We will leave this loop once
+ the stack is empty (e.g., DelimStackTop = 0). }
+ dec(DelimStackTop)
+ else if DelimStackTop < MaxNest then begin
+ { No. We have encountered nested delimiters. Add the delimiter
+ to the stack. }
+ inc(DelimStackTop);
+ DelimStack[DelimStackTop] := Result[CurPos];
+ end;
+
+ until DelimStackTop = 0;
+
+ { Move to the character after the final string delimiter. }
+ inc(CurPos);
+
+ end
+ else if (Result[CurPos] = ':') then begin
+ { Is this a double colon? }
+ if (Result[CurPos + 1] = ':') then
+ inc(CurPos, 2)
+ else begin
+ { No. We have found a single colon. Grab the name. Note that the
+ name may be in single quotes. }
+ StartPos := CurPos;
+ inc(CurPos);
+ { Is the colon followed by a double quote? In other words, is the
+ param name delimited by double quotes? }
+ if Result[CurPos] = '"' then begin
+ inc(CurPos);
+ NameStartPos := CurPos;
+ repeat
+ inc(CurPos);
+ until Result[CurPos] = '"';
+ EndPos := CurPos;
+ NameEndPos := CurPos - 1;
+ end
+ else begin
+ NameStartPos := CurPos;
+ repeat
+ inc(CurPos);
+ until Result[CurPos] in ParamNameTerminators;
+ EndPos := CurPos - 1;
+ NameEndPos := EndPos;
+ end;
+
+
+ { Create a TParam if necessary. Replace the name with a '?'. }
+ if createParams and assigned(aParams) then
+ aParams.CreateParam(ftUnknown,
+ Copy(Result, NameStartPos,
+ (NameEndPos - NameStartPos) + 1), ptUnknown);
+
+ Result[StartPos] := '?';
+ System.Delete(Result, StartPos + 1, EndPos - StartPos);
+ CurPos := StartPos + 1;
+
+ end;
+ end else
+ { Not the start of a literal or a colon. Move to next character. }
+ inc(CurPos);
+
+ until (CurPos > Length(Result)) or (Result[CurPos] = #0);
+
+end;
+{--------}
+procedure TffQuery.quPreparePrim(prepare : boolean);
+var
+ SQLResult : TffResult;
+ Msg : string;
+ MsgLen : integer;
+ Stream : TMemoryStream;
+begin
+ { Requirement: Query must be closed. }
+ if dsCursorID > 0 then
+ RaiseFFErrorObj(Self, ffdse_QueryMustBeClosed);
+
+ if (FPrepared <> prepare) then begin
+
+ FExecuted := False;
+
+// { Requirement: Must have a database. } {Moved !!.03}
+// dsEnsureDatabaseOpen(True); {Moved !!.03}
+
+ { Are we preparing? }
+ if prepare then begin
+ { Yes. Requirement: Must have a database. } {!!.03}
+ dsEnsureDatabaseOpen(True); {!!.03}
+ FRowsAffected := -1; {!!.10}
+ FCanModify := False; {!!.10}
+ FRecordsRead := 0; {!!.10}
+
+ { If we have a SQL statement then allocate & prepare a SQL
+ statement on the engine. }
+ if (length(FText) > 0) then begin
+ Check(ServerEngine.SQLAlloc(dsProxy.Database.Session.Client.ClientID,
+ dsProxy.Database.DatabaseID, dsGetTimeout,
+ FStmtID));
+ Stream := TMemoryStream.Create;
+ try
+ try
+ SQLResult := ServerEngine.SQLPrepare(FStmtID, pointer(FText),
+ Stream);
+ if SQLResult <> DBIERR_NONE then begin
+ Stream.Position := 0;
+ Stream.Read(MsgLen, sizeOf(MsgLen));
+ if MsgLen > 0 then begin
+ SetLength(Msg, MsgLen);
+ Stream.Read(Msg[1], MsgLen);
+ RaiseFFErrorObjFmt(Self, ffdse_QueryPrepareFail, [#13#10, Msg]);
+ end
+ else
+ Check(SQLResult);
+ end;
+ except
+ quFreeStmt;
+ raise;
+ end;
+ finally
+ Stream.Free;
+ end;
+ end
+ else
+ { No SQL statement. Raise an exception. }
+ RaiseFFErrorObj(Self, ffdse_EmptySQLStatement);
+ end
+ else
+ { No. Free the statement. }
+ quFreeStmt;
+ FPrepared := prepare;
+ end;
+end;
+{$IFDEF DCC4OrLater}
+{--------}
+procedure TffQuery.quReadParams(Reader : TReader);
+begin
+ Reader.ReadValue;
+ Reader.ReadCollection(FParams);
+end;
+{$ENDIF}
+{--------}
+procedure TffQuery.quRefreshParams;
+var
+ DataSet: TDataSet;
+begin
+ DisableControls;
+ try
+ if assigned(FDataLink.DataSource) then begin
+ DataSet := FDataLink.DataSource.DataSet;
+ if assigned(DataSet) then
+ if DataSet.Active and (DataSet.State <> dsSetKey) then begin
+ Close;
+ Open;
+ end;
+ end;
+ finally
+ EnableControls;
+ end;
+end;
+{--------}
+procedure TffQuery.quSetDataSource(aSrc : TDataSource);
+begin
+ { If we have a circular link then raise an exception. }
+ if IsLinkedTo(aSrc) then
+ RaiseFFErrorObjFmt(Self, ffdse_TblCircDataLink, [aSrc.Name]);
+ FDataLink.DataSource := aSrc;
+end;
+{--------}
+procedure TffQuery.quSetParams(aParamList : TParams);
+begin
+ FParams.AssignValues(aParamList);
+end;
+{--------}
+procedure TffQuery.quSetParamsFromCursor;
+var
+ I: Integer;
+ DataSet: TDataSet;
+begin
+ if assigned(FDataLink.DataSource) then begin
+ DataSet := FDataLink.DataSource.DataSet;
+ if assigned(DataSet) then begin
+ DataSet.FieldDefs.Update;
+ for I := 0 to Pred(FParams.Count) do
+ with FParams[I] do
+ { Has this parameter been bound? }
+ if not Bound then begin
+ { No. Get a value from the dataset. }
+ AssignField(DataSet.FieldByName(Name));
+ Bound := False;
+ end;
+ end;
+ end;
+end;
+{--------}
+procedure TffQuery.quSetPrepared(aFlag : boolean);
+begin
+ if aFlag then
+ Prepare
+ else
+ Unprepare;
+end;
+{--------}
+procedure TffQuery.quSetRequestLive(aFlag : boolean);
+begin
+ if aFlag then Exit; {!!.11}
+(* if FRequestLive <> aFlag then begin {!!.11}
+ FRequestLive := aFlag;
+ dsReadOnly := (not aFlag);
+ end;*)
+end;
+{--------}
+procedure TffQuery.quSetSQL(aValue : TStrings);
+begin
+ if FSQL.Text <> aValue.Text then begin
+ quDisconnect;
+ FSQL.BeginUpdate;
+ try
+ FSQL.Assign(aValue);
+ finally
+ FSQL.EndUpdate;
+ end;
+ end;
+end;
+{--------}
+procedure TffQuery.quSQLChanged(Sender : TObject);
+var
+ aList : TParams;
+begin
+{Begin !!.02}
+ {$IFNDEF DCC4OrLater}
+ aList := nil;
+ {$ENDIF}
+{End !!.02}
+ { Is the component loading? }
+ if not (csReading in ComponentState) then begin
+ { No. Disconnect from the server. }
+ quDisconnect;
+ { Are we supposed to regenerate the parameters or are we in the IDE? }
+ if FParamCheck or (csDesigning in ComponentState) then begin
+ { Yes. Rebuild the parameters. }
+ {$IFDEF DCC4OrLater}
+ aList := TParams.Create(Self);
+ {$ELSE}
+ aList := TParams.Create;
+ {$ENDIF}
+ try
+ FText := quParseSQL(FSQL.Text, True, aList);
+ aList.AssignValues(FParams);
+ FParams.Clear;
+ FParams.Assign(aList);
+ finally
+ aList.Free;
+ end;
+ end else
+ FText := FSQL.Text;
+ DataEvent(dePropertyChange, 0);
+ end
+ else
+ { Yes. Parse the text, replacing parameters with question marks. }
+{Begin !!.02}
+ {$IFDEF DCC4OrLater}
+ FText := quParseSQL(FSQL.Text, False, nil);
+ {$ELSE}
+ begin {!!.03}
+ aList := TParams.Create;
+ try
+ FText := quParseSQL(FSQL.Text, True, aList);
+ aList.AssignValues(FParams);
+ FParams.Clear;
+ FParams.Assign(aList);
+ finally
+ aList.Free;
+ end;
+ end; {!!.03}
+ {$ENDIF}
+end;
+{$IFDEF DCC4OrLater}
+{--------}
+procedure TffQuery.quWriteParams(Writer : TWriter);
+begin
+ Writer.WriteCollection(FParams);
+end;
+{$ENDIF}
+{--------}
+procedure TffQuery.Unprepare;
+begin
+ quPreparePrim(False);
+end;
+{====================================================================}
+
+{===Initialization routine===========================================}
+procedure InitializeUnit;
+var
+ Sess : TffSession;
+ CL : TffClient;
+begin
+ {create the Clients list}
+ Clients := TffClientList.Create;
+
+ {create the default comms engine}
+ CL := TffClient.Create(nil);
+ CL.ClientName := AutoObjName;
+ CL.IsDefault := True;
+
+ {create the default session in the default comms engine}
+ Sess := TffSession.Create(nil);
+ Sess.SessionName := AutoObjName;
+ Sess.IsDefault := True;
+end;
+{====================================================================}
+
+
+{===Finalization routine=============================================}
+procedure FinalizeUnit;
+var
+ Sess : TffSession;
+ CL : TffBaseClient;
+begin
+ Sess := FindDefaultffSession;
+ CL := FindDefaultFFClient;
+ Sess.Free;
+ CL.Free;
+ Clients.Free;
+ Clients := nil;
+ {$IFDEF SingleExe}
+ if Assigned(ServerEngine) then begin
+ ServerEngine.Free;
+ ServerEngine := nil;
+ end;
+ {$ENDIF}
+end;
+{====================================================================}
+
+
+initialization
+ InitializeUnit;
+{--------}
+finalization
+ FinalizeUnit;
+{--------}
+end.
+
+
diff --git a/components/flashfiler/sourcelaz/ffdbbase.pas b/components/flashfiler/sourcelaz/ffdbbase.pas
new file mode 100644
index 000000000..ee69704b8
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffdbbase.pas
@@ -0,0 +1,1151 @@
+{*********************************************************}
+{* FlashFiler: Support classes for FFDB *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffdbbase;
+
+interface
+
+uses
+ classes,
+ db,
+ ffclbase, {!!.06}
+ ffsrbde,
+ ffllbase,
+ ffsrmgr;
+
+{$I ffdscnst.inc}
+
+var
+ ffStrResDataSet : TffStringResource;
+
+type
+ EffDatabaseError = class(EDatabaseError)
+ protected {private}
+ deErrorCode : TffResult;
+ protected
+ function deGetErrorString : string;
+ public
+ constructor Create(const aMsg : string);
+ constructor CreateViaCode(aErrorCode : TffResult; aDummy : Boolean);
+ constructor CreateViaCodeFmt(const aErrorCode : TffResult; {!!.06}
+ const args : array of const; {!!.06}
+ const aDummy : Boolean); {!!.06}
+ constructor CreateWithObj(aObj : TComponent;
+ const aErrorCode : TffResult;
+ const aMsg : string);
+ constructor CreateWithObjFmt(aObj : TComponent; const aErrorCode : TffResult;
+ const args : array of const); {!!.11}
+ property ErrorCode : TffResult read deErrorCode;
+ property ErrorString : string read deGetErrorString;
+ end;
+
+type
+ TffDBListItem = class;
+ TffDBList = class;
+
+ TffDBListItem = class(TffComponent)
+ protected {private}
+ dbliActive : Boolean;
+ dbliDBName : string;
+ dbliDBOwner : TffDBListItem;
+ dbliDBOwnerName : string;
+ dbliFailedActive : Boolean;
+ dbliFixing : Boolean;
+ dbliLoading : Boolean;
+ dbliMakeActive : Boolean;
+ dbliOwnedDBItems : TffDBList;
+ dbliReqPropName : string;
+ dbliTemporary : Boolean; {!!.01}
+ { The actual name of the required property corresponding to DBName. }
+ protected
+ dbliLoadPriority : Integer; {*not* private, descendants set it}
+ dbliNeedsNoOwner : Boolean; {*not* private, descendants set it}
+
+ function dbliGetDBOwner : TffDBListItem;
+ function dbliGetDBOwnerName : string;
+ function dbliGetOwned : Boolean;
+ procedure dbliSetActive(const aValue : Boolean);
+ procedure dbliSetDBName(const aName : string);
+ procedure dbliSetDBOwner(const aDBOwner : TffDBListItem);
+ procedure dbliSetDBOwnerName(const aName : string);
+
+ procedure dbliClosePrim; virtual;
+ function dbliCreateOwnedList : TffDBList; virtual;
+ procedure dbliDBItemAdded(aItem : TffDBListItem); virtual;
+ procedure dbliDBItemDeleted(aItem : TffDBListItem); virtual;
+ procedure dbliNotifyDBOwnerChanged; virtual;
+ procedure dbliDBOwnerChanged; virtual;
+ function dbliFindDBOwner(const aName : string) : TffDBListItem; virtual;
+ procedure dbliFreeTemporaryDependents; {!!.01}
+ procedure dbliLoaded; virtual;
+ procedure dbliMustBeClosedError; virtual;
+ procedure dbliMustBeOpenError; virtual;
+ procedure dbliOpenPrim; virtual;
+ function dbliResolveDBOwner(const aName : string) : TffDBListItem;
+ procedure dbliSwitchOwnerTo(const aDBOwner : TffDBListItem);
+
+ property Active : Boolean
+ read dbliActive
+ write dbliSetActive
+ default False;
+ property Connected : Boolean
+ read dbliActive
+ write dbliSetActive
+ default False;
+ property DBName : string
+ read dbliDBName
+ write dbliSetDBName;
+ property DBOwner : TffDBListItem
+ read dbliGetDBOwner
+ write dbliSetDBOwner;
+ property DBOwnerName : string
+ read dbliGetDBOwnerName
+ write dbliSetDBOwnerName;
+ property FixingFromStream : Boolean
+ read dbliFixing
+ write dbliFixing;
+ property LoadPriority : Integer
+ read dbliLoadPriority;
+ property LoadingFromStream : Boolean
+ read dbliLoading
+ write dbliLoading;
+ property NeedsNoOwner : Boolean
+ read dbliNeedsNoOwner;
+ property OwnedDBItems : TffDBList
+ read dbliOwnedDBItems;
+ property Temporary : Boolean {!!.01}
+ read dbliTemporary write dbliTemporary; {!!.01}
+ public
+ constructor Create(aOwner: TComponent); override;
+ destructor Destroy; override;
+
+ procedure Loaded; override;
+
+ procedure Open;
+ procedure CheckActive;
+ procedure CheckInactive(const aCanClose : Boolean);
+ procedure Close;
+ procedure FFNotificationEx(const AOp : Byte; AFrom : TffComponent;
+ const AData : TffWord32); override;
+ procedure ForceClosed;
+
+ property IsOwned : Boolean
+ read dbliGetOwned;
+ property LoadActiveFailed : Boolean
+ read dbliFailedActive;
+ end;
+
+ { All list management was moved to TffComponent after documentation was
+ released to the printers. This class does not store items anymore,
+ instead it's methods reference the dependent list in TffComponent. This
+ required the addition of a owner field. Owner references the item
+ controlling a collection of other items. For instance, if the list
+ belonged to a TffBaseClient, then this class would control TffSession
+ components.}
+ TffDBList = class(TffObject)
+ protected {private}
+ dblOwner : TffDBListItem; {controller of this list}
+ protected
+ function dblGetCount : Integer;
+ function dblGetItem(aInx : Integer) : TffDBListItem;
+ procedure dblFreeItem(aItem : TffDBListItem); virtual;
+ procedure dblFreeUnownedItems;
+ public
+ constructor Create(aOwner : TffDBListItem);
+ destructor Destroy; override;
+
+ function FindItem(const aName : string; var aItem : TffDBListItem) : Boolean;
+ procedure GetItem(const aName : string; var aItem : TffDBListItem);
+ procedure GetItemNames(aList : TStrings);
+ function IndexOfItem(aItem : TffDBListItem) : Integer;
+
+ property Count : Integer
+ read dblGetCount;
+ property Items[aInx : Integer] : TffDBListItem
+ read dblGetItem; default;
+ end;
+
+ TffDBStandaloneList = class
+ protected {private}
+ dblList : TffThreadList;
+ protected
+ function dblGetCount : integer;
+ function dblGetItem(aInx : integer) : TffDBListItem;
+
+ procedure dblCloseAllItems;
+ procedure dblFreeItem(aItem : TffDBListItem); virtual;
+ procedure dblFreeUnownedItems;
+ public
+ constructor Create;
+ destructor Destroy; override;
+
+ procedure AddItem(aItem : TffDBListItem);
+ procedure DeleteItem(aItem : TffDBListItem);
+ function FindItem(const aName : string; var aItem : TffDBListItem) : boolean;
+ procedure GetItem(const aName : string; var aItem : TffDBListItem);
+ procedure GetItemNames(aList : TStrings);
+ function IndexOfItem(aItem : TffDBListItem) : integer;
+
+ procedure BeginRead; {!!.02}
+ procedure BeginWrite; {!!.02}
+ procedure EndRead; {!!.02}
+ procedure EndWrite; {!!.02}
+
+ property Count : integer read dblGetCount;
+ property Items[aInx : integer] : TffDBListItem read dblGetItem; default;
+ end;
+
+
+{---Helper routines---}
+procedure Check(const aStatus : TffResult);
+procedure RaiseFFErrorCode(const aErrorCode : TffResult);
+procedure RaiseFFErrorMsg(const aMsg : string);
+procedure RaiseFFErrorObj(aObj : TComponent; const aErrorCode : TffResult);
+procedure RaiseFFErrorObjFmt(aObj : TComponent; const aErrorCode : TffResult;
+ args: array of const);
+function IsPath(const Value : string) : Boolean;
+
+{---Internal helper routines---}
+procedure AddToFixupList(aItem : TffDBListItem);
+procedure ApplyFixupList;
+
+implementation
+
+{$R ffdscnst.res}
+
+uses
+ dialogs,
+ sysutils,
+ forms,
+ ffconst,
+ ffllexcp,
+ ffnetmsg; {!!.06}
+
+{===Fixup list helper code===========================================}
+{Notes: this fixup list is to ensure that components that depend on
+ others being fully loaded from the DFM file first, are
+ completely initialized only after the components they depend
+ on are initialized.
+ The properties whose values are deferred at load time are the
+ DBOwner name and the Active properties. For example, a
+ database component which has a session name for a session
+ component that hasn't been completely loaded yet cannot itself
+ be loaded properly.
+ The fixup list ensures that components with a high load
+ priority (1) are fully loaded before those with a lower load
+ priority (4).}
+var
+ DBItemFixupList : TList;
+
+{--------}
+procedure CreateFixupList;
+begin
+ DBItemFixupList := TList.Create;
+end;
+{--------}
+procedure DestroyFixupList;
+begin
+ if (DBItemFixupList <> nil) then begin
+ DBItemFixupList.Destroy;
+ DBItemFixupList := nil;
+ end;
+end;
+{--------}
+procedure AddToFixupList(aItem : TffDBListItem);
+begin
+ if (DBItemFixupList = nil) then
+ CreateFixupList;
+ if (DBItemFixupList.IndexOf(aItem) = -1) then
+ DBItemFixupList.Add(aItem);
+end;
+{--------}
+procedure ApplyFixupList;
+var
+ LoadPty : Integer;
+ Inx : Integer;
+ Item : TffDBListItem;
+begin
+ if (DBItemFixupList <> nil) then begin
+ for LoadPty := 1 to 4 do begin
+ for Inx := pred(DBItemFixupList.Count) downto 0 do begin
+ Item := TffDBListItem(DBItemFixupList[Inx]);
+ if (Item.LoadPriority = LoadPty) then begin
+ Item.LoadingFromStream := false;
+ Item.FixingFromStream := true;
+ Item.dbliLoaded;
+ Item.FixingFromStream := false;
+ DBItemFixupList.Delete(Inx);
+ end;
+ end;
+ end;
+ if (DBItemFixupList.Count = 0) then
+ DestroyFixupList;
+ end;
+end;
+{====================================================================}
+
+
+{===Interfaced helper routines=======================================}
+procedure Check(const aStatus : TffResult);
+begin
+ if aStatus <> 0 then
+ RaiseFFErrorCode(aStatus);
+end;
+{--------}
+procedure RaiseFFErrorCode(const aErrorCode : TffResult);
+begin
+ raise EffDatabaseError.CreateViaCode(aErrorCode, False);
+end;
+{--------}
+procedure RaiseFFErrorMsg(const aMsg : string);
+begin
+ raise EffDatabaseError.Create(aMsg);
+end;
+{--------}
+procedure RaiseFFErrorObj(aObj : TComponent; const aErrorCode : TffResult);
+begin
+ raise EffDatabaseError.CreateWithObj(aObj, aErrorCode,
+ ffStrResDataSet[aErrorCode]);
+end;
+{--------}
+procedure RaiseFFErrorObjFmt(aObj : TComponent; const aErrorCode : TffResult;
+ args: array of const);
+begin
+ raise EffDatabaseError.CreateWithObjFmt(aObj, aErrorCode, args);
+end;
+{--------}
+function IsPath(const Value : string) : Boolean;
+begin
+ Result := (Pos(':', Value) <> 0 ) or
+ (Pos('\', Value) <> 0 ) or {!!.05}
+ (Value = '.') or {!!.05}
+ (Value = '..'); {!!.05}
+end;
+{====================================================================}
+
+
+{===EffDatabaseError=================================================}
+constructor EffDatabaseError.Create(const aMsg : string);
+begin
+ deErrorCode := 0;
+ inherited CreateFmt(ffStrResDataSet[ffdse_NoErrorCode], [aMsg]);
+end;
+{--------}
+constructor EffDatabaseError.CreateViaCode(aErrorCode : TffResult; aDummy : Boolean);
+var
+ Msg : string;
+begin
+ deErrorCode := aErrorCode;
+ Msg := deGetErrorString;
+ inherited CreateFmt(ffStrResDataSet[ffdse_HasErrorCode], [Msg, aErrorCode, aErrorCode]);
+end;
+{Begin !!.06}
+{--------}
+constructor EffDatabaseError.CreateViaCodeFmt(const aErrorCode : TffResult;
+ const args : array of const;
+ const aDummy : boolean);
+var
+ Msg : string;
+begin
+ deErrorCode := aErrorCode;
+ Msg := deGetErrorString;
+ inherited Create(Format(Msg, args));
+end;
+{End !!.06}
+{--------}
+constructor EffDatabaseError.CreateWithObj(aObj : TComponent;
+ const aErrorCode : TffResult;
+ const aMsg : string);
+var
+ ObjName : string;
+begin
+ deErrorCode := aErrorCode;
+ if (aObj = nil) then
+ ObjName := ffStrResDataSet[ffdse_NilPointer]
+ else begin
+ ObjName := aObj.Name;
+ if (ObjName = '') then
+ ObjName := Format(ffStrResDataSet[ffdse_UnnamedInst], [aObj.ClassName]);
+ end;
+ inherited CreateFmt(ffStrResDataSet[ffdse_InstNoCode], [ObjName, aMsg]);
+end;
+{--------}
+constructor EffDatabaseError.CreateWithObjFmt(aObj : TComponent;
+ const aErrorCode : TffResult;
+ const args : array of const); {!!.11}
+var
+ Msg : string;
+ ObjName : string;
+begin
+ deErrorCode := aErrorCode;
+ Msg := format(deGetErrorString, args);
+
+ if (aObj = nil) then
+ ObjName := ffStrResDataSet[ffdse_NilPointer]
+ else begin
+ ObjName := aObj.Name;
+ if (ObjName = '') then
+ ObjName := Format(ffStrResDataSet[ffdse_UnnamedInst], [aObj.ClassName]);
+ end;
+
+ inherited CreateFmt(ffStrResDataSet[ffdse_InstCode],
+ [ObjName, Msg, aErrorCode, aErrorCode]);
+end;
+{--------}
+function EffDatabaseError.deGetErrorString : string;
+var
+ PC : array [0..127] of char;
+begin
+ if (deErrorCode >= ffDSCNSTLow) and (deErrorCode <= ffDSCNSTHigh) then
+ ffStrResDataSet.GetASCIIZ(deErrorCode, PC, sizeOf(DBIMSG))
+ else if (deErrorCode >= ffLLCNSTLow) and (deErrorCode <= ffLLCNSTHigh) then
+ ffStrResGeneral.GetASCIIZ(deErrorCode, PC, sizeOf(DBIMSG))
+ else if (deErrorCode >= ffCLCNSTLow) and (deErrorCode <= ffCLCNSTHigh) then {!!.06}
+ ffStrResClient.GetASCIIZ(deErrorCode, PC, SizeOf(DBIMSG)) {!!.06}
+ else
+ GetErrorStringPrim(deErrorCode, PC);
+ Result := StrPas(PC);
+end;
+{====================================================================}
+
+
+{===TffDBList========================================================}
+constructor TffDBList.Create(aOwner : TffDBListItem);
+begin
+ dblOwner := aOwner;
+end;
+{--------}
+destructor TffDBList.Destroy;
+begin
+ dblOwner.FFNotifyDependents(ffn_Destroy);
+
+ dblOwner := nil;
+
+ inherited Destroy;
+end;
+{--------}
+procedure TffDBList.dblFreeItem(aItem : TffDBListItem);
+begin
+ aItem.Free;
+end;
+{--------}
+procedure TffDBList.dblFreeUnownedItems;
+var
+ Idx : Integer;
+begin
+ if Assigned(dblOwner.fcDependentList) then
+{Begin !!.11}
+ with dblOwner do begin
+ fcLock.Lock;
+ try
+ for Idx := Pred(fcDependentList.Count) downto 0 do
+ if TObject(fcDependentList[Idx]) is TffDBListItem then
+ with TffDBListItem(fcDependentList[Idx]) do
+ if IsOwned then
+ DBOwnerName := ''
+ else
+ dblFreeItem(TffDBListItem(fcDependentList[Idx]));
+ finally
+ fcLock.Unlock;
+ end;
+ end; { with }
+{End !!.11}
+end;
+{--------}
+function TffDBList.dblGetCount : Integer;
+begin
+ with dblOwner do
+{Begin !!.11}
+ if Assigned(fcDependentList) then begin
+ fcLock.Lock;
+ try
+ Result := fcDependentList.Count;
+ finally
+ fcLock.Unlock;
+ end;
+ end
+{End !!.11}
+ else
+ Result := 0;
+end;
+{--------}
+function TffDBList.dblGetItem(aInx : Integer): TffDBListItem;
+begin
+ Assert(aInx > -1);
+ Assert(aInx < Count, Format('%d not < %d', [aInx, Count]));
+ with dblOwner do
+{Begin !!.11}
+ if Assigned(fcDependentList) then begin
+ fcLock.Lock;
+ try
+ Result := TffDBListItem(fcDependentList.Items[aInx].Key^);
+ finally
+ fcLock.Unlock;
+ end;
+ end
+{End !!.11}
+ else
+ Result := nil;
+end;
+{--------}
+function TffDBList.FindItem(const aName: string; var aItem: TffDBListItem): Boolean;
+var
+ Inx : Integer;
+ DBItem : TffDBListItem;
+begin
+ aItem := nil;
+ Result := False;
+ if aName <> '' then
+ with dblOwner do
+{Begin !!.11}
+ if Assigned(fcDependentList) then begin
+ fcLock.Lock;
+ try
+ with fcDependentList do
+ for Inx := Pred(Count) downto 0 do begin
+ DBItem := TffDBListItem(Items[Inx].Key^);
+ if (FFAnsiCompareText(DBItem.DBName, aName) = 0) then begin {!!.07}
+ aItem := DBItem;
+ Result := true;
+ Exit;
+ end;
+ end;
+ finally
+ fcLock.Unlock;
+ end;
+ end
+{End !!.11}
+ else
+ Result := False;
+end;
+{--------}
+procedure TffDBList.GetItem(const aName: string; var aItem: TffDBListItem);
+begin
+ if aName = '' then
+ aItem := nil
+ else
+ if not FindItem(aName, aItem) then
+ RaiseFFErrorMsg(ffStrResDataSet[ffdse_MissingItem]);
+end;
+{--------}
+procedure TffDBList.GetItemNames(aList : TStrings);
+var
+ Inx : Integer;
+ Item : TffDBListItem;
+begin
+ Assert(Assigned(aList));
+ with dblOwner do
+{Begin !!.11}
+ if Assigned(fcDependentList) then begin
+ fcLock.Lock;
+ try
+ with fcDependentList do begin
+ aList.BeginUpdate;
+ try
+ for Inx := Pred(Count) downto 0 do begin
+ Item := TffDBListItem(Items[Inx].Key^);
+ if (Item.DBName <> '') then
+ aList.Add(Item.DBName);
+ end;
+ finally
+ aList.EndUpdate;
+ end;
+ end;
+ finally
+ fcLock.Unlock;
+ end;
+ end;
+{End !!.11}
+end;
+{--------}
+function TffDBList.IndexOfItem(aItem : TffDBListItem) : Integer;
+begin
+ with dblOwner do
+{Begin !!.11}
+ if Assigned(fcDependentList) then begin
+ fcLock.Lock;
+ try
+ Result := IndexofItem(@aItem);
+ finally
+ fcLock.Unlock;
+ end;
+ end
+{End !!.11}
+ else
+ Result := -1;
+end;
+{====================================================================}
+
+
+{===TffDBListItem====================================================}
+constructor TffDBListItem.Create(aOwner: TComponent);
+begin
+ inherited Create(aOwner);
+ dbliOwnedDBItems := dbliCreateOwnedList;
+end;
+{--------}
+destructor TffDBListItem.Destroy;
+begin
+ FFNotifyDependents(ffn_Destroy);
+
+ dbliSwitchOwnerTo(nil);
+
+ dbliOwnedDBItems.Free;
+ dbliOwnedDBItems := nil;
+
+ inherited Destroy;
+end;
+{--------}
+procedure TffDBListItem.CheckActive;
+begin
+ if not Active then
+ dbliMustBeOpenError;
+end;
+{--------}
+procedure TffDBListItem.CheckInactive(const aCanClose : Boolean);
+
+begin
+ if Active then
+ if aCanClose then
+ Close
+ else
+ dbliMustBeClosedError;
+end;
+{--------}
+procedure TffDBListItem.Close;
+begin
+ Active := False;
+end;
+{--------}
+procedure TffDBListItem.FFNotificationEx(const AOp : Byte; AFrom : TffComponent;
+ const AData : TffWord32);
+begin
+ if (dbliDBOwner = AFrom) then
+ case AOp of
+ ffn_Destroy,
+ ffn_Remove :
+ begin
+ Close;
+ dbliDBOwner := nil;
+ end;
+ ffn_Deactivate :
+ begin
+ Close;
+ end;
+ ffn_OwnerChanged :
+ begin
+ dbliDBOwnerChanged;
+ DBOwnerName := TffDBListItem(AFrom).dbliDBName;
+ end;
+ end;
+end;
+{--------}
+procedure TffDBListItem.dbliClosePrim;
+begin
+ FFNotifyDependents(ffn_Deactivate);
+end;
+{--------}
+function TffDBListItem.dbliCreateOwnedList : TffDBList;
+begin
+ Result := TffDBList.Create(Self);
+end;
+{--------}
+procedure TffDBListItem.dbliDBItemAdded(aItem : TffDBListItem);
+begin
+ {do nothing}
+end;
+{--------}
+procedure TffDBListItem.dbliDBItemDeleted(aItem : TffDBListItem);
+begin
+ {do nothing}
+end;
+{--------}
+procedure TffDBListItem.dbliNotifyDBOwnerChanged;
+begin
+ FFNotifyDependents(ffn_OwnerChanged);
+end;
+{--------}
+procedure TffDBListItem.dbliDBOwnerChanged;
+begin
+ { do nothing }
+end;
+{--------}
+function TffDBListItem.dbliFindDBOwner(const aName : string) : TffDBListItem;
+begin
+ {at this level we have no hope of identifying a DB owner}
+ Result := nil;
+end;
+{Begin !!.01}
+{--------}
+procedure TffDBListItem.dbliFreeTemporaryDependents;
+var
+ aComp : TffDBListItem;
+ aList : TffPointerList;
+ Idx,Idx2 : Integer; {!!.02}
+begin
+ { Note: Removal of items from dependency list must be separated from
+ deactivation of those items otherwise we get a list deadlock. }
+ if Assigned(fcDependentList) then begin
+
+ aList := nil;
+
+ { Stage 1: Look for temporary items. }
+{Begin !!.11}
+ fcLock.Lock;
+ try
+ for Idx := Pred(fcDependentList.Count) downto 0 do begin
+ aComp := TffDBListItem(TffIntListItem(fcDependentList[Idx]).KeyAsInt);
+ if aComp.Temporary then begin
+ if aList = nil then
+ aList := TffPointerList.Create;
+ aList.Append(pointer(Idx));
+ end;
+ end; { for }
+ finally
+ fcLock.Unlock;
+ end;
+{End !!.11}
+
+ { Stage 2: Tell the temporary items to close. Must do this without locking
+ the dependency list otherwise we get a deadlock. }
+ if aList <> nil then begin
+ for Idx := 0 to pred(aList.Count) do begin
+ Idx2 := Longint(aList[Idx]); {!!.02}
+ aComp := TffDBListItem(TffIntListItem(fcDependentList[Idx2]).KeyAsInt); {!!.02}
+ aComp.Active := False;
+ end;
+
+ { Stage 3: Remove the temporary items from the dependency list. }
+{Begin !!.11}
+ fcLock.Lock;
+ try
+ for Idx := 0 to pred(aList.Count) do begin
+ Idx2 := Longint(aList[Idx]); {!!.02}
+ aComp := TffDBListItem(TffIntListItem(fcDependentList[Idx2]).KeyAsInt); {!!.02}
+ fcDependentList.DeleteAt(Idx2); {!!.02}
+ aComp.Free;
+ end;
+ finally
+ fcLock.Unlock;
+ end;
+{End !!.11}
+ aList.Free;
+ end; { if aList <> nil }
+ end;
+
+end;
+{End !!.01}
+{--------}
+function TffDBListItem.dbliGetDBOwner : TffDBListItem;
+begin
+ if (dbliDBOwner = nil) then
+ DBOwner := dbliFindDBOwner(dbliDBOwnerName);
+ Result := dbliDBOwner;
+end;
+{--------}
+function TffDBListItem.dbliGetDBOwnerName : string;
+begin
+ if (dbliDBOwner <> nil) then begin
+ dbliDBOwnerName := dbliDBOwner.DBName;
+ Result := dbliDBOwnerName;
+ end else begin
+ DBOwner := dbliFindDBOwner(dbliDBOwnerName);
+ if (dbliDBOwner = nil) then
+ Result := dbliDBOwnerName
+ else {DB owner exists} begin
+ dbliDBOwnerName := dbliDBOwner.DBName;
+ Result := dbliDBOwnerName;
+ end;
+ end;
+end;
+{--------}
+function TffDBListItem.dbliGetOwned : Boolean;
+begin
+ Result := Assigned(Owner);
+end;
+{--------}
+procedure TffDBListItem.dbliLoaded;
+begin
+ try
+ if dbliMakeActive then begin
+ {if we need a DB owner, resolve our DB owner name to an object}
+ if not NeedsNoOwner then
+ DBOwner := dbliResolveDBOwner(dbliDBOwnerName);
+ {if we don't need a DB owner or our DB owner has managed to
+ become active, make ourselves active}
+ if NeedsNoOwner or not (DBOwner.LoadActiveFailed) then begin
+ dbliFailedActive := true;
+ Active := true;
+ dbliMakeActive := false;
+ dbliFailedActive := false;
+ end;
+ end else
+ if (dbliDBOwnerName <> '') then
+ dbliGetDBOwner;
+ except
+ if (csDesigning in ComponentState) then
+ Application.HandleException(Self)
+ else
+ raise;
+ end;{try..except}
+end;
+{--------}
+procedure TffDBListItem.dbliMustBeClosedError;
+begin
+ RaiseFFErrorObj(Self, ffdse_MustBeClosed);
+end;
+{--------}
+procedure TffDBListItem.dbliMustBeOpenError;
+begin
+ RaiseFFErrorObj(Self, ffdse_MustBeOpen);
+end;
+{--------}
+procedure TffDBListItem.dbliOpenPrim;
+begin
+ {do nothing at this level}
+end;
+{--------}
+function TffDBListItem.dbliResolveDBOwner(const aName : string) : TffDBListItem;
+begin
+ Result := dbliFindDBOwner(aName);
+ if (Result = nil) then
+ if not NeedsNoOwner then
+ RaiseFFErrorObjFmt(Self, ffdse_MissingOwner, [Self.ClassName, Self.DBName]);
+end;
+{--------}
+procedure TffDBListItem.dbliSetActive(const aValue: Boolean);
+begin
+ if aValue <> dbliActive then
+ if (csReading in ComponentState) or LoadingFromStream then begin
+ if aValue then
+ dbliMakeActive := true;
+ AddToFixupList(Self);
+ end else begin
+ {if we're making ourselves active...}
+ if aValue then begin
+ {if we haven't actually become active yet...}
+ if not dbliActive then begin
+ {we need a name}
+ if (DBName = '') then
+ RaiseFFErrorObjFmt(Self, ffdse_NeedsName, [dbliReqPropName]);
+ {if we need a DB owner...}
+ if not NeedsNoOwner then begin
+ {make sure we have a DB owner name}
+ if (DBOwnerName = '') then
+ RaiseFFErrorObj(Self, ffdse_NeedsOwnerName);
+ {make sure we have a DB owner object}
+ if (dbliDBOwner = nil) then
+ DBOwner := dbliResolveDBOwner(dbliDBOwnerName);
+ {make sure our DB owner is open}
+ if not DBOwner.Active then
+ DBOwner.Active := true;
+ end;
+ {now we open ourselves}
+ dbliOpenPrim;
+ end;
+ dbliActive := True;
+ end else {closing} begin
+ dbliClosePrim;
+ dbliActive := False;
+ end;
+ end;
+end;
+{--------}
+procedure TffDBListItem.dbliSetDBName(const aName: string);
+begin
+ CheckInactive(True);
+ dbliDBName := aName;
+end;
+{--------}
+procedure TffDBListItem.dbliSetDBOwner(const aDBOwner : TffDBListItem);
+begin
+ if (aDBOwner = nil) and (dbliDBOwner = nil) then
+ Exit;
+ CheckInactive(True);
+ dbliSwitchOwnerTo(aDBOwner);
+ dbliNotifyDBOwnerChanged;
+end;
+{--------}
+procedure TffDBListItem.dbliSetDBOwnerName(const aName: string);
+begin
+ if (csReading in ComponentState) or LoadingFromStream then begin
+ dbliDBOwnerName := aName;
+ AddToFixupList(Self);
+ end else
+ if (FFAnsiCompareText(dbliDBOwnerName, aName) <> 0) then begin {!!.07}
+ CheckInactive(true);
+ {set our DB owner to nil}
+ dbliSwitchOwnerTo(nil);
+ {save our new DB owner name}
+ dbliDBOwnerName := aName;
+ dbliNotifyDBOwnerChanged;
+ end;
+end;
+{--------}
+procedure TffDBListItem.dbliSwitchOwnerTo(const aDBOwner : TffDBListItem);
+begin
+ if (dbliDBOwner <> nil) then begin
+ dbliDBOwner.FFRemoveDependent(Self);
+ end;
+ dbliDBOwner := aDBOwner;
+ if (dbliDBOwner = nil) then
+ dbliDBOwnerName := ''
+ else begin
+ dbliDBOwner.FFAddDependent(Self);
+ dbliDBOwnerName := dbliDBOwner.DBName;
+ end;
+end;
+{--------}
+procedure TffDBListItem.ForceClosed;
+begin
+ Close;
+end;
+{--------}
+procedure TffDBListItem.Loaded;
+begin
+ inherited Loaded;
+ ApplyFixupList;
+ LoadingFromStream := False;
+end;
+{--------}
+procedure TffDBListItem.Open;
+begin
+ Active := True;
+end;
+{====================================================================}
+
+
+{===TffDBStandaloneList========================================================}
+constructor TffDBStandaloneList.Create;
+begin
+ inherited Create;
+ dblList := TffThreadList.Create;
+end;
+{--------}
+destructor TffDBStandaloneList.Destroy;
+begin
+ if Assigned(dblList) then
+ with dblList.BeginWrite do
+ try
+ dblCloseAllItems;
+ finally
+ EndWrite;
+ end;
+
+ dblList.Free;
+ dblList := nil;
+
+ inherited Destroy;
+end;
+{--------}
+procedure TffDBStandaloneList.AddItem(aItem: TffDBListItem);
+begin
+ Assert(Assigned(dblList));
+ with dblList.BeginWrite do
+ try
+ Insert(TffIntListItem.Create(Longint(aItem)));
+ finally
+ EndWrite;
+ end;
+end;
+{--------}
+procedure TffDBStandaloneList.dblCloseAllItems;
+var
+ Inx : integer;
+ Item : TffDBListItem;
+begin
+ for Inx := pred(dblList.Count) downto 0 do begin
+ Item := Items[Inx];
+ {note: item opens are reference counted, so we need to force the
+ item closed}
+ Item.Close;
+ end;
+end;
+{--------}
+procedure TffDBStandaloneList.dblFreeItem(aItem : TffDBListItem);
+begin
+ aItem.Free;
+end;
+{--------}
+procedure TffDBStandaloneList.dblFreeUnownedItems;
+var
+ Inx : integer;
+ DBItem : TffDBListItem;
+begin
+ for Inx := pred(dblList.Count) downto 0 do begin
+ DBItem := Items[Inx];
+ if DBItem.IsOwned then
+ DBItem.DBOwnerName := ''
+ else
+ dblFreeItem(DBItem);
+ end;
+end;
+{--------}
+function TffDBStandaloneList.dblGetCount: integer;
+begin
+ with dblList.BeginRead do
+ try
+ Result := Count;
+ finally
+ EndRead;
+ end;
+end;
+{--------}
+function TffDBStandaloneList.dblGetItem(aInx: integer): TffDBListItem;
+begin
+ with dblList.BeginRead do
+ try
+ Result := TffDBListItem(dblList[aInx].Key^);
+ finally
+ EndRead;
+ end;
+end;
+{--------}
+procedure TffDBStandaloneList.DeleteItem(aItem: TffDBListItem);
+var
+ Inx : integer;
+begin
+ with dblList.BeginWrite do
+ try
+ Inx := dblList.Index(Longint(aItem));
+ if (Inx <> -1) then
+ dblList.Delete(Longint(aItem));
+ finally
+ EndWrite;
+ end;
+end;
+{--------}
+function TffDBStandaloneList.FindItem(const aName: string; var aItem: TffDBListItem): boolean;
+var
+ Inx : integer;
+ DBItem : TffDBListItem;
+begin
+ with dblList.BeginRead do
+ try
+ for Inx := Pred(Count) downto 0 do begin
+ DBItem := TffDBListItem(Items[Inx].Key^);
+ if (FFAnsiCompareText(DBItem.DBName, aName) = 0) then begin {!!.07}
+ aItem := DBItem;
+ Result := true;
+ Exit;
+ end;
+ end;
+ aItem := nil;
+ Result := false;
+ finally
+ EndRead;
+ end;
+end;
+{--------}
+procedure TffDBStandaloneList.GetItem(const aName: string; var aItem: TffDBListItem);
+begin
+ with dblList.BeginRead do
+ try
+ if not FindItem(aName, aItem) then
+ RaiseFFErrorMsg(ffStrResDataSet[ffdse_MissingItem]);
+ finally
+ EndRead;
+ end;
+end;
+{--------}
+procedure TffDBStandaloneList.GetItemNames(aList: TStrings);
+var
+ Inx : integer;
+ Item: TffDBListItem;
+begin
+ with dblList.BeginRead do
+ try
+ aList.BeginUpdate;
+ try
+ for Inx := pred(dblList.Count) downto 0 do begin
+ Item := TffDBListItem(Items[Inx].Key^);
+ if (Item.DBName <> '') then
+ aList.Add(Item.DBName);
+ end;
+ finally
+ aList.EndUpdate;
+ end;{try..finally}
+ finally
+ EndRead;
+ end;
+end;
+{--------}
+function TffDBStandaloneList.IndexOfItem(aItem : TffDBListItem) : integer;
+begin
+ with dblList.BeginRead do
+ try
+ Result := IndexOfItem(@aItem)
+ finally
+ EndRead;
+ end;
+end;
+{Begin !!.02}
+{--------}
+procedure TffDBStandaloneList.BeginRead;
+begin
+ dblList.BeginRead;
+end;
+{--------}
+procedure TffDBStandaloneList.BeginWrite;
+begin
+ dblList.BeginWrite;
+end;
+{--------}
+procedure TffDBStandaloneList.EndRead;
+begin
+ dblList.EndRead;
+end;
+{--------}
+procedure TffDBStandaloneList.EndWrite;
+begin
+ dblList.EndWrite;
+end;
+{End !!.02}
+{====================================================================}
+
+procedure FinalizeUnit;
+begin
+ ffStrResDataSet.Free;
+end;
+
+procedure InitializeUnit;
+begin
+ ffStrResDataSet := nil;
+ ffStrResDataSet := TffStringResource.Create(hInstance, 'FF_DATASET_ERROR_STRINGS');
+end;
+
+initialization
+ InitializeUnit;
+
+finalization
+ FinalizeUnit;
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffdbcnst.rc b/components/flashfiler/sourcelaz/ffdbcnst.rc
new file mode 100644
index 000000000..c92837014
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffdbcnst.rc
@@ -0,0 +1,31 @@
+/*********************************************************
+ * FlashFiler: BDE errors string table resource *
+ *********************************************************/
+
+/* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** */
+
+FF_BDE_ERROR_STRINGS RCDATA FFDBCNST.SRM
+
diff --git a/components/flashfiler/sourcelaz/ffdbcnst.res b/components/flashfiler/sourcelaz/ffdbcnst.res
new file mode 100644
index 000000000..7aa7a5492
Binary files /dev/null and b/components/flashfiler/sourcelaz/ffdbcnst.res differ
diff --git a/components/flashfiler/sourcelaz/ffdbcnst.srm b/components/flashfiler/sourcelaz/ffdbcnst.srm
new file mode 100644
index 000000000..6578bba2c
Binary files /dev/null and b/components/flashfiler/sourcelaz/ffdbcnst.srm differ
diff --git a/components/flashfiler/sourcelaz/ffdbcnst.str b/components/flashfiler/sourcelaz/ffdbcnst.str
new file mode 100644
index 000000000..d09024530
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffdbcnst.str
@@ -0,0 +1,578 @@
+;*********************************************************
+;* FlashFiler: BDE errors string table resource *
+;*********************************************************
+
+;* ***** BEGIN LICENSE BLOCK *****
+;* Version: MPL 1.1
+;*
+;* The contents of this file are subject to the Mozilla Public License Version
+;* 1.1 (the "License"); you may not use this file except in compliance with
+;* the License. You may obtain a copy of the License at
+;* http://www.mozilla.org/MPL/
+;*
+;* Software distributed under the License is distributed on an "AS IS" basis,
+;* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+;* for the specific language governing rights and limitations under the
+;* License.
+;*
+;* The Original Code is TurboPower FlashFiler
+;*
+;* The Initial Developer of the Original Code is
+;* TurboPower Software
+;*
+;* Portions created by the Initial Developer are Copyright (C) 1996-2002
+;* the Initial Developer. All Rights Reserved.
+;*
+;* Contributor(s):
+;*
+;* ***** END LICENSE BLOCK *****
+
+#include "ffconst.inc"
+8449, "Cannot open a system file."
+8450, "I/O error on a system file."
+8451, "Data structure corruption."
+8452, "Cannot find Engine configuration file."
+8453, "Cannot write to Engine configuration file."
+8454, "Cannot initialize with different configuration file."
+8455, "System has been illegally re-entered."
+8456, "Cannot locate IDAPI32 .DLL."
+8457, "Cannot load IDAPI32 .DLL."
+8458, "Cannot load an IDAPI service library."
+8459, "Cannot create or open temporary file."
+8705, "At beginning of table."
+8706, "At end of table."
+8707, "Record moved because key value changed."
+8708, "Record/Key deleted."
+8709, "No current record."
+8710, "Could not find record."
+8711, "End of BLOB."
+8712, "Could not find object."
+8713, "Could not find family member."
+8714, "BLOB file is missing."
+8715, "Could not find language driver."
+8961, "Corrupt table/index header."
+8962, "Corrupt file - other than header."
+8963, "Corrupt Memo/BLOB file."
+8965, "Corrupt index."
+8966, "Corrupt lock file."
+8967, "Corrupt family file."
+8968, "Corrupt or missing .VAL file."
+8969, "Foreign index file format."
+9217, "Read failure."
+9218, "Write failure."
+9219, "Cannot access directory."
+9220, "File Delete operation failed."
+9221, "Cannot access file."
+9222, "Access to table disabled because of previous error."
+9473, "Insufficient memory for this operation."
+9474, "Not enough file handles."
+9475, "Insufficient disk space."
+9476, "Temporary table resource limit."
+9477, "Record size is too big for table."
+9478, "Too many open cursors."
+9479, "Table is full."
+9480, "Too many sessions from this workstation."
+9481, "Serial number limit (Paradox)."
+9482, "Some internal limit (see context)."
+9483, "Too many open tables."
+9484, "Too many cursors per table."
+9485, "Too many record locks on table."
+9486, "Too many clients."
+9487, "Too many indexes on table."
+9488, "Too many sessions."
+9489, "Too many open databases."
+9490, "Too many passwords."
+9491, "Too many active drivers."
+9492, "Too many fields in Table Create."
+9493, "Too many table locks."
+9494, "Too many open BLOBs."
+9495, "Lock file has grown too large."
+9496, "Too many open queries."
+9498, "Too many BLOBs."
+9499, "File name is too long for a Paradox version 5.0 table."
+9500, "Row fetch limit exceeded."
+9501, "Long name not allowed for this tablelevel."
+9729, "Key violation."
+9730, "Minimum validity check failed."
+9731, "Maximum validity check failed."
+9732, "Field value required."
+9733, "Master record missing."
+9734, "Master has detail records. Cannot delete or modify."
+9735, "Master table level is incorrect."
+9736, "Field value out of lookup table range."
+9737, "Lookup Table Open operation failed."
+9738, "Detail Table Open operation failed."
+9739, "Master Table Open operation failed."
+9740, "Field is blank."
+9741, "Link to master table already defined."
+9742, "Master table is open."
+9743, "Detail table(s) exist."
+9744, "Master has detail records. Cannot empty it."
+9745, "Self referencing referential integrity must be entered one at a time with no other changes to the table"
+9746, "Detail table is open."
+9747, "Cannot make this master a detail of another table if its details are not empty."
+9748, "Referential integrity fields must be indexed."
+9749, "A table linked by referential integrity requires password to open."
+9750, "Field(s) linked to more than one master."
+9751, "Expression validity check failed."
+9985, "Number is out of range."
+9986, "Invalid parameter."
+9987, "Invalid file name."
+9988, "File does not exist."
+9989, "Invalid option."
+9990, "Invalid handle to the function."
+9991, "Unknown table type."
+9992, "Cannot open file."
+9993, "Cannot redefine primary key."
+9994, "Cannot change this RINTDesc."
+9995, "Foreign and primary key do not match."
+9996, "Invalid modify request."
+9997, "Index does not exist."
+9998, "Invalid offset into the BLOB."
+9999, "Invalid descriptor number."
+10000, "Invalid field type."
+10001, "Invalid field descriptor."
+10002, "Invalid field transformation."
+10003, "Invalid record structure."
+10004, "Invalid descriptor."
+10005, "Invalid array of index descriptors."
+10006, "Invalid array of validity check descriptors."
+10007, "Invalid array of referential integrity descriptors."
+10008, "Invalid ordering of tables during restructure."
+10009, "Name not unique in this context."
+10010, "Index name required."
+10011, "Invalid session handle."
+10012, "invalid restructure operation."
+10013, "Driver not known to system."
+10014, "Unknown database."
+10015, "Invalid password given."
+10016, "No callback function."
+10017, "Invalid callback buffer length."
+10018, "The alias references a directory that does not exist."
+10019, "Translate Error. Value out of bounds."
+10020, "Cannot set cursor of one table to another."
+10021, "Bookmarks do not match table."
+10022, "Invalid index/tag name."
+10023, "Invalid index descriptor."
+10024, "Table does not exist."
+10025, "Table has too many users."
+10026, "Cannot evaluate Key or Key does not pass filter condition."
+10027, "Index already exists."
+10028, "Index is open."
+10029, "Invalid BLOB length."
+10030, "Invalid BLOB handle in record buffer."
+10031, "Table is open."
+10032, "Need to do (hard) restructure."
+10033, "Invalid mode."
+10034, "Cannot close index."
+10035, "Index is being used to order table."
+10036, "Unknown user name or password."
+10037, "Multi-level cascade is not supported."
+10038, "Invalid field name."
+10039, "Invalid table name."
+10040, "Invalid linked cursor expression."
+10041, "Name is reserved."
+10042, "Invalid file extension."
+10043, "Invalid language Driver."
+10044, "Alias is not currently opened."
+10045, "Incompatible record structures."
+10046, "Name is reserved by DOS."
+10047, "Destination must be indexed."
+10048, "Invalid index type"
+10049, "Language Drivers of Table and Index do not match"
+10050, "Filter handle is invalid"
+10051, "Invalid Filter"
+10052, "Invalid table create request"
+10053, "Invalid table delete request"
+10054, "Invalid index create request"
+10055, "Invalid index delete request"
+10056, "Invalid table specified"
+10058, "Invalid Time."
+10059, "Invalid Date."
+10060, "Invalid Datetime"
+10061, "Tables in different directories"
+10062, "Mismatch in the number of arguments"
+10063, "Function not found in service library."
+10064, "Must use baseorder for this operation."
+10065, "Invalid procedure name"
+10066, "The field map is invalid."
+10241, "Record locked by another user."
+10242, "Unlock failed."
+10243, "Table is busy."
+10244, "Directory is busy."
+10245, "File is locked."
+10246, "Directory is locked."
+10247, "Record already locked by this session."
+10248, "Object not locked."
+10249, "Lock time out."
+10250, "Key group is locked."
+10251, "Table lock was lost."
+10252, "Exclusive access was lost."
+10253, "Table cannot be opened for exclusive use."
+10254, "Conflicting record lock in this session."
+10255, "A deadlock was detected."
+10256, "A user transaction is already in progress."
+10257, "No user transaction is currently in progress."
+10258, "Record lock failed."
+10259, "Couldn't perform the edit because another user changed the record."
+10260, "Couldn't perform the edit because another user deleted or moved the record."
+10497, "Insufficient field rights for operation."
+10498, "Insufficient table rights for operation. Password required."
+10499, "Insufficient family rights for operation."
+10500, "This directory is read only."
+10501, "Database is read only."
+10502, "Trying to modify read-only field."
+10503, "Encrypted dBASE tables not supported."
+10504, "Insufficient SQL rights for operation."
+10753, "Field is not a BLOB."
+10754, "BLOB already opened."
+10755, "BLOB not opened."
+10756, "Operation not applicable."
+10757, "Table is not indexed."
+10758, "Engine not initialized."
+10759, "Attempt to re-initialize Engine."
+10760, "Message ID of reply does not match expected message ID."
+10761, "Paradox driver not active."
+10762, "Driver not loaded."
+10763, "Table is read only."
+10764, "No associated index."
+10765, "Table(s) open. Cannot perform this operation."
+10766, "Table does not support this operation."
+10767, "Index is read only."
+10768, "Table does not support this operation because it is not uniquely indexed."
+10769, "Operation must be performed on the current session."
+10770, "Invalid use of keyword."
+10771, "Connection is in use by another statement."
+10772, "Passthrough SQL connection must be shared"
+11009, "Invalid function number."
+11010, "File or directory does not exist."
+11011, "Path not found."
+11012, "Too many open files. You may need to increase MAXFILEHANDLE limit in IDAPI configuration."
+11013, "Permission denied."
+11014, "Bad file number."
+11015, "Memory blocks destroyed."
+11016, "Not enough memory."
+11017, "Invalid memory block address."
+11018, "Invalid environment."
+11019, "Invalid format."
+11020, "Invalid access code."
+11021, "Invalid data."
+11023, "Device does not exist."
+11024, "Attempt to remove current directory."
+11025, "Not same device."
+11026, "No more files."
+11027, "Invalid argument."
+11028, "Argument list is too long."
+11029, "Execution format error."
+11030, "Cross-device link."
+11041, "Math argument."
+11042, "Result is too large."
+11043, "File already exists."
+11047, "Unknown internal operating system error."
+11058, "Share violation."
+11059, "Lock violation."
+11060, "Critical DOS Error."
+11061, "Drive not ready."
+11108, "Not exact read/write."
+11109, "Operating system network error."
+11110, "Error from NOVELL file server."
+11111, "NOVELL server out of memory."
+11112, "Record already locked by this workstation."
+11113, "Record not locked."
+11265, "Network initialization failed."
+11266, "Network user limit exceeded."
+11267, "Wrong .NET file version."
+11268, "Cannot lock network file."
+11269, "Directory is not private."
+11270, "Directory is controlled by other .NET file."
+11271, "Unknown network error."
+11272, "Not initialized for accessing network files."
+11273, "SHARE not loaded. It is required to share local files."
+11274, "Not on a network. Not logged in or wrong network driver."
+11275, "Lost communication with SQL server."
+11277, "Cannot locate or connect to SQL server."
+11278, "Cannot locate or connect to network server."
+11521, "Optional parameter is required."
+11522, "Invalid optional parameter."
+11777, "obsolete"
+11778, "obsolete"
+11779, "Ambiguous use of ! (inclusion operator)."
+11780, "obsolete"
+11781, "obsolete"
+11782, "A SET operation cannot be included in its own grouping."
+11783, "Only numeric and date/time fields can be averaged."
+11784, "Invalid expression."
+11785, "Invalid OR expression."
+11786, "obsolete"
+11787, "bitmap"
+11788, "CALC expression cannot be used in INSERT, DELETE, CHANGETO and SET rows."
+11789, "Type error in CALC expression."
+11790, "CHANGETO can be used in only one query form at a time."
+11791, "Cannot modify CHANGED table."
+11792, "A field can contain only one CHANGETO expression."
+11793, "A field cannot contain more than one expression to be inserted."
+11794, "obsolete"
+11795, "CHANGETO must be followed by the new value for the field."
+11796, "Checkmark or CALC expressions cannot be used in FIND queries."
+11797, "Cannot perform operation on CHANGED table together with a CHANGETO query."
+11798, "chunk"
+11799, "More than 255 fields in ANSWER table."
+11800, "AS must be followed by the name for the field in the ANSWER table."
+11801, "DELETE can be used in only one query form at a time."
+11802, "Cannot perform operation on DELETED table together with a DELETE query."
+11803, "Cannot delete from the DELETED table."
+11804, "Example element is used in two fields with incompatible types or with a BLOB."
+11805, "Cannot use example elements in an OR expression."
+11806, "Expression in this field has the wrong type."
+11807, "Extra comma found."
+11808, "Extra OR found."
+11809, "One or more query rows do not contribute to the ANSWER."
+11810, "FIND can be used in only one query form at a time."
+11811, "FIND cannot be used with the ANSWER table."
+11812, "A row with GROUPBY must contain SET operations."
+11813, "GROUPBY can be used only in SET rows."
+11814, "Use only INSERT, DELETE, SET or FIND in leftmost column."
+11815, "Use only one INSERT, DELETE, SET or FIND per line."
+11816, "Syntax error in expression."
+11817, "INSERT can be used in only one query form at a time."
+11818, "Cannot perform operation on INSERTED table together with an INSERT query."
+11819, "INSERT, DELETE, CHANGETO and SET rows may not be checked."
+11820, "Field must contain an expression to insert (or be blank)."
+11821, "Cannot insert into the INSERTED table."
+11822, "Variable is an array and cannot be accessed."
+11823, "Label"
+11824, "Rows of example elements in CALC expression must be linked."
+11825, "Variable name is too long."
+11826, "Query may take a long time to process."
+11827, "Reserved word or one that can't be used as a variable name."
+11828, "Missing comma."
+11829, "Missing )."
+11830, "Missing right quote."
+11831, "Cannot specify duplicate column names."
+11832, "Query has no checked fields."
+11833, "Example element has no defining occurrence."
+11834, "No grouping is defined for SET operation."
+11835, "Query makes no sense."
+11836, "Cannot use patterns in this context."
+11837, "Date does not exist."
+11838, "Variable has not been assigned a value."
+11839, "Invalid use of example element in summary expression."
+11840, "Incomplete query statement. Query only contains a SET definition."
+11841, "Example element with ! makes no sense in expression."
+11842, "Example element cannot be used more than twice with a ! query."
+11843, "Row cannot contain expression."
+11844, "obsolete"
+11845, "obsolete"
+11846, "No permission to insert or delete records."
+11847, "No permission to modify field."
+11848, "Field not found in table."
+11849, "Expecting a column separator in table header."
+11850, "Expecting a column separator in table."
+11851, "Expecting column name in table."
+11852, "Expecting table name."
+11853, "Expecting consistent number of columns in all rows of table."
+11854, "Cannot open table."
+11855, "Field appears more than once in table."
+11856, "This DELETE, CHANGE or INSERT query has no ANSWER."
+11857, "Query is not prepared. Properties unknown."
+11858, "DELETE rows cannot contain quantifier expression."
+11859, "Invalid expression in INSERT row."
+11860, "Invalid expression in INSERT row."
+11861, "Invalid expression in SET definition."
+11862, "row use"
+11863, "SET keyword expected."
+11864, "Ambiguous use of example element."
+11865, "obsolete"
+11866, "obsolete"
+11867, "Only numeric fields can be summed."
+11868, "Table is write protected."
+11869, "Token not found."
+11870, "Cannot use example element with ! more than once in a single row."
+11871, "Type mismatch in expression."
+11872, "Query appears to ask two unrelated questions."
+11873, "Unused SET row."
+11874, "INSERT, DELETE, FIND, and SET can be used only in the leftmost column."
+11875, "CHANGETO cannot be used with INSERT, DELETE, SET or FIND."
+11876, "Expression must be followed by an example element defined in a SET."
+11877, "Lock failure."
+11878, "Expression is too long."
+11879, "Refresh exception during query."
+11880, "Query canceled."
+11881, "Unexpected Database Engine error."
+11882, "Not enough memory to finish operation."
+11883, "Unexpected exception."
+11884, "Feature not implemented yet in query."
+11885, "Query format is not supported."
+11886, "Query string is empty."
+11887, "Attempted to prepare an empty query."
+11888, "Buffer too small to contain query string."
+11889, "Query was not previously parsed or prepared."
+11890, "Function called with bad query handle."
+11891, "QBE syntax error."
+11892, "Query extended syntax field count error."
+11893, "Field name in sort or field clause not found."
+11894, "Table name in sort or field clause not found."
+11895, "Operation is not supported on BLOB fields."
+11896, "General BLOB error."
+11897, "Query must be restarted."
+11898, "Unknown answer table type."
+11926, "Blob cannot be used as grouping field."
+11927, "Query properties have not been fetched."
+11928, "Answer table is of unsuitable type."
+11929, "Answer table is not yet supported under server alias."
+11930, "Non-null blob field required. Can't insert records"
+11931, "Unique index required to perform changeto"
+11932, "Unique index required to delete records"
+11933, "Update of table on the server failed."
+11934, "Can't process this query remotely."
+11935, "Unexpected end of command."
+11936, "Parameter not set in query string."
+11937, "Query string is too long."
+11946, "No such table or correlation name."
+11947, "Expression has ambiguous data type."
+11948, "Field in order by must be in result set."
+11949, "General parsing error."
+11950, "Record or field constraint failed."
+11951, "Field in group by must be in result set."
+11952, "User defined function is not defined."
+11953, "Unknown error from User defined function."
+11954, "Single row subquery produced more than one row."
+11955, "Expressions in group by are not supported."
+11956, "Queries on text or ascii tables are not supported."
+11957, "ANSI join keywords USING and NATURAL are not supported in this release."
+11958, "SELECT DISTINCT may not be used with UNION unless UNION ALL is used."
+11959, "GROUP BY is required when both aggregate and non-aggregate fields are used in result set."
+11960, "INSERT and UPDATE operations are not supported on autoincrement field type."
+11961, "UPDATE on Primary Key of a Master Table may modify more than one record."
+12033, "Interface mismatch. Engine version different."
+12034, "Index is out of date."
+12035, "Older version (see context)."
+12036, ".VAL file is out of date."
+12037, "BLOB file version is too old."
+12038, "Query and Engine DLLs are mismatched."
+12039, "Server is incompatible version."
+12040, "Higher table level required"
+12289, "Capability not supported."
+12290, "Not implemented yet."
+12291, "SQL replicas not supported."
+12292, "Non-blob column in table required to perform operation."
+12293, "Multiple connections not supported."
+12294, "Full dBASE expressions not supported."
+12545, "Invalid database alias specification."
+12546, "Unknown database type."
+12547, "Corrupt system configuration file."
+12548, "Network type unknown."
+12549, "Not on the network."
+12550, "Invalid configuration parameter."
+12801, "Object implicitly dropped."
+12802, "Object may be truncated."
+12803, "Object implicitly modified."
+12804, "Should field constraints be checked?"
+12805, "Validity check field modified."
+12806, "Table level changed."
+12807, "Copy linked tables?"
+12809, "Object implicitly truncated."
+12810, "Validity check will not be enforced."
+12811, "Multiple records found, but only one was expected."
+12812, "Field will be trimmed, cannot put master records into PROBLEM table."
+13057, "File already exists."
+13058, "BLOB has been modified."
+13059, "General SQL error."
+13060, "Table already exists."
+13061, "Paradox 1.0 tables are not supported."
+13062, "Update aborted."
+13313, "Different sort order."
+13314, "Directory in use by earlier version of Paradox."
+13315, "Needs Paradox 3.5-compatible language driver."
+13569, "Data Dictionary is corrupt"
+13570, "Data Dictionary Info Blob corrupted"
+13571, "Data Dictionary Schema is corrupt"
+13572, "Attribute Type exists"
+13573, "Invalid Object Type"
+13574, "Invalid Relation Type"
+13575, "View already exists"
+13576, "No such View exists"
+13577, "Invalid Record Constraint"
+13578, "Object is in a Logical DB"
+13579, "Dictionary already exists"
+13580, "Dictionary does not exist"
+13581, "Dictionary database does not exist"
+13582, "Dictionary info is out of date - needs Refresh"
+13584, "Invalid Dictionary Name"
+13585, "Dependent Objects exist"
+13586, "Too many Relationships for this Object Type"
+13587, "Relationships to the Object exist"
+13588, "Dictionary Exchange File is corrupt"
+13589, "Dictionary Exchange File Version mismatch"
+13590, "Dictionary Object Type Mismatch"
+13591, "Object exists in Target Dictionary"
+13592, "Cannot access Data Dictionary"
+13593, "Cannot create Data Dictionary"
+13594, "Cannot open Database"
+
+DBIERR_FF_BadStruct, "FF SERVER ERROR: TffFileInfo record contains invalid data"
+DBIERR_FF_OpenFailed, "FF SERVER ERROR: File could not be opened. File may be in use by another process."
+DBIERR_FF_OpenNoMem, "FF SERVER ERROR: Out of memory when opening a file"
+DBIERR_FF_CloseFailed, "FF SERVER ERROR: File could not be closed"
+DBIERR_FF_ReadFailed, "FF SERVER ERROR: Error when reading from file"
+DBIERR_FF_ReadExact, "FF SERVER ERROR: Could not read exact number of bytes from file"
+DBIERR_FF_WriteFailed, "FF SERVER ERROR: Error when writing to file. There may not be enough space on the disk."
+DBIERR_FF_WriteExact, "FF SERVER ERROR: Could not write exact number of bytes to file"
+DBIERR_FF_SeekFailed, "FF SERVER ERROR: Error when seeking to position in file"
+DBIERR_FF_FlushFailed, "FF SERVER ERROR: Error when flushing file"
+DBIERR_FF_SetEOFFailed, "FF SERVER ERROR: Error when setting end-of-file"
+DBIERR_FF_TempStorageFull, "FF SERVER ERROR: Temporary storage is full. More space may need to be allocated."
+DBIERR_FF_CopyFile, "FF SERVER ERROR: Error when copying a file"
+DBIERR_FF_DeleteFile, "FF SERVER ERROR: Error when deleting a file"
+DBIERR_FF_RenameFile, "FF SERVER ERROR: Error when renaming a file"
+DBIERR_FF_BadBlockNr, "FF SERVER ERROR: Block number is either < 0, or >= number of blocks in file"
+DBIERR_FF_RecDeleted, "FF SERVER ERROR: Record accessed is deleted"
+DBIERR_FF_BadRefNr, "FF SERVER ERROR: Record reference number is invalid"
+DBIERR_FF_BadDataBlock, "FF SERVER ERROR: Block read from file is not a data block"
+DBIERR_FF_BadStreamBlock, "FF SERVER ERROR: Block read from file is not a stream block"
+DBIERR_FF_BadStreamOrigin, "FF SERVER ERROR: Stream origin is invalid"
+DBIERR_FF_StreamSeekError, "FF SERVER ERROR: Stream could not seek requested position"
+DBIERR_FF_BadInxBlock, "FF SERVER ERROR: Block read from file is not an index block"
+DBIERR_FF_BadIndex, "FF SERVER ERROR: Index number passed to routine is out of range"
+DBIERR_FF_MaxIndexes, "FF SERVER ERROR: The maximum number of indexes (255) have already been added"
+DBIERR_FF_BadMergeCall, "FF SERVER ERROR: MergeChildren called with pages not half-filled, suspect corruption"
+DBIERR_FF_KeyNotFound, "FF SERVER ERROR: Key was not found in index when attempting to delete it"
+DBIERR_FF_KeyPresent, "FF SERVER ERROR: Key was found in index when attempting to add it"
+DBIERR_FF_NoKeys, "FF SERVER ERROR: There are no keys in the index, cannot calculate an approximate position/key"
+DBIERR_FF_NoSeqAccess, "FF SERVER ERROR: Cannot create sequential cursor (index 0) as the group has no sequential access path"
+DBIERR_FF_BadApproxPos, "FF SERVER ERROR: The approximate position must be between 0 and 100 inclusive"
+DBIERR_FF_BadServerName, "FF SERVER ERROR: The server name is invalid"
+DBIERR_FF_V1File, "The file could not be opened because it is a FlashFiler 1.0 file."
+DBIERR_FF_FileBLOBOpen, "FF SERVER ERROR: An error occurred when opening the external file for a file BLOB"
+DBIERR_FF_FileBLOBRead, "FF SERVER ERROR: An error occurred when reading the external file for a file BLOB"
+DBIERR_FF_FileBLOBClose, "FF SERVER ERROR: An error occurred when closing the external file for a file BLOB"
+DBIERR_FF_CorruptTrans, "FF SERVER ERROR: The transaction was corrupt due to an earlier failure and has been rolled back. No commit took place."
+DBIERR_FF_FilterTimeout, "FF SERVER ERROR: The server-side filter timed out."
+DBIERR_FF_ReplyTimeout, "Timed out waiting for reply."
+DBIERR_FF_WaitFailed, "Unable to wait for event."
+DBIERR_FF_ClientIDFail, "When trying to establish a connection, could not generate a temporary clientID."
+DBIERR_FF_NoAddHandler, "FF SERVER ERROR: No AddClient handler specified for the remote transport."
+DBIERR_FF_NoRemHandler, "FF SERVER ERROR: No RemoveClient handler specified for the remote transport."
+DBIERR_FF_UnknownClient, "Unknown client or client may be in process of being removed."
+DBIERR_FF_UnknownSession, "Unknown session or session may be in process of closing."
+DBIERR_FF_UnknownDB, "Unknown database or database may be in process of closing."
+DBIERR_FF_UnknownCursor, "Unknown cursor or cursor may be in process of closing."
+DBIERR_FF_BLOBTooBig, "BLOB size exceeds maximum size."
+DBIERR_FF_Deadlock, "A deadlock was detected. This transaction was chosen as the victim."
+DBIERR_FF_Timeout, "The server operation timed out. This typically occurs if a lock could not be obtained on a table or file block."
+DBIERR_FF_LockRejected, "A lock request was rejected by the database's lock manager."
+DBIERR_FF_ServerUnavail, "The server is not started and cannot process requests."
+DBIERR_FF_GeneralTimeout, "The operation could not be completed in the allotted time."
+DBIERR_FF_NoSQLEngine, "The server engine is not attached to a SQL engine."
+DBIERR_FF_TableVersion, "The table cannot be opened because it was created with a newer version of FlashFiler."
+DBIERR_FF_IxHlprRegistered, "Helper with that name already registered."
+DBIERR_FF_IxHlprNotReg, "No helper with that name has been registered."
+DBIERR_FF_IxHlprNotSupp, "Index helper does not support that field type."
+DBIERR_FF_IncompatDict, "The cursor dictionaries are incompatible. Verify the correct field types, lengths, units, and decimal places have been specified."
+DBIERR_FF_SameTable, "The cursors may not reference the same table for this operation."
+
+DBIERR_FF_Unknown, "FF SERVER ERROR: Unknown (server exception object has unknown error code)"
+DBIERR_FF_UnknownExcp, "FF SERVER ERROR: Unknown (unexpected exception object raised)"
+DBIERR_FF_UnknownMsg, "FF SERVER ERROR: Message is unrecognized."
+
+DBIERR_FF_RangeNotSupported, "Ranges not supported by this cursor class."
diff --git a/components/flashfiler/sourcelaz/ffdefine.inc b/components/flashfiler/sourcelaz/ffdefine.inc
new file mode 100644
index 000000000..a00e0c4d9
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffdefine.inc
@@ -0,0 +1,347 @@
+{*********************************************************}
+{* FlashFiler: Compiler options/directives include file *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{NOTE: FFDEFINE.INC is included in all FlashFiler units; hence you can
+ specify global compiler options here. FFDEFINE.INC is included
+ *before* each unit's own required compiler options, so options
+ specified here could be overridden by hardcoded options in the
+ unit source file.}
+
+{====Compiler options that can be changed====}
+{$A+ Force alignment on word/dword boundaries}
+{$S- No stack checking}
+
+
+{====Determination of compiler (do NOT change)====}
+{$IFDEF VER100}
+ {$DEFINE Delphi3}
+ {$DEFINE IsDelphi}
+ {$DEFINE ExprParserType1}
+ {$DEFINE CannotOverrideDispatch}
+{$ENDIF}
+{$IFDEF VER110}
+ {$DEFINE CBuilder3}
+ {$DEFINE ExprParserType1}
+{$ENDIF}
+{$IFDEF VER120}
+ {$DEFINE Delphi4}
+ {$DEFINE IsDelphi}
+ {$DEFINE DCC4OrLater}
+ {$DEFINE HasStrictCardinal}
+ {$DEFINE ResizePersistFields}
+ {$DEFINE ExprParserType2}
+{$ENDIF}
+{$IFDEF VER125}
+ {$DEFINE CBuilder4}
+ {$DEFINE DCC4OrLater}
+ {$DEFINE HasStrictCardinal}
+ {$DEFINE ResizePersistFields}
+ {$DEFINE ExprParserType2}
+{$ENDIF}
+{$IFDEF VER130}
+ {$DEFINE DCC4OrLater}
+ {$DEFINE DCC5OrLater}
+ {$DEFINE ProvidesDatasource}
+ {$IFNDEF BCB}
+ {$DEFINE Delphi5}
+ {$DEFINE IsDelphi}
+ {$DEFINE HasStrictCardinal}
+ {$DEFINE ResizePersistFields}
+ {$DEFINE ExprParserType3}
+ {$ELSE}
+ {$DEFINE CBuilder5}
+ {$DEFINE HasStrictCardinal}
+ {$DEFINE ResizePersistFields}
+ {$DEFINE ExprParserType3}
+ {$ENDIF}
+{$ENDIF}
+{$IFDEF VER140}
+ {$DEFINE DCC4OrLater}
+ {$DEFINE DCC5OrLater}
+ {$DEFINE DCC6OrLater}
+ {$DEFINE ProvidesDatasource}
+ {$IFNDEF BCB}
+ {$DEFINE Delphi6}
+ {$DEFINE IsDelphi}
+ {$DEFINE HasStrictCardinal}
+ {$DEFINE ResizePersistFields}
+ {$DEFINE ExprParserType3}
+ {$ELSE}
+ {$DEFINE CBuilder6}
+ {$DEFINE HasStrictCardinal}
+ {$DEFINE ResizePersistFields}
+ {$DEFINE ExprParserType3}
+ {$ENDIF}
+{$ENDIF}
+{$IFDEF VER150}
+ {$DEFINE DCC4OrLater}
+ {$DEFINE DCC5OrLater}
+ {$DEFINE DCC6OrLater}
+ {$DEFINE DCC7OrLater}
+ {$DEFINE ProvidesDatasource}
+ {$IFNDEF BCB}
+ {$DEFINE Delphi7}
+ {$DEFINE IsDelphi}
+ {$DEFINE HasStrictCardinal}
+ {$DEFINE ResizePersistFields}
+ {$DEFINE ExprParserType3}
+ {$ENDIF}
+{$ENDIF}
+
+{$IFDEF VER180} //meine Turbodelphi
+ {$DEFINE DCC4OrLater}
+ {$DEFINE DCC5OrLater}
+ {$DEFINE DCC6OrLater}
+ {$DEFINE DCC7OrLater}
+ {$DEFINE ProvidesDatasource}
+ {$IFNDEF BCB}
+ {$DEFINE Delphi7}
+ {$DEFINE IsDelphi}
+ {$DEFINE HasStrictCardinal}
+ {$DEFINE ResizePersistFields}
+ {$DEFINE ExprParserType3}
+ {$ENDIF}
+{$ENDIF}
+
+{$IFDEF FPC }
+ {.$DEFINE DONTUSEDELPHIUNIT} //Disables in ffdb.pas the function TffDataSet.dsCreateLookupFilter
+ //if it called then it raises exception!
+ {$MODE DELPHI }
+ {$DEFINE DCC4OrLater}
+ {$DEFINE DCC5OrLater}
+ {$DEFINE DCC6OrLater}
+ {$DEFINE DCC7OrLater}
+ {$DEFINE ProvidesDatasource}
+ {$IFNDEF BCB}
+ {$DEFINE Delphi7}
+ {$DEFINE IsDelphi}
+ {$DEFINE HasStrictCardinal}
+ {$DEFINE ResizePersistFields}
+ {$DEFINE ExprParserType3}
+ {$ENDIF}
+{$ENDIF }
+
+{$IFDEF DCC5OrLater}
+ {$UNDEF UsesBDE}
+{$ELSE}
+ {$DEFINE UsesBDE}
+{$ENDIF}
+
+
+{====Global fixed compiler options (do NOT change)====}
+{---Delphi 3---}
+ {$IFDEF Delphi3}
+ {$B- Incomplete boolean evaluation}
+ {$H+ Long string support}
+ {$J+ Writeable typed constants}
+ {$P- No open string parameters}
+ {$T- No type-checked pointers}
+ {$V- No var string checking}
+ {$X+ Extended syntax}
+ {$Z1 Enumerations are word sized}
+ {$ENDIF}
+{---Delphi 4---}
+ {$IFDEF Delphi4}
+ {$B- Incomplete boolean evaluation}
+ {$H+ Long string support}
+ {$J+ Writeable typed constants}
+ {$P- No open string parameters}
+ {$T- No type-checked pointers}
+ {$V- No var string checking}
+ {$X+ Extended syntax}
+ {$Z1 Enumerations are word sized}
+ {$ENDIF}
+{---Delphi 5---}
+ {$IFDEF Delphi5}
+ {$B- Incomplete boolean evaluation}
+ {$H+ Long string support}
+ {$J+ Writeable typed constants}
+ {$P- No open string parameters}
+ {$T- No type-checked pointers}
+ {$V- No var string checking}
+ {$X+ Extended syntax}
+ {$Z1 Enumerations are word sized}
+ {$ENDIF}
+{---Delphi 6---}
+ {$IFDEF Delphi6}
+ {$B- Incomplete boolean evaluation}
+ {$H+ Long string support}
+ {$J+ Writeable typed constants}
+ {$P- No open string parameters}
+ {$T- No type-checked pointers}
+ {$V- No var string checking}
+ {$X+ Extended syntax}
+ {$Z1 Enumerations are word sized}
+ {$ENDIF}
+{---Delphi 7---}
+ {$IFDEF Delphi7}
+ {$B- Incomplete boolean evaluation}
+ {$H+ Long string support}
+ {$J+ Writeable typed constants}
+ {$P- No open string parameters}
+ {$T- No type-checked pointers}
+ {$V- No var string checking}
+ {$X+ Extended syntax}
+ {$Z1 Enumerations are word sized}
+ {$WARN UNIT_PLATFORM OFF}
+ {$WARN UNSAFE_CODE OFF}
+ {$WARN UNSAFE_TYPE OFF}
+ {$WARN UNSAFE_CAST OFF}
+ {$WARN UNIT_DEPRECATED OFF}
+ {$ENDIF}
+{---C++Builder 3---}
+ {$IFDEF CBuilder3}
+ {$B- Incomplete boolean evaluation}
+ {$H+ Long string support}
+ {$J+ Writeable typed constants}
+ {$P- No open string parameters}
+ {$T- No type-checked pointers}
+ {$V- No var string checking}
+ {$X+ Extended syntax}
+ {$Z1 Enumerations are word sized}
+ {$OBJEXPORTALL ON}
+ {$ENDIF}
+{---C++Builder 4---}
+ {$IFDEF CBuilder4}
+ {$B- Incomplete boolean evaluation}
+ {$H+ Long string support}
+ {$J+ Writeable typed constants}
+ {$P- No open string parameters}
+ {$T- No type-checked pointers}
+ {$V- No var string checking}
+ {$X+ Extended syntax}
+ {$Z1 Enumerations are word sized}
+ {$OBJEXPORTALL ON}
+ {$ENDIF}
+{---C++Builder 5---}
+ {$IFDEF CBuilder5}
+ {$B- Incomplete boolean evaluation}
+ {$H+ Long string support}
+ {$J+ Writeable typed constants}
+ {$P- No open string parameters}
+ {$T- No type-checked pointers}
+ {$V- No var string checking}
+ {$X+ Extended syntax}
+ {$Z1 Enumerations are word sized}
+ {$OBJEXPORTALL ON}
+ {$ENDIF}
+{---C++Builder 6---}
+ {$IFDEF CBuilder6}
+ {$B- Incomplete boolean evaluation}
+ {$H+ Long string support}
+ {$J+ Writeable typed constants}
+ {$P- No open string parameters}
+ {$T- No type-checked pointers}
+ {$V- No var string checking}
+ {$X+ Extended syntax}
+ {$Z1 Enumerations are word sized}
+ {$OBJEXPORTALL ON}
+ {$ENDIF}
+
+
+
+{====General defines=================================================}
+
+{Activate the following define to include extra code to get rid of all
+ hints and warnings. Parts of FlashFiler are written in such a way
+ that the hint/warning algorithms of the Delphi compilers are
+ fooled and report things like variables being used before
+ initialisation and so on when in reality the problem does not exist.}
+{$DEFINE DefeatWarnings}
+
+{Activate the following define to enable safer text comparisons.
+AnsiCompareText has problems comparing text for some locals that cause
+this define to be necessary. For instance, in the Norwegian locale,
+BAALAM <> BaAlam when using AnsiCompareText, instead AnsiCompareText
+should report that the values are equal.
+Enabling this define will cause AnsiLowerText to be performed on
+both input strings before AnsiCompareText is called.}
+{.$DEFINE SafeAnsiCompare}
+
+{====CLIENT specific defines=========================================}
+
+{WARNING: The following define is provided *ONLY* for backwards compatibility
+ with FlashFiler 1. If you have placed a TffServerEngine within your component,
+ do *NOT* uncomment this define. Instead, connect your TffTable and TffQuery
+ components to the TffServerEngine through a TffDatabase, TffSession, and
+ TffClient components. Connect the TffClient component to the TffServerEngine.
+
+ If you are porting an existing FlashFiler 1 application to FlashFiler 2 and
+ you wish to use the old SingleEXE method, even though its use is disdained and
+ frowned upon, activate the following define to enable compiling client and
+ server into the same single user application.}
+{.$DEFINE SingleEXE}
+
+{Activate the following define to look to the Registry for Client
+ configuration information.}
+{$DEFINE UseRegistryConfig}
+
+{Activate the following define to look to the FF2.INI file for Client
+ configuration information}
+{.$DEFINE UseINIConfig}
+
+{====SERVER specific defines=========================================}
+
+{Activate the following define to include the tracing facility.}
+{.$DEFINE Tracing}
+
+
+{Activate the following define to allow rebuild operations (reindex,
+ pack, restructure) to run in a separate thread from the main server
+ process.}
+{$DEFINE ThreadedRebuilds}
+
+
+{Activate the following define to compile a secured server}
+{$DEFINE SecureServer}
+ {$IFDEF SecureServer}
+ {Turn on the following define to make TempStorage secure}
+ {.$DEFINE SecureTempStorage}
+ {$ENDIF}
+
+
+{Activate the following define to enable some debugging code within the
+ FlashFiler Server. }
+{.$DEFINE FF_DEBUG}
+{.$DEFINE FF_DEBUG_THREADS}
+
+{Activate the following define to enable exception logging in the
+ following applications.
+ -BDE2FF.EXE BETA.EXE FF1INTFC.DLL
+ -FFCNVRT.EXE FFCNVRTC.EXE P2BFF2xx.DLL
+ -FFE.EXE FFCOMMS.EXE FFSERVER.EXE
+ -FFSRVICE.EXE
+Note: You must manually set the project to create a map file for this
+ option to be useful}
+
+ {.$DEFINE USETeDEBUG}
+
+{-------- !! DO NOT CHANGE DEFINES BELOW THIS LINE !! --------}
+
+{$DEFINE FF2}
diff --git a/components/flashfiler/sourcelaz/ffdscnst.inc b/components/flashfiler/sourcelaz/ffdscnst.inc
new file mode 100644
index 000000000..632b20860
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffdscnst.inc
@@ -0,0 +1,96 @@
+{*********************************************************}
+{* FlashFiler: Stringtable constants for DataSet code *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+
+{Note: Actual string values are found in the resource scripts
+ FFDSCNST.STR - TDataSet descendant strings}
+
+{String constants}
+const
+ ffdse_NoErrorCode = $D500;
+ ffdse_HasErrorCode = $D501;
+ ffdse_NilPointer = $D502;
+ ffdse_UnnamedInst = $D503;
+ ffdse_InstNoCode = $D504;
+ ffdse_MissingItem = $D505;
+ ffdse_MustBeClosed = $D506;
+ ffdse_MustBeOpen = $D507;
+ ffdse_MissingOwner = $D508;
+ ffdse_NeedsName = $D509;
+ ffdse_NeedsOwnerName = $D50A;
+ ffdse_NoDefaultCL = $D50B;
+ ffdse_NoSessions = $D50C;
+ ffdse_NilSession = $D50D;
+ ffdse_CLNameExists = $D50E;
+ ffdse_CLMustBeOpen = $D50F;
+ ffdse_CLMustBeClosed = $D510;
+ ffdse_SessMustBeOpen = $D511;
+ ffdse_SessMustBeClosed = $D512;
+ ffdse_CannotStartEng = $D513;
+ ffdse_CannotStartCL = $D514;
+ ffdse_CannotOpenSess = $D515;
+ ffdse_SessNameExists = $D516;
+ ffdse_DBMustBeClosed = $D517;
+ ffdse_DBMustBeOpen = $D518;
+ ffdse_CantOpenDBSess = $D519;
+ ffdse_DBNoOwningSess = $D51A;
+ ffdse_MatchesAlias = $D51B;
+ ffdse_DBNameExists = $D51C;
+ ffdse_TblMustBeClosed = $D51D;
+ ffdse_TblMustBeOpen = $D51E;
+ ffdse_CantOpenTblDB = $D51F;
+ ffdse_NotSameTbl = $D520;
+ ffdse_UnnamedTblNoFlds = $D521;
+ ffdse_CantGetTblHandle = $D522;
+ ffdse_TblNotEditing = $D523;
+ ffdse_TblFldNotInIndex = $D524;
+ ffdse_TblCantGetBuf = $D525;
+ ffdse_TblCalcFlds = $D526;
+ ffdse_TblReadOnlyEdit = $D527;
+ ffdse_TblChkKeyNoEdit = $D528;
+ ffdse_TblNoName = $D529;
+ ffdse_TblBadDBName = $D52A;
+ ffdse_TblBadDBRefCount = $D52B;
+ ffdse_TblBadReadOnly = $D52C;
+ ffdse_TblIdxFldRange = $D52D;
+ ffdse_TblIdxFldMissing = $D52E;
+ ffdse_TblIdxNotExist = $D52F;
+ ffdse_TblCircDataLink = $D530;
+ ffdse_BLOBFltNoFldAccess = $D531;
+ ffdse_BLOBAccessNoMatch = $D532;
+ ffdse_BLOBTblNoEdit = $D533;
+ ffdse_InvalidFieldType = $D534;
+ ffdse_InstCode = $D535;
+ ffdse_EmptySQLStatement = $D536;
+ ffdse_QueryMustBeClosed = $D537;
+ ffdse_QueryExecFail = $D538;
+ ffdse_QuerySetParamsFail = $D539;
+ ffdse_QueryPrepareFail = $D53A;
+ ffdse_RSENeedsTransport = $D53B;
+ ffdse_StartTranTblActive = $D53C; {!!.10}
diff --git a/components/flashfiler/sourcelaz/ffdscnst.rc b/components/flashfiler/sourcelaz/ffdscnst.rc
new file mode 100644
index 000000000..1a05fafbf
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffdscnst.rc
@@ -0,0 +1,31 @@
+/*********************************************************
+ * FlashFiler: TDataSet descendant errors string table *
+ *********************************************************/
+
+/* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** */
+
+FF_DATASET_ERROR_STRINGS RCDATA FFDSCNST.SRM
+
diff --git a/components/flashfiler/sourcelaz/ffdscnst.res b/components/flashfiler/sourcelaz/ffdscnst.res
new file mode 100644
index 000000000..95bb4c6ca
Binary files /dev/null and b/components/flashfiler/sourcelaz/ffdscnst.res differ
diff --git a/components/flashfiler/sourcelaz/ffdscnst.srm b/components/flashfiler/sourcelaz/ffdscnst.srm
new file mode 100644
index 000000000..54e762834
Binary files /dev/null and b/components/flashfiler/sourcelaz/ffdscnst.srm differ
diff --git a/components/flashfiler/sourcelaz/ffdscnst.str b/components/flashfiler/sourcelaz/ffdscnst.str
new file mode 100644
index 000000000..c2a63b7f3
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffdscnst.str
@@ -0,0 +1,92 @@
+;*********************************************************
+;* FlashFiler: TDataSet descendant errors string table *
+;*********************************************************
+
+;* ***** BEGIN LICENSE BLOCK *****
+;* Version: MPL 1.1
+;*
+;* The contents of this file are subject to the Mozilla Public License Version
+;* 1.1 (the "License"); you may not use this file except in compliance with
+;* the License. You may obtain a copy of the License at
+;* http://www.mozilla.org/MPL/
+;*
+;* Software distributed under the License is distributed on an "AS IS" basis,
+;* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+;* for the specific language governing rights and limitations under the
+;* License.
+;*
+;* The Original Code is TurboPower FlashFiler
+;*
+;* The Initial Developer of the Original Code is
+;* TurboPower Software
+;*
+;* Portions created by the Initial Developer are Copyright (C) 1996-2002
+;* the Initial Developer. All Rights Reserved.
+;*
+;* Contributor(s):
+;*
+;* ***** END LICENSE BLOCK *****
+
+#include "ffdscnst.inc"
+
+ffdse_NoErrorCode, "FlashFiler: %s [no error code]"
+ffdse_HasErrorCode, "FlashFiler: %s [$%x/%d]"
+ffdse_NilPointer, ""
+ffdse_UnnamedInst, ""
+ffdse_InstNoCode, "FlashFiler: %s: %s [no error code]"
+ffdse_MissingItem, "TffDBList.GetItem could not find item requested"
+ffdse_MustBeClosed, "This DB object must be closed before performing this operation"
+ffdse_MustBeOpen, "This DB object must be open before performing this operation"
+ffdse_MissingOwner, "The %s object [%s] has no owner in the database heirarchy or it cannot be found"
+ffdse_NeedsName, "Please specify a [%s] for this component"
+ffdse_NeedsOwnerName, "Cannot open DB object without specifying an owner name"
+ffdse_NoDefaultCL, "There is no default client"
+ffdse_NoSessions, "The default client has no sessions"
+ffdse_NilSession, "Session is nil: hence cannot retrieve database names"
+ffdse_CLNameExists, "Client name [%s] already exists"
+ffdse_CLMustBeClosed, "The Client must be inactive before performing this operation"
+ffdse_CLMustBeOpen, "The Client must be active before performing this operation"
+ffdse_SessMustBeOpen, "The session must be open before performing this operation"
+ffdse_SessMustBeClosed, "The session must be closed before performing this operation"
+ffdse_CannotStartEng, "Could not start the FlashFiler client engine"
+ffdse_CannotStartCL, "Could not open the session's client"
+ffdse_CannotOpenSess, "Could not open session [%s] (usually indicates no server could be detected)"
+ffdse_SessNameExists, "Session name [%s] already exists"
+ffdse_DBMustBeClosed, "The database must be closed before performing this operation"
+ffdse_DBMustBeOpen, "The database must be open before performing this operation"
+ffdse_CantOpenDBSess, "Could not open the session for database [%s]"
+ffdse_DBNoOwningSess, "Database [%s] has no owning session"
+ffdse_MatchesAlias, "Database name %s matches an alias name"
+ffdse_DBNameExists, "Database name %s already exists"
+ffdse_TblMustBeClosed, "The table must be closed before performing this operation"
+ffdse_TblMustBeOpen, "The table must be open before performing this operation"
+ffdse_CantOpenTblDB, "Could not open the database for table [%s]"
+ffdse_NotSameTbl, "GotoCurrent: Table objects are not the same physical table at the server"
+ffdse_UnnamedTblNoFlds, "The table is unnamed; cannot retrieve field information"
+ffdse_CantGetTblHandle, "TffTable.OpenCursor: unable to obtain handle"
+ffdse_TblNotEditing, "Table not in editing mode"
+ffdse_TblFldNotInIndex, "Field being set is not part of an index"
+ffdse_TblCantGetBuf, "Could not retrieve the active buffer"
+ffdse_TblCalcFlds, "DataSet not in editing mode"
+ffdse_TblReadOnlyEdit, "Field cannot be changed: it is readonly"
+ffdse_TblChkKeyNoEdit, "TffTable.tcCheckKeyEditMode: not in edit or set key mode"
+ffdse_TblNoName, "TffTable.tcCreateHandle: no table name specified"
+ffdse_TblBadDBName, "Table cannot open its database: the database name is not set or doesn't exist"
+ffdse_TblBadDBRefCount, "DB open ref count error: mismatch between opens and closes"
+ffdse_TblBadReadOnly, "BIG TROUBLE: we got a readonly error when using readonly"
+ffdse_TblIdxFldRange, "TffTable.tcGetIndexField: field index out of range"
+ffdse_TblIdxFldMissing, "TffTable.tcGetIndexField: cannot find field object"
+ffdse_TblIdxNotExist, "Index name [%s] does not exist"
+ffdse_TblCircDataLink, "Circular data link with data source [%s]"
+ffdse_BLOBFltNoFldAccess, "No access to field whilst table is being filtered"
+ffdse_BLOBAccessNoMatch, "The field is readonly but BLOB stream is being opened for read/write access"
+ffdse_BLOBTblNoEdit, "The BLOB stream is being opened for read/write access but the table is not being edited"
+ffdse_InvalidFieldType, "Field type '%s' specified for field '%s' is not supported"
+ffdse_InstCode, "FlashFiler: %s: %s [$%x/%d]"
+ffdse_EmptySQLStatement, "No SQL statement specified"
+ffdse_QueryMustBeClosed, "The query must be closed before performing this operation"
+ffdse_QueryExecFail, "Query execution failed: %s%s"
+ffdse_QuerySetParamsFail, "Query set parameters failed: %s%s"
+ffdse_QueryPrepareFail, "Query preparation failed: %s%s"
+ffdse_RSENeedsTransport, "Cannot open session: No transport associated with Remote Server Engine"
+ffdse_StartTranTblActive, "Table %s passed to TffBaseDatabase.StartTransactionWith is not active."
diff --git a/components/flashfiler/sourcelaz/ffdtmsgq.pas b/components/flashfiler/sourcelaz/ffdtmsgq.pas
new file mode 100644
index 000000000..4d0ef330a
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffdtmsgq.pas
@@ -0,0 +1,589 @@
+{*********************************************************}
+{* FlashFiler: Data message queue class *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffdtmsgq;
+
+interface
+
+uses
+ Windows,
+ Messages,
+ SysUtils,
+ Classes,
+ ExtCtrls,
+ ffllbase,
+ ffllcomm,
+ ffnetmsg;
+
+type
+ PffDataMessageNode = ^TffDataMessageNode;
+ TffDataMessageNode = record
+ dmnMsg : PffDataMessage;
+ dmnNext : PFFDataMessageNode;
+ dmnOffset : TffMemSize;
+ dmnPrev : PFFDataMessageNode;
+ dmnProcessing : boolean;
+ end;
+
+ { This class is used to store partial or completed messages until
+
+ a) the message has been received completely and
+ b) the message is examined by a consumer.
+
+ By default, this class is not thread-safe. You can make it thread-safe
+ by using the BeginRead/EndRead and BeginWrite/EndWrite methods.
+ }
+ TffDataMessageQueue = class(TffObject)
+ protected {private}
+ FCount : integer;
+ FNotifyHandle : HWND;
+
+ dmqPortal : TffReadWritePortal;
+ dmqHead : PFFDataMessageNode;
+ dmqTail : PFFDataMessageNode;
+ dmqStack : PFFDataMessageNode;
+ protected
+ procedure dmqPopStack;
+ procedure dmqSplitMultiPartMessage;
+ public
+ constructor Create;
+ destructor Destroy; override;
+
+ function AddToData(aMsg : longint;
+ aClientID : TFFClientID;
+ aRequestID : longint;
+ aData : pointer;
+ aDataLen : TffMemSize) : PffDataMessageNode;
+ {-copy extra data to partially received data message; if the message
+ is complete then returns a pointer to the node in the queue otherwise
+ returns nil. }
+ function Append(aMsg : longint;
+ aClientID : longint;
+ aRequestID : longint;
+ aTimeOut : TffWord32;
+ aError : longint;
+ aData : pointer;
+ aDataLen : TffMemSize;
+ aTotalLen : TffMemSize) : PffDataMessageNode;
+ {-append a data message to the queue; a copy of the Data
+ memory block is made; if the message is complete then
+ returns a pointer to the node in the queue otherwise
+ returns nil. }
+
+ function BeginRead : TffDataMessageQueue;
+ {-A thread must call this method to gain read access to the list.
+ Returns Self as a convenience. }
+
+ function BeginWrite : TffDataMessageQueue;
+ {-A thread must call this method to gain write access to the list.
+ Returns Self as a convenience.}
+
+ procedure EndRead;
+ {-A thread must call this method when it no longer needs read access
+ to the list. If it does not call this method, all writers will
+ be perpetually blocked. }
+
+ procedure EndWrite;
+ {-A thread must call this method when it no longer needs write access
+ to the list. If it does not call this method, all readers and writers
+ will be perpetualy blocked. }
+
+ function Examine : PFFDataMessage;
+ {-return the data message at the top of the queue; no pop
+ occurs, the message remains at the top of the queue}
+ function IsEmpty : boolean;
+ {-return true if there are no data messages in the queue}
+ function SoftPop : PFFDataMessage;
+ {-destroys the data message at the top of the queue; the data
+ memory block is _not_ destroyed}
+ procedure Pop;
+ {-destroys the data message at the top of the queue; the data
+ memory block is also freed}
+ procedure Remove(aNode : PffDataMessageNode;
+ const freeMessageData : boolean);
+ {-Use this method to remove a node from the queue. If you want this
+ method to free the message data then set the freeMessageData
+ parameter to True. Otherwise it will just dispose of the node
+ and assume somebody else is freeing the message data. }
+ procedure SendFrontToBack;
+ {-sends the data message at the front of the queue to the
+ back}
+
+ property Count : integer
+ read FCount;
+ {-number of messages in the queue}
+ property NotifyHandle : HWND
+ read FNotifyHandle write FNotifyHandle;
+ {-handle to notify that there are messages available}
+ end;
+
+function FFCreateSubMessage(aSubMsg : PffsmHeader;
+ aMsgID : longint;
+ aError : longint;
+ aDataType : TffNetMsgDataType;
+ aData : pointer;
+ aDataLen : longint) : PffsmHeader;
+ {-Create a submessage in a multipart message, return pointer to next
+ submessage}
+
+implementation
+
+{===helper routines==================================================}
+procedure NodeDestroy(aNode : PffDataMessageNode);
+begin
+ with aNode^ do begin
+ if assigned(dmnMsg) and
+ assigned(dmnMsg^.dmData) and
+ (dmnMsg^.dmDataLen > 0) then
+ FFFreeMem(dmnMsg^.dmData, dmnMsg^.dmDataLen);
+ FFFreeMem(dmnMsg, sizeOf(TffDataMessage));
+ end;
+ FFFreeMem(aNode, sizeOf(TffDataMessageNode));
+end;
+{--------}
+function StackIsEmpty(aStack : PffDataMessageNode) : boolean;
+begin
+ Result := (aStack^.dmnNext = nil);
+end;
+{--------}
+procedure StackPop(aStack : PffDataMessageNode;
+ var aNode : PffDataMessageNode);
+begin
+ aNode := aStack^.dmnNext;
+ aStack^.dmnNext := aNode^.dmnNext;
+end;
+{--------}
+procedure StackPush(aStack : PffDataMessageNode;
+ aNode : PffDataMessageNode);
+begin
+ aNode^.dmnNext := aStack^.dmnNext;
+ aStack^.dmnNext := aNode;
+end;
+{--------}
+procedure QAppend(aHead : PffDataMessageNode;
+ var aTail : PffDataMessageNode;
+ aNode : PffDataMessageNode);
+begin
+ aTail^.dmnNext := aNode;
+ aNode^.dmnPrev := aTail;
+ aTail := aNode;
+end;
+{--------}
+procedure QJump(aHead : PffDataMessageNode;
+ var aTail : PffDataMessageNode;
+ aNode : PffDataMessageNode);
+begin
+ aNode^.dmnPrev := aHead;
+ aNode^.dmnNext := aHead^.dmnNext;
+ if assigned(aHead^.dmnNext) then
+ aHead^.dmnNext^.dmnPrev := aNode;
+ aHead^.dmnNext := aNode;
+ if (aHead = aTail) then
+ aTail := aNode;
+end;
+{--------}
+procedure QPop(aHead : PffDataMessageNode;
+ var aTail : PffDataMessageNode;
+ var aNode : PffDataMessageNode);
+begin
+ aNode := aHead^.dmnNext;
+ aHead^.dmnNext := aNode^.dmnNext;
+ if assigned(aHead^.dmnNext) then
+ aHead^.dmnNext^.dmnPrev := aHead;
+ if (aNode = aTail) then
+ aTail := aHead;
+end;
+{--------}
+procedure QRemove(aHead : PffDataMessageNode;
+ var aTail : PffDataMessageNode;
+ aNode : PffDataMessageNode);
+begin
+ if assigned(aNode^.dmnPrev) then
+ aNode^.dmnPrev^.dmnNext := aNode^.dmnNext;
+ if assigned(aNode^.dmnNext) then
+ aNode^.dmnNext^.dmnPrev := aNode^.dmnPrev;
+ if (aNode = aTail) then
+ aTail := aHead;
+end;
+{====================================================================}
+
+
+{===TffDataMsgQueue==================================================}
+constructor TffDataMessageQueue.Create;
+begin
+ inherited Create;
+
+ {create the head and tail of the queue}
+ FFGetZeroMem(dmqHead, sizeof(TffDataMessageNode));
+ {dmqHead^.dmnNext := nil;}
+ dmqTail := dmqHead;
+ {FCount := 0;}
+
+ {create the stack for partial messages}
+ FFGetZeroMem(dmqStack, sizeof(TffDataMessageNode));
+ {dmqStack^.dmnNext := nil;}
+
+ {create the lock}
+ dmqPortal := TffReadWritePortal.Create;
+
+end;
+{--------}
+destructor TffDataMessageQueue.Destroy;
+begin
+ {pop all messages from main queue, dispose of it}
+ while not IsEmpty do
+ Pop;
+ NodeDestroy(dmqHead);
+ {pop all messages from partial message stack, dispose of it}
+ dmqPopStack;
+ NodeDestroy(dmqStack);
+ {clean up other stuff}
+ if assigned(dmqPortal) then
+ dmqPortal.Free;
+ inherited Destroy;
+end;
+{--------}
+function TffDataMessageQueue.AddToData(aMsg : longint;
+ aClientID : TffClientID;
+ aRequestID : longint;
+ aData : pointer;
+ aDataLen : TffMemSize) : PffDataMessageNode;
+var
+ Temp : PffDataMessageNode;
+ Dad : PffDataMessageNode;
+ BytesToCopy : longint;
+begin
+ Result := nil;
+ {find the partially created message in the stack}
+ Temp := dmqStack^.dmnNext;
+ Dad := dmqStack;
+ while (Temp <> nil) and
+ not ((Temp^.dmnMsg^.dmMsg = aMsg) and
+ (Temp^.dmnMsg^.dmClientID = aClientID) and
+ (Temp^.dmnMsg^.dmRequestID = aRequestID)) do begin
+ Dad := Temp;
+ Temp := Temp^.dmnNext;
+ end;
+ {if it ain't there forget it}
+ if (Temp = nil) then
+ Exit;
+
+ with Temp^ do begin
+ {move this next chunk o' data into the data message}
+ BytesToCopy := FFMinL(aDataLen, dmnMsg^.dmDataLen - dmnOffset);
+ Move(aData^, PffByteArray(dmnMsg^.dmData)^[dmnOffset], BytesToCopy);
+ inc(dmnOffset, BytesToCopy);
+ {if the data message is now complete..}
+ if (dmnOffset = dmnMsg^.dmDataLen) then begin
+ {..remove it from the stack}
+ Dad^.dmnNext := dmnNext;
+ {add it to the end of the queue}
+ QAppend(dmqHead, dmqTail, Temp);
+ Result := Temp;
+ inc(FCount);
+ end;
+ end;
+end;
+{--------}
+function TffDataMessageQueue.Append(aMsg : longint;
+ aClientID : longint;
+ aRequestID : longint;
+ aTimeOut : TffWord32;
+ aError : longint;
+ aData : pointer;
+ aDataLen : TffMemSize;
+ aTotalLen : TffMemSize) : PffDataMessageNode;
+var
+ Temp : PFFDataMessageNode;
+begin
+ Result := nil;
+ {get a new node}
+ FFGetZeroMem(Temp, sizeof(TffDataMessageNode));
+ FFGetZeroMem(Temp^.dmnMsg, sizeOf(TffDataMessage));
+ try
+ {fill the node with data, get the complete data buffer as well}
+ with Temp^ do begin
+ if (aTotalLen > 0) then begin
+ FFGetZeroMem(dmnMsg^.dmData, aTotalLen);
+ Move(aData^, dmnMsg^.dmData^, aDataLen);
+ end;
+ dmnMsg^.dmMsg := aMsg;
+ dmnMsg^.dmClientID := aClientID;
+ dmnMsg^.dmRequestId := aRequestID;
+ dmnMsg^.dmTime := GetTickCount;
+ dmnMsg^.dmRetryUntil := dmnMsg^.dmTime + aTimeOut;
+ dmnMsg^.dmErrorCode := aError;
+ dmnMsg^.dmDataLen := aTotalLen;
+ dmnOffset := aDataLen;
+ dmnProcessing := false;
+ end;
+ {add this new message to the relevant structure}
+ {if the data message is complete, add it to the queue}
+ if (aDataLen = aTotalLen) then begin
+ QAppend(dmqHead, dmqTail, Temp);
+ Result := Temp;
+ inc(FCount);
+ end
+ {if the data message is not all there, add it to the stack}
+ else begin
+ StackPush(dmqStack, Temp);
+ end;
+ except
+ if assigned(Temp^.dmnMsg^.dmData) then
+ FFFreeMem(Temp^.dmnMsg^.dmData, aTotalLen);
+ FFFreeMem(Temp^.dmnMsg, sizeOf(TffDataMessage));
+ FFFreeMem(Temp, sizeof(TffDataMessageNode));
+ raise;
+ end;{try..except}
+end;
+{--------}
+function TffDataMessageQueue.BeginRead : TffDataMessageQueue;
+begin
+ dmqPortal.BeginRead;
+ Result := Self;
+end;
+{--------}
+function TffDataMessageQueue.BeginWrite : TffDataMessageQueue;
+begin
+ dmqPortal.BeginWrite;
+ Result := Self;
+end;
+{--------}
+procedure TffDataMessageQueue.EndRead;
+begin
+ dmqPortal.EndRead;
+end;
+{--------}
+procedure TffDataMessageQueue.EndWrite;
+begin
+ dmqPortal.EndWrite;
+end;
+{--------}
+function TffDataMessageQueue.Examine : PFFDataMessage;
+begin
+ if (Count > 0) then begin
+ if dmqHead^.dmnNext^.dmnProcessing then
+ Result := nil
+ else begin
+ Result := dmqHead^.dmnNext^.dmnMsg;
+ if (Result^.dmMsg = ffnmMultiPartMessage) then
+ dmqSplitMultiPartMessage;
+ Result := dmqHead^.dmnNext^.dmnMsg;
+ dmqHead^.dmnNext^.dmnProcessing := true;
+ end
+ end
+ else
+ Result := nil;
+end;
+{--------}
+function TffDataMessageQueue.IsEmpty : boolean;
+begin
+ Result := (FCount = 0);
+end;
+{--------}
+function TffDataMessageQueue.SoftPop : PFFDataMessage;
+var
+ Temp : PFFDataMessageNode;
+begin
+ {nothing to do if there are no messages}
+ if (Count > 0) then begin
+ { Check for multipart messages. }
+ if (dmqHead^.dmnNext^.dmnMsg^.dmMsg = ffnmMultiPartMessage) then
+ dmqSplitMultiPartMessage;
+ {pop the topmost message}
+ QPop(dmqHead, dmqTail, Temp);
+ dec(FCount);
+ Temp^.dmnProcessing := false;
+ Result := Temp^.dmnMsg;
+ FFFreeMem(Temp, sizeOf(TffDataMessageNode));
+ end else
+ Result := nil;
+end;
+{--------}
+procedure TffDataMessageQueue.Pop;
+var
+ Temp : PFFDataMessageNode;
+begin
+ {nothing to do if there are no messages}
+ if (Count > 0) then begin
+ {pop the topmost message}
+ QPop(dmqHead, dmqTail, Temp);
+ dec(FCount);
+ Temp^.dmnProcessing := false;
+ NodeDestroy(Temp)
+ end;
+end;
+{--------}
+procedure TffDataMessageQueue.Remove(aNode : PffDataMessageNode;
+ const freeMessageData : boolean);
+begin
+ QRemove(dmqHead, dmqTail, aNode);
+ if freeMessageData then
+ NodeDestroy(aNode)
+ else
+ FFFreeMem(aNode, sizeOf(TffDataMessageNode));
+ dec(FCount);
+end;
+{--------}
+procedure TffDataMessageQueue.dmqPopStack;
+var
+ Temp : PFFDataMessageNode;
+begin
+ while not StackIsEmpty(dmqStack) do begin
+ StackPop(dmqStack, Temp);
+ NodeDestroy(Temp);
+ end;
+end;
+{--------}
+procedure TffDataMessageQueue.SendFrontToBack;
+var
+ Temp : PFFDataMessageNode;
+begin
+ {note: there's nothing to do if there are no data messages in the
+ queue, similarly if there's only one data message (it's
+ already *at* the back of the queue)}
+ if (Count > 1) then begin
+ Temp := dmqHead^.dmnNext;
+ dmqHead^.dmnNext := Temp^.dmnNext;
+ Temp^.dmnNext := nil;
+ dmqTail^.dmnNext := Temp;
+ dmqTail := Temp;
+ end;
+end;
+{--------}
+procedure TffDataMessageQueue.dmqSplitMultiPartMessage;
+var
+ MPMsgNode : PffDataMessageNode;
+ Stack : PffDataMessageNode;
+ Temp : PffDataMessageNode;
+ Offset : longint;
+ SubMsgHdr : PffsmHeader;
+ FirstMsg : boolean;
+begin
+ {we assume that the message at the top of the queue is a multipart
+ message; we need to split this into the relevant messages and add
+ them to the queue (as queue jumpers)}
+ {pop off the multipart message}
+ QPop(dmqHead, dmqTail, MPMsgNode);
+ dec(FCount);
+ {create a stack to push the sub-messages onto first; think about it:
+ we'll be creating messages from the front of the multipart message
+ to the back and yet we must push them onto the queue as queue
+ jumpers from the back to the front, so we push them onto an
+ intermediary stack and then pop stack/queue jump}
+ FFGetZeroMem(Stack, sizeof(TffDataMessageNode));
+ try
+ {prepare for the loop}
+ FirstMsg := true;
+ Offset := 0;
+ SubMsgHdr := PffsmHeader(MPMsgNode^.dmnMsg^.dmData);
+ {loop through the sub-messages and create a new message for each,
+ push onto temp stack}
+ while (Offset < MPMsgNode^.dmnMsg^.dmDataLen) do begin
+ FFGetZeroMem(Temp, sizeof(TffDataMessageNode));
+ FFGetZeroMem(Temp^.dmnMsg, sizeOf(TffDataMessage));
+ try
+ {fill the node with data, get the complete data buffer as well}
+ with Temp^, SubMsgHdr^ do begin
+ dmnMsg^.dmDataLen := smhReplyLen - ffc_SubMsgHeaderSize;
+ if (dmnMsg^.dmDataLen > 0) then begin
+ if (smhDataType = nmdByteArray) then begin
+ FFGetMem(dmnMsg^.dmData, dmnMsg^.dmDataLen);
+ Move(smhData, dmnMsg^.dmData^, dmnMsg^.dmDataLen);
+ end
+ else begin
+ dmnMsg^.dmData := pointer(TMemoryStream.Create);
+ TMemoryStream(dmnMsg^.dmData).Write(smhData, dmnMsg^.dmDataLen);
+ end;
+ end;
+ dmnMsg^.dmMsg := smhMsgID;
+ dmnMsg^.dmClientID := MPMsgNode^.dmnMsg^.dmClientID;
+ dmnMsg^.dmTime := MPMsgNode^.dmnMsg^.dmTime;
+ dmnMsg^.dmRetryUntil := MPMsgNode^.dmnMsg^.dmRetryUntil;
+ dmnMsg^.dmErrorCode := smhErrorCode;
+ dmnOffset := smhReplyLen;
+ dmnProcessing := false;
+ end;
+ StackPush(Stack, Temp);
+ except
+ NodeDestroy(Temp);
+ raise;
+ end;
+ {advance to next submessage}
+ if FirstMsg and (SubMsgHdr^.smhErrorCode <> 0) then
+ Break;
+ FirstMsg := false;
+ inc(Offset, SubMsgHdr^.smhReplyLen);
+ SubMsgHdr := PffsmHeader(PAnsiChar(SubMsgHdr) + SubMsgHdr^.smhReplyLen);
+ end;
+ {destroy the original multipart message}
+ NodeDestroy(MPMsgNode);
+ {transfer messages over from stack to queue}
+ while not StackIsEmpty(Stack) do begin
+ StackPop(Stack, Temp);
+ QJump(dmqHead, dmqTail, Temp);
+ inc(FCount);
+ end;
+ finally
+ while not StackIsEmpty(Stack) do begin
+ StackPop(Stack, Temp);
+ NodeDestroy(Temp);
+ end;
+ FFFreeMem(Stack, sizeof(TffDataMessageNode));
+ end;{try..finally}
+end;
+{====================================================================}
+
+
+{===CreateSubMessage=================================================}
+function FFCreateSubMessage(aSubMsg : PffsmHeader;
+ aMsgID : longint;
+ aError : longint;
+ aDataType : TffNetMsgDataType;
+ aData : pointer;
+ aDataLen : longint) : PffsmHeader;
+begin
+ with aSubMsg^ do begin
+ smhMsgID := aMsgID;
+ smhReplyLen := ffc_SubMsgHeaderSize + aDataLen;
+ smhErrorCode := aError;
+ smhDataType := aDataType;
+ if (aData <> @smhData) and (aDataLen <> 0) then
+ if (aData = nil) then
+ Move(aData^, smhData, aDataLen)
+ else
+ FillChar(smhData, aDataLen, 0);
+ Result := PffsmHeader(PAnsiChar(aSubMsg) + smhReplyLen);
+ end;
+end;
+{====================================================================}
+
+end.
diff --git a/components/flashfiler/sourcelaz/fffile.inc b/components/flashfiler/sourcelaz/fffile.inc
new file mode 100644
index 000000000..a94e5c2e0
--- /dev/null
+++ b/components/flashfiler/sourcelaz/fffile.inc
@@ -0,0 +1,300 @@
+{*********************************************************}
+{* FlashFiler: 32-bit file access routines include file *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{===File access routines (primitives)================================}
+
+procedure FFCloseFilePrim32(aFI : PffFileInfo);
+var
+ WinError : TffWord32;
+begin
+ {$IFDEF Tracing}
+ FFAddTrace(foClose, aFI^.fiHandle, sizeof(aFI^.fiHandle));
+ {$ENDIF}
+ {close the file handle}
+ if not CloseHandle(aFI^.fiHandle) then begin
+ WinError := GetLastError;
+ {$IFDEF Tracing}
+ FFAddTrace(foUnknown, WinError, sizeof(WinError));
+ {$ENDIF}
+ FFRaiseException(EffServerException, ffStrResServer, fferrCloseFailed,
+ [aFI.fiName^, WinError, SysErrorMessage(WinError)]);
+ end;
+end;
+{--------}
+procedure FFFlushFilePrim32(aFI : PffFileInfo);
+var
+ WinError : TffWord32;
+begin
+ {$IFDEF Tracing}
+ FFAddTrace(foFlush, aFI^.fiHandle, sizeof(aFI^.fiHandle));
+ {$ENDIF}
+ if not FlushFileBuffers(aFI^.fiHandle) then begin
+ WinError := GetLastError;
+ {$IFDEF Tracing}
+ FFAddTrace(foUnknown, WinError, sizeof(WinError));
+ {$ENDIF}
+ FFRaiseException(EffServerException, ffStrResServer, fferrFlushFailed,
+ [aFI.fiName^, WinError, SysErrorMessage(WinError)]);
+ end;
+end;
+{--------}
+function FFGetPositionFilePrim32(aFI : PffFileInfo) : TffInt64;
+var
+ WinError : TffWord32;
+ HighWord : TffWord32;
+ {$IFDEF Tracing}
+ Params : array [0..1] of Longint;
+ {$ENDIF}
+begin
+ {$IFDEF Tracing}
+ Params[0] := aFI^.fiHandle;
+ Params[1] := 0;
+ FFAddTrace(foSeek, Params, sizeof(Params));
+ {$ENDIF}
+ HighWord := 0;
+ result.iLow := SetFilePointer(aFI^.fiHandle, 0, @HighWord , FILE_CURRENT);
+ if (Result.iLow = $FFFFFFFF) then begin
+ WinError := GetLastError;
+ {$IFDEF Tracing}
+ FFAddTrace(foUnknown, WinError, sizeof(WinError));
+ {$ENDIF}
+ FFRaiseException(EffServerException, ffStrResServer, fferrSeekFailed,
+ [aFI.fiName^, 0, 0, WinError, SysErrorMessage(WinError)]);
+ end;
+ result.ihigh := HighWord;
+ {$IFDEF Tracing}
+ FFAddTrace(foUnknown, Result, sizeof(Result));
+ {$ENDIF}
+end;
+{--------}
+function FFOpenFilePrim32(aName : PAnsiChar;
+ aOpenMode : TffOpenMode;
+ aShareMode : TffShareMode;
+ aWriteThru : Boolean;
+ aCreateFile : Boolean) : THandle;
+var
+ AttrFlags : TffWord32;
+ CreateMode : TffWord32;
+ OpenMode : TffWord32;
+ ShareMode : TffWord32;
+ WinError : TffWord32;
+begin
+ {$IFDEF Tracing}
+ FFAddTrace(foOpen, aName^, succ(StrLen(aName)));
+ {$ENDIF}
+ {initialise parameters to CreateFile}
+ if (aOpenMode = omReadOnly) then
+ OpenMode := GENERIC_READ
+ else
+ OpenMode := GENERIC_READ or GENERIC_WRITE;
+ if (aShareMode = smExclusive) then
+ ShareMode := 0
+ else if (aShareMode = smShareRead) then {!!.06}
+ ShareMode := FILE_SHARE_READ {!!.06}
+ else
+ ShareMode := FILE_SHARE_READ or FILE_SHARE_WRITE;
+ if aCreateFile then
+ CreateMode := CREATE_ALWAYS
+ else
+ CreateMode := OPEN_EXISTING;
+ if aWriteThru then
+ AttrFlags := FILE_ATTRIBUTE_NORMAL or FILE_FLAG_WRITE_THROUGH
+ else
+ AttrFlags := FILE_ATTRIBUTE_NORMAL;
+ {open the file}
+ Result := CreateFile(aName,
+ OpenMode,
+ ShareMode,
+ nil, {!! Security attrs}
+ CreateMode,
+ AttrFlags,
+ 0);
+ if (Result = INVALID_HANDLE_VALUE) then begin
+ WinError := GetLastError;
+ {$IFDEF Tracing}
+ FFAddTrace(foUnknown, WinError, sizeof(WinError));
+ {$ENDIF}
+ FFRaiseException(EffServerException, ffStrResServer, fferrOpenFailed,
+ [aName, WinError, SysErrorMessage(WinError)]);
+ end;
+ {$IFDEF Tracing}
+ FFAddTrace(foUnknown, Result, sizeof(Result));
+ {$ENDIF}
+end;
+{--------}
+procedure FFPositionFilePrim32(aFI : PffFileInfo;
+ const aOffset : TffInt64);
+var
+ SeekResult : TffWord32;
+ WinError : TffWord32;
+ {$IFDEF Tracing}
+ Params : array [0..1] of Longint;
+ {$ENDIF}
+begin
+ {$IFDEF Tracing}
+ Params[0] := aFI^.fiHandle;
+ Params[1] := aOffset.iLow;
+ FFAddTrace(foSeek, Params, sizeof(Params));
+ {$ENDIF}
+ SeekResult := SetFilePointer(aFI^.fiHandle, aOffset.iLow, @aOffset.iHigh,
+ FILE_BEGIN);
+ if (SeekResult = $FFFFFFFF) then begin
+ WinError := GetLastError;
+ {$IFDEF Tracing}
+ FFAddTrace(foUnknown, WinError, sizeof(WinError));
+ {$ENDIF}
+ FFRaiseException(EffServerException, ffStrResServer, fferrSeekFailed,
+ [aFI.fiName^, aOffset.iLow, aOffset.iHigh, WinError,
+ SysErrorMessage(WinError)]);
+ end;
+ {$IFDEF Tracing}
+ FFAddTrace(foUnknown, SeekResult, sizeof(SeekResult));
+ {$ENDIF}
+end;
+{--------}
+function FFPositionFileEOFPrim32(aFI : PffFileInfo) : TffInt64;
+var
+ WinError : TffWord32;
+ highWord : TffWord32;
+ {$IFDEF Tracing}
+ Params : array [0..1] of Longint;
+ {$ENDIF}
+begin
+ {$IFDEF Tracing}
+ Params[0] := aFI^.fiHandle;
+ Params[1] := -1;
+ FFAddTrace(foSeek, Params, sizeof(Params));
+ {$ENDIF}
+ highWord := 0;
+ Result.iLow := SetFilePointer(aFI^.fiHandle, 0, @highWord, FILE_END);
+ if (Result.iLow = $FFFFFFFF) then begin
+ WinError := GetLastError;
+ {$IFDEF Tracing}
+ FFAddTrace(foUnknown, WinError, sizeof(WinError));
+ {$ENDIF}
+ FFRaiseException(EffServerException, ffStrResServer, fferrSeekFailed,
+ [aFI.fiName^, 0, 0, WinError, SysErrorMessage(WinError)]);
+ end;
+ result.iHigh := HighWord;
+ {$IFDEF Tracing}
+ FFAddTrace(foUnknown, Result, sizeof(Result));
+ {$ENDIF}
+end;
+{--------}
+function FFReadFilePrim32(aFI : PffFileInfo;
+ aToRead : TffWord32;
+ var aBuffer) : TffWord32;
+var
+ WinError : TffWord32;
+ BytesRead : DWORD;
+ {$IFDEF Tracing}
+ Params : array [0..1] of Longint;
+ {$ENDIF}
+begin
+ {$IFDEF Tracing}
+ Params[0] := aFI^.fiHandle;
+ Params[1] := aToRead;
+ FFAddTrace(foRead, Params, sizeof(Params));
+ {$ENDIF}
+ if not ReadFile(aFI^.fiHandle, aBuffer, aToRead, BytesRead, nil) then begin
+ WinError := GetLastError;
+ {$IFDEF Tracing}
+ FFAddTrace(foUnknown, WinError, sizeof(WinError));
+ {$ENDIF}
+ FFRaiseException(EffServerException, ffStrResServer, fferrReadFailed,
+ [aFI.fiName^, WinError, SysErrorMessage(WinError)]);
+ end;
+ Result := BytesRead;
+ {$IFDEF Tracing}
+ FFAddTrace(foUnknown, Result, sizeof(Result));
+ {$ENDIF}
+end;
+{--------}
+procedure FFSetEOFPrim32(aFI : PffFileInfo;
+ const aOffset : TffInt64);
+var
+ WinError : TffWord32;
+ {$IFDEF Tracing}
+ Params : array [0..1] of Longint;
+ {$ENDIF}
+begin
+ {$IFDEF Tracing}
+ Params[0] := aFI^.fiHandle;
+ Params[1] := aOffset.iLow;
+ FFAddTrace(foSetEOF, Params, sizeof(Params));
+ {$ENDIF}
+ FFPositionFilePrim(aFI, aOffset);
+ if not Windows.SetEndOfFile(aFI^.fiHandle) then begin
+ WinError := GetLastError;
+ {$IFDEF Tracing}
+ FFAddTrace(foUnknown, WinError, sizeof(WinError));
+ {$ENDIF}
+ FFRaiseException(EffServerException, ffStrResServer, fferrSetEOFFailed,
+ [aFI.fiName^, WinError, SysErrorMessage(WinError)]);
+ end;
+end;
+{--------}
+function FFWriteFilePrim32(aFI : PffFileInfo;
+ aToWrite : TffWord32;
+ const aBuffer) : TffWord32;
+var
+ WinError : TffWord32;
+ BytesWritten : DWORD;
+ {$IFDEF Tracing}
+ Params : array [0..2] of Longint;
+ {$ENDIF}
+begin
+ {$IFDEF Tracing}
+ Params[0] := aFI^.fiHandle;
+ Params[1] := aToWrite;
+ FFAddTrace(foWrite, Params, sizeof(Params));
+ {$ENDIF}
+ if not WriteFile(aFI^.fiHandle, aBuffer, aToWrite, BytesWritten, nil) then begin
+ WinError := GetLastError;
+ {$IFDEF Tracing}
+ FFAddTrace(foUnknown, WinError, sizeof(WinError));
+ {$ENDIF}
+ FFRaiseException(EffServerException, ffStrResServer, fferrWriteFailed,
+ [aFI.fiName^, WinError, SysErrorMessage(WinError)]);
+ end;
+ Result := BytesWritten;
+ {$IFDEF Tracing}
+ FFAddTrace(foUnknown, Result, sizeof(Result));
+ {$ENDIF}
+end;
+{====================================================================}
+
+
+{===Default Sleep routine============================================}
+procedure FFSleepPrim32(MilliSecs : Longint);
+begin
+ Windows.Sleep(MilliSecs);
+end;
+{====================================================================}
+
diff --git a/components/flashfiler/sourcelaz/fffile.pas b/components/flashfiler/sourcelaz/fffile.pas
new file mode 100644
index 000000000..8be8b80cf
--- /dev/null
+++ b/components/flashfiler/sourcelaz/fffile.pas
@@ -0,0 +1,415 @@
+{*********************************************************}
+{* FlashFiler: Low level file I/O routines *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+{.$DEFINE Tracing}
+
+unit fffile;
+
+interface
+
+uses
+ Windows,
+ SysUtils,
+ ffconst,
+ ffllbase,
+ ffsrmgr,
+ ffllexcp,
+ ffsrbase;
+
+procedure FileProcsInitialize;
+
+{$IFDEF Tracing}
+{---File Access Tracing---}
+type
+ TffTraceString = string[59];
+procedure FFStartTracing(BufferSize : longint);
+procedure FFDumpTrace(FileName : string);
+procedure FFAddUserTrace(const ParamRec; PRSize : word);
+procedure FFAddUserTraceStr(const S : TffTraceString);
+{$ENDIF}
+
+implementation
+
+{$IFDEF Tracing}
+type
+ TffFileOp = (foUnknown, foClose, foFlush, foLock, foOpen, foRead,
+ foSeek, foSetEOF, foUnlock, foWrite, foGeneral,
+ foUserTrace, foUserTraceStr);
+
+procedure FFAddTrace(Op : TffFileOp; const ParamRec; PRSize : word); forward;
+{$ENDIF}
+
+
+{===File Access Primitives===========================================}
+{$I FFFile.INC}
+{====================================================================}
+
+
+{$IFDEF Tracing}
+{===File Access Tracing==============================================}
+type
+ PTraceBuffer = ^TTraceBuffer;
+ TTraceBuffer = array [0..32767] of byte;
+ TTraceEntry = record
+ teWhat : word;
+ teSize : word;
+ teTime : TffWord32;
+ end;
+var
+ TraceBuffer : PTraceBuffer;
+ TBSize : longint;
+ TBHead : longint;
+ TBTail : longint;
+ TracePadlock : TffPadlock;
+{--------}
+procedure FFStartTracing(BufferSize : longint);
+ const
+ MaxBufferSize = 64*1024;
+ begin
+ if (TraceBuffer = nil) then
+ begin
+ if (BufferSize <= 0) then
+ TBSize := 1024
+ else if (BufferSize > MaxBufferSize) then
+ TBSize := MaxBufferSize
+ else
+ TBSize := (BufferSize + 1023) and (not 1023);
+ GetMem(TraceBuffer, TBSize);
+ end;
+ TBHead := 0;
+ TBTail := 0;
+ TracePadLock := TffPadlock.Create;
+ end;
+{--------}
+procedure FFDumpTrace(FileName : string);
+ type
+ PHandyBuffer = ^THandyBuffer;
+ THandyBuffer = record
+ case byte of
+ 0 : (L : array [0..127] of longint);
+ 1 : (B : array [0..511] of byte);
+ 2 : (C : array [0..511] of AnsiChar);
+ 3 : (S : string[255]);
+ end;
+ {------}
+ procedure Read4Bytes(var B);
+ begin
+ Move(TraceBuffer^[TBTail], B, 4);
+ inc(TBTail, 4);
+ if (TBTail >= TBSize) then
+ dec(TBTail, TBSize);
+ end;
+ {------}
+ procedure GrowBuffer(var GB : PHandyBuffer; var CurSize : word; NewSize : word);
+ begin
+ if (NewSize > CurSize) then
+ begin
+ if (GB <> nil) then
+ FreeMem(GB, CurSize);
+ GetMem(GB, NewSize);
+ CurSize := NewSize;
+ end;
+ end;
+ {------}
+ procedure PrintEntry(var F : text; const TE : TTraceEntry; GB : PHandyBuffer);
+ var
+ FileName : TffMaxPathZ;
+ Offset : integer;
+ RemBytes : integer;
+ i, j : integer;
+ begin
+ {print the time in hex}
+ write(F, Format('%x8', [TE.teTime]));
+ {print the rest}
+ case TffFileOp(TE.teWhat) of
+ foUnknown :
+ begin
+ if (((TE.teSize+3) and $FFFC) = 4) then
+ writeln(F, Format(' ..(result): %d ($%0:x)', [GB^.L[0]]))
+ else
+ writeln(F, ' [unknown]');
+ end;
+ foGeneral :
+ begin
+ writeln(F, ' [general]');
+ end;
+ foOpen :
+ begin
+ writeln(F, ' [open file]');
+ StrCopy(FileName, @GB^.L[0]);
+ writeln(F, Format(' ..name: %s', [FileName]));
+ end;
+ foSeek :
+ begin
+ writeln(F, ' [position file]');
+ writeln(F, Format(' ..handle: %d ($%0:x)', [GB^.L[0]]));
+ if (GB^.L[1] = -1) then
+ writeln(F, ' ..position: End-Of-File')
+ else
+ writeln(F, Format(' ..position: %d ($%0:x)', [GB^.L[1]]));
+ end;
+ foSetEOF :
+ begin
+ writeln(F, ' [truncate file]');
+ writeln(F, Format(' ..handle: %d ($%0:x)', [GB^.L[0]]));
+ writeln(F, Format(' ..position: %d ($%0:x)', [GB^.L[1]]));
+ end;
+ foFlush :
+ begin
+ writeln(F, ' [flush file]');
+ writeln(F, Format(' ..handle: %d ($%0:x)', [GB^.L[0]]));
+ end;
+ foRead :
+ begin
+ writeln(F, ' [read file]');
+ writeln(F, Format(' ..handle: %d ($%0:x)', [GB^.L[0]]));
+ writeln(F, Format(' ..bytes to read: %d ($%0:x)', [GB^.L[1]]));
+ end;
+ foWrite :
+ begin
+ writeln(F, ' [write file]');
+ writeln(F, Format(' ..handle: %d ($%0:x)', [GB^.L[0]]));
+ writeln(F, Format(' ..bytes to write: %d ($%0:x)', [GB^.L[1]]));
+ end;
+ foLock :
+ begin
+ writeln(F, ' [lock file]');
+ writeln(F, Format(' ..handle: %d ($%0:x)', [GB^.L[0]]));
+ writeln(F, Format(' ..offset: %d ($%0:x)', [GB^.L[1]]));
+ writeln(F, Format(' ..bytes to lock: %d ($%0:x)', [GB^.L[2]]));
+ end;
+ foUnlock :
+ begin
+ writeln(F, ' [unlock file]');
+ writeln(F, Format(' ..handle: %d ($%0:x)', [GB^.L[0]]));
+ writeln(F, Format(' ..offset: %d ($%0:x)', [GB^.L[1]]));
+ writeln(F, Format(' ..bytes to unlock: %d ($%0:x)', [GB^.L[2]]));
+ end;
+ foClose :
+ begin
+ writeln(F, ' [close file]');
+ writeln(F, Format(' ..handle: %d ($%0:x)', [GB^.L[0]]));
+ end;
+ foUserTrace :
+ begin
+ writeln(F, Format(' [user trace entry], %d bytes', [TE.teSize]));
+ Offset := 0;
+ if (TE.teSize >= 8) then
+ for i := 0 to pred(TE.teSize div 8) do
+ begin
+ write(F, ' ');
+ for j := 0 to 7 do
+ write(F, Format('%.2x ', [GB^.B[Offset+j]]));
+ write(F, ' [');
+ for j := 0 to 7 do
+ write(F, Format('%s', [GB^.C[Offset+j]]));
+ writeln(F, ']');
+ inc(Offset, 8);
+ end;
+ RemBytes := TE.teSize mod 8;
+ if (RemBytes > 0) then
+ begin
+ write(F, ' ');
+ for j := 0 to pred(RemBytes) do
+ write(F, Format('%.2x ', [GB^.B[Offset+j]]));
+ for j := RemBytes to 7 do
+ write(F, ' ');
+ write(F, ' [');
+ for j := 0 to pred(RemBytes) do
+ write(F, Format('%s', [GB^.C[Offset+j]]));
+ for j := RemBytes to 7 do
+ write(F, ' ');
+ writeln(F, ']');
+ end;
+ end;
+ foUserTraceStr :
+ begin
+ writeln(F, Format(' [USER: %s]', [GB^.S]));
+ end;
+ end;{case}
+ end;
+ {------}
+ var
+ F : text;
+ GenBuf : PHandyBuffer;
+ GenBufSize : word;
+ TraceEntry : TTraceEntry;
+ AdjSize : word;
+ i : word;
+ begin
+ if (TraceBuffer <> nil) then
+ begin
+ {..write it to file..}
+ GenBuf := nil;
+ GenBufSize := 0;
+ System.Assign(F, FileName);
+ System.Rewrite(F);
+ if (TBTail = TBHead) then
+ writeln(F, '***no entries***')
+ else
+ repeat
+ Read4Bytes(TraceEntry);
+ Read4Bytes(TraceEntry.teTime);
+ AdjSize := (TraceEntry.teSize + 3) and $FFFC;
+ GrowBuffer(GenBuf, GenBufSize, AdjSize);
+ for i := 0 to pred(AdjSize div 4) do
+ Read4Bytes(GenBuf^.L[i]);
+ PrintEntry(F, TraceEntry, GenBuf);
+ until TBTail = TBHead;
+ System.Close(F);
+ FreeMem(GenBuf, GenBufSize);
+ FreeMem(TraceBuffer, TBSize);
+ TraceBuffer := nil;
+ TracePadLock.Free;
+ end;
+ end;
+{--------}
+procedure FFAddTrace(Op : TffFileOp; const ParamRec; PRSize : word);
+ {------}
+ procedure Write4Bytes(const B);
+ begin
+ Move(B, TraceBuffer^[TBHead], 4);
+ inc(TBHead, 4);
+ if (TBHead >= TBSize) then
+ dec(TBHead, TBSize);
+ end;
+ {------}
+ procedure WriteXBytes(const B; Size : word);
+ begin
+ FillChar(TraceBuffer^[TBHead], 4, 0);
+ Move(B, TraceBuffer^[TBHead], Size);
+ inc(TBHead, 4);
+ if (TBHead >= TBSize) then
+ dec(TBHead, TBSize);
+ end;
+ {------}
+ var
+ TraceEntry : TTraceEntry;
+ AdjSize : word;
+ i : word;
+ BytesFree : longint;
+ PRasLongints : array [1..128] of longint absolute ParamRec;
+ begin
+ if (TraceBuffer <> nil) then
+ begin
+ {calc the size rounded to nearest 4 bytes}
+ AdjSize := (PRSize + 3) and $FFFC;
+ {make sure that there's enough space in the trace buffer}
+ repeat
+ {calculate the number of bytes free in the trace buffer}
+ if (TBTail = TBHead) then
+ BytesFree := TBSize
+ else if (TBTail < TBHead) then
+ BytesFree := (TBSize - TBHead) + TBTail
+ else
+ BytesFree := TBTail - TBHead;
+ {if not enough room for this entry..}
+ if (BytesFree <= AdjSize + sizeof(TraceEntry)) then
+ begin
+ {..advance TBTail over oldest entry}
+ Move(TraceBuffer^[TBTail], TraceEntry, 4);
+ inc(TBTail, ((TraceEntry.teSize + 3) and $FFFC) + sizeof(TraceEntry));
+ if (TBTail >= TBSize) then
+ dec(TBTail, TBSize);
+ end;
+ until (BytesFree > AdjSize + sizeof(TraceEntry));
+ with TraceEntry do
+ begin
+ teWhat := ord(Op);
+ teSize := PRSize;
+ teTime := GetTickCount;
+ end;
+ Write4Bytes(TraceEntry);
+ Write4Bytes(TraceEntry.teTime);
+ for i := 1 to pred(AdjSize div 4) do
+ Write4Bytes(PRasLongints[i]);
+ if (AdjSize = PRSize) then
+ Write4Bytes(PRasLongints[AdjSize div 4])
+ else
+ WriteXBytes(PRasLongints[AdjSize div 4], 4 + PRSize - AdjSize);
+ end;
+ end;
+{--------}
+procedure FFGetTraceAccess;
+ begin
+ TracePadLock.Locked := true;
+ end;
+{--------}
+procedure FFFreeTraceAccess;
+ begin
+ TracePadLock.Locked := false;
+ end;
+{--------}
+procedure FFAddUserTrace(const ParamRec; PRSize : word);
+ begin
+ if (TraceBuffer <> nil) then
+ begin
+ FFGetTraceAccess;
+ if (PRSize > 128) then
+ PRSize := 128;
+ FFAddTrace(foUserTrace, ParamRec, PRSize);
+ FFFreeTraceAccess;
+ end;
+ end;
+{--------}
+procedure FFAddUserTraceStr(const S : TffTraceString);
+ begin
+ if (TraceBuffer <> nil) then
+ begin
+ FFGetTraceAccess;
+ FFAddTrace(foUserTraceStr, S, length(S)+1);
+ FFFreeTraceAccess;
+ end;
+ end;
+{====================================================================}
+{$ENDIF}
+
+
+{===Unit initialization==============================================}
+procedure FileProcsInitialize;
+begin
+ FFCloseFilePrim := FFCloseFilePrim32;
+ FFFlushFilePrim := FFFlushFilePrim32;
+ FFGetPositionFilePrim := FFGetPositionFilePrim32;
+// FFLockFilePrim := FFLockFilePrim32;
+ FFOpenFilePrim := FFOpenFilePrim32;
+ FFPositionFilePrim := FFPositionFilePrim32;
+ FFPositionFileEOFPrim := FFPositionFileEOFPrim32;
+ FFReadFilePrim := FFReadFilePrim32;
+ FFSetEOFPrim := FFSetEOFPrim32;
+ FFSleepPrim := FFSleepPrim32;
+// FFUnlockFilePrim := FFUnlockFilePrim32;
+ FFWriteFilePrim := FFWriteFilePrim32;
+ {$IFDEF Tracing}
+ TraceBuffer := nil;
+ {$ENDIF}
+end;
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffhash.pas b/components/flashfiler/sourcelaz/ffhash.pas
new file mode 100644
index 000000000..87664ea50
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffhash.pas
@@ -0,0 +1,985 @@
+{*********************************************************}
+{* FlashFiler: Hash table & calculation routines *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+{.$DEFINE CompileDebugCode}
+unit ffhash;
+
+interface
+
+uses
+ SysUtils,
+ ffllbase;
+
+type
+
+ { forward declarations }
+ TffBaseHashTable = class;
+
+ TffHashIteratorFunction = procedure(aKey : longInt; aData : pointer;
+ const cookie1, cookie2, cookie3 : TffWord32) of object;
+ { Used by TffHash.Iterate. Called for each item in the hash
+ table. }
+
+ TffHash64IteratorFunction = procedure(aKey : TffInt64; aData : pointer;
+ const cookie1, cookie2, cookie3 : TffWord32) of object;
+ { Used by TffHash64.Iterate. Called for each item in the hash
+ table. }
+ { This type defines the kind of procedure called when the data associated
+ with a hash table entry must be freed by the owning object. }
+ TffDisposeDataProc = procedure(Sender : TffBaseHashTable; AData : Pointer) of object;
+
+
+ { This class is used to store key/value pairs within the hash table. }
+ { Assumption: The TffHashNode.ExtraData property is not used for
+ any other purpose. }
+ TffHashNode = class(TffObject)
+ protected
+ fhKey : Pointer;
+ fhNext : TffHashNode; { The next node in this hash table slot. }
+ fhValue : Pointer;
+ public
+ ExtraData : pointer;
+ end;
+
+
+ { This class is a simple hash table implementation. It assumes the
+ key values will be long integers and the associated data will be a
+ pointer. It assumes the owning object will properly destroy the
+ data associated with each hash table entry by assigning a disposal
+ function to the OnDispose property of this class.
+
+ This implementation is thread-safe.
+ }
+
+ TffBaseHashTable = class(TffObject)
+ protected {private}
+ FAtMin : boolean;
+ FCanShrink : boolean;
+ FCount : Integer;
+ FHashSizeIndex : integer;
+ FMinSizeIndex : Integer;
+ FOnDisposeData : TffDisposeDataProc;
+ FTable : TffPointerList;
+ protected
+ function fhAddPrim(aKey : Pointer;
+ aValue : Pointer) : Boolean;
+ {-Use this method to add an entry to the hash table. Returns True if
+ the key/value pair was added or False if the key is already in the
+ hash table. }
+
+ function fhCompareKey(const aKey1 : Pointer;
+ const aKey2 : Pointer) : Boolean; virtual;
+
+ function fhCreateNode: TffHashNode; virtual;
+
+ procedure fhDeletePrim(const AKey : Pointer;
+ const AInx : Integer);
+ {-This method is used to delete an entry in the hash table. aInx
+ must specify the exact slot within the table containing the entry.
+ This method will then run through the associated entry list and
+ locate the exact hash node using aKey. }
+
+ function fhFindPrim(const AKey : Pointer;
+ var AInx : Integer;
+ var ANode : TffHashNode) : Boolean;
+ {-This method is used to find an entry within the hash table.
+ It fills aInx with the index of the key within the hash table and
+ aNode with a pointer to the hash node storing the entry. }
+
+ procedure fhFreeKeyPrim(aKey : pointer); virtual; abstract;
+ {-Use this method to free a key created for a TffHashNode.
+ Called from fhDeletePrim. }
+
+ function fhGetIndex(const AKey : Pointer;
+ const ACount : Integer) : Integer; virtual; abstract;
+ {calculate the index, ie hash, of the key}
+
+ function fhMoveNodePrim(OldTable : TffPointerList;
+ OldNodeInx : integer;
+ Node : TffHashNode): Boolean;
+ {-Used by fhResizeTable to move a node from an old table to the new,
+ resized table. Assumption: Resized table has enough room to hold
+ the new node. }
+
+ procedure fhResizeTable(const increase : boolean); virtual;
+ {-Resize the table. If you want the table to increase to the next
+ level of capacity, set increase to True. If you want the table
+ to decrease to the next level of capacity, set increase to False. }
+ public
+ constructor Create(initialSizeIndex : integer); virtual;
+ {-This method creates and initializes the hash table. initialSizeIndex
+ specifies the index of array ffc_HashSizes that is to specify the
+ initial number of slots within the hash table. }
+
+ destructor Destroy; override;
+
+ procedure Clear;
+ {-Use this method to clear the hash table. The OnDisposeData event is
+ raised for each entry in case the caller needs to free the data
+ associated with the entry.}
+
+ property CanShrink : boolean read FCanShrink write FCanShrink;
+ {-Use this property to indicate whether or not the hash table may
+ be reduced in size when the number of items is less than 1/6 the
+ number of slots. }
+
+ property Count : Integer read FCount;
+ {-Use this property to determine the number of entries in the hash
+ table. }
+
+ property OnDisposeData : TffDisposeDataProc
+ read FOnDisposeData write FOnDisposeData;
+ {-This event is raised when data associated with an entry must be
+ destroyed by the calling object. }
+ end;
+
+ TffHash = class(TffBaseHashTable)
+ protected
+ procedure fhFreeKeyPrim(aKey : pointer); override;
+
+ function fhGetIndex(const AKey : Pointer;
+ const ACount : Integer) : Integer; override;
+ {calculate the index, ie hash, of the key}
+
+ public
+ function Add(aKey : Longint;
+ aValue : Pointer) : Boolean;
+ {-Use this method to add an entry to the hash table. Returns True if
+ the key/value pair was added or False if the key is already in the
+ hash table. }
+
+ function Get(const AKey : Longint) : Pointer;
+ {-Use this method to find an entry in the hash table. }
+
+ procedure Iterate(const CallBack : TffHashIteratorFunction;
+ const cookie1, cookie2, cookie3 : longInt);
+ {-Use this method to iterate through the entries in the hash table.
+ Callback will be called once for each entry. }
+
+ procedure IterateSafely(const CallBack : TffHashIteratorFunction;
+ const cookie1, cookie2, cookie3 : longInt);
+ {-Use this method to iterate through the entries in the hash table.
+ It is safe in the sense that it allows the Callback function to
+ free the item that is the current subject of the iteration.
+ Callback will be called once for each entry. }
+
+ function Remove(const AKey : Longint) : Boolean; {!!.02}
+ {-Use this method to remove an entry from the hash table. The
+ OnDisposeData event is raised in case the caller needs to free the
+ data associated with the entry. }
+
+
+
+ {$IFDEF CompileDebugCode}
+ procedure DebugPrint(const AFileName : string);
+ {-Use this method to dump the contents of the hash table during
+ testing stage. }
+ {$ENDIF}
+
+ end;
+
+ TffHash64 = class(TffBaseHashTable)
+ protected
+ function fhCompareKey(const aKey1 : Pointer;
+ const aKey2 : Pointer) : Boolean; override;
+
+ procedure fhFreeKeyPrim(aKey : pointer); override;
+
+ function fhGetIndex(const AKey : Pointer;
+ const ACount : Integer) : Integer; override;
+ {calculate the index, ie hash, of the key}
+
+ public
+ function Add(const AKey : TffInt64;
+ AValue : Pointer) : Boolean;
+ {-Use this method to add an entry to the hash table. Returns True if
+ the key/value pair was added or False if the key is already in the
+ hash table. }
+
+ function Get(const AKey : TffInt64) : Pointer;
+ {-Use this method to find an entry in the hash table. }
+
+ procedure Iterate(const CallBack : TffHash64IteratorFunction;
+ const cookie1, cookie2, cookie3 : longInt);
+ {-Use this method to iterate through the entries in the hash table.
+ Callback will be called once for each entry. }
+
+ procedure IterateSafely(const CallBack : TffHash64IteratorFunction;
+ const cookie1, cookie2, cookie3 : longInt);
+ {-Use this method to iterate through the entries in the hash table.
+ It is safe in the sense that it allows the Callback function to
+ free the item that is the current subject of the iteration.
+ Callback will be called once for each entry. }
+
+ procedure Remove(const AKey : TffInt64);
+ {-Use this method to remove an entry from the hash table. The
+ OnDisposeData event is raised in case the caller needs to free the
+ data associated with the entry. }
+
+ {$IFDEF CompileDebugCode}
+ procedure DebugPrint(const AFileName : string);
+ {-Use this method to dump the contents of the hash table during
+ testing stage. }
+ {$ENDIF}
+
+ end;
+
+
+ { This class is a threadsafe version of TffHash. This class allows multiple
+ threads to have read access or one thread to have write access (i.e.,
+ multiple read, exclusive write). A thread is granted write access only if
+ there are no reading threads or writing threads.}
+
+ TffThreadHash = class(TffHash)
+ protected {private}
+ FPortal : TffReadWritePortal;
+ public
+
+ constructor Create(initialSizeIndex : Integer); override;
+
+ destructor Destroy; override;
+
+ function BeginRead : TffThreadHash;
+ {-A thread must call this method to gain read access to the list.
+ Returns the instance of TffThreadList as a convenience. }
+
+ function BeginWrite : TffThreadHash;
+ {-A thread must call this method to gain write access to the list.
+ Returns the instance of TffThreadList as a convenience.}
+
+ procedure EndRead;
+ {-A thread must call this method when it no longer needs read access
+ to the list. If it does not call this method, all writers will
+ be perpetually blocked. }
+
+ procedure EndWrite;
+ {-A thread must call this method when it no longer needs write access
+ to the list. If it does not call this method, all readers and writers
+ will be perpetualy blocked. }
+ end;
+
+ TffThreadHash64 = class(TffHash64)
+ protected {private}
+ FPortal : TffReadWritePortal;
+ public
+
+ constructor Create(initialSizeIndex : Integer); override;
+
+ destructor Destroy; override;
+
+ function BeginRead : TffThreadHash64;
+ {-A thread must call this method to gain read access to the list.
+ Returns the instance of TffThreadList as a convenience. }
+
+ function BeginWrite : TffThreadHash64;
+ {-A thread must call this method to gain write access to the list.
+ Returns the instance of TffThreadList as a convenience.}
+
+ procedure EndRead;
+ {-A thread must call this method when it no longer needs read access
+ to the list. If it does not call this method, all writers will
+ be perpetually blocked. }
+
+ procedure EndWrite;
+ {-A thread must call this method when it no longer needs write access
+ to the list. If it does not call this method, all readers and writers
+ will be perpetualy blocked. }
+ end;
+
+
+{The following algorithm is the UNIX ELF format hash. The code was
+ converted and adapted from the one in C published in Dr Dobbs
+ Journal, April 1996, in the article "Hashing Rehashed" by
+ Andrew Binstock.}
+function FFCalcELFHash(const Buffer; BufSize : Integer) : TffWord32;
+
+function FFCalcShStrELFHash(const S : TffShStr) : TffWord32;
+
+const
+ { The following constants represent indexes into ffc_HashSizes array
+ declared in the implementation section of this unit. Use these constants
+ to specify the initial size index for hash tables. }
+ ffc_Size59 = 0;
+ ffc_Size127 = 1;
+ ffc_Size257 = 2;
+ ffc_Size521 = 3;
+ ffc_Size1049 = 4;
+ ffc_Size2099 = 5;
+
+implementation
+
+{ The following array contains the legal hash table sizes. Each is a prime
+ number which allows for better spread of inserts within a hash table. }
+const
+ ffc_HashSizes : array[0..15] of integer =
+ ( 59, 127, 257, 521, 1049, 2099, 4201, 8419,
+ 16843, 33703, 67409, 134837, 269683, 539389, 1078787, 2157587);
+
+const
+ ffc_HashLoadFactor = 4;
+ { When storing integer-ish items in a hash table, the hash table can
+ quickly walk through a slot's chain of nodes in those cases where a slot
+ contains more than one item. As a result, we can load up the hash
+ table with more items than slots. This constant specifies how far the
+ table may be overloaded. The table won't be resized until this limit
+ is reached. The limit is defined as Number of Slots * Load Factor. }
+
+{===TffBaseHashTable=================================================}
+constructor TffBaseHashTable.Create(initialSizeIndex : integer);
+begin
+ inherited Create;
+
+ FAtMin := False;
+ FCount := 0;
+ if initialSizeIndex > high(ffc_HashSizes) then
+ initialSizeIndex := high(ffc_HashSizes);
+ FHashSizeIndex := initialSizeIndex;
+ FMinSizeIndex := FHashSizeIndex;
+ FOnDisposeData := nil;
+ FTable := TffPointerList.Create;
+ FTable.Count := ffc_HashSizes[FHashSizeIndex];
+end;
+{--------}
+function TffBaseHashTable.fhCreateNode: TffHashNode;
+begin
+ Result := TffHashNode.Create;
+end;
+{--------}
+procedure TffBaseHashTable.Clear;
+var
+ i : integer;
+ Node : TffHashNode;
+ Temp : TffHashNode;
+begin
+ for i := 0 to pred(FTable.Count) do begin
+ Node := TffHashNode(FTable[i]);
+ while assigned(Node) do begin
+ Temp := Node;
+ Node := Node.fhNext;
+ if assigned(FOnDisposeData) then
+ FOnDisposeData(Self,Temp.fhValue);
+ {Temp.fhValue := nil;}
+ fhFreeKeyPrim(Temp.fhKey); {!!.01}
+ Temp.Free;
+ end;
+ FTable[i] := nil;
+ end;
+ FCount := 0;
+end;
+{--------}
+destructor TffBaseHashTable.Destroy;
+begin
+ Clear;
+ FTable.Free;
+ inherited Destroy;
+end;
+{--------}
+function TffBaseHashTable.fhAddPrim(aKey : Pointer;
+ aValue : Pointer): Boolean;
+var
+ Inx : integer;
+ Node : TffHashNode;
+begin
+ if fhFindPrim(aKey, Inx, Node) then
+ Result := false
+ else begin
+ Result := true;
+ Node := fhCreateNode;
+ Node.fhNext := TffHashNode(FTable[Inx]);
+ Node.fhKey := aKey;
+ Node.fhValue := aValue;
+ FTable.List[Inx] := Node;
+ inc(FCount);
+
+ { Expand the table if we've reached our load limit. }
+ if (FCount > (FTable.Count * ffc_HashLoadFactor)) then
+ fhResizeTable(True);
+ end;
+end;
+{--------}
+function TffBaseHashTable.fhCompareKey(const aKey1 : Pointer;
+ const aKey2 : Pointer) : Boolean;
+begin
+ Result := aKey1 = aKey2;
+end;
+{--------}
+procedure TffBaseHashTable.fhDeletePrim(const aKey : Pointer;
+ const aInx : Integer);
+var
+ Node : TffHashNode;
+ NextNode : TffHashNode;
+ PrevNode : TffHashNode;
+begin
+ Node := TffHashNode(FTable.List[aInx]);
+ PrevNode := nil;
+ while assigned(Node) and (not fhCompareKey(Node.fhKey, AKey)) do begin
+ PrevNode := Node;
+ Node := Node.fhNext;
+ end;
+ if assigned(Node) then begin
+ if assigned(FOnDisposeData) then
+ FOnDisposeData(Self, Node.fhValue);
+ NextNode := Node.fhNext;
+ {Node.fhValue := nil;}
+ fhFreeKeyPrim(Node.fhKey);
+ Node.Free;
+ if assigned(PrevNode) then
+ PrevNode.fhNext := NextNode
+ else if assigned(NextNode) then
+ FTable.List[aInx] := NextNode
+ else
+ FTable.List[aInx] := nil;
+ end;
+ dec(FCount);
+end;
+{--------}
+function TffBaseHashTable.fhFindPrim(const AKey : Pointer;
+ var AInx : Integer;
+ var ANode : TffHashNode): Boolean;
+var
+ Node : TffHashNode;
+begin
+ {assume we won't find aKey}
+ Result := false;
+ aNode := nil;
+ {calculate the index, ie hash, of the key}
+ aInx := fhGetIndex(aKey, FTable.Count);
+ {traverse the linked list at this entry, looking for the key in each
+ node we encounter--a case-sensitive comparison}
+ Node := TffHashNode(FTable[aInx]);
+ while (Node <> nil) do begin
+ if fhCompareKey(AKey, Node.fhKey) then begin
+ Result := true;
+ aNode := Node;
+ Exit;
+ end;
+ Node := Node.fhNext;
+ end;
+end;
+{--------}
+function TffBaseHashTable.fhMoveNodePrim(OldTable : TffPointerList;
+ OldNodeInx : integer;
+ Node : TffHashNode): Boolean;
+var
+ Inx : integer;
+ NextNode : TffHashNode;
+ PrevNode : TffHashNode;
+ TmpNode : TffHashNode;
+begin
+ { Assumption: The node will not be found in the table because we are only
+ being called during a resize. }
+
+ { Assumption: Table does not need to be expanded since this method is
+ called during table expansion. }
+
+ { Remove the node from the old table. }
+ TmpNode := TffHashNode(OldTable[OldNodeInx]);
+ PrevNode := nil;
+ while assigned(TmpNode) and
+ (not fhCompareKey(TmpNode.fhKey, Node.fhKey)) do begin
+ PrevNode := TmpNode;
+ TmpNode := TmpNode.fhNext;
+ end;
+ if assigned(TmpNode) then begin
+ NextNode := TmpNode.fhNext;
+ if assigned(PrevNode) then
+ PrevNode.fhNext := NextNode
+ else if assigned(NextNode) then
+ OldTable.List[OldNodeInx] := NextNode
+ else
+ OldTable.List[OldNodeInx] := nil;
+ end;
+
+ { Calculate the index, ie hash, of the key. }
+ Inx := fhGetIndex(Node.fhKey, FTable.Count);
+
+ { Insert the node into the new table. }
+ Result := true;
+ Node.fhNext := TffHashNode(FTable[Inx]);
+ FTable.List[Inx] := Node;
+
+end;
+{--------}
+procedure TffBaseHashTable.fhResizeTable(const increase : boolean);
+var
+ OldTable : TffPointerList;
+ Count : Integer;
+ Node : TffHashNode;
+ NewSize : Integer;
+begin
+ FAtMin := False;
+ { Are we increasing or decreasing? }
+ if increase then begin
+ { Increasing. Have we reached the limits of the ffc_HashSizes array? }
+ if FHashSizeIndex = high(ffc_HashSizes) then begin
+ { Yes. Double the current size and add one. If divisible by 3 then
+ add 2. }
+ NewSize := (FTable.Count * 2) + 1;
+ if NewSize mod 3 = 0 then
+ inc(NewSize, 2);
+ end
+ else begin
+ { No. Move to the next size. }
+ inc(FHashSizeIndex);
+ NewSize := ffc_HashSizes[FHashSizeIndex];
+ end;
+ end
+ else begin
+ { Decreasing. Have we reached our lower limit? }
+ FAtMin := (FHashSizeIndex = FMinSizeIndex);
+ if FAtMin then
+ exit
+ else begin
+ dec(FHashSizeIndex);
+ NewSize := ffc_HashSizes[FHashSizeIndex];
+ end;
+ end;
+
+ { Expand the table. }
+ OldTable := FTable;
+
+ FTable := TffPointerList.Create;
+ FTable.Count := NewSize;
+
+ for Count := 0 to Pred(OldTable.Count) do begin
+ Node := TffHashNode(OldTable.List[Count]);
+ repeat
+ if Assigned(Node) then
+ fhMoveNodePrim(OldTable, Count, Node);
+ Node := TffHashNode(OldTable.List[Count]);
+ until (not assigned(Node));
+ end;
+
+ OldTable.Free;
+end;
+{====================================================================}
+
+
+{===TffHash==========================================================}
+function TffHash.Add(aKey : LongInt;
+ aValue : Pointer): Boolean;
+begin
+ Result := fhAddPrim(pointer(aKey), aValue);
+end;
+{--------}
+{$IFDEF CompileDebugCode}
+
+procedure TffHash.DebugPrint(const AFileName: string);
+var
+ F : text;
+ i : integer;
+ Node : TffHashNode;
+begin
+ System.Assign(F, aFileName);
+ System.Rewrite(F);
+
+ for i := 0 to pred(FTable.Count) do begin
+ writeln(F, '---', i, '---');
+ Node := TffHashNode(FTable[i]);
+ while assigned(Node) do begin
+ writeln(F, Longint(Node.fhKey):10, intToStr(longInt(Node.fhValue)):20);
+ Node := Node.fhNext;
+ end;
+ end;
+
+ writeln(F);
+ writeln(F, 'Count: ', Count, ' (mean: ', Count/FTable.Count:5:3, ')');
+
+ System.Close(F);
+end;
+{$ENDIF}
+{--------}
+procedure TffHash.fhFreeKeyPrim(aKey : pointer);
+begin
+ { Do nothing. }
+end;
+{--------}
+function TffHash.fhGetIndex(const AKey : Pointer;
+ const ACount : Integer): Integer;
+begin
+ Result := Longint(AKey) mod ACount;
+end;
+{--------}
+function TffHash.Get(const AKey: Integer): Pointer;
+var
+ Inx : integer;
+ Node : TffHashNode;
+begin
+ Result := nil;
+ if fhFindPrim(Pointer(aKey), Inx, Node) then
+ Result := Node.fhValue
+end;
+{--------}
+procedure TffHash.Iterate(const CallBack : TffHashIteratorFunction;
+ const cookie1, cookie2, cookie3 : longInt);
+var
+ Count : Integer;
+ Node : TffHashNode;
+begin
+ for Count := 0 to Pred(FTable.Count) do begin
+ Node := TffHashNode(FTable[Count]);
+ while assigned(Node) do begin
+ CallBack(longInt(Node.fhKey), Node.fhValue, cookie1, cookie2, cookie3);
+ Node := Node.fhNext;
+ end;
+ end;
+end;
+{--------}
+procedure TffHash.IterateSafely(const CallBack : TffHashIteratorFunction;
+ const cookie1, cookie2, cookie3 : longInt);
+var
+ Count : Integer;
+ FirstNode : TffHashNode;
+ NextNode : TffHashNode;
+ Node : TffHashNode;
+ PrevNode : TffHashNode;
+begin
+ { Assumption: The TffHashNode.ExtraData property is not used for
+ any other purpose. }
+ { String the nodes together. }
+ FirstNode := nil;
+ PrevNode := nil;
+ for Count := 0 to Pred(FTable.Count) do begin
+ Node := TffHashNode(FTable[Count]);
+ while assigned(Node) do begin
+
+ if FirstNode = nil then
+ FirstNode := Node;
+
+ if Assigned(PrevNode) then
+ PrevNode.ExtraData := Node;
+
+ PrevNode := Node;
+ Node := Node.fhNext;
+ end;
+ end;
+
+ { Iterate through the list of nodes. }
+ Node := FirstNode;
+ while assigned(Node) do begin
+ NextNode := Node.ExtraData;
+ Callback(longInt(Node.fhKey), Node.fhValue, cookie1, cookie2, cookie3);
+ Node := NextNode;
+ end;
+
+end;
+{--------}
+function TffHash.Remove(const AKey: Longint) : Boolean; {!!.02}
+var
+ Inx : integer;
+ Node : TffHashNode;
+begin
+ if fhFindPrim(Pointer(aKey), Inx, Node) then begin
+ fhDeletePrim(Pointer(aKey), Inx);
+
+ { Shrink the table if:
+ 1. Shrinking is allowed.
+ 2. We are not at the minimum size already.
+ 3. We have some elements.
+ 4. We have some elements and we're under 1/6 full
+ }
+ if FCanShrink and (not FAtMin) and
+ (FCount > 10) and ((FCount * 6) < FTable.Count) then
+ fhResizeTable(False);
+ Result := True; {!!.02}
+ end {!!.02}
+ else {!!.02}
+ Result := False; {!!.02}
+end;
+{====================================================================}
+
+
+{===TffHash64========================================================}
+function TffHash64.Add(const aKey : TffInt64;
+ aValue : Pointer): Boolean;
+var
+ keyPtr : pointer;
+begin
+ FFGetMem(keyPtr, sizeOf(TffInt64));
+ TffInt64(keyPtr^) := aKey;
+ Result := fhAddPrim(keyPtr, aValue);
+ if not Result then
+ FFFreeMem(keyPtr, SizeOf(TffInt64));
+end;
+{--------}
+{$IFDEF CompileDebugCode}
+procedure TffHash64.DebugPrint(const AFileName: string);
+var
+ F : text;
+ i : integer;
+ Node : TffHashNode;
+begin
+ System.Assign(F, aFileName);
+ System.Rewrite(F);
+
+ for i := 0 to pred(FTable.Count) do begin
+ writeln(F, '---', i, '---');
+ Node := TffHashNode(FTable[i]);
+ while assigned(Node) do begin
+ writeln(F, FFI64ToStr(PffInt64(Node.fhKey)^), intToStr(longInt(Node.fhValue)):20);
+ Node := Node.fhNext;
+ end;
+ end;
+
+ writeln(F);
+ writeln(F, 'Count: ', Count, ' (mean: ', Count/FTable.Count:5:3, ')');
+
+ System.Close(F);
+end;
+{$ENDIF}
+{--------}
+function TffHash64.fhCompareKey(const aKey1 : Pointer;
+ const aKey2 : Pointer) : Boolean;
+begin
+ Result := FFCmpI64(PffInt64(aKey1)^, PffInt64(aKey2)^) = 0;
+end;
+{--------}
+procedure TffHash64.fhFreeKeyPrim(aKey : pointer);
+begin
+ FFFreeMem(aKey, sizeOf(TffInt64));
+end;
+{--------}
+function TffHash64.fhGetIndex(const AKey : Pointer;
+ const ACount : Integer): Integer;
+var
+ Int : Integer;
+begin
+ Int := ffI64ModInt(PffInt64(AKey)^, ACount);
+ Result := Int;
+end;
+{--------}
+function TffHash64.Get(const AKey : TffInt64) : Pointer;
+var
+ Inx : integer;
+ Node : TffHashNode;
+begin
+ Result := nil;
+ if fhFindPrim(@aKey, Inx, Node) then
+ Result := Node.fhValue
+end;
+{--------}
+procedure TffHash64.Iterate(const CallBack : TffHash64IteratorFunction;
+ const cookie1, cookie2, cookie3 : longInt);
+var
+ Count : Integer;
+ Node : TffHashNode;
+begin
+ for Count := 0 to Pred(FTable.Count) do begin
+ Node := TffHashNode(FTable[Count]);
+ while assigned(Node) do begin
+ CallBack(TffInt64(Node.fhKey^), Node.fhValue, cookie1, cookie2, cookie3);
+ Node := Node.fhNext;
+ end;
+ end;
+end;
+{--------}
+procedure Tffhash64.IterateSafely(const CallBack : TffHash64IteratorFunction;
+ const cookie1, cookie2, cookie3 : longInt);
+var
+ Count : Integer;
+ FirstNode : TffHashNode;
+ NextNode : TffHashNode;
+ Node : TffHashNode;
+ PrevNode : TffHashNode;
+begin
+ { Assumption: The TffHashNode.ExtraData property is not used for
+ any other purpose. }
+ { String the nodes together. }
+ FirstNode := nil;
+ PrevNode := nil;
+ for Count := 0 to Pred(FTable.Count) do begin
+ Node := TffHashNode(FTable[Count]);
+ while assigned(Node) do begin
+
+ if FirstNode = nil then
+ FirstNode := Node;
+
+ if Assigned(PrevNode) then
+ PrevNode.ExtraData := Node;
+
+ PrevNode := Node;
+ Node := Node.fhNext;
+ end;
+ end;
+
+ { Iterate through the list of nodes. }
+ Node := FirstNode;
+ while assigned(Node) do begin
+ NextNode := Node.ExtraData;
+ Callback(TffInt64(Node.fhKey^), Node.fhValue, cookie1, cookie2, cookie3);
+ Node := NextNode;
+ end;
+
+end;
+{--------}
+procedure TffHash64.Remove(const AKey : TffInt64);
+var
+ Inx : integer;
+ Node : TffHashNode;
+begin
+ if fhFindPrim(@aKey, Inx, Node) then begin
+ fhDeletePrim(@aKey, Inx);
+
+ { Shrink the table if:
+ 1. Shrinking is allowed.
+ 2. We are not at the minimum size already.
+ 3. We have some elements.
+ 4. We have some elements and we're under 1/6 full
+ }
+ if FCanShrink and (not FAtMin) and
+ (FCount > 10) and ((FCount * 6) < FTable.Count) then
+ fhResizeTable(False);
+ end;
+end;
+{====================================================================}
+
+
+{===TffThreadHash====================================================}
+function TffThreadHash.BeginRead : TffThreadHash;
+begin
+ if IsMultiThread then
+ FPortal.BeginRead;
+ Result := Self
+end;
+{--------}
+function TffThreadHash.BeginWrite : TffThreadHash;
+begin
+ if IsMultiThread then
+ FPortal.BeginWrite;
+ Result := Self
+end;
+{--------}
+constructor TffThreadHash.Create(initialSizeIndex : Integer);
+begin
+ inherited Create(initialSizeIndex);
+ FPortal := TffReadWritePortal.Create;
+end;
+{--------}
+destructor TffThreadHash.Destroy;
+begin
+ if Assigned(FPortal) then
+ FPortal.Free;
+ inherited Destroy;
+end;
+{--------}
+procedure TffThreadHash.EndRead;
+begin
+ if IsMultiThread then
+ FPortal.EndRead;
+end;
+{--------}
+procedure TffThreadHash.EndWrite;
+begin
+ if IsMultiThread then
+ FPortal.EndWrite;
+end;
+{====================================================================}
+
+
+{===TffThreadHash64==================================================}
+function TffThreadHash64.BeginRead : TffThreadHash64;
+begin
+ FPortal.BeginRead;
+ Result := Self
+end;
+{--------}
+function TffThreadHash64.BeginWrite : TffThreadHash64;
+begin
+ FPortal.BeginWrite;
+ Result := Self
+end;
+{--------}
+constructor TffThreadHash64.Create(initialSizeIndex : Integer);
+begin
+ inherited Create(initialSizeIndex);
+ FPortal := TffReadWritePortal.Create;
+end;
+{--------}
+destructor TffThreadHash64.Destroy;
+begin
+ if Assigned(FPortal) then
+ FPortal.Free;
+ inherited Destroy;
+end;
+{--------}
+procedure TffThreadHash64.EndRead;
+begin
+ FPortal.EndRead;
+end;
+{--------}
+procedure TffThreadHash64.EndWrite;
+begin
+ FPortal.EndWrite;
+end;
+
+{====================================================================}
+
+(****
+Note: the original C routine looked like this:
+
+unsigned long ElfHash ( const unsigned char *name )
+{
+ unsigned long h = 0, g;
+ while ( *name )
+ {
+ h = ( h << 4 ) + *name++;
+ if ( g = h & 0xF0000000 )
+ h ^= g >> 24;
+ h &= ~g;
+ }
+ return h;
+}
+****)
+
+{$Q-} {!!.05}
+function FFCalcELFHash(const Buffer; BufSize : integer) : TffWord32;
+var
+ BufAsBytes : TffByteArray absolute Buffer;
+ G : TffWord32;
+ i : integer;
+begin
+ Result := 0;
+ for i := 0 to pred(BufSize) do begin
+ Result := (Result shl 4) + BufAsBytes[i];
+ G := Result and $F0000000;
+ if (G <> 0) then
+ Result := Result xor (G shr 24);
+ Result := Result and (not G);
+ end;
+end;
+{$Q+} {!!.05}
+{--------}
+function FFCalcShStrELFHash(const S : TffShStr) : TffWord32;
+begin
+ Result := FFCalcELFHash(S[1], length(S));
+end;
+
+end.
+
diff --git a/components/flashfiler/sourcelaz/ffllbase.pas b/components/flashfiler/sourcelaz/ffllbase.pas
new file mode 100644
index 000000000..ff68c6431
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffllbase.pas
@@ -0,0 +1,7094 @@
+{*********************************************************}
+{* FlashFiler: General low level routines, types, etc *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+{$IFDEF DCC6OrLater}
+{$G+}
+{$ENDIF}
+
+{ Uncomment the following define to enable memory pool tracing. }
+{.$DEFINE MemPoolTrace}
+
+{ Uncomment the following to have memory obtained directly via GetMem,
+ FreeMem, and ReallocMem instead of the FF memory pools. This aids leak
+ detection using CodeWatch. }
+{.$DEFINE MemCheck}
+
+{$DEFINE UseEventPool}
+unit ffllbase;
+
+interface
+
+uses
+ Dialogs,
+ Windows,
+ Messages,
+ SysUtils,
+ ShellApi,
+ Classes,
+ ffconst;
+
+{$R ffllcnst.res}
+{$R ffdbcnst.res}
+
+{$IFDEF CBuilder3}
+(*$HPPEMIT '' *)
+(*$HPPEMIT '#pragma warn -hid' *)
+(*$HPPEMIT '' *)
+{$ENDIF}
+
+{$IFDEF CBuilder5}
+(*$HPPEMIT '' *)
+(*$HPPEMIT '#ifndef DELPHITHREAD' *)
+(*$HPPEMIT '#define DELPHITHREAD __declspec(thread)' *)
+(*$HPPEMIT '#endif' *)
+(*$HPPEMIT '' *)
+{$ENDIF}
+
+{===FlashFiler Version Number===}
+{ Version number is used to determine whether or not a client can properly
+ work with a server. The client supplies its version number to the
+ server and the server decides whether or not the client is compatible.
+
+ Reasons for incompatibility:
+
+ 1. The server's version number is less than the client's.
+ 2. The server's major version number is greater than the client's
+ major version number (at least in the case of 1.x and 2.x).
+
+ Following release of Flash Filer 1.0, there will be NO changes to any
+ message structure without a major Version increment. VersionNumber
+ div 10000 gives the standard decimal version number.
+
+ Minor version numbers increment in steps of 2 (to allow for DOS
+ timestamps).
+
+ If a message requires changes, an updated message will be added, and
+ old messages will be retained.
+}
+const
+ ffVersionNumber : Longint = 21300; {2.13.00}
+{Begin !!.11}
+ ffVersion2_10 : Longint = 20000 + 01000; {2_10_00 - The last release
+ prior to our changing the
+ BLOB nesting algorithm }
+{End !!.11}
+
+{===FlashFiler Version Number===}
+const
+ {$IFDEF Delphi3}
+ ffSpecialString : string = 'Release (D3)';
+ {$ENDIF}
+ {$IFDEF Delphi4}
+ ffSpecialString : string = 'Release (D4)';
+ {$ENDIF}
+ {$IFDEF Delphi5}
+ ffSpecialString : string = 'Release (D5)';
+ {$ENDIF}
+ {$IFDEF Delphi6}
+ ffSpecialString : string = 'Release (D6)';
+ {$ENDIF}
+ {$IFDEF Delphi7}
+ ffSpecialString : string = 'Release (D7)';
+ {$ENDIF}
+ {$IFDEF CBuilder3}
+ ffSpecialString : string = 'Release (C3)';
+ {$ENDIF}
+ {$IFDEF CBuilder4}
+ ffSpecialString : string = 'Release (C4)';
+ {$ENDIF}
+ {$IFDEF CBuilder5}
+ ffSpecialString : string = 'Release (C5)';
+ {$ENDIF}
+ {$IFDEF CBuilder6}
+ ffSpecialString : string = 'Release (C6)';
+ {$ENDIF}
+
+
+{===FlashFiler Limits===} { ***DO NOT ALTER*** }
+const
+ ffcl_INFINITE = High(DWORD); {!!.06}
+ ffcl_MaxIndexes = 256; {maximum number of indexes per table}
+ ffcl_MaxIndexFlds = 16; {maximum count of fields in a composite key}
+ ffcl_MaxKeyLength = 1024; {maximum length of a key}
+ ffcl_FixedBookmarkSize = 24; {size of fixed part of a bookmark (ie, without key value)}
+ ffcl_MaxBookmarkSize = ffcl_FixedBookmarkSize + ffcl_MaxKeyLength;
+ {maximum size of a bookmark}
+ ffcl_MaxBLOBLength = 2147483647; {maximum BLOB length(i.e., 2^31)}
+ ffcl_GeneralNameSize = 31; {count of chars in a (general) name}
+ ffcl_NetNameSize = 31; {count of chars in a network name}
+ ffcl_NetAddressSize = 63; {count of chars in a network address}
+ ffcl_UserNameSize = 31; {count of chars in a user/client name}
+ ffcl_ServerNameSize = 15; {count of chars in a server name}
+ ffcl_DescriptionSize = 63; {count of chars in a description}
+ ffcl_TableNameSize = 31; {count of chars in a table name}
+ ffcl_FileName = 31; {count of chars in a filename (no drive/path/ext)}
+ ffcl_Extension = 3; {count of chars in an extension}
+ ffcl_Path = 219; {count of chars in a directory path (excl final \)}
+ ffcl_MaxPictureLength = 175; {count of chars in a picture}
+ ffcl_MaxVCheckLength = 256; {count of bytes in a validity check value}
+ ffcl_MaxBlocks = 2147483647; {maximum number of blocks (i.e., 2^31)}
+ ffcl_MaxRecords = 2147483647; {maximum number of records (i.e., 2^31)}
+ ffcl_MinRecordLength = 8; {Minimum logical record length for the data
+ dictionary. We have a minimum because
+ we must have this many bytes to hold the
+ offset to the next deleted record. This
+ value does not include the leading
+ deleted flag byte in the physical
+ record. }
+ ffcl_MaxBlockedThreads = 50; {maximum number of threads that may be
+ waiting on read or write access to a
+ data structure protected by an instance
+ of TffReadWritePortal}
+ ffcl_InitialListSize = 64; {Initial capacity of a TffList. }
+ ffcl_1KB = 1024; {One kilobyte. } {!!.06}
+ ffcl_1MB = 1024 * 1024; {One megabyte. }
+ ffcl_64MB = 64 * ffcl_1MB; {64 megabytes. }
+ ffcl_64k = 64 * 1024; {64 kbytes. }
+ ffcl_InitialSemCount = 250; {Initial # of semaphores in sem pool. }
+ ffcl_RetainSemCount = 2500; {# of semaphores to retain when flush sem pool. } {!!.01}
+ ffcl_PortalTimeout = 5000; {# milliseconds for a BeginRead or BeginWrite
+ timeout. }
+ {$IFDEF UseEventPool}
+ ffcl_InitialEventCount = 250; {Initial # of events in event pool.}
+ ffcl_RetainEventCount = 2500; {# of events to retain when flush event pool. } {!!.01}
+ {$ENDIF}
+
+
+ {file-size constants}
+ ffcl_FourGigabytes = $FFFFFFFE;
+ ffcl_TwoGigabytes = $7FFFFFFF;
+ ffcl_MaxHDFloppy = $163E00;
+
+ {Transaction constants}
+ ffcl_TrImplicit = True;
+ ffcl_TrExplicit = False;
+
+ ffcl_CollectionFrequency = 300000;
+ { Default garbage collection to every 5 minutes. }
+
+ ffcl_TempStorageSize = 20;
+ { Default temporary storage size to 20 MB.}
+
+
+{===Extra 'primary' types===}
+type
+ PffLongint = ^Longint; {pointer to a Longint}
+ {$IFNDEF DCC4OrLater}
+ PShortInt = ^ShortInt; {pointer to a shortint}
+ {$ENDIF}
+ PffDateTime = ^TDateTime; {pointer to a TDateTime; required
+ because we use PDateTime but it
+ occurs only in D5+ or BCB4+ }
+ TffWord16 = word; {16-bit unsigned integer}
+ TffWord32 = type DWORD; {32-bit unsigned integer}
+ PffWord32 = ^TffWord32; {pointer to a 32-bit unsigned integer}
+ PffByteArray = ^TffByteArray; {General array of bytes}
+ TffByteArray = array[0..65531] of byte;
+ PffCharArray = ^TffCharArray; {For debugging purposes. }
+ TffCharArray = array[0..65531] of AnsiChar;
+ PffBLOBArray = ^TffBLOBArray;
+ TffBLOBArray = array [0..pred(ffcl_MaxBLOBLength)] of byte;
+ TffVarMsgField = array [0..1] of byte; {Variably sized field (for messages)}
+ PffLongintArray = ^TffLongintArray; {General array of long integers}
+ TffLongintArray = array [0..16382] of Longint;
+ TffShStr = string[255]; {a length-byte string}
+ PffShStr = ^TffShStr; {pointer to a length-byte string}
+ TffResult = Longint; {FlashFiler result error code}
+ TffMemSize = integer; {type for size of memory to alloc/free}
+ TffPicture = string[ffcl_MaxPictureLength];
+ {picture mask}
+ TffVCheckValue = array [0..pred(ffcl_MaxVCheckLength)] of byte;
+ {a validity check}
+ PffInt64 = ^TffInt64; {pointer to a TffInt64}
+ TffInt64 = record {64-bit integer for Delphi 3}
+ iLow : TffWord32;
+ iHigh : TffWord32;
+ end;
+
+ PffBlock = ^TffBlock; { A FlashFiler file consists of a set of blocks. }
+ TffBlock = array [0..65535] of byte; { A block may be 4k, 8k, 16k, 32k, or 64k
+ in size. }
+
+ TffBlockSize = (ffbs4k, ffbs8k, ffbs16k, ffbs32k, ffbs64k);
+ TffBlockSizes = set of TffBlockSize;
+
+ { The following types are used to improve parameter integrity. }
+{Begin !!.10}
+ TffBaseID = type TffWord32;
+ TffClientID = type TffBaseID;
+ TffCursorID = type TffBaseID;
+ TffDatabaseID = type TffBaseID;
+ TffSessionID = type TffBaseID;
+ TffSqlStmtID = type TffBaseID;
+ TffTransID = type TffBaseID;
+{End !!.10}
+
+{===Important constants===}
+const
+ ffc_BlockHeaderSizeData = 32; {was defined in FFSRBASE}
+ {file extensions (must NOT include period)}
+ ffc_ExtForData : string[ffcl_Extension] = 'FF2'; {extension for main table file}
+ ffc_ExtForTrans : string[ffcl_Extension] = 'FF$'; {extension for Transaction file}
+ ffc_ExtForSQL : string[ffcl_Extension] = 'SQL'; {extension for SQL text files}
+ ffc_NoClientID : TffClientID = 0; { Represents no clientID specified }
+
+{===component notification constants===}
+const
+ ffn_Insert = $01;
+ ffn_Remove = $02;
+ ffn_Activate = $03;
+ ffn_Deactivate = $04;
+ ffn_Destroy = $05;
+ ffn_OwnerChanged = $06;
+ ffn_ConnectionLost = $0A;
+
+{===Misc constants===}
+const
+ ffcCRLF = #13#10;
+ ffc_W32NoValue = $FFFFFFFF;
+
+{===Enumeration types===}
+type
+ TffOpenMode = ( {Open modes for opening databases, tables}
+ omReadOnly, {..read only mode}
+ omReadWrite); {..read/write mode}
+
+ TffShareMode = ( {Share modes for opening databases, tables}
+ smExclusive, {..exclusive, no sharing}
+ smShared, {..allows others to Read or Write} {!!.06}
+ smShareRead); {..allows others to Read only} {!!.06}
+
+ TffLockType = ( {Types of lock...}
+ ffltNoLock, {..no lock at all}
+ ffltReadLock, {..read lock (not for record locks)}
+ ffltWriteLock); {..write lock}
+
+ TffSearchKeyAction = ( {Key search actions...}
+ skaEqual, {..exactly equal to supplied key}
+ skaEqualCrack, {..equal to supplied key or on crack before
+ next key}
+ skaGreater, {..greater than supplied key}
+ skaGreaterEqual); {..greater than or equal to supplied key}
+
+type
+ TffFieldType = ( {Field types for the data dictionary}
+ fftBoolean, {..8-bit boolean flag}
+ fftChar, {..8-bit character}
+ fftWideChar, {..16-bit character (UNICODE)}
+ fftByte, {..byte (8-bit unsigned integer)}
+ fftWord16, {..16-bit unsigned integer (aka word)}
+ fftWord32, {..32-bit unsigned integer}
+ fftInt8, {..8-bit signed integer}
+ fftInt16, {..16-bit signed integer}
+ fftInt32, {..32-bit signed integer}
+ fftAutoInc, {..32-bit unsigned integer; auto incrementing}
+ fftSingle, {..IEEE single (4 bytes)}
+ fftDouble, {..IEEE double (8 bytes)}
+ fftExtended, {..IEEE extended (10 bytes)}
+ fftComp, {..IEEE comp type (8 bytes signed integer)}
+ fftCurrency, {..Delphi currency type (8 bytes, scaled integer)}
+ fftStDate, {..SysTools date type (4 bytes)}
+ fftStTime, {..SysTools time type (4 bytes)}
+ fftDateTime, {..Delphi date/time type (8 bytes)}
+ fftBLOB, {..variable length BLOB field - general binary data}
+ fftBLOBMemo, {..variable length BLOB field - text memo}
+ fftBLOBFmtMemo, {..variable length BLOB field - formatted text memo}
+ fftBLOBOLEObj, {..variable length BLOB field - OLE object (Paradox)}
+ fftBLOBGraphic, {..variable length BLOB field - graphics object}
+ fftBLOBDBSOLEObj,{..variable length BLOB field - OLE object (dBase)}
+ fftBLOBTypedBin, {..variable length BLOB field - typed binary data}
+ fftBLOBFile, {..variable lenght BLOB field - external file}
+
+ {..reserved enumeration elements - DO NOT USE}
+ fftReserved2, fftReserved3, fftReserved4,
+ fftReserved5, fftReserved6, fftReserved7, fftReserved8,
+ fftReserved9, fftReserved10, fftReserved11, fftReserved12,
+ fftReserved13, fftReserved14, fftReserved15, fftReserved16,
+ fftReserved17, fftReserved18, fftReserved19,
+
+ { NOTE: The SQL engine uses fftReserved20 to represent an
+ Interval field type. We do not yet expose this field type
+ to the outside world. }
+ fftReserved20,
+
+ fftByteArray, {..array of bytes}
+ {..EVERYTHING AFTER THIS POINT MUST BE A STRING TYPE}
+ fftShortString, {..length byte string}
+ fftShortAnsiStr, {..length byte Ansi string}
+ fftNullString, {..null-terminated string}
+ fftNullAnsiStr, {..null-terminated Ansi string}
+ fftWideString {..null-terminated string of wide chars}
+ );
+
+ TffFieldTypes = set of TffFieldType;
+ TffBLOBCopyMode = (ffbcmNoCopy, ffbcmCopyFull, ffbcmCreateLink);
+
+const
+ FieldDataTypes : array[TffFieldType] of string[16] = ( //!!was string[20]
+ 'Boolean',
+ 'Char',
+ 'Wide Char',
+ 'Byte',
+ 'Word16',
+ 'Word32',
+ 'Int8',
+ 'Int16',
+ 'Int32',
+ 'AutoInc',
+ 'Single',
+ 'Double',
+ 'Extended',
+ 'Comp',
+ 'Currency',
+ 'SysTools Date',
+ 'SysTools Time',
+ 'DateTime',
+ 'BLOB',
+ 'BLOB Memo',
+ 'BLOB Fmt Memo',
+ 'BLOB OLE Obj',
+ 'BLOB Graphic',
+ 'BLOB DBS OLE Obj',
+ 'BLOB Typed Bin',
+ 'BLOB File',
+ 'Reserved2',
+ 'Reserved3',
+ 'Reserved4',
+ 'Reserved5',
+ 'Reserved6',
+ 'Reserved7',
+ 'Reserved8',
+ 'Reserved9',
+ 'Reserved10',
+ 'Reserved11',
+ 'Reserved12',
+ 'Reserved13',
+ 'Reserved14',
+ 'Reserved15',
+ 'Reserved16',
+ 'Reserved17',
+ 'Reserved18',
+ 'Reserved19',
+ 'Reserved20',
+ 'Byte Array',
+ 'ShortString',
+ 'ANSI ShortString',
+ 'NullString',
+ 'ANSI NullString',
+ 'Wide String');
+
+const
+ ffcLastBLOBType = fftBLOBFile; {the last BLOB type, all BLOB types fall
+ between fftBLOB and this one}
+
+type
+ TffIndexType = ( {Index types for the data dictionary}
+ itComposite, {..composite index}
+ itUserDefined); {..user defined index}
+
+type
+ TffFileType = ( {File types for the data dictionary}
+ ftBaseFile, {..base file: at least data & dictionary}
+ ftIndexFile, {..index file}
+ ftBLOBFile); {..BLOB file}
+
+type
+ TffFileName = string[ffcl_FileName]; {File name type (no drive/path/extension)}
+ TffExtension = string[ffcl_Extension]; {Extension identifier type}
+ TffFileNameExt = string[succ(ffcl_FileName + ffcl_Extension)];
+ {File name + extension type}
+ TffFullFileName = string[255]; {Expanded file name (inc drive/path}
+ TffPath = string[ffcl_Path]; {Complete directory path (excl final \)}
+ TffMaxPathZ = array [0..pred(MAX_PATH)] of AnsiChar;
+ {Null-terminated path&file name type}
+
+ TffName = string[ffcl_GeneralNameSize]; {A general name type}
+{Begin !!.03}
+{$IFDEF IsDelphi}
+ TffNetName = string[ffcl_NetNameSize]; {a network name type}
+ TffNetAddress = string[ffcl_NetAddressSize]; {a network address type}
+{$ELSE}
+ TffNetName = string; {a network name type}
+ TffNetAddress = string; {a network address type}
+ TffNetNameShr = string[ffcl_NetNameSize]; {a network name type - for requests}
+ TffNetAddressShr = string[ffcl_NetAddressSize]; {a network address type - for requests}
+{$ENDIF}
+{End !!.03}
+ TffTableName = string[ffcl_TableNameSize]; {Table name type}
+
+ TffStringZ = array [0..255] of AnsiChar; {For converting ShortStrings to StringZs}
+
+{ !!.06 - Following type moved from FFNETMSG }
+{===Network message enums===}
+type
+ TffNetMsgDataType = ( {Types of network message data...}
+ nmdByteArray, {..it's an array of bytes}
+ nmdStream); {..it's a stream (TStream descendant)}
+
+type
+ TffDirItemType = ( {types of items a directory can contain}
+ ditFile, {..file}
+ ditDirectory, {..directory}
+ ditVolumeID); {..VolumeID}
+ TffDirItemTypeSet = set of TffDirItemType;
+
+ TffDirItemAttr = ( {attributes of directory items}
+ diaNormal, {..normal}
+ diaReadOnly, {..readonly}
+ diaHidden, {..hidden}
+ diaSystem, {..system}
+ diaArchive); {..not backed up}
+ TffDirItemAttrSet = set of TffDirItemAttr;
+
+ TffSearchRec = packed record {FlashFiler directory search record}
+ srTime : TffWord32; {..timestamp}
+ srSize : TffWord32; {..size (low 32 bits)}
+ srSizeHigh : TffWord32; {..size (high 32 bits, generally 0)}
+ srType : TffDirItemType; {..type}
+ srAttr : TffDirItemAttrSet;{..attributes}
+ srName : TffFileNameExt; {..name, including extension}
+ srHandle : THandle; {..internal use only}
+ srData : TWin32FindData; {..internal use only}
+ srFindType : TffDirItemTypeSet;{..internal use only}
+ srFindAttr : TffDirItemAttrSet;{..internal use only}
+ end;
+
+const
+ diaAnyAttr : TffDirItemAttrSet =
+ [diaNormal, diaReadOnly, diaHidden, diaSystem, diaArchive];
+
+
+{===FlashFiler data dictionary descriptors===}
+type
+ TffDictItemName = string[ffcl_GeneralNameSize]; {Field/Index name type}
+ TffDictItemDesc = string[ffcl_DescriptionSize]; {Field/Index description type}
+
+ PffVCheckDescriptor = ^TffVCheckDescriptor;
+ TffVCheckDescriptor = packed record {Validity check descriptor}
+ vdHasMinVal : boolean; {..true if the field has a minimum value}
+ vdHasMaxVal : boolean; {..true if the field has a maximum value}
+ vdHasDefVal : boolean; {..true if the field has a default value}
+ vdFiller : byte;
+ vdMinVal : TffVCheckValue; {..the field's minimum value}
+ vdMaxVal : TffVCheckValue; {..the field's maximum value}
+ vdDefVal : TffVCheckValue; {..the field's default value}
+ vdPicture : TffPicture; {..the field's picture clause}
+ end;
+
+ PffFieldDescriptor = ^TffFieldDescriptor;
+ TffFieldDescriptor = packed record {Field descriptor}
+ fdNumber : Longint; {..number of field in record (zero based)}
+ fdName : TffDictItemName; {..name of field}
+ fdDesc : TffDictItemDesc; {..description of field}
+ fdUnits : Longint; {..number of characters/digits etc}
+ fdDecPl : Longint; {..number of decimal places}
+ fdOffset : Longint; {..offset of field in record}
+ fdLength : Longint; {..length of field in bytes}
+ fdVCheck : PffVCheckDescriptor; {..validity check (if nil, there is none)}
+ fdType : TffFieldType; {..type of field}
+ fdRequired : boolean; {..true, if field must have a value to be stored}
+ fdFiller : array [0..1] of byte;
+ end;
+
+ TffFieldList = array [0..pred(ffcl_MaxIndexFlds)] of Longint;
+ {List of field numbers in an index}
+ TffFieldIHList = array [0..pred(ffcl_MaxIndexFlds)] of TffDictItemName;
+ {List of extension functions used to build/compare an index}
+
+ PffIndexDescriptor = ^TffIndexDescriptor;
+ TffIndexDescriptor = packed record {Index descriptor}
+ idNumber : Longint; {..number of index (zero based)}
+ idName : TffDictItemName; {..name of index}
+ idDesc : TffDictItemDesc; {..description of index}
+ idFile : Longint; {..number of file containing index}
+ idKeyLen : Longint; {..length of key in bytes}
+ idCount : Longint; {..number of fields in composite index, or}
+ { -1 for user defined index}
+ idFields : TffFieldList; {..field numbers for composite index}
+ idFieldIHlprs : TffFieldIHList; {..index helpers used to build/compare
+ a composite index}
+ idDups : boolean; {..0=no duplicate keys, 1=dups allowed}
+ idAscend : boolean; {..0=descending keys; 1=ascending keys}
+ idNoCase : boolean; {..0=case sensitive indexing; 1=case insensitive}
+ end;
+
+ PffFileDescriptor = ^TffFileDescriptor;
+ TffFileDescriptor = packed record {File descriptor}
+ fdNumber : Longint; {..number of file (zero based)}
+ fdDesc : TffDictItemDesc; {..description of file}
+ fdExtension : TffExtension; {..extension for file}
+ fdBlockSize : Longint; {..block size for file}
+ fdType : TffFileType; {..type of file}
+ end;
+
+ PffAliasDescriptor = ^TffAliasDescriptor;
+ TffAliasDescriptor = packed record {Database Alias descriptor}
+ adAlias : TffName; {..alias name}
+ adPath : TffPath; {..directory path for database}
+ end;
+
+ PffTableDescriptor = ^TffTableDescriptor;
+ TffTableDescriptor = packed record
+ tdTableName : TffTableName;
+ tdExt : TffExtension;
+ tdSizeLo : TffWord32;
+ tdSizeHi : TffWord32;
+ tdTimeStamp : TffWord32;
+ end;
+
+{===FlashFiler information types===}
+type
+ PffRebuildStatus = ^TffRebuildStatus;
+ TffRebuildStatus = packed record {Rebuild operation status info}
+ rsStartTime : DWord; {..start time (tick count from server)}{!!.10}
+ rsSnapshotTime : DWord; {..snapshot time (tick count from server)}{!!.10}
+ rsTotalRecs : Longint; {..total count of records to read}
+ rsRecsRead : Longint; {..count of records read}
+ rsRecsWritten : Longint; {..count of records written}
+ rsPercentDone : Longint; {..RecsRead*100/TotalRecs}
+ rsErrorCode : TffResult; {..error result for process}
+ rsFinished : boolean; {..process has finished}
+ end;
+
+ PffRecordInfo = ^TffRecordInfo;
+ TffRecordInfo = packed record {Information block for data records}
+ riRecLength : Longint; {..record length}
+ riRecCount : Longint; {..number of active records}
+ riDelRecCount : Longint; {..number of deleted records}
+ riRecsPerBlock : Longint; {..number of records in each block}
+ end;
+
+ PffIndexInfo = ^TffIndexInfo;
+ TffIndexInfo = packed record {Information block for an index}
+ iiKeyCount : Longint; {..number of keys}
+ iiPageCount : Longint; {..number of B-Tree pages}
+ iiMaxKeysPerNode : Longint; {..maximum number of keys per node page}
+ iiMaxKeysPerLeaf : Longint; {..maximum number of keys per leaf page}
+ iiKeyLength : word; {..length of a key in bytes}
+ iiAllowDups : boolean; {..duplicate keys allowed}
+ iiKeysAreRefs : boolean; {..keys are reference numbers}
+ iiBTreeHeight : integer; {..height of the b-tree}
+ end;
+
+ PffServerStatistics = ^TffServerStatistics; {begin !!.10}
+ TffServerStatistics = packed record {Server statistics info}
+ ssName : TffNetName;
+ ssVersion : Longint;
+ ssState : ShortString;
+ ssClientCount : TffWord32;
+ ssSessionCount : TffWord32;
+ ssOpenDatabasesCount : TffWord32;
+ ssOpenTablesCount : TffWord32;
+ ssOpenCursorsCount : TffWord32;
+ ssRamUsed : TffWord32;
+ ssMaxRam : TffWord32;
+ ssUpTimeSecs : DWord;
+ ssCmdHandlerCount : Integer;
+ end;
+
+ PffCommandHandlerStatistics = ^TffCommandHandlerStatistics;
+ TffCommandHandlerStatistics = packed record {stats for command handler}
+ csTransportCount : Integer;
+ end;
+
+ PffTransportStatisticsInfo = ^TffTransportStatistics;
+ TffTransportStatistics = packed record {stats related to a transport}
+ tsName : TffNetName;
+ tsState : ShortString;
+ tsAddress : TffNetAddress;
+ tsClientCount : TffWord32;
+ tsMessageCount : TffWord32;
+ tsMessagesPerSec : Double;
+ end; {end !!.10}
+
+
+{===Notify event declarations===}
+type
+ TffNetIdle = procedure(Sender : TObject);
+
+
+type
+
+ { Delphi's memory management is not suitable for a 24x7 database server. It
+ will eat up memory and eventually crash. To avoid this problem, we
+ override certain VCL classes so that we can have the VCL classes use our
+ own memory manager. The new classes are listed below. }
+
+ TffPadlock = class; { forward declaration }
+
+{===FlashFiler TffObject class===}
+ { All FF classes that would normally inherit from TObject must inherit
+ from this class instead. }
+ TffObject = class(TObject)
+{Begin !!.03}
+ {$IFDEF FF_DEBUG_THREADS}
+ protected {private}
+ ffoMethodLock : Integer;
+ ffoCurrentThreadID : Cardinal;
+ ffoThreadLockCount : Integer;
+ protected
+ procedure ThreadEnter;
+ procedure ThreadExit;
+ public
+ {$ENDIF}
+{End !!.03}
+ class function NewInstance: TObject; override;
+ procedure FreeInstance; override;
+ end;
+
+{===FlashFiler TffVCLList class===}
+ { All FF classes using instances of TList should use this class instead. }
+ TffVCLList = class(TList)
+ class function NewInstance: TObject; override;
+ procedure FreeInstance; override;
+ end;
+
+{===FlashFiler TFFPersistent class===}
+ { All FF classes that would normally inherit from TPersistent must inherit
+ from this class instead. }
+ TffPersistent = class(TPersistent)
+{Begin !!.03}
+ {$IFDEF FF_DEBUG_THREADS}
+ protected {private}
+ ffpMethodLock : Integer;
+ ffpCurrentThreadID : Cardinal;
+ ffpThreadLockCount : Integer;
+ protected
+ procedure ThreadEnter;
+ procedure ThreadExit;
+ public
+ {$ENDIF}
+{End !!.03}
+ class function NewInstance: TObject; override;
+ procedure FreeInstance; override;
+ end;
+
+{===FlashFiler TFFThread class===}
+ { All FF classes that would normally inherit from TThread must inherit
+ from this class instead. Our reason for doing so is that Delphi's
+ memory management is not suitable for a 24x7 database server. It will
+ eat up memory and eventually crash. This class allocates its own memory.}
+ TffThread = class(TThread)
+ class function NewInstance: TObject; override;
+ procedure FreeInstance; override;
+ protected
+ procedure DoTerminate; override;
+ { Note: We override DoTerminate because the standard TThread.DoTerminate
+ will block when it calls Synchronize if the thread was not created
+ in the main thread of the application. }
+{Begin !!.02}
+ public
+ procedure WaitForEx(const Timeout : Longint);
+{End !!.02}
+ end;
+
+{===Multithread support===}
+ { Use TffEvent in those situations where Object A must wait for Object B to
+ tell it something has happened. For example, a TffRequest must wait for
+ a reply to be received by the sending thread of a TffLegacyTransport. }
+ TffEvent = class(TffObject)
+ private
+ ffeEvent : THandle; { the actual event object }
+ protected
+ public
+ constructor Create;
+
+ destructor Destroy; override;
+
+ procedure WaitFor(const timeOut : TffWord32);
+ {-Call this method when an object must wait for this event to be
+ signalled. Timeout is the number of milliseconds the thread should
+ wait for the event. If timeOut is <= 0 then the thread will wait
+ until the event is signalled otherwise it waits the specified
+ number of milliseconds. Raises an exception if the wait times out
+ or a failure occurs. }
+
+ function WaitForQuietly(const timeOut : TffWord32) : DWORD;
+ {-This method is just like the WaitFor method except that it returns
+ an error code instead of raising an exception if a failure occurs.
+ Possible return values:
+ WAIT_ABANDONED - See MS SDK help for WaitForSingleObject. It is much
+ more mind-twisting than should be documented here.
+ WAIT_OBJECT_0 - The event was signalled.
+ WAIT_TIMEOUT - The timeout interval elapsed without the event being
+ signaled. }
+
+ procedure SignalEvent;
+ {-Call this method when the event is to be set/raised/signalled.
+ This releases a thread that called WaitFor. }
+
+ property Handle : THandle read ffeEvent;
+ {-Returns the events handle. }
+
+ end;
+
+ { Use TffReadWritePortal to protect a data structure accessible by multiple
+ threads. This class allows multiple readers or one writer through the
+ portal at a time. It provides the best performance for multithreaded
+ access to a data structure.
+
+ When a thread wants to read the data structure, it must call BeginRead.
+ It must then call EndRead when it has finished reading.
+
+ When a thread wants to write to the data structure, it must call BeginWrite.
+ It must then call EndWrite when it has finished writing.
+
+ If a thread given write access needs to read the protected data structure
+ then BeginRead automatically grants read access.
+
+ Calls to BeginWrite are reference counted. A thread granted write access
+ may call BeginWrite multiple times but each call to BeginWrite must
+ have a corresponding call to EndWrite.
+ }
+
+ TffReadWritePortal = class(TffObject)
+ private
+ rwpBlockedReaders : THandle; { semaphore used to release blocked readers }
+ rwpBlockedWriters : THandle; { semaphore used to release blocked writers }
+ rwpGate : TffPadlock; { critical section allowing single-threaded
+ access to internal data structures }
+ rwpActiveReaders : integer; { the number of threads given read access }
+ rwpActiveWriter : boolean; { if True then a thread has been granted
+ write access; all other readers and writers
+ are blocked }
+ rwpActiveWriterID : TffWord32;{ the threadID of the thread granted write
+ access }
+ rwpWaitingReaders : integer; { the number of threads waiting for read
+ access }
+ rwpWaitingWriters : integer; { the number of threads waiting for write
+ access }
+ rwpWriterReadCount : integer; { the number of times the active writer has
+ called BeginRead }
+ rwpWriterWriteCount : integer; { the number of times the active writer has
+ called BeginWrite }
+ protected
+ public
+ constructor Create;
+ {-Use this method to create an instance of TffReadWritePortal.
+ maxBlockedThreads is the maximum number of reader or writer threads
+ that may wait for access to the protected data structure. }
+ destructor Destroy; override;
+ procedure BeginRead;
+ {-Call this method when a thread wants to start reading the protected
+ data structure. BeginRead will not return until the thread has been
+ granted read access. Each occurrence of BeginRead must have a
+ corresponding call to EndRead. }
+ procedure BeginWrite;
+ {-Call this method when a thread wants to start writing the protected
+ data structure. BeginWrite will not return until the thread has
+ been granted write access. Each occurrence of BeginWrite must have a
+ corresponding call to EndWrite. }
+ procedure EndRead;
+ {-Call this method when a thread has finished reading the protected
+ data structure. }
+ procedure EndWrite;
+ {-Call this method when a thread has finished writing to the
+ protected data structure. }
+ end;
+
+ { TffPadLock allows only one reader or writer at a time.
+ This class is obsolete and should be phased out. }
+ TffPadLock = class {*NOT* class (TffObject)}
+ protected {public}
+ plCount : integer;
+ plCritSect : TRTLCriticalSection;
+ protected
+ function GetLocked : boolean;
+ public
+ constructor Create;
+ {-Create a multithread padlock}
+ destructor Destroy; override;
+ {-Free a multithread padlock}
+ procedure Lock;
+ procedure Unlock;
+ property Locked : boolean read GetLocked;
+ end;
+
+{===FlashFiler List and List Item classes===}
+type
+ TffListState = (lsNormal, lsClearing);
+
+ TffListFindType = ( {How to find an item in a list}
+ ftFromID, {..from the item's ID}
+ ftFromIndex); {..from the index of the item}
+
+ TffList = class;
+
+ TffListItem = class(TffObject)
+ protected {private}
+ ffliList : TffList;
+ ffliFreeOnRemove : boolean;
+ ffliState : TffListState;
+ ffliMaintainLinks : boolean;
+ { If True then track what lists contain this item. }
+
+ protected
+ function GetRefCount : integer;
+ procedure ffliAddListLink(L : TffList);
+ procedure ffliBreakListLink(L : TffList);
+ procedure ffliSetMaintainLinks(const Value : Boolean); {!!.11}
+ public
+ constructor Create;
+ {-create the list item}
+ destructor Destroy; override;
+ {-destroy the list item; if the item is attached to any lists,
+ it removes itself from those lists as well}
+
+ function Compare(aKey : pointer) : integer; virtual; abstract;
+ {-compare Self's key to aKey: return <0 if aKey < Self's, 0 if
+ equal, >0 otherwise}
+ function Key : pointer; virtual; abstract;
+ {-return a pointer to this item's key}
+ property FreeOnRemove : boolean
+ read ffliFreeOnRemove write ffliFreeOnRemove;
+ {-if true, when item is removed from one list, it removes
+ itself from all lists (and hence would be freed)}
+ property MaintainLinks : boolean
+ read ffliMaintainLinks write ffliSetMaintainLinks;
+ {-If True then track which lists contain this list item.
+ Note that if you set this property after adding the item
+ to one or more lists then it will already have a list
+ of links to those lists. So set it as soon as the item
+ is created or pay the consequences. }
+ property ReferenceCount : integer
+ read GetRefCount;
+ {-the number of lists referencing this item}
+ end;
+
+ PffListItemArray = ^TffListItemArray;
+ TffListItemArray =
+ array [0..pred(MaxInt div sizeof(TffListItem))] of TffListItem;
+
+ TffStrListItem = class(TffListItem)
+ protected {private}
+ sliKey : PffShStr;
+ sliExtraData : pointer;
+ protected
+ public
+ constructor Create(const aKey : TffShStr);
+ {-create the list item; aKey is its access/sort key}
+ destructor Destroy; override;
+ {-destroy the list item}
+
+ function KeyAsStr : TffShStr;
+ {-return this item's key as a string (for convenience)}
+
+ function Compare(aKey : pointer) : integer; override;
+ {-compare Self's key to aKey: return <0 if aKey < Self's, 0 if
+ equal, >0 otherwise}
+ function Key : pointer; override;
+ {-return a pointer to this item's key: it'll be a pointer to a
+ shortstring}
+
+ property ExtraData : pointer
+ read sliExtraData write sliExtraData;
+ end;
+
+ TffUCStrListItem = class(TffStrListItem)
+ protected {private}
+ protected
+ public
+ function Compare(aKey : pointer) : integer; override;
+ {-compare Self's key to aKey: return <0 if aKey < Self's, 0 if
+ equal, >0 otherwise; case insensitive compare}
+ end;
+
+ TffI64ListItem = class(TffListItem)
+ protected {private}
+ iliKey : TffInt64;
+ iliExtraData : Pointer;
+ public
+ constructor Create(const aKey : TffInt64);
+ {-create the list item; aKey is its access/sort key}
+ function KeyValue : TffInt64;
+ {-return this item's ket as a TffInt64 (for convenience)}
+ function Compare(aKey : pointer) : integer; override;
+ {-compare Self's key to aKey: return <0 if aKey < Self's, 0 if
+ equal, >0 otherwise}
+ function Key : pointer; override;
+ {-return a pointer to this item's key: it'll be a pointer to a
+ TffInt64}
+ property ExtraData : Pointer
+ read iliExtraData write iliExtraData;
+ {-The additional data item attached to the list item.}
+ end;
+
+ TffIntListItem = class(TffListItem)
+ protected {private}
+ iliKey : Longint;
+ iliExtraData : pointer;
+ protected
+ public
+ constructor Create(const aKey : Longint);
+ {-create the list item; aKey is its access/sort key}
+ function KeyAsInt : Longint;
+ {-return this item's key as a Longint (for convenience)}
+ function Compare(aKey : pointer) : integer; override;
+ {-compare Self's key to aKey: return <0 if aKey < Self's, 0 if
+ equal, >0 otherwise}
+ function Key : pointer; override;
+ {-return a pointer to this item's key: it'll be a pointer to a
+ Longint}
+ property ExtraData : pointer
+ read iliExtraData write iliExtraData;
+ {-The additional data item attached to the list item.}
+ end;
+
+ TffWord32ListItem = class(TffListItem)
+ protected {private}
+ wliKey : TffWord32;
+ wliExtraData : pointer;
+ wliExtraData2 : Longint;
+ protected
+ public
+ constructor Create(const aKey : TffWord32);
+ {-create the list item; aKey is its access/sort key}
+ function KeyValue : TffWord32;
+ {-return this item's key as a TffWord32 (for convenience)}
+ function Compare(aKey : pointer) : integer; override;
+ {-compare Self's key to aKey: return <0 if aKey < Self's, 0 if
+ equal, >0 otherwise}
+ function Key : pointer; override;
+ {-return a pointer to this item's key: it'll be a pointer to a
+ Longint}
+ function KeyAsInt : TffWord32;
+ {-return this item's key as a TffWord32 (for convenience)}
+ property ExtraData : pointer
+ read wliExtraData write wliExtraData;
+ {-An additional data item attached to the list item.}
+
+ property ExtraData2 : Longint
+ read wliExtraData2 write wliExtraData2;
+ {-An additional data item attached to the list item.}
+ end;
+
+ TffSelfListItem = class(TffIntListItem)
+ protected {private}
+ protected
+ public
+ constructor Create;
+ {-create the list item; Key is the Self pointer as integer}
+ end;
+
+ TffList = class(TffObject) {!!.01}
+ protected {private}
+ fflCapacity : Longint;
+ fflCount : Longint;
+ fflList : PffListItemArray;
+ fflSorted : boolean;
+ fflPortal : TffReadWritePortal; {!!.02}
+ fflState : TffListState;
+ protected
+ procedure fflGrow;
+ function GetCapacity : Longint;
+ function GetCount : Longint;
+ function GetItem(const aInx : Longint) : TffListItem;
+ procedure SetCapacity(const C : Longint);
+ procedure SetCount(const C : Longint);
+ procedure SetItem(const aInx : Longint; Item : TffListItem);
+ procedure SetSorted(S : boolean);
+
+ procedure fflDeleteAtPrim(aInx : Longint);
+ {-Removes an item from the list and frees the item if its reference
+ count is zero. }
+ function fflIndexPrim(const aKey) : Longint;
+ procedure fflRemoveAtPrim(aInx : Longint);
+ {-Removes an item from the list but does not free the item. }
+
+ procedure InternalDelete(const aKey); {!!.02}
+ public
+ constructor Create;
+ {-create the list}
+ destructor Destroy; override;
+ {-destroy the list}
+// procedure Assign(Source : TPersistent); override; {Deleted !!.01}
+ {-assign another list's data to this one}
+ procedure Delete(const aKey);
+ {-Remove an item from the list, search for it. Note this method
+ will free the item if the item's reference count is zero.}
+ procedure DeleteAt(aInx : Longint);
+ {-Remove an item from the list using its index. Note this method
+ will free the item if the item's reference count is zero.}
+ procedure Empty;
+ {-empty the list of items}
+ function Exists(const aKey) : boolean;
+ {-return true if the list has an item with the given key}
+ function GetInsertionPoint(aItem : TffListItem) : Longint;
+ {-Returns the index into which the item would be inserted. }
+ function Insert(aItem : TffListItem) : boolean;
+ {-insert an item in key sequence; return true on success}
+ function InsertPrim(aItem : TffListItem) : Longint;
+ {-insert an item in key sequence; return index or -1}
+ function IsEmpty : boolean;
+ {-return true if the list is empty}
+ function Index(const aKey) : Longint;
+ {-calculate the index of an item with the given key}
+
+ procedure Remove(const aKey);
+ {-Use this method to remove an item from the list without freeing
+ the item. }
+ procedure RemoveAt(aInx : Longint);
+ {-Use this method to remove an item at the specified position. The
+ item is not freed after it is removed from the list. }
+
+ property Capacity : Longint
+ {-the total capacity of the list}
+ read GetCapacity write SetCapacity;
+
+ property Count : Longint
+ {-the number of items in the list}
+ read GetCount write SetCount;
+
+ property Items [const aInx : Longint] : TffListItem
+ {-the list of items}
+ read GetItem write SetItem;
+ default;
+
+ property Sorted : boolean
+ {-true (by default) if the list is sorted; cannot set true if
+ list contains items}
+ read fflSorted write SetSorted;
+ end;
+
+ { This class is a threadsafe version of TffList. This class allows multiple
+ threads to have read access or one thread to have write access (i.e.,
+ multiple read, exclusive write). A thread is granted write access only if
+ there are no reading threads or writing threads.
+
+ Threads desiring thread-safe access to the list must do the following:
+
+ 1. For read access, call BeginRead. The thread will be blocked until
+ it obtains read access. Once the thread has finished, it must call
+ EndRead.
+
+ 2. For write access, call BeginWrite. The thread will be blocked until
+ all existing readers and writers have finished. Once the thread has
+ finished, it must call EndWrite.
+
+ For example:
+
+ with FList.BeginWrite do
+ try
+ // do something
+ finally
+ EndWrite;
+ end;
+
+ This is a dangerous class to use in that outside objects are responsible
+ for calling BeginRead, etc. The outside code could be written such that
+ it does not or such that it fails to call EndRead/EndWrite.
+
+ However, this implementation was chosen so that only the appropriate
+ amount of locking is performed. For example, if something needs to read
+ through a list of 100 items then we do not want to ask for read access
+ 100 times. Instead, BeginRead is called once.
+ }
+ TffThreadList = class(TffList)
+ protected {private}
+// FPortal : TffReadWritePortal; {Deleted !!.02}
+ public
+
+ constructor Create; virtual;
+
+ destructor Destroy; override;
+
+ function BeginRead : TffThreadList;
+ {-A thread must call this method to gain read access to the list.
+ Returns the instance of TffThreadList as a convenience. }
+
+ function BeginWrite : TffThreadList;
+ {-A thread must call this method to gain write access to the list.
+ Returns the instance of TffThreadList as a convenience.}
+
+ procedure EndRead;
+ {-A thread must call this method when it no longer needs read access
+ to the list. If it does not call this method, all writers will
+ be perpetually blocked. }
+
+ procedure EndWrite;
+ {-A thread must call this method when it no longer needs write access
+ to the list. If it does not call this method, all readers and writers
+ will be perpetualy blocked. }
+ end;
+
+
+ TffStringList = class(TffPersistent)
+ protected {private}
+ slCaseSensitive : boolean;
+ slList : TffList;
+ protected
+ function GetCapacity : Longint;
+ function GetCount : Longint;
+ function GetObj(aInx : Longint) : TObject;
+ function GetSorted : boolean;
+ function GetStr(aInx : Longint) : TffShStr;
+ function GetValue(const aName : TffShStr) : TffShStr;
+ procedure SetCapacity(C : Longint);
+ procedure SetCaseSensitive(CS : boolean);
+ procedure SetObj(aInx : Longint; const aObj : TObject);
+ procedure SetStr(aInx : Longint; const aStr : TffShStr);
+ procedure SetSorted(S : boolean);
+ procedure SetValue(const aName, aStr : TffShStr);
+
+ public
+ constructor Create;
+ {-create the list}
+ destructor Destroy; override;
+ {-destroy the list}
+ procedure Assign(Source : TPersistent); override;
+ {-assign another list's string data to this one}
+ procedure AssignTo(Dest : TPersistent); override;
+ {-assign this string list's data to another one}
+ procedure Delete(const aStr : TffShStr);
+ {-remove a string from the list, search for it}
+ procedure DeleteAt(aInx : Longint);
+ {-remove a string from the list using its index}
+ procedure Empty;
+ {-empty the list of strings}
+ function Exists(const aStr : TffShStr) : boolean;
+ {-return true if the list has an item with the given string}
+ function Index(const aStr : TffShStr) : Longint;
+ {-calculate the index of an item with the given string}
+ function IndexOfName(const aName: TffShStr) : Longint;
+ {-return the index of the name part of a string which is of
+ the form Name=Value}
+ function Insert(const aStr : TffShStr) : boolean;
+ {-insert an item in string sequence; return true on success}
+ function InsertPrim(const aStr : TffShStr) : Longint;
+ {-insert an item in string sequence; return index or -1}
+ function IsEmpty : boolean;
+ {-return true if the list is empty}
+
+ property Capacity : Longint
+ {-the total capacity of the list}
+ read GetCapacity write SetCapacity;
+
+ property CaseSensitive : boolean
+ read slCaseSensitive write SetCaseSensitive;
+ {-whether string compares are case sensitive or not; cannot
+ set true if the list contains items}
+
+ property Count : Longint
+ {-the number of strings in the list}
+ read GetCount;
+
+ property Strings [aInx : Longint] : TffShStr
+ {-the list of strings}
+ read GetStr write SetStr;
+ default;
+
+ property Objects [aInx : Longint] : TObject
+ {-the list of objects associated with strings}
+ read GetObj write SetObj;
+
+ property Sorted : boolean
+ {-true (by default) if the list is sorted; cannot set true if
+ list contains items}
+ read GetSorted write SetSorted;
+
+ property Values [const aName: TffShStr] : TffShStr
+ {-returns a string value given a string keyword. Assumes the
+ list of strings consists of "keyword=value" pairs. }
+ read GetValue write SetValue;
+ end;
+
+ { The following types are used by TffPointerList to store a list of pointers. }
+ PffPointerArray = ^TffPointerArray;
+ TffPointerArray =
+ array [0..pred(MaxInt div sizeof(Pointer))] of Pointer;
+
+ { This is an unsorted list type dealing only with pointers. Note that it is
+ the responsibility of the application to free the memory referenced by the
+ pointer. }
+ TffPointerList = class(TffPersistent)
+ protected {private}
+ plCapacity : Longint;
+ plCount : Longint;
+ plList : PffPointerArray;
+ protected
+
+ function AppendPrim(aPtr : Pointer) : Longint;
+ procedure fflGrow;
+ function GetCapacity : Longint;
+ function GetCount : Longint;
+ function GetPointer(aInx : Longint) : Pointer;
+ function GetInternalAddress : Pointer;
+ procedure SetCapacity(const C : Longint);
+ procedure SetCount(const C : Longint);
+ procedure SetPointer(aInx : Longint; aPtr : Pointer);
+
+ procedure fflRemoveAtPrim(aInx : Longint);
+ {-Removes an item from the list but does not free the item. }
+
+ public
+ constructor Create;
+ {-create the list}
+ destructor Destroy; override;
+ {-destroy the list}
+ procedure Assign(Source : TPersistent); override;
+ {-assign another list's data to this one}
+ function Append(aPtr : Pointer) : boolean;
+ {-append an item to the list; return true on success}
+ procedure Empty;
+ {-Empty the list of pointers. Note that the application is
+ responsible for freeing the memory referenced by the pointers. }
+ function IsEmpty : boolean;
+ {-return true if the list is empty}
+
+ procedure RemoveAt(aInx : Longint);
+ {-Use this method to remove the pointer at the specified position. }
+
+ property Capacity : Longint
+ {-the total capacity of the list}
+ read GetCapacity write SetCapacity;
+
+ property Count : Longint
+ {-the number of items in the list}
+ read GetCount write SetCount;
+
+ property InternalAddress : pointer read GetInternalAddress;
+ {-Returns a pointer to the internal list of pointers. Be careful with
+ this. It is to be used only when necessary. }
+
+ property List : PffPointerArray read plList;
+ {-Provides direct access to the internal list of pointers. Use this
+ only if you know what you are doing. }
+
+ property Pointers[aInx : Longint] : Pointer
+ {-the list of items}
+ read GetPointer write SetPointer; default;
+ end;
+
+
+ { The following types are used by TffHandleList to store a list of handles. }
+ PffHandleArray = ^TffHandleArray;
+ TffHandleArray =
+ array [0..pred(MaxInt div sizeof(THandle))] of THandle;
+
+ { This is an unsorted list type dealing only with THandles. It is used by
+ TffSemaphorePool, TffMutexPool & TffEventPool. }
+ TffHandleList = class(TffPersistent)
+ protected {private}
+ FCapacity : Longint;
+ FCount : Longint;
+ FList : PffHandleArray;
+ protected
+
+ function AppendPrim(aHandle : THandle) : Longint;
+ procedure fflGrow;
+ function GetCapacity : Longint;
+ function GetCount : Longint;
+ function GetHandle(aInx : Longint) : THandle;
+ function GetInternalAddress : pointer;
+ procedure SetCapacity(const C : Longint);
+ procedure SetCount(const C : Longint);
+
+ procedure fflDeleteAtPrim(aInx : Longint);
+ {-Removes an item from the list and frees the item if its reference
+ count is zero. }
+ procedure fflRemoveAtPrim(aInx : Longint);
+ {-Removes an item from the list but does not free the item. }
+
+ public
+ constructor Create;
+ {-create the list}
+ destructor Destroy; override;
+ {-destroy the list}
+ procedure Assign(Source : TPersistent); override;
+ {-assign another list's data to this one}
+ procedure DeleteAt(aInx : Longint);
+ {-Remove an item from the list using its index. Note this method
+ will close the handle. }
+ procedure Empty;
+ {-empty the list of items}
+ function Append(aHandle : THandle) : boolean;
+ {-append an item to the list; return true on success}
+ function IsEmpty : boolean;
+ {-return true if the list is empty}
+
+ procedure RemoveAll;
+ {-Removes all handles from the list without closing any of the
+ handles. }
+
+ procedure RemoveAt(aInx : Longint);
+ {-Use this method to remove an item at the specified position. The
+ handle is not closed after it is removed from the list. }
+
+ property Capacity : Longint
+ {-the total capacity of the list}
+ read GetCapacity write SetCapacity;
+
+ property Count : Longint
+ {-the number of items in the list}
+ read GetCount write SetCount;
+
+ property InternalAddress : pointer read GetInternalAddress;
+ {-Returns a pointer to the internal list of handles. Be careful with
+ this. It is to be used only when necessary. }
+
+ property Handles[aInx : Longint] : THandle
+ {-the list of items}
+ read GetHandle; default;
+ end;
+
+ { This is a thread-safe string list class. It handles read/write access issues
+ identical to TffThreadList. }
+ TffThreadStringList = class(TffStringList)
+ protected
+ tslPortal : TffReadWritePortal;
+ public
+
+ constructor Create;
+
+ destructor Destroy; override;
+
+ function BeginRead : TffThreadStringList;
+ {-A thread must call this method to gain read access to the list.
+ Returns the instance of TffThreadList as a convenience. }
+
+ function BeginWrite : TffThreadStringList;
+ {-A thread must call this method to gain write access to the list.
+ Returns the instance of TffThreadList as a convenience. }
+
+ procedure EndRead;
+ {-A thread must call this method when it no longer needs read access
+ to the list. If it does not call this method, all writers will
+ be perpetually blocked. }
+
+ procedure EndWrite;
+ {-A thread must call this method when it no longer needs write access
+ to the list. If it does not call this method, all readers and writers
+ will be perpetualy blocked. }
+
+ end;
+
+ TffQueue = class(TffObject)
+ protected
+ ffqList : TffList;
+
+ function GetCount : Longint;
+
+ function GetItem(aInx : Longint) : TffListItem;
+
+ public
+
+ constructor Create;
+
+ destructor Destroy; override;
+
+ procedure Delete(const aKey);
+ { Remove an item from the queue based upon its key. }
+
+ function Dequeue : TffListItem;
+ {-Returns the first item inserted into the queue or nil if the queue
+ is empty. The item is automatically removed from the queue. }
+
+ procedure Enqueue(anItem : TffListItem);
+ {-Add an item to the queue. }
+
+ function IsEmpty : boolean;
+ {-Returns True if the queue is empty. }
+
+ property Count : Longint read GetCount;
+ {-Returns the number of items in the queue. }
+
+ property Items [aInx : Longint] : TffListItem read GetItem; default;
+ {-The list of queued items. Items[0] is the first item in the
+ queue. }
+
+ end;
+
+ TffThreadQueue = class(TffQueue)
+ protected
+ fftqPortal : TffReadWritePortal;
+ public
+ constructor Create;
+
+ destructor Destroy; override;
+
+ function BeginRead : TffThreadQueue;
+ {-A thread must call this method to gain read access to the queue.
+ Returns the instance of TffThreadQueue as a convenience. }
+
+ function BeginWrite : TffThreadQueue;
+ {-A thread must call this method to gain write access to the queue.
+ Returns the instance of TffThreadQueue as a convenience. }
+
+ procedure EndRead;
+ {-A thread must call this method when it no longer needs read access
+ to the queue. If it does not call this method, all writers will
+ be perpetually blocked. }
+
+ procedure EndWrite;
+ {-A thread must call this method when it no longer needs write access
+ to the queue. If it does not call this method, all readers and writers
+ will be perpetualy blocked. }
+
+ end;
+
+{===Semaphore Pool===}
+type
+ TffSemaphorePool = class
+ protected
+ spList : TffHandleList;
+ spRetainCount : integer;
+ spPadLock : TffPadlock;
+ public
+ constructor Create(const initialCount, retainCount : integer);
+ destructor Destroy; override;
+ procedure Flush;
+ function Get : THandle;
+ procedure GetTwo(var aHandle1, aHandle2 : THandle); {!!.06}
+ procedure Put(const aHandle : THandle);
+ end;
+
+{===Mutex Pool===}
+type
+ TffMutexPool = class
+ protected
+ mpList : TffHandleList;
+ mpRetainCount : integer;
+ mpPadLock : TffPadlock;
+ public
+ constructor Create(const initialCount, retainCount : integer);
+ destructor Destroy; override;
+ procedure Flush;
+ function Get : THandle;
+ procedure Put(const aHandle : THandle);
+ end;
+
+{$IFDEF UseEventPool}
+{===Event Pool===}
+type
+ TffEventPool = class
+ protected
+ epList : TffHandleList;
+ epRetainCount : Integer;
+ epPadLock : TffPadLock;
+ public
+ constructor Create(const InitialCount, RetainCount : Integer);
+ destructor Destroy; override;
+ procedure Flush;
+ function Get : THandle;
+ procedure Put(const aHandle : THandle);
+ end;
+{$ENDIF}
+
+{===Memory Pool===}
+type
+ { This type defines the format of the information at the head of each
+ block allocated by a memory pool. }
+ PffMemBlockInfo = ^TffMemBlockInfo;
+ TffMemBlockInfo = packed record
+ NextBlock : pointer;
+ UsageCounter : Longint;
+ end;
+ TffMemoryPool = class
+ { A memory pool is a heap manager for managing allocations and
+ deallocations of items on the heap which all have the same size. This
+ class helps reduce heap fragmentation when lots of small allocations
+ (interspersed with frees) are made on the heap.
+
+ In practice, an application will have multiple memory pools to support
+ allocation of items of varying size.
+
+ When new memory is needed, a memory pool requests a slightly larger
+ than 64k block from the Delphi memory manager. The memory pool's
+ block format is as follows:
+
+ 1. The first 4 bytes of a block are used as a pointer to the next block
+ previously allocated by the memory pool. The memory pool maintains
+ a chain of blocks. When the memory pool is freed, it walks through
+ and deallocates the blocks. The very last block in the chain will
+ have these 4 bytes set to nil.
+
+ 2. The second 4 bytes of a block implement a usage counter. As mentioned
+ above, a block will be subdivided into one or more items with one
+ item being handed out to each request for memory. The usage counter
+ tracks the actual number of items handed out. The usage counter is
+ incremented when an item is allocated (i.e., handed out). The usage
+ counter is decremented when an item is deallocated (i.e., handed
+ back).
+
+ The memory pool's RemoveUnusedBlocks method gets rid of blocks having
+ their usage counter set to zero.
+
+ 3. The remaining bytes of the block are subdivided into items of the
+ size supported by the pool. However, each item includes an extra
+ 2 bytes which serve as an offset back to the block's usage counter.
+
+ For example, if the memory pool is created to support items that are
+ 32 bytes in size then the 32k block will be subdivided into
+ 65536 div (32 bytes + 2 bytes) = 1,927 items. As mentioned above, the
+ first 2 bytes of each item provide an offset back to the block's usage
+ counter. This is required so that when an item is deallocated, the
+ block's usage counter may be decremented.
+
+ The next 4 bytes of the item are used to include the item in a chain
+ of free items. When the block is initialized, the memory pool
+ walks through the items forming a chain as it goes. The first item
+ in the block has this 4 bytes set to nil. The second item has the
+ 4 bytes pointing back to the first item. The third item has the
+ 4 bytes pointing back to the second item, and so on until the last
+ item of the block.
+
+ This chaining makes it very quick to allocate a new item. The
+ memory pool maintains a pointer to the first free item (regardless
+ of block). When the item is allocated, the memory pool updates the
+ head of this chain to point to the item referenced by the
+ newly-allocated item. }
+ protected {private}
+ FItemSize : TffMemSize;
+ FItemsInBlock: integer;
+ FBlockSize : integer;
+ FFirstBlock : PffMemBlockInfo;
+ FFreeList : pointer;
+ {-Points to the next available item in a chain of items that The free
+ list is updated as items are freed and removed. }
+
+ mpPadlock : TffPadlock;
+ protected
+ procedure mpAddBlock;
+ procedure mpCleanFreeList(const BlockStart : pointer);
+ {-When a block is removed from memory, this routine is used to remove
+ the block's items from the free list. }
+ public
+ constructor Create(ItemSize : TffMemSize; ItemsInBlock : integer);
+ {-Create a pool of items. Each item has size ItemSize;
+ ItemsInBlock defines how many items are allocated at once
+ from the Delphi heap manager. If ItemSize * ItemsInBlock > 64k
+ then ItemsInBlock will be reduced such that it fits within 64k. }
+ destructor Destroy; override;
+ {-Free all blocks in the memory pool; destroy the object; all
+ non-freed allocations from the pool will be invalid after
+ this point}
+ function Alloc : pointer;
+ {-Allocate a new item from the pool, return its address}
+ function BlockCount : Longint;
+ {-Return the number of blocks owned by the memory pool. }
+ function BlockUsageCount(const BlockIndex : Longint) : Longint;
+ {-Retrieves the usage count for a specific block. BlockIndex identifies
+ the block whose usage count is to be retrieved and is base 0.
+ Returns -1 if the specified block could not be found. }
+ procedure Dispose(var P);
+ {-Return an item to the pool for reuse; set the pointer to nil}
+ function RemoveUnusedBlocks : integer;
+ {-Use this method to have the memory pool free its unused blocks.
+ Returns the number of blocks freed. }
+
+ property BlockSize : integer read FBlockSize;
+ { The total size of a block in the memory pool. }
+
+ property ItemsInBlock : integer read FItemsInBlock;
+ { The number of items into which a block is subdivided. }
+
+ property ItemSize : TffMemSize read FItemSize;
+ { The size of each item within the block. }
+ end;
+
+
+{===FlashFiler TffComponent class===}
+ { All FF classes that would normally inherit from TComponent must inherit
+ from this class instead. }
+ TffComponent = class(TComponent)
+{$IFDEF IsDelphi} {!!.03}
+ class function NewInstance : TObject; override;
+ procedure FreeInstance; override;
+{$ENDIF} {!!.03}
+{Begin !!.03}
+ {$IFDEF FF_DEBUG_THREADS}
+ protected {private}
+ ffcMethodLock : Integer;
+ ffcCurrentThreadID : Cardinal;
+ ffcThreadLockCount : Integer;
+ protected
+ procedure ThreadEnter;
+ procedure ThreadExit;
+ public
+ {$ENDIF}
+{End !!.03}
+ protected
+ fcDependentList : TffList; {!!.11}
+ fcLock : TffPadlock; {!!.11}
+ fcDestroying : Boolean;
+ function GetVersion : string;
+ procedure SetVersion(const Value : string);
+ public
+ constructor Create(AOwner : TComponent); override;
+ destructor Destroy; override;
+
+ procedure FFAddDependent(ADependent : TffComponent); virtual; {!!.11}
+ procedure FFNotification(const AOp : Byte; AFrom : TffComponent);
+ procedure FFNotificationEx(const AOp : Byte; AFrom : TffComponent;
+ const AData : TffWord32); virtual;
+ procedure FFRemoveDependent(ADependent : TffComponent); virtual; {!!.11}
+ procedure FFNotifyDependents(const AOp : Byte); virtual; {!!.05}
+ procedure FFNotifyDependentsEx(const AOp : Byte; const AData : TffWord32);
+ published
+ property Version : string
+ read GetVersion
+ write SetVersion
+ stored False;
+ end;
+
+{===Timer declarations===}
+type
+ TffTimer = packed record
+ trStart : DWord; {!!.10}
+ trExpire : DWord; {!!.10}
+ trWrapped : boolean;
+ trForEver : boolean;
+ end;
+
+const
+ ffc_TimerInfinite = 0; {!!.06}
+// {$IFDEF FF_DEBUG} {Deleted !!.03}
+ ffc_TimerMaxExpiry = 3600 * 1000;
+// {$ELSE} {Deleted !!.03}
+// ffc_TimerMaxExpiry = 30000; {Deleted !!.03}
+// {$ENDIF FF_DEBUG} {Deleted !!.03}
+
+procedure SetTimer(var T : TffTimer; Time : DWord); {!!.10}
+ {-Set a timer to expire in Time milliseconds. 1 <= Time <= 30000.}
+function HasTimerExpired(const T : TffTimer) : boolean;
+ {-Return true if the timer has expired}
+
+
+{===Comparison declarations===}
+function FFCmpB(a, b : byte) : integer;
+ {-return -ve number if ab; a,b unsigned 8-bit}
+function FFCmpDW(const a, b : TffWord32) : integer;
+ {-return -ve number if ab; a,b unsigned 32-bit}
+function FFCmpI(a, b : integer) : integer;
+ {-return -ve number if ab; a,b signed integers}
+function FFCmpI16(a, b : smallint) : integer;
+ {-return -ve number if ab; a,b signed 16-bit}
+function FFCmpI32(a, b : Longint) : integer;
+ {-return -ve number if ab; a,b signed 32-bit}
+function FFCmpI8(a, b : shortint) : integer;
+ {-return -ve number if ab; a,b signed 8-bit}
+function FFCmpW(a, b : TffWord16) : integer;
+ {-return -ve number if ab; a,b unsigned 16-bit}
+function FFCmpBytes(const a, b : PffByteArray; MaxLen : integer) : integer;
+ {-return -ve number if ab; a,b byte arrays}
+ { At most MaxLen bytes are compared}
+function FFCmpShStr(const a, b : TffShStr; MaxLen : byte) : integer;
+ {-return -ve number if ab; a,b short strings}
+ { At most MaxLen characters are compared}
+function FFCmpShStrUC(const a, b : TffShStr; MaxLen : byte) : integer;
+ {-return -ve number if ab; a,b short strings, case insensitive}
+ { At most MaxLen characters are compared}
+function FFCmpI64(const a, b : TffInt64) : integer;
+ {-return -ve number if ab; a,b signed TffWord32}
+
+{===TffInt64 Operations===}
+procedure ffCloneI64(var aDest : TffInt64; const aSrc : TffInt64);
+ {-clone a variable of type TffInt64}
+procedure ffInitI64(var I : TffInt64);
+ {-initialize a variable of type TffInt64}
+procedure ffShiftI64L(const I : TffInt64; const Bits : Byte; var Result : TffInt64);
+ {-shift a TffInt64 to the left Bits spaces}
+procedure ffShiftI64R(const I : TffInt64; const Bits : Byte; var Result : TffInt64);
+ {-shift a TffInt64 to the right Bits spaces}
+procedure ffI64MinusI64(const a, b : TffInt64; var Result : TffInt64);
+ {-subtract a TffInt64 from a TffInt64}
+procedure ffI64MinusInt(const aI64 : TffInt64; const aInt : TffWord32; var Result : TffInt64);
+ {-subtract an integer from a TffInt64}
+function ffI64ModInt(const aI64 : TffInt64; const aInt : TffWord32) : integer;
+ {-remainder of aI64 divided by aInt}
+procedure ffI64DivInt(const aI64 : TffInt64; const aInt : TffWord32; var Result : TffInt64);
+ {-divide a TffInt64 by an integer}
+procedure ffI64MultInt(const aI64 : TffInt64; const aInt : TffWord32; var Result : TffInt64);
+ {-Multiply a TffInt64 by an integer}
+procedure ffI64AddInt(const aI64 : TffInt64; const aInt : TffWord32; var Result : TffInt64);
+ {-add an integer to a TffInt64}
+function ffI64ToInt(const aI64 : TffInt64) : TffWord32;
+ {-convert a TffInt64 to an integer}
+function ffI64ToStr(const aI64 : TffInt64) : string;
+ {-convert a TffInt64 to a string}
+procedure ffIntToI64(const aInt : TffWord32; var Result : TffInt64);
+ {-convert an integer to a TffInt64}
+function ffI64IsZero(const aI64 : TffInt64) : boolean;
+ {-If the specified Int64 is zero then return True. }
+
+
+{===Minimum/maximum declarations===}
+function FFMinDW(a, b : TffWord32) : TffWord32;
+ {-calculate the (signed) minimum of two long integers}
+function FFMaxDW(a, b : TffWord32) : TffWord32;
+ {-calculate the (signed) maximum of two long integers}
+function FFMinI(a, b : integer) : integer;
+ {-calculate the (signed) minimum of two integers}
+function FFMaxI(a, b : integer) : integer;
+ {-calculate the (signed) maximum of two integers}
+function FFMinL(a, b : Longint) : Longint;
+ {-calculate the (signed) minimum of two long integers}
+function FFMaxL(a, b : Longint) : Longint;
+ {-calculate the (signed) maximum of two long integers}
+function FFMinI64(a, b : TffInt64) : TffInt64;
+ {-calculate the (signed) minimum of two TffInt64s}
+function FFMaxI64(a, b : TffInt64) : TffInt64;
+ {-calculate the (signed) maximum of two TffInt64s}
+
+{===Calculate value declarations===}
+function FFCheckDescend(aAscend : boolean; a : integer) : integer;
+ {-if aAscend is false, -a is returned, if true a is returned}
+function FFForceInRange(a, aLow, aHigh : Longint) : Longint;
+ {-Force a to be in the range aLow..aHigh inclusive}
+ { NOTE: no checks are made to see that aLow < aHigh}
+function FFForceNonZero(a, b : integer) : integer;
+ {-if first integer is non-zero return it, else return second}
+
+{===Memory allocation, etc===}
+procedure FFFreeMem(var P; Size : TffMemSize);
+ {-deallocate memory allocated by FFGetMem}
+procedure FFGetMem(var P; Size : TffMemSize);
+ {-like GetMem, but uses memory pools}
+procedure FFGetZeroMem(var P; Size : TffMemSize);
+ {-like GetMem, but allocated memory is zeroed out}
+procedure FFReallocMem(var P; OldSize, NewSize: Integer);
+ {-deallocates OldSize bytes for P then allocates aNewSize bytes
+ for P. }
+
+{===String routines===}
+function FFCommaizeChL(L : Longint; Ch : AnsiChar) : AnsiString;
+ {-Convert a long integer to a string with Ch in comma positions}
+procedure FFShStrConcat(var Dest : TffShStr; const Src : TffShStr);
+procedure FFShStrAddChar(var Dest : TffShStr; C : AnsiChar);
+function FFShStrAlloc(const S : TffShStr) : PffShStr;
+procedure FFShStrFree(var P : PffShStr);
+function FFShStrRepChar(C : AnsiChar; N : integer) : TffShStr;
+function FFShStrUpper(const S : TffShStr) : TffShStr;
+function FFShStrUpperAnsi(const S : TffShStr) : TffShStr;
+function FFStrAlloc(aSize : integer) : PAnsiChar;
+function FFStrAllocCopy(S : PAnsiChar) : PAnsiChar;
+procedure FFStrDispose(S : PAnsiChar);
+function FFStrNew(const S : TffShStr) : PAnsiChar;
+function FFStrPas(S : PAnsiChar) : TffShStr;
+function FFStrPasLimit(S : PAnsiChar; MaxCharCount : integer) : TffShStr;
+function FFStrPCopy(Dest : PAnsiChar; const S : TffShStr) : PAnsiChar;
+function FFStrPCopyLimit(Dest : PAnsiChar; const S : TffShStr;
+ MaxCharCount : integer) : PAnsiChar;
+procedure FFShStrSplit(S: TffShStr; const SplitChars: TffShStr;
+ var Left, Right: TffShStr);
+ {-Returns in Left and Right the substrings of S that exist to the left
+ and right of any occurrence of any character given in SplitChars (see
+ implementation) }
+procedure FFStrTrim(P : PAnsiChar);
+ {-Trim leading and trailing blanks from P}
+function FFStrTrimR(S : PAnsiChar) : PAnsiChar;
+ {-Return a string with trailing white space removed}
+function FFShStrTrim(const S : TffShStr) : TffShStr;
+function FFShStrTrimL(const S : TffShStr) : TffShStr;
+function FFShStrTrimR(const S : TffShStr) : TffShStr;
+function FFShStrTrimWhite(const S : TffShStr) : TffShStr;
+function FFShStrTrimWhiteL(const S : TffShStr) : TffShStr;
+function FFShStrTrimWhiteR(const S : TffShStr) : TffShStr;
+function FFTrim(const S : string) : string;
+function FFTrimL(const S : string) : string;
+function FFTrimR(const S : string) : string;
+function FFTrimWhite(const S : string) : string;
+function FFTrimWhiteL(const S : string) : string;
+function FFTrimWhiteR(const S : string) : string;
+function FFOmitMisc(const S : string) : string;
+ {-Omit whitespace and punctuation characters from a string. }
+function FFAnsiCompareText(const S1, S2 : string) : Integer; {!!.10}
+ {-Includes an extra failsafe comparison option if SafeAnsiCompare
+ is defined }
+function FFAnsiStrIComp(S1, S2: PChar): Integer; {!!.10}
+ {-Includes an extra failsafe comparison option if SafeAnsiCompare
+ is defined }
+function FFAnsiStrLIComp(S1, S2: PChar; MaxLen: Cardinal): Integer; {!!.10}
+ {-Includes an extra failsafe comparison option if SafeAnsiCompare
+ is defined }
+
+{===Wide-String routines===}
+function FFCharToWideChar(Ch: AnsiChar): WideChar;
+{-Copies an ANSI character to a UNICODE wide character}
+
+function FFWideCharToChar(WC: WideChar): AnsiChar;
+{-Copies a UNICODE wide char to an ANSI character}
+
+function FFShStrLToWideStr(S: TffShStr; WS: PWideChar; MaxLen: Longint): PWideChar;
+{-Copies a short string to a null-terminated UNICODE wide string}
+
+function FFWideStrLToShStr(WS: PWideChar; MaxLen: Longint): TffShStr;
+{-Copies a null-terminated UNICODE wide string to a short string}
+
+function FFNullStrLToWideStr(ZStr: PAnsiChar; WS: PWideChar; MaxLen: Longint): PWideChar;
+{-Copies a null-terminated ANSI string to a null-terminated UNICODE wide string}
+
+function FFWideStrLToNullStr(WS: PWideChar; ZStr: PAnsiChar; MaxLen: Longint): PAnsiChar;
+{-Copies a null-terminated UNICODE wide string to a null-terminated ANSI string}
+
+function FFWideStrLToWideStr(aSourceValue, aTargetValue: PWideChar; MaxLength: Longint): PWideChar;
+{-Copies a null-terminated UNICODE wide string to another null-terminated UNICODE string}
+
+{===File and Path name routines===}
+function FFDirectoryExists(const Path : TffPath) : boolean;
+ {-Returns true if the directory given by PN exists}
+function FFExpandFileName(const FN : TffFullFileName) : TffFullFileName;
+ {-Merges the filename with the current drive/directory to give a
+ fully expanded file name; . and .. references are removed}
+function FFExtractExtension(const PFN : TffFullFileName) : TffExtension;
+ {-Extracts the file name extension from the path/file name PFN}
+function FFExtractFileName(const PFN : TffFullFileName) : TffFileName;
+ {-Strips the path and extension from the path/file name PFN}
+function FFExtractPath(const PFN : TffFullFileName) : TffPath;
+ {-Extracts the path from the path/file name PFN (excluding final \)}
+function FFExtractTableName(const PFN : TffFullFileName) : TffTableName;
+ {-Strips the path and extension from the path/file name PFN to give a table name}
+function FFFileExists(const PFN : TffFullFileName) : boolean;
+ {-Return true if the file exists; wildcards are not allowed: if any
+ are found, returns false}
+procedure FFFindClose(var SR : TffSearchRec);
+function FFFindFirst(const PFN : TffFullFileName;
+ ItemType : TffDirItemTypeSet;
+ Attr : TffDirItemAttrSet;
+ var SR : TffSearchRec) : integer;
+function FFFindNext(var SR : TffSearchRec) : integer;
+ {-Directory 'find file' routines, in 32-bit they use shortstrings
+ instead}
+function FFForceExtension(const PFN : TffFullFileName;
+ const Ext : TffExtension) : TffFullFileName;
+ {-Forces the path/file name PFN to have a given extension Ext}
+function FFGetCurDir : TffPath;
+ {-Returns the current directory (in 16-bit, on the current drive)}
+function FFGetDirList(const Path : TffPath; FileSpec : TffFileNameExt) : TffStringList;
+ {-Reads a directory with a given file spec, creates a string list to
+ hold each file+ext encountered (the caller must free the list)}
+function FFGetEXEName : TffFullFileName;
+ {-Retrieves the full expanded file name of the calling program}
+function FFHasExtension(const PFN : TffFullFileName; var DotPos : integer) : boolean;
+ {-Returns true and the period position if the given path/file name
+ has an extension}
+function FFMakeFileNameExt(const FileName : TffFileName;
+ const Ext : TffExtension) : TffFileNameExt;
+ {-Concatenate a file name with extension}
+function FFMakeFullFileName(const Path : TffPath;
+ const FileName : TffFileNameExt) : TffFullFileName;
+ {-Prepend a path to a file name with extension}
+function FFSetCurDir(Path : TffPath) : boolean;
+ {-Set the current directory}
+
+
+{===BitSet routines===}
+procedure FFClearAllBits(BitSet : PffByteArray; BitCount : integer);
+ {-Clear all bits in a bit set}
+procedure FFClearBit(BitSet : PffByteArray; Bit : integer);
+ {-Clear a bit in a bit set}
+function FFIsBitSet(BitSet : PffByteArray; Bit : integer) : boolean;
+ {-Return whether a bit is set}
+procedure FFSetAllBits(BitSet : PffByteArray; BitCount : integer);
+ {-Clear a bit set, ie set all bits off}
+procedure FFSetBit(BitSet : PffByteArray; Bit : integer);
+ {-Set all bits in a bit set}
+
+
+{===Verification routines===}
+function FFVerifyBlockSize(BlockSize : Longint) : boolean;
+ {-Verify BlockSize to be 4K, 8K, 16K or 32K}
+function FFVerifyKeyLength(KeyLen : word) : boolean;
+ {-Verify length of key to be between 1 and 1024}
+function FFVerifyExtension(const Ext : TffExtension) : boolean;
+ {-Validates a string to contain a valid extension; allowed: a-z, 0-9
+ and _}
+function FFVerifyFileName(const FileName : TffFileName) : boolean;
+ {-Validates a string to contain a valid filename (no drive, path or
+ extension allowed); in 16-bit the length must be 8 or less; in
+ 32-bit it must be 31 characters or less; allowed: a-z, 0-9 and _}
+function FFVerifyServerName(aName: TffNetAddress): Boolean;
+ {-Validates a string to contain a valid server name; must be 15
+ chars or less; valid chars are A-Z, a-z, 0-9, or space }
+
+{===WWW Interfaces===}
+procedure ShellToWWW;
+ {-Shell out to TurboPower WWW site}
+procedure ShellToEMail;
+ {-Shell to e-mail to TurboPower tech support}
+
+{===Mutex & Semaphore pools===}
+var
+ FFSemPool : TffSemaphorePool;
+ { FF uses a lot of semaphores for managing threadsafe lists & queues.
+ It takes a lot of time to create semaphores so we store unused
+ semaphores in a pool until they are needed. }
+
+ {$IFDEF UseEventPool}
+ FFEventPool : TffEventPool;
+ {$ENDIF}
+ { FF uses a lot of semaphores for managing access to threadsafe lists
+ & queues. It takes a lot of time to create events so we store unused
+ events in a pool until they are needed. }
+
+{===Utility routines===}
+function FFByteAsHex(Dest : PAnsiChar; B : byte) : PAnsiChar;
+function FFMapBlockSize(const aBlockSize : Longint) : TffBlockSize;
+function FFPointerAsHex(Dest : PAnsiChar; P : pointer) : PAnsiChar;
+procedure FFFlushMemPools; {!!.01}
+procedure FFValCurr(const S : string; var V : Currency; var Code : Integer); {!!.06}
+
+{== File-related utility routines ====================================}{!!.11 - Start}
+{$IFDEF DCC4OrLater}
+function PreGetDiskFreeSpaceEx(Directory : PChar;
+ var FreeAvailable,
+ TotalSpace : TLargeInteger;
+ TotalFree : PLargeInteger)
+ : Bool; stdcall;
+
+function FFGetDiskFreeSpace(const aDirectory : string) : Integer;
+ { Returns the amount of free space on the specified drive & directory,
+ in kilobytes. }
+
+var
+ FFLLGetDiskFreeSpaceEx : function (Directory : PChar;
+ var FreeAvailable,
+ TotalSpace : TLargeInteger;
+ TotalFree : PLargeInteger)
+ : Bool stdcall;
+{$ELSE}
+function PreGetDiskFreeSpaceEx(Directory : PChar;
+ var FreeAvailable,
+ TotalSpace : Integer;
+ TotalFree : PInteger)
+ : Bool; stdcall;
+
+function FFGetDiskFreeSpace(const aDirectory : string) : Integer;
+ { Returns the amount of free space on the specified drive & directory,
+ in kilobytes. }
+
+var
+ FFLLGetDiskFreeSpaceEx : function (Directory : PChar;
+ var FreeAvailable,
+ TotalSpace : Integer;
+ TotalFree : PInteger)
+ : Bool stdcall;
+{$ENDIF}
+
+
+{$IFDEF MemPoolTrace}
+var
+ Log : System.Text;
+{$ENDIF}
+
+implementation
+
+uses
+ {$IFDEF FF_DEBUG_THREADS}
+ JclSynch,
+ {$ENDIF}
+ ffllexcp;
+
+resourcestring
+ EX_ErrorWWW = 'Unable to start web browser. Make sure you have it properly setup on your system.';
+ //EX_ErrorEMAIL = 'Unable to start Internet mail client. Make sure you have it properly setup on your system.';
+
+{===Timer routines===================================================}
+procedure SetTimer(var T : TffTimer; Time : DWord); {!!.10}
+begin
+ with T do begin
+ if (Time = ffc_TimerInfinite) then begin
+ trForEver := true;
+ trStart := 0;
+ trExpire := 0;
+ trWrapped := false;
+ end
+ else begin
+ trForEver := false;
+ Time := FFForceInRange(Time, 1, ffc_TimerMaxExpiry);
+ trStart := GetTickCount;
+ trExpire := trStart + Time;
+ trWrapped := FFCmpDW(trStart, trExpire) < 0;
+ end;
+ end;
+end;
+{--------}
+function HasTimerExpired(const T : TffTimer) : boolean;
+asm
+ push ebx
+ xor ebx, ebx
+ cmp [eax].TffTimer.trForEver, 0
+ jne @@Exit
+ push eax
+ call GetTickCount
+ pop edx
+ mov ecx, [edx].TffTimer.trExpire
+ mov edx, [edx].TffTimer.trStart
+ cmp edx, ecx
+ jbe @@StartLEExpire
+@@StartGEExpire:
+ cmp eax, edx
+ jae @@Exit
+ cmp eax, ecx
+ jae @@Expired
+ jmp @@Exit
+@@StartLEExpire:
+ cmp eax, ecx
+ jae @@Expired
+ cmp eax, edx
+ jae @@Exit
+@@Expired:
+ inc ebx
+@@Exit:
+ mov eax, ebx
+ pop ebx
+end;
+{====================================================================}
+
+{===Utility routines=================================================}
+function FFByteAsHex(Dest : PAnsiChar; B : byte) : PAnsiChar;
+const
+ HexChars : array [0..15] of AnsiChar = '0123456789abcdef';
+begin
+ if (Dest <> nil) then begin
+ Dest[0] := HexChars[B shr 4];
+ Dest[1] := HexChars[B and $F];
+ Dest[2] := #0;
+ end;
+ Result := Dest;
+end;
+{--------}
+function FFMapBlockSize(const aBlockSize : Longint) : TffBlockSize;
+begin
+ case aBlockSize of
+ 4 * 1024 : Result := ffbs4k;
+ 8 * 1024 : Result := ffbs8k;
+ 16 * 1024 : Result := ffbs16k;
+ 32 * 1024 : Result := ffbs32k;
+ 64 * 1024 : Result := ffbs64k;
+ else
+ Result := ffbs4k
+ end; { case }
+end;
+{--------}
+function FFPointerAsHex(Dest : PAnsiChar; P : pointer) : PAnsiChar;
+var
+ L : Longint;
+begin
+ Result := Dest;
+ if (Dest <> nil) then begin
+ L := Longint(P);
+ FFByteAsHex(Dest, L shr 24);
+ inc(Dest, 2);
+ FFByteAsHex(Dest, (L shr 16) and $FF);
+ inc(Dest, 2);
+ FFByteAsHex(Dest, (L shr 8) and $FF);
+ inc(Dest, 2);
+ FFByteAsHex(Dest, L and $FF);
+ end;
+end;
+{====================================================================}
+
+{===Integer comparison declarations==================================}
+function FFCmpB(a, b : byte) : integer;
+asm
+ xor ecx, ecx
+ cmp al, dl
+ ja @@GT
+ je @@EQ
+@@LT:
+ dec ecx
+ dec ecx
+@@GT:
+ inc ecx
+@@EQ:
+ mov eax, ecx
+end;
+{--------}
+function FFCmpDW(const a, b : TffWord32) : integer;
+asm
+ xor ecx, ecx
+ cmp eax, edx
+ ja @@GT
+ je @@EQ
+@@LT:
+ dec ecx
+ dec ecx
+@@GT:
+ inc ecx
+@@EQ:
+ mov eax, ecx
+end;
+{--------}
+function FFCmpI(a, b : integer) : integer;
+asm
+ xor ecx, ecx
+ cmp eax, edx
+ jg @@GT
+ je @@EQ
+@@LT:
+ dec ecx
+ dec ecx
+@@GT:
+ inc ecx
+@@EQ:
+ mov eax, ecx
+end;
+{--------}
+function FFCmpI16(a, b : smallint) : integer;
+asm
+ xor ecx, ecx
+ cmp ax, dx
+ jg @@GT
+ je @@EQ
+@@LT:
+ dec ecx
+ dec ecx
+@@GT:
+ inc ecx
+@@EQ:
+ mov eax, ecx
+end;
+{--------}
+function FFCmpI8(a, b : shortint) : integer;
+asm
+ xor ecx, ecx
+ cmp al, dl
+ jg @@GT
+ je @@EQ
+@@LT:
+ dec ecx
+ dec ecx
+@@GT:
+ inc ecx
+@@EQ:
+ mov eax, ecx
+end;
+{--------}
+function FFCmpI32(a, b : Longint) : integer;
+asm
+ xor ecx, ecx
+ cmp eax, edx
+ jg @@GT
+ je @@EQ
+@@LT:
+ dec ecx
+ dec ecx
+@@GT:
+ inc ecx
+@@EQ:
+ mov eax, ecx
+end;
+{--------}
+function FFCmpW(a, b : TffWord16) : integer;
+asm
+ xor ecx, ecx
+ cmp ax, dx
+ ja @@GT
+ je @@EQ
+@@LT:
+ dec ecx
+ dec ecx
+@@GT:
+ inc ecx
+@@EQ:
+ mov eax, ecx
+end;
+{--------}
+function FFCmpBytes(const a, b : PffByteArray; MaxLen : integer) : integer;
+asm
+ push esi
+ push edi
+ mov esi, eax
+ mov edi, edx
+ xor eax, eax
+ or ecx, ecx
+ jz @@Equal
+ repe cmpsb
+ jb @@Exit
+ je @@Equal
+ inc eax
+@@Equal:
+ inc eax
+@@Exit:
+ dec eax
+ pop edi
+ pop esi
+end;
+{--------}
+function FFCmpShStr(const a, b : TffShStr; MaxLen : byte) : integer;
+asm
+ push esi
+ push edi
+ mov esi, eax
+ mov edi, edx
+ movzx ecx, cl
+ mov ch, cl
+ xor eax, eax
+ mov dl, [esi]
+ inc esi
+ mov dh, [edi]
+ inc edi
+ cmp cl, dl
+ jbe @@Check2ndLength
+ mov cl, dl
+@@Check2ndLength:
+ cmp cl, dh
+ jbe @@CalcSigLengths
+ mov cl, dh
+@@CalcSigLengths:
+ cmp dl, ch
+ jbe @@Calc2ndSigLength
+ mov dl, ch
+@@Calc2ndSigLength:
+ cmp dh, ch
+ jbe @@CompareStrings
+ mov dh, ch
+@@CompareStrings:
+ movzx ecx, cl
+ or ecx, ecx
+ jz @@CompareLengths
+ repe cmpsb
+ jb @@Exit
+ ja @@GT
+@@CompareLengths:
+ cmp dl, dh
+ je @@Equal
+ jb @@Exit
+@@GT:
+ inc eax
+@@Equal:
+ inc eax
+@@Exit:
+ dec eax
+ pop edi
+ pop esi
+end;
+{--------}
+function FFCmpShStrUC(const a, b : TffShStr; MaxLen : byte) : integer;
+asm
+ push esi
+ push edi
+ push ebx
+ mov esi, eax
+ mov edi, edx
+ movzx ecx, cl
+ mov ch, cl
+ xor eax, eax
+ mov dl, [esi]
+ inc esi
+ mov dh, [edi]
+ inc edi
+ cmp cl, dl
+ jbe @@Check2ndLength
+ mov cl, dl
+@@Check2ndLength:
+ cmp cl, dh
+ jbe @@CalcSigLengths
+ mov cl, dh
+@@CalcSigLengths:
+ cmp dl, ch
+ jbe @@Calc2ndSigLength
+ mov dl, ch
+@@Calc2ndSigLength:
+ cmp dh, ch
+ jbe @@CompareStrings
+ mov dh, ch
+@@CompareStrings:
+ movzx ecx, cl
+ or ecx, ecx
+ jz @@CompareLengths
+@@NextChars:
+ mov bl, [esi]
+ cmp bl, 'a'
+ jb @@OtherChar
+ cmp bl, 'z'
+ ja @@OtherChar
+ sub bl, 'a'-'A'
+@@OtherChar:
+ mov bh, [edi]
+ cmp bh, 'a'
+ jb @@CompareChars
+ cmp bh, 'z'
+ ja @@CompareChars
+ sub bh, 'a'-'A'
+@@CompareChars:
+ cmp bl, bh
+ jb @@Exit
+ ja @@GT
+ inc esi
+ inc edi
+ dec ecx
+ jnz @@NextChars
+@@CompareLengths:
+ cmp dl, dh
+ je @@Equal
+ jb @@Exit
+@@GT:
+ inc eax
+@@Equal:
+ inc eax
+@@Exit:
+ dec eax
+ pop ebx
+ pop edi
+ pop esi
+end;
+{--------}
+procedure ffCloneI64(var aDest : TffInt64; const aSrc : TffInt64);
+begin
+ aDest.iLow := aSrc.iLow;
+ aDest.iHigh := aSrc.iHigh;
+end;
+{--------}
+procedure ffInitI64(var I : TffInt64);
+begin
+ I.iLow := 0;
+ I.iHigh := 0;
+end;
+{--------}
+function FFCmpI64(const a, b : TffInt64) : Integer; {!!.06 - Rewritten}
+begin
+ if (a.iHigh = b.iHigh) then
+ Result := FFCmpDW(a.iLow, b.iLow)
+ else
+ Result := FFCmpDW(a.iHigh, b.iHigh);
+end; {!!.06 - End rewritten}
+{--------}
+procedure ffShiftI64L(const I : TffInt64;
+ const Bits : Byte;
+ var Result : TffInt64);
+asm
+ push ebx
+ push edi
+ mov ebx, [eax]
+ mov edi, [eax+4]
+ or dl, dl
+ je @@Exit
+@@LOOP:
+ shl ebx, 1
+ rcl edi, 1
+ dec dl
+ jnz @@LOOP
+@@EXIT:
+ mov [ecx], ebx
+ mov [ecx+4], edi
+ pop edi
+ pop ebx
+end;
+{--------}
+procedure ffShiftI64R(const I : TffInt64; const Bits : Byte; var Result : TffInt64);
+asm
+ push ebx
+ push edi
+ mov ebx, [eax]
+ mov edi, [eax+4]
+ or dl, dl
+ je @@Exit
+@@LOOP:
+ shr edi, 1
+ rcr ebx, 1
+// rcr edi, 1
+ dec dl
+ jnz @@LOOP
+@@EXIT:
+ mov [ecx], ebx
+ mov [ecx+4], edi
+ pop edi
+ pop ebx
+end;
+{--------}
+procedure ffI64MinusI64(const a, b : TffInt64; var Result : TffInt64);
+asm
+ push ebx
+ push edi
+ mov ebx, eax
+ mov edi, edx
+ mov eax,[ebx]
+ mov edx,[ebx+4]
+ sub eax,[edi]
+ sbb edx,[edi+4]
+ mov [ecx], eax
+ mov [ecx+4], edx
+ pop edi
+ pop ebx
+end;
+{--------}
+procedure ffI64MinusInt(const aI64 : TffInt64; const aInt : TffWord32; var Result : TffInt64);
+asm
+ push edi
+ mov edi, edx
+ mov edx, [eax+4]
+ mov eax, [eax]
+ sub eax, edi
+ sbb edx, 0
+ mov [ecx], eax
+ mov [ecx+4], edx
+ pop edi
+end;
+{--------}
+function ffI64ModInt(const aI64 : TffInt64; const aInt : TffWord32) : integer;
+var
+ Quotient : TffInt64;
+ QSum : TffInt64;
+begin
+ Quotient.iLow := 0;
+ Quotient.iHigh := 0;
+ QSum.iLow := 0;
+ QSum.iHigh := 0;
+ {how many time will aInt go into aI64?}
+ ffI64DivInt(aI64, aInt, Quotient);
+ {multiply Quotient by aInt to see what it (QSum) equals}
+ ffI64MultInt(Quotient, aInt, QSum);
+ {mod equals (aI64 minus QSum)}
+ ffI64MinusI64(aI64, QSum, QSum);
+
+ Result := QSum.iLow;
+end;
+{--------}
+procedure ffI64DivInt(const aI64 : TffInt64; const aInt : TffWord32; var Result : TffInt64);
+ {This procedure was originally intended to divide a 64-bit word by a
+ 64-bit word. Since we are now dividing a 64-bit word by a 32-bit word,
+ we are forcing the divisor's high word to a 0. This is an area for
+ improvement}
+asm
+ push ebp
+ push ebx
+ push esi
+ push edi
+ push ecx {push ecx to the stack before we trash the address}
+
+ mov ebx, edx //move divisor low word to ebx
+ mov ecx, 0 {we are forcing the divosor high word to zero because our divisor in only 4 bytes}
+ mov edx, [eax+4] //move the dividend low word to edx
+ mov eax, [eax]
+
+
+{if the low word of the dividend (i.e., aI64) is zero or
+ the divisor low word is 0
+ then we can do a quick division. }
+ or edx, edx
+ jz @ffI64DivInt_Quick
+ or ebx, ebx
+ jz @ffI64DivInt_Quick
+
+{ Slow division starts here}
+@ffI64DivInt_Slow:
+ mov ebp, ecx
+ mov ecx, 64
+ xor edi, edi
+ xor esi, esi
+
+@ffI64DivInt_xLoop:
+ shl eax, 1
+ rcl edx, 1
+ rcl esi, 1
+ rcl edi, 1
+ cmp edi, ebp
+ jb @ffI64DivInt_NoSub
+ ja @ffI64DivInt_Subtract
+ cmp esi, ebx
+ jb @ffI64DivInt_NoSub
+
+@ffI64DivInt_Subtract:
+ sub esi, ebx
+ sbb edi, ebp
+ inc eax
+
+@ffI64DivInt_NoSub:
+ loop @ffI64DivInt_xLoop
+ jmp @ffI64DivInt_Finish
+
+{ Quick division starts here}
+{ - either the dividend's low word or divisor low word is 0}
+@ffI64DivInt_Quick:
+ div ebx
+ xor edx, edx
+
+@ffI64DivInt_Finish:
+// fill result, ecx = low word, ecx+4 = high word
+ pop ecx
+ mov [ecx].TffInt64.iHigh, edx
+ mov [ecx].TffInt64.iLow, eax
+ pop edi
+ pop esi
+ pop ebx
+ pop ebp
+end;
+{--------}
+procedure ffI64MultInt(const aI64 : TffInt64; const aInt : TffWord32; var Result : TffInt64);
+asm
+ push ebx
+ push edi
+
+ mov ebx, eax // set [ebx] to aI64
+ mov edi, edx // set edi to aInt
+
+ mov eax, [ebx+4] // get top DWORD of aI64
+ mul edi // multiply by aInt
+ push eax // save bottom DWORD of result
+ mov eax, [ebx] // get bottom DWORD of aI64
+ mul edi // multiply by aInt
+
+ pop ebx // pop bottom part of upper result
+ add edx, ebx // add to top part of lower result
+
+ mov [ecx], eax // save result
+ mov [ecx+4], edx
+
+ pop edi
+ pop ebx
+end;
+{--------}
+procedure ffI64AddInt(const aI64 : TffInt64; const aInt : TffWord32; var Result : TffInt64);
+asm
+ push ebx
+ mov ebx, [eax].TffInt64.iLow
+ add ebx, edx
+ mov [ecx].TffInt64.iLow, ebx
+ mov ebx, [eax].TffInt64.iHigh
+ adc ebx, 0
+ mov [ecx].TffInt64.iHigh, ebx
+ pop ebx
+end;
+{--------}
+function ffI64toInt(const aI64 : TffInt64) : TffWord32;
+begin
+ {What should we do if aI64 larger than DWord?
+ - D5 doesn't do anything}
+ Result := aI64.iLow;
+end;
+{--------}
+function ffI64ToStr(const aI64 : TffInt64) : string;
+begin
+ Result := IntToStr(aI64.iHigh) + IntToStr(aI64.iLow);
+end;
+{--------}
+procedure ffIntToI64(const aInt : TffWord32; var Result : TffInt64);
+begin
+ Result.iLow := aInt;
+ Result.iHigh := 0;
+end;
+{--------}
+function ffI64IsZero(const aI64 : TffInt64) : boolean;
+begin
+ Result := ((aI64.iHigh = 0) and (aI64.iLow = 0));
+end;
+{====================================================================}
+
+
+{===Minimum/maximum routines=========================================}
+function FFMinDW(a, b : TffWord32) : TffWord32;
+asm
+ cmp eax, edx
+ jbe @@Exit
+ mov eax, edx
+@@Exit:
+end;
+{--------}
+function FFMaxDW(a, b : TffWord32) : TffWord32;
+asm
+ cmp eax, edx
+ jae @@Exit
+ mov eax, edx
+@@Exit:
+end;
+{--------}
+function FFMinI(a, b : integer) : integer;
+asm
+ cmp eax, edx
+ jle @@Exit
+ mov eax, edx
+@@Exit:
+end;
+{--------}
+function FFMaxI(a, b : integer) : integer;
+asm
+ cmp eax, edx
+ jge @@Exit
+ mov eax, edx
+@@Exit:
+end;
+{--------}
+function FFMinL(a, b : Longint) : Longint;
+asm
+ cmp eax, edx
+ jle @@Exit
+ mov eax, edx
+@@Exit:
+end;
+{--------}
+function FFMaxL(a, b : Longint) : Longint;
+asm
+ cmp eax, edx
+ jge @@Exit
+ mov eax, edx
+@@Exit:
+end;
+{--------}
+function FFMinI64(a, b : TffInt64) : TffInt64;
+begin
+ if FFCmpI64(a,b) <= 0 then
+ Result := a
+ else
+ Result := b;
+end;
+{--------}
+function FFMaxI64(a, b : TffInt64) : TffInt64;
+begin
+ if FFCmpI64(a,b) >= 0 then
+ Result := a
+ else
+ Result := b;
+end;
+{====================================================================}
+
+
+{====================================================================}
+function FFCheckDescend(aAscend : boolean; a : integer) : integer;
+register;
+asm
+ or al, al
+ jnz @@Exit
+ neg edx
+@@Exit:
+ mov eax, edx
+end;
+{--------}
+function FFForceInRange(a, aLow, aHigh : Longint) : Longint;
+register;
+asm
+ cmp eax, edx
+ jg @@CheckHigh
+ mov eax, edx
+ jmp @@Exit
+@@CheckHigh:
+ cmp eax, ecx
+ jl @@Exit
+ mov eax, ecx
+@@Exit:
+end;
+{--------}
+function FFForceNonZero(a, b : integer) : integer;
+register;
+asm
+ or eax, eax
+ jnz @@Exit
+ mov eax, edx
+@@Exit:
+end;
+{====================================================================}
+
+
+{===Memory allocation, etc===========================================}
+var
+
+ FFMemPools : array [0..91] of TffMemoryPool;
+ { Array of memory pools used to replace Delphi's heap manager.
+ Pools 0..31 handle object sizes in 32-byte increments.
+ For example:
+ Pool[0] is used to allocate objects <= 32 bytes in size
+ Pool[1] for objects between 33 and 64 bytes in size
+ on up to Pool[31] for objects between 993 and 1024 bytes in size.
+ The maximum size handled by Pools 0..31 can be calculated as
+ succ[] * 32
+
+ Pools 32..91 handle object sizes in 256-byte increments after the
+ 1024 byte boundary.
+ For example:
+ Pool[32] for objects between 1025 and 1280 bytes in size
+ Pool[33] for objects between 1281 and 1536 bytes in size
+ on up to Pool[91] for objects between 16129 and 16384 bytes in size
+ The maximum size handled by Pools 32..91 can be calculated as
+ 1024 + ( - 31 * 256) }
+{--------}
+function CalcPoolIndex(Size : TffMemSize) : integer;
+begin
+ if (Size <= 1024) then
+ Result := (Size-1) div 32 {ie, 0..31}
+ else
+ Result := ((Size-1) div 256) - 4 + 32; {ie, 32..91}
+end;
+{--------}
+procedure FFFreeMem(var P; Size : TffMemSize);
+{$IFNDEF MemCheck}
+var
+ Pt : pointer;
+ Inx : integer;
+{$ENDIF}
+begin
+ {$IFDEF MemCheck}
+ FreeMem(pointer(P), Size);
+ {$ELSE}
+ Pt := pointer(P);
+ if (Pt <> nil) then begin
+ if (Size <= 16*1024) then begin
+ Inx := CalcPoolIndex(Size);
+ FFMemPools[Inx].Dispose(Pt);
+ end
+ else
+ FreeMem(Pt, Size);
+ end;
+ {$ENDIF}
+end;
+{--------}
+procedure FFGetMem(var P; Size : TffMemSize);
+{$IFNDEF MemCheck}
+var
+ Pt : pointer absolute P;
+ Inx : integer;
+{$ENDIF}
+begin
+ {$IFDEF MemCheck}
+ GetMem(pointer(P), Size);
+ {$ELSE}
+ if (Size <= 16*1024) then begin
+ Inx := CalcPoolIndex(Size);
+ Pt := FFMemPools[Inx].Alloc;
+ end
+ else
+ GetMem(Pt, Size);
+ {$ENDIF}
+end;
+{--------}
+procedure FFGetZeroMem(var P; Size : TffMemSize);
+var
+ Pt : pointer absolute P;
+begin
+ FFGetMem(Pt, Size);
+ FillChar(Pt^, Size, 0);
+end;
+{--------}
+procedure FFReallocMem(var P; OldSize, NewSize: Integer);
+{$IFNDEF MemCheck}
+var
+ Pt : Pointer absolute P;
+ P2 : Pointer;
+ OldInx, NewInx: Integer;
+{$ENDIF}
+begin
+ {$IFDEF MemCheck}
+ ReallocMem(pointer(P), NewSize);
+ {$ELSE}
+ if Pt = nil then
+ FFGetMem(P, NewSize)
+ else
+ if NewSize = 0 then begin
+ FFFreeMem(P, OldSize);
+ Pt := nil;
+ end
+ else
+ if (OldSize > 16*1024) and (NewSize > 16*1024) then
+ ReAllocMem(Pt, NewSize)
+ else begin
+ OldInx := CalcPoolIndex(OldSize);
+ NewInx := CalcPoolIndex(NewSize);
+ if OldInx <> NewInx then begin
+ if NewInx <= 91 then
+ P2 := FFMemPools[NewInx].Alloc
+ else
+ GetMem(P2, NewSize);
+ if NewSize < OldSize then {!!.02}
+ Move(Pt^, P2^, NewSize) {!!.02}
+ else {!!.02}
+ Move(Pt^, P2^, OldSize); {!!.02}
+ if OldInx <= 91 then
+ FFMemPools[OldInx].Dispose(Pt)
+ else
+ FreeMem(Pt);
+ Pointer(P) := P2;
+ end;
+ end;
+ {$ENDIF}
+end;
+{Begin !!.01}
+{--------}
+procedure FFFlushMemPools;
+var
+ anInx : integer;
+begin
+ for anInx := 0 to 91 do
+ FFMemPools[anInx].RemoveUnusedBlocks;
+end;
+{End !!.01}
+{--------}
+{begin !!.06}
+procedure FFValCurr(const S : string; var V : Currency; var Code : Integer); {!!.06}
+{
+Evaluate string as a floating point number, emulates Borlandish Pascal's
+Val() intrinsic
+
+Recognizes strings of the form:
+[-/+](d*[.][d*]|[d*].d*)[(e|E)[-/+](d*)]
+
+Parameters:
+ S : string to convert
+ V : Resultant Extended value
+ Code: position in string where an error occured or
+ -- 0 if no error
+ -- Length(S) + 1 if otherwise valid string terminates prematurely (e.g. "10.2e-")
+
+ if Code <> 0 on return then the value of V is undefined
+}
+
+type
+ { recognizer machine states }
+ TNumConvertState = (ncStart, ncSign, ncWhole, ncDecimal, ncStartDecimal,
+ ncFraction, ncE, ncExpSign, ncExponent, ncEndSpaces, ncBadChar);
+const
+ { valid stop states for machine }
+ StopStates: set of TNumConvertState = [ncWhole, ncDecimal, ncFraction,
+ ncExponent, ncEndSpaces];
+
+var
+ i : Integer; { general purpose counter }
+ P : PChar; { current position in evaluated string }
+ NegVal : Boolean; { is entire value negative? }
+ NegExp : Boolean; { is exponent negative? }
+ Exponent : LongInt; { accumulator for exponent }
+ Mantissa : Currency; { mantissa }
+ FracMul : Currency; { decimal place holder }
+ State : TNumConvertState; { current state of recognizer machine }
+
+
+begin
+{initializations}
+ V := 0.0;
+ Code := 0;
+
+ State := ncStart;
+
+ NegVal := False;
+ NegExp := False;
+
+ Mantissa := 0.0;
+ FracMul := 0.1;
+ Exponent := 0;
+
+{
+Evaluate the string
+When the loop completes (assuming no error)
+ -- WholeVal will contain the absolute value of the mantissa
+ -- Exponent will contain the absolute value of the exponent
+ -- NegVal will be set True if the mantissa is negative
+ -- NegExp will be set True if the exponent is negative
+
+If an error occurs P will be pointing at the character that caused the problem,
+or one past the end of the string if it terminates prematurely
+}
+
+ { keep going until run out of string or halt if unrecognized or out-of-place
+ character detected }
+
+ P := PChar(S);
+ for i := 1 to Length(S) do begin
+(*****)
+ case State of
+ ncStart : begin
+ if P^ = '.' then begin
+ State := ncStartDecimal; { decimal point detected in mantissa }
+ end else
+
+ case P^ of
+ ' ': begin
+ {ignore}
+ end;
+
+ '+': begin
+ State := ncSign;
+ end;
+
+ '-': begin
+ NegVal := True;
+ State := ncSign;
+ end;
+
+ 'e', 'E': begin
+ Mantissa := 0;
+ State := ncE; { exponent detected }
+ end;
+
+ '0'..'9': begin
+ State := ncWhole; { start of whole portion of mantissa }
+ Mantissa := (Mantissa * 10) + (Ord(P^) - Ord('0'));
+ end;
+
+ else
+ State := ncBadChar;
+ end;
+
+ end;
+
+ ncSign : begin
+ if P^ = '.' then begin
+ State := ncDecimal; { decimal point detected in mantissa }
+ end else
+
+ case P^ of
+ '0'..'9': begin
+ State := ncWhole; { start of whole portion of mantissa }
+ Mantissa := (Mantissa * 10) + (Ord(P^) - Ord('0'));
+ end;
+
+ 'e', 'E': begin
+ Mantissa := 0;
+ State := ncE; { exponent detected }
+ end;
+
+ else
+ State := ncBadChar;
+ end;
+ end;
+
+ ncWhole : begin
+ if P^ = '.' then begin
+ State := ncDecimal; { decimal point detected in mantissa }
+ end else
+
+ case P^ of
+ '0'..'9': begin
+ Mantissa := (Mantissa * 10) + (Ord(P^) - Ord('0'));
+ end;
+
+ '.': begin
+ end;
+
+ 'e', 'E': begin
+ State := ncE; { exponent detected }
+ end;
+
+ ' ': begin
+ State := ncEndSpaces;
+ end;
+
+ else
+ State := ncBadChar;
+ end;
+ end;
+
+ ncDecimal : begin
+ case P^ of
+ '0'..'9': begin
+ State := ncFraction; { start of fractional portion of mantissa }
+ Mantissa := Mantissa + (FracMul * (Ord(P^) - Ord('0')));
+ FracMul := FracMul * 0.1;
+ end;
+
+ 'e', 'E': begin
+ State := ncE; { exponent detected }
+ end;
+
+ ' ': begin
+ State := ncEndSpaces;
+ end;
+
+ else
+ State := ncBadChar;
+ end;
+
+ end;
+
+ ncStartDecimal : begin
+ case P^ of
+ '0'..'9': begin
+ State := ncFraction; { start of fractional portion of mantissa }
+ Mantissa := Mantissa + (FracMul * (Ord(P^) - Ord('0')));
+ FracMul := FracMul * 0.1;
+ end;
+
+ ' ': begin
+ State := ncEndSpaces;
+ end;
+
+ else
+ State := ncBadChar;
+ end;
+ end;
+
+ ncFraction : begin
+ case P^ of
+ '0'..'9': begin
+ Mantissa := Mantissa + (FracMul * (Ord(P^) - Ord('0')));
+ FracMul := FracMul * 0.1;
+ end;
+
+ 'e', 'E': begin
+ State := ncE; { exponent detected }
+ end;
+
+ ' ': begin
+ State := ncEndSpaces;
+ end;
+
+ else
+ State := ncBadChar;
+ end;
+ end;
+
+ ncE : begin
+ case P^ of
+ '0'..'9': begin
+ State := ncExponent; { start of exponent }
+ Exponent := Exponent * 10 + (Ord(P^) - Ord('0'));
+ end;
+
+ '+': begin
+ State := ncExpSign;
+ end;
+
+ '-': begin
+ NegExp := True; { exponent is negative }
+ State := ncExpSign;
+ end;
+
+ else
+ State := ncBadChar;
+ end;
+ end;
+
+ ncExpSign : begin
+ case P^ of
+ '0'..'9': begin
+ State := ncExponent; { start of exponent }
+ Exponent := Exponent * 10 + (Ord(P^) - Ord('0'));
+ end;
+
+ else
+ State := ncBadChar;
+ end;
+ end;
+
+ ncExponent : begin
+ case P^ of
+ '0'..'9': begin
+ Exponent := Exponent * 10 + (Ord(P^) - Ord('0'));
+ end;
+
+ ' ': begin
+ State := ncEndSpaces;
+ end;
+
+ else
+ State := ncBadChar;
+ end;
+ end;
+
+ ncEndSpaces : begin
+ case P^ of
+ ' ': begin
+ {ignore}
+ end;
+ else
+ State := ncBadChar;
+ end;
+ end;
+ end;
+
+(*****)
+ Inc(P);
+ if State = ncBadChar then begin
+ Code := i;
+ Break;
+ end;
+ end;
+{
+Final calculations
+}
+ if not (State in StopStates) then begin
+ Code := i; { point to error }
+ end else begin
+ { negate if needed }
+ if NegVal then
+ Mantissa := -Mantissa;
+
+
+ { apply exponent if any }
+ if Exponent <> 0 then begin
+ if NegExp then
+ for i := 1 to Exponent do
+ Mantissa := Mantissa * 0.1
+ else
+ for i := 1 to Exponent do
+ Mantissa := Mantissa * 10.0;
+ end;
+
+ V := Mantissa;
+ end;
+end;
+{end !!.06}
+{====================================================================}
+
+
+{===String routines==================================================}
+const
+ EmptyShStr : array [0..1] of AnsiChar = #0#0;
+
+{--------}
+function FFCommaizeChL(L : Longint; Ch : AnsiChar) : AnsiString;
+ {-Convert a long integer to a string with Ch in comma positions}
+var
+ Temp : string;
+ NumCommas, I, Len : Cardinal;
+ Neg : Boolean;
+begin
+ SetLength(Temp, 1);
+ Temp[1] := Ch;
+ if L < 0 then begin
+ Neg := True;
+ L := Abs(L);
+ end else
+ Neg := False;
+ Result := IntToStr(L);
+ Len := Length(Result);
+ NumCommas := (Pred(Len)) div 3;
+ for I := 1 to NumCommas do
+ System.Insert(Temp, Result, Succ(Len-(I * 3)));
+ if Neg then
+ System.Insert('-', Result, 1);
+end;
+{--------}
+procedure FFShStrConcat(var Dest : TffShStr; const Src : TffShStr);
+begin
+ Move(Src[1], Dest[succ(length(Dest))], length(Src));
+ inc(Dest[0], length(Src));
+end;
+{--------}
+procedure FFShStrAddChar(var Dest : TffShStr; C : AnsiChar);
+begin
+ inc(Dest[0]);
+ Dest[length(Dest)] := C;
+end;
+{--------}
+function FFShStrAlloc(const S : TffShStr) : PffShStr;
+begin
+ if (S = '') then
+ Result := PffShStr(@EmptyShStr)
+ else begin
+ {save room for length byte and terminating #0}
+ FFGetMem(Result, length(S)+2);
+ Result^ := S;
+ Result^[succ(length(S))] := #0;
+ end;
+end;
+{--------}
+procedure FFShStrFree(var P : PffShStr);
+begin
+ if (P <> nil) and (P <> PffShStr(@EmptyShStr)) then
+ FFFreeMem(P, length(P^)+2);
+ P := nil;
+end;
+{--------}
+procedure FFShStrSplit(S: TffShStr; const SplitChars: TffShStr;
+ var Left, Right: TffShStr);
+ {-This procedure locates the first occurrence in S of any of the
+ characters listed in SplitChars and returns the substring to the
+ left of the split char (exclusive) in Left and the substring to the
+ right of the split char (exclusive) in Right. If none of the chars
+ given in SplitChar exist in S, then Left = S and Right = ''. }
+var
+ I: Integer;
+begin
+ Left := S;
+ Right := '';
+ for I := 1 to Length(S) do begin
+ if Pos(SplitChars, Copy(S, I, 1)) <> 0 then begin
+ Left := Copy(S, 1, I - 1);
+ Right := Copy(S, I + 1, 255);
+ Break;
+ end;
+ end;
+end;
+{--------}
+function StrStDeletePrim(P : PAnsiChar; Pos, Count : Cardinal) : PAnsiChar; register;
+asm
+ push eax {save because we will be changing them}
+ push edi
+ push esi
+ push ebx
+
+ mov ebx, ecx {move Count to BX}
+ mov esi, eax {move P to ESI and EDI}
+ mov edi, eax
+
+ xor eax, eax {null}
+ or ecx, -1
+ cld
+ repne scasb {find null terminator}
+ not ecx {calc length}
+ jecxz @@ExitPoint
+
+ sub ecx, ebx {subtract Count}
+ sub ecx, edx {subtract Pos}
+ jns @@L1
+
+ mov edi,esi {delete everything after Pos}
+ add edi,edx
+ stosb
+ jmp @@ExitPoint
+
+@@L1:
+ mov edi,esi
+ add edi,edx {point to position to adjust}
+ mov esi,edi
+ add esi,ebx {point past string to delete in src}
+ inc ecx {one more to include null terminator}
+ rep movsb {adjust the string}
+
+@@ExitPoint:
+
+ pop ebx {restore registers}
+ pop esi
+ pop edi
+ pop eax
+end;
+{--------}
+procedure FFStrTrim(P : PAnsiChar);
+ {-Trim leading and trailing blanks from P}
+var
+ I : Integer;
+ PT : PAnsiChar;
+begin
+ I := StrLen(P);
+ if I = 0 then
+ Exit;
+
+ {delete trailing spaces}
+ Dec(I);
+ while (I >= 0) and (P[I] = ' ') do begin
+ P[I] := #0;
+ Dec(I);
+ end;
+
+ {delete leading spaces}
+ I := 0;
+ PT := P;
+ while PT^ = ' ' do begin
+ Inc(I);
+ Inc(PT);
+ end;
+ if I > 0 then
+ StrStDeletePrim(P, 0, I);
+end;
+
+function FFStrTrimR(S : PAnsiChar) : PAnsiChar; register;
+asm
+ cld
+ push edi
+ mov edx, eax
+ mov edi, eax
+
+ or ecx, -1
+ xor al, al
+ repne scasb
+ not ecx
+ dec ecx
+ jecxz @@ExitPoint
+
+ dec edi
+
+@@1:
+ dec edi
+ cmp byte ptr [edi],' '
+ jbe @@1
+ mov byte ptr [edi+1],00h
+@@ExitPoint:
+ mov eax, edx
+ pop edi
+end;
+{--------}
+function FFShStrTrim(const S : TffShStr) : TffShStr;
+var
+ StartCh : integer;
+ EndCh : integer;
+ LenS : integer;
+begin
+ LenS := length(S);
+ StartCh := 1;
+ while (StartCh <= LenS) and (S[StartCh] = ' ') do
+ inc(StartCh);
+ if (StartCh > LenS) then
+ Result := ''
+ else begin
+ EndCh := LenS;
+ while (EndCh > 0) and (S[EndCh] = ' ') do
+ dec(EndCh);
+ Result := Copy(S, StartCh, succ(EndCh - StartCh));
+ end;
+end;
+{--------}
+function FFShStrTrimL(const S : TffShStr) : TffShStr;
+var
+ StartCh : integer;
+ LenS : integer;
+begin
+ LenS := length(S);
+ StartCh := 1;
+ while (StartCh <= LenS) and (S[StartCh] = ' ') do
+ inc(StartCh);
+ if (StartCh > LenS) then
+ Result := ''
+ else
+ Result := Copy(S, StartCh, succ(LenS - StartCh));
+end;
+{--------}
+function FFShStrTrimR(const S : TffShStr) : TffShStr;
+begin
+ Result := S;
+ while (length(Result) > 0) and (Result[length(Result)] = ' ') do
+ dec(Result[0]);
+end;
+{--------}
+function FFShStrTrimWhite(const S : TffShStr) : TffShStr;
+var
+ StartCh : integer;
+ EndCh : integer;
+ LenS : integer;
+begin
+ LenS := length(S);
+ StartCh := 1;
+ while (StartCh <= LenS) and (S[StartCh] <= ' ') do
+ inc(StartCh);
+ if (StartCh > LenS) then
+ Result := ''
+ else begin
+ EndCh := LenS;
+ while (EndCh > 0) and (S[EndCh] <= ' ') do
+ dec(EndCh);
+ Result := Copy(S, StartCh, succ(EndCh - StartCh));
+ end;
+end;
+{--------}
+function FFShStrTrimWhiteL(const S : TffShStr) : TffShStr;
+var
+ StartCh : integer;
+ LenS : integer;
+begin
+ LenS := length(S);
+ StartCh := 1;
+ while (StartCh <= LenS) and (S[StartCh] <= ' ') do
+ inc(StartCh);
+ if (StartCh > LenS) then
+ Result := ''
+ else
+ Result := Copy(S, StartCh, succ(LenS - StartCh));
+end;
+{--------}
+function FFShStrTrimWhiteR(const S : TffShStr) : TffShStr;
+begin
+ Result := S;
+ while (length(Result) > 0) and (Result[length(Result)] <= ' ') do
+ dec(Result[0]);
+end;
+{--------}
+function FFShStrRepChar(C : AnsiChar; N : integer) : TffShStr;
+var
+ i : integer;
+begin
+ if (N < 0) then
+ N := 0
+ else if (N > 255) then
+ N := 255;
+ Result[0] := AnsiChar(N);
+ for i := 1 to N do
+ Result[i] := C;
+end;
+{--------}
+function FFShStrUpper(const S : TffShStr) : TffShStr;
+var
+ i : integer;
+begin
+ Result[0] := S[0];
+ for i := 1 to length(S) do
+ Result[i] := upcase(S[i]);
+end;
+{--------}
+function FFShStrUpperAnsi(const S : TffShStr) : TffShStr;
+begin
+ Result := S;
+ CharUpperBuff(@Result[1], length(Result));
+end;
+{--------}
+function FFStrAlloc(aSize : integer) : PAnsiChar;
+begin
+ inc(aSize, sizeof(longint));
+ FFGetMem(Result, aSize);
+ PLongInt(Result)^ := aSize;
+ inc(Result, sizeof(longint));
+ Result[0] := #0;
+end;
+{--------}
+function FFStrAllocCopy(S : PAnsiChar) : PAnsiChar;
+var
+ Len : integer;
+ Size : longint;
+begin
+ Len := StrLen(S);
+ if (Len = 0) then
+ Result := nil
+ else begin
+ Size := succ(Len) + sizeof(longint);
+ FFGetMem(Result, Size);
+ PLongInt(Result)^ := Size;
+ inc(Result, sizeof(longint));
+ StrCopy(Result, S);
+ end;
+end;
+{--------}
+procedure FFStrDispose(S : PAnsiChar);
+begin
+ if (S <> nil) then begin
+ dec(S, sizeof(longint));
+ FFFreeMem(S, PLongint(S)^);
+ end;
+end;
+{--------}
+function FFStrNew(const S : TffShStr) : PAnsiChar;
+var
+ Len : integer;
+ Size : longint;
+begin
+ Len := length(S);
+ if (Len = 0) then
+ Result := nil
+ else begin
+ Size := succ(Len) + sizeof(longint);
+ FFGetMem(Result, Size);
+ PLongInt(Result)^ := Size;
+ inc(Result, sizeof(longint));
+ Move(S[1], Result^, Len);
+ Result[Len] := #0;
+ end;
+end;
+{--------}
+function FFStrPas(S : PAnsiChar) : TffShStr;
+var
+ Len : integer;
+begin
+ if (S = nil) then
+ Result := ''
+ else begin
+ Len := FFMinI(StrLen(S), 255);
+ Move(S[0], Result[1], Len);
+ Result[0] := AnsiChar(Len);
+ end;
+end;
+{--------}
+function FFStrPasLimit(S : PAnsiChar; MaxCharCount : integer) : TffShStr;
+var
+ Len : integer;
+begin
+ Len := FFMinI(StrLen(S), MaxCharCount);
+ Move(S[0], Result[1], Len);
+ Result[0] := AnsiChar(Len);
+end;
+{--------}
+function FFStrPCopy(Dest : PAnsiChar; const S : TffShStr) : PAnsiChar;
+begin
+ Result := Dest;
+ if (Dest <> nil) then begin
+ Move(S[1], Dest[0], length(S));
+ Dest[length(S)] := #0;
+ end;
+end;
+{--------}
+function FFStrPCopyLimit(Dest : PAnsiChar; const S : TffShStr;
+ MaxCharCount : integer) : PAnsiChar;
+var
+ Len : integer;
+begin
+ Result := Dest;
+ if (Dest <> nil) then begin
+ Len := FFMinI(MaxCharCount, length(S));
+ Move(S[1], Dest[0], Len);
+ Dest[Len] := #0;
+ end;
+end;
+{--------}
+function FFTrim(const S : string) : string;
+var
+ StartCh : integer;
+ EndCh : integer;
+ LenS : integer;
+begin
+ LenS := length(S);
+ StartCh := 1;
+ while (StartCh <= LenS) and (S[StartCh] = ' ') do
+ inc(StartCh);
+ if (StartCh > LenS) then
+ Result := ''
+ else begin
+ EndCh := LenS;
+ while (EndCh > 0) and (S[EndCh] = ' ') do
+ dec(EndCh);
+ Result := Copy(S, StartCh, succ(EndCh - StartCh));
+ end;
+end;
+{--------}
+function FFTrimL(const S : string) : string;
+var
+ StartCh : integer;
+ LenS : integer;
+begin
+ LenS := length(S);
+ StartCh := 1;
+ while (StartCh <= LenS) and (S[StartCh] = ' ') do
+ inc(StartCh);
+ if (StartCh > LenS) then
+ Result := ''
+ else
+ Result := Copy(S, StartCh, succ(LenS - StartCh));
+end;
+{--------}
+function FFTrimR(const S : string) : string;
+var
+ EndCh : integer;
+begin
+ EndCh := length(S);
+ while (EndCh > 0) and (S[EndCh] = ' ') do
+ dec(EndCh);
+ if (EndCh > 0) then
+ Result := Copy(S, 1, EndCh)
+ else
+ Result := '';
+end;
+{--------}
+function FFTrimWhite(const S : string) : string;
+var
+ StartCh : integer;
+ EndCh : integer;
+ LenS : integer;
+begin
+ LenS := length(S);
+ StartCh := 1;
+ while (StartCh <= LenS) and (S[StartCh] <= ' ') do
+ inc(StartCh);
+ if (StartCh > LenS) then
+ Result := ''
+ else begin
+ EndCh := LenS;
+ while (EndCh > 0) and (S[EndCh] <= ' ') do
+ dec(EndCh);
+ Result := Copy(S, StartCh, succ(EndCh - StartCh));
+ end;
+end;
+{--------}
+function FFTrimWhiteL(const S : string) : string;
+var
+ StartCh : integer;
+ LenS : integer;
+begin
+ LenS := length(S);
+ StartCh := 1;
+ while (StartCh <= LenS) and (S[StartCh] <= ' ') do
+ inc(StartCh);
+ if (StartCh > LenS) then
+ Result := ''
+ else
+ Result := Copy(S, StartCh, succ(LenS - StartCh));
+end;
+{--------}
+function FFTrimWhiteR(const S : string) : string;
+var
+ EndCh : integer;
+begin
+ EndCh := length(S);
+ while (EndCh > 0) and (S[EndCh] <= ' ') do
+ dec(EndCh);
+ if (EndCh > 0) then
+ Result := Copy(S, 1, EndCh)
+ else
+ Result := '';
+end;
+{--------}
+function FFOmitMisc(const S : string) : string;
+var
+ CurCh : integer;
+ LenS : integer;
+begin
+ Result := '';
+ LenS := length(S);
+ CurCh := 1;
+ while (CurCh <= LenS) do begin
+ if S[CurCh] in ['0'..'9', 'A'..'Z', 'a'..'z'] then
+ Result := Result + S[CurCh];
+ inc(CurCh);
+ end;
+end;
+{--------}
+function FFAnsiCompareText(const S1, S2 : string) : Integer; {!!.10}
+begin
+ {$IFDEF SafeAnsiCompare}
+ Result := AnsiCompareText(AnsiLowerCase(S1), AnsiLowerCase(S2));
+ {$ELSE}
+ Result := AnsiCompareText(S1, S2);
+ {$ENDIF}
+end;
+{--------}
+function FFAnsiStrIComp(S1, S2: PChar): Integer; {!!.10}
+begin
+ {$IFDEF SafeAnsiCompare}
+ Result := AnsiStrIComp(AnsiStrLower(S1), AnsiStrLower(S2));
+ {$ELSE}
+ Result := AnsiStrIComp(S1, S2);
+ {$ENDIF}
+end;
+{--------}
+function FFAnsiStrLIComp(S1, S2: PChar; MaxLen: Cardinal): Integer; {!!.10}
+begin
+ {$IFDEF SafeAnsiCompare}
+ Result := AnsiStrLIComp(AnsiStrLower(S1), AnsiStrLower(S2), MaxLen);
+ {$ELSE}
+ Result := AnsiStrLIComp(S1, S2, MaxLen);
+ {$ENDIF}
+end;
+{====================================================================}
+
+
+{===Wide-String Routines=============================================}
+function FFCharToWideChar(Ch: AnsiChar): WideChar;
+begin
+ Result := WideChar(Ord(Ch));
+end;
+
+function FFWideCharToChar(WC: WideChar): AnsiChar;
+begin
+ if WC >= #256 then WC := #0;
+ Result := AnsiChar(Ord(WC));
+end;
+
+function FFShStrLToWideStr(S: TffShStr; WS: PWideChar; MaxLen: Longint): PWideChar;
+begin
+ WS[MultiByteToWideChar(0, 0, @S[1], MaxLen, WS, MaxLen + 1)] := #0;
+ Result := WS;
+end;
+
+function FFWideStrLToShStr(WS: PWideChar; MaxLen: Longint): TffShStr;
+begin
+ Result := WideCharLenToString(WS, MaxLen);
+end;
+
+function FFNullStrLToWideStr(ZStr: PAnsiChar; WS: PWideChar; MaxLen: Longint): PWideChar;
+begin
+ WS[MultiByteToWideChar(0, 0, ZStr, MaxLen, WS, MaxLen)] := #0;
+ Result := WS;
+end;
+
+function FFWideStrLToNullStr(WS: PWideChar; ZStr: PAnsiChar; MaxLen: Longint): PAnsiChar;
+begin
+ ZStr[WideCharToMultiByte(0, 0, WS, MaxLen, ZStr, MaxLen, nil, nil)] := #0;
+ Result := ZStr;
+end;
+
+function FFWideStrLToWideStr(aSourceValue, aTargetValue: PWideChar; MaxLength: Longint): PWideChar;
+begin
+ { Assumption: MaxLength is really # units multiplied by 2, which is how
+ a Wide String's length is stored in the table's data dictionary. }
+ Move(aSourceValue^, aTargetValue^, MaxLength);
+ aTargetValue[MaxLength div 2] := #0;
+ Result := aTargetValue;
+end;
+{=============
+=======================================================}
+
+{===File and Path name routines======================================}
+{===Helpers===}
+const
+{$IFDEF DCC6OrLater}
+ {$WARN SYMBOL_PLATFORM OFF}
+{$ENDIF}
+ faNotNormal = faReadOnly or faHidden or faSysFile or faArchive;
+{$IFDEF DCC6OrLater}
+ {$WARN SYMBOL_PLATFORM ON}
+{$ENDIF}
+{--------}
+procedure SearchRecConvertPrim(var SR : TffSearchRec);
+type
+ LH = packed record L, H : word; end;
+var
+ LocalFileTime : TFileTime;
+begin
+ with SR do begin
+ srName := FFStrPasLimit(srData.cFileName, pred(sizeof(srName)));
+ FileTimeToLocalFileTime(srData.ftLastWriteTime, LocalFileTime);
+ FileTimeToDosDateTime(LocalFileTime, LH(srTime).H, LH(srTime).L);
+ srSize := srData.nFileSizeLow;
+ srSizeHigh := srData.nFileSizeHigh;
+ if ((srData.dwFileAttributes and faDirectory) <> 0) then
+ srType := ditDirectory
+ {$IFDEF DCC6OrLater}
+ {$WARN SYMBOL_PLATFORM OFF}
+ {$ENDIF}
+ else if ((srData.dwFileAttributes and faVolumeID) <> 0) then
+ {$IFDEF DCC6OrLater}
+ {$WARN SYMBOL_PLATFORM ON}
+ {$ENDIF}
+ srType := ditVolumeID
+ else
+ srType := ditFile;
+ srAttr := [];
+ {$IFDEF DCC6OrLater}
+ {$WARN SYMBOL_PLATFORM OFF}
+ {$ENDIF}
+ if ((srData.dwFileAttributes and faHidden) <> 0) then
+ include(srAttr, diaHidden);
+ if ((srData.dwFileAttributes and faReadOnly) <> 0) then
+ include(srAttr, diaReadOnly);
+ if ((srData.dwFileAttributes and faSysFile) <> 0) then
+ include(srAttr, diaSystem);
+ if ((srData.dwFileAttributes and faArchive) <> 0) then
+ include(srAttr, diaArchive);
+ if ((srData.dwFileAttributes and faNotNormal) = 0) then
+ include(srAttr, diaNormal);
+ {$IFDEF DCC6OrLater}
+ {$WARN SYMBOL_PLATFORM ON}
+ {$ENDIF}
+ end;
+end;
+{--------}
+function TypeAndAttrMatch(OSAttr : TffWord32;
+ aType : TffDirItemTypeSet;
+ aAttr : TffDirItemAttrSet) : boolean;
+begin
+ {$IFDEF DCC6OrLater}
+ {$WARN SYMBOL_PLATFORM OFF}
+ {$ENDIF}
+ Result := ((ditFile in aType) and ((OSAttr and (faDirectory or faVolumeID)) = 0)) or
+ ((ditDirectory in aType) and ((OSAttr and faDirectory) <> 0)) or
+ ((ditVolumeID in aType) and ((OSAttr and faVolumeID) <> 0));
+ {$IFDEF DCC6OrLater}
+ {$WARN SYMBOL_PLATFORM ON}
+ {$ENDIF}
+
+ if not Result then
+ Exit;
+ {$IFDEF DCC6OrLater}
+ {$WARN SYMBOL_PLATFORM OFF}
+ {$ENDIF}
+ Result := ((diaReadOnly in aAttr) and ((OSAttr and faReadOnly) <> 0)) or
+ ((diaHidden in aAttr) and ((OSAttr and faHidden) <> 0)) or
+ ((diaSystem in aAttr) and ((OSAttr and faSysFile) <> 0)) or
+ ((diaArchive in aAttr) and ((OSAttr and faArchive) <> 0)) or
+ ((diaNormal in aAttr) and ((OSAttr and faNotNormal) = 0));
+ {$IFDEF DCC6OrLater}
+ {$WARN SYMBOL_PLATFORM ON}
+ {$ENDIF}
+
+end;
+{--------}
+procedure ExtractHelper(const PFN : TffFullFileName;
+ var DotPos : integer;
+ var SlashPos : integer);
+var
+ i : integer;
+begin
+ {Note: if there is no period, DotPos is returned as one greater than
+ the length of the full file name. If there is no slash
+ SlashPos is returned as zero}
+ DotPos := 0;
+ SlashPos := 0;
+ i := length(PFN);
+ while (i > 0) and ((DotPos = 0) or (SlashPos = 0)) do begin
+ if (PFN[i] = '.') then begin
+ if (DotPos = 0) then
+ DotPos := i;
+ end
+ else if (PFN[i] = '\') then begin
+ SlashPos := i;
+ if (DotPos = 0) then
+ DotPos := succ(length(PFN));
+ end;
+ dec(i);
+ end;
+ if (DotPos = 0) then
+ DotPos := succ(length(PFN));
+end;
+{--------}
+function ValidFileNameHelper(const S : TffShStr; MaxLen : integer) : boolean;
+const
+ UnacceptableChars : set of AnsiChar =
+ ['"', '*', '.', '/', ':', '<', '>', '?', '\', '|'];
+var
+ i : integer;
+ LenS : integer;
+begin
+ Result := false;
+ LenS := length(S);
+ if (0 < LenS) and (LenS <= MaxLen) then begin
+ for i := 1 to LenS do
+ if (S[i] in UnacceptableChars) then
+ Exit;
+ Result := true;
+ end;
+end;
+{===end Helpers===}
+function FFDirectoryExists(const Path : TffPath) : boolean;
+var
+ Attr : TffWord32;
+ PathZ: TffStringZ;
+begin
+ Result := false;
+ {we don't support wildcards}
+ if (Pos('*', Path) <> 0) or (Pos('?', Path) <> 0) then
+ Exit;
+ Attr := GetFileAttributes(FFStrPCopy(PathZ, Path));
+ if (Attr <> TffWord32(-1)) and ((Attr and FILE_ATTRIBUTE_DIRECTORY) <> 0) then
+ Result := true;
+end;
+{--------}
+function FFExpandFileName(const FN : TffFullFileName) : TffFullFileName;
+var
+ FNZ : TffMaxPathZ;
+ EFNZ : TffMaxPathZ;
+ FileNamePos : PAnsiChar;
+begin
+ GetFullPathName(FFStrPCopy(FNZ, FN), sizeof(EFNZ), EFNZ, FileNamePos);
+ Result := FFStrPasLimit(EFNZ, pred(sizeof(TffFullFileName)));
+end;
+{--------}
+function FFExtractExtension(const PFN : TffFullFileName) : TffExtension;
+var
+ DotPos : integer;
+ SlashPos : integer;
+begin
+ ExtractHelper(PFN, DotPos, SlashPos);
+ if (DotPos >= length(PFN)) then
+ Result := ''
+ else
+ Result := Copy(PFN, succ(DotPos), (length(PFN) - DotPos));
+end;
+{--------}
+function FFExtractFileName(const PFN : TffFullFileName) : TffFileName;
+var
+ DotPos : integer;
+ SlashPos : integer;
+begin
+ ExtractHelper(PFN, DotPos, SlashPos);
+ Result := Copy(PFN, succ(SlashPos), FFMinI(pred(DotPos - SlashPos), ffcl_FileName));
+end;
+{--------}
+function FFExtractPath(const PFN : TffFullFileName) : TffPath;
+var
+ DotPos : integer;
+ SlashPos : integer;
+begin
+ ExtractHelper(PFN, DotPos, SlashPos);
+ if (SlashPos = 0) then
+ Result := ''
+ else
+ Result := Copy(PFN, 1, FFMinI(pred(SlashPos), ffcl_Path));
+end;
+{--------}
+function FFExtractTableName(const PFN : TffFullFileName) : TffTableName;
+
+var
+ DotPos : integer;
+ SlashPos : integer;
+begin
+ ExtractHelper(PFN, DotPos, SlashPos);
+ Result := Copy(PFN, succ(SlashPos), FFMinI(pred(DotPos - SlashPos), ffcl_TableNameSize));
+end;
+{--------}
+function FFFileExists(const PFN : TffFullFileName) : boolean;
+var
+ SR : TffSearchRec;
+begin
+ if (Pos('*', PFN) <> 0) or (Pos('?', PFN) <> 0) then
+ Result := false
+ else if (FFFindFirst(PFN, [ditFile], diaAnyAttr, SR) = 0) then begin
+ Result := true;
+ FFFindClose(SR);
+ end
+ else
+ Result := false;
+end;
+{--------}
+procedure FFFindClose(var SR : TffSearchRec);
+begin
+ if (SR.srHandle <> INVALID_HANDLE_VALUE) then begin
+ Windows.FindClose(SR.srHandle);
+ SR.srHandle := INVALID_HANDLE_VALUE;
+ end;
+end;
+{--------}
+function FFFindFirst(const PFN : TffFullFileName;
+ ItemType : TffDirItemTypeSet;
+ Attr : TffDirItemAttrSet;
+ var SR : TffSearchRec) : integer;
+var
+ PathZ : TffStringZ;
+ GotAnError : boolean;
+begin
+ FillChar(SR, sizeof(SR), 0);
+ SR.srFindType := ItemType;
+ SR.srFindAttr := Attr;
+ SR.srHandle := Windows.FindFirstFile(FFStrPCopy(PathZ, PFN), SR.srData);
+ if (SR.srHandle = INVALID_HANDLE_VALUE) then
+ Result := GetLastError
+ else begin
+ GotAnError := false;
+ while (not GotAnError) and
+ (not TypeAndAttrMatch(SR.srData.dwFileAttributes, SR.srFindType, SR.srFindAttr)) do
+ if not Windows.FindNextFile(SR.srHandle, SR.srData) then
+ GotAnError := true;
+ if GotAnError then begin
+ Windows.FindClose(SR.srHandle);
+ Result := GetLastError;
+ end
+ else begin
+ Result := 0;
+ SearchRecConvertPrim(SR);
+ end;
+ end;
+end;
+{--------}
+function FFFindNext(var SR : TffSearchRec) : integer;
+var
+ GotAnError : boolean;
+begin
+ if Windows.FindNextFile(SR.srHandle, SR.srData) then begin
+ GotAnError := false;
+ while (not GotAnError) and
+ (not TypeAndAttrMatch(SR.srData.dwFileAttributes, SR.srFindType, SR.srFindAttr)) do
+ if not Windows.FindNextFile(SR.srHandle, SR.srData) then
+ GotAnError := true;
+ if GotAnError then begin
+ Result := GetLastError;
+ end
+ else begin
+ Result := 0;
+ SearchRecConvertPrim(SR);
+ end;
+ end
+ else
+ Result := GetLastError;
+end;
+{--------}
+function FFForceExtension(const PFN : TffFullFileName;
+ const Ext : TffExtension) : TffFullFileName;
+var
+ DotPos : integer;
+begin
+ Result := PFN;
+ if FFHasExtension(PFN, DotPos) then
+ if (Ext = '') then
+ SetLength(Result, pred(DotPos))
+ else begin
+ SetLength(Result, DotPos + length(Ext));
+ Move(Ext[1], Result[succ(DotPos)], length(Ext));
+ end
+ else if (PFN <> '') and (Ext <> '') then begin
+ FFShStrAddChar(Result, '.');
+ FFShStrConcat(Result, Ext);
+ end;
+end;
+{--------}
+function FFGetCurDir : TffPath;
+var
+ CurDirZ : TffMaxPathZ;
+ Len : integer;
+begin
+ Len := GetCurrentDirectory(sizeof(CurDirZ), CurDirZ);
+ if (Len = 0) then
+ Result := ''
+ else
+ Result := FFStrPasLimit(CurDirZ, 255);
+end;
+{--------}
+function FFGetDirList(const Path : TffPath; FileSpec : TffFileNameExt) : TffStringList;
+var
+ FullSearchPath : TffFullFileName;
+ ErrorCode : integer;
+ SR : TffSearchRec;
+begin
+ Result := TffStringList.Create;
+ Try
+ Result.Capacity := 32; {to avoid too many reallocs}
+ Result.CaseSensitive := false;
+ FullSearchPath := FFMakeFullFileName(Path, FileSpec);
+ ErrorCode := FFFindFirst(FullSearchPath, [ditFile], diaAnyAttr, SR);
+ while (ErrorCode = 0) do begin
+ Result.Insert(SR.srName);
+ ErrorCode := FFFindNext(SR);
+ end;
+ FFFindClose(SR);
+ except
+ Result.Free;
+ Raise;
+ end;
+end;
+{--------}
+function FFGetEXEName : TffFullFileName;
+begin
+ Result := FFExpandFileName(ParamStr(0));
+end;
+{--------}
+function FFHasExtension(const PFN : TffFullFileName; var DotPos : integer) : boolean;
+var
+ i : integer;
+begin
+ Result := false;
+ DotPos := 0;
+ for i := length(PFN) downto 1 do
+ if (PFN[i] = '.') then begin
+ DotPos := i;
+ Result := true;
+ Exit;
+ end
+ else if (PFN[i] = '\') then
+ Exit;
+end;
+{--------}
+function FFMakeFileNameExt(const FileName : TffFileName;
+ const Ext : TffExtension) : TffFileNameExt;
+begin
+ Result := FileName;
+ FFShStrAddChar(Result, '.');
+ FFShStrConcat(Result, Ext);
+end;
+{--------}
+function FFMakeFullFileName(const Path : TffPath;
+ const FileName : TffFileNameExt) : TffFullFileName;
+begin
+ Result := Path;
+ if (Result[length(Result)] <> '\') then
+ FFShStrAddChar(Result, '\');
+ FFShStrConcat(Result, FileName);
+end;
+{--------}
+function FFSetCurDir(Path : TffPath) : boolean;
+var
+ DirZ : TffMaxPathZ;
+begin
+ Result := SetCurrentDirectory(FFStrPCopy(DirZ, Path));
+end;
+{====================================================================}
+
+
+{===Bitset routines==================================================}
+procedure FFClearAllBits(BitSet : PffByteArray; BitCount : integer);
+begin
+ FillChar(BitSet^, (BitCount+7) shr 3, 0);
+end;
+{--------}
+procedure FFClearBit(BitSet : PffByteArray; Bit : integer);
+var
+ BS : PAnsiChar absolute BitSet;
+ P : PAnsiChar;
+ M : byte;
+begin
+ P := BS + (Bit shr 3);
+ M := 1 shl (byte(Bit) and 7);
+ P^ := AnsiChar(byte(P^) and not M);
+end;
+{--------}
+function FFIsBitSet(BitSet : PffByteArray; Bit : integer) : boolean;
+var
+ BS : PAnsiChar absolute BitSet;
+ P : PAnsiChar;
+ M : byte;
+begin
+ P := BS + (Bit shr 3);
+ M := 1 shl (byte(Bit) and 7);
+ Result := (byte(P^) and M) <> 0;
+end;
+{--------}
+procedure FFSetAllBits(BitSet : PffByteArray; BitCount : integer);
+begin
+ FillChar(BitSet^, (BitCount+7) shr 3, $FF);
+end;
+{--------}
+procedure FFSetBit(BitSet : PffByteArray; Bit : integer);
+var
+ BS : PAnsiChar absolute BitSet;
+ P : PAnsiChar;
+ M : byte;
+begin
+ P := BS + (Bit shr 3);
+ M := 1 shl (byte(Bit) and 7);
+ P^ := AnsiChar(byte(P^) or M);
+end;
+{====================================================================}
+
+
+{===Verification routines============================================}
+function FFVerifyBlockSize(BlockSize : Longint) : boolean;
+begin
+ Result := (BlockSize = 4*1024) or
+ (BlockSize = 8*1024) or
+ (BlockSize = 16*1024) or
+ (BlockSize = 32*1024) or
+ (BlockSize = 64*1024);
+end;
+{--------}
+function FFVerifyExtension(const Ext : TffExtension) : boolean;
+begin
+ Result := ValidFileNameHelper(Ext, ffcl_Extension);
+end;
+{--------}
+function FFVerifyFileName(const FileName : TffFileName) : boolean;
+begin
+ Result := ValidFileNameHelper(FileName, ffcl_FileName);
+end;
+{--------}
+function FFVerifyServerName(aName: TffNetAddress): Boolean;
+var
+ I: Integer;
+begin
+ aName := FFShStrTrim(aName);
+ Result := not ((aName = '') or (Length(aName) > 15));
+ if Result then
+ for I := 1 to Length(aName) do
+ if not (aName[I] in ['A'..'Z', 'a'..'z', '0'..'9', ' ']) then begin
+ Result := False;
+ Break;
+ end;
+end;
+{--------}
+function FFVerifyKeyLength(KeyLen : word) : boolean;
+begin
+ Result := (0 < KeyLen) and (KeyLen <= ffcl_MaxKeyLength);
+end;
+{====================================================================}
+
+{===WWW Shell Routines===============================================}
+procedure ShellToWWW;
+begin
+ if ShellExecute(0, 'open', 'http://sourceforge.net/projects/tpflashfiler', '',
+ '', SW_SHOWNORMAL) <= 32 then
+ ShowMessage(EX_ErrorWWW);
+end;
+{--------}
+procedure ShellToEMail;
+begin
+ ShowMessage('Email support disabled in open source version.');
+// if ShellExecute(0, 'open',
+// 'mailto:support@turbopower.com',
+// '', '', SW_SHOWNORMAL) <= 32 then
+// ShowMessage(EX_ErrorEMAIL);
+end;
+{====================================================================}
+
+
+{===FlashFiler TffObject class=======================================}
+class function TffObject.NewInstance: TObject;
+begin
+ FFGetMem(Result, InstanceSize);
+ InitInstance(Result);
+end;
+{--------}
+procedure TffObject.FreeInstance;
+var
+ Temp : pointer;
+begin
+ {$IFDEF FF_DEBUG_THREADS} {!!.03}
+ ThreadEnter; {!!.03}
+ ThreadExit; {!!.03}
+ ffoMethodLock := 2; {!!.03}
+ {$ENDIF} {!!.03}
+ Temp := Self;
+ CleanupInstance;
+ FFFreeMem(Temp, InstanceSize);
+end;
+{Begin !!.03}
+{$IFDEF FF_DEBUG_THREADS}
+{--------}
+procedure TffObject.ThreadEnter;
+begin
+ case LockedExchange(ffoMethodLock, 1) of
+ 0: ; //ok
+ 2: raise Exception.Create('Attempt to access a destroyed object!');
+ else
+ ffoMethodLock := 3;
+ raise Exception.Create('Multithreading violation [ObjID: '+IntToStr(Integer(Self))+']');
+ end;
+ try
+ if ffoThreadLockCount > 0 then
+ if ffoCurrentThreadID <> GetCurrentThreadID then
+ raise Exception.Create('Multithreading violation [ObjID: ' +
+ IntToStr(Integer(Self)) +
+ ', Locking thread: ' +
+ IntToStr(ffoCurrentThreadID) +
+ ', Current thread: ' +
+ IntToStr(GetCurrentThreadID) +
+ ']')
+ else
+ Inc(ffoThreadLockCount)
+ else begin
+ ffoCurrentThreadID := GetCurrentThreadID;
+ Inc(ffoThreadLockCount);
+ end;
+ finally
+ case LockedExchange(ffoMethodLock, 0) of
+ 1: ; //ok
+ 2: raise Exception.Create('Attemp to access a destroyed object!');
+ else
+ ffoMethodLock := 3;
+ raise Exception.Create('Multithreading violation [ObjID: '+IntToStr(Integer(Self))+']');
+ end;
+ end;
+end;
+{--------}
+procedure TffObject.ThreadExit;
+begin
+ case LockedExchange(ffoMethodLock, 1) of
+ 0: ; //ok
+ 2: raise Exception.Create('Attempt to access a destroyed object!');
+ else
+ ffoMethodLock := 3;
+ raise Exception.Create('Multithreading violation [ObjID: '+IntToStr(Integer(Self))+']');
+ end;
+ try
+ if ffoThreadLockCount > 0 then
+ if ffoCurrentThreadID <> GetCurrentThreadID then
+ raise Exception.Create('Multithreading violation [ObjID: ' +
+ IntToStr(Integer(Self)) +
+ ', Locking thread: ' +
+ IntToStr(ffoCurrentThreadID) +
+ ', Current thread: ' +
+ IntToStr(GetCurrentThreadID) +
+ ']')
+ else
+ Dec(ffoThreadLockCount)
+ else
+ raise Exception.Create('ThreadEnter <-> ThreadExit');
+ finally
+ case LockedExchange(ffoMethodLock, 0) of
+ 1: ; //ok
+ 2: raise Exception.Create('Attemp to access a destroyed object!');
+ else
+ ffoMethodLock := 3;
+ raise Exception.Create('Multithreading violation [ObjID: '+IntToStr(Integer(Self))+']');
+ end;
+ end;
+end;
+{$ENDIF}
+{End !!.03}
+{====================================================================}
+
+{===FlashFiler TffVCLList class======================================}
+class function TffVCLList.NewInstance: TObject;
+begin
+ FFGetMem(Result, InstanceSize);
+ InitInstance(Result);
+end;
+{--------}
+procedure TffVCLList.FreeInstance;
+var
+ Temp : pointer;
+begin
+ Temp := Self;
+ CleanupInstance;
+ FFFreeMem(Temp, InstanceSize);
+end;
+{====================================================================}
+
+{===FlashFiler TffComponent class====================================}
+constructor TffComponent.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+ fcDestroying := False;
+ fcLock := TffPadlock.Create; {!!.11}
+end;
+{--------}
+destructor TffComponent.Destroy;
+var
+ Idx : Integer;
+begin
+ FFNotifyDependents(ffn_Destroy);
+
+{Begin !!.11}
+ if Assigned(fcDependentList) then begin
+ fcLock.Lock;
+ try
+ with fcDependentList do
+ for Idx := Pred(Count) downto 0 do
+ DeleteAt(Idx);
+ finally
+ fcLock.Unlock;
+ end;
+ end; { if }
+{End !!.11}
+ fcDependentList.Free;
+ fcLock.Free; {!!.11}
+ inherited Destroy;
+end;
+{--------}
+procedure TffComponent.FFAddDependent(ADependent : TffComponent);
+{Rewritten!!.11}
+var
+ Item : TffIntListItem;
+begin
+ if not Assigned(ADependent) then Exit;
+ Assert(ADependent <> Self); {!!.02}
+
+ if not Assigned(fcDependentList) then
+ fcDependentList := TffList.Create;
+ fcLock.Lock;
+ try
+ with fcDependentList do
+ if not Exists(Longint(ADependent)) then begin
+ Item := TffIntListItem.Create(Longint(ADependent));
+ Item.MaintainLinks := False;
+ Insert(Item);
+ end;
+ finally
+ fcLock.Unlock;
+ end;
+end;
+{--------}
+procedure TffComponent.FFNotification(const AOp : Byte; AFrom : TffComponent);
+begin
+ FFNotificationEX(AOp, AFrom, 0);
+end;
+{--------}
+procedure TffComponent.FFNotificationEx(const AOp : Byte; AFrom : TffComponent;
+ const aData : TffWord32);
+begin
+ { do nothing at this level }
+end;
+{--------}
+procedure TffComponent.FFNotifyDependents(const AOp : Byte);
+var
+ Idx : Integer;
+begin
+ if (fcDestroying and (AOp = ffn_Destroy)) then
+ Exit;
+{Begin !!.11}
+ if Assigned(fcDependentList) then begin
+ fcLock.Lock;
+ try
+ fcDestroying := AOp = ffn_Destroy;
+ for Idx := Pred(fcDependentList.Count) downto 0 do
+ TffComponent(TffIntListItem(fcDependentList[Idx]).KeyAsInt).FFNotification(AOp, Self);
+ finally
+ fcLock.Unlock;
+ end;
+ end; { if }
+{End !!.11}
+end;
+{--------}
+procedure TffComponent.FFNotifyDependentsEx(const AOp : Byte; const AData : TffWord32);
+var
+ Idx : Integer;
+begin
+ if (fcDestroying and (AOp = ffn_Destroy)) then
+ Exit;
+{Begin !!.11}
+ if Assigned(fcDependentList) then begin
+ fcLock.Lock;
+ try
+ fcDestroying := AOp = ffn_Destroy;
+ for Idx := Pred(fcDependentList.Count) downto 0 do
+ TffComponent(TffIntListItem(fcDependentList[Idx]).KeyAsInt).FFNotificationEx(AOp, Self, AData);
+ finally
+ fcLock.Unlock;
+ end;
+ end; { if }
+end;
+{--------}
+procedure TffComponent.FFRemoveDependent(ADependent: TffComponent);
+begin
+{Begin !!.11}
+ if Assigned(ADependent) and Assigned(fcDependentList) then begin
+ fcLock.Lock;
+ try
+ fcDependentList.Delete(Longint(ADependent));
+ finally
+ fcLock.Unlock;
+ end;
+ end; { if }
+{End !!.11}
+end;
+{--------}
+{$IFDEF IsDelphi} {!!.03}
+class function TffComponent.NewInstance: TObject;
+begin
+ FFGetMem(Result, InstanceSize);
+ InitInstance(Result);
+end;
+{--------}
+procedure TffComponent.FreeInstance;
+var
+ Temp : pointer;
+begin
+ {$IFDEF FF_DEBUG_THREADS} {!!.03}
+ ThreadEnter; {!!.03}
+ ThreadExit; {!!.03}
+ ffcMethodLock := 2; {!!.03}
+ {$ENDIF} {!!.03}
+ Temp := Self;
+ CleanupInstance;
+ FFFreeMem(Temp, InstanceSize);
+end;
+{$ENDIF} {!!.03}
+{Begin !!.03}
+{$IFDEF FF_DEBUG_THREADS}
+{--------}
+procedure TffComponent.ThreadEnter;
+begin
+ case LockedExchange(ffcMethodLock, 1) of
+ 0: ; //ok
+ 2: raise Exception.Create('Attemp to access a destroyed object!');
+ else
+ ffcMethodLock := 3;
+ raise Exception.Create('Multithreading violation [ObjID: '+IntToStr(Integer(Self))+']');
+ end;
+ try
+ if ffcThreadLockCount>0 then
+ if ffcCurrentThreadID <> GetCurrentThreadID then
+ raise Exception.Create('Multithreading violation [ObjID: '+IntToStr(Integer(Self))+']')
+ else
+ Inc(ffcThreadLockCount)
+ else begin
+ ffcCurrentThreadID := GetCurrentThreadID;
+ Inc(ffcThreadLockCount);
+ end;
+ finally
+ case LockedExchange(ffcMethodLock, 0) of
+ 1: ; //ok
+ 2: raise Exception.Create('Attemp to access a destroyed object!');
+ else
+ ffcMethodLock := 3;
+ raise Exception.Create('Multithreading violation [ObjID: '+IntToStr(Integer(Self))+']');
+ end;
+ end;
+end;
+{--------}
+procedure TffComponent.ThreadExit;
+begin
+ case LockedExchange(ffcMethodLock, 1) of
+ 0: ; //ok
+ 2: raise Exception.Create('Attemp to access a destroyed object!');
+ else
+ ffcMethodLock := 3;
+ raise Exception.Create('Multithreading violation [ObjID: '+IntToStr(Integer(Self))+']');
+ end;
+ try
+ if ffcThreadLockCount>0 then
+ if ffcCurrentThreadID <> GetCurrentThreadID then
+ raise Exception.Create('Multithreading violation [ObjID: '+IntToStr(Integer(Self))+']')
+ else
+ Dec(ffcThreadLockCount)
+ else
+ raise Exception.Create('ThreadEnter <-> ThreadExit');
+ finally
+ case LockedExchange(ffcMethodLock, 0) of
+ 1: ; //ok
+ 2: raise Exception.Create('Attemp to access a destroyed object!');
+ else
+ ffcMethodLock := 3;
+ raise Exception.Create('Multithreading violation [ObjID: '+IntToStr(Integer(Self))+']');
+ end;
+ end;
+end;
+{$ENDIF}
+{End !!.03}
+{--------}
+function TffComponent.GetVersion : string;
+begin
+ Result := Format('%5.4f', [ffVersionNumber / 10000.0]);
+end;
+{--------}
+procedure TffComponent.SetVersion(const Value : string);
+begin
+ {do nothing}
+end;
+{====================================================================}
+
+{===FlashFiler TffPersistent class===================================}
+class function TffPersistent.NewInstance: TObject;
+begin
+ FFGetMem(Result, InstanceSize);
+ InitInstance(Result);
+end;
+{--------}
+procedure TffPersistent.FreeInstance;
+var
+ Temp : pointer;
+begin
+ {$IFDEF FF_DEBUG_THREADS} {!!.03}
+ ThreadEnter; {!!.03}
+ ThreadExit; {!!.03}
+ ffpMethodLock := 2; {!!.03}
+ {$ENDIF} {!!.03}
+ Temp := Self;
+ CleanupInstance;
+ FFFreeMem(Temp, InstanceSize);
+end;
+{Begin !!.03}
+{$IFDEF FF_DEBUG_THREADS}
+{--------}
+procedure TffPersistent.ThreadEnter;
+begin
+ case LockedExchange(ffpMethodLock, 1) of
+ 0: ; //ok
+ 2: raise Exception.Create('Attemp to access a destroyed object!');
+ else
+ ffpMethodLock := 3;
+ raise Exception.Create('Multithreading violation [ObjID: '+IntToStr(Integer(Self))+']');
+ end;
+ try
+ if (ffpThreadLockCount>0) then
+ if ffpCurrentThreadID <> GetCurrentThreadID then
+ raise Exception.Create('Multithreading violation [ObjID: '+IntToStr(Integer(Self))+']')
+ else
+ Inc(ffpThreadLockCount)
+ else begin
+ ffpCurrentThreadID := GetCurrentThreadID;
+ Inc(ffpThreadLockCount);
+ end;
+ finally
+ case LockedExchange(ffpMethodLock, 0) of
+ 1: ; //ok
+ 2: raise Exception.Create('Attemp to access a destroyed object!');
+ else
+ ffpMethodLock := 3;
+ raise Exception.Create('Multithreading violation [ObjID: '+IntToStr(Integer(Self))+']');
+ end;
+ end;
+end;
+{--------}
+procedure TffPersistent.ThreadExit;
+begin
+ case LockedExchange(ffpMethodLock, 1) of
+ 0: ; //ok
+ 2: raise Exception.Create('Attemp to access a destroyed object!');
+ else
+ ffpMethodLock := 3;
+ raise Exception.Create('Multithreading violation [ObjID: '+IntToStr(Integer(Self))+']');
+ end;
+ try
+ if (ffpThreadLockCount>0) then
+ if ffpCurrentThreadID <> GetCurrentThreadID then
+ raise Exception.Create('Multithreading violation [ObjID: '+IntToStr(Integer(Self))+']')
+ else
+ Dec(ffpThreadLockCount)
+ else
+ raise Exception.Create('ThreadEnter <-> ThreadExit');
+ finally
+ case LockedExchange(ffpMethodLock, 0) of
+ 1: ; //ok
+ 2: raise Exception.Create('Attemp to access a destroyed object!');
+ else
+ ffpMethodLock := 3;
+ raise Exception.Create('Multithreading violation [ObjID: '+IntToStr(Integer(Self))+']');
+ end;
+ end;
+end;
+{$ENDIF}
+{End !!.03}
+{====================================================================}
+
+{===FlashFiler TffThread class=======================================}
+procedure TffThread.DoTerminate;
+begin
+ if Assigned(OnTerminate) then OnTerminate(Self);
+end;
+{--------}
+class function TffThread.NewInstance: TObject;
+begin
+ FFGetMem(Result, InstanceSize);
+ InitInstance(Result);
+end;
+{--------}
+procedure TffThread.FreeInstance;
+var
+ Temp : pointer;
+begin
+ Temp := Self;
+ CleanupInstance;
+ FFFreeMem(Temp, InstanceSize);
+end;
+{Begin !!.02}
+{--------}
+procedure TffThread.WaitForEx(const Timeout : Longint);
+var
+ H: THandle;
+ Msg: TMsg;
+begin
+ H := Handle;
+
+ if GetCurrentThreadID = MainThreadID then
+ while MsgWaitForMultipleObjects(1, H, False, Timeout, QS_SENDMESSAGE) =
+ WAIT_OBJECT_0 + 1 do
+ PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE)
+ else
+ WaitForSingleObject(H, Timeout);
+end;
+{End !!.02}
+{====================================================================}
+
+{===FlashFiler List and List Item classes============================}
+constructor TffListItem.Create;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ inherited Create;
+ ffliList := TffList.Create;
+ ffliState := lsNormal;
+ ffliMaintainLinks := True;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+destructor TffListItem.Destroy;
+var
+ inx : integer;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ ffliState := lsClearing;
+{Begin !!.11}
+ if ffliList <> nil then begin
+ for inx := 0 to pred(ffliList.Count) do
+ TffList(TffIntListItem(ffliList[inx]).KeyAsInt).InternalDelete(Key^); {!!.02}
+ ffliList.Free;
+ end;
+{End !!.11}
+ inherited Destroy;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffListItem.ffliAddListLink(L : TffList);
+var
+ anItem : TffIntListItem;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ {NOTE: this only gets called from a TffList object, so there's no
+ need to insert Self into the calling list: it will do it
+ itself}
+ if (ffliList.Index(Longint(L)) = -1) then begin
+ anItem := TffIntListItem.Create(Longint(L));
+ { Turn off link maintenance for the item otherwise we will
+ get into an infinitely recursive death spiral. }
+ anItem.MaintainLinks := False;
+ ffliList.Insert(anItem);
+ end;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffListItem.ffliBreakListLink(L : TffList);
+var
+ inx : integer;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ {NOTE: this only gets called from a TffList object, so there's no
+ need to remove Self from the calling list: it will do it
+ itself}
+ if (ffliState = lsNormal) then begin
+ inx := ffliList.Index(Longint(L));
+ if (inx <> -1) then
+ ffliList.DeleteAt(inx);
+ if ffliFreeOnRemove then begin
+ ffliState := lsClearing;
+ for inx := pred(ffliList.Count) downto 0 do
+ TffList(TffIntListItem(ffliList[inx]).KeyAsInt).InternalDelete(Key^); {!!.02}
+ ffliList.Empty;
+ ffliState := lsNormal;
+ end;
+ end;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{Begin !!.11}
+{--------}
+procedure TffListItem.ffliSetMaintainLinks(const Value : Boolean);
+{ Rewritten !!.12}
+begin
+ ffliMaintainLinks := Value;
+ if not Value then begin
+ ffliList.Free;
+ ffliList := nil;
+ end
+ else if ffliList = nil then
+ ffliList := TffList.Create;
+end;
+{End !!.11}
+{--------}
+function TffListItem.GetRefCount : integer;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+{Begin !!.11}
+ if ffliList <> nil then
+ Result := ffliList.Count
+ else
+ Result := 0;
+{End !!.11}
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+constructor TffStrListItem.Create(const aKey : TffShStr);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ inherited Create;
+ sliKey := FFShStrAlloc(aKey);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+destructor TffStrListItem.Destroy;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ {NOTE: inherited Destroy must be called first, because it will in
+ turn make a call to get the Key for the item, and so the
+ Key pointer had still better exist.}
+ inherited Destroy;
+ FFShStrFree(sliKey);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffStrListItem.Compare(aKey : pointer) : integer;
+begin
+ Result := FFCmpShStr(PffShStr(aKey)^, sliKey^, 255);
+end;
+{--------}
+function TffStrListItem.Key : pointer;
+begin
+ Result := sliKey;
+end;
+{--------}
+function TffStrListItem.KeyAsStr : TffShStr;
+begin
+ Result := sliKey^;
+end;
+{--------}
+function TffUCStrListItem.Compare(aKey : pointer) : integer;
+begin
+ Result := FFCmpShStrUC(PffShStr(aKey)^, PffShStr(Key)^, 255);
+end;
+{--------}
+constructor TffIntListItem.Create(const aKey : Longint);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ inherited Create;
+ iliKey := aKey;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffIntListItem.Compare(aKey : pointer) : integer;
+begin
+ Result := FFCmpI32(PffLongint(aKey)^, iliKey);
+end;
+{--------}
+function TffIntListItem.Key : pointer;
+begin
+ Result := @iliKey;
+end;
+{--------}
+function TffIntListItem.KeyAsInt : Longint;
+begin
+ Result := iliKey;
+end;
+{--------}
+constructor TffWord32ListItem.Create(const aKey : TffWord32);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ inherited Create;
+ wliKey := aKey;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffWord32ListItem.Compare(aKey : pointer) : integer;
+begin
+ Result := FFCmpDW(PffWord32(aKey)^, wliKey);
+end;
+{--------}
+function TffWord32ListItem.Key : pointer;
+begin
+ Result := @wliKey;
+end;
+{--------}
+function TffWord32ListItem.KeyAsInt : TffWord32;
+begin
+ Result := wliKey;
+end;
+{--------}
+function TffWord32ListItem.KeyValue : TffWord32;
+begin
+ Result := wliKey;
+end;
+{--------}
+constructor TffI64ListItem.Create(const aKey : TffInt64);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ inherited Create;
+ iliKey := aKey;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffI64ListItem.Compare(aKey : pointer) : integer;
+begin
+ Result := FFCmpI64(PffInt64(aKey)^, iliKey);
+end;
+{--------}
+function TffI64ListItem.Key : pointer;
+begin
+ Result := @iliKey;
+end;
+{--------}
+function TffI64ListItem.KeyValue : TffInt64;
+begin
+ Result := iliKey;
+end;
+{--------}
+constructor TffSelfListItem.Create;
+begin
+ inherited Create(Longint(Self));
+end;
+{--------}
+constructor TffList.Create;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ inherited Create;
+ fflState := lsNormal;
+ { Allocate space for the initial number of items. }
+ FFGetMem(fflList, ffcl_InitialListSize * sizeOf(TffListItem));
+ FillChar(fflList^, ffcl_InitialListSize * sizeOf(TffListItem), 0);
+ fflCapacity := ffcl_InitialListSize;
+ fflCount := 0;
+ fflSorted := true;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+destructor TffList.Destroy;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Empty;
+ FFFreeMem(fflList, fflCapacity * sizeOf(TffListItem));
+ inherited Destroy;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+{Deleted !!.01}
+{procedure TffList.Assign(Source : TPersistent);
+var
+ SrcList : TffList;
+ i : Longint;
+begin
+ if (Source is TffList) then begin
+ Empty;
+ SrcList := TffList(Source);
+ for i := 0 to pred(SrcList.Count) do
+ Insert(SrcList.Items[i]);
+ end
+ else
+ inherited Assign(Source);
+end;}
+{--------}
+procedure TffList.Delete(const aKey);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ fflDeleteAtPrim(fflIndexPrim(aKey));
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{Begin !!.02}
+{--------}
+procedure TffList.InternalDelete(const aKey);
+begin
+ if Assigned(fflPortal) then
+ fflPortal.BeginWrite;
+ try
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ fflDeleteAtPrim(fflIndexPrim(aKey));
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+ finally
+ if Assigned(fflPortal) then
+ fflPortal.EndWrite;
+ end;
+end;
+{End !!.02}
+{--------}
+procedure TffList.DeleteAt(aInx : Longint);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ fflDeleteAtPrim(aInx);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffList.fflDeleteAtPrim(aInx : Longint);
+var
+ Item : TffListItem;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ if (fflState = lsNormal) and
+ (0 <= aInx) and
+ (aInx < fflCount) then begin
+ Item := fflList^[aInx];
+ if assigned(Item) then begin
+ if Item.MaintainLinks then
+ Item.ffliBreakListLink(Self);
+ if (Item.ReferenceCount = 0) then
+ Item.Free;
+ dec(fflCount);
+ if aInx < fflCount then
+ Move(fflList^[aInx + 1], fflList^[aInx],
+ (fflCount - aInx) * SizeOf(TffListItem));
+ end;
+ end;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffList.Empty;
+var
+ Inx : Longint;
+ Item : TffListItem;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ fflState := lsClearing;
+ try
+ for Inx := pred(fflCount) downto 0 do begin
+ Item := fflList^[Inx];
+ if assigned(Item) then begin
+ if Item.MaintainLinks then
+ Item.ffliBreakListLink(Self);
+ if (Item.ReferenceCount = 0) then
+ Item.Free;
+ dec(fflCount);
+ end;
+ end;
+ { Zero out the array. }
+ fillChar(fflList^, fflCapacity * sizeOf(TffListItem), 0);
+ finally
+ fflState := lsNormal;
+ end;{try..finally}
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffList.Exists(const aKey) : boolean;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Result := fflIndexPrim(aKey) <> -1;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffList.fflGrow;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ SetCapacity(fflCapacity + ffcl_InitialListSize);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffList.GetCapacity : Longint;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Result := fflCapacity;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffList.GetCount : Longint;
+begin
+ Result := fflCount;
+end;
+{--------}
+function TffList.GetInsertionPoint(aItem : TffListItem) : Longint;
+var
+ OurCount: Longint;
+ L, R, M : Longint;
+ CompareResult : integer;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ OurCount := fflCount;
+ {take care of the easy case}
+ if (OurCount = 0) then
+ L := 0
+ else if Sorted then begin
+ {standard binary search}
+ L := 0;
+ R := pred(OurCount);
+ repeat
+ M := (L + R) div 2;
+ CompareResult := fflList^[M].Compare(aItem.Key);
+ if (CompareResult = 0) then begin
+ {do nothing, key already exists}
+ Result := -1;
+ Exit;
+ end
+ else if (CompareResult < 0) then
+ R := M - 1
+ else
+ L := M + 1
+ until (L > R);
+ {as it happens, on exit from this repeat..until loop the
+ algorithm will have set L to the correct insertion point}
+ end
+ else {not Sorted}
+ L := OurCount;
+
+ Result := L;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffList.GetItem(const aInx : Longint) : TffListItem;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ if (aInx >= 0) and (aInx < fflCount) then
+ Result := fflList^[aInx]
+ else
+ Result := nil;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffList.Insert(aItem : TffListItem) : boolean;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Result := InsertPrim(aItem) <> -1;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffList.InsertPrim(aItem : TffListItem) : Longint;
+var
+ L : Longint;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ { Determine the insertion point. }
+ L := GetInsertionPoint(aItem);
+ if L >= 0 then begin
+ { If we are at the limit then increase capacity. }
+ if fflCount = fflCapacity then
+ fflGrow;
+
+ { If we are before the last element in the list, shift everything up. }
+ if L < fflCount then
+ Move(fflList^[L], fflList^[L + 1], (fflCount - L) * sizeOf(TffListItem));
+
+ fflList^[L] := aItem;
+ if aItem.MaintainLinks then
+ aItem.ffliAddListLink(Self);
+ inc(fflCount);
+ end;
+ Result := L;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffList.IsEmpty : boolean;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Result := Count = 0;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffList.Index(const aKey) : Longint;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Result := fflIndexPrim(aKey);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffList.fflIndexPrim(const aKey) : Longint;
+var
+ M, L, R : Longint;
+ CompareResult : integer;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ if (fflCount > 0) then {!!.11}
+ if Sorted then begin
+ {standard binary search}
+ L := 0;
+ R := pred(fflCount);
+ repeat
+ M := (L + R) div 2;
+ CompareResult := fflList^[M].Compare(@aKey);
+ if (CompareResult = 0) then begin
+ Result := M;
+ Exit;
+ end
+ else if (CompareResult < 0) then
+ R := M - 1
+ else
+ L := M + 1
+ until (L > R);
+ end
+ else {not Sorted} begin
+ {standard sequential search}
+ for M := 0 to pred(fflCount) do
+ if (fflList^[M].Compare(@aKey) = 0) then begin
+ Result := M;
+ Exit;
+ end
+ end;
+ Result := -1;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffList.Remove(const aKey);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ fflRemoveAtPrim(fflIndexPrim(aKey));
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffList.RemoveAt(aInx : Longint);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ fflRemoveAtPrim(aInx);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffList.fflRemoveAtPrim(aInx : Longint);
+var
+ Item : TffListItem;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ if (fflState = lsNormal) and
+ (0 <= aInx) and
+ (aInx < fflCount) then begin
+ Item := fflList^[aInx];
+ if assigned(Item) then begin
+ if Item.MaintainLinks then
+ Item.ffliBreakListLink(Self);
+ { Note: the item is not freed }
+ dec(fflCount);
+ if aInx < fflCount then
+ Move(fflList^[aInx + 1], fflList^[aInx],
+ (fflCount - aInx) * SizeOf(TffListItem));
+ end;
+ end;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffList.SetCapacity(const C : Longint);
+var
+ NewList : PffListItemArray;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ if (C >= fflCount) and (C <> fflCapacity) then begin
+ { Get a new block. }
+ FFGetMem(NewList, C * sizeOf(TffListItem));
+ FillChar(NewList^, C * sizeOf(TffListItem), 0);
+
+ { Transfer the existing data. }
+ Move(fflList^, NewList^, fflCount * SizeOf(TffListItem));
+
+ { Free the existing data. }
+ FFFreeMem(fflList, fflCapacity * SizeOf(TffListItem));
+ fflList := NewList;
+ fflCapacity := C;
+ end;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffList.SetCount(const C : Longint);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ { Do we need to grow the table? }
+ if C <> fflCapacity then
+ SetCapacity(C);
+ fflCount := C;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffList.SetItem(const aInx : Longint; Item : TffListItem);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ if (0 <= aInx) and (aInx < fflCount) then
+ fflList^[aInx] := Item;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffList.SetSorted(S : boolean);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ if (S <> fflSorted) then
+ fflSorted := (S and IsEmpty);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{====================================================================}
+
+{===TffPointerList===================================================}
+constructor TffPointerList.Create;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ inherited Create;
+ { Allocate space for the initial number of items. }
+ FFGetMem(plList, ffcl_InitialListSize * sizeOf(Pointer));
+ FillChar(plList^, ffcl_InitialListSize * sizeOf(Pointer), 0);
+ plCapacity := ffcl_InitialListSize;
+ plCount := 0;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+destructor TffPointerList.Destroy;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ FFFreeMem(plList, plCapacity * sizeOf(Pointer));
+ inherited Destroy;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffPointerList.Assign(Source : TPersistent);
+var
+ SrcList : TffPointerList;
+ i : Longint;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ if (Source is TffPointerList) then begin
+ Empty;
+ SrcList := TffPointerList(Source);
+ for i := 0 to pred(SrcList.Count) do
+ Append(SrcList.Pointers[i]);
+ end
+ else
+ inherited Assign(Source);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffPointerList.Empty;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ { Did the array contain anything? }
+ if plCount > 0 then
+ { Yes. Zero it out. }
+ FillChar(plList^, plCapacity * sizeOf(Pointer), 0);
+ plCount := 0;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffPointerList.fflGrow;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ SetCapacity(plCapacity + ffcl_InitialListSize);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffPointerList.GetCapacity : Longint;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Result := plCapacity;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffPointerList.GetCount : Longint;
+begin
+ Result := plCount;
+end;
+{--------}
+function TffPointerList.GetPointer(aInx : Longint) : Pointer;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ if (0 <= aInx) and (aInx < plCount) then
+ Result := plList^[aInx]
+ else
+ Result := nil;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffPointerList.GetInternalAddress : pointer;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Result := pointer(plList);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffPointerList.Append(aPtr : Pointer) : boolean;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Result := AppendPrim(aPtr) <> -1;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffPointerList.AppendPrim(aPtr : Pointer) : Longint;
+var
+ L : Longint;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ { Determine the insertion point. }
+ L := plCount;
+ if L >= 0 then begin
+ { If we are at the limit then increase capacity. }
+ if plCount = plCapacity then
+ fflGrow;
+
+ { If we are before the last element in the list, shift everything up. }
+ if L < plCount then
+ Move(plList^[L], plList^[L + 1], (plCount - L) * sizeOf(Pointer));
+
+ plList^[L] := aPtr;
+ inc(plCount);
+ end;
+ Result := L;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffPointerList.IsEmpty : boolean;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Result := Count = 0;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffPointerList.RemoveAt(aInx : Longint);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ fflRemoveAtPrim(aInx);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffPointerList.fflRemoveAtPrim(aInx : Longint);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ if (0 <= aInx) and
+ (aInx < plCount) then begin
+ dec(plCount);
+ if aInx < plCount then
+ Move(plList^[aInx + 1], plList^[aInx],
+ (plCount - aInx) * SizeOf(Pointer));
+ end;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffPointerList.SetCapacity(const C : Longint);
+var
+ NewList : PffPointerArray;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ if (C >= plCount) and (C <> plCapacity) then begin
+ { Get a new block. }
+ FFGetMem(NewList, C * sizeOf(Pointer));
+ FillChar(NewList^, C * sizeOf(Pointer), 0);
+
+ { Transfer the existing data. }
+ Move(plList^, NewList^, plCount * SizeOf(Pointer));
+
+ { Free the existing data. }
+ FFFreeMem(plList, plCapacity * SizeOf(Pointer));
+ plList := NewList;
+ plCapacity := C;
+ end;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffPointerList.SetCount(const C : Longint);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ { Do we need to grow the table? }
+ if C > plCapacity then
+ SetCapacity(C);
+ plCount := C;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffPointerList.SetPointer(aInx : Longint; aPtr : Pointer);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ { Is the index within range? }
+ if (0 <= aInx) and (aInx < plCount) then
+ plList^[aInx] := aPtr;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{====================================================================}
+
+{===TffHandleList====================================================}
+constructor TffHandleList.Create;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ inherited Create;
+ { Allocate space for the initial number of items. }
+ FFGetMem(FList, ffcl_InitialListSize * sizeOf(THandle));
+ FillChar(FList^, ffcl_InitialListSize * sizeOf(THandle), 0);
+ FCapacity := ffcl_InitialListSize;
+ FCount := 0;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+destructor TffHandleList.Destroy;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Empty;
+ FFFreeMem(FList, FCapacity * sizeOf(THandle));
+ inherited Destroy;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffHandleList.Assign(Source : TPersistent);
+var
+ SrcList : TffHandleList;
+ i : Longint;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ if (Source is TffHandleList) then begin
+ Empty;
+ SrcList := TffHandleList(Source);
+ for i := 0 to pred(SrcList.Count) do
+ Append(SrcList.Handles[i]);
+ end
+ else
+ inherited Assign(Source);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffHandleList.DeleteAt(aInx : Longint);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ fflDeleteAtPrim(aInx);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffHandleList.fflDeleteAtPrim(aInx : Longint);
+var
+ aHandle : THandle;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ if (0 <= aInx) and
+ (aInx < FCount) then begin
+ aHandle := FList^[aInx];
+ CloseHandle(aHandle);
+ dec(FCount);
+ if aInx < FCount then
+ Move(FList^[aInx + 1], FList^[aInx],
+ (FCount - aInx) * SizeOf(THandle));
+ end;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffHandleList.Empty;
+var
+ Inx : Longint;
+ aHandle : THandle;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ for Inx := pred(FCount) downto 0 do begin
+ aHandle := FList^[Inx];
+ CloseHandle(aHandle);
+ dec(FCount);
+ end;
+ { Zero out the array. }
+ fillChar(FList^, FCapacity * sizeOf(THandle), 0);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffHandleList.fflGrow;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ SetCapacity(FCapacity + ffcl_InitialListSize);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffHandleList.GetCapacity : Longint;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Result := FCapacity;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffHandleList.GetCount : Longint;
+begin
+ Result := FCount;
+end;
+{--------}
+function TffHandleList.GetHandle(aInx : Longint) : THandle;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ if (0 <= aInx) and (aInx < FCount) then
+ Result := FList^[aInx]
+ else
+ Result := 0;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffHandleList.GetInternalAddress : pointer;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Result := pointer(FList);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffHandleList.Append(aHandle : THandle) : boolean;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Result := AppendPrim(aHandle) <> -1;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffHandleList.AppendPrim(aHandle : THandle) : Longint;
+var
+ L : Longint;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ { Determine the insertion point. }
+ L := FCount;
+ if L >= 0 then begin
+ { If we are at the limit then increase capacity. }
+ if FCount = FCapacity then
+ fflGrow;
+
+ { If we are before the last element in the list, shift everything up. }
+ if L < FCount then
+ Move(FList^[L], FList^[L + 1], (FCount - L) * sizeOf(THandle));
+
+ FList^[L] := aHandle;
+ inc(FCount);
+ end;
+ Result := L;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffHandleList.IsEmpty : boolean;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Result := Count = 0;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffHandleList.RemoveAll;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ FCount := 0;
+ { Zero out the array. }
+ fillChar(FList^, FCapacity * sizeOf(THandle), 0);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffHandleList.RemoveAt(aInx : Longint);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ fflRemoveAtPrim(aInx);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffHandleList.fflRemoveAtPrim(aInx : Longint);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ if (0 <= aInx) and
+ (aInx < FCount) then begin
+ { Note: The handle is not closed. }
+ dec(FCount);
+ if aInx < FCount then
+ Move(FList^[aInx + 1], FList^[aInx],
+ (FCount - aInx) * SizeOf(THandle));
+ end;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffHandleList.SetCapacity(const C : Longint);
+var
+ NewList : PffHandleArray;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ if (C >= FCount) and (C <> FCapacity) then begin
+ { Get a new block. }
+ FFGetMem(NewList, C * sizeOf(THandle));
+ FillChar(NewList^, C * sizeOf(THandle), 0);
+
+ { Transfer the existing data. }
+ Move(FList^, NewList^, FCount * SizeOf(THandle));
+
+ { Free the existing data. }
+ FFFreeMem(FList, FCapacity * SizeOf(THandle));
+ FList := NewList;
+ FCapacity := C;
+ end;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffHandleList.SetCount(const C : Longint);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ { Do we need to grow the table? }
+ if C > FCapacity then
+ SetCapacity(C);
+ FCount := C;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{====================================================================}
+
+{===TffThreadList====================================================}
+constructor TffThreadList.Create;
+begin
+ inherited Create;
+ fflPortal := TffReadWritePortal.Create;
+end;
+{--------}
+destructor TffThreadList.Destroy;
+begin
+ fflPortal.Free;
+ inherited Destroy;
+end;
+{--------}
+function TffThreadList.BeginRead : TffThreadList;
+begin
+ if isMultiThread then
+ fflPortal.BeginRead;
+ Result := Self;
+end;
+{--------}
+function TffThreadList.BeginWrite : TffThreadList;
+begin
+ if isMultiThread then
+ fflPortal.BeginWrite;
+ Result := Self;
+end;
+{--------}
+procedure TffThreadList.EndRead;
+begin
+ if isMultiThread then
+ fflPortal.EndRead;
+end;
+{--------}
+procedure TffThreadList.EndWrite;
+begin
+ if isMultiThread then
+ fflPortal.EndWrite;
+end;
+{====================================================================}
+
+
+{===TffStringList====================================================}
+constructor TffStringList.Create;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ inherited Create;
+ slCaseSensitive := true;
+ slList := TffList.Create;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+destructor TffStringList.Destroy;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ slList.Free;
+ inherited Destroy;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffStringList.Assign(Source : TPersistent);
+var
+ StrList : TffStringList;
+ Strs : TStrings;
+ I : Longint;
+ Inx : Longint;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+
+ StrList := TffStringList(Source);
+ Strs := TStrings(Source);
+
+ if Source is TffStringList then begin
+ Empty;
+
+ CaseSensitive := StrList.CaseSensitive;
+ Sorted := StrList.Sorted;
+
+ for I := 0 to StrList.Count - 1 do begin
+ Inx := InsertPrim(StrList.Strings[I]);
+ Objects[Inx] := StrList.Objects[I];
+ end;
+ end
+ else if Source is TStrings then begin
+ Empty;
+ Sorted := false;
+ for I := 0 to Strs.Count - 1 do begin
+ Insert(Strs.Strings[I]);
+ Objects[I] := Strs.Objects[I];
+ end;
+ end
+ else
+ inherited Assign(Source);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffStringList.AssignTo(Dest : TPersistent);
+var
+ StrList : TffStringList;
+ Strs : TStrings;
+ I : Longint;
+ Inx : Longint;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+
+ StrList := TffStringList(Dest);
+ Strs := TStrings(Dest);
+
+ if Dest is TffStringList then begin
+
+ StrList.Empty;
+ StrList.CaseSensitive := CaseSensitive;
+ StrList.Sorted := Sorted;
+
+ for I := 0 to pred(Count) do begin
+ Inx := StrList.InsertPrim(Strings[I]);
+ StrList.Objects[Inx] := Objects[I];
+ end;
+ end
+ else if Dest is TStrings then begin
+ Strs.Clear;
+ for I := 0 to pred(Count) do begin
+ Strs.Add(Strings[I]);
+ Strs.Objects[I] := Objects[I];
+ end;
+ end
+ else
+ inherited AssignTo(Dest);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffStringList.Delete(const aStr : TffShStr);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ slList.Delete(aStr);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffStringList.DeleteAt(aInx : Longint);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ slList.DeleteAt(aInx);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffStringList.Empty;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ slList.Empty;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffStringList.Exists(const aStr : TffShStr) : boolean;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Result := slList.Exists(aStr);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffStringList.GetCapacity : Longint;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Result := slList.Capacity;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffStringList.GetCount : Longint;
+begin
+ Result := slList.Count;
+end;
+{--------}
+function TffStringList.GetObj(aInx : Longint) : TObject;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Result := TObject(TffStrListItem(slList.Items[aInx]).ExtraData);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffStringList.GetSorted : boolean;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Result := slList.Sorted;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffStringList.GetStr(aInx : Longint) : TffShStr;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Result := TffStrListItem(slList.Items[aInx]).KeyAsStr;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffStringList.GetValue(const aName: TffShStr) : TffShStr;
+var
+ I: Longint;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ I := IndexOfName(aName);
+ if I >= 0 then Result := GetStr(I)
+ else Result := '';
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffStringList.IndexOfName(const aName: TffShStr): Longint;
+var
+ P: Longint;
+ S: TffShStr;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ for Result := 0 to GetCount - 1 do
+ begin
+ S := GetStr(Result);
+ P := Pos('=', S);
+ if (P <> 0) and (FFCmpShStr(Copy(S, 1, P - 1), aName, 255) = 0) then Exit;
+ end;
+ Result := -1;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffStringList.Insert(const aStr : TffShStr) : boolean;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Result := InsertPrim(aStr) <> -1;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffStringList.InsertPrim(const aStr : TffShStr) : Longint;
+var
+ Item : TffStrListItem;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ if CaseSensitive then
+ Item := TffStrListItem.Create(aStr)
+ else
+ Item := TffUCStrListItem.Create(aStr);
+ try
+ Result := slList.InsertPrim(Item);
+ if Result < 0 then {!!.10}
+ Item.Free; {!!.10}
+ except
+ Item.Free;
+ raise;
+ end;{try..except}
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffStringList.IsEmpty : boolean;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Result := slList.Count = 0;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffStringList.Index(const aStr : TffShStr) : Longint;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Result := slList.Index(aStr);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffStringList.SetCapacity(C : Longint);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ slList.Capacity := C;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffStringList.SetCaseSensitive(CS : boolean);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ if (slList.Count = 0) then
+ slCaseSensitive := CS;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffStringList.SetObj(aInx : Longint; const aObj : TObject);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ TffStrListItem(slList.Items[aInx]).ExtraData := pointer(aObj);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffStringList.SetSorted(S : boolean);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ slList.Sorted := S;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffStringList.SetStr(aInx : Longint; const aStr : TffShStr);
+var
+ Item : TffStrListItem;
+ Obj : TObject;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ {get the current item}
+ Item := TffStrListItem(slList.Items[aInx]);
+ if (Item = nil) then
+ Exit;
+ if slList.Sorted then begin
+ {delete the old item, create a new one and insert it}
+ Obj := TObject(Item.ExtraData);
+ slList.DeleteAt(aInx);
+ if CaseSensitive then
+ Item := TffStrListItem.Create(aStr)
+ else
+ Item := TffUCStrListItem.Create(aStr);
+ Item.ExtraData := pointer(Obj);
+ try
+ slList.Insert(Item);
+ except
+ Item.Free;
+ raise;
+ end;
+ end
+ else {the list is not sorted} begin
+ FFShStrFree(Item.sliKey);
+ Item.sliKey := FFShStrAlloc(aStr);
+ end;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffStringList.SetValue(const aName, aStr : TffShStr);
+var
+ Idx: Integer;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Idx := IndexOfName(aName);
+ if aStr <> '' then begin
+ if Idx < 0 then begin
+ { Item doesn't already exist }
+ Insert(aName);
+ Idx := IndexOfName(aName);
+ end;
+ SetStr(Idx, aName + '=' + aStr);
+ end
+ else begin
+ if Idx >= 0 then DeleteAt(Idx);
+ end;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{====================================================================}
+
+{===TffThreadStringList==============================================}
+constructor TffThreadStringList.Create;
+begin
+ inherited Create;
+ tslPortal := TffReadWritePortal.Create;
+ slList.fflPortal := tslPortal {!!.02}
+end;
+{--------}
+destructor TffThreadStringList.Destroy;
+begin
+ tslPortal.Free;
+ inherited Destroy;
+end;
+{--------}
+function TffThreadStringList.BeginRead : TffThreadStringList;
+begin
+ tslPortal.BeginRead;
+ Result := Self;
+end;
+{--------}
+function TffThreadStringList.BeginWrite : TffThreadStringList;
+begin
+ tslPortal.BeginWrite;
+ Result := Self;
+end;
+{--------}
+procedure TffThreadStringList.EndRead;
+begin
+ tslPortal.EndRead;
+end;
+{--------}
+procedure TffThreadStringList.EndWrite;
+begin
+ tslPortal.EndWrite;
+end;
+{====================================================================}
+
+{===TffQueue=========================================================}
+constructor TffQueue.Create;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ inherited Create;
+ ffqList := TffList.Create;
+ { Turn off sorting so that items are appended to list. }
+ ffqList.Sorted := False;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+destructor TffQueue.Destroy;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ ffqList.Free;
+ inherited Destroy;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffQueue.Delete(const aKey);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ ffqList.Delete(aKey);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffQueue.Dequeue : TffListItem;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Result := nil;
+ if GetCount > 0 then begin
+ Result := ffqList[0];
+ ffqList.RemoveAt(0);
+ end;
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+procedure TffQueue.Enqueue(anItem : TffListItem);
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ ffqList.Insert(anItem);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffQueue.GetCount : Longint;
+begin
+ Result := ffqList.Count;
+end;
+{--------}
+function TffQueue.IsEmpty : boolean;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Result := (ffqList.Count = 0);
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+function TffQueue.GetItem(aInx : Longint) : TffListItem;
+begin
+ {$IFDEF FF_DEBUG_THREADS}ThreadEnter; try{$ENDIF} {!!.03}
+ Result := ffqList[aInx];
+ {$IFDEF FF_DEBUG_THREADS}finally ThreadExit; end;{$ENDIF} {!!.03}
+end;
+{--------}
+{====================================================================}
+
+{===TffThreadQueue===================================================}
+constructor TffThreadQueue.Create;
+begin
+ inherited Create;
+ fftqPortal := TffReadWritePortal.Create;
+ ffqList.fflPortal := fftqPortal {!!.02}
+end;
+{--------}
+destructor TffThreadQueue.Destroy;
+begin
+ fftqPortal.Free;
+ inherited Destroy;
+end;
+{--------}
+function TffThreadQueue.BeginRead : TffThreadQueue;
+begin
+ fftqPortal.BeginRead;
+ Result := Self;
+end;
+{--------}
+function TffThreadQueue.BeginWrite : TffThreadQueue;
+begin
+ fftqPortal.BeginWrite;
+ Result := Self;
+end;
+{--------}
+procedure TffThreadQueue.EndRead;
+begin
+ fftqPortal.EndRead;
+end;
+{--------}
+procedure TffThreadQueue.EndWrite;
+begin
+ fftqPortal.EndWrite;
+end;
+{====================================================================}
+
+{===TffLatch=========================================================}
+constructor TffEvent.Create;
+begin
+ inherited Create;
+ {$IFDEF UseEventPool}
+ if Assigned(FFEventPool) then begin
+ ffeEvent := FFEventPool.Get;
+ { Make sure the event is not signaled. }
+ ResetEvent(ffeEvent);
+ end
+ else
+ ffeEvent := CreateEvent(nil, False, False, nil);
+ {$ELSE}
+ ffeEvent := CreateEvent(nil, False, False, nil);
+ {$ENDIF}
+end;
+{--------}
+destructor TffEvent.Destroy;
+begin
+ {$IFDEF UseEventPool}
+ if Assigned(FFEventPool) then
+ FFEventPool.Put(ffeEvent)
+ else
+ CloseHandle(ffeEvent);
+ {$ELSE}
+ CloseHandle(FEvent);
+ {$ENDIF}
+ inherited Destroy;
+end;
+{--------}
+procedure TffEvent.WaitFor(const timeOut : TffWord32);
+var
+ aTimeOut : TffWord32;
+ waitResult : DWord;
+begin
+ if timeOut <= 0 then
+ aTimeOut := ffcl_INFINITE {!!.06}
+ else
+ aTimeout := timeOut;
+
+ waitResult := WaitForSingleObject(ffeEvent, aTimeout);
+ if waitResult = WAIT_TIMEOUT then
+ raise EffException.CreateEx(ffStrResGeneral, fferrReplyTimeout,
+ [SysErrorMessage(GetLastError), GetLastError])
+ else if waitResult <> WAIT_OBJECT_0 then
+ raise EffException.CreateEx(ffStrResGeneral, fferrWaitFailed,
+ [SysErrorMessage(GetLastError), GetLastError]);
+end;
+{--------}
+function TffEvent.WaitForQuietly(const timeOut : TffWord32) : DWORD;
+var
+ aTimeOut : TffWord32;
+begin
+ if timeOut <= 0 then
+ aTimeOut := ffcl_INFINITE {!!.06}
+ else
+ aTimeout := timeOut;
+
+ Result := WaitForSingleObject(ffeEvent, aTimeout);
+
+end;
+{--------}
+procedure TffEvent.SignalEvent;
+begin
+ SetEvent(ffeEvent);
+end;
+{====================================================================}
+
+{===TffReadWritePortal===============================================}
+constructor TffReadWritePortal.Create;
+begin
+ inherited Create;
+// rwpBlockedReaders := FFSemPool.Get; {Deleted !!.06}
+// rwpBlockedWriters := FFSemPool.Get; {Deleted !!.06}
+ FFSemPool.GetTwo(rwpBlockedReaders, rwpBlockedWriters); {!!.06}
+ rwpGate := TffPadlock.Create;
+ rwpActiveReaders := 0;
+ rwpActiveWriter := false;
+ rwpActiveWriterID := 0;
+ rwpWaitingReaders := 0;
+ rwpWaitingWriters := 0;
+ rwpWriterReadCount := 0;
+ rwpWriterWriteCount := 0;
+end;
+{--------}
+destructor TffReadWritePortal.Destroy;
+begin
+ rwpGate.Free;
+ FFSemPool.Put(rwpBlockedReaders);
+ FFSemPool.Put(rwpBlockedWriters);
+ inherited Destroy; {!!.01}
+end;
+{--------}
+procedure TffReadWritePortal.BeginRead;
+var
+ MustWait : boolean;
+begin
+
+ if not IsMultiThread then
+ Exit;
+
+ { Wait for access to internal data. }
+ rwpGate.Lock;
+ try
+ { If the active writer is trying to read then automatically grant access. }
+ if rwpActiveWriter and (rwpActiveWriterID = GetCurrentThreadID) then begin
+ inc(rwpWriterReadCount);
+ exit;
+ end;
+
+ { If a writer has been granted access or there is at least one writer
+ waiting for access, add self as a waiting reader and make sure we
+ wait for read access. }
+ if rwpActiveWriter or (rwpWaitingWriters <> 0) then begin
+ inc(rwpWaitingReaders);
+ MustWait := true;
+ end else begin
+ { Otherwise, add self as an active reader. }
+ inc(rwpActiveReaders);
+ MustWait := false;
+ end;
+
+ finally
+ rwpGate.Unlock;
+ end;
+
+ if MustWait then
+ WaitForSingleObject(rwpBlockedReaders, ffcl_INFINITE); {!!.06}
+
+end;
+{--------}
+procedure TffReadWritePortal.BeginWrite;
+var
+ MustWait : boolean;
+begin
+
+ if not IsMultiThread then
+ Exit;
+
+ { Wait for access to internal data. }
+ rwpGate.Lock;
+ try
+
+ { If the active writer is calling BeginWrite once more, increment our
+ count of such calls, release the gate, and exit. }
+ if rwpActiveWriter and (rwpActiveWriterID = GetCurrentThreadID) then begin
+ Inc(rwpWriterWriteCount);
+ Exit;
+ end;
+
+ { If there are active readers or an active writer, add self as a waiting
+ writer. }
+ if rwpActiveWriter or (rwpActiveReaders <> 0) then begin
+ Inc(rwpWaitingWriters);
+ MustWait := True;
+ end else begin
+ { Otherwise, mark self as the active writer. }
+ rwpActiveWriter := True;
+ rwpActiveWriterID := GetCurrentThreadID; {!!.06}
+ MustWait := False;
+ end;
+ finally
+ rwpGate.Unlock;
+ end;
+
+ if MustWait then begin {!!.06 - Start}
+ WaitForSingleObject(rwpBlockedWriters, ffcl_INFINITE); {!!.06}
+ rwpActiveWriterID := GetCurrentThreadID;
+ end;
+
+ { If we reach this point then we have write access. Store our threadID
+ so that BeginRead knows who we are. Set our reference counts. }
+ {rwpActiveWriterID := GetCurrentThreadID;} {!!.06 - End}
+ rwpWriterReadCount := 0; {!!.02}
+ rwpWriterWriteCount := 1;
+end;
+{--------}
+procedure TffReadWritePortal.EndRead;
+begin
+
+ if not IsMultiThread then
+ Exit;
+
+ { Wait for access to internal data. }
+ rwpGate.Lock;
+ try
+
+ { If a writer is active and it is calling EndRead then decrement the read
+ count. }
+ if rwpActiveWriter and (rwpActiveWriterID = GetCurrentThreadID) then begin
+ dec(rwpWriterReadCount);
+ exit;
+ end;
+
+ { Note: This method does not catch the following cases:
+ 1. Thread calls EndRead before a BeginRead was issued.
+ 2. Active writer threadcalls EndRead before a BeginRead was called or
+ after EndWrite was called. }
+
+ if rwpActiveReaders > 0 then
+ dec(rwpActiveReaders);
+
+ { If we are the last reader and there is at least one waiting writer,
+ activate the waiting writer. }
+ if (rwpActiveReaders = 0) and (rwpWaitingWriters <> 0) then begin
+ dec(rwpWaitingWriters);
+ rwpActiveWriter := true;
+ ReleaseSemaphore(rwpBlockedWriters, 1, nil);
+ end;
+ finally
+ rwpGate.Unlock;
+ end;
+
+end;
+{--------}
+procedure TffReadWritePortal.EndWrite;
+var
+ tmpWaiting : integer;
+begin
+
+ if not IsMultiThread then
+ Exit;
+
+ { Wait for access to internal data. }
+ rwpGate.Lock;
+ try
+
+ { If this is the writer thread, see if this is the final call to
+ EndWrite. If not then just exist the method. }
+ if rwpActiveWriterID = GetCurrentThreadID then begin
+ dec(rwpWriterWriteCount);
+ if rwpWriterWriteCount > 0 then begin
+ exit;
+ end;
+ end else begin {!!.06 - Start}
+ { This should NEVER happend. }
+ Exit;
+ end;
+
+ { Note: This method doesn't catch the following cases:
+ 1. A thread other than the active thread calls EndWrite.
+ 2. A thread calls EndWrite before BeginWrite.
+ }
+
+ {rwpActiveWriter := False;}
+ {rwpActiveWriterID := 0;} {!!.06 - End}
+
+ { If there are any waiting readers then release them. }
+ if (rwpWaitingReaders <> 0) then begin
+ tmpWaiting := rwpWaitingReaders;
+ Dec(rwpWaitingReaders, rwpWaitingReaders);
+ Inc(rwpActiveReaders, tmpWaiting);
+ rwpActiveWriterID := 0; {!!.06}
+ rwpActiveWriter := False; {!!.06}
+ ReleaseSemaphore(rwpBlockedReaders, tmpWaiting, nil);
+ end else if (rwpWaitingWriters <> 0) then begin
+ { Otherwise if there is at least one waiting writer then release one. }
+ Dec(rwpWaitingWriters);
+ {rwpActiveWriter := True;} {!!.06 - Start}
+ rwpActiveWriterID := 0;
+ ReleaseSemaphore(rwpBlockedWriters, 1, nil);
+ end else begin
+ rwpActiveWriterID := 0;
+ rwpActiveWriter := False;
+ end; {!!.06 - End}
+ finally
+ rwpGate.Unlock;
+ end;
+end;
+{====================================================================}
+
+{===TffPadlock=======================================================}
+constructor TffPadLock.Create;
+begin
+ inherited Create;
+ InitializeCriticalSection(plCritSect);
+ plCount := 0;
+end;
+{--------}
+destructor TffPadLock.Destroy;
+begin
+ DeleteCriticalSection(plCritSect);
+ inherited Destroy;
+end;
+{--------}
+function TffPadLock.GetLocked : boolean;
+begin
+ Result := plCount > 0;
+end;
+{--------}
+procedure TffPadLock.Lock;
+begin
+ if IsMultiThread then begin
+ EnterCriticalSection(plCritSect);
+ inc(plCount);
+ end;
+end;
+{--------}
+procedure TffPadLock.Unlock;
+begin
+ if (plCount > 0) then begin
+ dec(plCount);
+ LeaveCriticalSection(plCritSect);
+ end;
+end;
+{====================================================================}
+
+{===Mutex pool=======================================================}
+constructor TffMutexPool.Create(const initialCount, retainCount : integer);
+var
+ aHandle : THandle;
+ Index : integer;
+begin
+ inherited Create;
+ mpList := TffHandleList.Create;
+ mpRetainCount := retainCount;
+ mpPadLock := TffPadlock.Create;
+
+ { Create the initial set of mutexes. }
+ for Index := 1 to initialCount do begin
+ aHandle := CreateMutex(nil, false, nil);
+ mpList.Append(aHandle);
+ end;
+end;
+{--------}
+destructor TffMutexPool.Destroy;
+begin
+ mpList.Free;
+ mpPadLock.Free;
+ inherited Destroy;
+end;
+{--------}
+procedure TffMutexPool.Flush;
+var
+ Index : integer;
+begin
+ mpPadLock.Lock;
+ try
+ if mpRetainCount < mpList.Count then
+ for Index := pred(mpList.Count) downto mpRetainCount do {!!.01}
+ mpList.DeleteAt(Index);
+ finally
+ mpPadLock.Unlock;
+ end;
+end;
+{--------}
+function TffMutexPool.Get : THandle;
+var
+ aCount : Longint;
+begin
+ mpPadLock.Lock;
+ try
+ if mpList.IsEmpty then
+ Result := CreateMutex(nil, false, nil)
+ else begin
+ { Get the last item in the list. This speeds up the RemoveAt
+ operation incredibly since it won't have to shift any bytes in the
+ list. }
+ aCount := pred(mpList.Count);
+ Result := mpList.Handles[aCount];
+ mpList.RemoveAt(aCount);
+ end;
+ finally
+ mpPadLock.Unlock;
+ end;
+end;
+{--------}
+procedure TffMutexPool.Put(const aHandle : THandle);
+begin
+ mpPadLock.Lock;
+ try
+ mpList.Append(aHandle);
+ finally
+ mpPadLock.Unlock;
+ end;
+end;
+{====================================================================}
+
+{===Semaphore pool===================================================}
+constructor TffSemaphorePool.Create(const initialCount, retainCount : integer);
+var
+ aHandle : THandle;
+ Index : integer;
+begin
+ inherited Create;
+ spList := TffHandleList.Create;
+ spRetainCount := retainCount;
+ spPadLock := TffPadlock.Create;
+
+ { Create the initial set of semaphores. }
+ for Index := 1 to initialCount do begin
+ aHandle := CreateSemaphore(nil, 0, ffcl_MaxBlockedThreads, nil);
+ spList.Append(aHandle);
+ end;
+end;
+{--------}
+destructor TffSemaphorePool.Destroy;
+begin
+ spList.Free;
+ spPadLock.Free;
+ inherited Destroy;
+end;
+{--------}
+procedure TffSemaphorePool.Flush;
+var
+ Index : integer;
+begin
+ spPadLock.Lock;
+ try
+ if spRetainCount < spList.Count then
+ for Index := pred(spList.Count) downto spRetainCount do {!!.01}
+ spList.DeleteAt(Index);
+ finally
+ spPadLock.Unlock;
+ end;
+end;
+{--------}
+function TffSemaphorePool.Get : THandle;
+var
+ aCount : Longint;
+begin
+ spPadLock.Lock;
+ try
+ if spList.IsEmpty then
+ Result := CreateSemaphore(nil, 0, ffcl_MaxBlockedThreads, nil)
+ else begin
+ { Get the last item in the list. This speeds up the RemoveAt
+ operation incredibly since it won't have to shift any bytes in the
+ list. }
+ aCount := pred(spList.Count);
+ Result := spList.Handles[aCount];
+ spList.RemoveAt(aCount);
+ end;
+ finally
+ spPadLock.Unlock;
+ end;
+end;
+{Begin !!.06}
+{--------}
+procedure TffSemaphorePool.GetTwo(var aHandle1,
+ aHandle2 : THandle);
+var
+ aCount, i : Longint;
+begin
+ spPadLock.Lock;
+ try
+ aCount := spList.FCount;
+ if (aCount < 2) then begin
+ for i := 1 to ffcl_InitialSemCount do
+ spList.Append(CreateSemaphore(nil, 0, ffcl_MaxBlockedThreads, nil));
+ aCount := aCount + ffcl_InitialSemCount;
+ end;
+ { Get the last items in the list. This speeds up the RemoveAt
+ operation incredibly since it won't have to shift any bytes in the
+ list. }
+ aCount := aCount - 1;
+ aHandle1 := spList.Handles[aCount];
+ spList.RemoveAt(aCount);
+ aCount := aCount - 1;
+ aHandle2 := spList.Handles[aCount];
+ spList.RemoveAt(aCount);
+ finally
+ spPadLock.Unlock;
+ end;
+end;
+{End !!.06}
+{--------}
+procedure TffSemaphorePool.Put(const aHandle : THandle);
+begin
+ spPadLock.Lock;
+ try
+ spList.Append(aHandle);
+ finally
+ spPadLock.Unlock;
+ end;
+end;
+{====================================================================}
+
+{$IFDEF UseEventPool}
+{===Event pool=======================================================}
+constructor TffEventPool.Create(const initialCount, retainCount : integer);
+var
+ aHandle : THandle;
+ Index : integer;
+begin
+ inherited Create;
+ epList := TffHandleList.Create;
+ epRetainCount := RetainCount;
+ epPadLock := TffPadlock.Create;
+
+ { Create the initial set of mutexes. }
+ for Index := 1 to InitialCount do begin
+ aHandle := CreateEvent(nil, False, False, nil); // manual reset, start signaled
+ epList.Append(aHandle);
+ end;
+end;
+{--------}
+destructor TffEventPool.Destroy;
+begin
+ epList.Free;
+ epPadLock.Free;
+ inherited Destroy;
+end;
+{--------}
+procedure TffEventPool.Flush;
+var
+ Index : integer;
+begin
+ epPadLock.Lock;
+ try
+ if epRetainCount < epList.Count then
+ for Index := Pred(epList.Count) downto Pred(epRetainCount) do
+ epList.DeleteAt(Index);
+ finally
+ epPadLock.Unlock;
+ end;
+end;
+{--------}
+function TffEventPool.Get : THandle;
+var
+ aCount : Longint;
+begin
+ epPadLock.Lock;
+ try
+ if epList.IsEmpty then
+ Result := CreateEvent(nil, False, False, nil) // manual reset, start signaled
+ else begin
+ { Get the last item in the list. This speeds up the RemoveAt
+ operation incredibly since it won't have to shift any bytes in the
+ list. }
+ aCount := Pred(epList.Count);
+ Result := epList.Handles[aCount];
+ epList.RemoveAt(aCount);
+ end;
+ finally
+ epPadLock.Unlock;
+ end;
+end;
+{--------}
+procedure TffEventPool.Put(const aHandle : THandle);
+begin
+ epPadLock.Lock;
+ try
+ epList.Append(aHandle);
+ finally
+ epPadLock.Unlock;
+ end;
+end;
+{=====================================================================}
+{$ENDIF}
+
+{== Memory pool ======================================================}
+type
+ PffPoolItem = ^TffPoolItem;
+ TffPoolItem = pointer {PffPoolItem};
+{--------}
+constructor TffMemoryPool.Create(ItemSize : TffMemSize;
+ ItemsInBlock : Integer);
+const
+ BlockSizeAdjustment = SizeOf(TffMemBlockInfo);
+
+ MaxBlockSize = (64 * 1024) + (BlockSizeAdjustment * 2);
+ {-We add a little bit of pad to account for a) the info stored at the
+ beginning of each block and b) each item having a pointer back to the
+ usage counter. When we get up to the 32768 & 65536 item sizes, we
+ need to make sure that at least 2 and 1 items are allocated,
+ respectively.
+
+ Note: Block size should not exceed 64k. We use a Word to store an offset
+ back to the block's usage counter. The max value of a Word is 65535.
+ Going over 64k block size leads to us storing a pointer to the usage
+ counter instead of an offset. }
+var
+ RealItemSize : Integer;
+ TestSize : Longint;
+const
+ MinItemSize = SizeOf(Word) + SizeOf(Pointer);
+ {-An item must have room for an offset back to the block's usage counter
+ & a pointer to the next free item. }
+begin
+
+ { Calculate the minimum item size. }
+ FItemSize := FFMaxL(ItemSize, MinItemSize);
+ FItemsInBlock := ItemsInBlock;
+
+ { Calculate # of bytes required for ItemsInBlock. Real item size is the asked
+ for ItemSize + 2 bytes. The extra 2 bytes are for an offset that leads us
+ back to the block's usage counter. }
+ RealItemSize := FItemSize + sizeof(Word);
+ TestSize := (RealItemSize * FItemsInBlock) + BlockSizeAdjustment;
+
+ { If the number of items would require more bytes than the max block size
+ then recalculate the number of items that we can hold in the max block
+ size. }
+ if (TestSize > MaxBlockSize) then begin
+ FItemsInBlock := (MaxBlockSize - BlockSizeAdjustment) div RealItemSize;
+ TestSize := (RealItemSize * FItemsInBlock) + BlockSizeAdjustment;
+ end;
+ FBlockSize := TestSize;
+ mpPadlock := TffPadlock.Create;
+end;
+{--------}
+destructor TffMemoryPool.Destroy;
+var
+ Temp : PffMemBlockInfo;
+ Next : PffMemBlockInfo;
+begin
+ mpPadlock.Lock;
+ try
+ Temp := FFirstBlock;
+ while Assigned(Temp) do begin
+ Next := Temp^.NextBlock;
+ FreeMem(Temp, FBlockSize);
+ Temp := Next;
+ end;
+ finally
+ mpPadlock.Unlock;
+ mpPadlock.Free;
+ end;{try..finally}
+ inherited Destroy; {!!.01}
+end;
+{--------}
+procedure TffMemoryPool.mpAddBlock;
+var
+ aBlock : PffMemBlockInfo;
+ Temp : PAnsiChar;
+ Prev : Pointer;
+ i : Integer;
+begin
+ {$IFDEF MemPoolTrace}
+ writeLn(Log, format('%d %d %d: Add block',
+ [GetTickCount, FItemSize, GetCurrentThreadID]));
+ flush(log);
+ {$ENDIF}
+ { Get pool, set links & usage counter. }
+ GetMem(aBlock, FBlockSize);
+ aBlock^.NextBlock := FFirstBlock;
+ aBlock^.UsageCounter := 0;
+ FFirstBlock := aBlock;
+ Temp := PAnsiChar(aBlock);
+
+ { Move to the first item in the block. }
+ inc(Temp, sizeof(pointer) + sizeOf(Longint));
+
+ { Set up the available item list. }
+ Prev := nil;
+ for i := 0 to pred(FItemsInBlock) do begin
+
+ { First 2 bytes are an offset back to usage counter. }
+ PWord(Temp)^ := Temp - PAnsiChar(aBlock);
+
+ { Next 4 bytes is the start of the item and it points to the previous
+ available item. }
+ inc(Temp, sizeOf(Word));
+ PffPoolItem(Temp)^ := Prev;
+ Prev := Temp;
+
+ { Move to the next available item. }
+ inc(Temp, FItemSize);
+ end;
+ FFreeList := Prev;
+end;
+{--------}
+function TffMemoryPool.Alloc : Pointer;
+var
+ aBlock : PffMemBlockInfo;
+ {$IFDEF MemPoolTrace}
+ PtrString, PtrString2 : array[0..8] of AnsiChar;
+ {$ENDIF}
+ Temp : PAnsiChar;
+begin
+ {$IFDEF MemPoolTrace}
+ WriteLn(Log, Format('%d, Block count %d', [FItemSize, BlockCount]));
+ {$ENDIF}
+ mpPadlock.Lock;
+ try
+ if not Assigned(FFreeList) then
+ mpAddBlock;
+ Result := FFreeList;
+ FFreeList := PffPoolItem(Result)^;
+
+ {$IFDEF MemPoolTrace}
+ FFPointerAsHex(PtrString, Result);
+ FFPointerAsHex(PtrString2, FFreelist);
+ writeLn(log, format('%d %d %d: Alloc, Result = %s, FFreeList = %s',
+ [GetTickCount, FItemSize, GetCurrentThreadID,
+ PtrString, PtrString2]));
+ flush(log);
+ {$ENDIF}
+
+ { Get the offset to the start of the block. It is in the 2 bytes just
+ prior to the newly-allocated item. }
+ Temp := Result;
+ dec(Temp, sizeOf(Word));
+
+ { Move back to the start of the block. }
+ dec(Temp, PWord(Temp)^);
+ aBlock := PffMemBlockInfo(Temp);
+
+ { Increment the usage counter. }
+ inc(aBlock^.UsageCounter);
+
+ finally
+ mpPadlock.UnLock;
+ end;{try..finally}
+end;
+{--------}
+function TffMemoryPool.BlockCount : Longint;
+var
+ Temp : PffMemBlockInfo;
+begin
+ Result := 0;
+ mpPadlock.Lock;
+ try
+ Temp := FFirstBlock;
+ while Assigned(Temp) do begin
+ inc(Result);
+ Temp := Temp^.NextBlock;
+ end;
+ finally
+ mpPadlock.Unlock;
+ end;{try..finally}
+end;
+{--------}
+function TffMemoryPool.BlockUsageCount(const BlockIndex : Longint) : Longint;
+var
+ Index : Longint;
+ Temp : PffMemBlockInfo;
+begin
+ Result := -1;
+ Index := 0;
+ mpPadlock.Lock;
+ try
+ Temp := FFirstBlock;
+ while Assigned(Temp) and (Index <= BlockIndex) do begin
+ if Index = BlockIndex then begin
+ { We have found the right block. Return the usage counter. }
+ Result := Temp^.UsageCounter;
+ break;
+ end
+ else begin
+ inc(Index);
+ Temp := Temp^.NextBlock;
+ end;
+ end;
+ finally
+ mpPadlock.Unlock;
+ end;{try..finally}
+end;
+{--------}
+procedure TffMemoryPool.Dispose(var P);
+var
+ aBlock : PffMemBlockInfo;
+ Pt : pointer absolute P;
+ {$IFDEF MemPoolTrace}
+ PtrString : array[0..8] of AnsiChar;
+ PtrString2 : array[0..8] of AnsiChar;
+ {$ENDIF}
+ Temp : PAnsiChar;
+begin
+ mpPadlock.Lock;
+ try
+ {$IFDEF MemPoolTrace}
+ FFPointerAsHex(PtrString, Pt);
+ FFPointerAsHex(PtrString2, FFreeList);
+ writeLn(log, format('%d %d %d: Dispose, Ptr = %s, FFreeList = %s',
+ [GetTickCount, FItemSize, GetCurrentThreadID,
+ PtrString, PtrString2]));
+ flush(log);
+ {$ENDIF}
+
+ PffPoolItem(Pt)^ := FFreeList;
+ FFreeList := Pt;
+
+ { Get the offset to the start of the block. }
+ Temp := FFreeList;
+ dec(Temp, sizeOf(Word));
+
+ { Move back to the start of the block. }
+ dec(Temp, PWord(Temp)^);
+
+ { Decrement the usage counter. }
+ aBlock := PffMemBlockInfo(Temp);
+ dec(aBlock^.UsageCounter);
+
+ Pt := nil;
+ finally
+ mpPadlock.UnLock;
+ end;{try..finally}
+end;
+{--------}
+procedure TffMemoryPool.mpCleanFreeList(const BlockStart : Pointer);
+var
+ BlockEnd : Pointer;
+ ItemsFound : Longint;
+ Prev : Pointer;
+ Temp : Pointer;
+begin
+ { Scan through the free list. If we find an item that falls within the
+ bounds of the block being freed then remove that item from the chain.
+ Stop the scan when all of the block's items have been found. }
+ BlockEnd := PAnsiChar(BlockStart) + FBlockSize;
+ ItemsFound := 0;
+
+ { Prev points to the last good item. }
+ Prev := nil;
+ Temp := FFreeList;
+
+ while assigned(Temp) and (ItemsFound < FItemsInBlock) do begin
+ { Does this item fall within the bounds of the freed block? }
+ if (PAnsiChar(Temp) > BlockStart) and (PAnsiChar(Temp) <= BlockEnd) then begin
+ { Yes. Increment item count. }
+ inc(ItemsFound);
+
+ { Is this item the head of the free list? }
+ if Temp = FFreeList then
+ { Yes. Update the head of the free list. }
+ FFreeList := PffPoolItem(Temp)^
+ else begin
+ { No. Point the previous item to the next item. }
+ PffPoolItem(Prev^) := PffPoolItem(Temp^);
+ end;
+
+ { Move to the next item. }
+ Temp := PffPoolItem(Temp)^;
+
+ end else begin
+ { No. Move to next item. }
+ Prev := Temp;
+ Temp := PffPoolItem(Temp)^;
+ end;
+ end;
+end;
+{--------}
+function TffMemoryPool.RemoveUnusedBlocks : Integer;
+var
+ Next : PffMemBlockInfo;
+ Prev : PffMemBlockInfo;
+ Temp : PffMemBlockInfo;
+begin
+ mpPadlock.Lock;
+ Result := 0;
+ try
+ { Loop through the chain of blocks, looking for those blocks with usage
+ count = 0. }
+ Prev := nil;
+ Temp := FFirstBlock;
+ while assigned(Temp) do begin
+ { Grab the pointer to the next block. }
+ Next := Temp^.NextBlock;
+
+ { Is this block's usage counter = 0? }
+ if Temp^.UsageCounter = 0 then begin
+ { Yes. Is this the first block in the chain? }
+ if Temp = FFirstBlock then
+ { Yes. Set first block = next block in chain. }
+ FFirstBlock := Next
+ else if assigned(Prev) then
+ { No. Update the previous block's Next Block pointer. }
+ Prev^.NextBlock := Next;
+ { Remove the block's items from the free list. }
+ mpCleanFreeList(Temp);
+ { Free the block. }
+ Freemem(Temp, FBlockSize);
+ inc(Result);
+ end
+ else
+ { No. Update the pointer to the previous block. }
+ Prev := Temp;
+
+ { Position to the next block. }
+ Temp := Next;
+ end;
+ finally
+ mpPadlock.Unlock;
+ end
+end;
+{=====================================================================}
+
+{== Initialization/Finalization ======================================}
+procedure FinalizeUnit;
+var
+ Inx : Integer;
+begin
+ FFSemPool.Free;
+ {$IFDEF UseEventPool}
+ FFEventPool.Free;
+ {$ENDIF}
+ for Inx := 0 to 91 do
+ FFMemPools[Inx].Free;
+
+ {$IFDEF MemPoolTrace}
+ {Close the log}
+ System.Close(Log);
+ {$ENDIF}
+end;
+{--------}
+procedure InitializeUnit;
+var
+ Inx : Integer;
+begin
+ {$IFDEF MemPoolTrace}
+ {open up the log file}
+ System.Assign(Log, 'MplTrace.log');
+ System.Rewrite(Log);
+ {$ENDIF}
+
+ { Create the memory pools ahead of time. We do it now instead of during
+ normal execution so that we can avoid thread A and thread B both trying
+ to create the memory pool at the same time. }
+ for Inx := 0 to 31 do
+ FFMemPools[Inx] := TffMemoryPool.Create(succ(Inx) * 32, 1024);
+
+ for Inx := 32 to 91 do
+ FFMemPools[Inx] := TffMemoryPool.Create(1024 + ((Inx - 31) * 256), 1024);
+
+ FFSemPool := TffSemaphorePool.Create(ffcl_InitialSemCount, ffcl_RetainSemCount);
+
+ {$IFDEF UseEventPool}
+ FFEventPool := TffEventPool.Create(ffcl_InitialEventCount, ffcl_RetainEventCount);
+ {$ENDIF}
+ end;
+{--------}
+{Begin !!.11}
+{$IFDEF DCC4OrLater}
+function PreGetDiskFreeSpaceEx(Directory : PChar;
+ var FreeAvailable,
+ TotalSpace : TLargeInteger;
+ TotalFree : PLargeInteger)
+ : Bool; stdcall;
+var
+ SectorsPerCluster,
+ BytesPerSector,
+ FreeClusters,
+ TotalClusters : LongWord;
+{$ELSE}
+function PreGetDiskFreeSpaceEx(Directory : PChar;
+ var FreeAvailable,
+ TotalSpace : Integer;
+ TotalFree : PInteger)
+ : Bool; stdcall;
+var
+ SectorsPerCluster,
+ BytesPerSector,
+ FreeClusters,
+ TotalClusters : DWord;
+{$ENDIF}
+ Root : string; {!!.12}
+begin
+ Root := ExtractFileDrive(Directory) + '\'; {!!.12}
+ Result := GetDiskFreeSpaceA(PChar(Root), {!!.12}
+ SectorsPerCluster,
+ BytesPerSector,
+ FreeClusters,
+ TotalClusters);
+ if Result then begin
+ FreeAvailable := SectorsPerCluster * BytesPerSector * FreeClusters;
+ TotalSpace := SectorsPerCluster * BytesPerSector * TotalClusters;
+ end
+ else
+ raise Exception.Create('Error checking free disk space: ' +
+ SysErrorMessage(GetLastError));
+end;
+
+function FFGetDiskFreeSpace(const aDirectory : string) : Integer;
+var
+ Kernel : THandle;
+ Path : array[0..255] of char;
+
+ {needed for GetDiskFreeSpaceEx}
+ {$IFDEF DCC4OrLater}
+ FreeAvailable : Int64;
+ TotalSpace : Int64;
+ {$ELSE}
+ FreeAvailable : Integer;
+ TotalSpace : Integer;
+ {$ENDIF}
+begin
+ FFLLGetDiskFreeSpaceEx := @PreGetDiskFreeSpaceEx;
+
+ { Get API routine to use to check free disk space }
+ Kernel := GetModuleHandle(Windows.Kernel32);
+{Begin !!.12}
+ if (Kernel <> 0) then begin
+ @FFLLGetDiskFreeSpaceEx := GetProcAddress(Kernel,
+ 'GetDiskFreeSpaceExA');
+ if not assigned(FFLLGetDiskFreeSpaceEx) then
+ FFLLGetDiskFreeSpaceEx := @PreGetDiskFreeSpaceEx;
+ end; { if }
+{End !!.12}
+
+ StrPCopy(Path, aDirectory);
+ if FFLLGetDiskFreeSpaceEx(Path, FreeAvailable, TotalSpace, nil) then
+ Result := FreeAvailable div 1024
+ else
+ raise Exception.Create('Error getting free disk space: %s' +
+ SysErrorMessage(GetLastError));
+end;
+{End !!.11}
+
+initialization
+ InitializeUnit;
+
+finalization
+ FinalizeUnit;
+
+end.
+
diff --git a/components/flashfiler/sourcelaz/ffllcnst.rc b/components/flashfiler/sourcelaz/ffllcnst.rc
new file mode 100644
index 000000000..32af5d054
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffllcnst.rc
@@ -0,0 +1,32 @@
+/*********************************************************
+ * FlashFiler: Lowlevel (common) string table resource *
+ *********************************************************/
+
+/* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** */
+
+
+FF_GENERAL_STRINGS RCDATA FFLLCNST.SRM
+
diff --git a/components/flashfiler/sourcelaz/ffllcnst.res b/components/flashfiler/sourcelaz/ffllcnst.res
new file mode 100644
index 000000000..e5702a129
Binary files /dev/null and b/components/flashfiler/sourcelaz/ffllcnst.res differ
diff --git a/components/flashfiler/sourcelaz/ffllcnst.srm b/components/flashfiler/sourcelaz/ffllcnst.srm
new file mode 100644
index 000000000..7b3c3027a
Binary files /dev/null and b/components/flashfiler/sourcelaz/ffllcnst.srm differ
diff --git a/components/flashfiler/sourcelaz/ffllcnst.str b/components/flashfiler/sourcelaz/ffllcnst.str
new file mode 100644
index 000000000..516b40e30
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffllcnst.str
@@ -0,0 +1,96 @@
+;*********************************************************
+;* FlashFiler: Lowlevel (common) string table resource *
+;*********************************************************
+
+;* ***** BEGIN LICENSE BLOCK *****
+;* Version: MPL 1.1
+;*
+;* The contents of this file are subject to the Mozilla Public License Version
+;* 1.1 (the "License"); you may not use this file except in compliance with
+;* the License. You may obtain a copy of the License at
+;* http://www.mozilla.org/MPL/
+;*
+;* Software distributed under the License is distributed on an "AS IS" basis,
+;* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+;* for the specific language governing rights and limitations under the
+;* License.
+;*
+;* The Original Code is TurboPower FlashFiler
+;*
+;* The Initial Developer of the Original Code is
+;* TurboPower Software
+;*
+;* Portions created by the Initial Developer are Copyright (C) 1996-2002
+;* the Initial Developer. All Rights Reserved.
+;*
+;* Contributor(s):
+;*
+;* ***** END LICENSE BLOCK *****
+
+#include "ffconst.inc"
+
+fferrCopyFile, "Operating system error when copying a file [%d, %s]"
+fferrDeleteFile, "Operating system error when deleting a file [%d, %s]"
+fferrRenameFile, "Operating system error when renaming a file [%d, %s]"
+
+fferrReplyTimeout, "Timed out waiting for reply"
+fferrWaitFailed, "Failure occurred while calling WaitForSingleObject: %s [%d]"
+fferrInvalidProtocol, "Protocol %s may not be specified for transport."
+fferrProtStartupFail, "Could not start %s protocol."
+fferrConnectionLost, "Connection to server is no longer valid."
+fferrTransportFail, "Transport error occurred. See transport log for details."
+fferrPortalTimeout, "Timeout occurred in TffReadWritePortal.%s"
+
+fferrOutOfBounds, "Field, index or file number does not exist in the dictionary [%s, item %d]"
+fferrDictPresent, "Once a dictionary has been defined for a file, another cannot be defined [%s]"
+fferrNotADict, "Attempted to assign an object that wasn't a dictionary to a dictionary object [%s]"
+fferrNoFields, "Dictionary has no field definitions, it cannot be used until at least one is defined [%s]"
+fferrBadFieldRef, "Composite index refers to field number that does not exist [%s, field %d]"
+fferrBadFieldType, "Unknown field type encountered in a case statement [%d]"
+fferrRecTooLong, "The sum of the field lengths in the dictionary is greater than the maximum record length [%s]"
+fferrDiffBlockSize, "Attempted to write dictionary to a file with different block size [%s, old size %d, new %d]"
+fferrDictReadOnly, "Once a table has been built, cannot modify its dictionary [%s]"
+fferrDictMissing, "The data dictionary is not present in the file [%s]"
+fferrBLOBFileDefd, "A BLOB file has already been defined for this dictionary [%s]"
+fferrBaseFile, "Cannot remove the base file descriptor [%s, file 0]"
+fferrBadFileNumber, "File number does not exist in dictionary [%s, file %d]"
+fferrBadBaseName, "Table name is invalid: can only have a-z, A-Z, 0-9, or _ characters [passed: %s]"
+fferrBadExtension, "Extension is invalid: can only have a-z, A-Z, 0-9, or _ characters, must have 1, 2 or 3 chars [%s, ext %s]"
+fferrDupExtension, "Extension is already present in the data dictionary [%s, ext %s]"
+fferrDataFileDefd, "There can only be one data file per table, and it has already been defined for this dictionary [%s]"
+fferrNoFieldsInKey, "There must be at least one field in a composite index [%s]"
+fferrBadParameter, "Invalid parameter passed to routine [%s, parameter %d]"
+fferrBadBlockSize, "The block size must be 4KB, 8KB, 16KB or 32KB only [size used: %d]"
+fferrKeyTooLong, "The key length for an index should be between 0 and 1024 bytes [passed %d]"
+fferrDupFieldName, "There is a duplicate field name in the dictionary [%s, field %s]"
+fferrDupIndexName, "There is a duplicate index name in the dictionary [%s, index %s]"
+fferrIxHlprRegistered, "Index helper [%s] is already registered."
+fferrIxHlprNotReg, "Index helper [%s] is not registered."
+fferrIxHlprNotSupp, "Index helper [%s] does not support field type [%s]."
+fferrIncompatDict, "The cursor dictionaries are incompatible. Verify the correct field types, lengths, units, and decimal places have been specified."
+fferrFileInUse, "Cannot remove file %d because it is still referenced by an index."
+fferrFieldInUse, "Cannot remove field %s because it is still referenced by an index."
+
+fferrCommsNoWinRes, "No window resources left: Communications notify window creation failed"
+fferrCommsCannotCall, "Servers cannot issue call requests, they only listen"
+fferrCommsCantListen, "Clients cannot issue listen requests, they only call"
+fferrWinsock, "Winsock communications: Unexpected Winsock error %d/$%x [%s]"
+fferrWSNoWinsock, "Winsock communications: Winsock not found, or DLL is invalid"
+fferrWSNoSocket, "Winsock communications: Cannot create a new socket"
+fferrWSNoLocalAddr, "Winsock communications: Cannot retrieve local address information"
+
+fferrTmpStoreCreateFail, "Could not create temporary storage, size %d. Error %d/$%x [%s]"
+fferrTmpStoreFull, "Temporary storage is full, reaching %d MB in size. More space may need to be allocated."
+fferrMapFileCreateFail, "Could not create map file %s, size %d, error %d/%x [%s]"
+fferrMapFileHandleFail, "Could not open map file %s, size %d, error %d/%x [%s]"
+fferrMapFileViewFail, "%s: Could not create view for block %d of map file %s, error %d/%x [%s]"
+
+ffscSeqAccessIndexName, "Sequential Access Index"
+ffscMainTableFileDesc, "Data/DataDict File"
+ffscRegistryMainKey, "\Software\TurboPower\FlashFiler\"
+
+fferrInvalidServerName, "Invalid server name"
+fferrInvalidNameorPath, "Invalid name or path"
+fferrDuplicateAliasName, "Duplicate alias name not allowed"
+fferrEmptyValuesNotAllowed, "One or more values not defined"
+
diff --git a/components/flashfiler/sourcelaz/ffllcoll.pas b/components/flashfiler/sourcelaz/ffllcoll.pas
new file mode 100644
index 000000000..dd23db9de
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffllcoll.pas
@@ -0,0 +1,265 @@
+{*********************************************************}
+{* FlashFiler: Collection class *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffllcoll;
+
+interface
+
+uses
+ Classes,
+ ffllbase;
+
+type
+ TffCollection = class; {forward declaration}
+
+ TffCollectionItem = class {class of item appearing in collection}
+ protected {private}
+ ciContainer : TffCollection;
+ ciParent : TObject;
+ protected
+ function ciGetIdentifier : integer;
+ public
+ constructor Create(aParent : TObject; aContainer : TffCollection);
+ destructor Destroy; override;
+
+ property Container : TffCollection read ciContainer;
+ property Identifier : integer read ciGetIdentifier;
+ property Parent : TObject read ciParent;
+ end;
+
+ {note: rewritted to use TList !!.06}
+ TffCollection = class
+ protected {private}
+ FItems : TList;
+ protected
+ function tcGet(aIndex : integer) : TffCollectionItem;
+ function tcGetCapacity : integer;
+ function tcGetCount : integer;
+ procedure tcPut(aIndex : integer; aItem : TffCollectionItem);
+ procedure tcSetCapacity(aNewCapacity : integer);
+ public
+ constructor Create;
+ destructor Destroy; override;
+
+ procedure InsertAt(aIndex: integer; aItem : TffCollectionItem);
+ procedure Delete(aItem : TffCollectionItem);
+ procedure FreeAll;
+ function IndexOf(aItem : TffCollectionItem) : integer; virtual;
+ function Insert(aItem : TffCollectionItem) : boolean; virtual;
+
+ property Count: integer read tcGetCount;
+ property Items[aIndex : integer] : TffCollectionItem
+ read tcGet write tcPut; default;
+ end;
+
+ TffSortedCollection = class(TffCollection)
+ private
+ tscAllowDups : boolean;
+ public
+ constructor Create(aAllowDups : boolean);
+
+ function KeyOf(aItem : TffCollectionItem) : pointer; virtual;
+ function Compare(aKey1, aKey2 : Pointer) : integer; virtual; abstract;
+ function Insert(aItem : TffCollectionItem) : boolean; override;
+ function Search(aKey : Pointer; var aIndex : integer): boolean; virtual;
+
+ property AllowDups : boolean read tscAllowDups;
+ end;
+
+implementation
+
+uses
+ SysUtils,
+ ffconst,
+ ffclbase;
+
+{===TffCollectionItem================================================}
+constructor TffCollectionItem.Create(aParent : TObject;
+ aContainer : TffCollection);
+begin
+ inherited Create;
+ ciParent := aParent;
+ ciContainer := aContainer;
+ if (aContainer <> nil) then
+ if not aContainer.Insert(Self) then
+ raise Exception.Create(ffStrResClient[ffccDupItemInColl]);
+end;
+{--------}
+destructor TffCollectionItem.Destroy;
+begin
+ if (ciContainer <> nil) then
+ ciContainer.Delete(Self);
+ inherited Destroy;
+end;
+{--------}
+function TffCollectionItem.ciGetIdentifier : integer;
+begin
+ if (ciContainer <> nil) then
+ Result := ciContainer.IndexOf(Self)
+ else
+ Result := 0;
+end;
+{====================================================================}
+
+
+{===TffCollection====================================================}
+constructor TffCollection.Create;
+begin
+ inherited Create;
+ FItems := TList.Create;
+end;
+{--------}
+destructor TffCollection.Destroy;
+begin
+ if (FItems <> nil) then begin
+ FreeAll;
+ FItems.Free;
+ end;
+ inherited Destroy;
+end;
+{--------}
+procedure TffCollection.InsertAt(aIndex : integer; aItem : TffCollectionItem);
+begin
+ FItems.Insert(aIndex, aItem);
+end;
+{--------}
+procedure TffCollection.Delete(aItem : TffCollectionItem);
+var
+ Inx : integer;
+begin
+ Inx := FItems.IndexOf(aItem);
+ if (Inx <> -1) then
+ FItems.Delete(Inx);
+end;
+{--------}
+procedure TffCollection.FreeAll;
+var
+ Inx : integer;
+begin
+ {note: the downto is required because the base item class will
+ delete itself from the collection when freed}
+ for Inx := pred(FItems.Count) downto 0 do
+ TObject(FItems[Inx]).Free;
+ FItems.Clear;
+end;
+{--------}
+function TffCollection.IndexOf(aItem : TffCollectionItem) : integer;
+begin
+ Result := FItems.IndexOf(aItem);
+end;
+{--------}
+function TffCollection.Insert(aItem : TffCollectionItem) : boolean;
+begin
+ FItems.Add(aItem);
+ Result := true;
+end;
+{--------}
+function TffCollection.tcGet(aIndex : integer) : TffCollectionItem;
+begin
+ Result := TffCollectionItem(FItems[aIndex]);
+end;
+{--------}
+function TffCollection.tcGetCount: integer;
+begin
+ Result := FItems.Count;
+end;
+{--------}
+function TffCollection.tcGetCapacity : integer;
+begin
+ Result := FItems.Capacity;
+end;
+{--------}
+procedure TffCollection.tcPut(aIndex : integer; aItem : TffCollectionItem);
+begin
+ FItems[aIndex] := aItem;
+end;
+{--------}
+procedure TffCollection.tcSetCapacity(aNewCapacity : integer);
+begin
+ FItems.Capacity := aNewCapacity;
+end;
+{====================================================================}
+
+
+{===TffSortedCollection==============================================}
+constructor TffSortedCollection.Create(aAllowDups : boolean);
+begin
+ inherited Create;
+ tscAllowDups := aAllowDups;
+end;
+{--------}
+function TffSortedCollection.Insert(aItem : TffCollectionItem) : boolean;
+var
+ Inx : integer;
+begin
+ if (not Search(KeyOf(aItem), Inx)) or AllowDups then begin
+ InsertAt(Inx, aItem);
+ Result := true;
+ end else
+ Result := false;
+end;
+{--------}
+function TffSortedCollection.KeyOf(aItem : TffCollectionItem) : pointer;
+begin
+ Result := aItem;
+end;
+{--------}
+function TffSortedCollection.Search(aKey : pointer; var aIndex : integer) : boolean;
+var
+ L, R, M : integer;
+ CmpRes : integer;
+begin
+ Result := false;
+ L := 0;
+ R := pred(Count);
+ while (L <= R) do begin
+ M := (L + R) div 2;
+ CmpRes := Compare(KeyOf(FItems[M]), aKey);
+ if (CmpRes < 0) then
+ L := succ(M)
+ else if (CmpRes > 0) then
+ R := pred(M)
+ else {CmpRes = 0} begin
+ Result := true;
+ if not AllowDups then begin
+ aIndex := M;
+ Exit;
+ end;
+ R := pred(M); {need to find the first dup item}
+ end;
+ end;
+ aIndex := L;
+end;
+{====================================================================}
+
+
+end.
+
diff --git a/components/flashfiler/sourcelaz/ffllcomm.pas b/components/flashfiler/sourcelaz/ffllcomm.pas
new file mode 100644
index 000000000..98435cc48
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffllcomm.pas
@@ -0,0 +1,1946 @@
+{*********************************************************}
+{* FlashFiler: Base unit for transports & cmd handlers *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffllcomm;
+
+interface
+
+uses
+ classes,
+ forms,
+ windows,
+ ffllbase,
+ ffllcomp,
+ fflleng,
+ fflllog,
+ ffllreq,
+ ffllthrd,
+ ffnetmsg;
+
+
+type
+
+ { TffDataMessage contains the message information passed from a transport
+ to a server command handler, plugin command handler, or engine manager. }
+ PffDataMessage = ^TffDataMessage;
+ TffDataMessage = record
+ dmMsg : Longint; { the unique ID identifying the msg type }
+ dmClientID : TffClientID; { the client sending the message }
+ dmRequestID : Longint; { the unique ID of the request }
+ dmTime : TffWord32; { the time the message was received }
+ dmRetryUntil : TffWord32;
+ dmErrorCode : TffResult;
+ dmData : pointer;
+ dmDataLen : TffMemSize;
+ end;
+
+ { The following options may be used to control logging in the transports.
+ Values:
+ fftpLogErrors - Write errors to the event log.
+ fftpLogRequests - Write requests to the event log. If in Send mode
+ then logs all sent requests. If in Listen mode then logs all received
+ requests.
+ fftpLogReplies - If in Send mode then logs all received replies. If in
+ Listen mode then logs all sent replies. }
+ TffTransportLogOption = (fftpLogErrors,
+ fftpLogRequests, fftpLogReplies);
+ TffTransportLogOptions = set of TffTransportLogOption;
+
+ { A transport will send a request to the server. When the reply is
+ received, the transport must notify the object submitting the request.
+ To be notified, the object submitting the request must define a procedure
+ of type TffReplyCallback. Parameters passed to this procedure are as
+ follows:
+ @param msgID The message identifier returned by the server.
+ @param errorCode The error code returned by the server.
+ @param replyData The data returned by the server.
+ @param replyDataLen The length of the data returned by the server.
+ @param replyType The format of the data: byteArray (e.g., packed record)
+ or stream.
+ @param replyCookie The replyCookie parameter originally supplied to the
+ TffBaseTransport.Request method. The meaning of this parameter is
+ specific to the object submitting the request. For the
+ TffRemoteServerEngine, this is a pointer to TffProxyClient.
+ }
+ TffReplyCallback = procedure(msgID : Longint;
+ errorCode : TffResult;
+ replyData : pointer;
+ replyDataLen : Longint;
+ replyCookie : Longint);
+
+ TffBasePluginCommandHandler = class; { forward declaration }
+ TffBaseEngineManager = class; { forward declaration }
+ TffBaseTransport = class; { forward declaration }
+
+ { This is the base class for the command handler. A command handler
+ receives requests from a transport and routes them to a destination.
+ The base class supports routing of commands to plugins that have
+ themselves with the command handler. }
+ TffBaseCommandHandler = class(TffStateComponent)
+ protected {private}
+
+ FManager : TffBaseEngineManager;
+ {-The engine manager that may receive shutdown and startup requests
+ through this command handler. Note that the command handler doesn't
+ really know about shutdown and startup requests. The engine manager
+ is like a special plugin. If a plugin does not handle the message,
+ it is routed to the engine manager. The engine manager may or may
+ not handle the message. }
+
+ FPlugins : TffThreadList;
+ {-The list of plugins that reference the command handler. }
+
+ FSkipInitial : Boolean; {!!.01}
+ {-Internal state that reflects whether the Engine Manager Wizard has
+ created this component as a proxy (true) or not}
+
+ FTransports : TffThreadList;
+ {-The list of transports that reference the command handler. }
+
+ protected
+
+ procedure bchFreeMsg(msg : PffDataMessage); virtual;
+ { When a transport passes off a request to the command handler, it
+ becomes the command handler's responsibility to free the message
+ data associated with the request. This method frees the TffDataMessage
+ structure as well as the message content contained by TffDataMessage.
+ Command handlers should call this method, or find some other way of
+ freeing the memory, once a request has been processed. }
+
+ function bchGetTransport(aInx : Integer) : TffBaseTransport; virtual;
+ { Retrieves a transport from the command handler's list.}
+
+ function bchGetTransportCount : Longint; virtual;
+ { Retrieves the number of transports owned by this command
+ handler.}
+
+ procedure bchSetEngineManager(aManager : TffBaseEngineManager); virtual;
+ {-Used to set the manager to which messages may be routed. }
+
+ procedure scSetState(const aState : TffState); override;
+ { This method is called when the command handler's state changes.
+ This implementation sets the state of the associated transports. }
+
+ property SkipInitial : Boolean {BEGIN !!.01}
+ read FSkipInitial
+ write FSkipInitial;
+ { This property is used by the engine manager wizard. It's purpose is
+ to keep the bchSetEngineManger routine from generating an access
+ violation when the expert creates a new engine manager } {END !!.01}
+ public
+
+ constructor Create(AOwner : TComponent); override;
+
+ destructor Destroy; override;
+
+ procedure FFAddDependent(ADependent : TffComponent); override; {!!.11}
+ procedure FFRemoveDependent(ADependent : TffComponent); override; {!!.11}
+
+ procedure Process(Msg : PffDataMessage); virtual;
+ { This method is called by the transport in order to process a message.
+ The default implementation forwards the message to the registered
+ plugin(s). If a plugin does not handle the message and an engine
+ manager has been specified, the message is forwarded to the
+ engine manager. If the message is not handled, a reply is sent to
+ the client stating the message is unrecognized. }
+
+ property TransportCount : Longint read bchGetTransportCount;
+ { The number of transports passing requests to this command handler.}
+
+ property Transports[aInx : Longint] : TffBaseTransport
+ read bchGetTransport;
+ { Use this property to access the transports connected to the command
+ handler. }
+ published
+
+ property EngineManager : TffBaseEngineManager
+ read FManager write bchSetEngineManager;
+
+ end;
+
+ {This is the base class for a plugin engine. All plugin engines inherit from
+ this class. A client application may interface with a plugin engine
+ via direct calls to the plugin engine or via calls to a remote plugin
+ engine.
+ To create a custom plugin engine, you must do the following:
+ 1. Create an abstract plugin engine that defines the interface of your
+ engine.
+ 2. From the abstract plugin engine, create a real plugin engine that
+ implements the engine interface.
+ 3. From the abstract plugin engine, create a remote plugin engine. Assign
+ it a property Transport of type TffBaseTransport. The remote plugin
+ engine is placed on the client application and transfers the commands to
+ a listener on the server. The commands are routed from the listener to
+ a plugin command handler to your real plugin engine.
+ 4. From the abstract TffBasePluginCommandHandler class, create a command
+ handler for the plugin. }
+ TffBasePluginEngine = class(TffStateComponent)
+ private
+
+ FPluginCmdHandlers : TffThreadList;
+ {-The list of plugin command handlers registered with this engine. }
+
+ protected
+
+ procedure scSetState(const aState : TffState); override;
+ {-Sets the state of the engine. This will also set the state of any
+ associated plugin command handlers. }
+
+ public
+
+ constructor Create(aOwner : TComponent); override;
+
+ destructor Destroy; override;
+
+ procedure FFAddDependent(ADependent : TffComponent); override; {!!.11}
+ procedure FFRemoveDependent(ADependent : TffComponent); override; {!!.11}
+
+ end;
+
+ {This is the base class for a plugin command handler. A plugin command
+ handler receives requests through a standard command handler. It passes
+ the requests on to a plugin engine.
+ As a plugin designer, you will need to create a class that inherits from
+ TffBasePluginCommandHandler. The class must recognize the messages to be
+ handled by your real plugin engine.
+ Note: Descendants of TffBaseCommandHandler must free the message data in
+ their overridden Process methods. However, this does not apply to
+ plugin command handlers. That is because they are typically passed a
+ request from TffBaseCommandHandler.Process and
+ TffBaseCommandHandler.Process handles the freeing of the message data
+ on behalf of the plugin command handlers. }
+ TffBasePluginCommandHandler = class(TffStateComponent)
+ protected
+
+ FCmdHandler : TffBaseCommandHandler;
+
+ FPluginEngine : TffBasePluginEngine;
+ {-The plugin engine receiving commands through this plugin. }
+
+ procedure pchSetCmdHandler(aCmdHandler : TffBaseCommandHandler); virtual;
+ {-The command handler forwarding commands to this plugin command
+ handler. }
+
+ procedure pchSetPluginEngine(anEngine : TffBasePluginEngine); virtual;
+ {-The plugin engine receiving commands through this plugin. This method
+ calls TffBasePluginEngine.AddCmdHandler. Because a plugin command
+ handler is associated with a specific plugin engine class, the plugin
+ designer must specify his own PluginEngine property. The custom
+ PluginEngine property should eventually call this SetPluginEngine
+ method. }
+
+ public
+
+ constructor Create(aOwner : TComponent); override;
+
+ destructor Destroy; override;
+
+ procedure FFNotificationEx(const AOp : Byte; AFrom : TffComponent; {!!.11}
+ const AData : TffWord32); override; {!!.11}
+
+ procedure Process(Msg : PffDataMessage; var handled : boolean); virtual; abstract;
+ { This method is called by a command handler when it has a message that
+ may be processed by a plugin. If the plugin handles the message,
+ set handled to True. }
+
+ published
+
+ property CommandHandler : TffBaseCommandHandler read FCmdHandler
+ write pchSetCmdHandler;
+ { The command handler passing requests to this plugin command handler. }
+
+ end;
+
+ {The engine manager is a type of data module that contains one or more engines
+ (e.g., TffBasePluginEngine or TffBaseServerEngine) and controls their
+ startup and shutdown. The manager can be controlled by the GUI of its
+ parent application or remotely via startup and shutdown commands received
+ through a command handler. }
+ TffBaseEngineManager = class(TDataModule)
+ private
+ FCmdHandlers : TffThreadList;
+ {-The command handlers registered with the engine manager. }
+
+ protected
+
+ procedure bemAddCmdHandler(aCmdHandler : TffBaseCommandHandler); virtual;
+ {-When a command handler references an engine manager, it registers
+ itself with the engine manager via this method. }
+
+ function bemGetCmdHandler(aInx : Longint) : TffBaseCommandHandler; virtual;
+ {-Returns a specified command handler registered with the engine
+ manager. }
+
+ function bemGetCmdHandlerCount : Longint;
+ {-Returns the number of command handlers routing requests to the engine
+ manager. }
+
+ procedure bemRemoveCmdHandler(aCmdHandler : TffBaseCommandHandler); virtual;
+ {-When a command handler no longer references an engine manager, it
+ unregisters itself with the engine manager via this method. }
+
+ public
+
+ constructor Create(aOwner : TComponent); override;
+
+ destructor Destroy; override;
+
+ procedure Process(msg : PffDataMessage; var handled : boolean); virtual; abstract;
+ { The command handler calls this method when it has a message that is
+ not handled by another engine. }
+
+ procedure Restart; virtual; abstract;
+ { Use this method to stop and restart all engines and their associated
+ components. }
+
+ procedure Shutdown; virtual; abstract;
+ { Use this method to stop all engines and their associated components.
+ Because the associated components (i.e., the manager's command handler)
+ are shutdown, the manager may not be instructed to restart. The manager
+ must be instructed to restart from the server GUI or the computer
+ must be restarted. }
+
+ procedure Startup; virtual; abstract;
+ { Use this method to start all engines and their associated components. }
+
+ procedure Stop; virtual; abstract;
+ { Use this method to stop all engines but leave their associated
+ components in an active state. This allows a Startup command to be
+ received from a remote client. }
+
+ public
+ property CmdHandler[aInx : Longint] : TffBaseCommandHandler
+ read bemGetCmdHandler;
+
+ property CmdHandlerCount : Longint read bemGetCmdHandlerCount;
+
+ end;
+
+ TffAddClientEvent = procedure(Listener : TffBaseTransport;
+ const userID : TffName;
+ const timeout : Longint;
+ const clientVersion : Longint;
+ var passwordHash : TffWord32;
+ var aClientID : TffClientID;
+ var errorCode : TffResult;
+ var isSecure : boolean;
+ var serverVersion : Longint) of object;
+ { This is the type of event raised when a listening transport requires a
+ new clientID in order to establish a new client connection.
+
+ Inputs:
+ UserID - Provided by the client application and assumed to be the
+ login ID of an existing user.
+ Timeout - The timeout value associated with client-level operations.
+ ClientVersion - The client's version number. The server should use
+ this to determine if the client is compatible.
+ Outputs:
+ Passwordhash - The user's encrypted password, supplied by the event
+ handler. In situations where a secure connection is to be established,
+ this hash can be used to encrypt the outgoing communications.
+ aClientID - The unique identifier assigned to the client. The client
+ must supply this ID with each subsequent request sent to th server.
+ If the value zero is returned for this parameter then it is assumed
+ a failure occurred.
+ errorCode - If an error occurred then the error code is returned in
+ this parameter.
+ isSecure - If True then the server requires this connection to be
+ encrypted. If False then no encryption is required.
+ serverVersion - The server's version number. Gives the client the
+ opportunity to determine if any compatibility issues are present. }
+
+ TffConnectionLostEvent = procedure(Sender : TffBaseTransport;
+ aClientID : TffClientID) of object;
+ { This is the type of event raised when a client connection is
+ unexpectedly terminated by the other end of the connection.
+ aClientID is the unique client identifier returned by
+ EstablishConnection. }
+
+ TffRemoveClientEvent = procedure(Listener : TffBaseTransport;
+ const aClientID : TffClientID;
+ var errorCode : TffResult) of object;
+ { This is the type of event raised when a listening transport needs to
+ disconnect a client. AClientID is the unique client identifier returned
+ by TffAddClientEvent when the connection was initially established.
+ errorCode will be zero if the client was successfully removed or a non-zero
+ value if an error occurred. }
+
+ TffTransportMode = (fftmSend, fftmListen);
+ { The valid modes for a transport. Values:
+
+ fftmSend - The transport sends messages.
+ fftmListen - The transport listens for messages. }
+
+ { This is the base transport class. It includes support for sending and
+ receiving requests. A transport that receives requests is referred to as
+ a listener. A transport that sends requests is to as a sender.
+
+ To use a transport, you must do the following:
+
+ 1. Instantiate the transport.
+ 2. Set the ServerName property.
+ 3. Set the State to ffesInitializing, ffesStarting, and then ffesStarted.
+ This normally occurs when a server engine starts up and sets the states
+ of the command handlers connected to the server. Each command handler
+ then passes on the state to the transports connected to the command
+ handler.
+ 4. Obtain a clientID by calling the EstablishConnection method.
+ 5. Submit requests to the transport using either the Post or Request
+ methods. You cannot call Post or Request unless you have a valid
+ clientID.
+ 6. When you have finished using the transport, call
+ TerminateConnection for each established connection.
+ 7. After terminating the connections, set the State to ffesShuttingDown
+ and then ffesInactive. }
+ TffBaseTransport = class(TffStateComponent)
+ protected {private}
+ { We need a scheme in the class to store potential properties, and
+ then apply them. To do this we add BeginUpdate, and EndUpdate methods
+ to the class. When BeginUpdate is called the _* fields will be set to
+ match their associated fields. While updating, property set methods
+ store their values in _* Fields. When EndUpdate is called the _*
+ values are copied into their associated fields. BeginUpdate, and
+ EndUpdate are reference counted. IOW if BeginUpdate is called twice,
+ then EndUpdate must also be called twice.}
+
+ FCmdHandler : TffBaseCommandHandler;
+ _FCmdHandler : TffBaseCommandHandler;
+ {-The command handler to which requests are routed. }
+
+ FEnabled : boolean;
+ _FEnabled : boolean;
+ {-If True then the transport can send/receive messages. Note that
+ it will send/receive only if enabled and state = ffesStarted. }
+
+ _FLogEnabled : Boolean;
+ {-If True then event logging is enabled. Defaults to False. }
+
+ FLogOptions : TffTransportLogOptions;
+ _FLogOptions : TffTransportLogOptions;
+ {-The type of logging to be performed. }
+
+ FMode : TffTransportMode;
+ _FMode : TffTransportMode;
+ {-The current mode of the transport. }
+
+ FMsgCount : Longint;
+ {-The number of messages processed by this transport. }
+
+ FOnAddClient : TffAddClientEvent;
+ {-Event handler to call when need to establish a new client. }
+
+ FOnConnectionLost : TffConnectionLostEvent;
+ {-Handler for OnConnectionLost. }
+
+ FOnRemoveClient : TffRemoveClientEvent;
+ {-Event handler to call when need to remove an existing client. }
+
+ _FOnStateChange : TNotifyEvent;
+ {-Event handler to call when the transport's state has changed. }
+
+ FRespondToBroadcasts : boolean;
+ _FRespondToBroadcasts : Boolean;
+ {-If True and FListen := True then this transport will respond to
+ broadcasts for active listeners. }
+
+ FServerName : TffNetAddress;
+ _FServerName : TffNetAddress;
+ {-The name of the server to which this transport connects. }
+
+ FServerNameRequired : boolean;
+ {-This variable influences the btCheckServerName method.
+ If set to True then a servername is required. There may be some
+ transports where a servername is not required (e.g., Single User
+ Protocol in TffLegacyTransport) in which case those transports should
+ set this variable to False. }
+
+ _FState : TffState;
+ {-The state of the transport. }
+
+ FUpdateCount : Integer; { Update ReferenceCount field }
+
+ protected
+
+ { Property access methods }
+
+ function btGetCmdHandler : TffBaseCommandHandler; virtual;
+ procedure btSetCmdHandler(aCmdHandler : TffBaseCommandHandler); virtual;
+ {-The command handler forwarding commands to this plugin command
+ handler. }
+
+ function btGetEnabled : boolean; virtual;
+ procedure btSetEnabled(const aEnabled : boolean); virtual;
+ {-Whether or not the transport is enabled. }
+
+ function btGetLogOptions : TffTransportLogOptions; virtual;
+ procedure btSetLogOptions(const anOptions : TffTransportLogOptions); virtual;
+ {-The type of information to be logged. }
+
+ function btGetMode : TffTransportMode; virtual;
+ procedure btSetMode(const aMode : TffTransportMode); virtual;
+ {-Whether or not the transport is to listen for requests. For a Client
+ set Mode to fftmSend. For a Server, set Mode to fftmListen. }
+
+ procedure btSetOnStateChange(const aHandler : TNotifyEvent); virtual;
+ {-Event raised when transport's state changes. }
+
+ function btGetRespondToBroadcasts : Boolean; virtual;
+ procedure btSetRespondToBroadcasts(const aRespond : Boolean); virtual;
+ {-Whether or not a transport in server mode (i.e., Listen = True) is
+ to respond to broadcast messages. }
+
+ function btGetServerName : string; virtual; {!!.10}
+ procedure btSetServername(const aServername : string); virtual; {!!.10}
+ {-For a transport in Listen mode (i.e., Server), the server's name. For
+ a transport in Send mode (i.e., Client), the name of the server to
+ which the client is to send information. The implementation for this
+ class does not perform any validation. Transport subclasses should
+ perform their own validation. }
+
+ { Other protected methods }
+
+ procedure btCheckListener;
+ { When setting certain properties or calling certain methods, this
+ method is called to ensure the transport is in listening mode. If the
+ transport is not listening then this method raises exception
+ ffsce_MustBeListening. }
+
+ procedure btCheckSender;
+ { When setting certain properties or calling certain methods, this
+ method is called to ensure the transport is in sending mode. If the
+ transport is not a sender then this method raises exception
+ ffsce_MustBeSender. }
+
+ procedure btCheckServerName;
+ { Verifies the servername has been specified. }
+
+ function btGetConnectionID(const anIndex : Longint) : TffClientID; virtual; abstract;
+ { Used to obtain the IDs of the protocol's connections. Handy for when
+ a server wants to send messages to one or more client connections. }
+
+ procedure btInternalReply(msgID : Longint;
+ errorCode : TffResult;
+ replyData : pointer;
+ replyDataLen : Longint); virtual;
+ { This method is called from TffBaseTransport.Reply. It must send the
+ reply to the client. The base implementation verifies the transport
+ is started and is listening. }
+
+ procedure btStoreSelfInThreadvar; virtual;
+ {-This method stores Self in ffitvTransport. This is isolated into
+ its own function because an inherited class may need to Reply to
+ a message (e.g., add client) before calling the inherited Process
+ method where the setting of ffitvTransport is normally done. }
+
+ procedure btBeginUpdatePrim; virtual;
+ procedure btEndUpdatePrim; virtual;
+
+ procedure lcSetLogEnabled(const aEnabled : boolean); override;
+
+ property UpdateCount : Integer
+ read FUpdateCount;
+ {-This represents the current updating state. If updating is taking
+ place this value will be > 0 }
+
+ public
+
+ constructor Create(aOwner : TComponent); override;
+
+ destructor Destroy; override;
+
+ procedure BeginUpdate;
+ { redirect property set routines to _* fields }
+
+ procedure CancelUpdate;
+ { cancel the property changes. }
+
+ procedure EndUpdate;
+ { Apply the new properties. }
+
+ procedure AutoConnectionLost(Sender : TffBaseTransport;
+ aClientID : TffClientID);
+
+ function ConnectionCount : Longint; virtual; abstract;
+ { Returns the number of established connections. For a sender (i.e.,
+ client), this will be the number of connections to the remote server.
+ For a listener (i.e., server), this will be the number of
+ connections establshed by remote clients. }
+
+ class function CurrentTransport : TffBaseTransport;
+ { Returns the transport used by the current thread. In other words,
+ the transport pointed to by ffitvTransportID. }
+
+ function EstablishConnection(const aUserName : TffName;
+ aPasswordHash : integer;
+ timeOut : Longint;
+ var aClientID : TffClientID ) : TffResult; virtual; abstract;
+ { Use this method to establish a connection with the server. If the
+ return code is DBIERR_NONE then aClientID will contain the clientID
+ supplied by the server. This clientID must be used in all subsequent
+ requests to the server. }
+
+ function GetName : string; virtual; abstract;
+ { Retrieves the transport's name. Must be specified for each subclass.
+ Note that this is not a class function because we want the legacy
+ transport to be able to return a name based upon the selected protocol.
+ }
+
+ procedure GetServerNames(aList : TStrings; const timeout : Longint); virtual; abstract;
+ { Returns the list of servers available via this transport. Timeout
+ is the number of milliseconds in which all responses must be
+ received. }
+
+ function IsConnected : boolean; virtual; abstract;
+ { This method returns True if the transport is connected to a server. }
+
+ procedure FFNotificationEx(const AOp : Byte; AFrom : TffComponent; {!!.11}
+ const AData : TffWord32); override; {!!.11}
+
+ procedure Post(transportID : Longint;
+ clientID : TffClientID;
+ msgID : Longint;
+ requestData : pointer;
+ requestDataLen : Longint;
+ timeout : Longint;
+ replyMode : TffReplyModeType); virtual; abstract;
+ { Call this method in order to submit a request to the transport.
+ The request will be routed to the remote transport. This method
+ does not expect a reply and will return as soon as the request is
+ handed off. This method may be called when in Send or Listen mode.
+
+ Parameters are as follows:
+
+ @param transportID - For use by future protocols.
+ @param clientID - The ID of the client submitting the request. This
+ must be the clientID originally supplied by the server or it may be
+ zero for unsecured calls (e.g., initially asking for a connection
+ to the server).
+ @param msgID - The type of message being sent.
+ @param requestData - Pointer to a data buffer containing the message
+ data.
+ requestDataLen - The length of requestData.
+ timeout - The number of milliseconds in which the operation must
+ complete.
+ replyMode - Indicates whether or not the request should wait for the
+ request to be sent to the server.
+ }
+
+ procedure Process(Msg : PffDataMessage); virtual;
+ { When in listening mode, this method is called when a message is
+ to be processed by the transport. }
+
+ class procedure Reply(msgID : Longint;
+ errorCode : TffResult;
+ replyData : pointer;
+ replyDataLen : Longint); virtual;
+ { When acting as a listener, this method is called to send a reply back
+ to a client. The base implementation stores a pointer to Self in
+ the threadvar fftviTransportID. This allows the command handler to
+ call TffBaseTransport.Reply(...) without having to know which
+ transport told it to process the command.
+
+ Implementation:
+ fftviTransport.InternalReply(...)
+
+ }
+
+ procedure Request(transportID : Longint;
+ clientID : TffClientID;
+ msgID : Longint;
+ timeout : Longint;
+ requestData : pointer;
+ requestDataLen : Longint;
+ replyCallback : TffReplyCallback;
+ replyCookie : Longint); virtual; abstract;
+ { When the transport is in Send mode, call this method in order to
+ submit a request to the transport.
+
+ Parameters are as follows:
+
+ @param transportID - For use by future transports.
+ @param clientID - The ID of the client submitting the request. This
+ must be the clientID originally supplied by the server or it may be
+ zero for unsecured calls (e.g., initially asking for a connection
+ to the server).
+ @param msgID - The type of message being sent.
+ @param timeout - The number of milliseconds in which a reply must be
+ received from the server.
+ @param requestData - Pointer to a data buffer containing the message
+ data.
+ @param requestDataLen - The length of requestData.
+ @param replyCallback - The procedure to be called when the reply
+ has been received from the server.
+ @param replyCookie - Whatever the calling object wants it to be. This
+ parameter is supplied to the replyCallback.
+ }
+
+ procedure ResetMsgCount; virtual;
+ { Resets the MsgCount property to zero. }
+
+ function Sleep(const timeOut : Longint) : boolean; virtual;
+ { Use this function to have the client disconnect from the server but
+ leave the server-side resources intact so that the client may
+ reconnect at a later time. Returns True if the Sleep was successful or
+ False if the Sleep failed or is not supported.
+ Note that any activity on the client side will cause the connection to
+ be re-opened. }
+
+ function Supported : boolean; virtual;
+ { Returns True if the transport is supported on this workstation
+ otherwise returns False. }
+
+ procedure TerminateConnection(const aClientID : TffClientID;
+ const timeout : Longint); virtual; abstract;
+ { Use this method to terminate a connection with the server. aClientID
+ is the clientID originally returned in the call to
+ EstablishConnection. }
+
+ procedure Work; virtual; abstract;
+ { Based upon the transport's mode, this method tells the transport to
+ perform some work:
+
+ 1. When in sending mode, start sending requests and processing replies.
+ 2. When in listening mode, start listening for requests and passing
+ requests off to the command handler.
+ }
+
+ property ConnectionIDs[const anIndex : Longint] : TffClientID
+ read btGetConnectionID;
+ { Use this to access the client IDs of a listening transport. }
+
+ published
+
+ property CommandHandler : TffBaseCommandHandler
+ read btGetCmdHandler
+ write btSetCmdHandler;
+ { The command handler to which requests are routed. }
+
+ property Enabled : boolean
+ read btGetEnabled
+ write btSetEnabled
+ default False;
+ { Use this property to control whether or not the transport can send
+ or receive messages as per its Mode property. If this property is
+ set to True, the State property must still be set to ffesStarted
+ before the transport will actually send or receive messages. }
+
+ property EventLogOptions : TffTransportLogOptions
+ read btGetLogOptions
+ write btSetLogOptions
+ default []; {!!.01}
+ { The type of logging to be performed. Applicable only when
+ EventLogEnabled = True and EventLog is assigned. }
+
+ property Mode : TffTransportMode
+ read btGetMode
+ write btSetMode
+ default fftmSend;
+ { Use this property to determine whether the transport should be used for
+ sending requests or listening for requests. }
+
+ property MsgCount : Longint
+ read FMsgCount;
+ { The number of messages processed by this transport. }
+
+ property OnAddClient : TffAddClientEvent
+ read FOnAddClient
+ write FOnAddClient;
+ { The handler for the event raised when a listening transport must
+ establish a new connection. }
+
+ property OnConnectionLost : TffConnectionLostEvent
+ read FOnConnectionLost
+ write FOnConnectionLost;
+ { This event is raised when the other end of the connection unexpectedly
+ hangs up on the transport. }
+
+ property OnRemoveClient : TffRemoveClientEvent
+ read FOnRemoveClient
+ write FOnRemoveClient;
+ { The handler for the event raised when a listening transport must
+ disconnect an existing client. }
+
+ property OnStateChange : TNotifyEvent
+ read scOnStateChange
+ write btSetOnStateChange;
+ { Raised when the transport's state changes. }
+
+ property RespondToBroadcasts : boolean
+ read btGetRespondToBroadcasts
+ write btSetRespondToBroadcasts
+ default False;
+ { Use this property to indicate wheher or not a listener should respond
+ to a broadcast for active listeners. }
+
+ property ServerName : string {!!.10}
+ read btGetServerName
+ write btSetServerName;
+ { The name and address of the server to be accessed by this transport. }
+
+ end;
+
+ { This class provides support for protocols requiring a thread pool. }
+ TffThreadedTransport = class(TffBaseTransport)
+ protected {private}
+
+ FThreadPool : TffThreadPool;
+ {-The thread pool providing threads to this transport. }
+
+ FUnsentRequestQueue : TffThreadQueue;
+ {-When in Send mode and a client submits a request, the transport creates
+ a TffRequest object and places it in this queue.}
+
+ FWaitingForReplyList : TffThreadList;
+ {-When a request has been submitted to the server, the TffRequest
+ object is appended to this list. }
+
+ protected
+
+ procedure SetThreadPool(aPool : TffThreadPool); virtual;
+ {-Sets the thread pool to be used by this transport. }
+
+ procedure tpInternalRequest(aRequest : TffRequest;
+ timeout : Longint;
+ aCookie : HWND); virtual;
+ {-Internal method for sending a request. aRequest is the request to
+ send. timeout is the number of milliseconds the transport should wait
+ for a reply to the request. aCookie can be used as the transport sees
+ fit. }
+
+ procedure tpLogReq(aRequest : TffRequest;
+ const prefix : string); virtual;
+ { Write a request to the event log. }
+
+ procedure tpLogReq2(const aPrefix : string;
+ const aRequestID : Longint;
+ const aClientID : TffClientID;
+ const aMsgID : Longint;
+ const aData : pointer;
+ const aDataLen : Longint;
+ const aTimeout : Longint);
+ { Write a reply to the event log. Used by a transport in Listen mode. }
+
+ procedure tpLogReqMisc(const aMsg : string); virtual;
+ { Write a request-related string to the event log. }
+
+ procedure tpLogReply(aRequest : TffRequest); virtual;
+ { Write a reply to the event log. }
+
+ procedure tpLogReply2(const aRequestID : Longint;
+ const aClientID : TffClientID;
+ const aMsgID : Longint;
+ const aDataLen : Longint;
+ const anError : TffResult);
+ { Write a reply to the event log. Used by a transport in Listen mode. }
+ public
+
+ constructor Create(aOwner : TComponent); override;
+
+ destructor Destroy; override;
+
+ procedure FFNotificationEx(const AOp : Byte; AFrom : TffComponent; {!!.11}
+ const AData : TffWord32); override; {!!.11}
+ {-Called when the thread pool we're referencing has been operated upon.
+ We need to catch the case where the thread pool has been removed
+ from the form. }
+
+ procedure Post(transportID : Longint;
+ clientID : TffClientID;
+ msgID : Longint;
+ requestData : pointer;
+ requestDataLen : Longint;
+ timeout : Longint;
+ replyMode : TffReplyModeType); override;
+ { This method is called when a request is to be sent but a reply is
+ not needed. This implementation does the following:
+
+ 1. Creates a TffRequest instance.
+ 2. Assigns the request data to the TffRequest instance.
+ 3. Adds the TffRequest instance to the Unsent Request Queue.
+ 4. Exits from this method since a reply is not needed. }
+
+ procedure Request(transportID : Longint;
+ clientID : TffClientID;
+ msgID : Longint;
+ timeout : Longint;
+ requestData : pointer;
+ requestDataLen : Longint;
+ replyCallback : TffReplyCallback;
+ replyCookie : Longint); override;
+ { This method is called when a proxy client submits a request to the
+ transport. This implementation does the following:
+
+ 1. Creates a TffRequest instance.
+ 2. Assigns the request data to the TffRequest instance.
+ 3. Adds the TffRequest instance to the Unsent Request Queue.
+ 4. Calls TffRequest.WaitForReply. At this point, the calling
+ thread is blocked until a reply is received or a timeout
+ occurs.
+ 5. When TffRequest.WaitForReply returns, the reply is on the TffRequest
+ object. This method calls replyCallback, passing the message ID,
+ error code, reply data, length, and cookie.
+ 6. The TffRequest instance is freed. Could also be recycled to
+ improve performance. In either case, the TffRequest instance
+ frees the memory occupied by the reply.
+ }
+
+ published
+
+ property ThreadPool : TffThreadPool read FThreadPool write SetThreadPool;
+ { The thread pool providing worker threads for this protocol. }
+
+ end;
+
+const
+ ffc_Data = 'Data';
+ ffc_ReqAborted = '*** Req %d aborted, Clnt %d, Err %d, Tmout %d';
+ ffc_ReqLogString = '%s: %d, Clnt %d, Msg %d, Len %d, Tmout %d';
+ ffc_ReplyLogString = 'Reply: %d, Clnt %d, Msg %d, Len %d, Err %d';
+ ffc_SendErr = 'Snd Err %d: %s, Req %d, Clnt %d, Msg %d, Len %d, Tmout %d';
+
+ ffcl_RequestLatencyAdjustment : Longint = 500;
+ {-The number of additional milliseconds to wait for a reply. }
+
+implementation
+
+{Begin !!.03}
+uses
+ ffSrBase, {!!.13}
+ SysUtils;
+{End !!.03}
+
+{$I ffconst.inc}
+{$I ffllscst.inc}
+
+{ The following thread variable is an optimization for the TffBaseTransport.
+ A rule is that the thread that processes a request must be the
+ thread to send a reply back to the client. Since the reply is initiated
+ outside the transport, we don't want to pass a lot of information
+ about the connection.
+
+ Our solution is to store a pointer to the transport issuing the request
+ in a threadvar. This allows a command handler to call TffBaseTransport.Reply
+ without having to know the originating Transport. }
+threadvar
+ ffitvTransportID : Longint; { Pointer to the transport that originally
+ passed the request to the command handler. }
+
+
+{===TffBaseCommandHandler============================================}
+constructor TffBaseCommandHandler.Create(aOwner : TComponent);
+begin
+ inherited Create(aOwner);
+ FManager := nil;
+ FPlugins := TffThreadList.Create;
+ FTransports := TffThreadList.Create;
+end;
+{--------}
+destructor TffBaseCommandHandler.Destroy;
+begin
+
+ { Make sure we have a clean shutdown. }
+ if scState <> ffesInactive then
+ scSetState(ffesInactive);
+
+ FFNotifyDependents(ffn_Destroy); {!!.11}
+
+ FPlugins.Free; {!!.11}
+ FTransports.Free; {!!.11}
+
+ if assigned(FManager) and (not FSkipInitial) then {!!.01}
+ FManager.bemRemoveCmdHandler(Self);
+
+ inherited Destroy;
+end;
+{--------}
+procedure TffBaseCommandHandler.bchFreeMsg(msg : PffDataMessage);
+begin
+ if Msg^.dmDataLen > 0 then
+ FFFreeMem(Msg^.dmData, Msg^.dmDataLen);
+ FFFreeMem(Msg, SizeOf(TffDataMessage));
+end;
+{--------}
+function TffBaseCommandHandler.bchGetTransportCount: Integer;
+begin
+ Result := FTransports.Count;
+end;
+{--------}
+function TffBaseCommandHandler.bchGetTransport(aInx: Integer): TffBaseTransport;
+begin
+ Result := TffBaseTransport(TffIntListItem(FTransports[aInx]).KeyAsInt);
+end;
+{--------}
+procedure TffBaseCommandHandler.bchSetEngineManager(aManager : TffBaseEngineManager);
+ {-Used to set the manager to which messages may be routed. }
+begin
+ if FSkipInitial then begin {BEGIN !!.01}
+ FManager := aManager;
+ Exit;
+ end; {END !!.01}
+
+ if assigned(FManager) then FManager.bemRemoveCmdHandler(Self);
+ if assigned(aManager) then aManager.bemAddCmdHandler(Self);
+end;
+{Begin !!.11}
+{--------}
+procedure TffBaseCommandHandler.FFAddDependent(ADependent : TffComponent);
+var
+ aListItem : TffIntListItem;
+begin
+ inherited;
+
+ if ADependent is TffBaseTransport then begin
+ aListItem := TffIntListItem.Create(Longint(ADependent));
+ with FTransports.BeginWrite do
+ try
+ Insert(aListItem);
+ finally
+ EndWrite;
+ end;
+ end
+ else if ADependent is TffBasePluginCommandHandler then begin
+ aListItem := TffIntListItem.Create(Longint(ADependent));
+ with FPlugins.BeginWrite do
+ try
+ Insert(aListItem);
+ finally
+ EndWrite;
+ end;
+ end;
+end;
+{--------}
+procedure TffBaseCommandHandler.FFRemoveDependent(ADependent : TffComponent);
+begin
+ inherited;
+ if ADependent is TffBaseTransport then
+ with FTransports.BeginWrite do
+ try
+ Delete(Longint(ADependent));
+ finally
+ EndWrite;
+ end
+ else if ADependent is TffBasePluginCommandHandler then
+ with FPlugins.BeginWrite do
+ try
+ Delete(Longint(ADependent));
+ finally
+ EndWrite;
+ end;
+end;
+{End !!.11}
+{--------}
+procedure TffBaseCommandHandler.Process(Msg : PffDataMessage);
+var
+ aPlugin : TffBasePluginCommandHandler;
+ Handled : boolean;
+ anIndex : Longint;
+begin
+
+ Handled := False;
+ { See if a plugin recognizes the message. }
+ if assigned(FPlugins) then
+ with FPlugins.BeginRead do
+ try
+ for anIndex := 0 to pred(Count) do begin
+ aPlugin := TffBasePluginCommandHandler(TffIntListItem(Items[anIndex]).KeyAsInt);
+ aPlugin.Process(Msg, Handled);
+ if Handled then break;
+ end;
+ finally
+ EndRead;
+ end;
+
+ { If no plugin recognizes the message and we have an engine manager
+ then see if the engine manager will handle the message. }
+ if not Handled and assigned(FManager) then
+ FManager.Process(Msg, Handled);
+
+ { If the message has not been handled by this point, tell the client this
+ is an unrecognized message. Note that we are calling a TffBaseTransport
+ class function which gets the reply to the correct transport. }
+{Begin !!.13}
+ if not Handled then begin
+ lcLog(Format(ffStrResServer[ffErrUnknownMsg], [Msg.dmMsg]));
+ TffBaseTransport.Reply(Msg.dmMsg, ffErrUnknownMsg, nil, 0);
+ end;
+{End !!.13}
+
+end;
+{--------}
+procedure TffBaseCommandHandler.scSetState(const aState : TffState);
+var
+ aTransport : TffBaseTransport;
+ anIndex : Longint;
+ NextState : TffState;
+ OldState : TffState;
+begin
+
+ if (aState = scState) or {!!.01}
+ (aState in [ffesStopping, ffesStopped]) then exit; {!!.01}
+
+ OldState := scState;
+ aTransport := nil;
+
+ try
+ if assigned(FTransports) then
+ with FTransports.BeginRead do
+ try
+ while scState <> aState do begin
+ { Based upon our current state & the target state, get the next state. }
+ NextState := ffStateDiagram[scState, aState];
+
+ { Move all transports to the specified state. }
+ try
+ for anIndex := pred(Count) downto 0 do begin
+ aTransport := TffBaseTransport(TffIntListItem(Items[anIndex]).KeyAsInt);
+ if aTransport.Enabled then
+ aTransport.scSetState(NextState);
+ end;
+ except
+ on E:Exception do begin
+ { If a transport raises an exception, disable the transport.
+ The server must be restarted before we try this transport
+ again. }
+ lcLog(format('Transport state failure: %s',
+ [aTransport.GetName, E.message]));
+ try
+ aTransport.State := ffesFailed;
+ aTransport.Enabled := False;
+ except
+ { Eat any exception raised by changing the state. }
+ end;
+ end;
+ end;
+
+ scState := NextState;
+ { Call the appropriate internal method for this state. }
+ case NextState of
+ ffesInactive :
+ scShutdown;
+ ffesInitializing :
+ scInitialize;
+ ffesStarting :
+ scStartup;
+ ffesShuttingDown :
+ scPrepareForShutdown;
+ end; { case }
+ if assigned(scOnStateChange) then
+ scOnStateChange(Self);
+ end; { while }
+ finally
+ EndRead;
+ end;
+ except
+ scState := OldState;
+ raise;
+ end;
+
+end;
+{====================================================================}
+
+{===TffBasePluginCommandHandler======================================}
+constructor TffBasePluginCommandHandler.Create(aOwner : TComponent);
+begin
+ inherited Create(aOwner);
+ FCmdHandler := nil;
+ FPluginEngine := nil;
+end;
+{--------}
+destructor TffBasePluginCommandHandler.Destroy;
+begin
+ if assigned(FCmdHandler) then
+ FCmdHandler.FFRemoveDependent(Self); {!!.11}
+
+ if assigned(FPluginEngine) then
+ FPluginEngine.FFRemoveDependent(Self); {!!.11}
+
+ inherited Destroy;
+end;
+{Begin !!.11}
+{--------}
+procedure TffBasePluginCommandHandler.FFNotificationEx
+ (const AOp : Byte; AFrom : TffComponent;
+ const AData : TffWord32);
+begin
+ inherited;
+ if AOp in [ffn_Destroy, ffn_Remove] then begin
+ if AFrom = FCmdHandler then begin
+ FCmdHandler.FFRemoveDependent(Self);
+ FCmdHandler := nil;
+ end
+ else if AFrom = FPluginEngine then begin
+ FPluginEngine.FFRemoveDependent(Self);
+ FPluginEngine := nil;
+ end;
+ end;
+end;
+{--------}
+procedure TffBasePluginCommandHandler.pchSetCmdHandler(aCmdHandler : TffBaseCommandHandler);
+ {-The command handler forwarding commands to this plugin command
+ handler. }
+begin
+ if aCmdHandler <> FCmdHandler then begin
+ if assigned(FCmdHandler) then
+ FCmdHandler.FFRemoveDependent(Self);
+
+ if assigned(aCmdHandler) then
+ aCmdHandler.FFAddDependent(Self);
+
+ FCmdHandler := aCmdHandler;
+ end;
+
+ {Note: It is entirely possible for the plugin command handler to be active
+ and have its associated command handler set to nil. In such a case, the
+ plugin command handler never receives PrepareForShutdown and Shutdown
+ commands. }
+end;
+{--------}
+procedure TffBasePluginCommandHandler.pchSetPluginEngine(anEngine : TffBasePluginEngine);
+begin
+ if anEngine <> FPluginEngine then begin
+ if assigned(FPluginEngine) then
+ FPluginEngine.FFRemoveDependent(Self);
+
+ if assigned(anEngine) then
+ anEngine.FFAddDependent(Self);
+
+ FPluginEngine := anEngine;
+ end;
+end;
+{End !!.11}
+{====================================================================}
+
+{===TffBasePluginEngine==============================================}
+constructor TffBasePluginEngine.Create(aOwner : TComponent);
+begin
+ inherited Create(aOwner);
+ FPluginCmdHandlers := TffThreadList.Create;
+end;
+{--------}
+destructor TffBasePluginEngine.Destroy;
+{Begin !!.11}
+begin
+ scSetState(ffesInactive);
+ FFNotifyDependents(ffn_Destroy);
+ FPluginCmdHandlers.Free;
+ inherited Destroy;
+end;
+{--------}
+procedure TffBasePluginEngine.FFAddDependent(ADependent : TffComponent);
+var
+ aListItem : TffIntListItem;
+begin
+ inherited;
+
+ if ADependent is TffBasePluginCommandHandler then begin
+ aListItem := TffIntListItem.Create(Longint(ADependent));
+ with FPluginCmdHandlers.BeginWrite do
+ try
+ Insert(aListItem);
+ finally
+ EndWrite;
+ end;
+ end;
+end;
+{--------}
+procedure TffBasePluginEngine.FFRemoveDependent(ADependent : TffComponent);
+begin
+ inherited;
+ if ADependent is TffBasePluginCommandHandler then
+ with FPluginCmdHandlers.BeginWrite do
+ try
+ Delete(Longint(ADependent));
+ finally
+ EndWrite;
+ end;
+end;
+{End !!.11}
+{--------}
+procedure TffBasePluginEngine.scSetState(const aState : TffState);
+ {-Sets the state of the engine. This will also set the state of any
+ associated plugin command handlers. }
+var
+ aCmdHandler : TffBasePluginCommandHandler;
+ anIndex : Longint;
+ NextState : TffState;
+ OldState : TffState;
+begin
+ { If we are at the specified state then exit without doing anything. }
+ if aState = scState then exit;
+
+ OldState := scState;
+
+ try
+ if assigned(FPluginCmdHandlers) then
+ with FPluginCmdHandlers.BeginRead do
+ try
+ while scState <> aState do begin
+ { Based upon our current state & the target state, get the next state. }
+ NextState := ffStateDiagram[scState, aState];
+
+ { Move all command handlers to that state. }
+ for anIndex := 0 to pred(FPluginCmdHandlers.Count) do begin
+ aCmdHandler := TffBasePluginCommandHandler(TffIntListItem(Items[anIndex]).KeyAsInt);
+ if not (aState in [ffesStopping, ffesStopped,
+ ffesUnsupported, ffesFailed]) then
+ aCmdHandler.scSetState(aState);
+ end;
+
+ { Call the appropriate method for the new state. }
+ case NextState of
+ ffesInactive, ffesStopped :
+ scShutdown;
+ ffesInitializing :
+ scInitialize;
+ ffesStarting :
+ scStartup;
+ ffesStopping, ffesShuttingDown :
+ scPrepareForShutdown;
+ end; { case }
+
+ { Update our state. }
+ scState := NextState;
+ if assigned(scOnStateChange) then
+ scOnStateChange(Self);
+ end;
+ finally
+ EndRead;
+ end;
+ except
+ { Some kind of failure occurred. We need to rollback the engine to its
+ original state. We will leave the command handlers as is. }
+ scState := OldState;
+ raise;
+ end;
+end;
+{====================================================================}
+
+{===TffBaseEngineManager=============================================}
+constructor TffBaseEngineManager.Create(aOwner : TComponent);
+begin
+ FCmdHandlers := TffThreadList.Create;
+ inherited Create(aOwner);
+end;
+{--------}
+destructor TffBaseEngineManager.Destroy;
+var
+ aCmdHandler : TffBaseCommandHandler;
+ anIndex : Longint;
+begin
+
+ { Note: The real engine manager must do a graceful shutdown of the server
+ engine. }
+ if assigned(FCmdHandlers) then
+ with FCmdHandlers.BeginWrite do
+ try
+ { Make sure none of the plugin command handlers reference this engine. }
+ for anIndex := pred(Count) downto 0 do begin
+ aCmdHandler := TffBaseCommandHandler(TffIntListItem(Items[anIndex]).KeyAsInt);
+ aCmdHandler.bchSetEngineManager(nil);
+ end;
+ finally
+ EndWrite;
+ FCmdHandlers.Free;
+ end;
+
+ inherited Destroy;
+end;
+{--------}
+procedure TffBaseEngineManager.bemAddCmdHandler(aCmdHandler : TffBaseCommandHandler);
+var
+ aListItem : TffIntListItem;
+begin
+ aListItem := TffIntListItem.Create(Longint(aCmdHandler));
+ with FCmdHandlers.BeginWrite do
+ try
+ Insert(aListItem);
+ aCmdHandler.FManager := Self;
+ finally
+ EndWrite;
+ end;
+end;
+{--------}
+function TffBaseEngineManager.bemGetCmdHandler(aInx : Longint) : TffBaseCommandHandler;
+begin
+ with FCmdHandlers.BeginRead do
+ try
+ Result := TffBaseCommandHandler(TffIntListItem(Items[aInx]).KeyAsInt);
+ finally
+ EndRead;
+ end;
+end;
+{--------}
+function TffBaseEngineManager.bemGetCmdHandlerCount : Longint;
+begin
+ Result := FCmdHandlers.Count;
+end;
+{--------}
+procedure TffBaseEngineManager.bemRemoveCmdHandler(aCmdHandler : TffBaseCommandHandler);
+begin
+ aCmdHandler.FManager := nil;
+ with FCmdHandlers.BeginWrite do
+ try
+ Delete(Longint(aCmdHandler));
+ finally
+ EndWrite;
+ end;
+end;
+{====================================================================}
+
+
+{===TffBaseTransport=================================================}
+
+procedure TffBaseTransport.AutoConnectionLost(Sender : TffBaseTransport;
+ aClientID : TffClientID);
+begin
+ Sender.FFNotifyDependentsEx(ffn_ConnectionLost, aClientID);
+end;
+{--------}
+constructor TffBaseTransport.Create(aOwner : TComponent);
+begin
+ inherited Create(aOwner);
+ FCmdHandler := nil;
+ FEnabled := False;
+ FMode := fftmSend;
+ FRespondToBroadcasts := False;
+ FServerName := '';
+ FServerNameRequired := True;
+ scState := ffesInactive;
+
+ OnConnectionLost := AutoConnectionLost;
+end;
+{--------}
+destructor TffBaseTransport.Destroy;
+begin
+ FFNotifyDependents(ffn_Destroy);
+ if assigned(FCmdHandler) then
+ FCmdHandler.FFRemoveDependent(Self); {!!.11}
+ inherited Destroy;
+end;
+{--------}
+procedure TffBaseTransport.BeginUpdate;
+begin
+ if FUpdateCount = 0 then begin
+ { Give the descendent classes a chance to set their stored properties }
+ btBeginUpdatePrim;
+
+ { Set the _* fields to match their counterparts }
+ _FCmdHandler := FCmdHandler;
+ _FEnabled := FEnabled;
+ _FLogEnabled := FLogEnabled;
+ _FLogOptions := FLogOptions;
+ _FMode := FMode;
+ _FOnStateChange := scOnStateChange;
+ _FRespondToBroadcasts := FRespondToBroadcasts;
+ _FServerName := FServerName;
+ _FState := scState;
+ end;
+ Inc(FUpdateCount);
+end;
+{--------}
+procedure TffBaseTransport.btBeginUpdatePrim;
+begin
+ { do nothing }
+end;
+{--------}
+procedure TffBaseTransport.CancelUpdate;
+begin
+ FUpdateCount := 0;
+end;
+{--------}
+procedure TffBaseTransport.EndUpdate;
+begin
+ if FUpdateCount <> 0 then begin
+ Dec(FUpdateCount);
+ if FUpdateCount = 0 then begin
+
+ { Let the descendent classes do their work }
+ btEndUpdatePrim;
+
+ { Update the fields with the new values in their _* counterparts }
+ { We do not set the private field directly, since some processing may
+ need to be done by a properties write method. }
+ CommandHandler := _FCmdHandler;
+ { Make sure State is set prior to Enabled property and other
+ state-dependent properties. }
+ State := _FState;
+ Enabled := _FEnabled;
+ EventLogEnabled := _FLogEnabled;
+ EventLogOptions := _FLogOptions;
+ Mode := _FMode;
+ OnStateChange := _FOnStateChange;
+ RespondToBroadcasts := _FRespondToBroadcasts;
+ ServerName := _FServerName;
+
+ end;
+ end;
+end;
+{--------}
+procedure TffBaseTransport.btEndUpdatePrim;
+begin
+ { do nothing }
+end;
+{--------}
+function TffBaseTransport.btGetCmdHandler : TffBaseCommandHandler;
+begin
+ Result := FCmdHandler;
+end;
+{--------}
+function TffBaseTransport.btGetEnabled : boolean;
+begin
+ Result := FEnabled;
+end;
+{--------}
+function TffBaseTransport.btGetLogOptions : TffTransportLogOptions;
+begin
+ Result := FLogOptions;
+end;
+{--------}
+function TffBaseTransport.btGetMode : TffTransportMode;
+begin
+ Result := FMode;
+end;
+{--------}
+function TffBaseTransport.btGetRespondToBroadcasts : Boolean;
+begin
+ Result := FRespondToBroadcasts;
+end;
+{--------}
+function TffBaseTransport.btGetServerName : string; {!!.10}
+begin
+ Result := FServerName;
+end;
+{--------}
+procedure TffBaseTransport.btSetCmdHandler(aCmdHandler : TffBaseCommandHandler);
+begin
+ if (FUpdateCount > 0) then
+ _FCmdHandler := aCmdHandler
+ else begin
+ {Check to make sure the new property is different.}
+ if FCmdHandler = aCmdHandler then Exit;
+
+ if assigned(FCmdHandler) then
+ FCmdHandler.FFRemoveDependent(Self); {!!.11}
+
+ if assigned(aCmdHandler) then
+ aCmdHandler.FFAddDependent(Self); {!!.11}
+
+ FCmdHandler := aCmdHandler; {!!.11}
+ end;
+end;
+{--------}
+procedure TffBaseTransport.btSetEnabled(const aEnabled : Boolean);
+begin
+ if (FUpdateCount > 0) then
+ _FEnabled := aEnabled
+ else begin
+ {Check to make sure the new property is different.}
+ if FEnabled = aEnabled then Exit;
+ { If the transport is being disabled but the State indicates some
+ amount of activity then make sure the transport is inactive. }
+ if (not aEnabled) and (scState <> ffesInactive) then begin
+ FFNotifyDependents(ffn_Deactivate);
+ scSetState(ffesInactive);
+ end;
+ FEnabled := aEnabled;
+ end;
+end;
+{--------}
+procedure TffBaseTransport.btSetLogOptions(const anOptions : TffTransportLogOptions);
+begin
+ if (UpdateCount > 0) then
+ _FLogOptions := anOptions
+ else
+ FLogOptions := anOptions;
+end;
+{--------}
+procedure TffBaseTransport.btSetMode(const aMode : TffTransportMode);
+begin
+ if (FUpdateCount > 0) then
+ _FMode := aMode
+ else begin
+ {Check to make sure the new property is different.}
+ if FMode = aMode then Exit;
+ scCheckInactive;
+ FMode := aMode;
+ end;
+end;
+{--------}
+procedure TffBaseTransport.btSetOnStateChange(const aHandler : TNotifyEvent);
+begin
+ if (FUpdateCount > 0) then
+ _FOnStateChange := aHandler
+ else
+ scOnStateChange := aHandler;
+end;
+{--------}
+procedure TffBaseTransport.btSetRespondToBroadcasts(const aRespond : Boolean);
+begin
+ if (FUpdateCount > 0) then
+ _FRespondToBroadcasts := aRespond
+ else
+ FRespondToBroadcasts := aRespond;
+end;
+{--------}
+procedure TffBaseTransport.btSetServername(const aServername : string); {!!.10}
+begin
+ if (FUpdateCount > 0) then
+ _FServerName := aServerName
+ else begin
+ {Check to make sure the new property is different.}
+ if FServerName = aServername then Exit;
+ scCheckInactive;
+ FServerName := aServerName;
+ end;
+end;
+{--------}
+procedure TffBaseTransport.btCheckListener;
+begin
+ if FMode = fftmSend then
+ RaiseSCErrorCode(ffsce_MustBeListener);
+end;
+{--------}
+procedure TffBaseTransport.btCheckSender;
+begin
+ if FMode = fftmListen then
+ RaiseSCErrorCode(ffsce_MustBeSender);
+end;
+{--------}
+procedure TffBaseTransport.btCheckServerName;
+begin
+ if FServerNameRequired and (FServerName = '') then
+ RaiseSCErrorCode(ffsce_MustHaveServerName);
+end;
+{--------}
+procedure TffBaseTransport.btInternalReply(msgID : Longint;
+ errorCode : TffResult;
+ replyData : pointer;
+ replyDataLen : Longint);
+begin
+ scCheckStarted;
+end;
+{--------}
+procedure TffBaseTransport.lcSetLogEnabled(const aEnabled : Boolean);
+begin
+ if (UpdateCount > 0) then
+ _FLogEnabled := aEnabled
+ else
+ FLogEnabled := aEnabled;
+end;
+{--------}
+procedure TffBaseTransport.Process(Msg : PffDataMessage);
+begin
+
+ btStoreSelfInThreadvar;
+
+ { If we have a command handler, tell the command handler to process the
+ message. }
+ if assigned(FCmdHandler) then begin
+ { Increment the message count. Note: This happens whether or not the
+ message was handled by a command handler, plugin command handler, or
+ server engine. }
+ InterlockedIncrement(FMsgCount);
+ FCmdHandler.Process(Msg);
+ end;
+end;
+{--------}
+class function TffBaseTransport.CurrentTransport : TffBaseTransport;
+begin
+ Result := TffBaseTransport(ffitvTransportID);
+end;
+{--------}
+{Rewritten !!.11}
+procedure TffBaseTransport.FFNotificationEx(const AOp : Byte; AFrom : TffComponent;
+ const AData : TffWord32);
+begin
+ inherited;
+ if AOp in [ffn_Destroy, ffn_Remove] then
+ if (AFrom = FCmdHandler) then begin
+ FCmdHandler.FFRemoveDependent(Self);
+ FCmdHandler := nil
+ end
+ else if (AFrom = FEventLog) then begin
+ FEventLog.FFRemoveDependent(Self);
+ FEventLog := nil;
+ end;
+end;
+{--------}
+class procedure TffBaseTransport.Reply(msgID : Longint;
+ errorCode : TffResult;
+ replyData : pointer;
+ replyDataLen : Longint);
+begin
+ CurrentTransport.btInternalReply(msgID, errorCode,
+ replyData, replyDataLen);
+end;
+{--------}
+procedure TffBaseTransport.ResetMsgCount;
+begin
+ FMsgCount := 0;
+end;
+{--------}
+function TffBaseTransport.Sleep(const timeOut : Longint) : boolean;
+begin
+ Result := False;
+end;
+{--------}
+function TffBaseTransport.Supported : boolean;
+begin
+ Result := True;
+end;
+{--------}
+procedure TffBaseTransport.btStoreSelfInThreadvar;
+begin
+ { Store a pointer to this instance so the command handler may quickly
+ find us and submit a reply. }
+ ffitvTransportID := Longint(Self);
+end;
+{====================================================================}
+
+{===TffThreadedTransport=============================================}
+constructor TffThreadedTransport.Create(aOwner : TComponent);
+begin
+ inherited Create(aOwner);
+ FThreadPool := nil;
+ FUnsentRequestQueue := TffThreadQueue.Create;
+ FWaitingForReplyList := TffThreadList.Create;
+end;
+{--------}
+destructor TffThreadedTransport.Destroy;
+var
+ anIndex : Longint;
+ aRequest : TffRequest;
+begin
+ FFNotifyDependents(ffn_Destroy);
+
+ if assigned(FThreadPool) then
+ FThreadPool.FFRemoveDependent(Self); {!!.11}
+
+ if assigned(FUnsentRequestQueue) then
+ with FUnsentRequestQueue.BeginWrite do
+ try
+ for anIndex := pred(Count) downto 0 do begin
+ aRequest := TffRequest(TffIntListItem(Items[anIndex]).KeyAsInt);
+ aRequest.Free;
+ end;
+ finally
+ EndWrite;
+ Free;
+ end;
+
+ if assigned(FWaitingForReplyList) then
+ with FWaitingForReplyList.BeginWrite do
+ try
+ for anIndex := pred(Count) downto 0 do begin
+ aRequest := TffRequest(TffIntListItem(Items[anIndex]).KeyAsInt);
+ aRequest.Free;
+ end;
+ finally
+ EndWrite;
+ Free;
+ end;
+
+ inherited Destroy;
+end;
+{--------}
+{Rewritten !!.11}
+procedure TffThreadedTransport.FFNotificationEx(const AOp : Byte; AFrom : TffComponent;
+ const AData : TffWord32);
+begin
+ inherited;
+ if (AFrom = FThreadPool) and
+ (AOp in[ffn_Destroy, ffn_Remove]) then begin
+ FThreadPool.FFRemoveDependent(Self);
+ FThreadPool := nil;
+ end;
+end;
+{--------}
+procedure TffThreadedTransport.SetThreadPool(aPool : TffThreadPool);
+begin
+ if aPool <> FThreadPool then begin
+ if assigned(FThreadPool) then
+ FThreadPool.FFRemoveDependent(Self); {!!.11}
+
+ if Assigned(aPool) then begin
+ FThreadPool := aPool;
+ FThreadPool.FFAddDependent(Self); {!!.11}
+ end;
+ end;
+end;
+{--------}
+procedure TffThreadedTransport.Post(transportID : Longint;
+ clientID : TffClientID;
+ msgID : Longint;
+ requestData : pointer;
+ requestDataLen : Longint;
+ timeout : Longint;
+ replyMode : TffReplyModeType);
+var
+ aRequest : TffRequest;
+ anItem : TffIntListItem;
+begin
+ scCheckStarted;
+ aRequest := TffRequest.Create(clientID, msgID, requestData,
+ requestDataLen, timeout, replyMode);
+ anItem := TffIntListItem.Create(Longint(aRequest));
+ with FUnsentRequestQueue.BeginWrite do
+ try
+ Enqueue(anItem);
+ finally
+ EndWrite;
+ end;
+ if replyMode = ffrmNoReplyWaitUntilSent then begin
+ aRequest.WaitForReply(timeout);
+ if not aRequest.Aborted then
+ aRequest.Free
+ else
+ with aRequest do
+ tpLogReqMisc(format(ffc_ReqAborted,[Longint(aRequest), ClientID,
+ ErrorCode, Timeout]));
+ end;
+end;
+{--------}
+procedure TffThreadedTransport.Request(transportID : Longint;
+ clientID : TffClientID;
+ msgID : Longint;
+ timeout : Longint;
+ requestData : pointer;
+ requestDataLen : Longint;
+ replyCallback : TffReplyCallback;
+ replyCookie : Longint);
+var
+ aRequest : TffRequest;
+
+begin
+ scCheckStarted;
+ aRequest := TffRequest.Create(clientID, msgID, requestData, requestDataLen,
+ timeout, ffrmReplyExpected);
+ tpInternalRequest(aRequest, timeout, 0);
+ if assigned(replyCallback) then
+ replyCallback(aRequest.ReplyMsgID, aRequest.ErrorCode,
+ aRequest.ReplyData, aRequest.ReplyDataLen,
+ replyCookie);
+ if not aRequest.Aborted then
+ aRequest.Free
+ else
+ with aRequest do
+ tpLogReqMisc(format(ffc_ReqAborted,[Longint(aRequest), ClientID,
+ ErrorCode, Timeout]));
+end;
+{--------}
+procedure TffThreadedTransport.tpInternalRequest(aRequest : TffRequest;
+ timeout : Longint;
+ aCookie : HWND);
+var
+ anItem : TffIntListItem;
+begin
+ anItem := TffIntListItem.Create(Longint(aRequest));
+ with FUnsentRequestQueue.BeginWrite do
+ try
+ Enqueue(anItem);
+ finally
+ EndWrite;
+ end;
+
+ { Wait for the reply. If a timeout occurs, assume the request object
+ will be freed by the transport thread at some point. Timeout exceptions
+ are raised to the calling object. }
+ if timeout = 0 then
+ aRequest.WaitForReply(timeout)
+ else
+ aRequest.WaitForReply(timeout + ffcl_RequestLatencyAdjustment);
+
+end;
+{--------}
+procedure TffThreadedTransport.tpLogReq(aRequest : TffRequest;
+ const prefix : string);
+begin
+ if FLogEnabled and (fftpLogRequests in FLogOptions) and
+ assigned(FEventLog) and assigned(aRequest) then
+ with aRequest do begin
+ FEventLog.WriteStringFmt(ffc_ReqLogString,
+ [prefix, Longint(aRequest), ClientID, MsgID,
+ RequestDataLen, Timeout]);
+ FEventLog.WriteBlock('Data', aRequest.RequestData,
+ aRequest.RequestDataLen);
+ end;
+end;
+{--------}
+procedure TffThreadedTransport.tpLogReq2(const aPrefix : string;
+ const aRequestID : Longint;
+ const aClientID : TffClientID;
+ const aMsgID : Longint;
+ const aData : pointer;
+ const aDataLen : Longint;
+ const aTimeout : Longint);
+begin
+ FEventLog.WriteStringFmt(ffc_ReqLogString,
+ [aPrefix, aRequestID, aClientID, aMsgID,
+ aDataLen, aTimeout]);
+ FEventLog.WriteBlock(ffc_Data, aData, aDataLen);
+end;
+{--------}
+procedure TffThreadedTransport.tpLogReqMisc(const aMsg : string);
+begin
+ if FLogEnabled and (fftpLogRequests in FLogOptions) and
+ assigned(FEventLog) then
+ FEventLog.WriteString(aMsg);
+end;
+{--------}
+procedure TffThreadedTransport.tpLogReply(aRequest : TffRequest);
+begin
+ if FLogEnabled and (fftpLogReplies in FLogOptions) and
+ assigned(FEventLog) and assigned(aRequest) then
+ with aRequest do begin
+ FEventLog.WriteStringFmt(ffc_ReplyLogString,
+ [Longint(aRequest), ClientID, ReplyMsgID,
+ ReplyDataLen, ErrorCode]);
+ FEventLog.WriteBlock(ffc_Data, ReplyData, ReplyDataLen);
+ end;
+end;
+{--------}
+procedure TffThreadedTransport.tpLogReply2(const aRequestID : Longint;
+ const aClientID : TffClientID;
+ const aMsgID : Longint;
+ const aDataLen : Longint;
+ const anError : TffResult);
+begin
+ { Assumption: Calling routine will only call if it is legitimate to log
+ the data. We do it this way so that we avoid passing tons
+ of data on the stack. }
+ FEventLog.WriteStringFmt(ffc_ReplyLogString,
+ [aRequestID, aClientID, aMsgID, aDataLen, anError]);
+end;
+
+{====================================================================}
+end.
+
+
diff --git a/components/flashfiler/sourcelaz/ffllcomp.pas b/components/flashfiler/sourcelaz/ffllcomp.pas
new file mode 100644
index 000000000..e77620a07
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffllcomp.pas
@@ -0,0 +1,559 @@
+{*********************************************************}
+{* FlashFiler: Base component classes *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffllcomp;
+
+interface
+
+uses
+ Classes,
+ SysUtils,
+ ffllbase,
+ fflllog,
+ ffsrmgr;
+
+type
+ { This type defines the possible states of a TffStateComponent. Values:
+ ffesInactive - The engine and its associated components (i.e., command
+ handlers and transports) are inactive.
+ ffesInitializing - The engine and its associated components are
+ initializing.
+ ffesStarting - The engine and its associates are starting.
+ ffesStarted - The engine and its associates are operational and
+ processing requests.
+ ffesShuttingDown - The engine and its associates are in the process of
+ shutting down.
+ ffesStopping - The engine is in the process of stopping but its
+ associated components are still active.
+ ffesStopped - The engine is inactive but its associates are still
+ active.
+ ffesUnsupported - Transport-specific. The transport is not supported
+ on this workstation. For example, an IPX/SPX transport is unsupported
+ if an IPX/SPX driver is not installed on the workstation.
+ ffesFailed - A failure occurred and the engine or transport may no
+ longer be used. A transport's state is set to ffesFailed if an error
+ occurs during startup.
+ }
+ TffState = (ffesInactive,
+ ffesInitializing,
+ ffesStarting,
+ ffesStarted,
+ ffesShuttingDown,
+ ffesStopping,
+ ffesStopped,
+ ffesUnsupported,
+ ffesFailed);
+
+ { This class implements the basic functionality for associating a component
+ with a descendant of TffBaseLog. }
+ TffLoggableComponent = class(TffComponent)
+ protected
+
+ FEventLog : TffBaseLog;
+ { The log to which events may be written. }
+
+ FLogEnabled : boolean;
+ { If True then events may be written to the event log. }
+
+ function lcGetLogEnabled : boolean; virtual;
+
+ procedure lcLog(const aString : string); virtual;
+ { Use this to write a string to the event log. }
+
+{Begin !!.06}
+ procedure lcLogFmt(const aMsg : string; const args : array of const); virtual;
+ { Use this method to write a formatted error string to the event log. }
+{End !!.06}
+
+ procedure lcSetEventLog(anEventLog : TffBaseLog); virtual;
+ { Sets the event log to be used by this component. }
+
+ procedure lcSetLogEnabled(const aEnabled : boolean); virtual;
+
+ public
+
+ constructor Create(aOwner : TComponent); override;
+
+ destructor Destroy; override;
+
+ procedure FFNotificationEx(const AOp : Byte; AFrom : TffComponent; {!!.11}
+ const AData : TffWord32); override; {!!.11}
+ { When the freeing of the TffBaseLog is detected, this method
+ sets FEventLog to nil to avoid using the freed TffBaseLog. }
+
+ published
+
+ property EventLog : TffBaseLog read FEventLog write lcSetEventLog;
+ { The event log to which the component may log messages. }
+
+ property EventLogEnabled : boolean
+ read lcGetLogEnabled
+ write lcSetLogEnabled
+ default False;
+ { If True then events are logged to EventLog. }
+
+ end;
+
+ { This class implements a basic state engine. }
+ TffStateComponent = class(TffLoggableComponent)
+ protected
+
+ scOnStateChange : TNotifyEvent;
+ { Handler to be called when the component's state changes. }
+
+ scState : TffState;
+ { The current state of the component. }
+
+ procedure scCheckInactive; virtual;
+ { When setting certain properties or calling certain methods, this
+ method is called to ensure the object is inactive. If the
+ object is not inactive then this method raises exception
+ ffsce_MustBeInactive. }
+
+ procedure scCheckStarted; virtual;
+ { When setting certain properties or calling certain methods, this
+ method is called to ensure the object is started. If the
+ object is not started then this method raises exception
+ ffsce_MustBeStarted. }
+
+ procedure scInitialize; virtual; abstract;
+ { This method is called when the component is to perform
+ its initialization. }
+
+ procedure scPrepareForShutdown; virtual; abstract;
+ { This method is called when the component is to prepare for
+ shutdown. }
+
+ procedure scShutdown; virtual; abstract;
+ { This method is called when the component is to finalize its shutdown. }
+
+ procedure scStartup; virtual; abstract;
+ { This method is called when the component is to complete the actions
+ required for it to do whatever work it is supposed to do. }
+
+ procedure scSetState(const aState : TffState); virtual;
+ { Use this method to set the component's state. }
+
+ public
+
+ constructor Create(aOwner : TComponent); override;
+
+ destructor Destroy; override;
+
+ {$IFDEF DCC4OrLater} {!!.03}
+ procedure BeforeDestruction; override; {!!.03}
+ {$ENDIF} {!!.03}
+
+ procedure Shutdown; virtual;
+ { Sets the component's State to ffesInactive. }
+
+ procedure Startup; virtual;
+ { Sets the component's State to ffesStarted. }
+
+ procedure Stop; virtual;
+ { Sets the component's State to ffesStopped. }
+
+ property State : TffState read scState write scSetState;
+ { The current state of the component. }
+
+ published
+
+ property OnStateChange : TNotifyEvent
+ read scOnStateChange
+ write scOnStateChange;
+ { Event handler called when the component's state changes. }
+
+ end;
+
+ { This type of exception is raised by the various server components when
+ a component-related error occurs. For example, if the user or an application
+ tries to set the transport's servername property while the transport is
+ active. }
+ EffServerComponentError = class(Exception)
+ protected
+ sceErrorCode : longInt;
+ function sceGetErrorString : string;
+ public
+ constructor Create(const aMsg : string);
+ constructor CreateViaCode(const aErrorCode : Longint; aDummy : Boolean);
+ constructor CreateViaCodeFmt(const aErrorCode : Longint; args : array of const; aDummy : Boolean);
+ constructor CreateWithObj(aObj : TComponent; const aMsg : string);
+
+ property ErrorCode : longInt read sceErrorCode;
+ end;
+
+
+{---Helper routines---}
+function FFMapStateToString(const aState : TffState) : string;
+ { Maps a state value to a string. }
+procedure RaiseSCErrorCode(const aErrorCode : longInt);
+procedure RaiseSCErrorCodeFmt(const aErrorCode : longInt;
+ args : array of const);
+procedure RaiseSCErrorMsg(const aMsg : string);
+procedure RaiseSCErrorObj(aObj : TComponent; const aMsg : string);
+
+
+var
+ ffStrResServerCmp : TffStringResource;
+ {-The string resource providing access to the server component error
+ strings. }
+
+const
+ { The following array implements the server state engine as specified in
+ Section 3.4.3.14 of the FlashFiler 2.0 Design Document. Exceptions are
+ as follows:
+
+ 1. If the current state is ffesInitializing & the target state is specified
+ as ffesInactive, the next state is ffesInactive.
+
+ 2. If the current state is ffesStarting & the target state is specified
+ as ffesInactive, the next state is ffesInactive.
+
+ 3. State ffesUnsupported not shown in diagram.
+
+ 4. State ffesFailed not shown in diagram.
+
+ Exceptions 1 and 2 are allowed because we need a way to short-circuit
+ transports back to ffesInactive in the event they fail during initialization
+ or startup.
+
+ Given the current state of the engine and the target state of the engine,
+ this array identifies the state to which the engine should be moved.
+
+ The first dimension (vertical) of the array is the engine's current state.
+ The second dimension (horizontal) of the array is the engine's target state.
+
+ To get the next state, index into the array as follows:
+
+ nextState := ffEngineStateDiagram[, ];
+ }
+ ffStateDiagram : array [TffState, TffState] of TffState =
+ { Horizontal = destination state, Vertical = current state }
+ { ffesInactive - ffesInitializing- ffesStarting - ffesStarted - ffesShuttingDown- ffesStopping - ffesStopped - ffesUnsupported- ffesFailed }
+ ( ( ffesInactive, ffesInitializing, ffesInitializing, ffesInitializing, ffesInitializing, ffesInitializing, ffesInitializing, ffesUnsupported, ffesFailed), // ffesInactive
+ ( ffesInactive, ffesStarting, ffesStarting, ffesStarting, ffesStarting, ffesStarting, ffesStarting, ffesInactive, ffesInactive), // ffesInitializing
+ ( ffesInactive, ffesStarted, ffesStarting, ffesStarted, ffesStarted, ffesStarted, ffesStarted, ffesInactive, ffesInactive), // ffesStarting
+ ( ffesShuttingDown, ffesStopping, ffesStopping, ffesStarted, ffesShuttingDown, ffesStopping, ffesStopping, ffesInactive, ffesInactive ), // ffesStarted
+ ( ffesInactive, ffesInactive, ffesInactive, ffesInactive, ffesShuttingDown, ffesInactive, ffesInactive, ffesInactive, ffesInactive ), // ffesShuttingDown
+ ( ffesStopped, ffesStopped, ffesStopped, ffesStopped, ffesStopped, ffesStopping, ffesStopped, ffesInactive, ffesInactive ), // ffesStopping
+ ( ffesInitializing, ffesInitializing, ffesInitializing, ffesInitializing, ffesInitializing, ffesInitializing, ffesStopped, ffesInactive, ffesInactive), // ffesStopped
+ ( ffesUnsupported, ffesUnsupported, ffesUnsupported, ffesUnsupported, ffesUnsupported, ffesUnsupported, ffesUnsupported, ffesUnsupported, ffesUnsupported), // ffesUnsupported
+ ( ffesFailed, ffesFailed, ffesFailed, ffesFailed, ffesFailed, ffesFailed, ffesFailed, ffesFailed, ffesFailed) // ffesFailed
+ );
+
+
+implementation
+
+{$I ffllscst.inc}
+{$R ffllscst.res}
+
+resourcestring
+ ffcStateInactive = 'Inactive';
+ ffcStateInitializing = 'Initializing';
+ ffcStateStarting = 'Starting';
+ ffcStateStarted = 'Started';
+ ffcStateShuttingDown = 'Shutting down';
+ ffcStateStopping = 'Stopping';
+ ffcStateStopped = 'Stopped';
+ ffcStateUnsupported = 'Driver not installed';
+ ffcStateFailed = 'Failed';
+
+{===TffLoggableComponent=============================================}
+constructor TffLoggableComponent.Create(aOwner : TComponent);
+begin
+ inherited Create(aOwner);
+ FEventLog := nil;
+ FLogEnabled := False;
+end;
+{--------}
+destructor TffLoggableComponent.Destroy;
+begin
+ if assigned(FEventLog) then
+ FEventLog.FFRemoveDependent(Self); {!!.11}
+ inherited Destroy;
+end;
+{--------}
+function TffLoggableComponent.lcGetLogEnabled : boolean;
+begin
+ Result := FLogEnabled;
+end;
+{--------}
+procedure TffLoggableComponent.lcLog(const aString : string);
+begin
+ if FLogEnabled and assigned(FEventLog) then
+ FEventLog.WriteString(aString);
+end;
+{Begin !!.06}
+{--------}
+procedure TffLoggableComponent.lcLogFmt(const aMsg : string; const args : array of const);
+begin
+ if FLogEnabled and assigned(FEventLog) then
+ FEventLog.WriteStringFmt(aMsg, args);
+end;
+{End !!.06}
+{--------}
+procedure TffLoggableComponent.lcSetEventLog(anEventLog : TffBaseLog);
+{Rewritten !!.11}
+begin
+ if FEventLog <> anEventLog then begin
+ if assigned(FEventLog) then
+ FEventLog.FFRemoveDependent(Self);
+
+ FEventLog := anEventLog;
+ if assigned(FEventLog) then
+ FEventLog.FFAddDependent(Self);
+ end;
+end;
+{--------}
+procedure TffLoggableComponent.lcSetLogEnabled(const aEnabled : boolean);
+begin
+ FLogEnabled := aEnabled;
+end;
+{--------}
+{Rewritten !!.11}
+procedure TffLoggableComponent.FFNotificationEx(const AOp : Byte; AFrom : TffComponent;
+ const AData : TffWord32);
+begin
+ inherited;
+ if (AFrom = FEventLog) and
+ (AOp in [ffn_Destroy, ffn_Remove]) then begin
+ FEventLog.FFRemoveDependent(Self);
+ FEventLog := nil;
+ end;
+end;
+{====================================================================}
+
+{===TffStateComponent================================================}
+constructor TffStateComponent.Create(aOwner : TComponent);
+begin
+ inherited Create(aOwner);
+ scOnStateChange := nil;
+ scState := ffesInactive;
+end;
+{--------}
+destructor TffStateComponent.Destroy;
+begin
+ if scState <> ffesInactive then
+ scSetState(ffesInactive);
+ inherited Destroy;
+end;
+{Begin !!.03}
+{$IFDEF DCC4OrLater}
+{--------}
+ procedure TffStateComponent.BeforeDestruction;
+begin
+ inherited;
+
+ FFNotifyDependents(ffn_Deactivate); {!!.04}
+
+ if scState <> ffesInactive then
+ scSetState(ffesInactive);
+end;
+{$ENDIF}
+{End !!.03}
+{--------}
+procedure TffStateComponent.scCheckInactive;
+begin
+ if not (scState in [ffesInactive, ffesUnsupported, ffesFailed]) then {!!.03}
+ RaiseSCErrorCode(ffsce_MustBeInactive);
+end;
+{--------}
+procedure TffStateComponent.scCheckStarted;
+begin
+ if scState <> ffesStarted then
+ RaiseSCErrorCode(ffsce_MustBeStarted);
+end;
+{--------}
+procedure TffStateComponent.scSetState(const aState : TffState);
+var
+ NextState : TffState;
+ OldState : TffState;
+begin
+
+ if aState = scState then exit;
+
+ OldState := scState;
+
+ try
+ while scState <> aState do begin
+ NextState := ffStateDiagram[scState, aState];
+ { If our next state is exactly our current state then there is no way
+ we can get to the destination state. This happens when the current
+ state is ffesUnsupported or ffesFailed. }
+ if NextState = scState then exit;
+
+// if NextState = ffesShuttingDown then {!!.04}
+// FFNotifyDependents(ffn_Deactivate); {!!.04}
+
+ scState := NextState;
+ case NextState of
+ ffesInactive :
+ scShutdown;
+ ffesInitializing :
+ scInitialize;
+ ffesStarting :
+ scStartup;
+ ffesShuttingDown :
+ scPrepareForShutdown;
+ end; { case }
+ if assigned(scOnStateChange) then
+ scOnStateChange(Self);
+ end; { while }
+ except
+ scState := OldState;
+ raise;
+ end;
+end;
+{--------}
+procedure TffStateComponent.Shutdown;
+begin
+ State := ffesInactive;
+end;
+{--------}
+procedure TffStateComponent.Startup;
+begin
+ State := ffesStarted;
+end;
+{--------}
+procedure TffStateComponent.Stop;
+begin
+ State := ffesStopped;
+end;
+{====================================================================}
+
+{===Interfaced helper routines=======================================}
+function FFMapStateToString(const aState : TffState) : string;
+begin
+ case aState of
+ ffesInactive : Result := ffcStateInactive;
+ ffesInitializing : Result := ffcStateInitializing;
+ ffesStarting : Result := ffcStateStarting;
+ ffesStarted : Result := ffcStateStarted;
+ ffesShuttingDown : Result := ffcStateShuttingDown;
+ ffesStopping : Result := ffcStateStopping;
+ ffesStopped : Result := ffcStateStopped;
+ ffesUnsupported : Result := ffcStateUnsupported;
+ ffesFailed : Result := ffcStateFailed;
+ else
+ Result := '';
+ end; { case }
+end;
+{--------}
+procedure RaiseSCErrorCode(const aErrorCode : longInt);
+begin
+ raise EffServerComponentError.CreateViaCode(aErrorCode, False);
+end;
+{--------}
+procedure RaiseSCErrorCodeFmt(const aErrorCode : longInt;
+ args : array of const);
+begin
+ raise EffServerComponentError.CreateViaCode(aErrorCode, False);
+end;
+{--------}
+procedure RaiseSCErrorMsg(const aMsg : string);
+begin
+ raise EffServerComponentError.Create(aMsg);
+end;
+{--------}
+procedure RaiseSCErrorObj(aObj : TComponent; const aMsg : string);
+begin
+ raise EffServerComponentError.CreateWithObj(aObj, aMsg);
+end;
+{====================================================================}
+
+{===EffServerComponentError==========================================}
+constructor EffServerComponentError.Create(const aMsg : string);
+begin
+ sceErrorCode := 0;
+ inherited CreateFmt(ffStrResServerCmp[ffsce_NoErrorCode], [aMsg]);
+end;
+{--------}
+constructor EffServerComponentError.CreateViaCode(const aErrorCode : Longint; aDummy : Boolean);
+var
+ Msg : string;
+begin
+ sceErrorCode := aErrorCode;
+ Msg := sceGetErrorString;
+ inherited CreateFmt(ffStrResServerCmp[ffsce_HasErrorCode], [Msg, aErrorCode, aErrorCode]);
+end;
+{--------}
+constructor EffServerComponentError.CreateViaCodeFmt(const aErrorCode : longInt;
+ args : array of const;
+ aDummy : Boolean);
+var
+ Msg : string;
+begin
+ sceErrorCode := aErrorCode;
+ Msg := sceGetErrorString;
+ inherited CreateFmt(ffStrResServerCmp[ffsce_HasErrorCode],
+ [format(Msg, args), aErrorCode, aErrorCode]);
+end;
+{--------}
+constructor EffServerComponentError.CreateWithObj(aObj : TComponent;
+ const aMsg : string);
+var
+ ObjName : string;
+begin
+ sceErrorCode := 0;
+ if (aObj = nil) then
+ ObjName := ffStrResServerCmp[ffsce_NilPointer]
+ else begin
+ ObjName := aObj.Name;
+ if (ObjName = '') then
+ ObjName := Format(ffStrResServerCmp[ffsce_UnnamedInst], [aObj.ClassName]);
+ end;
+ inherited CreateFmt(ffStrResServerCmp[ffsce_InstNoCode], [ObjName, aMsg]);
+end;
+{--------}
+function EffServerComponentError.sceGetErrorString : string;
+begin
+ Result := ffStrResServerCmp[sceErrorCode];
+end;
+{====================================================================}
+
+procedure FinalizeUnit;
+begin
+ ffStrResServerCmp.Free;
+end;
+
+procedure InitializeUnit;
+begin
+ ffStrResServerCmp := nil;
+ ffStrResServerCmp := TffStringResource.Create(hInstance, 'FF_SERVER_CMP_STRINGS');
+end;
+
+initialization
+ InitializeUnit;
+
+finalization
+ FinalizeUnit;
+
+end.
diff --git a/components/flashfiler/sourcelaz/fflldate.pas b/components/flashfiler/sourcelaz/fflldate.pas
new file mode 100644
index 000000000..63cbe8173
--- /dev/null
+++ b/components/flashfiler/sourcelaz/fflldate.pas
@@ -0,0 +1,295 @@
+{*********************************************************}
+{* FlashFiler: Date/time support routines *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit fflldate;
+
+interface
+
+uses
+ ffllbase,
+ ffstdate,
+ Windows,
+ SysUtils;
+
+const
+ {the following characters are meaningful in date Picture masks}
+ pmMonth = 'M'; {formatting character for a date string picture mask. }
+ pmDay = 'D'; {formatting character for a date string picture mask. }
+ pmYear = 'Y'; {formatting character for a date string picture mask}
+ pmDateSlash = '/'; {formatting character for a date string picture mask}
+
+ pmHour = 'h'; {formatting character for a time string picture mask}
+ pmMinute = 'm'; {formatting character for a time string picture mask}
+ pmSecond = 's'; {formatting character for a time string picture mask}
+ {'hh:mm:ss tt' -\> '12:00:00 pm', 'hh:mmt' -\> '12:00p'}
+ pmAmPm = 't'; {formatting character for a time string picture mask.
+ This generates 'AM' or 'PM'}
+ pmTimeColon = ':'; {formatting character for a time string picture mask}
+
+ MaxDateLen = 40; { maximum length of date picture mask }
+
+
+function DateStringToDMY(const Picture, S : string; var Day, Month, Year : Integer;
+ Epoch : Integer) : Boolean;
+ {-extract day, month, and year from S, returning true if string is valid}
+
+function DatePCharToDMY(Picture, S : PAnsiChar; var Day, Month, Year : Integer;
+ Epoch : Integer) : Boolean;
+ {-extract day, month, and year from S, returning true if string is valid}
+
+function TimeStringToHMS(const Picture, S : string;
+ var Hour, Minute, Second : Integer) : Boolean;
+ {-extract Hours, Minutes, Seconds from St, returning true if string is valid}
+
+function TimePCharToHMS(Picture, S : PAnsiChar;
+ var Hour, Minute, Second : Integer) : Boolean;
+ {-extract Hours, Minutes, Seconds from St, returning true if string is valid}
+
+implementation
+
+var
+ w1159 : array[0..5] of AnsiChar;
+ w2359 : array[0..5] of AnsiChar;
+
+
+{===== Internal Routines =====}
+
+function StrChPos(P : PAnsiChar; C : AnsiChar;
+ var Pos : Cardinal): Boolean; register;
+ {-Sets Pos to position of character C within string P returns True if found}
+asm
+ push esi {save since we'll be changing}
+ push edi
+ push ebx
+ mov esi, ecx {save Pos}
+
+ cld {forward string ops}
+ mov edi, eax {copy P to EDI}
+ or ecx, -1
+ xor eax, eax {zero}
+ mov ebx, edi {save EDI to EBX}
+ repne scasb {search for NULL terminator}
+ not ecx
+ dec ecx {ecx has len of string}
+
+ test ecx, ecx
+ jz @@NotFound {if len of P = 0 then done}
+
+ mov edi, ebx {reset EDI to beginning of string}
+ mov al, dl {copy C to AL}
+ repne scasb {find C in string}
+ jne @@NotFound
+
+ mov ecx, edi {calculate position of C}
+ sub ecx, ebx
+ dec ecx {ecx holds found position}
+
+ mov [esi], ecx {store location}
+ mov eax, 1 {return true}
+ jmp @@ExitCode
+
+@@NotFound:
+ xor eax, eax
+
+@@ExitCode:
+
+ pop ebx {restore registers}
+ pop edi
+ pop esi
+end;
+
+
+function UpCaseChar(C : AnsiChar) : AnsiChar; register;
+asm
+ and eax, 0FFh
+ push eax
+ call CharUpper
+end;
+
+procedure ExtractFromPicture(Picture, S : PAnsiChar;
+ Ch : AnsiChar; var I : Integer;
+ Blank, Default : Integer);
+ {-extract the value of the subfield specified by Ch from S and return in
+ I. I will be set to -1 in case of an error, Blank if the subfield exists
+ in Picture but is empty, Default if the subfield doesn't exist in
+ Picture.}
+var
+ PTmp : Array[0..20] of AnsiChar;
+ J, K : Cardinal;
+ Code : Integer;
+ Found,
+ UpFound : Boolean;
+begin
+ {find the start of the subfield}
+ I := Default;
+ Found := StrChPos(Picture, Ch, J);
+ Ch := UpCaseChar(Ch);
+ UpFound := StrChPos(Picture, Ch, K);
+
+ if not Found or (UpFound and (K < J)) then begin
+ J := K;
+ Found := UpFound;
+ end;
+ if not Found or (StrLen(S) <> StrLen(Picture)) then
+ Exit;
+
+ {extract the substring}
+ PTmp[0] := #0;
+ K := 0;
+ while (UpCaseChar(Picture[J]) = Ch) and (J < StrLen(Picture)) do begin
+ if S[J] <> ' ' then begin
+ PTmp[k] := S[J];
+ Inc(K);
+ PTmp[k] := #0;
+ end;
+ Inc(J);
+ end;
+
+ if StrLen(PTmp) = 0 then
+ I := Blank
+ else begin
+ {convert to a value}
+ Val(PTmp, I, Code);
+ if Code <> 0 then
+ I := -1;
+ end;
+end;
+
+{===== Exported routines =====}
+
+
+function DateStringToDMY(const Picture, S : string; var Day, Month, Year : Integer;
+ Epoch : Integer) : Boolean;
+ {-extract day, month, and year from S, returning true if string is valid}
+var
+ Buf1 : array[0..255] of AnsiChar;
+ Buf2 : array[0..255] of AnsiChar;
+begin
+ StrPCopy(Buf1, Picture);
+ StrPCopy(Buf2, S);
+ Result := DatePCharToDMY(Buf1, Buf2, Day, Month, Year, Epoch);
+end;
+
+function DatePCharToDMY(Picture, S : PAnsiChar; var Day, Month, Year : Integer;
+ Epoch : Integer) : Boolean;
+ {-extract day, month, and year from S, returning true if string is valid}
+begin
+ Result := False;
+ if StrLen(Picture) <> StrLen(S) then
+ Exit;
+
+ ExtractFromPicture(Picture, S, pmMonth, Month, -1, DefaultMonth);
+ ExtractFromPicture(Picture, S, pmDay, Day, -1, 1);
+ ExtractFromPicture(Picture, S, pmYear, Year, -1, DefaultYear);
+ Result := ValidDate(Day, Month, Year, Epoch);
+end;
+
+function TimeStringToHMS(const Picture, S : string;
+ var Hour, Minute, Second : Integer) : Boolean;
+ {-extract Hours, Minutes, Seconds from St, returning true if string is valid}
+var
+ Buf1 : array[0..255] of AnsiChar;
+ Buf2 : array[0..255] of AnsiChar;
+begin
+ StrPCopy(Buf1, Picture);
+ StrPCopy(Buf2, S);
+ Result := TimePCharToHMS(Buf1, Buf2, Hour, Minute, Second);
+end;
+
+function TimePCharToHMS(Picture, S : PAnsiChar;
+ var Hour, Minute, Second : Integer) : Boolean;
+ {-extract Hours, Minutes, Seconds from St, returning true if string is valid}
+var
+ I, J : Cardinal;
+ Tmp,
+ t1159,
+ t2359 : array[0..20] of AnsiChar;
+begin
+ Result := False;
+ if StrLen(Picture) <> StrLen(S) then
+ Exit;
+
+ {extract hours, minutes, seconds from St}
+ ExtractFromPicture(Picture, S, pmHour, Hour, -1, 0);
+ ExtractFromPicture(Picture, S, pmMinute, Minute, -1, 0);
+ ExtractFromPicture(Picture, S, pmSecond, Second, -1, 0);
+ if (Hour = -1) or (Minute = -1) or (Second = -1) then begin
+ Result := False;
+ Exit;
+ end;
+
+ {check for TimeOnly}
+ if StrChPos(Picture, pmAmPm, I) and (w1159[0] <> #0)
+ and (w2359[0] <> #0) then begin
+ Tmp[0] := #0;
+ J := 0;
+ while Picture[I] = pmAmPm do begin
+ Tmp[J] := S[I];
+ Inc(J);
+ Inc(I);
+ end;
+ Tmp[J] := #0;
+ FFStrTrimR(Tmp);
+
+ StrCopy(t1159, w1159);
+ t1159[J] := #0;
+ StrCopy(t2359, w2359);
+ t2359[J] := #0;
+
+ if (Tmp[0] = #0) then
+ Hour := -1
+ else if StrIComp(Tmp, t2359) = 0 then begin
+ if (Hour < 12) then
+ Inc(Hour, 12)
+ else if (Hour = 0) or (Hour > 12) then
+ {force BadTime}
+ Hour := -1;
+ end else if StrIComp(Tmp, t1159) = 0 then begin
+ if Hour = 12 then
+ Hour := 0
+ else if (Hour = 0) or (Hour > 12) then
+ {force BadTime}
+ Hour := -1;
+ end else
+ {force BadTime}
+ Hour := -1;
+ end;
+
+ Result := ValidTime(Hour, Minute, Second);
+end;
+
+initialization
+ GetProfileString('intl', 's1159', 'AM', w1159, SizeOf(w1159));
+ GetProfileString('intl', 's2359', 'PM', w2359, SizeOf(w2359));
+end.
+
+
+
diff --git a/components/flashfiler/sourcelaz/fflldict.pas b/components/flashfiler/sourcelaz/fflldict.pas
new file mode 100644
index 000000000..95d7572ea
--- /dev/null
+++ b/components/flashfiler/sourcelaz/fflldict.pas
@@ -0,0 +1,2205 @@
+{NOTES:
+ 1. Have verification as optional--IFDEF'd out}
+
+{*********************************************************}
+{* FlashFiler: Table data dictionary *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit fflldict;
+
+interface
+
+uses
+ Windows,
+ SysUtils,
+ Classes,
+ FFConst,
+ ffllbase,
+ ffsrixhl,
+ ffsrmgr,
+ ffllexcp;
+
+
+{---Data dictionary class---}
+type
+
+ PffFieldDescriptorArray = ^TffFieldDescriptorArray;
+ TffFieldDescriptorArray = array[Word] of PffFieldDescriptor;
+
+ PffIndexDescriptorArray = ^TffIndexDescriptorArray;
+ TffIndexDescriptorArray = array[0..Pred(ffcl_MaxIndexes)] of PffIndexDescriptor;
+
+ PffIndexHelperArray = ^TffIndexHelperArray;
+ TffIndexHelperArray = array[0..Pred(ffcl_MaxIndexes),
+ 0..Pred(ffcl_MaxIndexFlds)] of TffSrIndexHelper;
+
+ TffTriBool = (fftbUnknown, fftbTrue, fftbFalse); {!!.03}
+
+ TffDataDictionary = class(TPersistent)
+ protected {private}
+ FBLOBFileNumber : Integer; {file number for BLOBs}
+ FFieldCapacity : Longint; {the number of fields the FieldDescriptor
+ array has been sized to hold }
+ FFldCount : Integer; {count of fields--duplicate for speed}
+ FHasBLOBs : TffTriBool; {True if table contains any BLOB fields} {!!.03}
+ FIndexCapacity : Longint; {the number of indices the IndexDescriptor
+ array has been sized to hold }
+ FInxCount : Integer; {count of indexes--duplicate for speed}
+ FFileCount : Integer; {count of files--duplicate for speed}
+ FBaseName : TffTableName;{the base name for the table}
+ FLogRecLen : Longint; {logical rec length--dupe for speed}
+ FIsEncrypted : Boolean; {true is files are encrypted}
+
+ ddFileList : TList; {list of files}
+ ddDefFldList : TList; {list of field numbers that have defaults}
+
+ ddReadOnly : Boolean; {true if the dictionary cannot be updated}
+
+ procedure AnsiStringWriter(const aString : string; {!!.05}
+ aWriter : TWriter); {!!.05}
+ { This method is used to bypass D6's TWriter.WriteString's logic
+ for writing strings with extended charcters as UTF8 strings.
+ Since D3-D5 and C3-C5 don't recognize the UTF8 string type, it
+ causes an error when TReader.ReadString tries to read the
+ streams created by D6 using the UTF8 string type.}
+ procedure ddExpandFieldArray(const minCapacity : Longint);
+ procedure ddExpandIndexArray(const minCapacity : Longint);
+ function GetBaseRecordLength : Longint;
+ function GetBlockSize : Longint;
+ function GetBookmarkSize(aIndexID : Integer) : Integer;
+ function GetDefaultFldCount : Integer;
+ function GetFieldDecPl(aField : Integer) : Longint;
+ function GetFieldDesc(aField : Integer) : TffDictItemDesc;
+ function GetFieldLength(aField : Integer) : Longint;
+ function GetFieldName(aField : integer) : TffDictItemName;
+ function GetFieldOffset(aField : integer) : Longint;
+ function GetFieldRequired(aField : integer) : boolean;
+ function GetFieldType(aField : integer) : TffFieldType;
+ function GetFieldUnits(aField : integer) : Longint;
+ function GetFieldVCheck(aField : integer) : PffVCheckDescriptor;
+ function GetFileBlockSize(aFile : integer) : Longint;
+ function GetFileDesc(aFile : integer) : TffDictItemDesc;
+ function GetFileDescriptor(aFile : integer) : PffFileDescriptor;
+ function GetFileExt(aFile : integer) : TffExtension;
+ function GetFileNameExt(aFile : integer) : TffFileNameExt;
+ function GetFileType(aFile : integer) : TffFileType;
+ function GetHasBLOBs : Boolean; {!!.03}
+ function GetIndexAllowDups(aIndexID : integer) : boolean;
+ function GetIndexAscend(aIndexID : integer) : boolean;
+ function GetIndexDesc(aIndexID : integer) : TffDictItemDesc;
+ function GetIndexFileNumber(aIndexID : integer) : Longint;
+ function GetIndexKeyLength(aIndexID : integer) : Longint;
+ function GetIndexName(aIndexID : integer) : TffDictItemName;
+ function GetIndexNoCase(aIndexID : Integer) : Boolean;
+ function GetIndexType(aIndexID : Integer) : TffIndexType;
+ function GetRecordLength : Longint;
+ procedure CheckForDefault(aVCheckDesc : PffVCheckDescriptor;
+ aFieldDesc : PffFieldDescriptor);
+ procedure SetBlockSize(BS : Longint);
+ procedure SetIsEncrypted(IE : Boolean);
+ protected
+ procedure ClearPrim(InclFileZero : boolean);
+ function CreateFieldDesc(const aIdent : TffDictItemName;
+ const aDesc : TffDictItemDesc;
+ aType : TffFieldType;
+ aUnits : Integer;
+ aDecPl : Integer;
+ aReqFld : Boolean;
+ const aValCheck : PffVCheckDescriptor)
+ : PffFieldDescriptor;
+ function CreateFileDesc(const aDesc : TffDictItemDesc;
+ const aExtension : TffExtension;
+ aBlockSize : Longint;
+ aType : TffFileType) : PffFileDescriptor;
+ function CreateIndexDesc(const aIdent : TffDictItemName;
+ const aDesc : TffDictItemDesc;
+ aFile : Integer;
+ aFldCount : Integer;
+ const aFldList : TffFieldList;
+ const aFldIHList : TffFieldIHList;
+ aAllowDups : Boolean;
+ aAscend : Boolean;
+ aNoCase : Boolean) : PffIndexDescriptor;
+ function CreateUserIndexDesc(const aIdent : TffDictItemName;
+ const aDesc : TffDictItemDesc;
+ aFile : Integer;
+ aKeyLength : Integer;
+ aAllowDups : Boolean;
+ aAscend : Boolean;
+ aNoCase : Boolean) : PffIndexDescriptor;
+
+ public
+ FieldDescriptor : PffFieldDescriptorArray;
+ { Array of field information for the fields in this dictionary.
+ Declared as a public array for speed reasons. }
+
+ IndexDescriptor : PffIndexDescriptorArray;
+ { Array of index information for the indexes in this dictionary.
+ Declared as a public array for speed reasons. }
+
+ IndexHelpers: PffIndexHelperArray;
+ { Index helper objects for composite indices
+ declared public (instead of private + public propert)
+ for speed reasons}
+
+ class function NewInstance: TObject; override;
+ procedure FreeInstance; override;
+
+ public
+ constructor Create(aBlockSize : Longint);
+ {-Create the instance, aBlockSize is the eventual block size
+ of the data file component of the table}
+ destructor Destroy; override;
+ {-Destroy the instance}
+
+ function AddFile(const aDesc : TffDictItemDesc;
+ const aExtension : TffExtension;
+ aBlockSize : Longint;
+ aFileType : TffFileType) : integer;
+ {-Add a file to the data dictionary (the actual file name will
+ be the base table name plus aExtension); result is the index
+ of the newly-added file in the file list}
+ procedure AddIndex(const aIdent : TffDictItemName;
+ const aDesc : TffDictItemDesc;
+ aFile : integer;
+ aFldCount : integer;
+ const aFldList : TffFieldList;
+ const aFldIHList : TffFieldIHList;
+ aAllowDups : boolean;
+ aAscend : boolean;
+ aCaseInsens : boolean);
+ {-Add an extended index to the data dictionary}
+ procedure AddUserIndex(const aIdent : TffDictItemName;
+ const aDesc : TffDictItemDesc;
+ aFile : integer;
+ aKeyLength : integer;
+ aAllowDups : boolean;
+ aAscend : boolean;
+ aCaseInsens: boolean);
+ {-Add a user defined index to the dictionary}
+ procedure AddField(const aIdent : TffDictItemName;
+ const aDesc : TffDictItemDesc;
+ aType : TffFieldType;
+ aUnits : Integer;
+ aDecPl : Integer;
+ aReqFld : Boolean;
+ const aValCheck : PffVCheckDescriptor);
+ {-Append a field to the end of the data dictionary's field list}
+ procedure Assign(Source: TPersistent); override;
+ {-Assign a data dictionary's data}
+ procedure BindIndexHelpers;
+ {-Binds the TffSrIndexHelper objects to the dictionary}
+ procedure CheckValid;
+ {-Raise an exception if the dictionary is invalid}
+ procedure Clear;
+ {-Delete all field/index data from the data dictionary}
+ procedure ExtractKey(aIndexID : integer;
+ aData : PffByteArray;
+ aKey : PffByteArray);
+ {-Given a record buffer and an index number, extract the key
+ for that index from the record}
+ function GetFieldFromName(const aFieldName : TffDictItemName) : integer;
+ {-Return the field number for a given field name, or -1 if not
+ found}
+ function GetIndexFromName(const aIndexName : TffDictItemName) : integer;
+ {-Return the index number for a given index name, or -1 if not
+ found}
+ function HasAutoIncField(var aField : integer) : boolean;
+ {-Return true and the index of the first autoinc field in the
+ dictionary}
+ procedure InsertField(AtIndex : Integer;
+ const aIdent : TffDictItemName;
+ const aDesc : TffDictItemDesc;
+ aType : TffFieldType;
+ aUnits : Integer;
+ aDecPl : Integer;
+ aReqFld : Boolean;
+ const aValCheck : PffVCheckDescriptor);
+ {-Insert a field into the data dictionary's field list}
+ function IsIndexDescValid(const aIndexDesc : TffIndexDescriptor) : boolean;
+ {-Return true if the given index descriptor defines a valid index}
+ procedure RemoveField(aField : Longint);
+ {-Remove a field from the data dictionary's field list}
+ procedure RemoveFile(aFile : Longint);
+ {-Remove a file from the data dictionary; if index file, the
+ relevant indexes are also removed}
+ procedure RemoveIndex(aIndex : Longint);
+ {-Remove an index from the data dictionary's index list}
+
+ {===Validity check routines===}
+ procedure SetValidityCheck(aField : integer;
+ var aExists : boolean;
+ const aVCheck : TffVCheckDescriptor);
+ {-Set a field's validity check record}
+
+ function HasSameFields(aSrcDict : TffDataDictionary;
+ var aBLOBFields : TffPointerList) : boolean;
+ {-Use this method to verify a dictionary has the same field types,
+ sizes, and ordering as a source dictionary. Returns True if the
+ field information matches otherwise returns False. Note that the
+ fields may have different names. If the record contains any
+ BLOB fields, the number of each BLOB field is stored in output
+ parameter aBLOBFields. }
+
+ function HasSameFieldsEx(aSrcDict : TffDataDictionary;
+ aFields : PffLongintArray;
+ aNumFields : integer;
+ var aBLOBFields : TffPointerList) : boolean;
+ {-Use this method to verify a dictionary has the same field types,
+ sizes, and ordering as the specified fields within a source
+ dictionary. Returns True if the field information matches otherwise
+ returns False. Note that the fields may have different names. If the
+ record contains any BLOB fields, the number of each BLOB field is
+ stored in output parameter aBLOBFields. }
+
+ {===record utility routines===}
+ function CheckRequiredRecordFields(aData : PffByteArray) : boolean;
+ {-Given a record buffer, checks that all required fields are
+ non-null}
+ procedure GetRecordField(aField : integer;
+ aData : PffByteArray;
+ var aIsNull: boolean;
+ aValue : pointer);
+ {-Given a record buffer, read the required field; aIsNull is
+ set to true if the field is null (no data is written to
+ aValue)}
+ procedure InitRecord(aData : PffByteArray);
+ {-Given a record buffer, initialize it so that all fields are
+ null}
+ function IsRecordFieldNull(aField : integer;
+ aData : PffByteArray) : boolean;
+ {-Given a record buffer, return true if the field is null}
+ procedure SetRecordField(aField : integer;
+ aData : PffByteArray;
+ aValue : pointer);
+ {-Given a record buffer, write the required field from the
+ buffer pointed to by aValue; if aValue is nil, the field is
+ set to null}
+ procedure SetRecordFieldNull(aField : integer;
+ aData : PffByteArray;
+ aIsNull : boolean);
+ {-Given a record buffer, set the required field to null or
+ non-null. Set the field in the record to binary zeros.}
+
+ procedure SetBaseName(const BN : TffTableName);
+ {-Set the internal table base name - used for error messages}
+
+{Begin !!.11}
+ procedure SetDefaultFieldValue(aData : PffByteArray;
+ const aField : Integer);
+ { If the field has a default value, this method sets the field to that
+ value. }
+{End !!.11}
+
+ procedure SetDefaultFieldValues(aData : PffByteArray);
+ {-Set any null fields to their default field, if the field
+ has a default value}
+
+ property BLOBFileNumber : integer
+ read FBLOBFileNumber;
+ {-The file number of the file that holds the BLOBs}
+ property BlockSize : Longint
+ read GetBlockSize write SetBlockSize;
+ {-The block size of the table to which this dictionary refers;
+ equals FileBlockSize[0] the block size of the base file}
+ property BookmarkSize [aIndexID : integer] : integer
+ read GetBookmarkSize;
+ {-The length of a bookmark for the given index}
+ property DefaultFieldCount : Integer
+ read GetDefaultFldCount;
+ {-Number of fields with default values}
+ property IsEncrypted : boolean
+ read FIsEncrypted write SetIsEncrypted;
+ {-Whether the files comprising the table are encrypted}
+
+ property FieldCount : integer
+ read FFldCount;
+ {-The number of fields in the data dictionary}
+ property FieldDecPl [aField : integer] : Longint
+ read GetFieldDecPl;
+ {-The decimal places value for a given field in the data dictionary}
+ property FieldDesc [aField : integer] : TffDictItemDesc
+ read GetFieldDesc;
+ {-The description of a given field in the data dictionary}
+ property FieldLength [aField : integer] : Longint
+ read GetFieldLength;
+ {-The length in bytes of a given field in the data dictionary}
+ property FieldName [aField : integer] : TffDictItemName
+ read GetFieldName;
+ {-The name of a given field in the data dictionary}
+ property FieldOffset [aField : integer] : Longint
+ read GetFieldOffset;
+ {-The offset of a given field in the record in the data dictionary}
+ property FieldRequired [aField : integer] : boolean
+ read GetFieldRequired;
+ {-Whether the field is required or not}
+ property FieldType [aField : integer] : TffFieldType
+ read GetFieldType;
+ {-The type of a given field in the data dictionary}
+ property FieldUnits [aField : integer] : Longint
+ read GetFieldUnits;
+ {-The units value for a given field in the data dictionary}
+ property FieldVCheck [aField : integer] : PffVCheckDescriptor
+ read GetFieldVCheck;
+ {-The validity check info for a given field}
+
+ property FileBlockSize [aFile : integer] : Longint
+ read GetFileBlockSize;
+ {-The block size of a given file in the data dictionary}
+ property FileCount : integer
+ read FFileCount;
+ {-The number of files in the data dictionary}
+ property FileDesc [aFile : integer] : TffDictItemDesc
+ read GetFileDesc;
+ {-The description of a given file in the data dictionary}
+ property FileDescriptor [aFile : integer] : PffFileDescriptor
+ read GetFileDescriptor;
+ {-The descriptor of a given file in the data dictionary}
+ property FileExt [aFile : integer] : TffExtension
+ read GetFileExt;
+ {-The extension of a given file in the data dictionary}
+ property DiskFileName [aFile : integer] : TffFileNameExt
+ read GetFileNameExt;
+ {-The disk name of a given file in the data dictionary}
+ property FileType [aFile : integer] : TffFileType
+ read GetFileType;
+ {-The type of file: data, index or BLOB}
+ property HasBLOBFields : Boolean {!!.03}
+ read GetHasBLOBs; {!!.03}
+ {-Returns True if the table contains any BLOB fields. } {!!.03}
+ property IndexAllowDups [aIndexID : integer] : boolean
+ read GetIndexAllowDups;
+ {-Whether the given index allows duplicate keys}
+ property IndexIsAscending [aIndexID : integer] : boolean
+ read GetIndexAscend;
+ {-Whether the given index has keys in ascending order}
+ property IndexIsCaseInsensitive [aIndexID : integer] : boolean
+ read GetIndexNoCase;
+ {-Whether the given index has keys in ascending order}
+ property IndexCount : integer
+ read FInxCount;
+ {-The number of indexes in the data dictionary}
+ property IndexDesc [aIndexID : integer] : TffDictItemDesc
+ read GetIndexDesc;
+ {-The description of a given index in the data dictionary}
+ property IndexFileNumber [aIndexID : integer] : Longint
+ read GetIndexFileNumber;
+ {-The descriptor of a given index in the data dictionary}
+ property IndexKeyLength [aIndexID : integer] : Longint
+ read GetIndexKeyLength;
+ {-The key length for the given index}
+ property IndexName [aIndexID : integer] : TffDictItemName
+ read GetIndexName;
+ {-The name of a given field in the data dictionary}
+ property IndexType [aIndexID : integer] : TffIndexType
+ read GetIndexType;
+ {-The type of the given index}
+
+ property RecordLength : Longint
+ read GetRecordLength;
+ {-The length of the physical record for the data dictionary. Includes
+ trailing byte array to identify null fields. }
+ property LogicalRecordLength : Longint
+ read GetBaseRecordLength;
+ {-The length of the logical record for the data dictionary (ie
+ just the total size of the fields. }
+
+ procedure ReadFromStream(S : TStream);
+ procedure WriteToStream(S : TStream);
+
+ end;
+
+{===Key manipulation routines===} {moved here from FFTBBASE}
+procedure FFInitKey(aKey : PffByteArray;
+ aKeyLen : integer;
+ aKeyFldCount : integer);
+function FFIsKeyFieldNull(aKey : PffByteArray;
+ aKeyLen : integer;
+ aKeyFldCount : integer;
+ aKeyFld : integer) : boolean;
+procedure FFSetKeyFieldNonNull(aKey : PffByteArray;
+ aKeyLen : integer;
+ aKeyFldCount : integer;
+ aKeyFld : integer);
+
+implementation
+
+const
+ ffcl_InitialFieldCapacity = 10;
+ { Number of fields dictionary can hold upon creation. The dictionary
+ will expand its capacity as necessary. }
+ ffcl_InitialIndexCapacity = 5;
+ { Number of indices dictionary can hold upon creation. The dictionary
+ will expand its capacity as necessary. }
+
+{===TffDataDictionary================================================}
+constructor TffDataDictionary.Create(aBlockSize : Longint);
+var
+ NewFileDesc : PffFileDescriptor;
+ NewInxDesc : PffIndexDescriptor;
+ SeqAccessName : TffShStr;
+begin
+ inherited Create;
+ FHasBLOBs := fftbUnknown; {!!.03}
+ {verify the block size}
+ if not FFVerifyBlockSize(aBlockSize) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrBadBlockSize,
+ [aBlockSize]);
+ {create the file list}
+ ddFileList := TList.Create;
+ {add the first file name (for the data/data dict file)}
+ NewFileDesc := CreateFileDesc(ffStrResGeneral[ffscMainTableFileDesc],
+ ffc_ExtForData, aBlockSize, ftBaseFile);
+ try
+ NewFileDesc^.fdNumber := 0;
+ ddFileList.Add(pointer(NewFileDesc));
+ FFileCount := 1;
+ except
+ FFFreeMem(NewFileDesc,sizeof(TffFileDescriptor));
+ raise;
+ end;{try..except}
+
+ ddDefFldList := TList.Create;
+
+ {create the field list}
+ FFieldCapacity := ffcl_InitialFieldCapacity;
+ FFGetMem(FieldDescriptor, SizeOf(PffFieldDescriptor) * FFieldCapacity);
+ {create the index list, add index 0: this is the sequential access
+ index}
+
+ FIndexCapacity := ffcl_InitialIndexCapacity;
+ FFGetMem(IndexDescriptor, SizeOf(PffIndexDescriptor) * FIndexCapacity);
+ SeqAccessName := ffStrResGeneral[ffscSeqAccessIndexName];
+ NewInxDesc := CreateUserIndexDesc(SeqAccessName, SeqAccessName, 0,
+ sizeof(TffInt64), false, true, true);
+ try
+ NewInxDesc^.idNumber := 0;
+ IndexDescriptor^[0] := NewInxDesc;
+ FInxCount := 1;
+ except
+ FFFreeMem(NewInxDesc,sizeof(TffIndexDescriptor));
+ raise;
+ end;{try..except}
+
+ FFGetMem(IndexHelpers,
+ SizeOf(TffSrIndexHelper) * ffcl_MaxIndexFlds * FIndexCapacity);
+end;
+{--------}
+destructor TffDataDictionary.Destroy;
+var
+ index : integer;
+ P : pointer;
+ Pfd : PffFieldDescriptor absolute P; {!!.01}
+begin
+
+ if assigned(IndexHelpers) then
+ FFFreeMem(IndexHelpers,
+ FIndexCapacity * ffcl_MaxIndexFlds * SizeOf(TffSrIndexHelper));
+
+ ClearPrim(true);
+
+ for Index := pred(FInxCount) downto 0 do begin
+ P := IndexDescriptor^[index];
+ FFFreeMem(P, sizeof(TffIndexDescriptor));
+ end;
+ FFFreeMem(IndexDescriptor, SizeOf(PffIndexDescriptor) * FIndexCapacity);
+
+ for Index := pred(FFldCount) downto 0 do begin
+ P := FieldDescriptor^[index];
+ if Pfd^.fdVCheck <> nil then {!!.01}
+ FFFreeMem(Pfd^.fdVCheck, sizeof(TffVCheckDescriptor)); {!!.01}
+ FFFreeMem(P, SizeOf(PffFieldDescriptor) * FFieldCapacity);
+ end;
+ FFFreeMem(FieldDescriptor, SizeOf(PffFieldDescriptor) * FFieldCapacity);
+
+ for index := (ddFileList.count - 1) downto 0 do begin
+ P := PffFileDescriptor(ddFileList[index]);
+ FFFreeMem(P, sizeOf(TffFileDescriptor));
+ ddFileList.delete(index);
+ end;
+
+ ddFileList.Free;
+ ddDefFldList.Free;
+ inherited Destroy;
+end;
+{--------}
+class function TffDataDictionary.NewInstance: TObject;
+begin
+ FFGetMem(Result, InstanceSize);
+ InitInstance(Result);
+end;
+{--------}
+procedure TffDataDictionary.FreeInstance;
+var
+ Temp : pointer;
+begin
+ Temp := Self;
+ FFFreeMem(Temp, InstanceSize);
+end;
+{--------}
+function TffDataDictionary.AddFile(const aDesc : TffDictItemDesc;
+ const aExtension : TffExtension;
+ aBlockSize : Longint;
+ aFileType : TffFileType) : integer;
+var
+ NewDesc : PffFileDescriptor;
+ i : integer;
+begin
+ {can't be done in readonly mode}
+ if ddReadOnly then
+ FFRaiseException(EffException, ffStrResGeneral, fferrDictReadOnly, [FBaseName]);
+ {verify the extension}
+ if not FFVerifyExtension(aExtension) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrBadExtension, [FBaseName, aExtension]);
+ {verify the block size}
+ if not FFVerifyBlockSize(aBlockSize) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrBadBlockSize, [aBlockSize]);
+ {if a base file type, check to see whether file 0 has been added
+ already}
+ if (aFileType = ftBaseFile) then
+ if (FFileCount > 0) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrDataFileDefd, [FBaseName]);
+ {check to see whether the extension has been used already}
+ for i := 0 to pred(FFileCount) do
+ if (PffFileDescriptor(ddFileList[i])^.fdExtension = aExtension) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrDupExtension, [FBaseName, aExtension]);
+ {if a BLOB file type check to see whether we have one already; we
+ can ignore file 0: it's the base file (ie data & dictionary)}
+ if (aFileType = ftBLOBFile) then
+ if (BLOBFileNumber <> 0) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrBLOBFileDefd, [FBaseName]);
+ {add a new file descriptor}
+ NewDesc := CreateFileDesc(aDesc, aExtension, aBlockSize, aFileType);
+ try
+ Result := FFileCount;
+ NewDesc^.fdNumber := FFileCount;
+ if (aFileType = ftBLOBFile) then
+ FBLOBFileNumber := FFileCount;
+ ddFileList.Add(pointer(NewDesc));
+ inc(FFileCount);
+ except
+ FFFreeMem(NewDesc,sizeof(TffFileDescriptor));
+ raise;
+ end;{try..except}
+end;
+{--------}
+procedure TffDataDictionary.AddIndex(const aIdent : TffDictItemName;
+ const aDesc : TffDictItemDesc;
+ aFile : integer;
+ aFldCount : integer;
+ const aFldList : TffFieldList;
+ const aFldIHList : TffFieldIHList;
+ aAllowDups : boolean;
+ aAscend : boolean;
+ aCaseInsens: boolean);
+var
+ NewDesc : PffIndexDescriptor;
+ i : integer;
+begin
+ {check for a duplicate index name}
+ if (GetIndexFromName(aIdent) <> -1) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrDupIndexName,
+ [FBaseName, aIdent]);
+ {check the file number}
+ if (0 > aFile) or (aFile >= FFileCount) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrBadFileNumber,
+ [FBaseName, aFile]);
+ {check all field numbers in field list}
+ for i := 0 to pred(aFldCount) do
+ if (aFldList[i] < 0) or (aFldList[i] >= FFldCount) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrBadFieldRef,
+ [FBaseName, aFldList[i]]);
+ {create the new index}
+ NewDesc := CreateIndexDesc(aIdent, aDesc, aFile, aFldCount, aFldList,
+ aFldIHList, aAllowDups, aAscend, aCaseInsens);
+ try
+ NewDesc^.idNumber := FInxCount;
+ IndexDescriptor^[FInxCount] := NewDesc;
+ inc(FInxCount);
+ { Have we reached our index capacity? }
+ if FInxCount = FIndexCapacity then
+ ddExpandIndexArray(0);
+ except
+ FFFreeMem(NewDesc,sizeof(TffIndexDescriptor));
+ raise;
+ end;{try..except}
+end;
+{--------}
+procedure TffDataDictionary.AddUserIndex(const aIdent : TffDictItemName;
+ const aDesc : TffDictItemDesc;
+ aFile : integer;
+ aKeyLength : integer;
+ aAllowDups : boolean;
+ aAscend : boolean;
+ aCaseInsens: boolean);
+var
+ NewDesc : PffIndexDescriptor;
+begin
+ {can't be done in readonly mode}
+ if ddReadOnly then
+ FFRaiseException(EffException, ffStrResGeneral, fferrDictReadOnly, [FBaseName]);
+ {check the file number}
+ if (0 > aFile) or (aFile >= FFileCount) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrBadFileNumber, [FBaseName, aFile]);
+ {check the key length}
+ if not FFVerifyKeyLength(aKeyLength) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrKeyTooLong, [aKeyLength]);
+ {create the new index}
+ NewDesc := CreateUserIndexDesc(aIdent, aDesc, aFile, aKeyLength, aAllowDups, aAscend, aCaseInsens);
+ try
+ NewDesc^.idNumber := FInxCount;
+ IndexDescriptor^[FInxCount] := NewDesc;
+ inc(FInxCount);
+ { Have we reached our index capacity? }
+ if FInxCount = FIndexCapacity then
+ ddExpandIndexArray(0);
+ except
+ FFFreeMem(NewDesc,sizeof(TffIndexDescriptor));
+ raise;
+ end;{try..except}
+end;
+{--------}
+procedure TffDataDictionary.AddField(const aIdent : TffDictItemName;
+ const aDesc : TffDictItemDesc;
+ aType : TffFieldType;
+ aUnits : Integer;
+ aDecPl : Integer;
+ aReqFld : Boolean;
+ const aValCheck : PffVCheckDescriptor);
+var
+ NewDesc : PffFieldDescriptor;
+ TempDesc : PffFieldDescriptor;
+begin
+ {can't be done in readonly mode}
+ if ddReadOnly then
+ FFRaiseException(EffException, ffStrResGeneral, fferrDictReadOnly, [FBaseName]);
+ {check for a duplicate field name}
+ if (GetFieldFromName(aIdent) <> -1) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrDupFieldName, [FBaseName, aIdent]);
+ {create it}
+ NewDesc := CreateFieldDesc(aIdent, aDesc, aType, aUnits, aDecPl, aReqFld, aValCheck);
+ try
+ NewDesc^.fdNumber := FFldCount;
+ if (FFldCount > 0) then begin
+ TempDesc := FieldDescriptor^[pred(FFldCount)];
+ with TempDesc^ do
+ NewDesc^.fdOffset := fdOffset + fdLength;
+ end;
+ FieldDescriptor^[FFldCount] := NewDesc;
+ inc(FFldCount);
+ { Have we reached our field capacity? }
+ if FFldCount = FFieldCapacity then
+ { Yes, expand our field array. }
+ ddExpandFieldArray(0);
+ with NewDesc^ do
+ FLogRecLen := fdOffset + fdLength;
+ FHasBLOBs := fftbUnknown; {!!.03}
+ except
+ FFFreeMem(NewDesc,sizeof(TffFieldDescriptor));
+ raise;
+ end;{try..except}
+end;
+{--------}
+procedure TffDataDictionary.AnsiStringWriter(const aString : string; {!!.05 - Added}
+ aWriter : TWriter);
+var
+ TempInt : Integer;
+begin
+ TempInt := Integer(vaString);
+ aWriter.Write(TempInt, SizeOf(vaString));
+
+ TempInt := Length(aString);
+ aWriter.Write(TempInt, SizeOf(Byte));
+
+ if (TempInt > 0) then
+ aWriter.Write(aString[1], TempInt);
+end;
+{--------} {!!.05 - End Added}
+procedure TffDataDictionary.Assign(Source: TPersistent);
+var
+// CheckVal : PffVCheckDescriptor; {!!.01}
+ item : integer;
+ SelfFldDesc : PffFieldDescriptor;
+ SrcDict : TffDataDictionary absolute Source;
+begin
+ {can't be done in readonly mode}
+ if ddReadOnly then
+ FFRaiseException(EffException, ffStrResGeneral, fferrDictReadOnly, [FBaseName]);
+ {Source must be one of us}
+ if not (Source is TffDataDictionary) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrNotADict, [FBaseName]);
+ {firstly clear our own lists (remove the base file item as well)}
+ ClearPrim(true);
+ {copy over the encrypted mode}
+ Self.FIsEncrypted := TffDataDictionary(Source).IsEncrypted;
+ { Now duplicate the items in the Source's lists. }
+ try
+ { The file list first; do include index 0. }
+ for item := 0 to pred(SrcDict.FFileCount) do
+ with PffFileDescriptor(SrcDict.ddFileList[item])^ do
+ Self.AddFile(fdDesc, fdExtension, fdBlockSize, fdType);
+
+ { The field list next. }
+ FHasBLOBs := fftbUnknown; {!!.03}
+ for item := 0 to pred(SrcDict.FFldCount) do
+ with SrcDict.FieldDescriptor^[Item]^ do begin
+ if Assigned(fdVCheck) then
+ Self.AddField(fdName, fdDesc, fdType, fdUnits, fdDecPl, fdRequired,
+ fdVCheck)
+ else begin
+// FFGetZeroMem(CheckVal, sizeof(TffVCheckDescriptor)); {Deleted !!.01}
+ Self.AddField(fdName, fdDesc, fdType, fdUnits, fdDecPl, fdRequired,
+ nil) {!!.01}
+ end;
+ if assigned(fdVCheck) then begin
+ SelfFldDesc := Self.FieldDescriptor^[item];
+ if SelfFldDesc^.fdVCheck = nil then {!!.06}
+ FFGetMem(SelfFldDesc^.fdVCheck, sizeOf(TffVCheckDescriptor)); {!!.06}
+ Move(fdVCheck^, SelfFldDesc^.fdVCheck^, sizeof(fdVCheck^));
+ end;
+ end;
+
+ { The index list next; skip index 0. }
+ for item := 1 to pred(SrcDict.FInxCount) do
+ with SrcDict.IndexDescriptor^[item]^ do
+ if (idCount <> -1) then
+ Self.AddIndex(idName, idDesc, idFile, idCount,
+ idFields, idFieldIHlprs, idDups, idAscend, idNoCase)
+ else
+ Self.AddUserIndex(idName, idDesc, idFile, idKeyLen, idDups, idAscend, idNoCase)
+ except
+ ClearPrim(true);
+ raise;
+ end;{try..except}
+end;
+{--------}
+procedure TffDataDictionary.BindIndexHelpers;
+var
+ i,j : Integer;
+begin
+ for i:= 0 to pred(IndexCount) do
+ with IndexDescriptor^[i]^do
+ if idCount>=0 then begin
+ for j:= 0 to Pred(idCount) do
+ IndexHelpers[i,j] :=
+ TffSrIndexHelper.FindHelper(idFieldIHlprs[j],GetFieldType(idFields[j]));
+ end;
+end;
+{--------}
+function TffDataDictionary.CheckRequiredRecordFields(aData : PffByteArray) : Boolean;
+var
+ FieldInx : integer;
+ BS : PffByteArray;
+begin
+ {note: it's probably faster to find all the null fields and then
+ check their required status, rather than the other way round
+ (getting a field descriptor requires a whole lot more calls
+ than checking a bit) but it does depend on a lotta factors.}
+ Result := false;
+ if (aData = nil) then
+ Exit;
+ BS := PffByteArray(@aData^[FLogRecLen]);
+ for FieldInx := 0 to pred(FFldCount) do begin
+ if FFIsBitSet(BS, FieldInx) then
+ if FieldDescriptor^[FieldInx]^.fdRequired then
+ Exit;
+ end;
+ Result := true;
+end;
+{--------}
+procedure TffDataDictionary.CheckValid;
+var
+ item : integer;
+ i : integer;
+ Fld : PffFieldDescriptor;
+ Indx : PffIndexDescriptor;
+begin
+ if (FFldCount <= 0) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrNoFields, [FBaseName]);
+ if (RecordLength > (BlockSize - ffc_BlockHeaderSizeData - sizeof(Longint))) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrRecTooLong, [FBaseName]);
+ if (IndexCount > ffcl_MaxIndexes) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrMaxIndexes, [FBaseName]);
+ {check all field numbers in all indexes, recalc key lengths}
+ if (FInxCount > 1) then
+ for item := 1 to pred(FInxCount) do
+ with IndexDescriptor^[item]^ do
+ if (idCount <> -1) then begin
+ if (idCount = 0) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrNoFieldsInKey, [FBaseName]);
+ idKeyLen := 0;
+ for i := 0 to pred(idCount) do begin
+ if (idFields[i] < 0) or (idFields[i] >= FFldCount) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrBadFieldRef, [FBaseName, idFields[i]]);
+ inc(idKeyLen, FieldDescriptor^[idFields[i]]^.fdLength);
+ end;
+ inc(idKeyLen, (idCount + 7) div 8);
+ end;
+ {field names must be unique}
+ for item := 0 to pred(FFldCount) do begin
+ Fld := FieldDescriptor^[item];
+ if (GetFieldFromName(Fld^.fdName) <> item) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrDupFieldName, [FBaseName, Fld^.fdName]);
+ end;
+ {index names must be unique}
+ if (FInxCount > 1) then
+ for item := 1 to pred(FInxCount) do begin
+ Indx := IndexDescriptor^[item];
+ if (GetIndexFromName(Indx^.idName) <> item) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrDupIndexName, [FBaseName, Indx^.idName]);
+ end;
+end;
+{--------}
+procedure TffDataDictionary.Clear;
+begin
+ {can't be done in readonly mode}
+ if ddReadOnly then
+ FFRaiseException(EffException, ffStrResGeneral, fferrDictReadOnly, [FBaseName]);
+ ClearPrim(false);
+end;
+{--------}
+procedure TffDataDictionary.ClearPrim(InclFileZero : boolean);
+var
+ item : integer;
+ BaseFileDesc : PffFileDescriptor;
+ TmpIndexDesc : PffIndexDescriptor;
+ FldDesc : PffFieldDescriptor;
+begin
+ {clear the entire file list EXCEPT item zero}
+ for item := 1 to pred(FFileCount) do begin
+ BaseFileDesc := PffFileDescriptor(ddFileList[item]);
+ FFFreeMem(BaseFileDesc, sizeof(TffFileDescriptor));
+ end;
+ {decide what to do about item zero: save it or dispose of it}
+ if InclFileZero and (FFileCount > 0) then begin
+ BaseFileDesc := PffFileDescriptor(ddFileList[0]);
+ FFFreeMem(BaseFileDesc, sizeof(TffFileDescriptor));
+ ddFileList.Clear;
+ FFileCount := 0;
+ end
+ else {don't dispose of file 0} begin
+ BaseFileDesc := PffFileDescriptor(ddFileList[0]);
+ ddFileList.Clear;
+ ddFileList.Add(pointer(BaseFileDesc));
+ FFileCount := 1;
+ end;
+ {clear the entire field list}
+ for item := 0 to pred(FFldCount) do begin
+ FldDesc := FieldDescriptor^[item];
+ if (FldDesc^.fdVCheck <> nil) then
+ FFFreeMem(FldDesc^.fdVCheck, sizeOf(TffVCheckDescriptor));
+ FFFreeMem(FldDesc, sizeOf(TffFieldDescriptor));
+ end;
+ FFldCount := 0;
+ FLogRecLen := 0;
+ {clear the entire index list EXCEPT for the first item}
+ for item := 1 to pred(FInxCount) do begin
+ TmpIndexDesc := IndexDescriptor^[item];
+ FFFreeMem(TmpIndexDesc, sizeOf(TffIndexDescriptor));
+ IndexDescriptor^[item] := nil;
+ end;
+ FInxCount := 1;
+
+ {clear out any old default field values} {!!.03}
+ ddDefFldList.Clear; {!!.03}
+ FHasBLOBs := fftbUnknown; {!!.03}
+end;
+{--------}
+function TffDataDictionary.CreateFieldDesc(const aIdent : TffDictItemName;
+ const aDesc : TffDictItemDesc;
+ aType : TffFieldType;
+ aUnits : Integer;
+ aDecPl : Integer;
+ aReqFld : Boolean;
+ const aValCheck : PffVCheckDescriptor)
+ : PffFieldDescriptor;
+var
+ FT : Integer;
+begin
+ if (aType = fftAutoInc) then
+ aReqFld := false;
+ FFGetZeroMem(Result, sizeof(TffFieldDescriptor));
+ with Result^ do begin
+ fdName := aIdent;
+ fdDesc := aDesc;
+ fdType := aType;
+ fdRequired := aReqFld;
+ case aType of
+ fftBoolean :
+ begin
+ fdUnits := 0;
+ fdDecPl := 0;
+ fdLength := sizeof(Boolean);
+ CheckForDefault(aValCheck, Result);
+ end;
+ fftChar :
+ begin
+ fdUnits := 1;
+ fdDecPl := 0;
+ fdLength := sizeof(AnsiChar);
+ CheckForDefault(aValCheck, Result);
+ end;
+ fftWideChar :
+ begin
+ fdUnits := 1;
+ fdDecPl := 0;
+ fdLength := sizeof(WideChar);
+ CheckForDefault(aValCheck, Result);
+ end;
+ fftByte :
+ begin
+ if (aUnits < 0) or (aUnits > 3) then
+ fdUnits := 3
+ else
+ fdUnits := aUnits;
+ fdDecPl := 0;
+ fdLength := sizeof(byte);
+ CheckForDefault(aValCheck, Result);
+ end;
+ fftWord16 :
+ begin
+ if (aUnits < 0) or (aUnits > 5) then
+ fdUnits := 5
+ else
+ fdUnits := aUnits;
+ fdDecPl := 0;
+ fdLength := sizeof(TffWord16);
+ CheckForDefault(aValCheck, Result);
+ end;
+ fftWord32 :
+ begin
+ if (aUnits < 0) or (aUnits > 10) then
+ fdUnits := 10
+ else
+ fdUnits := aUnits;
+ fdDecPl := 0;
+ fdLength := sizeof(TffWord32);
+ CheckForDefault(aValCheck, Result);
+ end;
+ fftInt8 :
+ begin
+ if (aUnits < 0) or (aUnits > 3) then
+ fdUnits := 3
+ else
+ fdUnits := aUnits;
+ fdDecPl := 0;
+ fdLength := sizeof(shortint);
+ CheckForDefault(aValCheck, Result);
+ end;
+ fftInt16 :
+ begin
+ if (aUnits < 0) or (aUnits > 5) then
+ fdUnits := 5
+ else
+ fdUnits := aUnits;
+ fdDecPl := 0;
+ fdLength := sizeof(smallint);
+ CheckForDefault(aValCheck, Result);
+ end;
+ fftInt32 :
+ begin
+ if (aUnits < 0) or (aUnits > 10) then
+ fdUnits := 10
+ else
+ fdUnits := aUnits;
+ fdDecPl := 0;
+ fdLength := sizeof(Longint);
+ CheckForDefault(aValCheck, Result);
+ end;
+ fftAutoInc :
+ begin
+ fdUnits := 10;
+ fdDecPl := 0;
+ fdLength := sizeof(Longint);
+ end;
+ fftSingle :
+ begin
+ fdUnits := aUnits;
+ fdDecPl := aDecPl;
+ fdLength := sizeof(single);
+ CheckForDefault(aValCheck, Result);
+ end;
+ fftDouble :
+ begin
+ fdUnits := aUnits;
+ fdDecPl := aDecPl;
+ fdLength := sizeof(double);
+ CheckForDefault(aValCheck, Result);
+ end;
+ fftExtended :
+ begin
+ fdUnits := aUnits;
+ fdDecPl := aDecPl;
+ fdLength := sizeof(extended);
+ CheckForDefault(aValCheck, Result);
+ end;
+ fftComp :
+ begin
+ fdUnits := aUnits;
+ fdDecPl := aDecPl;
+ fdLength := sizeof(comp);
+ CheckForDefault(aValCheck, Result);
+ end;
+ fftCurrency :
+ begin
+ fdUnits := aUnits;
+ fdDecPl := aDecPl;
+ fdLength := sizeof(comp);
+ CheckForDefault(aValCheck, Result);
+ end;
+ fftStDate :
+ begin
+ fdUnits := 0;
+ fdDecPl := 0;
+ fdLength := sizeof(Longint);
+ CheckForDefault(aValCheck, Result);
+ end;
+ fftStTime :
+ begin
+ fdUnits := 0;
+ fdDecPl := 0;
+ fdLength := sizeof(Longint);
+ CheckForDefault(aValCheck, Result);
+ end;
+ fftDateTime :
+ begin
+ fdUnits := 0;
+ fdDecPl := 0;
+ fdLength := sizeof(double);
+ CheckForDefault(aValCheck, Result);
+ end;
+ fftBLOB,
+ fftBLOBMemo,
+ fftBLOBFmtMemo,
+ fftBLOBOLEObj,
+ fftBLOBGraphic,
+ fftBLOBDBSOLEObj,
+ fftBLOBTypedBin,
+ fftBLOBFile :
+ begin
+ fdUnits := 0;
+ fdDecPl := 0;
+ fdLength := sizeof(TffInt64);
+ end;
+ fftByteArray :
+ begin
+ fdUnits := aUnits;
+ fdDecPl := 0;
+ fdLength := aUnits;
+ end;
+ fftShortString, fftShortAnsiStr, fftNullString, fftNullAnsiStr :
+ begin
+ fdUnits := aUnits;
+ fdDecPl := 0;
+ fdLength := (aUnits + 1) * sizeof(AnsiChar);
+ CheckForDefault(aValCheck, Result);
+ end;
+ fftWideString :
+ begin
+ fdUnits := aUnits;
+ fdDecPl := 0;
+ fdLength := (aUnits + 1) * sizeof(WideChar);
+ CheckForDefault(aValCheck, Result);
+ end;
+ else
+ FT := ord(aType);
+ FFRaiseException(EffException, ffStrResGeneral, fferrBadFieldType, [FT]);
+ end;{case}
+ end;
+end;
+{--------}
+function TffDataDictionary.CreateFileDesc(const aDesc : TffDictItemDesc;
+ const aExtension : TffExtension;
+ aBlockSize : Longint;
+ aType : TffFileType)
+ : PffFileDescriptor;
+begin
+ FFGetZeroMem(Result, sizeof(TffFileDescriptor));
+ with Result^ do
+ begin
+ fdDesc := aDesc;
+ fdExtension := aExtension;
+ fdBlockSize := aBlockSize;
+ fdType := aType;
+ end;
+end;
+{--------}
+function TffDataDictionary.CreateIndexDesc(const aIdent : TffDictItemName;
+ const aDesc : TffDictItemDesc;
+ aFile : integer;
+ aFldCount : integer;
+ const aFldList : TffFieldList;
+ const aFldIHList : TffFieldIHList;
+ aAllowDups : boolean;
+ aAscend : boolean;
+ aNoCase : boolean)
+ : PffIndexDescriptor;
+var
+ i : integer;
+begin
+ FFGetZeroMem(Result, sizeof(TffIndexDescriptor));
+ with Result^ do begin
+ idName := aIdent;
+ idDesc := aDesc;
+ idFile := aFile;
+ idCount := aFldCount;
+ idDups := aAllowDups;
+ idKeyLen := 0;
+ for i := 0 to pred(aFldCount) do begin
+ idFields[i] := aFldList[i];
+ inc(idKeyLen, FieldDescriptor^[aFldList[i]]^.fdLength);
+ end;
+ for i := 0 to pred(aFldCount) do
+ idFieldIHlprs[i] := aFldIHList[i];
+ inc(idKeyLen, {the key length itself}
+ (aFldCount + 7) div 8); {the bit array for nulls}
+ idAscend := aAscend;
+ idNoCase := aNoCase;
+ end;
+end;
+{--------}
+function TffDataDictionary.CreateUserIndexDesc(const aIdent : TffDictItemName;
+ const aDesc : TffDictItemDesc;
+ aFile : integer;
+ aKeyLength : integer;
+ aAllowDups : boolean;
+ aAscend : boolean;
+ aNoCase : boolean)
+ : PffIndexDescriptor;
+begin
+ FFGetZeroMem(Result, sizeof(TffIndexDescriptor));
+ with Result^ do begin
+ idName := aIdent;
+ idFile := aFile;
+ idDups := aAllowDups;
+ idCount := -1;
+ idKeyLen := aKeyLength;
+ idAscend := aAscend;
+ idNoCase := aNoCase;
+ end;
+end;
+{--------}
+procedure TffDataDictionary.ddExpandFieldArray(const minCapacity : Longint);
+var
+ OldCapacity : Longint;
+begin
+ OldCapacity := FFieldCapacity;
+{Begin !!.02}
+ if minCapacity = 0 then
+ inc(FFieldCapacity, ffcl_InitialFieldCapacity * 2)
+ else if FFieldCapacity = minCapacity then
+ Exit
+ else
+ FFieldCapacity := minCapacity;
+{End !!.02}
+ FFReallocMem(FieldDescriptor, SizeOf(PffFieldDescriptor) * OldCapacity,
+ SizeOf(PffFieldDescriptor) * FFieldCapacity);
+end;
+{--------}
+procedure TffDataDictionary.ddExpandIndexArray(const minCapacity : Longint);
+var
+ OldCapacity : Longint;
+begin
+ OldCapacity := FIndexCapacity;
+{Begin !!.02}
+ if minCapacity = 0 then
+ inc(FIndexCapacity, ffcl_InitialIndexCapacity * 2)
+ else if FIndexCapacity = minCapacity then
+ Exit
+ else
+ FIndexCapacity := minCapacity;
+{End !!.02}
+ FFReallocMem(IndexDescriptor, SizeOf(PffIndexDescriptor) * OldCapacity,
+ SizeOf(PffIndexDescriptor) * FIndexCapacity);
+ FFReallocMem(IndexHelpers,
+ SizeOf(TffSrIndexHelper) * ffcl_MaxIndexFlds * OldCapacity,
+ SizeOf(TffSrIndexHelper) * ffcl_MaxIndexFlds * FIndexCapacity);
+end;
+{--------}
+procedure TffDataDictionary.ExtractKey(aIndexID : integer;
+ aData : PffByteArray;
+ aKey : PffByteArray);
+var
+ KeyOffset : integer;
+ FieldNumber : integer;
+begin
+ KeyOffset := 0;
+ with IndexDescriptor^[aIndexID]^ do begin
+ {clear the entire key - sets all fields to null as well}
+ FFInitKey(aKey, idKeyLen, idCount);
+ {now build it}
+ for FieldNumber := 0 to pred(idCount) do begin
+ with FieldDescriptor^[idFields[FieldNumber]]^ do begin
+ if not IsRecordFieldNull(idFields[FieldNumber], aData) then begin
+ Move(aData^[fdOffset], aKey^[KeyOffset], fdLength);
+ FFSetKeyFieldNonNull(aKey, idKeyLen, idCount, FieldNumber);
+ end;
+ inc(KeyOffset, fdLength);
+ end;
+ end;
+ end;
+end;
+{--------}
+function TffDataDictionary.GetBaseRecordLength : Longint;
+begin
+ { A record must be at last ffcl_MinRecordLength bytes in length. This
+ is because we need that many bytes in order to store the next deleted
+ record when the record becomes part of the deleted record chain. }
+ Result := FFMaxL(FLogRecLen, ffcl_MinRecordLength);
+end;
+{--------}
+function TffDataDictionary.GetBlockSize : Longint;
+begin
+ if (FFileCount > 0) then
+ Result := PffFileDescriptor(ddFileList.Items[0])^.fdBlockSize
+ else
+ Result := 4096;
+end;
+{--------}
+function TffDataDictionary.GetBookmarkSize(aIndexID : integer) : integer;
+begin
+ if not ((0 <= aIndexID) and (aIndexID < FInxCount)) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aIndexID]);
+ Result := ffcl_FixedBookmarkSize + IndexDescriptor^[aIndexID]^.idKeyLen;
+end;
+{--------}
+function TffDataDictionary.GetFieldDecPl(aField : integer) : Longint;
+begin
+ if (aField < 0) or (aField >= FFldCount) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aField]);
+ Result := FieldDescriptor^[aField]^.fdDecPl;
+end;
+{--------}
+function TffDataDictionary.GetFieldDesc(aField : integer) : TffDictItemDesc;
+begin
+ if (aField < 0) or (aField >= FFldCount) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aField]);
+ Result := FieldDescriptor^[aField]^.fdDesc;
+end;
+{--------}
+function TffDataDictionary.GetFieldFromName(const aFieldName : TffDictItemName) : integer;
+begin
+ for Result := 0 to pred(FFldCount) do
+ if (FFCmpShStrUC(aFieldName,
+ FieldDescriptor^[Result]^.fdName,
+ 255) = 0) then
+ Exit;
+ Result := -1;
+end;
+{--------}
+function TffDataDictionary.GetFieldLength(aField : integer) : Longint;
+begin
+ if (aField < 0) or (aField >= FFldCount) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aField]);
+ Result := FieldDescriptor^[aField]^.fdLength;
+end;
+{--------}
+function TffDataDictionary.GetFieldName(aField : integer) : TffDictItemName;
+begin
+ if (aField < 0) or (aField >= FFldCount) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aField]);
+ Result := FieldDescriptor^[aField]^.fdName;
+end;
+{--------}
+function TffDataDictionary.GetFieldOffset(aField : integer) : Longint;
+begin
+ if (aField < 0) or (aField >= FFldCount) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aField]);
+ Result := FieldDescriptor^[aField]^.fdOffset;
+end;
+{--------}
+function TffDataDictionary.GetFieldRequired(aField : integer) : boolean;
+begin
+ if (aField < 0) or (aField >= FFldCount) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aField]);
+ Result := FieldDescriptor^[aField]^.fdRequired;
+end;
+{--------}
+function TffDataDictionary.GetFieldType(aField : integer) : TffFieldType;
+begin
+ if (aField < 0) or (aField >= FFldCount) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aField]);
+ Result := FieldDescriptor^[aField]^.fdType;
+end;
+{--------}
+function TffDataDictionary.GetFieldUnits(aField : integer) : Longint;
+begin
+ if (aField < 0) or (aField >= FFldCount) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aField]);
+ Result := FieldDescriptor^[aField]^.fdUnits;
+end;
+{--------}
+function TffDataDictionary.GetFieldVCheck(aField : integer) : PffVCheckDescriptor;
+begin
+ if (aField < 0) or (aField >= FFldCount) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aField]);
+ Result := FieldDescriptor^[aField]^.fdVCheck;
+end;
+{--------}
+function TffDataDictionary.GetFileBlockSize(aFile : integer) : Longint;
+begin
+ if (aFile < 0) or (aFile >= FFileCount) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aFile]);
+ Result := PffFileDescriptor(ddFileList.Items[aFile])^.fdBlockSize;
+end;
+{--------}
+function TffDataDictionary.GetFileDesc(aFile : integer) : TffDictItemDesc;
+begin
+ if (aFile < 0) or (aFile >= FFileCount) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aFile]);
+ Result := PffFileDescriptor(ddFileList.Items[aFile])^.fdDesc;
+end;
+{--------}
+function TffDataDictionary.GetFileDescriptor(aFile : integer) : PffFileDescriptor;
+begin
+ if (aFile < 0) or (aFile >= FFileCount) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aFile]);
+ Result := PffFileDescriptor(ddFileList.Items[aFile]);
+end;
+{--------}
+function TffDataDictionary.GetFileExt(aFile : integer) : TffExtension;
+begin
+ if (aFile < 0) or (aFile >= FFileCount) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aFile]);
+ Result := PffFileDescriptor(ddFileList.Items[aFile])^.fdExtension;
+end;
+{--------}
+function TffDataDictionary.GetFileNameExt(aFile : integer) : TffFileNameExt;
+var
+ Temp : PffFileDescriptor;
+begin
+ if (aFile < 0) or (aFile >= FFileCount) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aFile]);
+ Temp := PffFileDescriptor(ddFileList.Items[aFile]);
+ Result := FFMakeFileNameExt(FBaseName, Temp^.fdExtension);
+end;
+{--------}
+function TffDataDictionary.GetFileType(aFile : integer) : TffFileType;
+begin
+ if (aFile < 0) or (aFile >= FFileCount) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aFile]);
+ Result := PffFileDescriptor(ddFileList.Items[aFile])^.fdType;
+end;
+{Begin !!.03}
+{--------}
+function TffDataDictionary.GetHasBLOBs : Boolean;
+var
+ Index : Integer;
+ P : PffFieldDescriptor;
+begin
+ if FHasBLOBs = fftbUnknown then begin
+ FHasBLOBs := fftbFalse;
+ for Index := 0 to Pred(FFldCount) do begin
+ P := FieldDescriptor^[index];
+ if P^.fdType in [fftBLOB..fftBLOBFile] then begin
+ FHasBLOBs := fftbTrue;
+ Break;
+ end; { if }
+ end; { for }
+ end; { if }
+ Result := (FHasBLOBs = fftbTrue);
+end;
+{End !!.03}
+{--------}
+function TffDataDictionary.GetIndexAllowDups(aIndexID : integer) : boolean;
+begin
+ if not ((0 <= aIndexID) and (aIndexID < FInxCount)) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aIndexID]);
+ Result := IndexDescriptor^[aIndexID]^.idDups;
+end;
+{--------}
+function TffDataDictionary.GetIndexAscend(aIndexID : integer) : boolean;
+begin
+ if not ((0 <= aIndexID) and (aIndexID < FInxCount)) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aIndexID]);
+ Result := IndexDescriptor^[aIndexID]^.idAscend;
+end;
+{--------}
+function TffDataDictionary.GetIndexDesc(aIndexID : integer) : TffDictItemDesc;
+begin
+ if not ((0 <= aIndexID) and (aIndexID < FInxCount)) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aIndexID]);
+ Result := IndexDescriptor^[aIndexID]^.idDesc;
+end;
+{--------}
+function TffDataDictionary.GetIndexFileNumber(aIndexID : integer) : Longint;
+begin
+ if not ((0 <= aIndexID) and (aIndexID < FInxCount)) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aIndexID]);
+ Result := IndexDescriptor^[aIndexId]^.idFile;
+end;
+{--------}
+function TffDataDictionary.GetIndexFromName(const aIndexName : TffDictItemName) : integer;
+begin
+ for Result := 0 to pred(FInxCount) do
+ if (FFCmpShStrUC(aIndexName,
+ indexDescriptor^[Result]^.idName,
+ 255) = 0) then
+ Exit;
+ Result := -1;
+end;
+{--------}
+function TffDataDictionary.GetIndexKeyLength(aIndexID : integer) : Longint;
+begin
+ if not ((0 <= aIndexID) and (aIndexID < FInxCount)) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aIndexID]);
+ Result := IndexDescriptor^[aIndexID]^.idKeyLen;
+end;
+{--------}
+function TffDataDictionary.GetIndexName(aIndexID : integer) : TffDictItemName;
+begin
+ if not ((0 <= aIndexID) and (aIndexID < FInxCount)) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aIndexID]);
+ Result := IndexDescriptor^[aIndexID]^.idName;
+end;
+{--------}
+function TffDataDictionary.GetIndexNoCase(aIndexID : integer) : boolean;
+begin
+ if not ((0 <= aIndexID) and (aIndexID < FInxCount)) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aIndexID]);
+ Result := IndexDescriptor^[aIndexID]^.idNoCase;
+end;
+{--------}
+function TffDataDictionary.GetIndexType(aIndexID : integer) : TffIndexType;
+begin
+ if not ((0 <= aIndexID) and (aIndexID < FInxCount)) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aIndexID]);
+ Result := TffIndexType(IndexDescriptor^[aIndexID]^.idCount = -1);
+end;
+{--------}
+procedure TffDataDictionary.GetRecordField(aField : integer;
+ aData : PffByteArray;
+ var aIsNull: boolean;
+ aValue : pointer);
+begin
+ aIsNull := IsRecordFieldNull(aField, aData);
+ if (not aIsNull) and (aValue <> nil) then
+ with FieldDescriptor^[aField]^ do
+ Move(aData^[fdOffset], aValue^, fdLength);
+end;
+{--------}
+function TffDataDictionary.GetRecordLength : Longint;
+begin
+ Result := GetBaseRecordLength + {the fields themselves}
+ ((FFldCount + 7) div 8); {the bit array for nulls}
+end;
+{--------}
+function TffDataDictionary.HasAutoIncField(var aField : integer) : boolean;
+begin
+ Result := true;
+ aField := 0;
+ while (aField < FFldCount) do begin
+ if FieldDescriptor^[aField]^.fdType = fftAutoInc then
+ Exit;
+ inc(aField);
+ end;
+ Result := false;
+end;
+{--------}
+function TffDataDictionary.HasSameFields(aSrcDict : TffDataDictionary;
+ var aBLOBFields : TffPointerList) : boolean;
+var
+ anIndex : integer;
+begin
+ Result := False;
+ if FieldCount <> aSrcDict.FieldCount then
+ Exit;
+ aBLOBFields.Empty;
+
+ for anIndex := 0 to pred(FieldCount) do begin
+ { Must have same field type, length, decimal places, & units. }
+ Result := (FieldLength[anIndex] = aSrcDict.FieldLength[anIndex]) and
+ (FieldType[anIndex] = aSrcDict.FieldType[anIndex]) and
+ (FieldDecPl[anIndex] = aSrcDict.FieldDecPl[anIndex]) and
+ (FieldUnits[anIndex] = aSrcDict.FieldUnits[anIndex]);
+ if (not Result) then
+ Exit;
+ if FieldType[anIndex] in [fftBLOB..fftBLOBFile] then
+ aBLOBFields.Append(Pointer(anIndex));
+ end;
+end;
+{--------}
+function TffDataDictionary.HasSameFieldsEx(aSrcDict : TffDataDictionary;
+ aFields : PffLongintArray;
+ aNumFields : integer;
+ var aBLOBFields : TffPointerList) : boolean;
+var
+ anIndex, aSrcIndex : integer;
+begin
+ Result := False;
+ if FieldCount <> aNumFields then
+ Exit;
+ aBLOBFields.Empty;
+
+ for anIndex := 0 to pred(aNumFields) do begin
+ aSrcIndex := aFields^[anIndex];
+ { Must have same field type, length, decimal places, & units. }
+ Result := (FieldLength[anIndex] = aSrcDict.FieldLength[aSrcIndex]) and
+ (FieldType[anIndex] = aSrcDict.FieldType[aSrcIndex]) and
+ (FieldDecPl[anIndex] = aSrcDict.FieldDecPl[aSrcIndex]) and
+ (FieldUnits[anIndex] = aSrcDict.FieldUnits[aSrcIndex]);
+ if (not Result) then
+ Exit;
+ if FieldType[anIndex] in [fftBLOB..fftBLOBFile] then
+ aBLOBFields.Append(Pointer(anIndex));
+ end;
+end;
+{--------}
+procedure TffDataDictionary.CheckForDefault(aVCheckDesc : PffVCheckDescriptor;
+ aFieldDesc : PffFieldDescriptor);
+var
+ CheckVal : PffVCheckDescriptor;
+begin
+ if Assigned(aVCheckDesc) and aVCheckDesc^.vdHasDefVal then begin
+ if (not Assigned(aFieldDesc^.fdVCheck)) then begin
+ FFGetZeroMem(CheckVal, sizeof(TffVCheckDescriptor));
+ aFieldDesc^.fdVCheck := CheckVal;
+ end;
+ aFieldDesc^.fdVCheck^.vdHasDefVal := True;
+ aFieldDesc^.fdVCheck^.vdDefVal := aVCheckDesc.vdDefVal;
+ end;
+end;
+{--------}
+function TffDataDictionary.GetDefaultFldCount: Integer;
+begin
+ ddDefFldList.Pack;
+ Result := ddDefFldList.Count;
+end;
+{--------}
+procedure TffDataDictionary.InitRecord(aData : PffByteArray);
+begin
+ if (aData <> nil) and (FFldCount > 0) then begin
+ FillChar(aData^, FLogRecLen + ((FFldCount + 7) div 8), 0);
+ FFSetAllBits(PffByteArray(@aData^[LogicalRecordLength]), FFldCount); {!!.02}
+ end;
+end;
+{--------}
+procedure TffDataDictionary.InsertField(AtIndex : Integer;
+ const aIdent : TffDictItemName;
+ const aDesc : TffDictItemDesc;
+ aType : TffFieldType;
+ aUnits : Integer;
+ aDecPl : Integer;
+ aReqFld : Boolean;
+ const aValCheck : PffVCheckDescriptor);
+var
+ NewDesc : PffFieldDescriptor;
+ TempDesc : PffFieldDescriptor;
+ NewOffset: integer;
+ Inx : integer;
+begin
+ {can't be done in readonly mode}
+ if ddReadOnly then
+ FFRaiseException(EffException, ffStrResGeneral, fferrDictReadOnly, [FBaseName]);
+ {check for a duplicate field name}
+ if (GetFieldFromName(aIdent) <> -1) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrDupFieldName, [FBaseName, aIdent]);
+ {create it}
+ if (0 <= AtIndex) and (AtIndex < FFldCount) then begin
+ FHasBLOBs := fftbUnknown; {!!03}
+ NewDesc := CreateFieldDesc(aIdent, aDesc, aType, aUnits, aDecPl, aReqFld, aValCheck);
+ try
+ NewDesc^.fdNumber := AtIndex;
+ if (AtIndex > 0) then begin
+ TempDesc := FieldDescriptor^[pred(AtIndex)];
+ with TempDesc^ do
+ NewDesc^.fdOffset := fdOffset + fdLength;
+ end;
+ { Shift existing fields up. }
+ for Inx := pred(FFldCount) downto AtIndex do
+ FieldDescriptor^[succ(Inx)] := FieldDescriptor^[Inx];
+ FieldDescriptor^[AtIndex] := NewDesc;
+ inc(FFldCount);
+ { Have we reached our field capacity? }
+ if FFldCount = FFieldCapacity then
+ { Yes, expand our field array. }
+ ddExpandFieldArray(0);
+ {patch up all successive descriptors}
+ with NewDesc^ do
+ NewOffset := fdOffset + fdLength;
+ for Inx := succ(AtIndex) to pred(FFldCount) do begin
+ TempDesc := FieldDescriptor^[Inx];
+ with TempDesc^ do
+ begin
+ fdNumber := Inx;
+ fdOffset := NewOffset;
+ inc(NewOffset, fdLength);
+ end;
+ end;
+ FLogRecLen := NewOffset;
+ except
+ FFFreeMem(NewDesc,sizeof(TffFieldDescriptor));
+ raise;
+ end;{try..except}
+ end;
+end;
+{--------}
+function TffDataDictionary.IsIndexDescValid(const aIndexDesc : TffIndexDescriptor) : boolean;
+var
+ i : integer;
+ KeyLen : integer;
+begin
+ Result := false;
+ with aIndexDesc do begin
+ if (idName = '') then
+ Exit;
+ if (0 > idFile) or (idFile >= FFileCount) then
+ Exit;
+ if (idCount = -1) then begin {user-defined index}
+ if (idKeyLen <= 0) then
+ Exit;
+ end
+ else begin {composite index}
+ if (idCount = 0) then
+ Exit;
+ KeyLen := 0;
+ for i := 0 to pred(idCount) do begin
+ if (idFields[i] < 0) or (idFields[i] >= FFldCount) then
+ Exit;
+ inc(KeyLen, FieldDescriptor^[idfields[i]]^.fdLength);
+ end;
+ inc(KeyLen, (idCount + 7) div 8);
+ if (KeyLen > ffcl_MaxKeyLength) then
+ Exit;
+ end;
+ end;
+ Result := true;
+end;
+{--------}
+function TffDataDictionary.IsRecordFieldNull(aField : integer;
+ aData : PffByteArray) : boolean;
+begin
+ if (aField < 0) or (aField >= FFldCount) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds,
+ [FBaseName, aField]);
+ Result := (aData = nil) or
+ FFIsBitSet(PffByteArray(@aData^[FLogRecLen]), aField);
+end;
+{--------}
+procedure TffDataDictionary.ReadFromStream(S : TStream);
+var
+ Reader : TReader;
+ i, j : Integer;
+ FileDesc : PffFileDescriptor;
+ FldDesc : PffFieldDescriptor;
+ InxDesc : PffIndexDescriptor;
+ HasVCheck : Boolean;
+begin
+ ClearPrim(true);
+ Reader := TReader.Create(S, 4096);
+ try
+ with Reader do begin
+ FBLOBFileNumber := 0;
+ FIsEncrypted := ReadBoolean;
+ FFileCount := ReadInteger;
+ try
+ for i := 0 to pred(FFileCount) do begin
+ FFGetZeroMem(FileDesc, sizeof(TffFileDescriptor));
+ with FileDesc^ do begin
+ fdNumber := i;
+ fdDesc := ReadString;
+ fdExtension := ReadString; //<-- Soner fpc raises exception "Invalid Value for property"
+ // for embeddedserver in function classes.pas TReader.ReadString
+ fdBlockSize := ReadInteger;
+ fdType := TffFileType(ReadInteger);
+ if (fdType = ftBLOBFile) then
+ FBLOBFileNumber := i;
+ end;
+ ddFileList.Add(pointer(FileDesc));
+ FileDesc := nil;
+ end;
+ except
+ if Assigned(FileDesc) then
+ FFFreeMem(FileDesc, sizeOf(TffFileDescriptor));
+ raise;
+ end;{try..except}
+ FFldCount := ReadInteger;
+ ddExpandFieldArray(FFldCount + 1);
+ try
+ for i := 0 to pred(FFldCount) do begin
+ FFGetZeroMem(FldDesc, sizeof(TffFieldDescriptor));
+ with FldDesc^ do begin
+ fdNumber := i;
+ fdName := ReadString;
+ fdDesc := ReadString;
+ fdUnits := ReadInteger;
+ fdDecPl := ReadInteger;
+ fdOffset := ReadInteger;
+ fdLength := ReadInteger;
+ fdType := TffFieldType(ReadInteger);
+ fdRequired := ReadBoolean;
+ HasVCheck := ReadBoolean;
+ if HasVCheck then begin
+ FFGetZeroMem(fdVCheck, sizeof(TffVCheckDescriptor));
+ with fdVCheck^ do begin
+ vdPicture := ReadString;
+ vdHasMinVal := ReadBoolean;
+ vdHasMaxVal := ReadBoolean;
+ vdHasDefVal := ReadBoolean;
+ {if the field has a default value, we add the field
+ number to ddDefFldList}
+ if vdHasDefVal then begin
+ ddDefFldList.Add(Pointer(i));
+ end;
+ if vdHasMinVal then
+ Read(vdMinVal, fdLength);
+ if vdHasMaxVal then
+ Read(vdMaxVal, fdLength);
+ if vdHasDefVal then
+ Read(vdDefVal, fdLength);
+ end;
+ end;
+ end;
+ FieldDescriptor^[i] := FldDesc;
+ FldDesc := nil;
+ end;
+ except
+ if Assigned(FldDesc) then
+ FFFreeMem(FldDesc, sizeOf(TffFieldDescriptor));
+ raise;
+ end;{try..except}
+ FLogRecLen := ReadInteger;
+ FInxCount := ReadInteger;
+ ddExpandIndexArray(FInxCount + 1);
+ try
+ {note that index 0 is never stored on a stream}
+ for i := 1 to pred(FInxCount) do begin
+ FFGetZeroMem(InxDesc, sizeof(TffIndexDescriptor));
+ with InxDesc^ do begin
+ idNumber := i;
+ idName := ReadString;
+ idDesc := ReadString;
+ idFile := ReadInteger;
+ idKeyLen := ReadInteger;
+ idCount := ReadInteger;
+ if (idCount <> -1) then
+ for j := 0 to pred(idCount) do begin
+ idFields[j] := ReadInteger;
+ if NextValue=vaString then
+ idFieldIHlprs[j] := ReadString
+ else
+ idFieldIHlprs[j] := '';
+ end;
+ idDups := ReadBoolean;
+ idAscend := ReadBoolean;
+ idNoCase := ReadBoolean;
+ end;
+ IndexDescriptor^[i] := InxDesc;
+ InxDesc := nil;
+ end;
+ except
+ if Assigned(InxDesc) then
+ FFFreeMem(InxDesc, sizeOf(TffIndexDescriptor));
+ raise;
+ end;{try..except}
+ end;
+ finally
+ Reader.Free;
+ end;{try..finally}
+end;
+{--------}
+procedure TffDataDictionary.RemoveField(aField : Longint);
+var
+ TempDesc : PffFieldDescriptor;
+ NewOffset : Integer;
+ Inx, {!!.13}
+ FldInx : Integer; {!!.13}
+ InxDesc : PffIndexDescriptor; {!!.13}
+begin
+ {can't be done in readonly mode}
+ if ddReadOnly then
+ FFRaiseException(EffException, ffStrResGeneral, fferrDictReadOnly, [FBaseName]);
+ if (0 <= aField) and (aField < FFldCount) then begin
+{Begin !!.13}
+ { Verify the field is not being used by an index. }
+ for Inx := Pred(IndexCount) downto 0 do begin
+ InxDesc := IndexDescriptor[Inx];
+ for FldInx := 0 to Pred(InxDesc^.idCount) do
+ if InxDesc^.idFields[FldInx] = aField then
+ FFRaiseException(EffException, ffStrResGeneral, fferrFileInUse,
+ [aField]);
+ end;
+{End !!.13}
+ FHasBLOBs := fftbUnknown; {!!.03}
+ TempDesc := FieldDescriptor^[aField];
+ NewOffset := TempDesc^.fdOffset;
+ FFFreeMem(TempDesc, sizeOf(TffFieldDescriptor));
+ { Shift fields down to cover the empty space. }
+ for Inx := aField to (FFldCount - 2) do
+ FieldDescriptor^[Inx] := FieldDescriptor^[succ(Inx)]; {!!.01}
+ dec(FFldCount);
+ {patch up all successive descriptors}
+ for Inx := aField to pred(FFldCount) do begin
+ TempDesc := FieldDescriptor^[Inx];
+ with TempDesc^ do begin
+ fdNumber := Inx;
+ fdOffset := NewOffset;
+ inc(NewOffset, fdLength);
+ end;
+ end;
+ FLogRecLen := NewOffset;
+ end;
+end;
+{--------}
+procedure TffDataDictionary.RemoveFile(aFile : Longint);
+var
+ TempDesc : PffFileDescriptor;
+ Inx : integer;
+begin
+ {can't be done in readonly mode}
+ if ddReadOnly then
+ FFRaiseException(EffException, ffStrResGeneral, fferrDictReadOnly, [FBaseName]);
+ {can't remove entry 0: it's the base file}
+ if (aFile = 0) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrBaseFile, [FBaseName]);
+ {remove the entry}
+ if (0 < aFile) and (aFile < FFileCount) then begin
+ TempDesc := PffFileDescriptor(ddFileList.Items[aFile]);
+ {if the BLOB file is being removed from the dictionary then reset
+ the BLOB file number field}
+ if (TempDesc^.fdType = ftBLOBFile) then
+ FBLOBFileNumber := 0;
+{Begin!!.13}
+ { If an index file is being removed from the dictionary then make sure
+ it is not referenced by an index. }
+ if (TempDesc^.fdType = ftIndexFile) then begin
+ for Inx := pred(FInxCount) downto 0 do
+ if (IndexDescriptor^[Inx]^.idFile = aFile) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrFileInUse,
+ [aFile]);
+ { Fixup index descriptors referencing files with higher file numbers. }
+ for Inx := Pred(IndexCount) downto 0 do
+ if (IndexDescriptor^[Inx]^.idFile > aFile) then
+ Dec(IndexDescriptor^[Inx]^.idFile);
+ end; { if }
+{End !!.13}
+
+ FFFreeMem(TempDesc, sizeOf(TffFileDescriptor));
+ ddFileList.Delete(aFile);
+ dec(FFileCount);
+ {patch up all successive descriptors}
+ for Inx := aFile to pred(FFileCount) do begin
+ TempDesc := PffFileDescriptor(ddFileList[Inx]);
+ TempDesc^.fdNumber := Inx;
+ end;
+ end;
+end;
+{--------}
+procedure TffDataDictionary.RemoveIndex(aIndex : Longint);
+var
+ TempDesc : PffIndexDescriptor;
+ Inx : integer;
+begin
+ (*
+ {can't be done in readonly mode}
+ if ddReadOnly then
+ FFRaiseException(EffException, ffStrResGeneral, fferrDictReadOnly, [FBaseName]);
+ *)
+ {remove the entry}
+ if (0 <= aIndex) and (aIndex < FInxCount) then begin
+ TempDesc := IndexDescriptor^[aIndex];
+ FFFreeMem(TempDesc, sizeOf(TffIndexDescriptor));
+{Begin !!.02}
+ { Shift the descriptors above the deleted index down to fill in
+ the gap. }
+ for Inx := aIndex to (FInxCount - 2) do begin
+ IndexDescriptor^[Inx] := IndexDescriptor^[succ(Inx)];
+ IndexDescriptor^[Inx]^.idNumber := Inx;
+ end;
+ dec(FInxCount);
+ end;
+{End !!.02}
+end;
+{--------}
+procedure TffDataDictionary.SetBaseName(const BN : TffTableName);
+begin
+ FBaseName := BN;
+end;
+{--------}
+procedure TffDataDictionary.SetBlockSize(BS : Longint);
+begin
+ {can't be done in readonly mode}
+ if ddReadOnly then
+ FFRaiseException(EffException, ffStrResGeneral, fferrDictReadOnly, [FBaseName]);
+ if (BS <> BlockSize) and FFVerifyBlockSize(BS) then
+ if (BS > BlockSize) or
+ (RecordLength <= (BS - ffc_BlockHeaderSizeData - sizeof(Longint))) then begin
+ if (FFileCount > 0) then
+ PffFileDescriptor(ddFileList.Items[0])^.fdBlockSize := BS;
+ end;
+end;
+{Begin !!.11}
+{--------}
+procedure TffDataDictionary.SetDefaultFieldValue(aData : PffByteArray;
+ const aField : Integer);
+var
+ i : Integer;
+ BS : PffByteArray;
+ CurrField : PffByteArray;
+ HasDefault : Boolean;
+begin
+ if (aData = nil) then
+ Exit;
+ BS := PffByteArray(@aData^[LogicalRecordLength]);
+ HasDefault := False;
+ for i := 0 to Pred(ddDefFldList.Count) do begin
+ HasDefault := (Integer(ddDefFldList[i]) = aField);
+ if HasDefault then begin
+ { If the field is nil and it has a default value, we're going to
+ add the default value for the field. }
+ if FieldDescriptor^[aField]^.fdVCheck <> nil then
+ if FFIsBitSet(BS, aField) and
+ FieldDescriptor^[aField]^.fdVCheck^.vdHasDefVal then begin
+ CurrField := PffByteArray(@aData^[FieldDescriptor^[aField]^.fdOffset]);
+ Move(FieldDescriptor^[aField]^.fdVCheck^.vdDefVal,
+ CurrField^,
+ FieldDescriptor^[afield]^.fdLength);
+ FFClearBit(BS, aField);
+ end; { if }
+ break;
+ end; { if }
+ end; { for }
+ if not HasDefault then
+ SetRecordFieldNull(aField, aData, True);
+end;
+{End !!.11}
+{--------}
+procedure TffDataDictionary.SetDefaultFieldValues(aData : PffByteArray);
+var
+ DefFldNo : Integer;
+ i : Integer;
+ BS : PffByteArray;
+ CurrField : PffByteArray;
+begin
+ if (aData = nil) then
+ Exit;
+ BS := PffByteArray(@aData^[LogicalRecordLength]); {!!.06}
+ for i := 0 to pred(ddDefFldList.Count) do begin
+ {if the field is nil and it has a default value, we're going to
+ add the default value for the field}
+ DefFldNo := Integer(ddDefFldList[i]);
+ if FieldDescriptor^[DefFldNo]^.fdVCheck <> nil then
+ if FFIsBitSet(BS, DefFldNo) and
+ FieldDescriptor^[DefFldNo]^.fdVCheck^.vdHasDefVal then begin
+ CurrField := PffByteArray(@aData^[FieldDescriptor^[DefFldNo]^.fdOffset]);
+ Move(FieldDescriptor^[DefFldNo]^.fdVCheck^.vdDefVal,
+ CurrField^,
+ FieldDescriptor^[DefFldNo]^.fdLength);
+ FFClearBit(BS, DefFldNo);
+ end;
+ end;
+end;
+{--------}
+procedure TffDataDictionary.SetIsEncrypted(IE : Boolean);
+begin
+ {can't be done in readonly mode}
+ if ddReadOnly then
+ FFRaiseException(EffException, ffStrResGeneral, fferrDictReadOnly, [FBaseName]);
+ FIsEncrypted := IE;
+end;
+{--------}
+procedure TffDataDictionary.SetRecordField(aField : integer;
+ aData : PffByteArray;
+ aValue : pointer);
+begin
+ if (aField < 0) or (aField >= FFldCount) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aField]);
+ with FieldDescriptor^[aField]^ do begin
+ if (aValue = nil) then begin
+ FFSetBit(PffByteArray(@aData^[FLogRecLen]), aField);
+ FillChar(aData^[fdOffset], fdLength, 0);
+ end
+ else begin
+ FFClearBit(PffByteArray(@aData^[FLogRecLen]), aField);
+ Move(aValue^, aData^[fdOffset], fdLength);
+ end;
+ end;
+end;
+{--------}
+procedure TffDataDictionary.SetRecordFieldNull(aField : integer;
+ aData : PffByteArray;
+ aIsNull : boolean);
+begin
+ if (aField < 0) or (aField >= FFldCount) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aField]);
+ with FieldDescriptor^[aField]^ do begin
+ if aIsNull then
+ FFSetBit(PffByteArray(@aData^[FLogRecLen]), aField)
+ else
+ FFClearBit(PffByteArray(@aData^[FLogRecLen]), aField);
+ FillChar(aData^[fdOffset], fdLength, 0);
+ end;
+end;
+{--------}
+procedure TffDataDictionary.SetValidityCheck(aField : integer;
+ var aExists : boolean;
+ const aVCheck : TffVCheckDescriptor);
+begin
+ if (aField < 0) or (aField >= FFldCount) then
+ FFRaiseException(EffException, ffStrResGeneral, fferrOutOfBounds, [FBaseName, aField]);
+ with FieldDescriptor^[aField]^ do begin
+ if aExists then begin
+ if (fdVCheck = nil) then
+ FFGetZeroMem(fdVCheck, sizeOf(TffVCheckDescriptor));
+ if (@aVCheck <> fdVCheck) then
+ Move(aVCheck, fdVCheck^, sizeof(fdVCheck))
+ end
+ else {aExists is false} begin
+ if (fdVCheck <> nil) then
+ FFFreeMem(fdVCheck, sizeOf(TffVCheckDescriptor));
+ end;
+ end;
+end;
+{--------}
+procedure TffDataDictionary.WriteToStream(S : TStream);
+var
+ Writer : TWriter;
+ i, j : Integer;
+ FileDesc : PffFileDescriptor;
+ FldDesc : PffFieldDescriptor;
+ InxDesc : PffIndexDescriptor;
+begin
+ CheckValid;
+ Writer := TWriter.Create(S, 4096);
+ try
+ with Writer do begin
+ WriteBoolean(FIsEncrypted);
+ WriteInteger(FFileCount);
+ for i := 0 to pred(FFileCount) do begin
+ FileDesc := PffFileDescriptor(ddFileList[i]);
+ with FileDesc^ do begin
+ AnsiStringWriter(fdDesc, Writer); {!!.05}
+ AnsiStringWriter(fdExtension, Writer);
+ WriteInteger(fdBlockSize);
+ WriteInteger(ord(fdType));
+ end;
+ end;
+ WriteInteger(FFldCount);
+ for i := 0 to pred(FFldCount) do begin
+ FldDesc := FieldDescriptor^[i];
+ with FldDesc^ do begin
+ AnsiStringWriter(fdName, Writer); {!!.05}
+ AnsiStringWriter(fdDesc, Writer); {!!.05}
+ WriteInteger(fdUnits);
+ WriteInteger(fdDecPl);
+ WriteInteger(fdOffset);
+ WriteInteger(fdLength);
+ WriteInteger(ord(fdType));
+ WriteBoolean(fdRequired);
+ WriteBoolean(fdVCheck <> nil);
+ if (fdVCheck <> nil) then begin
+ with fdVCheck^ do begin
+ AnsiStringWriter(vdPicture, Writer); {!!.05}
+ WriteBoolean(vdHasMinVal);
+ WriteBoolean(vdHasMaxVal);
+ WriteBoolean(vdHasDefVal);
+ if vdHasMinVal then
+ Write(vdMinVal, fdLength);
+ if vdHasMaxVal then
+ Write(vdMaxVal, fdLength);
+ if vdHasDefVal then
+ Write(vdDefVal, fdLength);
+ end;
+ end;
+ end;
+ end;
+ WriteInteger(FLogRecLen);
+ WriteInteger(FInxCount);
+ {note we don't write index 0 to the stream}
+ for i := 1 to pred(FInxCount) do begin
+ InxDesc := IndexDescriptor^[i];
+ with InxDesc^ do begin
+ AnsiStringWriter(idName, Writer); {!!.05}
+ AnsiStringWriter(idDesc, Writer); {!!.05}
+ WriteInteger(idFile);
+ WriteInteger(idKeyLen);
+ WriteInteger(idCount);
+ if (idCount <> -1) then
+ for j := 0 to pred(idCount) do begin
+ WriteInteger(idFields[j]);
+ if Length(idFieldIHlprs[j]) > 0 then
+ AnsiStringWriter(idFieldIHlprs[j], Writer); {!!.05}
+ end;
+ WriteBoolean(idDups);
+ WriteBoolean(idAscend);
+ WriteBoolean(idNoCase);
+ end;
+ end;
+ end;
+ finally
+ Writer.Free;
+ end;{try..finally}
+end;
+{====================================================================}
+
+ {moved from FFTBBASE}
+{===Composite Key manipulation routines==============================}
+procedure FFInitKey(aKey : PffByteArray;
+ aKeyLen : integer;
+ aKeyFldCount : integer);
+begin
+ if (aKey <> nil) then begin
+ FillChar(aKey^, aKeyLen, 0);
+ if (aKeyFldCount <= 8) then
+ FFSetAllBits(PffByteArray(@aKey^[aKeyLen-1]), aKeyFldCount)
+ else
+ FFSetAllBits(PffByteArray(@aKey^[aKeyLen-2]), aKeyFldCount);
+ end;
+end;
+{--------}
+function FFIsKeyFieldNull(aKey : PffByteArray;
+ aKeyLen : integer;
+ aKeyFldCount : integer;
+ aKeyFld : integer) : boolean;
+begin
+ if (aKey = nil) then
+ Result := true
+ else begin
+ if (aKeyFldCount <= 8) then
+ Result := FFIsBitSet(PffByteArray(@aKey^[aKeyLen-1]), aKeyFld)
+ else
+ Result := FFIsBitSet(PffByteArray(@aKey^[aKeyLen-2]), aKeyFld);
+ end;
+end;
+{--------}
+procedure FFSetKeyFieldNonNull(aKey : PffByteArray;
+ aKeyLen : integer;
+ aKeyFldCount : integer;
+ aKeyFld : integer);
+begin
+ if (aKey <> nil) then begin
+ if (aKeyFldCount <= 8) then
+ FFClearBit(PffByteArray(@aKey^[aKeyLen-1]), aKeyFld)
+ else
+ FFClearBit(PffByteArray(@aKey^[aKeyLen-2]), aKeyFld);
+ end;
+end;
+{====================================================================}
+end.
diff --git a/components/flashfiler/sourcelaz/fflleng.pas b/components/flashfiler/sourcelaz/fflleng.pas
new file mode 100644
index 000000000..4d8c681ae
--- /dev/null
+++ b/components/flashfiler/sourcelaz/fflleng.pas
@@ -0,0 +1,1223 @@
+{*********************************************************}
+{* FlashFiler: Base engine classes *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit fflleng;
+
+interface
+
+uses
+ Windows,
+ Classes,
+ ffhash,
+ ffllbase,
+ ffllcomp,
+ fflldict,
+ ffsrbde,
+ ffsrlock;
+
+type
+ { This type defines the actions for which an extender may be notified.
+
+ ffeaAfterCreateClient - Called after a client is created.
+ If an extender returns an error code other than
+ DBIERR_NONE, the client will not be added and the
+ error code returned to the client application. The
+ client application is responsible for catching the
+ resulting exception and interpreting the error code
+ as there may be no client-side resource string
+ associated with the error code.
+ - All "after" actions will ignore extender error messages
+
+ }
+ TffEngineAction = ({record actions}
+ ffeaBeforeRecRead, ffeaAfterRecRead,
+ ffeaBeforeRecInsert, ffeaAfterRecInsert, ffeaInsertRecFail,
+ ffeaBeforeRecUpdate, ffeaAfterRecUpdate, ffeaUpdateRecFail,
+ ffeaBeforeRecDelete, ffeaAfterRecDelete, ffeaDeleteRecFail,
+ {table actions}
+ ffeaBeforeTabRead,
+ ffeaBeforeTabUpdate, ffeaTabUpdateFail,
+ ffeaBeforeTabDelete, ffeaTabDeleteFail,
+ ffeaBeforeTabInsert, ffeaTabInsertFail,
+ ffeaBeforeTabRestruct, ffeaTabRestructFail,
+ ffeaBeforeTabPack, ffeaTabPackFail,
+ ffeaBeforeAddInx, ffeaTabAddInxFail,
+ ffeaBeforeRebuildInx, ffeaTabRebuildInxFail,
+ ffeaBeforeTableLock, ffeaAfterTableLock, ffeaTableLockFail,
+ {databaseactions}
+ ffeaBeforeDBRead,
+ ffeaBeforeDBUpdate, ffeaDBUpdateFail,
+ ffeaBeforeDBDelete, ffeaDBDeleteFail,
+ ffeaBeforeDBInsert, ffeaDBInsertFail,
+ ffeaBeforeChgAliasPath, ffeaChgAliasPathFail,
+ {transactions actions}
+ ffeaAfterStartTrans,
+ ffeaBeforeCommit, ffeaAfterCommit, ffeaCommitFail, {!!.06}
+ ffeaBeforeRollback, ffeaAfterRollback,
+ {cursor actions}
+ ffeaBeforeCursorClose,
+ {BLOB actions}
+ ffeaBeforeBLOBCreate, ffeaAfterBLOBCreate, ffeaBLOBCreateFail,
+ ffeaBeforeBLOBRead, ffeaAfterBLOBRead, ffeaBLOBReadFail,
+ ffeaBeforeBLOBWrite, ffeaAfterBLOBWrite, ffeaBLOBWriteFail,
+ ffeaBeforeBLOBDelete, ffeaAfterBLOBDelete, ffeaBLOBDeleteFail,
+ ffeaBeforeBLOBTruncate, ffeaAfterBLOBTruncate, ffeaBLOBTruncateFail,
+ ffeaBeforeBLOBGetLength, ffeaAfterBLOBGetLength, ffeaBLOBGetLengthFail,
+ ffeaBeforeBLOBFree, ffeaAfterBLOBFree, ffeaBLOBFreeFail,
+ ffeaBeforeFileBLOBAdd, ffeaAfterFileBLOBAdd, ffeaFileBLOBAddFail,
+ ffeaBeforeBLOBLinkAdd, ffeaAfterBLOBLinkAdd, ffeaBLOBLinkAddFail,
+ {client actions}
+ ffeaBeforeRemoveClient,
+ ffeaAfterCreateClient,
+ {misc actions}
+ ffeaNoAction {used when no fallback action needs to be taken}
+ );
+
+ TffInterestedActions = set of TffEngineAction;
+
+ { Used by a monitor to register interest in a specific type of server object.
+ For example, TffSrBaseCursor and TffSrDatabase. }
+ TffServerObjectClass = class of TffObject;
+
+ TffBaseEngineMonitor = class; { forward }
+ TffBaseEngineExtender = class; { forward }
+ TffInterestStructure = class; { forward }
+
+ { TffBaseServerEngine is an abstract, virtual class that specifies the
+ minimum interface for a local or remote server engine. The base engine
+ provides support for adding and removing monitors. }
+ TffBaseServerEngine = class(TffStateComponent)
+ protected {private}
+
+ FInterests : TffInterestStructure;
+ {-This data structure tracks the interest of various monitors. }
+
+ FMonitors : TffThreadList;
+ {-The monitors registered with the engine. After a monitor registers
+ itself with the engine, it identifies the types of server objects
+ in which it is interested. }
+
+ protected
+ {property access methods}
+ function bseGetAutoSaveCfg : Boolean; virtual; abstract;
+ function bseGetReadOnly : Boolean; virtual; abstract;
+ procedure bseSetAutoSaveCfg(aValue : Boolean); virtual; abstract;{!!.01}
+ procedure bseSetReadOnly(aValue : Boolean); virtual; abstract; {!!.01}
+ procedure scSetState(const aState : TffState); override;
+
+ procedure AddInterest(aMonitor : TffBaseEngineMonitor;
+ serverObjectClass : TffServerObjectClass); virtual;
+ {-A monitor uses this method to register interest in a specific type of
+ server object. }
+
+{Begin !!.06}
+ function ProcessRequest(aClientID : TffClientID;
+ aMsgID : Longint;
+ aTimeout : Longint;
+ aRequestData : Pointer;
+ aRequestDataLen : Longint;
+ aRequestDataType : TffNetMsgDataType;
+ var aReply : Pointer;
+ var aReplyLen : Longint;
+ aReplyType : TffNetMsgDataType) : TffResult; virtual;
+ { Backdoor method for sending a request to a server engine.
+ Should only be implemented by remote server engines. }
+
+ function ProcessRequestNoReply(aClientID : TffClientID;
+ aMsgID : Longint;
+ aTimeout : Longint;
+ aRequestData : Pointer;
+ aRequestDataLen : Longint ) : TffResult; virtual;
+ { Backdoor method for sending a request, no reply expected, to a
+ server engine. Should only be implemented by remote server engines. }
+{End !!.06}
+
+ procedure RemoveAllInterest(aMonitor : TffBaseEngineMonitor); virtual;
+ {-A monitor uses this method to unregister its interest for all classes
+ in which it previously expressed interest. }
+
+ procedure RemoveInterest(aMonitor : TffBaseEngineMonitor;
+ serverObjectClass : TffServerObjectClass); virtual;
+ {-A monitor uses this method to remove interest in a specific type of
+ server object. }
+
+ public
+ {creation/destruction}
+ constructor Create(aOwner : TComponent); override;
+
+ destructor Destroy; override;
+
+ procedure FFAddDependent(ADependent : TffComponent); override; {!!.11}
+ procedure FFRemoveDependent(ADependent : TffComponent); override; {!!.11}
+
+ function GetInterestedMonitors(const anObjectClass : TffServerObjectClass) : TffList;
+ {-Use this method to retrieve a list of engine monitors interested in a
+ particular server object class. If no monitors have registered
+ interest then nil is returned. Otherwise this function returns a
+ TffList containing one or more TffIntListItems. You can convert
+ a TffIntListItem into a TffBaseEngineMonitor as follows:
+
+ aMonitor := TffBaseEngineMonitor(TffIntListItem(TffList[index]).KeyAsInt);
+
+ NOTE: The recipient of this functions' result is responsible for
+ freeing the TffList.
+ }
+
+ procedure GetServerNames(aList : TStrings;
+ aTimeout : Longint); virtual; abstract;
+ { Returns a list of the servers available through the server's
+ transport. }
+
+{Begin !!.10}
+ { Event logging }
+ procedure Log(const aMsg : string); virtual; abstract;
+ {-Use this method to log a string to the event log. }
+
+ procedure LogAll(const Msgs : array of string); virtual; abstract;
+ {-Use this method to log multiple strings to the event log. }
+
+ procedure LogFmt(const aMsg : string; args : array of const); virtual; abstract;
+ {-Use this method to log a formatted string to the event log. }
+{End !!.10}
+
+ {transaction tracking}
+ function TransactionCommit(const aDatabaseID : TffDatabaseID) : TffResult; virtual; abstract;
+ function TransactionRollback(const aDatabaseID : TffDatabaseID) : TffResult; virtual; abstract;
+ function TransactionStart(const aDatabaseID : TffDatabaseID;
+ const aFailSafe : boolean) : TffResult; virtual; abstract;
+{Begin !!.10}
+ function TransactionStartWith(const aDatabaseID : TffDatabaseID;
+ const aFailSafe : Boolean;
+ const aCursorIDs : TffPointerList) : TffResult; virtual; abstract;
+{End !!.10}
+
+ {client related stuff}
+ function ClientAdd(var aClientID : TffClientID;
+ const aClientName : TffNetName;
+ const aUserID : TffName;
+ const timeout : Longint;
+ var aHash : TffWord32) : TffResult; virtual; abstract;
+
+{Begin !!.11}
+ function ClientAddEx(var aClientID : TffClientID;
+ const aClientName : TffNetName;
+ const aUserID : TffName;
+ const timeout : Longint;
+ const aClientVersion : Longint;
+ var aHash : TffWord32) : TffResult; virtual; abstract;
+ { Same as ClientAdd but client version is supplied via the aClientVersion
+ parameter. }
+{End !!.11}
+
+ function ClientRemove(aClientID : TffClientID) : TffResult; virtual; abstract;
+ function ClientSetTimeout(const aClientID : TffClientID;
+ const aTimeout : Longint) : TffResult; virtual; abstract;
+
+ {client session related stuff}
+ function SessionAdd(const aClientID : TffClientID; const timeout : Longint;
+ var aSessionID : TffSessionID) : TffResult; virtual; abstract;
+ function SessionCloseInactiveTables(aClientID : TffClientID) : TffResult; virtual; abstract; {!!.06}
+ function SessionCount(aClientID : TffClientID; var aCount : integer) : TffResult; virtual; abstract;
+ function SessionGetCurrent(aClientID : TffClientID; var aSessionID : TffSessionID) : TffResult; virtual; abstract;
+ function SessionRemove(aClientID : TffClientID; aSessionID : TffSessionID) : TffResult; virtual; abstract;
+ function SessionSetCurrent(aClientID : TffClientID; aSessionID : TffSessionID) : TffResult; virtual; abstract;
+ function SessionSetTimeout(const aClientID : TffClientID;
+ const aSessionID : TffSessionID;
+ const aTimeout : Longint) : TffResult; virtual; abstract;
+
+ {database related stuff}
+ function DatabaseAddAlias(const aAlias : TffName;
+ const aPath : TffPath;
+ aCheckSpace : Boolean; {!!.11}
+ const aClientID : TffClientID)
+ : TffResult; virtual; abstract;
+ function DatabaseAliasList(aList : TList;
+ aClientID : TffClientID) : TffResult; virtual; abstract;
+ {-Return a list of database aliases. aList will contain zero or more
+ instances of PffAliasDescriptor. }
+
+ function RecoveryAliasList(aList : TList;
+ aClientID : TffClientID) : TffResult; virtual; abstract;
+ {-Return a list of database aliases for use by a journal recovery
+ engine. The functionality of this method is identical to
+ DatabaseAliasList except that it does not require the server engine
+ to be started. }
+ function DatabaseChgAliasPath(aAlias : TffName;
+ aNewPath : TffPath;
+ aCheckSpace : Boolean; {!!.11}
+ aClientID : TffClientID)
+ : TffResult; virtual; abstract;
+ function DatabaseClose(aDatabaseID : TffDatabaseID) : TffResult; virtual; abstract;
+ function DatabaseDeleteAlias(aAlias : TffName;
+ aClientID : TffClientID) : TffResult; virtual; abstract;
+ function DatabaseGetAliasPath(aAlias : TffName;
+ var aPath : TffPath;
+ aClientID : TffClientID) : TffResult; virtual; abstract;
+ function DatabaseGetFreeSpace(const aDatabaseID : TffDatabaseID;
+ var aFreeSpace : Longint) : TffResult; virtual; abstract;
+ function DatabaseModifyAlias(const ClientID : TffClientID;
+ const aAlias : TffName;
+ const aNewName : TffName;
+ const aNewPath : TffPath;
+ aCheckSpace : Boolean) {!!.11}
+ : TffResult; virtual; abstract;
+ function DatabaseOpen(aClientID : TffClientID;
+ const aAlias : TffName;
+ const aOpenMode : TffOpenMode;
+ const aShareMode : TffShareMode;
+ const aTimeout : Longint;
+ var aDatabaseID : TffDatabaseID) : TffResult; virtual; abstract;
+ function DatabaseOpenNoAlias(aClientID : TffClientID;
+ const aPath : TffPath;
+ const aOpenMode : TffOpenMode;
+ const aShareMode : TffShareMode;
+ const aTimeout : Longint;
+ var aDatabaseID : TffDatabaseID) : TffResult; virtual; abstract;
+ function DatabaseSetTimeout(const aDatabaseID : TffDatabaseID;
+ const aTimeout : Longint) : TffResult; virtual; abstract;
+ function DatabaseTableExists(aDatabaseID : TffDatabaseID;
+ const aTableName : TffTableName;
+ var aExists : Boolean) : TffResult; virtual; abstract;
+ function DatabaseTableList(aDatabaseID : TffDatabaseID;
+ const aMask : TffFileNameExt;
+ aList : TList) : TffResult; virtual; abstract;
+ function DatabaseTableLockedExclusive(aDatabaseID : TffDatabaseID;
+ const aTableName : TffTableName;
+ var aLocked : Boolean) : TffResult; virtual; abstract;
+ {-Return a list of the tables for the specified database that fit the
+ specified filename mask. aList will contain zero or more instances
+ of PffTableDescriptor. }
+
+ {rebuild status related stuff}
+ function RebuildGetStatus(aRebuildID : Longint;
+ const aClientID : TffClientID;
+ var aIsPresent : boolean;
+ var aStatus : TffRebuildStatus) : TffResult; virtual; abstract;
+
+ {table related stuff}
+
+ function TableAddIndex(const aDatabaseID : TffDatabaseID;
+ const aCursorID : TffCursorID;
+ const aTableName : TffTableName;
+ const aIndexDesc : TffIndexDescriptor) : TffResult; virtual; abstract;
+ function TableBuild(aDatabaseID : TffDatabaseID;
+ aOverWrite : boolean;
+ const aTableName : TffTableName;
+ aForServer : boolean;
+ aDictionary : TffDataDictionary) : TffResult; virtual; abstract;
+ function TableDelete(aDatabaseID : TffDatabaseID; const aTableName : TffTableName) : TffResult; virtual; abstract;
+ function TableDropIndex(aDatabaseID : TffDatabaseID;
+ aCursorID : TffCursorID;
+ const aTableName : TffTableName;
+ const aIndexName : TffDictItemName;
+ aIndexID : Longint) : TffResult; virtual; abstract;
+ function TableEmpty(aDatabaseID : TffDatabaseID;
+ aCursorID : TffCursorID;
+ const aTableName : TffTableName) : TffResult; virtual; abstract;
+ function TableGetAutoInc(aCursorID : TffCursorID;
+ var aValue : TffWord32) : TffResult; virtual; abstract;
+ function TableGetDictionary(aDatabaseID : TffDatabaseID;
+ const aTableName : TffTableName;
+ aForServer : boolean;
+ aStream : TStream) : TffResult; virtual; abstract;
+ function TableGetRecCount(aCursorID : TffCursorID;
+ var aRecCount : Longint) : TffResult; virtual; abstract;
+ function TableGetRecCountAsync(aCursorID : TffCursorID; {!!.10}
+ var aRebuildID : Longint) : TffResult; virtual; abstract; {!!.10}
+ function TableOpen(const aDatabaseID : TffDatabaseID;
+ const aTableName : TffTableName;
+ const aForServer : boolean;
+ const aIndexName : TffName;
+ aIndexID : Longint;
+ const aOpenMode : TffOpenMode;
+ aShareMode : TffShareMode;
+ const aTimeout : Longint;
+ var aCursorID : TffCursorID;
+ aStream : TStream) : TffResult; virtual; abstract;
+ function TablePack(aDatabaseID : TffDatabaseID;
+ const aTableName : TffTableName;
+ var aRebuildID : Longint): TffResult; virtual; abstract;
+ function TableRebuildIndex(aDatabaseID : TffDatabaseID;
+ const aTableName : TffTableName;
+ const aIndexName : TffName;
+ aIndexID : Longint;
+ var aRebuildID : Longint): TffResult; virtual; abstract;
+ function TableRename(aDatabaseID : TffDatabaseID; const aOldName, aNewName : TffName) : TffResult; virtual; abstract;
+ function TableRestructure(aDatabaseID : TffDatabaseID;
+ const aTableName : TffTableName;
+ aDictionary : TffDataDictionary;
+ aFieldMap : TffStringList;
+ var aRebuildID : Longint): TffResult; virtual; abstract;
+ function TableSetAutoInc(aCursorID : TffCursorID;
+ aValue : TffWord32) : TffResult; virtual; abstract;
+{Begin !!.11}
+ function TableVersion(aDatabaseID : TffDatabaseID;
+ const aTableName : TffTableName;
+ var aVersion : Longint) : TffResult; virtual; abstract;
+{End !!.11}
+
+ {table locks via cursor}
+ function TableIsLocked(aCursorID : TffCursorID; aLockType : TffLockType;
+ var aIsLocked : boolean) : TffResult; virtual; abstract;
+ function TableLockAcquire(aCursorID : TffCursorID; aLockType : TffLockType) : TffResult; virtual; abstract;
+ function TableLockRelease(aCursorID : TffCursorID; aAllLocks : boolean) : TffResult; virtual; abstract;
+
+ {cursor stuff}
+ function CursorClone(aCursorID : TffCursorID; aOpenMode : TffOpenMode;
+ var aNewCursorID : TffCursorID) : TffResult; virtual; abstract;
+ function CursorClose(aCursorID : TffCursorID) : TffResult; virtual; abstract;
+ function CursorCompareBookmarks(aCursorID : TffCursorID;
+ aBookmark1,
+ aBookmark2 : PffByteArray;
+ var aCompResult : Longint) : TffResult; virtual; abstract;
+{Begin !!.02}
+ function CursorCopyRecords(aSrcCursorID,
+ aDestCursorID : TffCursorID;
+ aCopyBLOBs : Boolean) : TffResult; virtual; abstract;
+{End !!.02}
+ function CursorDeleteRecords(aCursorID : TffCursorID) : TffResult; virtual; abstract; {!!.06}
+ function CursorGetBookmark(aCursorID : TffCursorID; aBookmark : PffByteArray) : TffResult; virtual; abstract;
+ function CursorGetBookmarkSize(aCursorID : TffCursorID;
+ var aSize : integer) : TffResult; virtual; abstract;
+ {Begin !!.03}
+ function CursorListBLOBFreeSpace(aCursorID : TffCursorID;
+ const aInMemory : Boolean;
+ aStream : TStream) : TffResult; virtual; abstract;
+ {End !!.03}
+ function CursorOverrideFilter(aCursorID : Longint;
+ aExpression : pCANExpr;
+ aTimeout : TffWord32) : TffResult; virtual; abstract;
+ function CursorResetRange(aCursorID : TffCursorID) : TffResult; virtual; abstract;
+ function CursorRestoreFilter(aCursorID : Longint) : TffResult; virtual; abstract;
+ function CursorSetRange(aCursorID : TffCursorID;
+ aDirectKey : boolean;
+ aFieldCount1 : integer;
+ aPartialLen1 : integer;
+ aKeyData1 : PffByteArray;
+ aKeyIncl1 : boolean;
+ aFieldCount2 : integer;
+ aPartialLen2 : integer;
+ aKeyData2 : PffByteArray;
+ aKeyIncl2 : boolean) : TffResult; virtual; abstract;
+ function CursorSetTimeout(const aCursorID : TffCursorID;
+ const aTimeout : Longint) : TffResult; virtual; abstract;
+ function CursorSetToBegin(aCursorID : TffCursorID) : TffResult; virtual; abstract;
+ function CursorSetToBookmark(aCursorID : TffCursorID; aBookmark : PffByteArray) : TffResult; virtual; abstract;
+ function CursorSetToCursor(aDestCursorID : TffCursorID; aSrcCursorID : TffCursorID) : TffResult; virtual; abstract;
+ function CursorSetToEnd(aCursorID : TffCursorID) : TffResult; virtual; abstract;
+ function CursorSetToKey(aCursorID : TffCursorID;
+ aSearchAction : TffSearchKeyAction;
+ aDirectKey : boolean;
+ aFieldCount : integer;
+ aPartialLen : integer;
+ aKeyData : PffByteArray) : TffResult; virtual; abstract;
+ function CursorSwitchToIndex(aCursorID : TffCursorID;
+ aIndexName : TffDictItemName;
+ aIndexID : integer;
+ aPosnOnRec : boolean) : TffResult; virtual; abstract;
+ function CursorSetFilter(aCursorID : TffCursorID;
+ aExpression : pCANExpr;
+ aTimeout : TffWord32) : TffResult; virtual; abstract;
+
+
+ {record stuff}
+ function RecordDelete(aCursorID : TffCursorID; aData : PffByteArray) : TffResult; virtual; abstract;
+ function RecordDeleteBatch(aCursorID : TffCursorID;
+ aBMCount : Longint;
+ aBMLen : Longint;
+ aData : PffByteArray;
+ aErrors : PffLongintArray) : TffResult; virtual; abstract;
+ function RecordExtractKey(aCursorID : TffCursorID; aData : PffByteArray; aKey : PffByteArray) : TffResult; virtual; abstract;
+ function RecordGet(aCursorID : TffCursorID; aLockType : TffLockType; aData : PffByteArray) : TffResult; virtual; abstract;
+ function RecordGetBatch(aCursorID : TffCursorID;
+ aRecCount : Longint;
+ aRecLen : Longint;
+ var aRecRead : Longint;
+ aData : PffByteArray;
+ var aError : TffResult) : TffResult; virtual; abstract;
+ function RecordGetForKey(aCursorID : TffCursorID;
+ aDirectKey : boolean;
+ aFieldCount : integer;
+ aPartialLen : integer;
+ aKeyData : PffByteArray;
+ aData : PffByteArray;
+ aFirstCall : Boolean) : TffResult; virtual; abstract;
+ function RecordGetNext(aCursorID : TffCursorID; aLockType : TffLockType; aData : PffByteArray) : TffResult; virtual; abstract;
+ function RecordGetPrior(aCursorID : TffCursorID; aLockType : TffLockType; aData : PffByteArray) : TffResult; virtual; abstract;
+ function RecordInsert(aCursorID : TffCursorID; aLockType : TffLockType; aData : PffByteArray) : TffResult; virtual; abstract;
+ function RecordInsertBatch(aCursorID : TffCursorID;
+ aRecCount : Longint;
+ aRecLen : Longint;
+ aData : PffByteArray;
+ aErrors : PffLongintArray) : TffResult; virtual; abstract;
+ function RecordIsLocked(aCursorID : TffCursorID; aLockType : TffLockType;
+ var aIsLocked : boolean) : TffResult; virtual; abstract;
+ function RecordModify(aCursorID : TffCursorID; aData : PffByteArray; aRelLock : boolean) : TffResult; virtual; abstract;
+ function RecordRelLock(aCursorID : TffCursorID; aAllLocks : boolean) : TffResult; virtual; abstract;
+
+ {BLOB stuff}
+ function BLOBCreate(aCursorID : TffCursorID;
+ var aBlobNr : TffInt64) : TffResult; virtual; abstract;
+ function BLOBDelete(aCursorID : TffCursorID; aBLOBNr : TffInt64) : TffResult; virtual; abstract;
+{Begin !!.03}
+ function BLOBListSegments(aCursorID : TffCursorID;
+ aBLOBNr : TffInt64;
+ aStream : TStream) : TffResult; virtual; abstract;
+{End !!.03}
+ function BLOBRead(aCursorID : TffCursorID;
+ aBLOBNr : TffInt64;
+ aOffset : TffWord32; {!!.06}
+ aLen : TffWord32; {!!.06}
+ var aBLOB;
+ var aBytesRead : TffWord32) {!!.06}
+ : TffResult; virtual; abstract;
+ function BLOBFree(aCursorID : TffCursorID; aBLOBNr : TffInt64;
+ readOnly : boolean) : TffResult; virtual; abstract;
+ function BLOBGetLength(aCursorID : TffCursorID; aBLOBNr : TffInt64;
+ var aLength : Longint) : TffResult; virtual; abstract;
+ function BLOBTruncate(aCursorID : TffCursorID; aBLOBNr : TffInt64;
+ aBLOBLength : Longint) : TffResult; virtual; abstract;
+ function BLOBWrite(aCursorID : TffCursorID; aBLOBNr : TffInt64;
+ aOffset : Longint;
+ aLen : Longint;
+ var aBLOB ) : TffResult; virtual; abstract;
+ function FileBLOBAdd(aCursorID : TffCursorID;
+ const aFileName : TffFullFileName;
+ var aBLOBNr : TffInt64) : TffResult; virtual; abstract;
+
+ {SQL Stuff }
+ function SQLAlloc(aClientID : TffClientID;
+ aDatabaseID : TffDatabaseID;
+ aTimeout : Longint;
+ var aStmtID : TffSqlStmtID) : TffResult; virtual; abstract;
+ function SQLExec(aStmtID : TffSqlStmtID;
+ aOpenMode : TffOpenMode;
+ var aCursorID : TffCursorID;
+ aStream : TStream) : TffResult; virtual; abstract;
+ function SQLExecDirect(aClientID : TffClientID;
+ aDatabaseID : TffDatabaseID;
+ aQueryText : PChar;
+ aTimeout : Longint;
+ aOpenMode : TffOpenMode;
+ var aCursorID : TffCursorID;
+ aStream : TStream) : TffResult; virtual; abstract;
+ function SQLFree(aStmtID : TffSqlStmtID) : TffResult; virtual; abstract;
+ function SQLPrepare(aStmtID : TffSqlStmtID;
+ aQueryText : PChar;
+ aStream : TStream) : TffResult; virtual; abstract;
+ function SQLSetParams(aStmtID : TffSqlStmtID;
+ aNumParams : word;
+ aParamDescs : Pointer;
+ aDataBuffer : PffByteArray;
+ aDataLen : integer;
+ aStream : TStream) : TffResult; virtual; abstract;
+
+ {misc stuff}
+ function GetServerDateTime(var aDateTime : TDateTime) : TffResult; virtual; abstract;
+{Begin !!.10}
+ function GetServerSystemTime(var aSystemTime : TSystemTime)
+ : TffResult; virtual; abstract;
+ function GetServerGUID(var aGUID : TGUID)
+ : TffResult; virtual; abstract;
+ function GetServerID(var aUniqueID : TGUID)
+ : TffResult; virtual; abstract;
+ function GetServerStatistics(var aStats : TffServerStatistics)
+ : TffResult; virtual; abstract;
+ function GetCommandHandlerStatistics(const aCmdHandlerIdx : Integer;
+ var aStats : TffCommandHandlerStatistics)
+ : TffResult; virtual; abstract;
+ function GetTransportStatistics(const aCmdHandlerIdx : Integer;
+ const aTransportIdx : Integer;
+ var aStats : TffTransportStatistics)
+ : TffResult; virtual; abstract;
+{End !!.10}
+ published
+
+ property IsReadOnly : Boolean
+ read bseGetReadOnly
+ write bseSetReadOnly {!!.01}
+ default False; {!!.01}
+
+ property NoAutoSaveCfg : Boolean
+ read bseGetAutoSaveCfg
+ write bseSetAutoSaveCfg {!!.01}
+ default False; {!!.01}
+ end;
+
+
+ { This is the base implementation for an engine monitor. An engine monitor
+ attaches directly to a server engine and registers interest in specific
+ types of server objects. When an object of that type is opened in the
+ server, the monitor has the opportunity to express interest in the object.
+ The monitor can then supply an extender that will be associated with the
+ object and will receive notification of events pertaining to the object. }
+ TffBaseEngineMonitor = class(TffStateComponent)
+ protected
+
+ FServerEngine : TffBaseServerEngine;
+
+ procedure bemSetServerEngine(anEngine : TffBaseServerEngine); virtual;
+ {-Called when a monitor is associated with a server engine. If the
+ monitor is already associated with a server engine then it calls
+ OldEngine.RemoveMonitor. If the monitor is to be associated with
+ a new engine then it calls NewEngine.AddMonitor.
+ Subclasses should override this method to register interest in specific
+ types of server objects. }
+
+ { State methods }
+ procedure scInitialize; override;
+ procedure scPrepareForShutdown; override;
+ procedure scShutdown; override;
+ procedure scStartup; override;
+
+ public
+
+ destructor Destroy; override;
+
+ procedure AddInterest(anObjectClass : TffServerObjectClass);
+ {-Use this method to have the monitor notify its parent server engine
+ of interest in a server object class. }
+
+ procedure FFNotificationEx(const AOp : Byte; AFrom : TffComponent; {!!.11}
+ const AData : TffWord32); override; {!!.11}
+
+ procedure RemoveAllInterest;
+ {-Use this method to have the monitor tells its parent engine to remove
+ all interests of the monitor. }
+
+ procedure RemoveInterest(anObjectClass : TffServerObjectClass);
+ {-Use this method to have the monitor tells its parent engine to remove
+ its interest in the specified object class. }
+
+ function Interested(aServerObject : TffObject) : TffBaseEngineExtender; virtual; abstract;
+ { This function is called from the server when an object (e.g., cursor)
+ is first opened. If the monitor is interested in receiving events
+ for the object, it must create and return an instance of a class that
+ can handle events for the object. Otherwise it should return nil.
+ This method is called only for the type of objects in which the monitor
+ previously expressed interested.
+
+ When deriving a class from TffBaseEngineMonitor, it is up to the
+ extender designer to verify the class of ServerObject is one that is
+ expected.
+ }
+
+ published
+
+ property ServerEngine : TffBaseServerEngine read FServerEngine
+ write bemSetServerEngine;
+ { Associates an engine monitor with an engine. }
+ end;
+
+ { This is the base class for engine extenders. An engine extender is attached
+ to a specific type of server object as governed by an engine monitor. The
+ types of notifications received by the extender depend upon the type of
+ object being extended.
+ An extender is freed when the server object with which it is associated
+ is freed. }
+ TffBaseEngineExtender = class(TffObject)
+ protected
+ FParent : TffBaseEngineMonitor;
+ FActions : TffInterestedActions;
+ { Set of actions extender is interested in.}
+ public
+ constructor Create(aOwner : TffBaseEngineMonitor); virtual;
+ function Notify(aServerObject : TffObject;
+ aAction : TffEngineAction) : TffResult; virtual; abstract;
+ { This method is called when the extender is to be notified of an
+ action affecting the server object with which the extender is
+ associated. If the extender performs its operations, whatever they
+ may be, then this function should return DBIERR_NONE. If a failure
+ occurs and the server should discontinue the current operation with this
+ server object, this function should return an error code other than
+ DBIERR_NONE.
+
+ Some actions may pay attention to the error codes while other actions
+ may ignore the error codes. If an action pays attention to the error
+ code then extenders "after" the extender returning the error will not
+ be notified of the action.
+ }
+
+ property InterestedActions : TffInterestedActions
+ read FActions;
+ { The set of actions in which the extender is interested. }
+
+ end;
+
+
+ { The following class is used to track a monitor's interest. It stores
+ data in the following manner:
+
+ 1. To support retrieval of all monitors interested in a particular
+ class of object, it creates a hash table where the hash is based
+ on the class' name. The hash bucket points to a list of monitors.
+
+ 2. To support removal of all interest for a monitor, it maintains a
+ separate hash table where the hash is based upon the monitor}
+ TffInterestStructure = class(TffObject)
+ private
+ FHashByInterest : TffHash;
+ { Given a server object class, this hash table returns a list of the
+ monitors interested in that object class. }
+
+ FHashByMonitor : TffHash;
+ { Given an engine monitor, this hash table returns a list of the
+ object classes in which the monitor has expressed interest. We use
+ this data structure in RemoveAllInterest to speed up our search
+ for the monitors in FHashByInterest. }
+
+ FPortal : TffReadWritePortal;
+ protected
+ procedure DisposeList(Sender : TffBaseHashTable; aData : pointer);
+ {-This method is called when a hash table entry is removed. }
+
+ procedure RemoveInterestPrim(const aMonitor : TffBaseEngineMonitor;
+ const anObjectClass : TffServerObjectClass);
+ {-This method removes an interest entry from the FHashByInterest
+ hash table. }
+
+ public
+
+ constructor Create;
+
+ destructor Destroy; override;
+
+ procedure AddInterest(const aMonitor : TffBaseEngineMonitor;
+ const anObjectClass : TffServerObjectClass);
+ {-Use this method to add a monitor's interest in a certain class. }
+
+ function BeginRead : TffInterestStructure;
+ {-Use this method to obtain read access to the data. }
+
+ function BeginWrite : TffInterestStructure;
+ {-Use this method to obtain write access to the data. }
+
+ procedure EndRead;
+ {-This method must be called after BeginRead once read access is no
+ longer needed. }
+
+ procedure EndWrite;
+ {-This method must be called after BeginWrite once write access is no
+ longer needed. }
+
+ function GetInterestedMonitors(const anObjectClass : TffServerObjectClass) : TffList;
+ {-Use this method to retrieve a list of engine monitors interested in a
+ particular server object class. If no monitors have registered
+ interest then nil is returned. Otherwise this function returns a
+ TffList containing one or more TffIntListItems. You can convert
+ a TffIntListItem into a TffBaseEngineMonitor as follows:
+
+ aMonitor := TffBaseEngineMonitor(TffIntListItem(TffList[index]).KeyAsInt);
+
+ NOTE: The recipient of this functions' result is responsible for
+ freeing the TffList.
+ }
+
+ procedure RemoveAllInterest(const aMonitor : TffBaseEngineMonitor);
+ {-Use this method to remove interest in all things for which a monitor
+ previously registered interest. }
+
+ procedure RemoveInterest(const aMonitor : TffBaseEngineMonitor;
+ const anObjectClass : TffServerObjectClass);
+ {-Use this method to remove a monitor's interest in a certain class. }
+
+ end;
+
+var
+ FFServerEngines : TffThreadList;
+
+implementation
+
+{===TffBaseServerEngine==============================================}
+constructor TffBaseServerEngine.Create(aOwner : TComponent);
+var
+ aListItem : TffIntListItem;
+begin
+ inherited Create(aOwner);
+ { Add our instance to the global server list }
+ aListItem := TffIntListItem.Create(Longint(Self));
+ with FFServerEngines.BeginWrite do
+ try
+ Insert(aListItem);
+ finally
+ EndWrite;
+ end;
+
+ FInterests := TffInterestStructure.Create;
+ FMonitors := TffThreadList.Create;
+end;
+{--------}
+destructor TffBaseServerEngine.Destroy;
+begin
+ FFNotifyDependents(ffn_Destroy); {!!.11}
+ FMonitors.Free; {!!.11}
+
+ if assigned(FInterests) then begin
+ FInterests.Free;
+ FInterests := nil;
+ end;
+
+ { Remove our instance from the global server list }
+ with FFServerEngines.BeginWrite do
+ try
+ Delete(Longint(Self));
+ finally
+ EndWrite;
+ end;
+
+ inherited Destroy;
+
+end;
+{--------}
+procedure TffBaseServerEngine.scSetState(const aState : TffState);
+var
+ Idx : Longint;
+ NextState : TffState;
+ OldState : TffState;
+ Monitor : TFFBaseEngineMonitor;
+begin
+
+ if aState = scState then exit;
+
+ OldState := scState;
+
+ try
+ if Assigned(FMonitors) then
+ with FMonitors.BeginRead do
+ try
+ while scState <> aState do begin
+ { Based upon our current state & the target state, get the next state. }
+ NextState := ffStateDiagram[scState, aState];
+
+ { Move all monitors to the specified state. }
+ for Idx := Pred(Count) downto 0 do begin
+ Monitor := TffBaseEngineMonitor(TffIntListItem(Items[Idx]).KeyAsInt);
+ Monitor.State := NextState;
+ end;
+ { Change our state. }
+ scState := NextState;
+ { Call the appropriate internal method for this state. }
+ case NextState of
+ ffesInactive, ffesStopped :
+ scShutdown;
+ ffesInitializing :
+ scInitialize;
+ ffesStarting :
+ scStartup;
+ ffesShuttingDown, ffesStopping :
+ scPrepareForShutdown;
+ end; { case }
+ if assigned(scOnStateChange) then
+ scOnStateChange(Self);
+ end; { while }
+ finally
+ EndRead;
+ end
+ else
+ inherited;
+ except
+ scState := OldState;
+ raise;
+ end;
+end;
+{--------}
+procedure TffBaseServerEngine.AddInterest(aMonitor : TffBaseEngineMonitor;
+ serverObjectClass : TffServerObjectClass);
+begin
+ with FInterests.BeginWrite do
+ try
+ AddInterest(aMonitor, serverObjectClass);
+ finally
+ EndWrite;
+ end;
+end;
+{Begin !!.11}
+{--------}
+procedure TffBaseServerEngine.FFAddDependent(ADependent : TffComponent);
+var
+ aListItem : TffIntListItem;
+begin
+ inherited;
+ if ADependent is TffBaseEngineMonitor then begin
+ aListItem := TffIntListItem.Create(Longint(ADependent));
+ with FMonitors.BeginWrite do
+ try
+ FMonitors.Insert(aListItem);
+ finally
+ EndWrite;
+ end;
+ end;
+end;
+{--------}
+procedure TffBaseServerEngine.FFRemoveDependent(ADependent : TffComponent);
+begin
+ inherited;
+ if ADependent is TffBaseEngineMonitor then
+ with FMonitors.BeginWrite do
+ try
+ Delete(Longint(ADependent));
+ RemoveAllInterest(TffBaseEngineMonitor(ADependent));
+ finally
+ EndWrite;
+ end;
+end;
+{End !!.11}
+{--------}
+function TffBaseServerEngine.GetInterestedMonitors
+ (const anObjectClass : TffServerObjectClass) : TffList;
+begin
+ with FInterests.BeginRead do
+ try
+ Result := FInterests.GetInterestedMonitors(anObjectClass);
+ finally
+ EndRead;
+ end;
+end;
+{Begin !!.06}
+{--------}
+function TffBaseServerEngine.ProcessRequest(aClientID : TffClientID;
+ aMsgID : Longint;
+ aTimeout : Longint;
+ aRequestData : Pointer;
+ aRequestDataLen : Longint;
+ aRequestDataType : TffNetMsgDataType;
+ var aReply : Pointer;
+ var aReplyLen : Longint;
+ aReplyType : TffNetMsgDataType) : TffResult;
+begin
+ { Do nothing. }
+ Result := DBIERR_NONE;
+end;
+{--------}
+function TffBaseServerEngine.ProcessRequestNoReply(aClientID : TffClientID;
+ aMsgID : Longint;
+ aTimeout : Longint;
+ aRequestData : Pointer;
+ aRequestDataLen : Longint ) : TffResult;
+begin
+ { Do nothing. }
+ Result := DBIERR_NONE;
+end;
+{End !!.06}
+{--------}
+procedure TffBaseServerEngine.RemoveAllInterest(aMonitor : TffBaseEngineMonitor);
+begin
+ with FInterests.BeginWrite do
+ try
+ RemoveAllInterest(aMonitor);
+ finally
+ EndWrite;
+ end;
+end;
+{--------}
+procedure TffBaseServerEngine.RemoveInterest(aMonitor : TffBaseEngineMonitor;
+ serverObjectClass : TffServerObjectClass);
+begin
+ with FInterests.BeginWrite do
+ try
+ RemoveInterest(aMonitor, serverObjectClass);
+ finally
+ EndWrite;
+ end;
+end;
+{====================================================================}
+
+{===TffBaseEngineMonitor=============================================}
+destructor TffBaseEngineMonitor.Destroy;
+begin
+ if assigned(FServerEngine) then
+ FServerEngine.FFRemoveDependent(Self); {!!.11}
+
+ inherited Destroy;
+end;
+{--------}
+procedure TffBaseEngineMonitor.AddInterest(anObjectClass : TffServerObjectClass);
+begin
+ if assigned(FServerEngine) then
+ FServerEngine.AddInterest(Self, anObjectClass);
+end;
+{--------}
+procedure TffBaseEngineMonitor.bemSetServerEngine(anEngine : TffBaseServerEngine);
+{Rewritten !!.11}
+begin
+ if anEngine <> FServerEngine then begin
+ if assigned(FServerEngine) then
+ FServerEngine.FFRemoveDependent(Self);
+ if assigned(anEngine) then
+ anEngine.FFAddDependent(Self);
+ FServerEngine := anEngine;
+ end;
+end;
+{Begin !!.11}
+{--------}
+procedure TffBaseEngineMonitor.FFNotificationEx(const AOp : Byte; AFrom : TffComponent;
+ const AData : TffWord32);
+begin
+ inherited;
+ if (AFrom = FServerEngine) and
+ (AOp in [ffn_Destroy, ffn_Remove]) then begin
+ FServerEngine.FFRemoveDependent(Self);
+ FServerEngine := nil;
+ end;
+end;
+{End !!.11}
+{--------}
+procedure TffBaseEngineMonitor.RemoveAllInterest;
+begin
+ if assigned(FServerEngine) then
+ FServerEngine.RemoveAllInterest(Self);
+end;
+{--------}
+procedure TffBaseEngineMonitor.RemoveInterest(anObjectClass : TffServerObjectClass);
+begin
+ if assigned(FServerEngine) then
+ FServerEngine.RemoveInterest(Self, anObjectClass);
+end;
+{--------}
+procedure TffBaseEngineMonitor.scInitialize;
+begin
+ { Do nothing - avoid abstract error }
+end;
+{--------}
+procedure TffBaseEngineMonitor.scPrepareForShutdown;
+begin
+ { Do nothing - avoid abstract error }
+end;
+{--------}
+procedure TffBaseEngineMonitor.scShutdown;
+begin
+ { Do nothing - avoid abstract error }
+end;
+{--------}
+procedure TffBaseEngineMonitor.scStartup;
+begin
+ { Do nothing - avoid abstract error }
+end;
+{====================================================================}
+
+{===TffInterestStructure=============================================}
+constructor TffInterestStructure.Create;
+begin
+ inherited Create;
+ FHashByInterest := TffHash.Create(0);
+ FHashByInterest.OnDisposeData := DisposeList;
+ FHashByMonitor := TffHash.Create(0);
+ FHashByMonitor.OnDisposeData := DisposeList;
+ FPortal := TffReadWritePortal.Create;
+end;
+{--------}
+destructor TffInterestStructure.Destroy;
+begin
+ if assigned(FHashByInterest) then
+ FHashByInterest.Free;
+
+ if assigned(FHashByMonitor) then
+ FHashByMonitor.Free;
+
+ if assigned(FPortal) then
+ FPortal.Free;
+
+ inherited Destroy;
+end;
+{--------}
+procedure TffInterestStructure.AddInterest(const aMonitor : TffBaseEngineMonitor;
+ const anObjectClass : TffServerObjectClass);
+var
+ MonitorList : TffList;
+ Item : TffIntListItem;
+begin
+
+ { Has interest already been registered in the class? }
+ Item := TffIntListItem.Create(Longint(aMonitor));
+ MonitorList := FHashByInterest.Get(Longint(anObjectClass));
+ if assigned(MonitorList) then begin
+ { If so then append the new interest. }
+ MonitorList.Insert(Item);
+ end else begin
+ { Otherwise, create a new entry and add the interest. }
+ MonitorList := TffList.Create;
+ MonitorList.Insert(Item);
+ FHashByInterest.Add(Longint(anObjectClass), pointer(MonitorList));
+ end;
+
+ { Has this monitor registered for any other classes? }
+ Item := TffIntListItem.Create(Longint(anObjectClass));
+ MonitorList := FHashByMonitor.Get(Longint(aMonitor));
+ if assigned(MonitorList) then begin
+ { If so then add this entry to the hash for monitors. }
+ MonitorList.Insert(Item);
+ end else begin
+ { Otherwise, create a new entry for the monitor. }
+ MonitorList := TffList.Create;
+ MonitorList.Insert(Item);
+ FHashByMonitor.Add(Longint(aMonitor), pointer(MonitorList));
+ end;
+
+end;
+{--------}
+function TffInterestStructure.BeginRead : TffInterestStructure;
+begin
+ FPortal.BeginRead;
+ Result := Self;
+end;
+{--------}
+function TffInterestStructure.BeginWrite : TffInterestStructure;
+begin
+ FPortal.BeginWrite;
+ Result := Self;
+end;
+{--------}
+procedure TffInterestStructure.DisposeList(Sender : TffBaseHashTable; aData : pointer);
+var
+ Index : Longint;
+ ItemList : TffList;
+begin
+ if assigned(aData) then begin
+ ItemList := TffList(aData);
+ { Free the items in the list. }
+ for Index := pred(ItemList.Count) downto 0 do
+ ItemList[Index].Free;
+ ItemList.Free;
+ end;
+end;
+{--------}
+procedure TffInterestStructure.EndRead;
+begin
+ FPortal.EndRead;
+end;
+{--------}
+procedure TffInterestStructure.EndWrite;
+begin
+ FPortal.EndWrite;
+end;
+{--------}
+function TffInterestStructure.GetInterestedMonitors
+ (const anObjectClass : TffServerObjectClass) : TffList;
+var
+ anItem : TffIntListItem;
+ Index : Longint;
+ MonitorList : TffList;
+begin
+
+ Result := nil;
+
+ { Get the list of monitors interested in this object class. }
+ MonitorList := FHashByInterest.Get(Longint(anObjectClass));
+
+ { If there are monitors, copy the info over to the result list. }
+ if assigned(MonitorList) then begin
+ Result := TffList.Create;
+ for Index := 0 to pred(MonitorList.Count) do begin
+ anItem := TffIntListItem.Create(TffIntListItem(MonitorList[Index]).KeyAsInt);
+ Result.Insert(anItem);
+ end;
+ end;
+
+end;
+{--------}
+procedure TffInterestStructure.RemoveAllInterest(const aMonitor : TffBaseEngineMonitor);
+var
+ Index : integer;
+ ClassList : TffList;
+begin
+ { Do we have any interests registered for this monitor? }
+ ClassList := FHashByMonitor.Get(Longint(aMonitor));
+ if assigned(ClassList) then begin
+ { For each class in which the monitor registered interest, remove the
+ monitor from that class' list in FHashByInterest. }
+ for Index := pred(ClassList.Count) downto 0 do
+ RemoveInterestPrim(aMonitor,
+ TffServerObjectClass(TffIntListItem(ClassList[Index]).KeyAsInt));
+ { Now get rid of the entry for this monitor. }
+ FHashByMonitor.Remove(Longint(aMonitor));
+ end;
+end;
+{--------}
+procedure TffInterestStructure.RemoveInterest(const aMonitor : TffBaseEngineMonitor;
+ const anObjectClass : TffServerObjectClass);
+var
+ ItemList : TffList;
+begin
+ { Remove the monitor's interest for this specific class. }
+ RemoveInterestPrim(aMonitor, anObjectClass);
+
+ { Now remove the class from the monitor's list of interests. }
+ ItemList := FHashByMonitor.Get(Longint(aMonitor));
+ if assigned(ItemList) then
+ ItemList.Delete(Longint(anObjectClass));
+
+ { If our list is empty then get rid of it. }
+ if ItemList.Count = 0 then
+ FHashByInterest.Remove(Longint(aMonitor));
+end;
+{--------}
+procedure TffInterestStructure.RemoveInterestPrim(const aMonitor : TffBaseEngineMonitor;
+ const anObjectClass : TffServerObjectClass);
+var
+ MonitorList : TffList;
+begin
+ MonitorList := FHashByInterest.Get(Longint(anObjectClass));
+ { If we did find a set of interests for the specified object class,
+ scan through it and eliminate registrations for the specified monitor. }
+ if assigned(MonitorList) then
+ MonitorList.Delete(aMonitor);
+
+ { If our list is empty then get rid of it. }
+ if MonitorList.Count = 0 then
+ FHashByInterest.Remove(Longint(anObjectClass));
+end;
+{====================================================================}
+
+constructor TffBaseEngineExtender.Create(aOwner : TffBaseEngineMonitor);
+begin
+ inherited Create; {!!.02}
+ FParent := aOwner;
+ FActions := [];
+end;
+{====================================================================}
+
+procedure FinalizeUnit;
+begin
+ FFServerEngines.Free;
+end;
+
+procedure InitializeUnit;
+begin
+ FFServerEngines := TffThreadList.Create;
+end;
+
+initialization
+ InitializeUnit;
+
+finalization
+ FinalizeUnit;
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffllexcp.pas b/components/flashfiler/sourcelaz/ffllexcp.pas
new file mode 100644
index 000000000..b4e2f2c95
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffllexcp.pas
@@ -0,0 +1,148 @@
+{*********************************************************}
+{* FlashFiler: FlashFiler exceptions *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffllexcp;
+
+interface
+
+uses
+ SysUtils,
+ ffconst,
+ ffllbase,
+ ffsrmgr;
+
+var
+ ffStrResGeneral : TffStringResource; {in FFLLCNST.RC}
+ ffStrResBDE : TffStringResource;
+
+
+{===FlashFiler exception classes===}
+type
+ {..the ancestor..}
+ EffException = class(Exception)
+ private
+ FErrorCode : integer;
+ public
+ constructor CreateEx(StrRes : TffStringResource;
+ ErrorCode : integer;
+ const ExtraData : array of const);
+ constructor CreateNoData(StrRes : TffStringResource;
+ ErrorCode : integer);
+ property ErrorCode : integer
+ read FErrorCode;
+ end;
+ TffExceptionClass = class of EffException;
+
+ {..the communications class exceptions..}
+ EffCommsException = class(EffException);
+
+ {..the server exception..}
+ EffServerException = class(EffException);
+
+ {..the client exception..}
+ EffClientException = class(EffException);
+
+ {..the BDE exception..}
+ EffBDEException = class(EffException);
+
+
+{---Exception raising---}
+procedure FFRaiseException(ExceptionClass : TffExceptionClass;
+ StringRes{ource} : TffStringResource; {!!.10}
+ {conflict with StringResource directive fools some
+ source parsing tools}
+ ErrorCode : integer;
+ const ExtraData : array of const);
+ {-Raise an exception. ErrorCode is the Filer error code, ExtraData
+ is an array of const values defining the extra data required by
+ the error code's string resource}
+procedure FFRaiseExceptionNoData(ExceptionClass : TffExceptionClass;
+ StringRes{ource} : TffStringResource; {!!.10}
+ {conflict with StringResource directive fools some
+ source parsing tools}
+ ErrorCode : integer);
+ {-Raise an exception. ErrorCode is the Filer error code}
+
+implementation
+
+{===Filer exception generator========================================}
+constructor EffException.CreateEx(StrRes : TffStringResource;
+ ErrorCode : integer;
+ const ExtraData : array of const);
+begin
+ inherited CreateFmt(StrRes[ErrorCode], ExtraData);
+ FErrorCode := ErrorCode;
+end;
+{--------}
+constructor EffException.CreateNoData(StrRes : TffStringResource;
+ ErrorCode : integer);
+begin
+ inherited Create(StrRes[ErrorCode]);
+ FErrorCode := ErrorCode;
+end;
+{--------}
+procedure FFRaiseException(ExceptionClass : TffExceptionClass;
+ StringRes{ource} : TffStringResource; {!!.10}
+ ErrorCode : integer;
+ const ExtraData : array of const);
+begin
+ raise ExceptionClass.CreateEx(StringRes{ource}, ErrorCode, ExtraData) {!!.10}
+end;
+{--------}
+procedure FFRaiseExceptionNoData(ExceptionClass : TffExceptionClass;
+ StringRes{ource} : TffStringResource; {!!.10}
+ ErrorCode : integer);
+begin
+ raise ExceptionClass.CreateNoData(StringRes{ource}, ErrorCode); {!!.10}
+end;
+{====================================================================}
+
+procedure FinalizeUnit;
+begin
+ ffStrResGeneral.Free;
+ ffStrResBDE.Free;
+end;
+
+procedure InitializeUnit;
+begin
+ ffStrResGeneral := nil;
+ ffStrResBDE := nil;
+ ffStrResGeneral := TffStringResource.Create(hInstance, 'FF_GENERAL_STRINGS');
+ ffStrResBDE := TffStringResource.Create(hInstance, 'FF_BDE_ERROR_STRINGS');
+end;
+
+initialization
+ InitializeUnit;
+
+finalization
+ FinalizeUnit;
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffllgrid.pas b/components/flashfiler/sourcelaz/ffllgrid.pas
new file mode 100644
index 000000000..09acc4065
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffllgrid.pas
@@ -0,0 +1,358 @@
+{*********************************************************}
+{* Custom string grid for server config forms *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffllgrid;
+
+interface
+
+uses
+ Classes,
+ Controls,
+ Grids,
+ SysUtils, {!!.07}
+ Messages;
+
+type
+ {$ifdef fpc}
+ TInPlaceEdit = TStringCellEditor; //soner
+ {$endif}
+ TffStringGrid = class; { forward declaration }
+
+ TffCellFocusEvent = procedure(Sender : TffStringGrid;
+ aCol, aRow : integer;
+ const text : string) of object;
+ { This event is raised when a TffStringGrid cell gains or loses focus. }
+
+ TffColumnSortEvent = procedure(Sender : TffStringGrid;
+ aCol : integer) of object;
+ { This event is raised when the user clicks on a fixed cell (header) of
+ the grid. }
+
+ { This string grid has the following extra features:
+ 1. Sort (one direction) on any column.
+ 2. OnEnterCell and OnExitCell events.
+ 3. Misc utility functions.
+ }
+ TffStringGrid = class(TStringGrid)
+ protected
+ FOnEnterCell : TffCellFocusEvent;
+ FOnExitCell : TffCellFocusEvent;
+ FOnSortColumn : TffColumnSortEvent;
+
+ sgSavedRow : TStringList;
+
+ function CreateEditor : TInPlaceEdit; {$ifndef fpc}override;{$endif}
+
+ procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
+ X, Y: Integer); override;
+
+ function SelectCell(ACol, ARow: Longint): Boolean; override; {!!.02}
+
+ procedure sgEnterCell(const text : string; aCol, aRow : integer); virtual;
+ { Called by custom inplace editor when the cell has gained focus.
+ Raises the OnEnterCell event. }
+
+ procedure sgExitCell(const text : string; aCol, aRow : integer); virtual;
+ { Called by custom inplace editor when the cell has lost focus.
+ Raises the OnExitCell event. }
+
+ function sgGetVersion : string; {!!.07}
+ procedure sgSetVersion(const aValue : string); {!!.07}
+ public
+
+ constructor Create(aOwner : TComponent); override;
+
+ destructor Destroy; override;
+
+ function AnyCellIsEmpty(const aRow : integer) : boolean;
+ { Returns True if any cell in the specified row is
+ empty. }
+
+ procedure BeginUpdate;
+ { Use this method to prevent the grid from redrawing itself
+ while it is being modified. }
+
+ procedure BlankRow(const aRow : integer);
+ { Blank out each cell in the specified row. }
+
+ procedure CopyRow(const srcRow, destRow : integer);
+ { Copies all cells in srcRow to the corresponding cells in destRow. }
+
+ procedure EndUpdate;
+ { After calling BeginUpdate and modifying the grid's contents,
+ use this method to have the grid redraw itself. }
+
+ function LastRowIsEmpty : boolean;
+ { Returns True if each cell of the last row is empty. }
+
+ procedure RestoreToRow(const aRow : integer);
+ { If the cells of a row have been preserved using the SaveRow method,
+ use this method to write the cells back to the specified row. }
+
+ function RowIsEmpty(const aRow : integer) : boolean;
+ { Returns True if each cell of the specified row is empty. }
+
+ function RowIsFilled(const aRow : integer) : boolean;
+ { Returns True if each cell of the specified row has a non-blank value. }
+
+ procedure SaveRow(const aRow : integer);
+ published
+
+ property Version : string {!!.07}
+ read sgGetVersion
+ write sgSetVersion
+ stored False;
+
+ property OnEnterCell: TffCellFocusEvent read FOnEnterCell write FOnEnterCell;
+ { This event is raised when a TffStringGrid cell gains focus. }
+
+ property OnExitCell: TffCellFocusEvent read FOnExitCell write FOnExitCell;
+ { This event is raised when a TffStringGrid cell loses focus. }
+
+ property OnSortColumn : TffColumnSortEvent read FOnSortColumn
+ write FOnSortColumn;
+ { This event is raised when the user clicks on a fixed cell (header) of
+ the grid. }
+
+ end;
+
+ { This class is an extension of the TInPlaceEdit used by the grid. It detects
+ when the user enters and leaves a cell. When the user leaves a cell,
+ this class invokes the TffStringGrid's sgExitCell method. }
+ TffInPlaceEdit = class(TInPlaceEdit)
+ protected
+ FLastCol : integer;
+ FLastRow : integer;
+
+ procedure WMKillFocus(var msg : TMessage); message WM_KILLFOCUS;
+
+ procedure WMSetFocus(var msg : TMessage); message WM_SETFOCUS;
+
+ public
+ end;
+
+implementation
+uses
+ ffllbase; {!!.07}
+
+{===TffInPlaceEdit===================================================}
+procedure TffInPlaceEdit.WMKillFocus(var msg : TMessage);
+begin
+ {$ifdef fpc}
+ if Parent<>nil then TffStringGrid(Parent).sgExitCell(Text, FLastCol, FLastRow);
+ {$else}
+ TffStringGrid(Grid).sgExitCell(Text, FLastCol, FLastRow);
+ {$endif}
+ inherited;
+end;
+{--------}
+procedure TffInPlaceEdit.WMSetFocus(var msg : TMessage);
+begin
+ {$ifdef fpc}
+ if Parent<>nil then FLastCol := TffStringGrid(Parent).Col;
+ if Parent<>nil then FLastRow := TffStringGrid(Parent).Row;
+ {$else}
+ FLastCol := TffStringGrid(Grid).Col;
+ FLastRow := TffStringGrid(Grid).Row;
+ {$endif}
+ //TffStringGrid(Grid).sgEnterCell(Text, FLastCol, FLastRow); {Deleted !!.02}
+ inherited;
+end;
+{====================================================================}
+
+{===TffStringGrid====================================================}
+constructor TffStringGrid.Create(aOwner : TComponent);
+begin
+ inherited Create(aOwner);
+ sgSavedRow := nil;
+end;
+{--------}
+destructor TffStringGrid.Destroy;
+begin
+ if assigned(sgSavedRow) then
+ sgSavedRow.Free;
+ inherited Destroy;
+end;
+{--------}
+function TffStringGrid.AnyCellIsEmpty(const aRow : integer) : boolean;
+var
+ Inx : integer;
+begin
+ Result := False;
+ for Inx := FixedCols to pred(ColCount) do
+ if Cells[Inx, aRow] = '' then begin
+ Result := True;
+ break;
+ end;
+end;
+{--------}
+procedure TffStringGrid.BeginUpdate;
+begin
+ Perform(WM_SETREDRAW, 0, 0);
+end;
+{--------}
+procedure TffStringGrid.BlankRow(const aRow : integer);
+var
+ Inx : integer;
+begin
+ for Inx := FixedCols to pred(ColCount) do begin
+ Cells[Inx, aRow] := '';
+ Objects[Inx, aRow] := nil;
+ end;
+end;
+{--------}
+procedure TffStringGrid.CopyRow(const srcRow, destRow : integer);
+var
+ Inx : integer;
+begin
+ for Inx := FixedCols to pred(ColCount) do begin
+ Cells[Inx, destRow] := Cells[Inx, srcRow];
+ Objects[Inx, destRow] := Objects[Inx, srcRow];
+ end;
+end;
+{--------}
+function TffStringGrid.CreateEditor : TInplaceEdit;
+begin
+ {$ifdef fpc}
+ Result := TStringCellEditor(Editor);
+ {$else}
+ Result := TfFInPlaceEdit.Create(self);
+ {$endif}
+end;
+{--------}
+procedure TffStringGrid.EndUpdate;
+begin
+ Perform(WM_SETREDRAW, 1, 0);
+ Invalidate;
+end;
+{--------}
+function TffStringGrid.LastRowIsEmpty : boolean;
+begin
+ Result := RowIsEmpty(pred(RowCount));
+end;
+{--------}
+procedure TffStringGrid.MouseUp(Button: TMouseButton; Shift: TShiftState;
+ X, Y: Integer);
+var
+ Column, Row: Longint;
+begin
+ if (FixedRows > 0) and (FGridState <> gsColSizing) then begin
+ MouseToCell(X, Y, Column, Row);
+ if (Row = 0) and assigned(FOnSortColumn) then
+ FOnSortColumn(Self, Column);
+ end;
+ inherited MouseUp(Button, Shift, X, Y);
+end;
+{--------}
+procedure TffStringGrid.RestoreToRow(const aRow : integer);
+var
+ Inx : integer;
+begin
+ if assigned(sgSavedRow) then begin
+ for Inx := 0 to pred(sgSavedRow.Count) do begin
+ Cells[FixedCols + Inx, aRow] := sgSavedRow[Inx];
+ Objects[FixedCols + Inx, aRow] := sgSavedRow.Objects[Inx];
+ end;
+ sgSavedRow.Free;
+ sgSavedRow := nil;
+ end;
+end;
+{--------}
+function TffStringGrid.RowIsEmpty(const aRow : integer) : boolean;
+var
+ Inx : integer;
+begin
+ Result := True;
+ for Inx := FixedCols to pred(ColCount) do
+ if (Cells[Inx, aRow] <> '') then begin
+ Result := False;
+ break;
+ end;
+end;
+{--------}
+function TffStringGrid.RowIsFilled(const aRow : integer) : boolean;
+var
+ Inx : integer;
+begin
+ Result := True;
+ for Inx := FixedCols to pred(ColCount) do
+ if (Cells[Inx, aRow] = '') then begin
+ Result := False;
+ break;
+ end;
+end;
+{--------}
+procedure TffStringGrid.SaveRow(const aRow : integer);
+var
+ Inx : integer;
+begin
+
+ if assigned(sgSavedRow) then
+ sgSavedRow.Free;
+
+ sgSavedRow := TStringList.Create;
+ for Inx := FixedCols to pred(ColCount) do
+ sgSavedRow.AddObject(Cells[Inx, aRow], Objects[Inx, ARow]);
+end;
+{Begin !!.02}
+{--------}
+function TffStringGrid.SelectCell(ACol, ARow: Longint): Boolean;
+begin
+ Result := inherited SelectCell(aCol, aRow);
+ if Result then
+ sgEnterCell(Cells[aCol, aRow], aCol, aRow);
+end;
+{End !!.02}
+{--------}
+procedure TffStringGrid.sgEnterCell(const text : string; aCol, aRow : integer);
+begin
+ if assigned(FOnEnterCell) then
+ FOnEnterCell(self, aCol, aRow, text);
+end;
+{--------}
+procedure TffStringGrid.sgExitCell(const text : string; aCol, aRow : integer);
+begin
+ if assigned(FOnExitCell) then
+ FOnExitCell(self, aCol, aRow, text);
+end;
+{--------}
+function TffStringGrid.sgGetVersion : string; {new !!.07}
+begin
+ Result := Format('%5.4f', [ffVersionNumber / 10000.0]);
+end;
+{--------}
+procedure TffStringGrid.sgSetVersion(const aValue : string); {new !!.07}
+begin
+ {do nothing}
+end;
+{====================================================================}
+
+end.
diff --git a/components/flashfiler/sourcelaz/fflllgcy.pas b/components/flashfiler/sourcelaz/fflllgcy.pas
new file mode 100644
index 000000000..10bb5eea5
--- /dev/null
+++ b/components/flashfiler/sourcelaz/fflllgcy.pas
@@ -0,0 +1,1809 @@
+{*********************************************************}
+{* FlashFiler: TffLegacyTransport *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit fflllgcy;
+
+interface
+
+uses
+ dialogs,
+ classes,
+ messages,
+ windows,
+ ffdtmsgq,
+ ffllbase,
+ ffllcomp,
+ fflleng,
+ ffllcomm,
+ fflllog,
+ ffllprot,
+ ffllreq,
+ ffnetmsg;
+
+type
+
+ TffLegacyTransportThread = class; { foward declaration }
+
+ {The purpose of this class is to give us a way of re-using the existing
+ protocols until better protocols can be written. It instantiates a protocol
+ object based upon the specified protocol type.
+
+ If Listen := False then the transport is in Send mode and is used to send
+ requests to a remote listener. A sender thread is used to process sending
+ of requests and receiving of replies. A little hoop to jump through: The
+ transport must do two things: wait for requests to be submitted to its
+ UnsentRequestQueue and allow the legacy protocol to listen for messages.
+
+ If Listen := True then the transport is in Listen mode and starts a thread
+ for receiving of requests. When a request is received, it processes the
+ request via a worker thread.
+ }
+ TffLegacyTransport = class(TffThreadedTransport)
+ protected {private}
+ { See comments in TFFBaseTransport for _* fields }
+
+ FMsgQueue : TffDataMessageQueue;
+ {-When in Listen mode, used to hold partially received messages. }
+
+ FLostConnWindow : HWND;
+ {-Used to receive lost connection events from the protocol thread. }
+
+ FProtocol : TffBaseCommsProtocol;
+ {-The protocol instantiated by this transport. }
+
+ FProtocolType : TffProtocolType;
+ _FProtocolType : TffProtocolType;
+ {-The enumeration describing the protocol instantiated by this transport. }
+
+ FSendBuffer : PffnmHeader;
+ {-The buffer used to send messages to the remote server. }
+
+ FServerLocalName : TffNetName;
+ {-This is the local name portion of FServerName. For example,
+ if we are trying to reach 'prod1@127.0.0.1' then the server's local
+ name is 'prod1' and the server's address is '127.0.0.1' }
+
+ FServerAddress : TffNetName;
+ {-This is FServerName minus the local name of the server. For example,
+ if we are trying to reach 'prod1@127.0.0.1' then the server's local
+ name is 'prod1' and FServerAddress will be '127.0.0.1' }
+
+ FTransportThread : TffLegacyTransportThread;
+ {-If in Listen mode, this is the thread that is listening. If in Send
+ mode, this is the thread that will be sending requests. }
+
+ protected
+
+ procedure btBeginUpdatePrim; override;
+
+ procedure btEndUpdatePrim; override;
+
+ function btGetConnectionID(const anIndex : Longint) : TffClientID; override;
+ { Used to obtain the IDs of the protocol's connections. Handy for when
+ a server wants to send messages to one or more client connections. }
+
+ procedure btInternalReply(msgID : Longint;
+ errorCode : TffResult;
+ replyData : pointer;
+ replyDataLen : Longint); override;
+ { This method is called from TffBaseTransport.Reply. It sends the
+ reply to the client. }
+
+ procedure btSetRespondToBroadcasts(const respond : boolean); override;
+ { This implementation makes sure the legacy protocol is configured
+ properly if RespondToBroadcasts is changed while the transport is
+ active. }
+
+ procedure btSetServername(const aServername : string); override; {!!.10}
+ {-This method sets the server name. The implementation for this class
+ does not perform any validation. Transport subclasses should perform
+ their own validation. }
+
+ procedure lcLog(const aMsg : string); override;
+ { Use this method to write an error string to the event log. }
+
+ procedure ltFreeMsg(msg : PffDataMessage); virtual; {!!.01}
+
+ function ltGetProtocol : TffProtocolType; virtual;
+ { Used to get the legacy protocol. }
+
+{Begin !!.01}
+ procedure ltDoHangup(const aClientID : TffClientID);
+ { Hangup processing. }
+{End !!.01}
+
+ procedure ltLostConnection(var aMsg : TMessage);
+ { Message handler for lost connections window. }
+
+ function ltMapProtocolToClass : TffCommsProtocolClass;
+ { Maps the transport's protocol to its protocol class. }
+
+ procedure lcSetEventLog(anEventLog : TffBaseLog); override;
+ { Set the transport's event log. This overridden method makes sure the
+ protocol's EventLog property is kept up-to-date. }
+
+ procedure lcSetLogEnabled(const aEnabled : Boolean); override;
+ { This overridden method updates the logEnabled property of the
+ TffBaseCommsProtocol instance created by this component. }
+
+ procedure ltSetProtocol(aProtocol : TffProtocolType); virtual;
+ { Used to set the legacy protocol. }
+
+{Begin !!.05}
+ procedure ltTerminateThread;
+ { Terminate the transport thread if it is active. }
+{End !!.05}
+
+ procedure scInitialize; override;
+ { Called when the transport is to initialize itself for operation. This
+ implementation creates and initializes the protocol and transport
+ thread. }
+
+ procedure scPrepareForShutdown; override;
+ { This method is called when the transport is to prepare for shutdown. }
+
+ procedure scShutdown; override;
+ { This method is called when the transport is to shut down. }
+
+ procedure scStartup; override;
+ { This method is called when the transport is to start up. }
+
+ procedure tpConnectionLost(aSender : TObject;
+ aClientID : TffClientID);
+ {-Called when the transport is sending and the remote server engine
+ unexpectedly hangs up on the client. This method is called within the
+ context of the transport thread. It sends a message to the
+ transports lost connection window and the message is then processed
+ by ltLostConnection. }
+
+ procedure tpDatagramReceived(aSender : TObject;
+ const aName : TffNetName;
+ aData : PffByteArray;
+ aDataLen : Longint);
+ { Used to log receipt of broadcast requests in listening transport. }
+
+ function tpGetCodeStart(const aClientID : TffClientID) : integer;
+ { Used to obtain the starting encryption code for the specified client. }
+
+ procedure tpHandleAddClient(aMsg : PffDataMessage);
+ {-This method is called by a listening transport to process the adding
+ of a new client. }
+
+ procedure tpHandleNextRequest;
+ {-This method is used to handle the next unsent request. The request
+ is moved from the unsent queue to the waiting for reply list. }
+
+ procedure tpHandleRemoveClient(aMsg : PffDataMessage);
+ {-This method is called by a listening transport to process the removal
+ of an existing client. }
+
+ procedure tpInternalRequest(aRequest : TffRequest;
+ timeout : Longint;
+ aCookie : HWND); override;
+ {-Internal method for sending a request. This implementation assigns the
+ protocol's event log to the request and assigns the protocol's window
+ handle to the value of aCookie. }
+
+ function tpMsgReceived(aSender : TObject;
+ clientID : TffClientID;
+ msgData : PffByteArray;
+ msgDataLen : Longint) : boolean;
+ {-This method is called when a request is received from a client or
+ when a reply is received from a server. }
+
+ procedure tpPrepareThread;
+ { Prepares the legacy transport thread for work. }
+
+ procedure tpProcessCallback(const aProcessCookie : Longint); virtual;
+ { When in Listen mode, this method is called by the worker thread to
+ process the request received from the client.
+ This method stores information such as the clientID and requestID in
+ threadvars so that it may be used when replying to the client.
+ aProcessCookie is a pointer to the message received from the client.
+ The method passes the message to the command handler.
+ }
+
+ procedure tpRemoteClientHangup(aSender : TObject;
+ aClientID : TffClientID);
+ {-Called when the transport is listening and a) the client hangs up
+ or b) the transport decides to hang up on the client. }
+
+ function tpReplyReceived(aSender : TObject;
+ clientID : TffClientID;
+ replyData : PffByteArray;
+ replyDataLen : Longint) : boolean; virtual;
+ { When sending, this method is called when the legacy protocol has
+ received a reply from the server. In this implementation the
+ following occurs:
+ 1. If this reply is acknowledging the last message was received then
+ the request is sitting in the pending list. Find the request and
+ put it in the Unsent Requests queue.
+
+ 2. If this reply is a full-fledged response to a complete message, do
+ the following:
+
+ a. Find the TffRequest.
+ b. Place the reply data on the request.
+ c. Remove the request from the WaitingForReply list.
+ d. Call TffRequest.WakeUpThread.
+ }
+
+ function tpRequestReceived(aSender : TObject;
+ clientID : TffClientID;
+ requestData : PffByteArray;
+ requestDataLen : Longint) : boolean; virtual;
+ { When listening, this method is called when the protocol thread has
+ received a request from a client. The transport then spawns a worker
+ thread that performs the actual work. }
+
+ function tpSendReply(msgID : Longint;
+ clientID : TffClientID;
+ requestID : Longint;
+ errorCode : TffResult;
+ replyData : pointer;
+ replyDataLen : Longint) : TffResult;
+ { This method sends the actual reply to the client. The reply is
+ sent in context of the thread that processed the client's request,
+ not the listening thread. }
+
+ function tpSendRequest(aRequest : TffRequest) : TffResult;
+ { Sends a request via the protocol to the remove server. This method
+ returns DBIERR_NONE if the request was successfully sent. }
+
+ procedure tpShutdownProtocol;
+ { This method is called when the protocol thread stops executing.
+ It must be run in context of the protocol thread so that any
+ thread-specific items (e.g., windows, timers) may be destroyed. }
+
+ procedure tpStartProtocol;
+ { This method is called when the protocol thread begins execution.
+ It must be run in context of the protocol thread so that the
+ window handle created by the protocol is associated with the
+ thread. }
+
+ procedure tpThreadTerminated(Sender : TObject);
+ { This method is called when the transport thread terminates.
+ The purpose of this handler is to detect the case where the
+ thread terminates prematurely. }
+
+ public
+
+ constructor Create(aOwner : TComponent); override;
+ destructor Destroy; override;
+
+ function ConnectionCount : Longint; override;
+ { Returns the number of established connections. For a sender (i.e.,
+ client), this will be the number of connections to the remote server.
+ For a listener (i.e., server), this will be the number of
+ connections establshed by remote clients. }
+
+ function EstablishConnection(const aUserName : TffName;
+ aPasswordHash : integer;
+ aTimeout : Longint;
+ var aClientID : TffClientID ) : TffResult; override;
+ { Use this method to establish a connection with the server. If the
+ return code is DBIERR_NONE then aClientID will contain the clientID
+ supplied by the server. This clientID must be used in all subsequent
+ requests to the server. }
+
+ function GetName : string; override;
+ { Returns the transport's name. }
+
+ procedure GetServerNames(aList : TStrings; const timeout : Longint); override;
+ { Returns the list of servers available via this transport. }
+
+ function IsConnected : boolean; override;
+ { Use this method to determine if the transport is connected to a remote
+ server. It is considered connected if a) the transport's State is
+ ffesStarted and b) there is at least one established connection.
+ If the transport has been started but no connections have been
+ established then this method returns False. }
+
+ procedure Request(transportID : Longint;
+ clientID : TffClientID;
+ msgID : Longint;
+ timeout : Longint;
+ requestData : pointer;
+ requestDataLen : Longint;
+ replyCallback : TffReplyCallback;
+ replyCookie : Longint); override;
+ { When the transport is in Send mode, call this method in order to
+ submit a request to the transport.
+
+ Parameters are as follows:
+
+ @param transportID - For use by future transports.
+ @param clientID - The ID of the client submitting the request. This
+ must be the clientID originally supplied by the server or it may be
+ zero for unsecured calls (e.g., initially asking for a connection
+ to the server).
+ @param msgID - The type of message being sent.
+ @param timeout - The number of milliseconds in which a reply must be
+ received from the server.
+ @param requestData - Pointer to a data buffer containing the message
+ data.
+ @param requestDataLen - The length of requestData.
+ @param replyCallback - The procedure to be called when the reply
+ has been received from the server.
+ @param replyCookie - Whatever the calling object wants it to be. This
+ parameter is supplied to the replyCallback.
+ }
+
+ function Supported : boolean; override;
+ { Use this method to determine if the transport's current protocol is
+ supported on the workstation. Returns True if the protocol is
+ supported otherwise returns False. }
+
+ procedure TerminateConnection(const aClientID : TffClientID;
+ const timeout : Longint); override;
+ { Use this method to terminate a connection with the server. aClientID
+ is the clientID originally returned in the call to EstablishConnection.}
+
+ procedure Work; override;
+ { Based upon the transport's mode, this method tells the transport to
+ perform some work:
+
+ 1. When in sending mode, sends requests and processes replies
+ 2. When in listening mode, listens for requests.
+
+ This method should be structured such that it does a bit of work and
+ then returns. It is to be repeatedly called from the
+ TffLegacyTransportThread.Execute method so that the Execute method
+ may check the thread's Terminated property.
+ }
+
+ published
+
+ property Protocol : TffProtocolType
+ read ltGetProtocol
+ write ltSetProtocol
+ default ptRegistry;
+ { The legacy protocol to be used by this transport. Defaults to
+ ptRegistry. }
+
+ end;
+
+ { In order to support sending and receiving of messages without blocking
+ the client application or server, the legacy transport carries out
+ sending and receiving of messages through an instance of this class.
+
+ The thread is always created in suspended mode. It is resumed by
+ TffLegacyTransport.tpStartup.
+ }
+ TffLegacyTransportThread = class(TffThread)
+ private
+ FTransport : TffLegacyTransport;
+ { The transport starting this thread. }
+ FUnexpectedTermination : boolean;
+ { Set to True if thread terminated by an exception. }
+ protected
+
+ procedure Execute; override;
+ { This method repeatedly calls the transport's Work method. Execute
+ should be called only when the transport's Startup method is called. }
+
+ public
+
+ constructor Create(aTransport : TffLegacyTransport);
+ { When creating a listener thread, the parent transport is identified.
+ The thread is suspended. }
+
+ property UnexpectedTermination : boolean read FUnexpectedTermination;
+
+ end;
+
+implementation
+
+uses
+ forms,
+ sysutils,
+ ffclcfg,
+ ffllexcp,
+ ffllthrd,
+ ffllwsck,
+ ffsrbase,
+ ffsrbde
+ {$ifdef fpc},LCLIntf{$endif}; //soner LCLIntf for functions AllocateHWnd and DeallocateHWnd
+
+{$I ffconst.inc}
+
+const
+ ffc_ThreadDoneTimeout = 1000; { # milliseconds to wait for send/listen
+ thread to shutdown }
+ ffc_ThreadStartTimeout = 2000; { # milliseconds to wait for the transport
+ thread to start }
+ ffc_SingleUserServerName = 'Local';
+
+ { Prefixes for logging requests. }
+ ffc_Post = 'Post';
+ ffc_PostWait = 'Post&Wait';
+ ffc_Request = 'Req';
+
+ { Error messages. }
+ ffc_ErrMsgType = 'Bad msg type %d, Clnt %d, Msg %d';
+
+{===TffLegacyTransport===============================================}
+
+threadvar
+ ffitvClientID : TffClientID;
+ ffitvRequestID : Longint;
+
+constructor TffLegacyTransport.Create(aOwner : TComponent);
+begin
+ inherited Create(aOwner);
+ FLogEnabled := False;
+ {$IFDEF DCC6OrLater}
+ {$WARN SYMBOL_DEPRECATED OFF}
+ {$ENDIF}
+ {$ifdef fpc}
+ FLostConnWindow := LCLIntf.AllocateHWND(ltLostConnection); //soner
+ {$else}
+ FLostConnWindow := AllocateHWND(ltLostConnection);
+ {$endif}
+ {$IFDEF DCC6OrLater}
+ {$WARN SYMBOL_DEPRECATED ON}
+ {$ENDIF}
+ FProtocol := nil;
+ FProtocolType := ptRegistry;
+ FTransportThread := nil;
+ FSendBuffer := nil;
+end;
+{--------}
+destructor TffLegacyTransport.Destroy;
+begin
+ FFNotifyDependents(ffn_Destroy);
+ ltTerminateThread; {!!.05}
+ {$IFDEF DCC6OrLater}
+ {$WARN SYMBOL_DEPRECATED OFF}
+ {$ENDIF}
+ {$ifdef fpc}
+ LCLIntf.DeallocateHWnd(FLostConnWindow); //soner
+ {$else}
+ DeallocateHWnd(FLostConnWindow);
+ {$endif}
+ {$IFDEF DCC6OrLater}
+ {$WARN SYMBOL_DEPRECATED ON}
+ {$ENDIF}
+ inherited Destroy;
+end;
+{--------}
+procedure TffLegacyTransport.btBeginUpdatePrim;
+begin
+ inherited btBeginUpdatePrim;
+
+ { Set the _* fields to match their counterparts }
+ _FProtocolType := FProtocolType;
+end;
+{--------}
+procedure TffLegacyTransport.btEndUpdatePrim;
+begin
+ { Update the fields with their _* counterparts. }
+ { All property write methods are required to check that the new value }
+ { does not match the old value! }
+ Protocol := _FProtocolType;
+ if Protocol = ptSingleUser then
+ _FServerName := ServerName;
+
+ if assigned(FProtocol) then
+ FProtocol.LogEnabled := _FLogEnabled;
+
+ inherited btEndUpdatePrim;
+end;
+{--------}
+function TffLegacyTransport.btGetConnectionID(const anIndex : Longint) : TffClientID;
+begin
+ Result := FProtocol.ConnectionIDs[anIndex];
+end;
+{--------}
+function TffLegacyTransport.ConnectionCount : Longint;
+begin
+ if assigned(FProtocol) then
+ Result := FProtocol.ConnectionCount
+ else
+ Result := 0;
+end;
+{--------}
+function TffLegacyTransport.EstablishConnection
+ (const aUserName : TffName;
+ aPasswordHash : integer;
+ aTimeout : Longint;
+ var aClientID : TffClientID ) : TffResult;
+var
+ aRequest : TffRequest;
+ AttachReq : TffnmAttachServerReq;
+ CallReq : TffnmCallServerReq;
+ PAttachRpy : PffnmAttachServerRpy;
+begin
+
+ btCheckSender;
+ btCheckServerName;
+ scCheckStarted;
+
+ { Have the protocol contact the server.
+ Note that we will get back a temporary clientID from the protocol.
+ This temporary ID will be replaced once we have a good one from
+ the server. }
+ CallReq.ServerName := FServerAddress;
+ aRequest := TffRequest.Create(aClientID, ffnmCallServer, @CallReq,
+ sizeOf(CallReq), aTimeout, ffrmReplyExpected);
+ try
+ tpInternalRequest(aRequest, aTimeout, FProtocol.NotifyWindow);
+ Result := aRequest.ErrorCode;
+ if Result <> DBIERR_NONE then begin
+ aRequest.Free;
+ exit;
+ end;
+ except
+ { If an exception occurs then the transport thread is responsible for
+ freeing the request. }
+ on E:EffException do begin
+ Result := E.ErrorCode;
+ exit;
+ end else
+ raise;
+ end;
+
+ { Connection successful. Get the clientID from the server. }
+ Assert(assigned(aRequest.ReplyData));
+ aClientID := PffnmCallServerRpy(aRequest.ReplyData)^.ClientID;
+ aRequest.Free;
+
+ { Obtain permission to attach a client. }
+ with AttachReq do begin
+ ClientName := aUserName;
+ UserID := aUserName;
+ Timeout := aTimeout;
+ ClientVersion := ffVersionNumber;
+ end;
+
+ { Submit the request. }
+ aRequest := TffRequest.Create(aClientID, ffnmAttachServer, @AttachReq,
+ sizeOf(AttachReq), aTimeout, ffrmReplyExpected);
+ try
+ tpInternalRequest(aRequest, aTimeout, FProtocol.NotifyWindow);
+ except
+ { If an exception occurs then the transport thread is responsible for
+ freeing the request. }
+ on E:EffException do begin
+ Result := E.ErrorCode;
+ exit;
+ end else
+ raise;
+ end;
+
+ { Evaluate the reply. }
+ Result := aRequest.ErrorCode;
+ if Result = DBIERR_NONE then begin
+ pAttachRpy := PffnmAttachServerRpy(aRequest.ReplyData);
+ with pAttachRpy^ do begin
+ { Have the protocol update our connection's clientID. }
+ FProtocol.UpdateClientID(aClientID, ClientID);
+ aClientID := ClientID;
+
+ if IsSecure then
+ FProtocol.InitCode(aClientID, Code xor Longint(aPasswordHash))
+ else
+ FProtocol.InitCode(aClientID, Code);
+
+ {Update the protocol's keep alive information. }
+ FProtocol.KeepAliveInterval := KAIntvl;
+ FProtocol.KeepAliveRetries := KARetries;
+ FProtocol.LastMsgInterval := LastMsgIntvl;
+ FProtocol.ResetKeepAliveTimer; {!!.06}
+
+ { Check secure communications...}
+ aRequest.Free;
+ aRequest := TffRequest.Create(aClientID, ffnmCheckSecureComms, nil, 0,
+ aTimeout, ffrmReplyExpected);
+ try
+ tpInternalRequest(aRequest, aTimeout, FProtocol.NotifyWindow);
+ except
+ { If an exception occurs then the transport thread is responsible for
+ freeing the request. }
+ on E:EffException do begin
+ Result := E.ErrorCode;
+ exit;
+ end else
+ raise;
+ end;
+ Result := aRequest.ErrorCode;
+ if Result <> DBIERR_NONE then begin
+ { The password is bogus. }
+ FProtocol.HangUpByClientID(aClientID);
+ if Result <> fferrReplyTimeout then {!!.06}
+ Result := DBIERR_INVALIDUSRPASS; {!!.06}
+ end; { if }
+ end; { with }
+ end else
+ { Server rejected us. Tell protocol to get rid of the connection. }
+ FProtocol.HangUpByClientID(aClientID);
+
+{Begin !!.06}
+ { If timed out waiting for a reply then we need to remove this request from
+ the waiting for reply queue. }
+ if Result = fferrReplyTimeout then
+ with FWaitingForReplyList.BeginWrite do
+ try
+ Delete(Longint(aRequest));
+ finally
+ EndWrite;
+ end;
+{End !!.06}
+
+ if assigned(aRequest) then
+ aRequest.Free;
+
+end;
+{Begin !!.01}
+{--------}
+procedure TffLegacyTransport.ltFreeMsg(msg : PffDataMessage);
+begin
+ if Msg^.dmDataLen > 0 then
+ FFFreeMem(Msg^.dmData, Msg^.dmDataLen);
+ FFFreeMem(Msg, SizeOf(TffDataMessage));
+end;
+{End !!.01}
+{--------}
+procedure TffLegacyTransport.ltLostConnection(var aMsg : TMessage);
+begin
+ { Lost connection message? Event handler declared? }
+ if (aMsg.Msg = ffm_LostConnection) then begin {!!.01}
+ if assigned(FOnConnectionLost) then begin
+ FOnConnectionLost(Self, aMsg.wParam)
+ end else
+ if csDesigning in ComponentState then
+ AutoConnectionLost(Self, aMsg.WParam);
+ end {!!.01}
+ else if aMsg.Msg = WM_QUERYENDSESSION then {!!.01}
+ aMsg.Result := 1 {!!.01}
+ else {!!.01}
+ Dispatch(aMsg); {!!.01}
+end;
+{--------}
+function TffLegacyTransport.ltMapProtocolToClass : TffCommsProtocolClass;
+var
+ protName : TffShStr;
+begin
+ if (FProtocolType <> ptRegistry) then begin
+ case Protocol of
+ ptSingleUser : Result := TffSingleUserProtocol;
+ ptTCPIP : Result := TffTCPIPProtocol;
+ ptIPXSPX : Result := TffIPXSPXProtocol;
+ else
+ Result := TffSingleUserProtocol;
+ end;
+ end
+ else
+ FFClientConfigReadProtocol(Result, protName);
+end;
+{--------}
+function TffLegacyTransport.GetName : string;
+begin
+ Result := ltMapProtocolToClass.GetProtocolName;
+end;
+{--------}
+procedure TffLegacyTransport.GetServerNames(aList : TStrings;
+ const timeout : Longint);
+var
+ OldServerNameRequired : boolean;
+ OldState : TffState;
+begin
+
+ if not assigned(aList) then
+ Exit;
+
+ OldState := scState;
+ OldServerNameRequired := false;
+
+ { If the transport has not been started, temporarily start the transport. }
+ if OldState <> ffesStarted then begin
+ OldServerNameRequired := FServerNameRequired;
+ FServerNameRequired := false;
+ State := ffesStarted;
+ end;
+
+ { Note: This is done outside the transport's sender thread. It should
+ not interfere with the sender thread's normal operation. }
+{Begin !!.05}
+ if Assigned(FProtocol) then
+ FProtocol.GetServerNames(aList, timeout)
+ else
+ aList.Clear;
+{End !!.05}
+
+ { Restore transport to original state. }
+ if OldState <> ffesStarted then begin
+ State := OldState;
+ FServerNameRequired := OldServerNameRequired;
+ end;
+
+end;
+{--------}
+procedure TffLegacyTransport.btInternalReply(msgID : Longint;
+ errorCode : TffResult;
+ replyData : pointer;
+ replyDataLen : Longint);
+begin
+ inherited btInternalReply(msgID, errorCode, replyData, replyDataLen);
+ tpSendReply(msgID, ffitvClientID, ffitvRequestID, errorCode,
+ replyData, replyDataLen);
+end;
+{--------}
+function TffLegacyTransport.IsConnected : boolean;
+begin
+ { We are connected if we are in the right state and there is at least one
+ established connection. }
+ Result := (scState = ffesStarted) and (FProtocol.ConnectionCount > 0);
+end;
+{--------}
+procedure TffLegacyTransport.lcLog(const aMsg : string);
+begin
+ if FLogEnabled and assigned(FEventLog) and (fftpLogErrors in FLogOptions) then
+ FEventLog.WriteString(aMsg);
+end;
+{--------}
+procedure TffLegacyTransport.lcSetLogEnabled(const aEnabled : Boolean);
+begin
+ inherited lcSetLogEnabled(aEnabled);
+ if (UpdateCount = 0) and assigned(FProtocol) then
+ FProtocol.LogEnabled := aEnabled;
+end;
+{--------}
+function TffLegacyTransport.ltGetProtocol : TffProtocolType;
+begin
+ Result := FProtocolType;
+end;
+{Begin !!.01}
+{--------}
+type
+ ProtocolCracker = class(TffBaseCommsProtocol);
+
+procedure TffLegacyTransport.ltDoHangup(const aClientID : TffClientID);
+{Rewritten !!.05}
+var
+ conn : TffConnection;
+ errorCode : TffResult;
+begin
+ conn := ProtocolCracker(FProtocol).cpGetConnection(aClientID);
+ if Assigned(conn) and (not conn.HangupDone) then begin
+ if assigned(FOnRemoveClient) then
+ FOnRemoveClient(Self, aClientID, errorCode)
+ else
+ { No handler assigned. Log an error. }
+ lcLogFmt('No RemoveClientHandler for transport %d', [GetName]);
+ conn.HangupDone := True;
+ end;
+end;
+{End !!.01}
+{--------}
+procedure TffLegacyTransport.ltSetProtocol(aProtocol : TffProtocolType);
+begin
+ if (UpdateCount > 0) then
+ _FProtocolType := aProtocol
+ else begin
+ {Check to make sure the new property is different.}
+ if FProtocolType = aProtocol then Exit;
+
+ {Note: If you ever remove the following requirement, update the Supported
+ test at the end of this routine. }
+ scCheckInactive;
+ FProtocolType := aProtocol;
+ if FProtocolType = ptSingleUser then begin
+ FServerNameRequired := False;
+ ServerName := ffc_SingleUserServerName;
+ end;
+
+ { Is this protocol supported on the workstation? }
+ if Supported then
+ scState := ffesInactive
+ else
+ scState := ffesUnsupported;
+ end;
+end;
+{Begin !!.05}
+{--------}
+procedure TffLegacyTransport.ltTerminateThread;
+begin
+ if assigned(FTransportThread) then begin
+ FTransportThread.Terminate;
+ FTransportThread.WaitForEx(5000);
+ FTransportThread.Free;
+ FTransportThread := nil;
+ end;
+end;
+{End !!.05}
+{--------}
+procedure TffLegacyTransport.btSetRespondToBroadcasts(const respond : boolean);
+var
+ OldValue : boolean;
+begin
+ OldValue := FRespondToBroadcasts;
+ inherited btSetRespondToBroadcasts(respond);
+ if (OldValue <> FRespondToBroadcasts) and
+ (scState = ffesStarted) then
+ if respond then
+ FProtocol.ReceiveDatagram
+ else
+ FProtocol.StopReceiveDatagram;
+end;
+{--------}
+procedure TffLegacyTransport.btSetServerName(const aServerName : string); {!!.10}
+begin
+ inherited btSetServerName(aServerName);
+ FFSplitNetAddress(aServerName, FServerLocalName, FServerAddress);
+end;
+{--------}
+procedure TffLegacyTransport.lcSetEventLog(anEventLog : TffBaseLog);
+begin
+ inherited lcSetEventLog(anEventLog);
+ if assigned(FProtocol) then
+ FProtocol.EventLog := anEventLog;
+end;
+{--------}
+procedure TffLegacyTransport.Request(transportID : Longint;
+ clientID : TffClientID;
+ msgID : Longint;
+ timeout : Longint;
+ requestData : pointer;
+ requestDataLen : Longint;
+ replyCallback : TffReplyCallback;
+ replyCookie : Longint);
+var
+ aRequest : TffRequest;
+
+begin
+ scCheckStarted;
+ aRequest := TffRequest.Create(clientID, msgID, requestData, requestDataLen,
+ timeout, ffrmReplyExpected);
+ tpInternalRequest(aRequest, timeout, FProtocol.NotifyWindow);
+ if assigned(replyCallback) then
+ replyCallback(aRequest.ReplyMsgID, aRequest.ErrorCode,
+ aRequest.ReplyData, aRequest.ReplyDataLen,
+ replyCookie);
+ if not aRequest.Aborted then
+ aRequest.Free
+ else
+ with aRequest do
+ tpLogReqMisc(format(ffc_ReqAborted,[Longint(aRequest), ClientID,
+ ErrorCode, Timeout]));
+end;
+{--------}
+procedure TffLegacyTransport.scInitialize;
+var
+ protClass : TffCommsProtocolClass;
+ whichSideOfTheCoin : TffClientServerType;
+begin
+
+ { Make sure the old protocol is freed. }
+ if assigned(FProtocol) then begin
+ if FProtocol.IsStarted then begin
+ scPrepareForShutdown;
+ scShutdown;
+ end;
+ end;
+
+ { If we are in sending mode then verify we have a target server. }
+ if FMode = fftmSend then
+ btCheckServerName;
+
+ { Figure out which type of protocol we are to instantiate. }
+ protClass := ltMapProtocolToClass;
+
+ if assigned(FMsgQueue) then begin
+ FMsgQueue.Free;
+ FMsgQueue := nil;
+ end;
+
+ { Figure out the protocol's mode. }
+ if FMode = fftmListen then
+ whichSideOfTheCoin := csServer
+ else
+ whichSideOfTheCoin := csClient;
+
+ FMsgQueue := TffDataMessageQueue.Create;
+
+ FProtocol := protClass.Create(FServerName, whichSideOfTheCoin);
+ if FMode = fftmListen then
+ with FProtocol do begin
+ OnConnectionLost := tpRemoteClientHangup;
+ OnHangUp := tpRemoteClientHangup;
+ OnHeardCall := nil;
+ OnReceiveDatagram := tpDatagramReceived;
+ OnReceiveMsg := tpMsgReceived;
+ end
+ else
+ with FProtocol do begin
+ OnConnectionLost := tpConnectionLost;
+ OnHangUp := nil;
+ OnHeardCall := nil;
+ OnReceiveDatagram := nil;
+ OnReceiveMsg := tpMsgReceived;
+ end;
+
+ FProtocol.EventLog := FEventLog; {!!.01}
+ FProtocol.LogEnabled := FLogEnabled;
+
+ { If we are listening then get our servername from the protocol. }
+ if FMode = fftmListen then
+ FServerName := FProtocol.NetName;
+
+ FFGetMem(FSendBuffer, FProtocol.MaxNetMsgSize);
+
+ tpPrepareThread;
+
+end;
+{--------}
+procedure TffLegacyTransport.scPrepareForShutdown;
+{Rewritten !!.05}
+begin
+ ltTerminateThread;
+end;
+{--------}
+procedure TffLegacyTransport.scShutdown;
+begin
+ try
+ { Note: We can't free the protocol or the thread until we know they have
+ finished or a certain number of milliseconds has elapsed. }
+ ltTerminateThread; {!!.05}
+ finally
+
+{Begin !!.03}
+ if assigned(FSendBuffer) then begin
+ FFFreeMem(FSendBuffer, FProtocol.MaxNetMsgSize);
+ FSendBuffer := nil;
+ end;
+{End !!.03}
+
+ if assigned(FMsgQueue) then begin
+ FMsgQueue.Free;
+ FMsgQueue := nil;
+ end;
+
+ if assigned(FProtocol) then begin
+ FProtocol.Free;
+ FProtocol := nil;
+ end;
+
+ if assigned(FTransportThread) then
+ { By this time, the transport thread will have freed itself. }
+ FTransportThread := nil;
+ end;
+end;
+{--------}
+procedure TffLegacyTransport.scStartup;
+begin
+ FTransportThread.Resume;
+
+ { An exception during protocol startup might leave the thread in a terminated
+ state. If the thread is still going, wait for the thread to finish or fail
+ startup. }
+ if (not FTransportThread.Terminated) then
+ FProtocol.StartedEvent.WaitFor(ffc_ThreadStartTimeout);
+
+ { If the thread fails then raise an exception. }
+ if not FProtocol.IsStarted then
+ raise EffException.CreateEx(ffStrResGeneral, fferrProtStartupFail,
+ [(FProtocol as TffBaseCommsProtocol).GetProtocolName]);
+
+end;
+{--------}
+function TffLegacyTransport.Supported : boolean;
+begin
+ Result := ltMapProtocolToClass.Supported;
+end;
+{--------}
+procedure TffLegacyTransport.TerminateConnection(const aClientID : TffClientID;
+ const timeout : Longint);
+begin
+{Begin delete !!.05}
+ { Post a message to the server stating that we are hanging up. }
+// Post(0, aClientID, ffnmDetachServer, nil, 0, timeout, ffrmNoReplyWaitUntilSent);
+ { After we know the message has been sent, tell the protocol to hangup. }
+{End delete !!.05}
+ { Tell the protocol to hangup. } {!!.05}
+ if assigned(FProtocol) then
+ FProtocol.HangUpByClientID(aClientID);
+end;
+{--------}
+procedure TffLegacyTransport.tpConnectionLost(aSender : TObject;
+ aClientID : TffClientID);
+{Begin !!.01}
+var
+ anInx : Longint;
+ aRequest : TffRequest;
+{End !!.01}
+ RequestFound : Boolean;
+begin
+// PostMessage(FLostConnWindow, ffm_LostConnection, aClientID, 0); {Deleted !!.12}
+{Begin !!.01}
+ { Abort the request pending for this client. There should be only one pending
+ request for the client at any one time. }
+ with FWaitingForReplyList.BeginRead do
+ try
+ RequestFound := False; {!!.13}
+ for anInx := 0 to pred(Count) do begin
+ aRequest := TffRequest(TffIntListItem(Items[anInx]).KeyAsInt);
+ if aRequest.ClientID = aClientID then begin
+ RequestFound := True; {!!.13}
+{Begin !!.12}
+ { If the request was something other than to check secure
+ communications (i.e., no password handling involved) then
+ post a message to the lost connection window. }
+ if aRequest.MsgID <> ffnmCheckSecureComms then
+ PostMessage(FLostConnWindow, ffm_LostConnection, aClientID, 0);
+{End !!.12}
+ { Mark the request as having lost its connection. }
+ aRequest.SetReply(aRequest.MsgID, fferrConnectionLost, nil, 0, 0);
+ { Remove the request's entry from the list. }
+ DeleteAt(anInx);
+ aRequest.WakeUpThread;
+ break;
+ end; { if }
+ end; { for }
+ if not RequestFound then {!!.13}
+ PostMessage(FLostConnWindow, ffm_LostConnection, aClientID, 0);{!!.13}
+ finally
+ EndRead;
+ end;
+{End !!.01}
+end;
+{--------}
+procedure TffLegacyTransport.tpDatagramReceived(aSender : TObject;
+ const aName : TffNetName;
+ aData : PffByteArray;
+ aDataLen : Longint);
+begin
+ tpLogReqMisc(format('Rcvd datagram from %s', [aName]));
+end;
+{--------}
+function TffLegacyTransport.tpGetCodeStart(const aClientID : TffClientID) : integer;
+begin
+ Result := FProtocol.GetCodeStart(aClientID);
+end;
+{--------}
+procedure TffLegacyTransport.tpHandleAddClient(aMsg : PffDataMessage);
+var
+ aReply : TffnmAttachServerRpy;
+ aClientID : TffClientID;
+ aVersionNumber : Longint;
+ errorCode : TffResult;
+ isSecure : boolean;
+ passwordHash : TffWord32;
+begin
+ if assigned(FOnAddClient) then begin
+ FOnAddClient(Self, PffnmAttachServerReq(aMsg^.dmData)^.userID,
+ PffnmAttachServerReq(aMsg^.dmData)^.timeout,
+ PffnmAttachServerReq(aMsg^.dmData)^.clientVersion,
+ passwordHash, aClientID, errorCode, isSecure, aVersionNumber);
+
+ { Build a reply. }
+ aReply.ClientID := aClientID;
+ aReply.VersionNumber := aVersionNumber;
+{Begin !!.05}
+ FProtocol.ConnLock;
+ try
+ if isSecure then
+ aReply.Code := TffWord32(tpGetCodeStart(aMsg^.dmClientID)) xor passwordHash
+ else
+ aReply.Code := tpGetCodeStart(aMsg^.dmClientID);
+ aReply.IsSecure := isSecure;
+ aReply.LastMsgIntvl := ffc_LastMsgInterval;
+ aReply.KAIntvl := ffc_KeepAliveInterval;
+ aReply.KARetries := ffc_KeepAliveRetries;
+
+ { Send the reply. }
+ Reply(aMsg^.dmMsg, errorCode, @aReply, sizeOf(TffnmAttachServerRpy));
+
+ { Update the clientID maintained by the protocol. }
+ if errorCode = DBIERR_NONE then
+ FProtocol.UpdateClientID(aMsg^.dmClientID, aClientID);
+ finally
+ FProtocol.ConnUnlock;
+ end;
+{End !!.05}
+
+ end else
+ { No handler assigned. Send back an error. }
+ Reply(aMsg^.dmMsg, DBIERR_FF_NoAddHandler, nil, 0);
+
+ { Free the message data. } {!!.01}
+ ltFreeMsg(aMsg); {!!.01}
+end;
+{--------}
+procedure TffLegacyTransport.tpHandleNextRequest;
+var
+ anItem : TffIntListItem;
+ aRequest : TffRequest;
+ Status : TffResult;
+begin
+
+ { Any messages in unsent request queue? Note that we don't care about
+ thread-safeness to check the count. We want to improve performance
+ by locking the queue only when necessary. If something slips into the
+ queue, we will run through this loop again very soon and pick it up
+ at that point. }
+ anItem := nil;
+ if FUnsentRequestQueue.Count > 0 then
+ { Yes. Grab one. }
+ with FUnsentRequestQueue.BeginWrite do
+ try
+ anItem := TffIntListItem(FUnsentRequestQueue.Dequeue);
+ finally
+ EndWrite;
+ end;
+
+ if assigned(anItem) then begin
+ aRequest := TffRequest(anItem.KeyAsInt);
+ anItem.Free;
+ { If this request has already timed out then ignore it. }
+ if aRequest.Aborted then
+ aRequest.Free
+ else begin
+ { Otherwise send the request. }
+ Status := tpSendRequest(aRequest);
+ if (Status <> DBIERR_NONE) and
+ (aRequest.ReplyMode = ffrmReplyExpected) then begin
+ aRequest.ErrorCode := Status;
+ aRequest.WakeUpThread;
+ end;
+ end;
+ end;
+
+end;
+{--------}
+procedure TffLegacyTransport.tpHandleRemoveClient(aMsg : PffDataMessage);
+//var {Deleted !!.01}
+// errorCode : TffResult; {Deleted !!.01}
+begin
+{Begin !!.01}
+ ltDoHangup(aMsg^.dmClientID);
+// if assigned(FOnRemoveClient) then
+// FOnRemoveClient(Self, aMsg^.dmClientID, errorCode)
+// else
+ { No handler assigned. Log an error. }
+// lcLogFmt(('No RemoveClientHandler for transport %d', [GetName]));
+{End !!.01}
+ { Free the message data. } {!!.01}
+ ltFreeMsg(aMsg); {!!.01}
+end;
+{--------}
+procedure TffLegacyTransport.tpInternalRequest(aRequest : TffRequest;
+ timeout : Longint;
+ aCookie : HWND);
+var
+ anItem : TffIntListItem;
+begin
+ aRequest.EventLog := FEventLog;
+ anItem := TffIntListItem.Create(Longint(aRequest));
+ anItem.MaintainLinks := False; {!!.01}
+ with FUnsentRequestQueue.BeginWrite do
+ try
+ Enqueue(anItem);
+ finally
+ EndWrite;
+ end;
+
+ if (aCookie <> 0) and IsWindow(aCookie) then
+ PostMessage(aCookie, 0, 0, 0);
+
+ { Wait for the reply. If a timeout occurs, assume the request object
+ will be freed by the transport thread at some point. Timeout exceptions
+ are raised to the calling object. }
+ if timeout = 0 then
+ aRequest.WaitForReply(timeout)
+ else
+ aRequest.WaitForReply(timeout + ffcl_RequestLatencyAdjustment);
+
+end;
+{--------}
+function TffLegacyTransport.tpMsgReceived(aSender : TObject;
+ clientID : TffClientID;
+ msgData : PffByteArray;
+ msgDataLen : Longint) : boolean;
+var
+ MsgHeader : PffnmHeader absolute msgData;
+begin
+// Result := False; {!!.01}
+ case MsgHeader^.nmhMsgType of
+ ffmtRequest:
+ Result := tpRequestReceived(aSender, clientID, msgData, msgDataLen);
+ ffmtReply:
+ Result := tpReplyReceived(aSender, clientID, msgData, msgDataLen);
+{Begin !!.01}
+ else begin
+ lcLogFmt(ffc_ErrMsgType,
+ [MsgHeader^.nmhMsgType, MsgHeader^.nmhClientID,
+ MsgHeader^.nmhMsgID]);
+ { Pass it on to tpRequestReceived as this may just be the result of a
+ user entering a bad password. }
+ Result := tpRequestReceived(aSender, clientID, msgData, msgDataLen);
+ end;
+ end; { case }
+{End !!.01}
+end;
+{--------}
+procedure TffLegacyTransport.tpPrepareThread;
+begin
+ if assigned(FTransportThread) then
+ FTransportThread.Free;
+ FTransportThread := TffLegacyTransportThread.Create(Self);
+ FTransportThread.FreeOnTerminate := False;
+ FTransportThread.OnTerminate := tpThreadTerminated;
+end;
+{--------}
+procedure TffLegacyTransport.tpProcessCallback(const aProcessCookie : Longint);
+var
+ conn : TffConnection;
+ msg : PffDataMessage;
+begin
+
+ btStoreSelfInThreadvar;
+
+{Begin !!.05}
+ msg := PffDataMessage(aProcessCookie);
+ conn := ProtocolCracker(FProtocol).cpGetConnection(msg^.dmClientID);
+ if conn <> nil then begin
+ conn.HangupLock;
+ try
+ { Save off some data for when we reply. }
+ ffitvClientID := msg^.dmClientID;
+ ffitvRequestID := msg^.dmRequestID;
+
+ { Is this a request to add a client? }
+ if (msg^.dmMsg = ffnmAttachServer) then begin
+ tpHandleAddClient(msg)
+ { Remove a client? }
+ end else if (msg^.dmMsg = ffnmDetachServer) then begin
+ tpHandleRemoveClient(msg)
+ end else
+ { None of the above. Call our Process method which will pass the message
+ onto the appropriate command handlers. }
+ Process(msg)
+ finally
+ conn.HangupUnlock;
+ end;
+ end;
+{End !!.05}
+end;
+{--------}
+procedure TffLegacyTransport.tpRemoteClientHangup(aSender : TObject;
+ aClientID : TffClientID);
+//var {Deleted !!.01}
+// errorCode : TffResult; {Deleted !!.01}
+begin
+ { As a just in case, make sure the client is removed. }
+{Begin !!.01}
+ ltDoHangup(aClientID);
+// if assigned(FOnRemoveClient) then
+// FOnRemoveClient(Self, aClientID, errorCode);
+{End !!.01}
+end;
+{--------}
+function TffLegacyTransport.tpReplyReceived(aSender : TObject;
+ clientID : TffClientID;
+ replyData : PffByteArray;
+ replyDataLen : Longint): boolean;
+var
+ msgHeader : PffnmHeader absolute replyData;
+ anItem : TffIntListItem;
+ aRequest : TffRequest;
+begin
+ Result := True;
+
+ { Find the request. }
+ with FWaitingForReplyList.BeginRead do
+ try
+ anItem := TffIntListItem
+ (FWaitingForReplyList
+ [FWaitingForReplyList.Index(msgHeader^.nmhRequestID)]);
+ finally
+ EndRead;
+ end;
+
+ { Did we find the request? If so then set its reply data.
+
+ If we did not find the request then the requesting thread timed out
+ and we can just toss the reply into the bitbucket. }
+ if assigned(anItem) then begin
+ aRequest := TffRequest(anItem.keyAsInt);
+
+ with msgHeader^ do
+ if msgHeader^.nmhFirstPart then
+ aRequest.SetReply(nmhMsgID, nmhErrorCode, @nmhData, nmhTotalSize,
+ replyDataLen - ffc_NetMsgHeaderSize)
+ else
+ aRequest.AddToReply(@nmhData, replyDataLen - ffc_NetMsgHeaderSize);
+
+ { If this is the last part of the message then remove the request from
+ the waiting list. }
+ if msgHeader^.nmhLastPart then begin
+ with FWaitingForReplyList.BeginWrite do
+ try
+ Delete(Longint(msgHeader^.nmhRequestID));
+ finally
+ EndWrite;
+ end;
+ { If the request has been aborted then get rid of it otherwise
+ wake up the requesting thread. }
+ if aRequest.Aborted then
+ aRequest.Free
+ else begin
+ tpLogReply(aRequest);
+ aRequest.WakeUpThread;
+ end;
+ end;
+
+ end else begin
+ lcLogFmt('Could not find Request %d, msgID %d',
+ [msgHeader^.nmhRequestID, msgHeader^.nmhMsgID]);
+ end;
+
+end;
+{--------}
+function TffLegacyTransport.tpRequestReceived(aSender : TObject;
+ clientID : TffClientID;
+ requestData : PffByteArray;
+ requestDataLen : Longint) : boolean;
+var
+ MsgHeader : PffnmHeader absolute requestData;
+ MsgNode : PffDataMessageNode;
+begin
+ Result := True;
+
+ with MsgHeader^ do begin
+
+ { Verify the client id in the message is correct. If not then either
+ we have a fake client using the wrong encryption or something else is
+ goofed up. Hangup. }
+ if (nmhMsgID <> ffnmAttachServer) and
+ (clientID <> nmhClientID) then begin
+
+ if FLogEnabled and assigned(FEventLog) and
+ (fftpLogErrors in FLogOptions) then
+ FEventLog.WriteStrings(['Hanging up due to bad client password',
+ Format(' ClientID (actual) %d', [clientID]),
+ Format(' ClientID (msg) %d', [nmhClientID]),
+ Format(' MsgID %d', [nmhMsgID])]);
+
+ FProtocol.HangUpByClientID(clientID);
+ Result := false;
+ Exit;
+ end;
+
+ if FLogEnabled and assigned(FEventLog) and
+ (fftpLogRequests in FLogOptions) then
+ tpLogReq2(ffc_Request, nmhRequestID, clientID, nmhMsgID, @nmhData,
+ requestDataLen - ffc_NetMsgHeaderSize, nmhTimeout);
+
+ with FMsgQueue.BeginWrite do
+ try
+ if nmhFirstPart then
+ MsgNode := Append(nmhMsgID,
+ clientID,
+ nmhRequestID,
+ nmhTimeout,
+ 0,
+ @nmhData,
+ requestDataLen - ffc_NetMsgHeaderSize,
+ nmhTotalSize)
+ else
+ MsgNode := AddToData(nmhMsgID,
+ clientID,
+ nmhRequestID,
+ @nmhData,
+ requestDataLen - ffc_NetMsgHeaderSize);
+ finally
+ EndWrite;
+ end;
+
+ { Is this the last part of the message? }
+ if assigned(MsgNode) then begin
+ { Yes. Do we have a thead pool? }
+ if assigned(FThreadPool) then
+ { Yes. Pass this request off to a worker thread. }
+ FThreadPool.ProcessThreaded(tpProcessCallback, Longint(MsgNode^.dmnMsg))
+ else
+ { No. Handle this ourselves. }
+ tpProcessCallback(Longint(MsgNode^.dmnMsg));
+
+ { Get rid of the request on the message queue. }
+ with FMsgQueue.BeginWrite do
+ try
+ Remove(MsgNode, false);
+ finally
+ EndWrite;
+ end;
+ end;
+ end; { with }
+end;
+{--------}
+function TffLegacyTransport.tpSendReply(msgID : Longint;
+ clientID : TffClientID;
+ requestID : Longint;
+ errorCode : TffResult;
+ replyData : pointer;
+ replyDataLen : Longint) : TffResult;
+var
+ BytesToGo : Longint;
+ BytesToSend : Longint;
+ FirstMsg : boolean;
+ LastMsg : boolean;
+ StartOffset : Longint;
+ SendBuffer : PffnmHeader;
+begin
+
+ try
+
+ FFGetMem(SendBuffer, FProtocol.MaxNetMsgSize);
+
+ try
+ { Set up the message header. }
+ with SendBuffer^ do begin
+ nmhMsgType := ffmtReply;
+ nmhMsgID := msgID;
+ nmhTotalSize := replyDataLen;
+ nmhClientID := clientID;
+ nmhRequestID := requestID;
+ nmhErrorCode := errorCode;
+ nmhTimeout := 0;
+ end;
+
+ StartOffset := 0;
+ BytesToGo := replyDataLen;
+ FirstMsg := true;
+
+ { Send data in reasonably-sized chunks }
+ repeat
+ { Calculate the size of the data to send in this message packet. }
+ BytesToSend := FFMinL(BytesToGo,
+ FProtocol.MaxNetMsgSize - ffc_NetMsgHeaderSize);
+ LastMsg := (BytesToSend = BytesToGo);
+ with SendBuffer^ do begin
+ nmhMsgLen := ffc_NetMsgHeaderSize + BytesToSend;
+ nmhFirstPart := FirstMsg;
+ nmhLastPart := LastMsg;
+ end;
+
+ { Copy the data into the send buffer. }
+ if (BytesToSend > 0) then
+ Move(PffBLOBArray(replyData)^[StartOffset],
+ SendBuffer^.nmhData, BytesToSend);
+
+ { Send the packet. }
+ Result := FProtocol.SendMsg(clientID, PffByteArray(SendBuffer),
+ SendBuffer^.nmhMsgLen, True); {!!.06}
+
+ { Do we need to get an acknowledgement? }
+ if not LastMsg then begin
+ { Update bytes sent, etc. }
+ dec(BytesToGo, BytesToSend);
+ inc(StartOffset, BytesToSend);
+ FirstMsg := false;
+ end;
+
+ until LastMsg or (Result <> DBIERR_NONE);
+{Moved !!.06}
+{Begin !!.10}
+ if Result <> DBIERR_NONE then
+ lcLogFmt(ffc_SendErr,
+ [Result, 'tpSendReply', -1, clientID, msgID, replyDataLen, 0])
+ else if FLogEnabled and assigned(FEventLog) and
+{End !!.10}
+ (fftpLogReplies in FLogOptions) then
+ tpLogReply2(requestID, clientID, msgID, replyDataLen, errorCode);
+ finally
+ FFFreeMem(SendBuffer, FProtocol.MaxNetMsgSize);
+ end;
+ except
+ on E:EffWinsockException do begin
+ Result := fferrTransportFail;
+ lcLogFmt('Transport failure %d: %s', [E.ErrorCode, E.Message]);
+ end;
+ on E:EffException do
+ Result := E.ErrorCode;
+ end;
+end;
+{--------}
+function TffLegacyTransport.tpSendRequest(aRequest : TffRequest) : TffResult;
+var
+ aClientID : TffClientID;
+ anItem : TffIntListItem;
+ BytesToSend : Longint;
+ FirstMsg : boolean;
+ LastMsg : boolean;
+ CallRpy : PffnmCallServerRpy;
+const
+ logPrefixArray : array[TffReplyModeType] of string = (ffc_Request,
+ ffc_Post,
+ ffc_PostWait);
+begin
+
+ Result := DBIERR_NONE;
+ anItem := nil;
+
+ try
+
+ tpLogReq(aRequest, logPrefixArray[aRequest.ReplyMode]);
+
+ { Is this a "call server" request or a regular request? }
+ if aRequest.MsgID = ffnmCallServer then begin
+{Begin !!.05}
+ tpLogReqMisc(Format(ffc_ReqLogString,
+ [ffc_Request, Longint(aRequest), aRequest.ClientID,
+ aRequest.MsgID, aRequest.RequestDataLen,
+ aRequest.Timeout]));
+{End !!.05}
+ aRequest.ErrorCode :=
+ FProtocol.Call(PffnmCallServerReq(aRequest.RequestData).ServerName,
+ aClientID, aRequest.Timeout);
+ FFGetMem(CallRpy, SizeOf(TffnmCallServerRpy));
+ CallRpy^.ClientID := aClientID;
+ aRequest.ReplyData := CallRpy;
+ aRequest.ReplyDataLen := SizeOf(TffnmCallServerRpy);
+ aRequest.ReplyMsgID := ffnmCallServer;
+{Begin !!.05}
+ if FLogEnabled and (fftpLogReplies in FLogOptions) and
+ (FEventLog <> nil) then
+ with aRequest do
+ FEventLog.WriteString(Format(ffc_ReplyLogString,
+ [Longint(aRequest), ClientID,
+ ReplyMsgID, ReplyDataLen, ErrorCode]));
+{End !!.05}
+ aRequest.WakeUpThread;
+ anItem.Free;
+ exit;
+ end;
+
+ { Set up the message header. }
+ with FSendBuffer^ do begin
+ nmhMsgType := ffmtRequest;
+ nmhMsgID := aRequest.MsgID;
+ nmhTotalSize := aRequest.RequestDataLen;
+ nmhClientID := aRequest.ClientID;
+ nmhRequestID := Longint(aRequest);
+ nmhErrorCode := 0;
+ nmhTimeout := aRequest.Timeout;
+ end;
+
+ FirstMsg := (aRequest.StartOffset = 0);
+
+
+ { Obtain exclusive write access. This is required because a reply
+ may be received from the server before an iteration of this repeat..until
+ block completes. In that situation, we want to make sure this method
+ finishes before the TffRequest is freed.
+
+ The corresponding call to TffRequest.Lock is in the TffRequest.Destroy
+ method. }
+ aRequest.Lock;
+
+ try
+
+ { Send data in reasonably-sized chunks }
+ repeat
+
+ { Calculate the size of the data to send in this message packet. }
+ BytesToSend := FFMinL(aRequest.BytesToGo,
+ FProtocol.MaxNetMsgSize - ffc_NetMsgHeaderSize);
+ LastMsg := (BytesToSend = aRequest.BytesToGo);
+ with FSendBuffer^ do begin
+ nmhMsgLen := ffc_NetMsgHeaderSize + BytesToSend;
+ nmhFirstPart := FirstMsg;
+ nmhLastPart := LastMsg;
+ end;
+
+ { Copy the data into the send buffer. }
+ if (BytesToSend > 0) then
+ Move(PffBLOBArray(aRequest.RequestData)^[aRequest.StartOffset],
+ FSendBuffer^.nmhData, BytesToSend);
+
+ { Update bytes sent, etc. }
+ aRequest.BytesToGo := aRequest.BytesToGo - BytesToSend;
+ aRequest.StartOffset := aRequest.StartOffset + BytesToSend;
+
+ { If this is the first message and the requesting thread must wait for a
+ reply, add the request to the Waiting For Reply list before we actually
+ send the message to the server. We do this to avoid the situation where
+ the reply is received before we actually get the request into the
+ Waiting For Reply list.
+
+ The request will sit in the Waiting For Reply list until the entire
+ reply is received. }
+ if FirstMsg and (aRequest.ReplyMode = ffrmReplyExpected) then
+ with FWaitingForReplyList.BeginWrite do
+ try
+ anItem := TffIntListItem.Create(Longint(aRequest));
+ Insert(anItem);
+ finally
+ EndWrite;
+ end;
+
+ { Send the packet. }
+ Result := FProtocol.SendMsg(aRequest.ClientID, PffByteArray(FSendBuffer),
+ FSendBuffer^.nmhMsgLen, True); {!!.06}
+
+ { If the send failed & we were expecting a reply, take the request out
+ of the Waiting For Reply list because no reply is forthcoming. }
+ if (Result <> DBIERR_NONE) and
+ (aRequest.ReplyMode = ffrmReplyExpected) then begin {!!.03}
+ aRequest.ReplyMsgID := aRequest.MsgID; {!!.03}
+ with FWaitingForReplyList.BeginWrite do
+ try
+ Delete(Longint(aRequest));
+ finally
+ EndWrite;
+ end;
+ end; {!!.03}
+
+ FirstMsg := False; {!!.01}
+
+ until LastMsg or (Result <> DBIERR_NONE);
+
+ if Result <> DBIERR_NONE then
+ lcLogFmt(ffc_SendErr,
+ [Result, 'tpSendRequest', -1, aRequest.ClientID,
+ aRequest.MsgID, aRequest.RequestDataLen, aRequest.Timeout]);
+
+ { Is the requesting thread waiting for the request to be sent to the
+ server but not wanting a reply? }
+ if aRequest.ReplyMode = ffrmNoReplyWaitUntilSent then begin
+ { Yes. Was the request aborted by the requesting thread
+ (i.e, timeout)? }
+ if aRequest.Aborted then begin
+ { Yes. Free the request. }
+ aRequest.Unlock;
+ aRequest.Free;
+ aRequest := nil;
+ end else
+ { No. Signal the requesting thread. }
+ aRequest.WakeUpThread;
+ end;
+
+ finally
+ if assigned(aRequest) then begin
+ aRequest.Unlock;
+ if aRequest.ReplyMode = ffrmNoReplyExpected then
+ aRequest.Free;
+ end;
+ end;
+ except
+ on E:Exception do begin
+ { Free the list item. }
+ if assigned(anItem) then
+ anItem.Free;
+
+ { Handle the exception. }
+ if E is EffWinsockException then begin
+ Result := fferrTransportFail;
+ lcLogFmt('Transport failure %d: %s',
+ [EffWinsockException(E).ErrorCode, E.Message]);
+ end
+ else if E is EffException then begin
+ Result := EffException(E).ErrorCode;
+ lcLogFmt('tpSendRequest exception %d: %s',
+ [EffException(E).ErrorCode, E.Message]);
+ end
+ else begin
+ Result := fferrTransportFail;
+ lcLogFmt('tpSendRequest general exception %s:', [E.Message]);
+ end;
+ end;
+ end;
+
+end;
+{--------}
+procedure TffLegacyTransport.tpShutdownProtocol;
+begin
+ if FLogEnabled and assigned(FEventLog) and
+ ((fftpLogRequests in FLogOptions) or
+ (fftpLogReplies in FLogOptions)) then
+ tpLogReqMisc(format('Transport thread (%s) shut down.', [GetName]));
+ FProtocol.Shutdown;
+end;
+{--------}
+procedure TffLegacyTransport.tpStartProtocol;
+begin
+ FProtocol.Startup;
+
+ { If we are to listen for broadcasts then set up to receive datagrams. }
+ //if (FMode = fftmListen) and FRespondToBroadcasts then begin {!!.05 - Start}
+ // FProtocol.ReceiveDatagram;
+ // FProtocol.Listen;
+ //end; }
+ if (FMode = fftmListen) then begin
+ FProtocol.Listen;
+ if (FRespondToBroadcasts) then
+ FProtocol.ReceiveDatagram;
+ end; {!!.05 - End}
+end;
+{--------}
+procedure TffLegacyTransport.tpThreadTerminated(Sender : TObject);
+begin
+ if TffLegacyTransportThread(Sender).UnexpectedTermination then begin
+ { The thread has shutdown prematurely. Log the event and restart
+ the thread. }
+ if assigned(FProtocol) then
+ lcLogFmt('Transport thread (%s) prematurely stopped.', [GetName]);
+ tpPrepareThread;
+ FTransportThread.Resume;
+ end;
+end;
+{--------}
+procedure TffLegacyTransport.Work;
+begin
+
+ { Legacy transports can both send and receive messages
+ (i.e., bi-directional). }
+
+ { Give the protocol a chance to receive requests. }
+ FProtocol.Breathe;
+
+ { Give the protocol a chance to send a request. }
+ tpHandleNextRequest;
+
+end;
+{====================================================================}
+
+{===TffLegacyTransportThread=========================================}
+constructor TffLegacyTransportThread.Create(aTransport : TffLegacyTransport);
+begin
+ inherited Create(True);
+ FTransport := aTransport;
+ FUnexpectedTermination := false;
+end;
+{--------}
+procedure TffLegacyTransportThread.Execute;
+begin
+ try
+ FTransport.tpStartProtocol;
+ repeat
+ try
+ FTransport.Work;
+ except
+ on E:Exception do
+ FTransport.lcLog
+ (format('Transport thread (%s) error: %s',
+ [FTransport.GetName, E.message]));
+ end;
+ until Terminated;
+ FTransport.tpShutdownProtocol;
+ except
+ on E:Exception do begin
+ { Signal the primary thread so that it can see our failure to start. }
+ FTransport.FProtocol.StartedEvent.SignalEvent;
+ FTransport.lcLog
+ (format('Transport thread startup (%s) error: %s',
+ [FTransport.GetName, E.message]));
+ end;
+ end;
+end;
+{====================================================================}
+end.
diff --git a/components/flashfiler/sourcelaz/fflllog.pas b/components/flashfiler/sourcelaz/fflllog.pas
new file mode 100644
index 000000000..3a34938e6
--- /dev/null
+++ b/components/flashfiler/sourcelaz/fflllog.pas
@@ -0,0 +1,544 @@
+{*********************************************************}
+{* FlashFiler: Logging facility *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+unit fflllog;
+
+interface
+
+uses
+ Classes,
+ ExtCtrls, {!!.06}
+ SysUtils,
+ Windows,
+ ffllbase;
+
+type
+ { Base class for event logs. }
+ TffBaseLog = class(TffComponent)
+ protected { private }
+ { Property variables }
+ FCache : Boolean; {!!.06}
+ FCacheLimit : Integer; {!!.06}
+ FEnabled : Boolean;
+ FFileName : TFileName;
+
+ { Internal variables }
+ blLogCS : TRTLCriticalSection;
+{Begin !!.06}
+ blTimer : TTimer;
+ { When caching, flushes cache during periods of inactivity. The timer
+ is enabled only when caching is enabled and something is written to
+ the log. The timer is reset as more stuff is added to the log. }
+{End !!.06}
+ { Property methods }
+ function blGetFileName : TFileName;
+ protected
+ procedure blLockLog;
+ procedure blUnlockLog;
+ function blGetEnabled : Boolean;
+ procedure blOnTimer(Sender : TObject); virtual; {!!.06}
+ procedure blSetEnabled(const Value : Boolean); virtual;
+ procedure blSetFileName(const Value : TFileName); virtual;
+ procedure Clear; virtual;
+ public
+ constructor Create(aOwner : TComponent); override;
+ destructor Destroy; override;
+
+ procedure Flush; virtual; {!!.06}
+
+ procedure WriteBlock(const S : string; Buf : pointer;
+ BufLen : TffMemSize); virtual; abstract;
+ { Use this method to write a block of data to the event log. }
+
+ procedure WriteString(const aMsg : string); virtual; abstract;
+ { Used to write a string to the event log. }
+
+ procedure WriteStringFmt(const aMsg : string; args : array of const); virtual; abstract;
+ { Used to write a formatted string to the event log. }
+
+ procedure WriteStrings(const Msgs : array of string); virtual; abstract;
+ { Used to write a block of strings to the event log. }
+
+ { Properties }
+{Begin !!.06}
+ property CacheEnabled : Boolean
+ read FCache
+ write FCache
+ default True;
+ { If True then log lines are cached in memory and flushed to
+ disk once the CacheLimit has been reached. }
+
+ property CacheLimit : Integer
+ read FCacheLimit
+ write FCacheLimit
+ default 500;
+ { The maximum number of log lines that may be retained in
+ memory. Not used if CacheEnabled is set to False. }
+{End !!.06}
+
+ property Enabled : Boolean
+ read blGetEnabled
+ write blSetEnabled
+ default False; {!!.01}
+ { Enable/disable event logging. }
+
+ property FileName : TFileName
+ read blGetFileName write blSetFileName;
+ { The file to which the event log is written. }
+ end;
+
+ TffEventLog = class(TffBaseLog)
+ protected
+ FLog : TStringList; {!!.06}
+ FLogSize : Integer; {!!.06}
+ FTruncateSize : Integer; {!!.06}
+ FMaxSize : Integer; {!!.06}
+ FWriteBlockData : Boolean; {!!.06}
+
+ procedure elTruncateCheck(const Stream : TStream); {!!.06}
+ procedure elWritePrim(const LogStr : string); virtual; {!!.05}
+ public
+ constructor Create(aOwner : TComponent); override;
+ destructor Destroy; override;
+
+ procedure Flush; override; {!!.06}
+ { Flushes the contents of the cache to the log. } {!!.06}
+
+ procedure WriteBlock(const S : string; Buf : pointer;
+ BufLen : TffMemSize); override;
+ procedure WriteString(const aMsg : string); override;
+ procedure WriteStringFmt(const aMsg : string; args : array of const); override;
+ procedure WriteStrings(const Msgs : array of string); override;
+
+ published
+
+ { Inherited properties }
+ property CacheEnabled; {!!.06}
+ property CacheLimit; {!!.06}
+ property Enabled;
+ property FileName;
+
+{Begin !!.06}
+ property MaxSize : Integer
+ read FMaxSize
+ write FMaxSize
+ default 50;
+ { Max size (in megabytes) of the log file. Once the log file
+ reaches this size it will be truncated to TruncateSize. By
+ default, the log is truncated at 50MB. }
+
+ property TruncateSize : Integer
+ read FTruncateSize
+ write FTruncateSize
+ default ffcl_1KB;
+ { Kilobytes of log kept when truncated. By default, 1MB is kept
+ when the log is truncated. See MaxSize. }
+
+ property WriteBlockData : Boolean
+ read FWriteBlockData
+ write FWriteBlockData
+ default False;
+ { If set to False then data passed to WriteBlock is *not*
+ written to the log. }
+{End !!.06}
+ end;
+
+{Begin !!.06}
+const
+ ffc_FlushTimerInterval : Cardinal = 1000;
+{End !!.06}
+
+implementation
+
+const
+ ffcsSpaces13 = ' ';
+ ffcsSpaces44 = ffcsSpaces13 + ffcsSpaces13 + ffcsSpaces13 + ' ';
+ ffcsFormat = '%s %12d %8d %s' + ffcCRLF;
+
+{===TffBaseLog=======================================================}
+
+constructor TffBaseLog.Create(aOwner : TComponent);
+begin
+ inherited Create(aOwner);
+ InitializeCriticalSection(blLogCS);
+ FCache := True;
+ FCacheLimit := 500;
+{Begin !!.06}
+ blTimer := TTimer.Create(nil);
+ blTimer.Enabled := False;
+ blTimer.Interval := ffc_FlushTimerInterval;
+ blTimer.OnTimer := blOnTimer;
+{End !!.06}
+end;
+{--------}
+destructor TffBaseLog.Destroy;
+begin
+ FFNotifyDependents(ffn_Destroy); {!!.11}
+ blTimer.Free; {!!.05}
+ DeleteCriticalSection(blLogCS);
+ inherited Destroy;
+end;
+{--------}
+function TffBaseLog.blGetEnabled : Boolean;
+begin
+ blLockLog;
+ try
+ Result := FEnabled;
+ finally
+ blUnlockLog;
+ end;
+end;
+{--------}
+function TffBaseLog.blGetFileName : TFileName;
+begin
+ blLockLog;
+ try
+ Result := FFileName;
+ finally
+ blUnlockLog;
+ end;
+end;
+{--------}
+procedure TffBaseLog.blLockLog;
+begin
+ if IsMultiThread then
+ EnterCriticalSection(blLogCS);
+end;
+{Begin !!.06}
+{--------}
+procedure TffBaseLog.blOnTimer(Sender : TObject);
+begin
+ blLockLog;
+ try
+ blTimer.Enabled := False;
+ Flush;
+ finally
+ blUnlockLog;
+ end;
+end;
+{End !!.06}
+{--------}
+procedure TffBaseLog.blSetEnabled(const Value : Boolean);
+begin
+ blLockLog;
+ try
+ FEnabled := Value;
+ finally
+ blUnlockLog;
+ end;
+end;
+{--------}
+procedure TffBaseLog.blSetFileName(const Value : TFileName);
+begin
+ blLockLog;
+ try
+ FFileName := Value;
+ finally
+ blUnlockLog;
+ end;
+end;
+{--------}
+procedure TffBaseLog.blUnlockLog;
+begin
+ if IsMultiThread then
+ LeaveCriticalSection(blLogCS);
+end;
+{Begin !!.06}
+{--------}
+procedure TffBaseLog.Clear;
+begin
+ { Do nothing }
+end;
+{--------}
+procedure TffBaseLog.Flush;
+begin
+ { Do nothing }
+end;
+{End !!.06}
+
+{====================================================================}
+
+{===TffEventLog======================================================}
+{Begin !!.06}
+constructor TffEventLog.Create(aOwner : TComponent);
+begin
+ inherited Create(aOwner);
+ FLog := TStringList.Create;
+ FLogSize := 0;
+ FWriteBlockData := False;
+ FMaxSize := 50;
+ FTruncateSize := ffcl_1KB;
+end;
+{--------}
+destructor TffEventLog.Destroy;
+begin
+ Flush;
+ FLog.Free;
+ inherited;
+end;
+{--------}
+procedure TffEventLog.elTruncateCheck(const Stream : TStream);
+var
+ TruncBytes,
+ MaxBytes : Integer;
+ TempStr : string;
+begin
+ { Convert MaxSize to Bytes. }
+ MaxBytes := (FMaxSize * ffcl_1MB);
+
+ { Is it time to truncate this log file? }
+ if ((FMaxSize <> 0) and
+ (FLogSize > MaxBytes)) then begin
+
+ { Convert the truncate size to bytes. }
+ TruncBytes := (FTruncateSize * ffcl_1KB);
+
+ { Position the log to the portion we want to keep. }
+ Stream.Seek(TruncBytes * -1, soFromEnd);
+ { Preserve the part we want to keep. }
+ SetLength(TempStr, TruncBytes);
+ Stream.Read(TempStr[1], TruncBytes);
+ { Truncate the file. }
+ Stream.Size := TruncBytes;
+ { Position to the beginning of the file and write the preserved
+ portion of the log. }
+ Stream.Position := 0;
+ Stream.Write(TempStr[1], TruncBytes);
+
+ { Reset the log's size. }
+ FLogSize := TruncBytes;
+ end;
+end;
+{--------}
+{End !!.06}
+procedure TffEventLog.elWritePrim(const LogStr : string);
+{Rewritten !!.06}
+var
+ FileStm : TFileStream;
+ LogMode : Word;
+begin
+ { Assumption: Log file locked for use by this thread. }
+
+ if FCache then begin
+ blTimer.Enabled := False;
+ if FLog.Count = FCacheLimit then
+ Flush;
+ blTimer.Enabled := True;
+ FLog.Add(LogStr);
+ end
+ else begin
+ { Check whether file exists, set flags appropriately }
+ if FileExists(FFileName) then
+ LogMode := (fmOpenReadWrite or fmShareDenyWrite)
+ else
+ LogMode := (fmCreate or fmShareDenyWrite);
+
+ { Open file, write string, close file }
+ FileStm := TFileStream.Create(FFileName, LogMode);
+ try
+ elTruncateCheck(FileStm);
+ FileStm.Seek(0, soFromEnd);
+ FLogSize := FLogSize +
+ FileStm.Write(LogStr[1], Length(LogStr));
+ finally
+ FileStm.Free;
+ end;
+ end;
+end;
+{Begin !!.06}
+{--------}
+procedure TffEventLog.Flush;
+var
+ Inx : Integer;
+ aStr : string;
+ FileStm : TFileStream;
+ LogMode : Word;
+begin
+ { Assumption: Log file locked for use by this thread. }
+
+ if FCache and (FLog.Count > 0) and (FFileName <> '') then begin
+ { Check whether file exists, set flags appropriately }
+ if FileExists(FFileName) then
+ LogMode := (fmOpenReadWrite or fmShareDenyWrite)
+ else
+ LogMode := (fmCreate or fmShareDenyWrite);
+
+ { Open file, write string, close file }
+ FileStm := TFileStream.Create(FFileName, LogMode);
+ try
+ elTruncateCheck(FileStm);
+ FileStm.Seek(0, soFromEnd);
+ for Inx := 0 to Pred(FLog.Count) do begin
+ aStr := FLog.Strings[Inx];
+ FLogSize := FLogSize +
+ FileStm.Write(aStr[1], Length(aStr));
+ end;
+ finally
+ FileStm.Free;
+ end;
+ FLog.Clear;
+ end;
+end;
+{End !!.06}
+{--------}
+procedure TffEventLog.WriteBlock(const S : string; Buf : pointer;
+ BufLen : TffMemSize);
+const
+ HexPos : array [0..15] of byte =
+ (1, 4, 7, 10, 14, 17, 20, 23, 27, 30, 33, 36, 40, 43, 46, 49);
+ HexChar : array [0..15] of char =
+ '0123456789abcdef';
+var
+ B : PffByteArray absolute Buf;
+ ThisWidth,
+ i, j : integer;
+ Line : string[70];
+ Work : byte;
+begin
+{Begin !!.06}
+ if FWriteBlockData then begin
+ blLockLog;
+ try
+ WriteStringFmt('%s (Size: %d)', [S, BufLen]);
+ if (BufLen = 0) or (Buf = nil) then
+ elWritePrim(ffcsSpaces13 + 'buffer is nil' + ffcCRLF)
+ else begin
+ if (BufLen > 1024) then begin
+ elWritePrim(ffcsSpaces13 + '(writing first 1K of buffer only)' + ffcCRLF);
+ BufLen := 1024;
+ end;
+ for i := 0 to ((BufLen-1) shr 4) do begin
+ FillChar(Line, 70, ' ');
+ Line[0] := #70;
+ Line[53] := '['; Line[70] := ']';
+ if (BufLen >= 16) then
+ ThisWidth := 16
+ else
+ ThisWidth := BufLen;
+ for j := 0 to ThisWidth-1 do begin
+ Work := B^[(i shl 4) + j];
+ Line[HexPos[j]] := HexChar[Work shr 4];
+ Line[HexPos[j]+1] := HexChar[Work and $F];
+ if (Work < 32) or (Work >= $80) then
+ Work := ord('.');
+ Line[54+j] := char(Work);
+ end;
+ elWritePrim(ffcsSpaces13 + Line + ffcCRLF);
+ dec(BufLen, ThisWidth);
+ end;
+ end;
+ finally
+ blUnlockLog;
+ end;
+ end; { if }
+{End !!.06}
+end;
+{--------}
+procedure TffEventLog.WriteString(const aMsg : string);
+var
+ LogStr : string;
+begin
+
+ { Bail if logging isn't turned on }
+ if not FEnabled then Exit;
+
+ blLockLog;
+ try
+ { Create appropriate string for log }
+ LogStr := format(ffcsFormat,
+ [DateTimeToStr(Now), getTickCount,
+ getCurrentThreadID, aMsg]);
+
+ elWritePrim(LogStr);
+
+ finally
+ blUnlockLog;
+ end;
+end;
+{--------}
+procedure TffEventLog.WriteStringFmt(const aMsg : string; args : array of const);
+var
+ LogStr : string;
+begin
+
+ { Bail if logging isn't turned on }
+ if not FEnabled then Exit;
+
+ blLockLog;
+ try
+ { Create appropriate string for log }
+ LogStr := format(ffcsFormat,
+ [DateTimeToStr(Now), getTickCount,
+ getCurrentThreadID, format(aMsg, args)]);
+
+ elWritePrim(LogStr);
+
+ finally
+ blUnlockLog;
+ end;
+end;
+{--------}
+procedure TffEventLog.WriteStrings(const Msgs : array of string);
+var
+ Index : longInt;
+ LogStr : string;
+ MsgStr : string;
+begin
+
+ { Bail if logging isn't turned on }
+ if not FEnabled then Exit;
+
+ blLockLog;
+ try
+
+ for Index := 0 to high(Msgs) do begin
+
+ { Create appropriate string for log }
+ MsgStr := Msgs[Index];
+ if (length(MsgStr) = 0) then
+ LogStr := ffcCRLF
+ else if(MsgStr[1] = ' ') then
+ LogStr := ffcsSpaces44 + MsgStr + ffcCRLF
+ else
+ LogStr := format(ffcsFormat,
+ [DateTimeToStr(Now), getTickCount,
+ getCurrentThreadID, MsgStr]);
+
+ elWritePrim(LogStr);
+
+ end;
+
+ finally
+ blUnlockLog;
+ end;
+end;
+{====================================================================}
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffllprot.pas b/components/flashfiler/sourcelaz/ffllprot.pas
new file mode 100644
index 000000000..14ab54fdf
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffllprot.pas
@@ -0,0 +1,2993 @@
+{*********************************************************}
+{* FlashFiler: Communications protocol class *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+{ Enable the following line to activate Keep Alive logging. }
+{.$DEFINE KALog}
+
+unit ffllprot;
+
+interface
+
+uses
+ {$ifdef fpc}LCLIntf{$endif}, //soner LCLIntf for functions AllocateHWnd and DeallocateHWnd and it must be firt because it changes tmsg and others from windows
+ Windows,
+ Messages,
+ SysUtils,
+ Classes,
+ ExtCtrls,
+ Forms,
+ ffconst,
+ ffllbase,
+ ffllexcp,
+ fflllog,
+ ffllwsct,
+ ffnetmsg,
+ ffsrmgr,
+ ffllwsck;
+
+type
+ TffProtocolType = ( {Protocol types..}
+ ptSingleUser, {..single user}
+ ptTCPIP, {..TCP/IP}
+ ptIPXSPX, {..IPX/SPX}
+ ptRegistry); {..value from registry}
+
+
+
+{===Constants relating to sending messages and datagrams}
+const
+ ffc_ConnectRetryTimeout : DWORD = 1000; {!!.05}
+ { Number of milliseconds before retry of connection request. } {!!.05}
+ ffc_UnblockWait : DWORD = 25; {!!.06}
+ { Number of milliseconds to wait before exiting unblock wait loop. } {!!.06}
+ ffc_MaxWinsockMsgSize = 24 * 1024;
+ ffc_MaxSingleUserMsgSize = 64 * 1024;
+ ffc_MaxDatagramSize = 128;
+ ffc_CodeLength = 256;
+ ffc_LastMsgInterval : longint = 30000;
+ ffc_KeepAliveInterval : longint = 5000;
+ ffc_KeepAliveRetries : longint = 5;
+
+ ffc_TCPInterface : Integer = 0; // NIC to use for TCPIP
+ ffc_TCPRcvBuf : longint = $8000; // request 32K Rcv Buffer
+ ffc_TCPSndBuf : longint = $8000; // request 32K Snd Buffer
+
+ ffc_SingleUserServerName = 'Local server';
+ ffc_SendMessageTimeout = 1 * 1000; {1 second} {!!.01}{!!.05}
+
+ ffc_SUPErrorTimeout : Integer = 25; {!!.06}
+ { # milliseconds to wait if error occurs during SUP send. } {!!.06}
+
+{===Single user messages constants (for dwData)}
+const
+ ffsumCallServer = $4631;
+ ffsumDataMsg = $4632;
+ ffsumHangUp = $4633;
+ ffsumKeepAlive = $4634;
+ ffm_ServerReply = WM_USER + $0FF9;
+
+{===Datagram types===}
+type
+ PffDatagram = ^TffDatagram;
+ TffDatagram = array [0..pred(ffc_MaxDatagramSize)] of byte;
+ PffDatagramArray = ^TffDatagramArray;
+ TffDatagramArray = array [0..255] of TffDatagram;
+
+{===Code types===}
+type
+ PffNetMsgCode = ^TffNetMsgCode;
+ TffNetMsgCode = array [0..pred(ffc_CodeLength)] of byte;
+
+{===Event types===}
+type
+ TffReceiveMsgEvent = function (aSender : TObject;
+ clientID : TffClientID;
+ replyData : PffByteArray;
+ replyLen : longInt) : boolean of object;
+ TffHeardCallEvent = procedure (aSender : TObject;
+ aConnHandle : longint) of object;
+ TffReceiveDatagramEvent = procedure (aSender : TObject;
+ const aName : TffNetName;
+ aData : PffByteArray;
+ aDataLen : longint) of object;
+ TffHangUpEvent = procedure (aSender : TObject;
+ aClientID : TffClientID) of object;
+
+
+{===Base Classes===}
+type
+ TffBaseCommsProtocol = class;
+
+ TffClientServerType = ( {type defining client or server}
+ csClient, {..client}
+ csServer); {..server}
+
+ TffConnection = class(TffSelfListItem)
+ protected {private}
+ FClientID : TffClientID;
+ FCode : PffNetMsgCode;
+ { The code used for encrypting messages. }
+ FCodeStart : DWord; {!!.10}
+ FHangingUp : boolean;
+ FHangupDone : boolean; {!!.01}
+ FHangupLock : TffPadlock; {!!.01}
+ FOwner : TffBaseCommsProtocol;
+ FRemoteName : PffShStr;
+ FAliveRetries : integer;
+ FLastMsgTimer : TffTimer;
+ FSendConfirm : boolean;
+ protected
+ function GetRemoteName : string; {!!.10}
+ procedure AddToList(List : TFFList); virtual;
+ procedure RemoveFromList(List : TFFList); virtual;
+ public
+ constructor Create(aOwner : TffBaseCommsProtocol;
+ aRemoteName : TffNetAddress);
+ destructor Destroy; override;
+
+ procedure ConfirmAlive(SendConfirm : boolean);
+ procedure DepleteLife;
+
+ procedure HangupLock; {!!.01}
+ procedure HangupUnlock; {!!.01}
+
+ procedure InitCode(const aStart : longint);
+ { Initializes the encryption code used for communicating with the
+ server. }
+ function IsAlive : boolean;
+ function IsVeryAlive : boolean;
+ function NeedsConfirmSent : boolean;
+
+ property ClientID : TffClientID read FClientID write FClientID;
+ property Code : PffNetMsgCode read FCode;
+ property CodeStart : DWord read FCodeStart; {!!.10}
+ property Owner : TffBaseCommsProtocol
+ read FOwner;
+ property Handle : longint
+ read KeyAsInt;
+ property HangingUp : boolean
+ read FHangingUp write FHangingUp;
+ { Set to True when we are deliberately hanging up the connection.
+ This variable tells us whether we need to invoke the OnHangUp or
+ OnConnectionLost event in the parent protocol. }
+ property HangupDone : boolean {!!.01}
+ read FHangupDone write FHangupDone; {!!.01}
+ property RemoteName : string {!!.10}
+ read GetRemoteName;
+ end;
+
+ { Defines the common interface for all legacy protocols. This class is
+ written with the assumption that only one thread will ever be using an
+ instance of this class at any given time. Therefore no locking/critical
+ sections are used. }
+ TffBaseCommsProtocol = class
+ protected {private}
+ FConnLock : TffPadlock;
+ FCSType : TffClientServerType;
+ FEventLog : TffBaseLog;
+ FHeardCall : TffHeardCallEvent;
+ FKeepAliveInterval : longInt;
+ FKeepAliveRetries : longInt;
+ FLastMsgInterval : longInt;
+ FLocalName : PffShStr;
+ FLogEnabled : boolean;
+ FMaxNetMsgSize : longint;
+ FNetName : PffShStr;
+ FNotifyWindow : HWND;
+ FOnConnectionLost : TffHangupEvent;
+ FOnHangup : TffHangUpEvent;
+ FReceiveDatagram : TffReceiveDatagramEvent;
+ FReceiveMsg : TffReceiveMsgEvent;
+ FSearchTimeOut : integer;
+ FStarted : boolean;
+ {-If True then the protocol is active. }
+ FStartedEvent : TffEvent;
+
+ cpConnList : TffList;
+ cpIndexByOSConnector : TffList; { This is an index by socket (TCP/IP or
+ IPX/SPX) or by window handle (SUP). }
+ cpIndexByClient : TffList; { This is an index by clientID. }
+ protected
+
+ function GetLocalName : string; {!!.10}
+ function GetNetName : string; {!!.10}
+
+ procedure cpAddConnection(aConnection : TffConnection);
+ function cpExistsConnection(aConnHandle : longint) : boolean;
+ function cpFindConnection(const aClientID : TffClientID) : Longint;
+ function cpGetConnection(const aClientID : TffClientID) : TffConnection;
+ function cpGetConnectionIDs(const anIndex : longInt) : TffClientID;
+ procedure cpRemoveConnection(aClientID : TffClientID);
+
+ function cpCreateNotifyWindow : boolean; dynamic;
+ procedure cpDestroyNotifyWindow;
+ procedure cpDoHangUp(aConn : TffConnection); dynamic;
+ procedure cpDoHeardCall(aConnHandle : longint); dynamic;
+ procedure cpDoReceiveDatagram(const aName : TffNetName;
+ aData : PffByteArray;
+ aDataLen : longint); dynamic;
+ function cpDoReceiveMsg(aConn : TffConnection;
+ msgData : PffByteArray;
+ msgDataLen : longInt) : boolean; dynamic;
+
+ procedure cpPerformShutdown; virtual;
+ procedure cpPerformStartUp; virtual; abstract;
+
+ procedure cpSetNetName(aName : string);
+
+ procedure cpCodeMessage(aConn : TffConnection; aData : PffByteArray;
+ aDataLen : longint); virtual;
+ procedure cpGotCheckConnection(aConn : TffConnection);
+ procedure cpTimerTick;
+ public
+ constructor Create(const aName : TffNetAddress; aCSType : TffClientServerType); virtual;
+ destructor Destroy; override;
+
+ function Call(const aServerName : TffNetName;
+ var aClientID : TffClientID;
+ const timeout : longInt) : TffResult; virtual; abstract;
+ function ClientIDExists(const aClientID : TffClientID) : boolean;
+ { Used by the legacy transport to determine if it has generated a
+ temporary clientID that conflicts with a real clientID. }
+
+ function ConnectionCount : longInt;
+ { Returns the number of established connections. }
+
+ procedure ConnLock;
+ procedure ConnUnlock;
+ { Use these procedures to prevent a newly-attached client from sending
+ the protocol a message before the protocol has updated the new
+ connection's clientID. }
+
+ procedure GetServerNames(aList : TStrings; const timeout : longInt); virtual; abstract;
+ { Protocol-specific method for retrieving servers accessible via the
+ protocol. }
+
+ function GetCodeStart(const aClientID : TffClientID) : integer;
+ { Get the starting encryption code for the specified client. }
+
+ class function GetProtocolName : string; virtual;
+ { Returns the name of the protocol (e.g., 'TCP/IP'). }
+
+ procedure HangUp(aConn : TffConnection); virtual; abstract;
+ procedure HangUpByClientID(aClientID : TffClientID); virtual;
+ procedure HangupDone(aClientID : TffClientID); {!!.01}
+ function HangupIsDone(aClientID : TffClientID) : Boolean; {!!.01}
+ procedure HangupLock(aClientID : TffClientID); {!!.01}
+ procedure HangupUnlock(aClientID : TffClientID); {!!.01}
+ procedure Listen; virtual; abstract;
+ function SendMsg(aClientID : TffClientID;
+ aData : PffByteArray;
+ aDataLen : longint;
+ aConnLock : Boolean) : TffResult; virtual; abstract; {!!.06}
+
+ procedure ReceiveDatagram; virtual; abstract;
+ procedure SendDatagram(const aName : TffNetName;
+ aData : PffByteArray;
+ aDataLen : longint); virtual; abstract;
+
+ procedure Shutdown; virtual;
+
+ procedure StartUp; virtual;
+
+ procedure StopReceiveDatagram; virtual; abstract;
+
+ class function Supported : boolean; virtual;
+ { Returns True if the protocol is supported on this workstation.
+ Default implementation always returns True. }
+
+ procedure Breathe; virtual;
+ procedure InitCode(const aClientID : TffClientID;
+ const aStart : longint);
+ procedure ResetKeepAliveTimer;
+
+ procedure UpdateClientID(const oldClientID, newClientID : TffClientID);
+ { After a client has successfully obtained access to the server, the
+ transport uses this method to replace the client's temporary ID
+ with the ID returned from the server. }
+
+ procedure LogStr(const aMsg : string);
+ { Use this method to write an event string to the protocol's event
+ log. }
+
+ procedure LogStrFmt(const aMsg : string; args : array of const);
+ { Use this method to write a formatted event string to the protocol's
+ event log. }
+
+ property ConnectionIDs[const anIndex : longInt] : TffClientID
+ read cpGetConnectionIDs;
+ { Use this method to retrieve the connection IDs for the protocol's
+ connections. }
+
+ property CSType : TffClientServerType
+ read FCSType;
+ property EventLog : TffBaseLog
+ read FEventLog write FEventLog;
+ property IsStarted : boolean
+ read FStarted;
+ property KeepAliveInterval : longInt
+ read FKeepAliveInterval
+ write FKeepAliveInterval;
+ property KeepAliveRetries : longInt
+ read FKeepAliveRetries
+ write FKeepAliveRetries;
+ property LastMsgInterval : longInt
+ read FLastMsgInterval
+ write FLastMsgInterval;
+ property LocalName : string {!!.10}
+ read GetLocalName;
+ property LogEnabled : boolean
+ read FLogEnabled
+ write FLogEnabled;
+ property MaxNetMsgSize : longint
+ read FMaxNetMsgSize;
+ property NetName : string {!!.10}
+ read GetNetName;
+ property NotifyWindow : HWND
+ read FNotifyWindow;
+ property OnConnectionLost : TffHangUpEvent
+ read FOnConnectionLost write FOnConnectionLost;
+ { This event is called when the other end of the connection unexpectedly
+ hangs up on this end. }
+ property OnHangUp : TffHangUpEvent
+ read FOnHangUp write FOnHangUp;
+ { This event is called when the protocol deliberately hangs up the
+ connection. }
+ property OnHeardCall : TffHeardCallEvent
+ read FHeardCall write FHeardCall;
+ property OnReceiveDatagram: TffReceiveDatagramEvent
+ read FReceiveDatagram write FReceiveDatagram;
+ property OnReceiveMsg : TffReceiveMsgEvent
+ read FReceiveMsg write FReceiveMsg;
+ property SearchTimeOut : integer
+ read FSearchTimeOut;
+ property StartedEvent : TffEvent
+ read FStartedEvent;
+ end;
+
+ TffCommsProtocolClass = class of TffBaseCommsProtocol;
+
+{===Winsock Classes===}
+type
+ PffwscPacket = ^TffwscPacket;
+ TffwscPacket = packed record
+ dwLength : longint;
+ dwStart : longint;
+ lpData : PffByteArray;
+ lpNext : PffwscPacket;
+ end;
+
+type
+ TffWinsockConnection = class(TffConnection)
+ protected {private}
+ FSocket : TffwsSocket;
+ FFamily : TffWinsockFamily;
+ wscNotifyWnd : HWND;
+// wscPortal : TffReadWritePortal; {Deleted !!.05}
+ {!!.05 - Replaced by TffConnection.HangupLock }
+ { Controls access to a connection in order that:
+ 1. The connection is not freed while a reply is outgoing.
+ 2. No more than one reply is being sent to the connection at
+ any one time.
+ }
+ wscRcvBuffer : PffByteArray;
+ wscRcvBufOfs : integer;
+// wscSendBuffer : PffByteArray;
+ protected
+ wscRcvBuf : longint;
+ wscSndBuf : longint;
+ wscPacketHead : PffwscPacket;
+ wscPacketTail : PffwscPacket;
+ wscIsSending : Boolean;
+ procedure AddToList(List : TFFList); override;
+ procedure RemoveFromList(List : TFFList); override;
+ public
+ constructor Create(aOwner : TffBaseCommsProtocol;
+ aRemoteName : TffNetAddress;
+ aSocket : TffwsSocket;
+ aFamily : TffWinsockFamily;
+ aNotifyWnd : HWND);
+ destructor Destroy; override;
+
+ function Send(aData : PffByteArray;
+ aDataLen : longint;
+ aDataStart : longint;
+ var aBytesSent : longint;
+ aConnLock : Boolean) : integer; {!!.06}
+ procedure StartReceive;
+
+ property IsSending : Boolean {!!.06}
+ read wscIsSending write wscIsSending; {!!.06}
+
+ property RcvBuffer : PffByteArray
+ read wscRcvBuffer;
+
+ property RcvBufferOffset : integer
+ read wscRcvBufOfs write wscRcvBufOfs;
+
+ property Socket : TffwsSocket
+ read FSocket;
+ end;
+
+type
+ TffWinsockProtocol = class(TffBaseCommsProtocol)
+ protected {private}
+ FCollectingServerNames : boolean;
+ FDatagramPadlock : TffPadlock;
+ FFamily : TffWinsockFamily;
+ FServerNames : TStringList;
+ wspLocalInAddr : TffwsInAddr;
+ wspLocalIPXNetNum : TffwsIPXNetNum;
+ wspLocalIPXAddr : TffwsIPXAddr;
+ wspListening : boolean;
+ wspListenSocket : TffwsSocket;
+ wspRcvDatagramSocket : TffwsSocket;
+ wspRcvDGBuffer : PffByteArray;
+ wspReceivingDatagram : boolean;
+ wspWaitingForConnect : boolean;
+ wspWaitingForSendToUnblock : boolean;
+ protected
+ procedure SetFamily(F : TffWinsockFamily);
+ function cpCreateNotifyWindow : boolean; override;
+ procedure cpDoReceiveDatagram(const aName : TffNetName;
+ aData : PffByteArray;
+ aDataLen : longint); override;
+ procedure cpPerformStartUp; override;
+
+ procedure wspConnectCompleted(aSocket : TffwsSocket);
+ function wspGetConnForSocket(aSocket : TffwsSocket) : TffWinsockConnection;
+ procedure wspHangupDetected(aSocket : TffwsSocket);
+ procedure wspListenCompleted(aSocket : TffwsSocket);
+ procedure wspProcessCompletedWSACall(WParam, LParam : longint);
+ procedure wspSendMsgCompleted(aSocket : TffwsSocket);
+ procedure wspReceiveCompleted(aSocket : TffwsSocket);
+ procedure wspReceiveDatagramCompleted(aSocket : TffwsSocket);
+ procedure wspReceiveMsgCompleted(aSocket : TffwsSocket);
+ procedure wspWaitForConnect(aTimeOut : integer);
+ function wspWaitForSendToUnblock : Boolean; {!!.06}
+ procedure wspWSAEventCompleted(var WSMsg : TMessage);
+ public
+ constructor Create(const aName : TffNetAddress;
+ aCSType : TffClientServerType); override;
+ destructor Destroy; override;
+
+ function Call(const aServerName : TffNetName;
+ var aClientID : TffClientID;
+ const timeOut : longInt) : TffResult; override;
+ procedure GetServerNames(aList : TStrings; const timeout : longInt); override;
+ procedure HangUp(aConn : TffConnection); override;
+ procedure Listen; override;
+ function SendMsg(aClientID : TffClientID;
+ aData : PffByteArray;
+ aDataLen : longint;
+ aConnLock : Boolean) : TffResult; override; {!!.06}
+
+ procedure ReceiveDatagram; override;
+ procedure SendDatagram(const aName : TffNetName;
+ aData : PffByteArray;
+ aDataLen : longint); override;
+ procedure StopReceiveDatagram; override;
+
+ property Family : TffWinsockFamily
+ read FFamily write SetFamily;
+ end;
+
+ TffTCPIPProtocol = class(TffWinsockProtocol)
+ protected
+ public
+ constructor Create(const aName : TffNetAddress;
+ aCSType : TffClientServerType); override;
+ class function GetProtocolName : string; override;
+ { Returns the name of the protocol (e.g., 'TCP/IP'). }
+
+ class function Supported : boolean; override;
+
+ end;
+
+ TffIPXSPXProtocol = class(TffWinsockProtocol)
+ protected
+ public
+ constructor Create(const aName : TffNetAddress;
+ aCSType : TffClientServerType); override;
+ class function GetProtocolName : string; override;
+ { Returns the name of the protocol (e.g., 'TCP/IP'). }
+
+ class function Supported : boolean; override;
+
+ end;
+
+ TffSingleUserConnection = class(TffConnection)
+ protected {private}
+ FPartner : HWND;
+ FUs : HWND;
+ sucSendBuffer : PffByteArray;
+ protected
+ procedure AddToList(List : TFFList); override;
+ procedure RemoveFromList(List : TFFList); override;
+ public
+ constructor Create(aOwner : TffBaseCommsProtocol;
+ aRemoteName : TffNetAddress;
+ aUs : HWND;
+ aPartner : HWND);
+ destructor Destroy; override;
+ procedure Send(aData : PffByteArray;
+ aDataLen : longint;
+ aConnLock : Boolean); {!!.06}
+ property Partner : HWND read FPartner write FPartner;
+ end;
+
+ TffSingleUserProtocol = class(TffBaseCommsProtocol)
+ protected {private}
+ supMsgID : TffWord32;
+ supPostMsgID : TffWord32;
+ supPartner : HWND;
+ supReceivingDatagram : boolean;
+ protected
+ function cpCreateNotifyWindow : boolean; override;
+ procedure cpPerformStartUp; override;
+
+ procedure supDataMsgReceived(const aClientID : TffClientID;
+ const aCDS : TCopyDataStruct);
+ function supGetConnForPartner(aPartner : HWND) : TffSingleUserConnection;
+ procedure supHangupDetected(const aClientID : TffClientID);
+ procedure supListenCompleted(aClientID : TffClientID; Wnd : HWND);
+ procedure supMsgReceived(var SUMsg : TMessage);
+ function supFindPartner(const aClientID : TffClientID;
+ const timeout : longInt): HWND;
+ public
+ constructor Create(const aName : TffNetAddress; aCSType : TffClientServerType); override;
+ function Call(const aServerName : TffNetName;
+ var aClientID : TffClientID;
+ const timeout : longInt) : TffResult; override;
+ class function GetProtocolName : string; override;
+ { Returns the name of the protocol (e.g., 'TCP/IP'). }
+
+ procedure GetServerNames(aList : TStrings; const timeout : longInt); override;
+ procedure HangUp(aConn : TffConnection); override;
+ procedure Listen; override;
+ function SendMsg(aClientID : TffClientID;
+ aData : PffByteArray;
+ aDataLen : longint;
+ aConnLock : Boolean) : TffResult; override; {!!.06}
+
+ procedure ReceiveDatagram; override;
+ procedure SendDatagram(const aName : TffNetName;
+ aData : PffByteArray;
+ aDataLen : longint); override;
+ procedure StopReceiveDatagram; override;
+
+ end;
+
+{===Helper routines===}
+procedure FFSplitNetAddress(const aAddress : TffNetAddress;
+ var aLocalName : TffNetName;
+ var aNetName : TffNetName);
+procedure FFMakeNetAddress(var aAddress : TffNetAddress;
+ const aLocalName : TffNetName;
+ const aNetName : TffNetName);
+
+{ TCP & UDP - FFSetxxx routines expect port number to be in
+ host byte order. }
+procedure FFSetTCPPort(const aPort : integer);
+procedure FFSetUDPPortServer (const aPort : integer);
+procedure FFSetUDPPortClient (const aPort : integer);
+
+function FFGetTCPPort : integer;
+function FFGetUDPPortServer : integer;
+function FFGetUDPPortClient : integer;
+
+{ IPX/SPX - FFSetxxx routines expect port number to be in
+ host byte order. }
+procedure FFSetIPXSocketServer (const aSocket : integer);
+procedure FFSetIPXSocketClient (const aSocket : integer);
+procedure FFSetSPXSocket (const aSocket : integer);
+
+function FFGetIPXSocketServer : integer;
+function FFGetIPXSocketClient : integer;
+function FFGetSPXSocket : integer;
+
+{$IFDEF KALog}
+var
+ KALog : TffEventLog;
+{$ENDIF}
+
+implementation
+
+uses
+ ffsrbde;
+
+const
+ DeallocTimeOut = 500;
+
+ { Port constants - define in network-byte order. }
+ ffc_TCPPort : integer = $6563;
+ ffc_UDPPortServer : integer = $6563;
+ ffc_UDPPortClient : integer = $6564;
+ ffc_IPXSocketServer : integer = $6563;
+ ffc_IPXSocketClient : integer = $6564;
+ ffc_SPXSocket : integer = $6565;
+
+{===Helper routines==================================================}
+procedure CodeBuffer(var aCode : TffNetMsgCode; var aBuf; aBufLen : integer);
+register;
+asm
+ push ebx
+ push esi
+ push edi
+ mov edi, eax
+@@ResetCode:
+ mov ebx, ffc_CodeLength
+ mov esi, edi
+@@NextByte:
+ mov al, [edx]
+ xor al, [esi]
+ mov [edx], al
+ dec ecx
+ jz @@Exit
+ inc edx
+ dec ebx
+ jz @@ResetCode
+ inc esi
+ jmp @@NextByte
+@@Exit:
+ pop edi
+ pop esi
+ pop ebx
+end;
+{--------}
+procedure GenerateCode(aStart : longint; var aCode : TffNetMsgCode);
+const
+ im = 259200;
+ ia = 7141;
+ ic = 54773;
+var
+ i : integer;
+begin
+ {Note: routine and constants are from Numerical Recipes in Pascal, page 218}
+ aStart := aStart mod im;
+ for i := 0 to pred(ffc_CodeLength) do begin
+ aStart := ((aStart * ia) + ic) mod im;
+ aCode[i] := (aStart * 256) div im;
+ end;
+end;
+{--------}
+procedure CheckWinsockError(const ErrorCode : Integer; const Connecting : Boolean);
+{ Rewritten !!.05}
+{ When doing mass numbers of connects/disconnects and retrying connections
+ (see TffWinsockProtocol.Call), certain errors may occur that appear to be
+ timing-related (i.e., the code doesn't see that the socket is connected
+ because the event from the Winsock layer has yet to be processed).
+ WsaEALREADY & WsaEISCONN showed up consistently on Windows 2000.
+ WsaEINVAL showed up consistently on W95. }
+var
+ TmpCode : Integer;
+begin
+ if (ErrorCode = SOCKET_ERROR) then begin
+ TmpCode := WinsockRoutines.WSAGetLastError;
+ if (TmpCode <> 0) and (TmpCode <> WSAEWOULDBLOCK) then
+ if not (Connecting and
+ ((TmpCode = WsaEALREADY) or
+ (TmpCode = WsaEISCONN) or
+ (TmpCode = WsaEINVAL)
+ )
+ ) then
+ raise EffWinsockException.CreateTranslate(TmpCode, nil);
+ end; { if }
+end;
+{--------}
+procedure FFSplitNetAddress(const aAddress : TffNetAddress;
+ var aLocalName : TffNetName;
+ var aNetName : TffNetName);
+var
+ PosAt : integer;
+begin
+ PosAt := Pos('@', aAddress);
+ if (PosAt > 0) then begin
+ aLocalName := Copy(aAddress, 1, FFMinI(Pred(PosAt), ffcl_NetNameSize)); {!!.06}
+ aNetName := Copy(aAddress, succ(PosAt), FFMinI(Length(aAddress) - PosAt, ffcl_NetNameSize)); {!!.06}
+ end
+ else begin
+ aLocalName := aAddress;
+ aNetName := aAddress;
+ end;
+end;
+{--------}
+procedure FFMakeNetAddress(var aAddress : TffNetAddress;
+ const aLocalName : TffNetName;
+ const aNetName : TffNetName);
+begin
+ aAddress := aLocalName;
+{Begin !!.03}
+{$IFDEF IsDelphi}
+ if (FFCmpShStr(aLocalName, aNetName, 255) <> 0) then begin
+ FFShStrAddChar(aAddress, '@');
+ FFShStrConcat(aAddress, aNetName);
+ end;
+{$ELSE}
+ if aLocalName <> aNetName then
+ aAddress := aAddress + '@' + aNetName;
+{$ENDIF}
+{End !!.03}
+end;
+{--------}
+procedure FFSetTCPPort(const aPort : integer);
+begin
+ if not FFWSInstalled then
+ raise EffWinsockException.CreateNoData(ffStrResGeneral, fferrWSNoWinsock);
+ ffc_TCPPort := WinsockRoutines.htons(aPort);
+end;
+{--------}
+procedure FFSetUDPPortServer (const aPort : integer);
+begin
+ if not FFWSInstalled then
+ raise EffWinsockException.CreateNoData(ffStrResGeneral, fferrWSNoWinsock);
+ ffc_UDPPortServer := WinsockRoutines.htons(aPort);
+end;
+{--------}
+procedure FFSetUDPPortClient (const aPort : integer);
+begin
+ if not FFWSInstalled then
+ raise EffWinsockException.CreateNoData(ffStrResGeneral, fferrWSNoWinsock);
+ ffc_UDPPortClient := WinsockRoutines.htons(aPort);
+end;
+{--------}
+function FFGetTCPPort : integer;
+begin
+ if FFWSInstalled then
+ Result := WinsockRoutines.ntohs(ffc_TCPPort)
+ else
+ Result := 0;
+end;
+{--------}
+function FFGetUDPPortServer : integer;
+begin
+ if FFWSInstalled then
+ Result := WinsockRoutines.ntohs(ffc_UDPPortServer)
+ else
+ Result := 0;
+end;
+{--------}
+function FFGetUDPPortClient : integer;
+begin
+ if FFWSInstalled then
+ Result := WinsockRoutines.ntohs(ffc_UDPPortClient)
+ else
+ Result := 0;
+end;
+{--------}
+procedure FFSetIPXSocketServer (const aSocket : integer);
+begin
+ if not FFWSInstalled then
+ raise EffWinsockException.CreateNoData(ffStrResGeneral, fferrWSNoWinsock);
+ ffc_IPXSocketServer := WinsockRoutines.htons(aSocket);
+end;
+{--------}
+procedure FFSetIPXSocketClient (const aSocket : integer);
+begin
+ if not FFWSInstalled then
+ raise EffWinsockException.CreateNoData(ffStrResGeneral, fferrWSNoWinsock);
+ ffc_IPXSocketClient := WinsockRoutines.htons(aSocket);
+end;
+{--------}
+procedure FFSetSPXSocket (const aSocket : integer);
+begin
+ if not FFWSInstalled then
+ raise EffWinsockException.CreateNoData(ffStrResGeneral, fferrWSNoWinsock);
+ ffc_SPXSocket := WinsockRoutines.htons(aSocket);
+end;
+{--------}
+function FFGetIPXSocketServer : integer;
+begin
+ if FFWSInstalled then
+ Result := WinsockRoutines.ntohs(ffc_IPXSocketServer)
+ else
+ Result := 0;
+end;
+{--------}
+function FFGetIPXSocketClient : integer;
+begin
+ if FFWSInstalled then
+ Result := WinsockRoutines.ntohs(ffc_IPXSocketClient)
+ else
+ Result := 0;
+end;
+{--------}
+function FFGetSPXSocket : integer;
+begin
+ if FFWSInstalled then
+ Result := WinsockRoutines.ntohs(ffc_SPXSocket)
+ else
+ Result := 0;
+end;
+{====================================================================}
+
+
+{===TffConnection====================================================}
+constructor TffConnection.Create(aOwner : TffBaseCommsProtocol;
+ aRemoteName : TffNetAddress);
+begin
+ inherited Create;
+ FFGetMem(FCode, SizeOf(TffNetMsgCode));
+ FClientID := 0;
+ FHangingUp := True;
+ FHangupDone := False; {!!.01}
+ FHangupLock := TffPadlock.Create; {!!.01}
+ FOwner := aOwner;
+ FRemoteName := FFShStrAlloc(aRemoteName);
+ MaintainLinks := False; {!!.05}
+end;
+{--------}
+destructor TffConnection.Destroy;
+begin
+ FHangupLock.Free;
+ FFFreeMem(FCode, SizeOf(TffNetMsgCode));
+ FFShStrFree(FRemoteName);
+ inherited Destroy;
+end;
+{--------}
+Procedure TffConnection.AddToList(List : TFFList);
+begin {do nothing, descendant must do the work}
+end;
+{--------}
+function TffConnection.GetRemoteName : string; {!!.10}
+begin
+ Result := FRemoteName^;
+end;
+{--------}
+procedure TffConnection.ConfirmAlive(SendConfirm : boolean);
+begin
+ FAliveRetries := 0;
+ FFLLBASE.SetTimer(FLastMsgTimer, FOwner.LastMsgInterval);
+ FSendConfirm := SendConfirm;
+end;
+{--------}
+procedure TffConnection.DepleteLife;
+begin
+{$IFDEF KALog}
+ KALog.WriteStringFmt('DepleteLife, client %d', [ClientID]);
+{$ENDIF}
+ inc(FAliveRetries);
+end;
+{Begin !!.01}
+{--------}
+procedure TffConnection.HangupLock;
+begin
+ FHangupLock.Lock;
+end;
+{--------}
+procedure TffConnection.HangupUnlock;
+begin
+ FHangupLock.Unlock;
+end;
+{End !!.01}
+{--------}
+procedure TffConnection.InitCode(const aStart : longint);
+begin
+ { Find the connection associated with this client. }
+
+ if (aStart = 0) then begin
+ FCodeStart := GetTickCount;
+ if (FCodeStart = 0) then
+ FCodeStart := $12345678;
+ end
+ else
+ FCodeStart := aStart;
+
+ GenerateCode(FCodeStart, FCode^);
+end;
+{--------}
+function TffConnection.IsAlive : boolean;
+begin
+ Result := FAliveRetries < FOwner.KeepAliveRetries;
+end;
+{--------}
+function TffConnection.IsVeryAlive : boolean;
+begin
+ Result := not HasTimerExpired(FLastMsgTimer);
+end;
+{--------}
+function TffConnection.NeedsConfirmSent : boolean;
+begin
+ Result := FSendConfirm;
+ FSendConfirm := false;
+end;
+{--------}
+procedure TffConnection.RemoveFromList(List : TFFList);
+begin {do nothing, descendant must do the work}
+end;
+{====================================================================}
+
+
+
+{===TffBaseCommsProtocol=================================================}
+constructor TffBaseCommsProtocol.Create(const aName : TffNetAddress;
+ aCSType : TffClientServerType);
+var
+ LocalNm : TffNetName;
+ NetNm : TffNetName;
+begin
+ inherited Create;
+ FConnLock := TffPadlock.Create;
+ FCSType := aCSType;
+ FEventLog := nil;
+ FKeepAliveInterval := ffc_KeepAliveInterval;
+ FKeepAliveRetries := ffc_KeepAliveRetries;
+ FLastMsgInterval := ffc_LastMsgInterval;
+ FFSplitNetAddress(aName, LocalNm, NetNm);
+ FLocalName := FFShStrAlloc(LocalNm);
+ FLogEnabled := false;
+ cpSetNetName('Local');
+ FSearchTimeOut := 500;
+ FStarted := false;
+ FStartedEvent := TffEvent.Create;
+ {the net name is set by our descendants}
+ cpConnList := TffList.Create;
+ cpIndexByClient := TffList.Create;
+ cpIndexByClient.Sorted := True;
+ cpIndexByOSConnector := nil;
+ { If this protocol is for a server then create a connection lookup list.
+ The lookup list serves as an index, allowing us to quickly find a
+ connection object. This is much faster than doing a sequential search
+ through the cpConnList. }
+ if aCSType = csServer then begin
+ cpIndexByOSConnector := TFFList.Create;
+ cpIndexByOSConnector.Sorted := True;
+ end;
+end;
+{--------}
+destructor TffBaseCommsProtocol.Destroy;
+begin
+ FStarted := false;
+ FConnLock.Free;
+ if assigned(FStartedEvent) then
+ FStartedEvent.Free;
+ FFShStrFree(FLocalName);
+ FFShStrFree(FNetName);
+ cpConnList.Free;
+ cpIndexByClient.Free;
+ if assigned(cpIndexByOSConnector) then
+ cpIndexByOSConnector.Free;
+ inherited Destroy;
+end;
+{--------}
+procedure TffBaseCommsProtocol.Breathe;
+var
+ dummy : pointer;
+ Msg : TMsg;
+begin
+ if PeekMessage(Msg, FNotifyWindow, 0, 0, PM_NOREMOVE) then begin
+ while PeekMessage(Msg, FNotifyWindow, 0, 0, PM_REMOVE) do
+ DispatchMessage(Msg);
+ end
+ else begin
+ dummy := nil;
+ MsgWaitForMultipleObjects(0, dummy, false, 1, QS_ALLINPUT);
+ end;
+end;
+{--------}
+function TffBaseCommsProtocol.ClientIDExists(const aClientID : TffClientID) : boolean;
+{Rewritten !!.05}
+begin
+ ConnLock;
+ try
+ Result := (cpIndexByClient.Index(aClientID) <> -1);
+ finally
+ ConnUnlock;
+ end;
+end;
+{--------}
+function TffBaseCommsProtocol.ConnectionCount : longInt;
+begin
+ Result := 0;
+ if assigned(cpConnList) then
+ Result := cpConnList.Count;
+end;
+{--------}
+procedure TffBaseCommsProtocol.ConnLock;
+begin
+ FConnLock.Lock;
+end;
+{--------}
+procedure TffBaseCommsProtocol.ConnUnlock;
+begin
+ FConnLock.Unlock;
+end;
+{--------}
+procedure TffBaseCommsProtocol.cpAddConnection(aConnection : TffConnection);
+{Rewritten !!.05}
+var
+ anItem : TffIntListItem;
+begin
+ ConnLock;
+ try
+ aConnection.InitCode(0);
+ cpConnList.Insert(aConnection);
+ { Add an entry to the index by client. }
+ anItem := TffIntListItem.Create(aConnection.ClientID);
+ anItem.ExtraData := aConnection;
+ cpIndexByClient.Insert(anItem);
+ if Assigned(cpIndexByOSConnector) then
+ aConnection.AddToList(cpIndexByOSConnector);
+ finally
+ ConnUnlock;
+ end;
+end;
+{--------}
+procedure TffBaseCommsProtocol.cpCodeMessage(aConn : TffConnection;
+ aData : PffByteArray;
+ aDataLen : longint);
+const
+ LeaveRawLen = 2 * sizeof(longint);
+var
+ aCode : TffNetMsgCode;
+begin
+ if (aDataLen >= LeaveRawLen) then begin
+ if (PffLongint(aData)^ <> ffnmAttachServer) then begin
+ aCode := aConn.Code^;
+ CodeBuffer(aCode, aData^[LeaveRawLen], aDataLen - LeaveRawLen);
+ end;
+ end
+end;
+{--------}
+function TffBaseCommsProtocol.cpCreateNotifyWindow : boolean;
+begin
+ FNotifyWindow := 0;
+ Result := false;
+end;
+{--------}
+procedure TffBaseCommsProtocol.cpDestroyNotifyWindow;
+begin
+ if (FNotifyWindow <> 0) then begin
+ KillTimer(FNotifyWindow, 1);
+ {$IFDEF DCC6OrLater} {!!.11}
+ {$WARN SYMBOL_DEPRECATED OFF}
+ {$ENDIF}
+ {$ifdef fpc}
+ LCLIntf.DeallocateHWnd(FNotifyWindow); //soner
+ {$else}
+ DeallocateHWnd(FNotifyWindow);
+ {$endif}
+
+ {$IFDEF DCC6OrLater} {!!.11}
+ {$WARN SYMBOL_DEPRECATED ON}
+ {$ENDIF}
+ end;
+end;
+{--------}
+procedure TffBaseCommsProtocol.cpDoHangUp(aConn : TffConnection);
+begin
+{Begin !!.01}
+ aConn.HangupLock;
+ try
+ if aConn.HangupDone then
+ Exit;
+ { Are we hanging up on purpose? }
+ if aConn.HangingUp then begin
+ { Yes. Call the OnHangUp event if it is declared. }
+ if Assigned(FOnHangUp) then
+ FOnHangUp(Self, aConn.ClientID);
+ end
+ { No. This is an unexpected hangup. Invoke OnConnectionLost if it is
+ declared. }
+ else if Assigned(FOnConnectionLost) then
+ FOnConnectionLost(Self, aConn.ClientID);
+ aConn.HangupDone := True;
+ finally
+ aConn.HangupUnlock;
+ end;
+{End !!.01}
+end;
+{--------}
+procedure TffBaseCommsProtocol.cpDoHeardCall(aConnHandle : longint);
+begin
+ if Assigned(FHeardCall) then
+ FHeardCall(Self, aConnHandle);
+end;
+{--------}
+procedure TffBaseCommsProtocol.cpPerformShutdown;
+begin
+ cpDestroyNotifyWindow;
+end;
+{--------}
+procedure TffBaseCommsProtocol.cpSetNetName(aName : string);
+begin
+ if assigned(FNetName) then
+ FFShStrFree(FNetName);
+
+ FNetName := FFShStrAlloc(aName);
+end;
+{--------}
+procedure TffBaseCommsProtocol.cpDoReceiveDatagram(const aName : TffNetName;
+ aData : PffByteArray;
+ aDataLen : longint);
+begin
+ if Assigned(FReceiveDatagram) then
+ FReceiveDatagram(Self, aName, aData, aDataLen);
+end;
+{--------}
+function TffBaseCommsProtocol.cpDoReceiveMsg(aConn : TffConnection;
+ msgData : PffByteArray;
+ msgDataLen : longInt) : boolean;
+begin
+ {Look out for keep alives}
+ if (PffLongint(msgData)^ = ffnmCheckConnection) then begin
+ cpGotCheckConnection(aConn);
+ Result := true;
+ Exit;
+ end;
+
+ {process normal FF message}
+{$IFDEF KALog}
+ KALog.WriteStringFmt('RcvMsg, client %d', [aConn.ClientID]);
+{$ENDIF}
+ aConn.ConfirmAlive(false);
+ { If this message is too big for us then reject it. }
+
+ if msgDataLen > FMaxNetMsgSize then begin
+ LogStrFmt('Message size %d too large.', [msgDataLen]);
+ Result := False;
+ end
+ { Otherwise if we have a handler for the message then send the message
+ to the handler. }
+ else if Assigned(FReceiveMsg) then begin
+ cpCodeMessage(aConn, msgData, msgDataLen);
+ Result := FReceiveMsg(Self, aConn.ClientID, msgData, msgDataLen);
+ end else
+ { Otherwise no handler so just smile. }
+ Result := true;
+end;
+{--------}
+function TffBaseCommsProtocol.cpExistsConnection(aConnHandle : longint) : boolean;
+begin
+ Result := cpConnList.Exists(aConnHandle);
+end;
+{--------}
+function TffBaseCommsProtocol.cpFindConnection(const aClientID : TffClientID) : Longint;
+var
+ Inx : Longint;
+begin
+ Result := -1;
+ for Inx := 0 to pred(cpConnList.Count) do
+ if TffConnection(cpConnList[Inx]).ClientID = aClientID then begin
+ Result := Inx;
+ break;
+ end;
+end;
+{--------}
+function TffBaseCommsProtocol.cpGetConnection(const aClientID : TffClientID) : TffConnection;
+{ Modified !!.05}
+var
+ Inx : integer;
+begin
+ { Note: It is possible for a newly-attached client to send another request to
+ the server before the server has had a chance to update the new
+ client's server-side clientID. So we use a lock to prevent this
+ from happening. }
+ ConnLock;
+ try
+ Inx := cpIndexByClient.Index(aClientID);
+ if (Inx = -1) then
+ Result := nil
+ else
+ Result := TffConnection(TffIntListItem(cpIndexByClient[Inx]).ExtraData);
+ finally
+ ConnUnlock;
+ end;
+end;
+{--------}
+function TffBaseCommsProtocol.cpGetConnectionIDs(const anIndex : longInt) : TffClientID;
+{Begin !!.01}
+var
+ aConn : TffConnection;
+begin
+ aConn := TffConnection(cpConnList[anIndex]);
+ if aConn = nil then
+ Result := 0
+ else
+ Result := TffConnection(cpConnList[anIndex]).ClientID;
+{End !!.01}
+end;
+{--------}
+procedure TffBaseCommsProtocol.cpGotCheckConnection(aConn : TffConnection);
+begin
+ {Reset keepalives}
+ if assigned(aConn) then begin
+{$IFDEF KALog}
+ KALog.WriteStringFmt('RcvKA, client %d', [aConn.ClientID]);
+{$ENDIF}
+ aConn.ConfirmAlive(true);
+ end;
+end;
+{--------}
+procedure TffBaseCommsProtocol.cpRemoveConnection(aClientID : TffClientID);
+var
+ Inx : integer;
+ aConn : TffConnection;
+begin
+{Begin !!.05}
+ ConnLock;
+ try
+ Inx := cpIndexByClient.Index(aClientID);
+ { Did we find the connection in the index? }
+ if (Inx >= 0) then begin
+ { Yes. Remove the connection from the index and from the connection
+ list. }
+ aConn := TffConnection(cpIndexByClient[Inx]).ExtraData;
+ cpIndexByClient.DeleteAt(Inx);
+ cpConnList.Remove(aConn);
+ if assigned(cpIndexByOSConnector) then
+ aConn.RemoveFromList(cpIndexByOSConnector);
+ aConn.Free;
+ end
+ else begin
+ { No. It may be that we have encountered a client that could not
+ successfully connect. We have an entry in the connection list but not
+ in the index. Do a sequential search for the client. }
+ Inx := cpFindConnection(aClientID);
+ if Inx >= 0 then begin
+ aConn := TffConnection(cpConnList[Inx]);
+ cpConnList.RemoveAt(Inx);
+ aConn.Free;
+ end;
+ end;
+ finally
+ ConnUnlock;
+ end;
+{End !!.05}
+end;
+{--------}
+procedure TffBaseCommsProtocol.cpTimerTick;
+var
+ Inx : integer;
+ Conn : TffConnection;
+ KAMsg : longint;
+begin
+{Begin !!.05}
+ ConnLock;
+ try
+ KAMsg := ffnmCheckConnection;
+ for Inx := pred(cpConnList.Count) downto 0 do begin
+ Conn := TffConnection(cpConnList[Inx]);
+ with Conn do begin
+ if (not Conn.FHangupLock.Locked) and (not IsAlive) then begin {!!.11}
+{$IFDEF KALog}
+ KALog.WriteStringFmt('Hangup, client %d', [Conn.ClientID]);
+{$ENDIF}
+ Conn.HangingUp := False; {!!.06}
+ HangUp(Conn);
+ end
+ else if NeedsConfirmSent or (not IsVeryAlive) then begin
+{$IFDEF KALog}
+ KALog.WriteStringFmt('Send KA, client %d', [Conn.ClientID]);
+{$ENDIF}
+ SendMsg(ClientID, @KAMsg, sizeof(KAMsg), False); {!!.06}
+ DepleteLife;
+ end;
+ end;
+ end;
+ finally
+ ConnUnlock;
+ end;
+{End !!.05}
+end;
+{--------}
+function TffBaseCommsProtocol.GetLocalName : string; {!!.10}
+begin
+ if Assigned(FLocalName) then
+ Result := FLocalName^
+ else
+ Result := '';
+end;
+{--------}
+function TffBaseCommsProtocol.GetNetName : string; {!!.10}
+begin
+ if Assigned(FNetName) then
+ Result := FNetName^
+ else
+ Result := '';
+end;
+{--------}
+function TffBaseCommsProtocol.GetCodeStart(const aClientID : TffClientID) : integer;
+var
+ aConn : TffConnection;
+ anItem : TffIntListItem;
+begin
+ { Assumption: Connection lists locked via ConnLock at a higher level. }
+ Result := 0;
+ { Find the connection associated with this client. }
+ anItem := TffIntListItem(cpIndexByClient[cpIndexByClient.Index(aClientID)]);
+ if assigned(anItem) then begin
+ aConn := TffConnection(anItem.ExtraData);
+ Result := aConn.CodeStart;
+ end;
+end;
+{--------}
+class function TffBaseCommsProtocol.GetProtocolName : string;
+begin
+ { return nothing at this level }
+ Result := '';
+end;
+{--------}
+procedure TffBaseCommsProtocol.HangUpByClientID(aClientID : TffClientID);
+var
+ aConn : TffConnection;
+begin
+ aConn := cpGetConnection(aClientID);
+ if assigned(aConn) then begin
+ aConn.HangingUp := True;
+ HangUp(aConn);
+ end;
+end;
+{Begin !!.01}
+{--------}
+procedure TffBaseCommsProtocol.HangupDone(aClientID : TffClientID);
+var
+ aConn : TffConnection;
+begin
+ aConn := cpGetConnection(aClientID);
+ if assigned(aConn) then
+ aConn.HangupDone := True;
+end;
+{--------}
+function TffBaseCommsProtocol.HangupIsDone(aClientID : TffClientID) : Boolean;
+var
+ aConn : TffConnection;
+begin
+ Result := False;
+ aConn := cpGetConnection(aClientID);
+ if assigned(aConn) then
+ Result := aConn.HangupDone;
+end;
+{--------}
+procedure TffBaseCommsProtocol.HangupLock(aClientID : TffClientID);
+var
+ aConn : TffConnection;
+begin
+ aConn := cpGetConnection(aClientID);
+ if assigned(aConn) then
+ aConn.HangupLock;
+end;
+{--------}
+procedure TffBaseCommsProtocol.HangupUnlock(aClientID : TffClientID);
+var
+ aConn : TffConnection;
+begin
+ aConn := cpGetConnection(aClientID);
+ if assigned(aConn) then
+ aConn.HangupUnlock;
+end;
+{End !!.01}
+{--------}
+procedure TffBaseCommsProtocol.InitCode(const aClientID : TffClientID;
+ const aStart : longint);
+var
+ aConn : TffConnection;
+ anItem : TffIntListItem;
+begin
+ { Find the connection associated with this client. }
+ anItem := TffIntListItem(cpIndexByClient[cpIndexByClient.Index(aClientID)]);
+ if assigned(anItem) then begin
+ aConn := TffConnection(anItem.ExtraData);
+ aConn.InitCode(aStart);
+ end;
+end;
+{--------}
+procedure TffBaseCommsProtocol.ResetKeepAliveTimer;
+begin
+ if (FNotifyWindow <> 0) then begin
+{$IFDEF KALog}
+ KALog.WriteStringFmt('ResetKeepAliveTimer: protocol %d', [Longint(Self)]);
+{$ENDIF}
+ KillTimer(FNotifyWindow, 1);
+ Windows.SetTimer(FNotifyWindow, 1, FKeepAliveInterval, nil); {!!.05}
+ end;
+end;
+{--------}
+procedure TffBaseCommsProtocol.Shutdown;
+begin
+ if IsStarted then begin
+ cpPerformShutdown;
+ FStarted := false;
+ end;
+end;
+{--------}
+procedure TffBaseCommsProtocol.StartUp;
+begin
+ if not IsStarted then begin
+ cpPerformStartUp;
+ FStarted := true;
+ FStartedEvent.SignalEvent;
+ end;
+end;
+{--------}
+class function TffBaseCommsProtocol.Supported : boolean;
+begin
+ Result := True;
+end;
+{--------}
+procedure TffBaseCommsProtocol.UpdateClientID(const oldClientID,
+ newClientID : TffClientID);
+var
+ aConn : TffConnection;
+ anItem : TffIntListItem;
+begin
+{Begin !!.05}
+ ConnLock;
+ try
+ anItem := TffIntListItem(cpIndexByClient[cpIndexByClient.Index(oldClientID)]);
+ if assigned(anItem) then begin
+ aConn := anItem.ExtraData;
+ aConn.ClientID := newClientID;
+
+ { Get rid of the old index entry; as a side effect, anItem should be
+ freed. }
+ cpIndexByClient.Delete(oldClientID);
+
+ { Create a new entry for the index. }
+ anItem := TffIntListItem.Create(newClientID);
+ anItem.ExtraData := aConn;
+ cpIndexByClient.Insert(anItem);
+ end;
+ finally
+ ConnUnlock;
+ end;
+{End !!.05}
+end;
+{--------}
+procedure TffBaseCommsProtocol.LogStr(const aMsg : string);
+begin
+ if FLogEnabled and assigned(FEventLog) then
+ FEventLog.WriteSTring(format('%s: %s',
+ [Self.GetProtocolName, aMsg]));
+end;
+{--------}
+procedure TffBaseCommsProtocol.LogStrFmt(const aMsg : string;
+ args : array of const);
+begin
+ if FLogEnabled and assigned(FEventLog) then
+ LogStr(format(aMsg, args));
+end;
+{====================================================================}
+
+{===TffWinsockConnection=============================================}
+constructor TffWinsockConnection.Create(aOwner : TffBaseCommsProtocol;
+ aRemoteName : TffNetAddress;
+ aSocket : TffwsSocket;
+ aFamily : TffWinsockFamily;
+ aNotifyWnd : HWND);
+var
+ NagelOn : Bool;
+begin
+ inherited Create(aOwner, aRemoteName);
+ FHangingUp := False;
+ { Note that we are overriding the initial value of FHangingUp on purpose. }
+ FSocket := aSocket;
+ FFamily := aFamily;
+ if (aFamily = wfTCP) then begin
+ FFWSGetSocketOption(aSocket, IPPROTO_TCP, TCP_NODELAY, NagelOn, sizeof(NagelOn));
+ if NagelOn then begin
+ NagelOn := false;
+ FFWSSetSocketOption(aSocket, IPPROTO_TCP, TCP_NODELAY, NagelOn, sizeof(NagelOn));
+ end;
+ end;
+ FFWSSetSocketOption(aSocket, SOL_SOCKET, So_RCVBUF, ffc_TCPRcvBuf,
+ sizeof(ffc_TCPRcvBuf));
+ FFWSSetSocketOption(aSocket, SOL_SOCKET, So_SNDBUF, ffc_TCPSndBuf,
+ sizeof(ffc_TCPSndBuf));
+ FFWSGetSocketOption(aSocket, SOL_SOCKET, So_RCVBUF, wscRcvBuf,
+ sizeof(wscRcvBuf));
+ FFWSGetSocketOption(aSocket, SOL_SOCKET, So_SNDBUF, wscSndBuf,
+ sizeof(wscSndBuf));
+ wscNotifyWnd := aNotifyWnd;
+// wscPortal := TffReadWritePortal.Create; {Deleted !!.05}
+ GetMem(wscRcvBuffer, ffc_MaxWinsockMsgSize);
+ wscPacketHead := Nil;
+ wscPacketTail := Nil;
+ wscIsSending := False;
+end;
+{--------}
+destructor TffWinsockConnection.Destroy;
+var
+ aPacket : PffwscPacket;
+begin
+ HangupLock; {!!.05}
+// wscPortal.BeginWrite; {Deleted !!.05}
+ try
+ try
+ FFWSDestroySocket(Socket);
+ except
+ end;
+ while wscPacketHead <> Nil do begin
+ aPacket := wscPacketHead^.lpNext;
+ ffFreeMem(wscPacketHead^.lpData, wscPacketHead^.dwLength);
+ ffFreeMem(wscPacketHead, sizeof(TffwscPacket));
+ wscPacketHead := aPacket;
+ end;
+ FreeMem(wscRcvBuffer, ffc_MaxWinsockMsgSize);
+ finally
+ HangupUnlock; {!!.05}
+// wscPortal.EndWrite; {Deleted !!.05}
+// wscPortal.Free; {Deleted !!.05}
+ end;
+ inherited Destroy;
+end;
+{--------}
+Procedure TffWinsockConnection.AddToList(List : TFFList);
+var
+ T : TffIntListItem;
+begin {add a list entry to allow socket lookups}
+ T := TffIntListItem.Create(Socket);
+ T.ExtraData := Self;
+ List.Insert(T);
+end;
+{--------}
+Procedure TffWinsockConnection.RemoveFromList(List : TFFList);
+begin
+ List.Delete(FSocket);
+end;
+{--------}
+function TffWinsockConnection.Send(aData : PffByteArray;
+ aDataLen : longint;
+ aDataStart : longint;
+ var aBytesSent : longint;
+ aConnLock : Boolean) : integer; {!!.06}
+var
+ BytesSent : longint;
+ PacketBuffer : PffwscPacket;
+begin
+ if aConnLock then {!!.06}
+ HangupLock; {!!.05}
+// wscPortal.BeginWrite; {Deleted !!.05}
+ try
+ Result := 0;
+ if (aDataLen-aDataStart) > 0 then begin
+ {Add the data packet to the wscPacketList }
+ ffGetMem(PacketBuffer,sizeof(TffwscPacket));
+ ffGetMem(PacketBuffer^.lpData, aDataLen);
+ PacketBuffer^.dwLength := aDataLen;
+ PacketBuffer^.dwStart := aDataStart;
+ Move(aData^[0], PacketBuffer^.lpData^, PacketBuffer^.dwLength);
+ Owner.cpCodeMessage(Self, PacketBuffer^.lpData, PacketBuffer^.dwLength);
+ PacketBuffer^.lpNext := Nil;
+ {Add the packet to the end of the list }
+ if not assigned(wscPacketHead) then
+ wscPacketHead := PacketBuffer
+ else if assigned(wscPacketTail) then
+ wscPacketTail^.lpNext := PacketBuffer;
+ wscPacketTail := PacketBuffer;
+ aBytesSent := 0; {!!.06}
+// aBytesSent := aDataLen-aDataStart; {Always report all bytes sent} {Deleted !!.06}
+ end;
+ if (not wscIsSending) and Assigned(wscPacketHead) then begin
+ {now try to send some data}
+ try
+ {send the first waiting data packet}
+ BytesSent := WinsockRoutines.send(Socket,
+ wscPacketHead^.lpData^[wscPacketHead^.dwStart],
+ wscPacketHead^.dwLength-wscPacketHead^.dwStart,
+ 0);
+ except
+ BytesSent := SOCKET_ERROR;
+ end;
+ if (BytesSent = SOCKET_ERROR) then begin
+ {There was an error sending }
+ Result := WinsockRoutines.WSAGetLastError;
+ if (Result = WSAEWOULDBLOCK) then begin
+ { Mark this connection as blocked and leave the Packet on the list. }
+ wscIsSending := True;
+// Result := 0; {Deleted !!.06}
+ end
+{Begin !!.06}
+ else if Result = 0 then
+ { If no error code returned then reset the Result to -1 so that we
+ break out of the send loop, avoiding a re-add of the current
+ packet to the packet list. }
+ Result := -1;
+{End !!.06}
+ end else if BytesSent < (wscPacketHead^.dwLength - wscPacketHead^.dwStart) then begin
+ { we didn't send the whole thing, so re-size the data packet}
+ inc(wscPacketHead^.dwStart, BytesSent);
+ inc(aBytesSent, BytesSent); {!!.06}
+ { now try sending the remaining data again }
+ Result := Send(nil, 0, 0, aBytesSent, aConnLock); {!!.06}
+ end else begin
+ {we sent the packet, so remove it and continue }
+ ffFreeMem(wscPacketHead^.lpData, wscPacketHead^.dwLength);
+ PacketBuffer := wscPacketHead;
+ wscPacketHead := wscPacketHead^.lpNext;
+ if not Assigned(wscPacketHead) then
+ wscPacketTail := Nil;
+ ffFreeMem(PacketBuffer, sizeof(TffwscPacket));
+ inc(aBytesSent, BytesSent); {!!.11}
+ Result := 0;
+ end;
+ end;
+ finally
+ if aConnLock then {!!.06}
+ HangupUnlock; {!!.05}
+// wscPortal.EndWrite; {Deleted !!.05}
+ end;
+end;
+{--------}
+procedure TffWinsockConnection.StartReceive;
+begin
+ FFWSAsyncSelect(Socket, wscNotifyWnd,
+ FD_READ or FD_WRITE or FD_CLOSE);
+end;
+{====================================================================}
+
+
+{===TffWinsockProtocol===============================================}
+constructor TffWinsockProtocol.Create(const aName : TffNetAddress;
+ aCSType : TffClientServerType);
+begin
+ {make sure Winsock is installed}
+ if not FFWSInstalled then
+ raise EffWinsockException.CreateNoData(ffStrResGeneral, fferrWSNoWinsock);
+ {let our ancestor create itself}
+ inherited Create(aName, aCSType);
+ FCollectingServerNames := false;
+ FDatagramPadlock := TffPadlock.Create;
+ FMaxNetMsgSize := ffc_MaxWinsockMsgSize;
+ FServerNames := TStringList.Create;
+ FServerNames.Sorted := True;
+ FServerNames.Duplicates := dupIgnore;
+ {set the sockets we use to default values}
+ wspListenSocket := INVALID_SOCKET;
+ wspRcvDatagramSocket := INVALID_SOCKET;
+ {allocate a receive datagram buffer}
+ GetMem(wspRcvDGBuffer, ffc_MaxDatagramSize);
+end;
+{--------}
+destructor TffWinsockProtocol.Destroy;
+begin
+ if assigned(FServerNames) then
+ FServerNames.Free;
+ if assigned(FDatagramPadlock) then
+ FDatagramPadlock.Free;
+ FFWSDestroySocket(wspListenSocket);
+ FFWSDestroySocket(wspRcvDatagramSocket);
+ inherited Destroy;
+ FFShStrFree(FNetName);
+ FreeMem(wspRcvDGBuffer, ffc_MaxDatagramSize);
+end;
+{--------}
+function TffWinsockProtocol.Call(const aServerName : TffNetName;
+ var aClientID : TffClientID;
+ const timeout : longInt) : TffResult;
+var
+ NewSocket : TffwsSocket;
+ Conn : TffWinsockConnection;
+ SASize : integer;
+ AddrFamily : integer;
+ Protocol : integer;
+ RemSockAddr : TffwsSockAddr;
+ aNetName : TffNetName;
+ T : TffTimer; {!!.05}
+ StartTime : DWORD; {!!.05}
+begin
+
+ Result := DBIERR_NONE;
+
+ {servers don't call}
+ if (CSType = csServer) then
+ raise EffCommsException.CreateNoData(ffStrResGeneral, fferrCommsCannotCall);
+
+ { If no servername then we cannot connect. }
+ if (aServerName = '') then begin
+ Result := DBIERR_SERVERNOTFOUND;
+ Exit;
+ end;
+
+ {either create a socket address record for TCP...}
+ if (Family = wfTCP) then begin
+ AddrFamily := AF_INET;
+ Protocol := 0;
+ SASize := sizeof(TffwsSockAddrIn);
+ FillChar(RemSockAddr, SASize, 0);
+ with RemSockAddr.TCP do begin
+ sin_family := PF_INET;
+ sin_port := ffc_TCPPort;
+ if FFWSCvtStrToAddr(aServerName, sin_addr) then
+// aNetName := FFWSGetRemoteNameFromAddr(sin_addr)
+ else begin
+ if not FFWSGetRemoteHost(aServerName, aNetName, sin_addr) then begin
+ Result := DBIERR_SERVERNOTFOUND; {!!.06}
+ Exit;
+ end;
+ end;
+ end;
+ end
+ {or for IPX...}
+ else {if (Family = wfIPX) then} begin
+ AddrFamily := AF_IPX;
+ Protocol := NSPROTO_SPX;
+ SASize := sizeof(TffwsSockAddrIPX);
+ FillChar(RemSockAddr, SASize, 0);
+ with RemSockAddr.IPX do begin
+ sipx_family := PF_IPX;
+ if not FFWSCvtStrToIPXAddr(aServerName,
+ sipx_netnum,
+ sipx_nodenum) then
+ Exit;
+ sipx_socket := ffc_SPXSocket;
+ end;
+ end;
+ {open a call socket}
+ NewSocket := FFWSCreateSocket(AddrFamily, SOCK_STREAM, Protocol);
+ try
+ {set the socket to non-blocking mode}
+ FFWSAsyncSelect(NewSocket, FNotifyWindow, FD_CONNECT);
+ {try and connect}
+ wspWaitingForConnect := true;
+ CheckWinsockError(
+ WinsockRoutines.connect(NewSocket, RemSockAddr, SASize), False);
+{Begin !!.05}
+// wspWaitForConnect(timeout, NewSocket);
+ StartTime := GetTickCount;
+ SetTimer(T, timeout);
+ while wspWaitingForConnect and (not HasTimerExpired(T)) do begin
+ if (GetTickCount - StartTime) > ffc_ConnectRetryTimeout then begin
+ CheckWinsockError(WinsockRoutines.connect(NewSocket, RemSockAddr,
+ SASize), True);
+ Starttime := GetTickCount;
+ end;
+ Breathe;
+ end;
+{End !!.05}
+ {if we connected...}
+ if not wspWaitingForConnect then begin
+ {create a new connection}
+ Conn := TffWinsockConnection.Create(Self, aNetName, NewSocket, Family,
+ FNotifyWindow);
+ Conn.ClientID := Conn.Handle;
+ aClientID := Conn.Handle;
+ cpAddConnection(Conn);
+ Conn.StartReceive;
+ end
+ else begin {we didn't connect}
+ FFWSDestroySocket(NewSocket);
+ Result := DBIERR_SERVERNOTFOUND;
+ end;
+ except
+ FFWSDestroySocket(NewSocket);
+ raise;
+ end;{try..except}
+end;
+{--------}
+procedure TffWinsockProtocol.cpDoReceiveDatagram(const aName : TffNetName;
+ aData : PffByteArray;
+ aDataLen : longint);
+var
+ Addr : TffNetAddress; { sender }
+ Datagram : PffnmServerNameReply absolute aData; { sender }
+ Msg : PffnmRequestServerName absolute aData; { listener }
+ Reply : TffnmServerNameReply; { listener }
+begin
+ inherited cpDoReceiveDatagram(aName, aData, aDataLen);
+ FDatagramPadlock.Lock;
+ try
+ { If we are on the sending side, waiting for server names to roll in
+ then get the server's reply and add it to our list of server names. }
+ if FCollectingServerNames then begin
+ if assigned(aData) and (Datagram^.MsgID = ffnmServerNameReply) then begin
+ FFMakeNetAddress(Addr, Datagram^.ServerLocalName, aName);
+ FServerNames.Add(Addr);
+ end;
+ end else
+ { Otherwise, we are on the listening side and a client is asking us to
+ identify ourself. }
+ if (aDataLen = sizeof(TffnmRequestServerName)) and
+ (Msg^.MsgID = ffnmRequestServerName) then begin
+ {send a message back to the caller with our name}
+ Reply.MsgID := ffnmServerNameReply;
+ Reply.ServerLocalName := LocalName;
+ Reply.ServerNetName := NetName;
+ SendDatagram(aName, @Reply, sizeof(Reply));
+ end;
+ finally
+ FDatagramPadlock.Unlock;
+ end;
+end;
+{--------}
+procedure TffWinsockProtocol.cpPerformStartUp;
+var
+ AddrFamily : integer;
+ Protocol : integer;
+ SASize : integer;
+ SockAddr : TffwsSockAddr;
+begin
+ {create our notify window}
+ if not cpCreateNotifyWindow then begin
+ LogStr('Could not create notification window.');
+ raise EffCommsException.CreateNoData(ffStrResGeneral, fferrCommsNoWinRes);
+ end;
+
+ {create and bind the listen socket if we're a server; for a client,
+ we never would listen}
+ if (CSType = csServer) then begin
+ {==the listen socket==}
+ {create a socket address record}
+ if (Family = wfTCP) then begin
+ AddrFamily := AF_INET;
+ Protocol := 0;
+ SASize := sizeof(TffwsSockAddrIn);
+ FillChar(SockAddr, SASize, 0);
+ with SockAddr.TCP do begin
+ sin_family := PF_INET;
+ sin_port := ffc_TCPPort;
+ sin_addr := wspLocalInAddr;
+ end;
+ end
+ else {if (Family = wfIPX) then} begin
+ AddrFamily := AF_IPX;
+ Protocol := NSPROTO_SPX;
+ SASize := sizeof(TffwsSockAddrIPX);
+ FillChar(SockAddr, SASize, 0);
+ with SockAddr.IPX do begin
+ sipx_family := PF_IPX;
+ sipx_netnum := wspLocalIPXNetNum;
+ sipx_nodenum := wspLocalIPXAddr;
+ sipx_socket := ffc_SPXSocket;
+ end;
+ end;
+ {open a listen socket}
+ wspListenSocket := FFWSCreateSocket(AddrFamily, SOCK_STREAM, Protocol);
+ {bind the socket to the address}
+ CheckWinsockError(
+ WinsockRoutines.bind(wspListenSocket, SockAddr, SASize), False);
+ end;
+end;
+{--------}
+procedure TffWinsockProtocol.GetServerNames(aList : TStrings; const timeout : longInt);
+var
+ TotalTimer : TffTimer;
+ NameReq : TffnmRequestServerName;
+begin
+ if not assigned(aList) then
+ exit;
+
+ { Open and prepare a UDP socket. }
+ ReceiveDatagram;
+ FCollectingServerNames := true;
+ try
+ aList.Clear;
+ FServerNames.Clear;
+ NameReq.MsgID := ffnmRequestServerName;
+ SetTimer(TotalTimer, timeout); {!!.13}
+ SendDatagram('', @NameReq, sizeOf(NameReq));
+ repeat
+ Breathe;
+ until HasTimerExpired(TotalTimer);
+ aList.Assign(FServerNames);
+ finally
+ FCollectingServerNames := false;
+ StopReceiveDatagram;
+ end;
+
+end;
+{--------}
+procedure TffWinsockProtocol.HangUp(aConn : TffConnection);
+begin
+ cpDoHangUp(aConn);
+ cpRemoveConnection(aConn.ClientID);
+end;
+{--------}
+procedure TffWinsockProtocol.Listen;
+begin
+ {clients don't listen}
+ if (CSType = csClient) then
+ raise EffCommsException.CreateNoData(ffStrResGeneral, fferrCommsCantListen);
+ {start listening, if not doing so already}
+ if not wspListening then begin
+ FFWSAsyncSelect(wspListenSocket, FNotifyWindow, FD_ACCEPT);
+ CheckWinsockError(WinsockRoutines.listen(wspListenSocket, SOMAXCONN), False);
+ wspListening := true;
+ end;
+end;
+{--------}
+procedure TffWinsockProtocol.ReceiveDatagram;
+var
+ AddrFamily : integer;
+ Protocol : integer;
+ SASize : integer;
+ BCastOn : Bool;
+ SockAddr : TffwsSockAddr;
+begin
+ if not wspReceivingDatagram then begin
+ {create and bind the receive datagram socket}
+ {create a socket address record}
+ if (Family = wfTCP) then begin
+ AddrFamily := AF_INET;
+ Protocol := 0;
+ SASize := sizeof(TffwsSockAddrIn);
+ FillChar(SockAddr, SASize, 0);
+ with SockAddr.TCP do begin
+ sin_family := PF_INET;
+ if (CSType = csClient) then
+ sin_port := ffc_UDPPortClient
+ else
+ sin_port := ffc_UDPPortServer;
+ sin_addr := wspLocalInAddr;
+ end;
+ end
+ else {if (Family = wfIPX) then} begin
+ AddrFamily := AF_IPX;
+ Protocol := NSPROTO_IPX;
+ SASize := sizeof(TffwsSockAddrIPX);
+ FillChar(SockAddr, SASize, 0);
+ with SockAddr.IPX do begin
+ sipx_family := PF_IPX;
+ sipx_netnum := wspLocalIPXNetNum;
+ sipx_nodenum := wspLocalIPXAddr;
+ if (CSType = csClient) then
+ sipx_socket := ffc_IPXSocketClient
+ else
+ sipx_socket := ffc_IPXSocketServer;
+ end;
+ end;
+ {open a receivedatagram socket}
+ wspRcvDatagramSocket := FFWSCreateSocket(AddrFamily,
+ SOCK_DGRAM,
+ Protocol);
+ {make sure the socket can do broadcasts (req for IPX)}
+ if (Family = wfIPX) then begin
+ BCastOn := true;
+ FFWSSetSocketOption(wspRcvDatagramSocket, SOL_SOCKET, SO_BROADCAST,
+ BCastOn, sizeof(BCastOn));
+ end;
+ {bind the socket to the address}
+ CheckWinsockError(
+ WinsockRoutines.bind(wspRcvDatagramSocket, SockAddr, SASize), False);
+ FFWSAsyncSelect(wspRcvDatagramSocket, FNotifyWindow, FD_READ or FD_WRITE);
+ wspReceivingDatagram := true;
+ end;
+end;
+{--------}
+procedure TffWinsockProtocol.SendDatagram(const aName : TffNetName;
+ aData : PffByteArray;
+ aDataLen : longint);
+var
+ SockAddr : TffwsSockAddr;
+ Socket : TffwsSocket;
+ SASize : integer;
+ BCastOn : Bool;
+ NetName : TffNetName;
+begin
+ {create a send datagram socket}
+ if (Family = wfTCP) then begin
+ Socket := FFWSCreateSocket(AF_INET, SOCK_DGRAM, 0);
+ end
+ else {Family <> wfTCP} begin
+ Socket := FFWSCreateSocket(AF_IPX, SOCK_DGRAM, NSPROTO_IPX);
+ end;
+ try
+ {create the socket address to bind to}
+ if (aName = '') then begin {a broadcast message}
+ {create a socket address record}
+ if (Family = wfTCP) then begin
+ SASize := sizeof(TffwsSockAddrIn);
+ FillChar(SockAddr, SASize, 0);
+ with SockAddr.TCP do begin
+ sin_family := PF_INET;
+ if (CSType = csClient) then
+ sin_port := ffc_UDPPortServer
+ else
+ sin_port := ffc_UDPPortClient;
+ sin_addr := INADDR_BROADCAST;
+ end;
+ end
+ else {Family <> wfTCP} begin
+ SASize := sizeof(TffwsSockAddrIPX);
+ FillChar(SockAddr, SASize, 0);
+ with SockAddr.IPX do begin
+ sipx_family := PF_IPX;
+ FillChar(sipx_nodenum, sizeof(sipx_nodenum), $FF);
+ if (CSType = csClient) then
+ sipx_socket := ffc_IPXSocketServer
+ else
+ sipx_socket := ffc_IPXSocketClient;
+ end;
+ end;
+ {make sure the socket can do broadcasts}
+ BCastOn := true;
+ FFWSSetSocketOption(Socket, SOL_SOCKET, SO_BROADCAST, BCastOn, sizeof(BCastOn));
+ end
+ else begin {a specific target}
+ {create a socket address record}
+ if (Family = wfTCP) then begin
+ SASize := sizeof(TffwsSockAddrIn);
+ FillChar(SockAddr, SASize, 0);
+ with SockAddr.TCP do begin
+ sin_family := PF_INET;
+ if (CSType = csClient) then
+ sin_port := ffc_UDPPortServer
+ else
+ sin_port := ffc_UDPPortClient;
+ if not FFWSCvtStrToAddr(aName, sin_addr) then
+ if not FFWSGetRemoteHost(aName, NetName, sin_addr) then
+ Exit;
+ end;
+ end
+ else {Family <> wfTCP} begin
+ SASize := sizeof(TffwsSockAddrIPX);
+ FillChar(SockAddr, SASize, 0);
+ with SockAddr.IPX do begin
+ sipx_family := PF_IPX;
+ if not FFWSCvtStrToIPXAddr(aName, sipx_netnum, sipx_nodenum) then
+ Exit;
+ if (CSType = csClient) then
+ sipx_socket := ffc_IPXSocketServer
+ else
+ sipx_socket := ffc_IPXSocketClient;
+ end;
+ end;
+ end;
+ CheckWinsockError(
+ WinsockRoutines.sendto(Socket, aData^, aDataLen, 0, SockAddr, SASize),
+ False);
+ finally
+ FFWSDestroySocket(Socket);
+ end;{try.finally}
+end;
+{--------}
+function TffWinsockProtocol.SendMsg(aClientID : TffClientID;
+ aData : PffByteArray;
+ aDataLen : longint;
+ aConnLock : Boolean) : TffResult; {!!.06}
+var
+ Conn : TffWinsockConnection;
+ SendResult : integer;
+ BytesSent : longint;
+ SentSoFar : longint;
+ DataPtr : PffByteArray; {!!.06}
+ DataLen : Longint; {!!.06}
+ TimerExpired : Boolean; {!!.06}
+begin
+ Result := DBIERR_NONE;
+ Conn := TffWinsockConnection(cpGetConnection(aClientID));
+ if Assigned(Conn) then begin
+ DataPtr := aData; {!!.06}
+ DataLen := aDataLen; {!!.06}
+ SentSoFar := 0;
+ while (SentSoFar < DataLen) do begin
+ SendResult := Conn.Send(DataPtr, DataLen, SentSoFar, BytesSent, {!!.06}
+ aConnLock); {!!.06}
+ if (SendResult = WSAEWOULDBLOCK) then begin
+{Begin !!.06}
+ TimerExpired := wspWaitForSendToUnblock;
+ { The connection has the packet already on its list, waiting to be
+ resent. Reset the data pointer & length so that the connection
+ does not add a duplicate packet to its list. }
+ DataPtr := nil;
+ DataLen := 0;
+ { The connection may have been killed (hung up), so recheck. }
+ Conn := TffWinsockConnection(cpGetConnection(aClientID));
+ if Conn = nil then
+ Exit
+ else if TimerExpired then begin
+ wspWaitingForSendToUnblock := False;
+ Conn.IsSending := False;
+ end;
+{End !!.06}
+ end
+ else if (SendResult <> 0) then begin
+ LogStrFmt('Unhandled Winsock Exception %d', [SendResult]);
+ Result := SendResult;
+// Conn.HangingUp := True; {Deleted !!.06}
+// HangUp(Conn); {Deleted !!.06}
+ exit;
+ end
+ else begin
+ inc(SentSoFar, BytesSent);
+ end;
+ end; { while }
+ end else
+ Result := fferrConnectionLost;
+end;
+{--------}
+procedure TffWinsockProtocol.SetFamily(F : TffWinsockFamily);
+var
+ LocalHost : TffNetName;
+begin
+ if (FNetName <> nil) then
+ FFShStrFree(FNetName);
+ FFamily := F;
+ if (F = wfTCP) then begin
+ {get our name and address}
+ if not FFWSGetLocalHostByNum(ffc_TCPInterface, LocalHost,
+ wspLocalInAddr) then
+ raise EffWinsockException.CreateNoData(ffStrResGeneral, fferrWSNoLocalAddr);
+ cpSetNetName(FFWSCvtAddrToStr(wspLocalInAddr));
+ end
+ else if (F = wfIPX) then begin
+ {get our IPX address}
+ if not FFWSGetLocalIPXAddr(wspLocalIPXNetNum, wspLocalIPXAddr) then
+ raise EffWinsockException.CreateNoData(ffStrResGeneral, fferrWSNoLocalAddr);
+ cpSetNetName(FFWSCvtIPXAddrToStr(wspLocalIPXNetNum, wspLocalIPXAddr));
+ end;
+end;
+{--------}
+procedure TffWinsockProtocol.StopReceiveDatagram;
+begin
+ if wspReceivingDatagram then begin
+ FFWSDestroySocket(wspRcvDatagramSocket);
+ wspRcvDatagramSocket := INVALID_SOCKET;
+ wspReceivingDatagram := false;
+ end;
+end;
+{--------}
+procedure TffWinsockProtocol.wspConnectCompleted(aSocket : TffwsSocket);
+begin
+ wspWaitingForConnect := false;
+end;
+{--------}
+function TffWinsockProtocol.cpCreateNotifyWindow : boolean;
+begin
+ {$IFDEF DCC6OrLater} {!!.11}
+ {$WARN SYMBOL_DEPRECATED OFF}
+ {$ENDIF}
+ {$ifdef fpc}
+ FNotifyWindow := LCLIntf.AllocateHWnd(wspWSAEventCompleted); //soner
+ {$else}
+ FNotifyWindow := AllocateHWnd(wspWSAEventCompleted);
+ {$endif}
+
+ {$IFDEF DCC6OrLater} {!!.11}
+ {$WARN SYMBOL_DEPRECATED ON}
+ {$ENDIF}
+ Result := FNotifyWindow <> 0;
+ if Result then begin
+{$IFDEF KALog}
+ KALog.WriteStringFmt('Winsock.cpCreateNotifyWindow: protocol %d',
+ [Longint(Self)]);
+{$ENDIF}
+ Windows.SetTimer(FNotifyWindow, 1, FKeepAliveInterval, nil); {!!.05}
+ end;
+end;
+{--------}
+function TffWinsockProtocol.wspGetConnForSocket(aSocket : TffwsSocket) : TffWinsockConnection;
+var
+ Inx : integer;
+ T : TffIntListItem;
+begin
+
+ ConnLock;
+ try
+ { If indexing connections then use the index to find the connection. }
+ if Assigned(cpIndexByOSConnector) then begin
+ T := TffIntListItem(cpIndexByOSConnector.Items[cpIndexByOSConnector.Index(aSocket)]);
+ if T = Nil then
+ Result := Nil
+ else
+ Result := T.ExtraData;
+ exit;
+ end;
+ for Inx := 0 to pred(cpConnList.Count) do begin
+ Result := TffWinsockConnection(cpConnList[Inx]);
+ if (Result.Socket = aSocket) then
+ Exit;
+ end;
+ finally
+ ConnUnlock;
+ end;
+ Result := nil;
+end;
+{--------}
+procedure TffWinsockProtocol.wspHangupDetected(aSocket : TffwsSocket);
+{Rewritten !!.06}
+var
+ Conn : TffWinsockConnection;
+begin
+ Conn := wspGetConnForSocket(aSocket);
+ if (Conn <> nil) then begin
+ Conn.HangingUp := False;
+ HangUp(Conn);
+ end;
+end;
+{--------}
+procedure TffWinsockProtocol.wspListenCompleted(aSocket : TffwsSocket);
+var
+ NewSocket : TffwsSocket;
+ SocketAddr : TffwsSockAddr;
+ AddrLen : integer;
+ Conn : TffWinsockConnection;
+ RemoteName : TffNetName;
+ WasAdded : boolean;
+begin
+ AddrLen := sizeof(SocketAddr);
+ NewSocket := WinsockRoutines.accept(aSocket, SocketAddr, AddrLen);
+ if (NewSocket <> INVALID_SOCKET) then begin
+ {a listen event has been accepted, create a connection}
+ WasAdded := false;
+ Conn := nil;
+ try
+ RemoteName := ''; {!!!!}
+ { When we first create this connection, we don't have a clientID so
+ we temporarily use the connection's handle. There is also a temporary
+ clientID on the client-side of things.
+ When the client is given a real clientID, the temporary clientIDs on
+ both client and server are replaced with the true clientID. }
+ Conn := TffWinsockConnection.Create(Self, RemoteName, NewSocket, Family,
+ FNotifyWindow);
+ Conn.ClientID := Conn.Handle;
+// Conn.InitCode(0); {Deleted !!.05}
+ cpAddConnection(Conn);
+ WasAdded := True; {!!.03}
+ Conn.StartReceive;
+ cpDoHeardCall(Conn.ClientID);
+ except
+ if WasAdded then
+ cpRemoveConnection(Conn.ClientID);
+ raise;
+ end;
+ end;
+end;
+{--------}
+procedure TffWinsockProtocol.wspProcessCompletedWSACall(WParam, LParam : longint);
+begin
+ {check the error code}
+ if (WSAGetSelectError(LParam) <> 0) then
+ begin
+ wspHangupDetected(TffwsSocket(WParam));
+ wspWaitingForSendToUnblock := false;
+ Exit;
+ end;
+ {check for event completion (note case is in numeric sequence)}
+ case WSAGetSelectEvent(LParam) of
+ FD_READ :
+ wspReceiveCompleted(TffwsSocket(WParam));
+ FD_WRITE :
+ wspSendMsgCompleted(TffwsSocket(WParam));
+ FD_OOB :
+ {do nothing};
+ FD_ACCEPT :
+ wspListenCompleted(TffwsSocket(WParam));
+ FD_CONNECT :
+ wspConnectCompleted(TffwsSocket(WParam));
+ FD_CLOSE :
+ wspHangupDetected(TffwsSocket(WParam));
+ end;{case}
+end;
+{--------}
+procedure TffWinsockProtocol.wspSendMsgCompleted(aSocket : TffwsSocket);
+var
+ SocketType : integer;
+ Conn : TffWinsockConnection;
+ dummy : longint;
+begin
+ wspWaitingForSendToUnblock := false;
+ SocketType := 0;
+ FFWSGetSocketOption(aSocket, SOL_SOCKET, SO_TYPE, SocketType,
+ sizeof(SocketType));
+ if (SocketType = SOCK_STREAM) then begin
+ Conn := wspGetConnForSocket(aSocket);
+ if Assigned(Conn) then begin
+ Conn.wscIsSending := False;
+ while (Not Conn.wscIsSending) and Assigned(Conn.wscPacketHead) do
+ {try to send all outstanding packets}
+ Conn.Send(nil, 0, 0, dummy, True); {!!.06}
+ end;
+ end;
+end;
+{--------}
+procedure TffWinsockProtocol.wspReceiveCompleted(aSocket : TffwsSocket);
+var
+ SocketType : integer;
+begin
+ SocketType := 0;
+ FFWSGetSocketOption(aSocket, SOL_SOCKET, SO_TYPE, SocketType, sizeof(SocketType));
+ if (SocketType = SOCK_STREAM) then
+ wspReceiveMsgCompleted(aSocket)
+ else if (SocketType = SOCK_DGRAM) then
+ wspReceiveDatagramCompleted(aSocket);
+end;
+{--------}
+procedure TffWinsockProtocol.wspReceiveDatagramCompleted(aSocket : TffwsSocket);
+var
+ RemNetName : TffNetName;
+ BytesAvail : longint;
+ BytesRead : integer;
+ Error : integer;
+ SockAddrLen: integer;
+ SockAddr : TffwsSockAddr;
+begin
+ Error := WinsockRoutines.ioctlsocket(aSocket, FIONREAD, BytesAvail);
+ if (Error <> SOCKET_ERROR) and (BytesAvail > 0) then begin
+ FillChar(SockAddr, sizeof(SockAddr), 0);
+ if (Family = wfTCP) then begin
+ SockAddrLen := sizeof(TffwsSockAddrIn);
+ end
+ else {Family <> wfTCP} begin
+ SockAddrLen := sizeof(TffwsSockAddrIPX);
+ end;
+ BytesRead := WinsockRoutines.recvfrom(aSocket,
+ wspRcvDGBuffer^,
+ ffc_MaxDatagramSize,
+ 0,
+ SockAddr,
+ SockAddrLen);
+ if (BytesRead <> SOCKET_ERROR) then begin
+ {get our user to process the data}
+ if (Family = wfTCP) then begin
+ RemNetName := FFWSCvtAddrToStr(SockAddr.TCP.sin_addr);
+ end
+ else {Family <> wfTCP} begin
+ with SockAddr.IPX do
+ RemNetName :=
+ FFWSCvtIPXAddrToStr(sipx_netnum, sipx_nodenum);
+ end;
+ cpDoReceiveDatagram(RemNetName, wspRcvDGBuffer, BytesRead);
+ end;
+ end;
+end;
+{--------}
+procedure TffWinsockProtocol.wspReceiveMsgCompleted(aSocket : TffwsSocket);
+var
+ BytesAvail : longint;
+ BytesRead : integer;
+ Conn : TffWinsockConnection;
+ Error : integer;
+ MsgLen : integer;
+ Parsing : boolean;
+begin
+ Error := WinsockRoutines.ioctlsocket(aSocket, FIONREAD, BytesAvail);
+ if (Error <> SOCKET_ERROR) and (BytesAvail > 0) then begin
+ Conn := wspGetConnForSocket(aSocket);
+ if assigned(Conn) then
+ with Conn do begin
+ {read everything we can}
+ BytesRead := WinsockRoutines.recv(aSocket,
+ RcvBuffer^[RcvBufferOffset],
+ ffc_MaxWinsockMsgSize - RcvBufferOffset,
+ 0);
+ if (BytesRead <> SOCKET_ERROR) then begin
+ {calculate the number of valid bytes in our receive buffer}
+ RcvBufferOffset := RcvBufferOffset + BytesRead;
+ Parsing := true;
+ while Parsing do begin
+ Parsing := false;
+ {discard check connection (keepalive) messages now, we may
+ have real messages piggybacking one}
+ while (RcvBufferOffset >= sizeof(longint)) and
+ (PLongint(RcvBuffer)^ = ffnmCheckConnection) do begin
+ {move the remainder of the received data up by 4 bytes}
+ RcvBufferOffset := RcvBufferOffset - sizeof(longint);
+ if (RcvBufferOffset > 0) then
+ Move(RcvBuffer^[sizeof(longint)], RcvBuffer^[0], RcvBufferOffset);
+ cpGotCheckConnection(Conn);
+ Parsing := true;
+ end; { while }
+ {if we have something left..., and enough of it...}
+ if (RcvBufferOffset >= ffc_NetMsgHeaderSize) then begin
+ MsgLen := PffnmHeader(RcvBuffer)^.nmhMsgLen;
+ if (RcvBufferOffset >= MsgLen) then begin
+ {get our ancestor to process the data}
+ if cpDoReceiveMsg(Conn, RcvBuffer, MsgLen) then begin
+ {remove the message}
+ RcvBufferOffset := RcvBufferOffset - MsgLen;
+ if (RcvBufferOffset > 0) then
+ Move(RcvBuffer^[MsgLen], RcvBuffer^[0], RcvBufferOffset);
+ Parsing := true;
+ end;
+ end;
+ end; { if }
+ end; { while }
+ end; { if }
+ end { with }
+ else
+ LogStrFmt('Could not find connection for socket %d', [aSocket]);
+ end; { if }
+end;
+{--------}
+procedure TffWinsockProtocol.wspWaitForConnect(aTimeOut : integer);
+var
+ T : TffTimer;
+begin
+ SetTimer(T, aTimeOut);
+ while wspWaitingForConnect and (not HasTimerExpired(T)) do begin
+ Breathe;
+ end;
+end;
+{--------}
+function TffWinsockProtocol.wspWaitForSendToUnblock : Boolean;
+{ Rewritten !!.06}
+var
+ UnblockTimer : TffTimer;
+begin
+ wspWaitingForSendToUnblock := true;
+ SetTimer(UnblockTimer, ffc_UnblockWait);
+ repeat
+ Breathe;
+ Result := HasTimerExpired(UnblockTimer);
+ until (not wspWaitingForSendToUnblock) or Result;
+end;
+{--------}
+procedure TffWinsockProtocol.wspWSAEventCompleted(var WSMsg : TMessage);
+begin
+ with WSMsg do begin
+ if (Msg = ffwscEventComplete) then begin
+ wspProcessCompletedWSACall(WParam, LParam);
+ Result := 0;
+ end
+ else if (Msg = WM_TIMER) then begin
+ cpTimerTick;
+ end
+ else
+ Result := DefWindowProc(FNotifyWindow, Msg, WParam, LParam);
+ end;
+end;
+{====================================================================}
+
+
+{===TffTCPIPProtocol=================================================}
+constructor TffTCPIPProtocol.Create(const aName : TffNetAddress;
+ aCSType : TffClientServerType);
+begin
+ inherited Create(aName, aCSType);
+ Family := wfTCP;
+end;
+{--------}
+class function TffTCPIPProtocol.GetProtocolName : string;
+begin
+ Result := 'TCP/IP (FF)';
+end;
+{--------}
+class function TffTCPIPProtocol.Supported : boolean;
+begin
+ if FFWSInstalled then
+ Result := wfTCP in ffwsFamiliesInstalled
+ else
+ Result := False;
+end;
+{====================================================================}
+
+
+{===TffIPXSPXProtocol================================================}
+constructor TffIPXSPXProtocol.Create(const aName : TffNetAddress;
+ aCSType : TffClientServerType);
+begin
+ inherited Create(aName, aCSType);
+ Family := wfIPX;
+end;
+{--------}
+class function TffIPXSPXProtocol.GetProtocolName : string;
+begin
+ Result := 'IPX/SPX (FF)';
+end;
+{--------}
+class function TffIPXSPXProtocol.Supported : boolean;
+begin
+ if FFWSInstalled then
+ Result := wfIPX in ffwsFamiliesInstalled
+ else
+ Result := False;
+end;
+{====================================================================}
+
+
+{===Helper routines for single user==================================}
+type
+ PffSUEnumData = ^TffSUEnumData;
+ TffSUEnumData = packed record
+ MsgID : integer;
+ OurWnd : HWND;
+ SrvWnd : HWND;
+ end;
+{====================================================================}
+
+
+{===TffSingleUserConnection==========================================}
+constructor TffSingleUserConnection.Create(aOwner : TffBaseCommsProtocol;
+ aRemoteName : TffNetAddress;
+ aUs : HWND;
+ aPartner : HWND);
+begin
+ inherited Create(aOwner, aRemoteName);
+ FUs := aUs;
+ FPartner := aPartner;
+ GetMem(sucSendBuffer, ffc_MaxSingleUserMsgSize);
+end;
+{--------}
+destructor TffSingleUserConnection.Destroy;
+var
+ CDS : TCopyDataStruct;
+ MsgResult : DWORD;
+ WinError : TffWord32; {!!.12}
+begin
+ { If we are deliberately hanging up then send a message to our partner. }
+ if FHangingUp then begin
+ if IsWindow(Partner) then begin
+ CDS.dwData := ffsumHangUp;
+ CDS.cbData := 0;
+ CDS.lpData := nil;
+{Begin !!.12}
+ if not LongBool(SendMessageTimeout(FPartner, WM_COPYDATA, FClientID,
+ longint(@CDS),
+{$IFDEF RunningUnitTests}
+ SMTO_ABORTIFHUNG,
+{$ELSE}
+ SMTO_ABORTIFHUNG or SMTO_BLOCK,
+{$ENDIF}
+ ffc_SendMessageTimeout, MsgResult)) or
+ (MsgResult <> 0) then begin
+ Sleep(ffc_SUPErrorTimeout);
+ { Experimentation shows the following:
+ 1. The first SendMessageTimeout will return False but
+ GetLastError returns zero.
+ 2. Leaving out the Sleep() leads to a failure in the following
+ call to SendMessageTimeout. Note that error code is still
+ set to zero in that case.
+ 3. Inserting a Sleep(1) resolves one timeout scenario (loading
+ JPEGs from table). However, it does not resolve the issue
+ where Keep Alive Interval >= 20000 and scrolling through
+ large table in FFE.
+ 4. Inserting a Sleep(25) resolves the latter case mentioned in
+ Item 3. }
+ if not LongBool(SendMessageTimeout(FPartner, WM_COPYDATA, FClientID,
+ longint(@CDS),
+{$IFDEF RunningUnitTests}
+ SMTO_ABORTIFHUNG,
+{$ELSE}
+ SMTO_ABORTIFHUNG or SMTO_BLOCK,
+{$ENDIF}
+ ffc_SendMessageTimeout, MsgResult)) then begin
+ WinError := GetLastError;
+ FOwner.LogStrFmt('Error %d sending message via SUP connection: %s',
+ [WinError, SysErrorMessage(WinError)]);
+ end;
+ end;
+{End !!.12}
+ end;
+ end;
+ FreeMem(sucSendBuffer, ffc_MaxSingleUserMsgSize);
+ inherited Destroy;
+end;
+{--------}
+Procedure TffSingleUserConnection.AddToList(List : TFFList);
+var
+ T : TffIntListItem;
+ {$IFNDEF WIN32}
+ tmpLongInt : longInt;
+ {$ENDIF}
+begin {add a list entry to allow partner hwnd lookups}
+ {$IFDEF WIN32}
+ T := TffIntListItem.Create(FPartner);
+ {$ELSE}
+ { The 16-bit HWND is a Word. Cast it to a longInt so that
+ our TffIntList comparison will work. }
+ tmpLongInt := FPartner;
+ T := TffIntListItem.Create(tmpLongInt);
+ {$ENDIF}
+ T.ExtraData := Self;
+ List.Insert(T);
+end;
+{--------}
+class function TffSingleUserProtocol.GetProtocolName : string;
+begin
+ Result := 'Single User (FF)';
+end;
+{--------}
+Procedure TffSingleUserConnection.RemoveFromList(List : TFFList);
+begin
+ List.Delete(FPartner);
+end;
+{--------}
+procedure TffSingleUserConnection.Send(aData : PffByteArray;
+ aDataLen : longint;
+ aConnLock : Boolean); {!!.06}
+var
+ CDS : TCopyDataStruct;
+ MsgResult : DWORD;
+ WinError : TffWord32; {!!.05}
+begin
+ if IsWindow(Partner) then begin
+ if aConnLock then {!!.06}
+ HangupLock; {!!.05}
+ try {!!.05}
+ if (aDataLen <> 0) then begin
+ Move(aData^, sucSendBuffer^, aDataLen);
+ Owner.cpCodeMessage(Self, sucSendBuffer, aDataLen);
+ CDS.lpData := sucSendBuffer;
+ CDS.cbData := aDataLen;
+ end
+ else begin
+ CDS.lpData := nil;
+ CDS.cbData := 0;
+ end;
+ CDS.dwData := ffsumDataMsg;
+{Begin !!.05}
+ if not LongBool(SendMessageTimeout(FPartner, WM_COPYDATA, FClientID,
+ longint(@CDS),
+{$IFDEF RunningUnitTests}
+ SMTO_ABORTIFHUNG,
+{$ELSE}
+ SMTO_ABORTIFHUNG or SMTO_BLOCK,
+{$ENDIF}
+ ffc_SendMessageTimeout, MsgResult)) or
+ (MsgResult <> 0) then begin
+{Begin !!.06}
+ Sleep(ffc_SUPErrorTimeout);
+ { Experimentation shows the following:
+ 1. The first SendMessageTimeout will return False but
+ GetLastError returns zero.
+ 2. Leaving out the Sleep() leads to a failure in the following
+ call to SendMessageTimeout. Note that error code is still
+ set to zero in that case.
+ 3. Inserting a Sleep(1) resolves one timeout scenario (loading
+ JPEGs from table). However, it does not resolve the issue
+ where Keep Alive Interval >= 20000 and scrolling through
+ large table in FFE.
+ 4. Inserting a Sleep(25) resolves the latter case mentioned in
+ Item 3. }
+{End !!.06}
+ if not LongBool(SendMessageTimeout(FPartner, WM_COPYDATA, FClientID,
+ longint(@CDS),
+{$IFDEF RunningUnitTests}
+ SMTO_ABORTIFHUNG,
+{$ELSE}
+ SMTO_ABORTIFHUNG or SMTO_BLOCK,
+{$ENDIF}
+ ffc_SendMessageTimeout, MsgResult)) then begin
+ WinError := GetLastError;
+ FOwner.LogStrFmt('Error %d sending message via SUP connection: %s',
+ [WinError, SysErrorMessage(WinError)]);
+ end;
+{End !!.05}
+ end;
+ finally {!!.05}
+ if aConnLock then {!!.06}
+ HangupUnlock; {!!.05}
+ end; {!!.05}
+ end;
+end;
+{====================================================================}
+
+
+{===TffSingleUserProtocol============================================}
+constructor TffSingleUserProtocol.Create(const aName : TffNetAddress;
+ aCSType : TffClientServerType);
+begin
+ inherited Create(aName, aCSType);
+ FMaxNetMsgSize := ffc_MaxSingleUserMsgSize;
+ { Create a new Windows message. }
+ supMsgID := RegisterWindowMessage('FlashFiler2SingleUser');
+ supPostMsgID := RegisterWindowMessage('FlashFiler2SingleUserPostMessage');
+end;
+{--------}
+function TffSingleUserProtocol.Call(const aServerName : TffNetName;
+ var aClientID : TffClientID;
+ const timeout : longInt) : TffResult;
+var
+ Conn : TffSingleUserConnection;
+ SUED : TffSUEnumData;
+begin
+
+ Result := DBIERR_NONE;
+
+ {servers don't call}
+ if (CSType = csServer) then
+ raise EffCommsException.CreateNoData(ffStrResGeneral, fferrCommsCannotCall);
+ {assume failure}
+
+ {enumerate the top-level windows, looking for a server}
+ SUED.MsgID := supMsgID;
+ SUED.OurWnd := FNotifyWindow;
+ SUED.SrvWnd := 0;
+
+ { Create a connection object with the assumption we find a server. }
+ Conn := TffSingleUserConnection.Create(Self, '', FNotifyWindow, SUED.SrvWnd);
+ Conn.ClientID := Conn.Handle;
+
+ SUED.SrvWnd := supFindPartner(Conn.ClientID, timeout);
+
+ {did we find one?}
+ if (SUED.SrvWnd <> 0) then begin
+ Conn.Partner := SUED.SrvWnd;
+ cpAddConnection(Conn);
+ aClientID := Conn.ClientID;
+ end else begin
+ Conn.Free;
+ Result := DBIERR_SERVERNOTFOUND;
+ end;
+end;
+{--------}
+procedure TffSingleUserProtocol.cpPerformStartUp;
+begin
+ {create our Window}
+ if not cpCreateNotifyWindow then begin
+ LogStr('Could not create notification window.');
+ raise EffCommsException.CreateNoData(ffStrResGeneral, fferrCommsNoWinRes);
+ end;
+end;
+{--------}
+procedure TffSingleUserProtocol.GetServerNames(aList : TStrings; const timeout : longInt);
+begin
+ if not assigned(aList) then
+ exit;
+
+ aList.Clear;
+ aList.Add(ffc_SingleUserServerName);
+end;
+{--------}
+procedure TffSingleUserProtocol.HangUp(aConn : TffConnection);
+begin
+ cpDoHangUp(aConn);
+ cpRemoveConnection(aConn.ClientID);
+end;
+{--------}
+procedure TffSingleUserProtocol.Listen;
+begin
+end;
+{--------}
+procedure TffSingleUserProtocol.ReceiveDatagram;
+begin
+ if not supReceivingDatagram then
+ supReceivingDatagram := true;
+end;
+{--------}
+procedure TffSingleUserProtocol.SendDatagram(const aName : TffNetName;
+ aData : PffByteArray;
+ aDataLen : longint);
+begin
+end;
+{--------}
+function TffSingleUserProtocol.SendMsg(aClientID : TffClientID;
+ aData : PffByteArray;
+ aDataLen : longint;
+ aConnLock : Boolean) : TffResult; {!!.06}
+var
+ Conn : TffSingleUserConnection;
+begin
+ Result := DBIERR_NONE;
+ Conn := TffSingleUserConnection(cpGetConnection(aClientID));
+ if Assigned(Conn) then
+ Conn.Send(aData, aDataLen, aConnLock) {!!.06}
+ else
+ Result := fferrConnectionLost;
+end;
+{--------}
+procedure TffSingleUserProtocol.StopReceiveDatagram;
+begin
+ if supReceivingDatagram then
+ supReceivingDatagram := false;
+end;
+{--------}
+function TffSingleUserProtocol.cpCreateNotifyWindow : boolean;
+begin
+ {$IFDEF DCC6OrLater} {!!.11}
+ {$WARN SYMBOL_DEPRECATED OFF}
+ {$ENDIF}
+ {$ifdef fpc}
+ FNotifyWindow := LCLIntf.AllocateHWnd(supMsgReceived); //soner
+ {$else}
+ FNotifyWindow := AllocateHWnd(supMsgReceived);
+ {$endif}
+ {$IFDEF DCC6OrLater} {!!.11}
+ {$WARN SYMBOL_DEPRECATED ON}
+ {$ENDIF}
+ Result := FNotifyWindow <> 0;
+ if Result then begin
+{$IFDEF KALog}
+ KALog.WriteStringFmt('SingleUser.cpCreateNotifyWindow: protocol %d',
+ [Longint(Self)]);
+{$ENDIF}
+ Windows.SetTimer(FNotifyWindow, 1, FKeepAliveInterval, nil); {!!.05}
+ end;
+end;
+{--------}
+procedure TffSingleUserProtocol.supDataMsgReceived(const aClientID : TffClientID;
+ const aCDS : TCopyDataStruct);
+var
+ Conn : TffSingleUserConnection;
+begin
+
+ Conn := TffSingleUserConnection(cpGetConnection(aClientID));
+ {get our user to process the data}
+ if assigned(Conn) then
+ cpDoReceiveMsg(Conn, aCDS.lpData, aCDS.cbData)
+ else
+ LogStrFmt('Could not find connection for client %d', [aClientID]);
+end;
+{--------}
+function TffSingleUserProtocol.supGetConnForPartner(aPartner : HWND) : TffSingleUserConnection;
+var
+ Inx : integer;
+ T : TffIntListItem;
+begin
+ { If we are indexing connections then use the index to locate
+ the connection. }
+ if Assigned(cpIndexByOSConnector) then begin
+ T := TffIntListItem(cpIndexByOSConnector.Items[cpIndexByOSConnector.Index(aPartner)]);
+ if T = Nil then
+ Result := Nil
+ else
+ Result := T.ExtraData;
+ exit;
+ end;
+ for Inx := 0 to pred(cpConnList.Count) do begin
+ Result := TffSingleUserConnection(cpConnList[Inx]);
+ if (Result.Partner = aPartner) then
+ Exit;
+ end;
+ Result := nil;
+end;
+{--------}
+procedure TffSingleUserProtocol.supHangupDetected(const aClientID : TffClientID);
+{Rewritten !!.06}
+var
+ Conn : TffSingleUserConnection;
+begin
+ Conn := TffsingleUserConnection(cpGetConnection(aClientID));
+ if Conn <> nil then begin
+ Conn.HangingUp := False;
+ HangUp(Conn);
+ end;
+end;
+{--------}
+procedure TffSingleUserProtocol.supListenCompleted(aClientID : TffClientID;
+ Wnd : HWND);
+var
+ Conn : TffSingleUserConnection;
+ WasAdded : boolean;
+begin
+ {a listen event has been accepted, create a connection}
+ WasAdded := false;
+ Conn := nil;
+ try
+ { When we first create this connection, we don't have a clientID so
+ we temporarily use the connection's handle. There is also a temporary
+ clientID on the client-side of things.
+ When the client is given a real clientID, the temporary clientIDs on
+ both client and server are replaced with the true clientID. }
+ Conn := TffSingleUserConnection.Create(Self, '', FNotifyWindow, Wnd);
+ Conn.ClientID := aClientID;
+// Conn.InitCode(0); {Deleted !!.05}
+ cpAddConnection(Conn);
+ WasAdded := True;
+ cpDoHeardCall(Conn.ClientID);
+ except
+ if WasAdded then
+ cpRemoveConnection(Conn.ClientID);
+ raise;
+ end;{try..except}
+end;
+{--------}
+procedure TffSingleUserProtocol.supMsgReceived(var SUMsg : TMessage);
+begin
+ with SUMsg do begin
+ if (Msg = supMsgID) then begin
+ if (CSType = csServer) then begin
+ Result := ffsumCallServer {'FF'};
+ supListenCompleted(WParam, LParam);
+ end
+ else
+ Result := 0;
+ end
+ else if Msg = supPostMsgID then begin
+ if CSType = csServer then begin
+ { Client is trying to initiate conversation with us. Send back
+ a reply. }
+ if LParam = ffsumCallServer {'FF'} then begin
+ if IsWindow(WParam) then
+ PostMessage(WParam, ffm_ServerReply, FNotifyWindow, ffsumCallServer);
+ end;
+ end;
+ end
+ else if Msg = ffm_ServerReply then begin
+ if supPartner = 0 then begin
+ if CSType = csClient then begin
+ if LParam = ffsumCallServer {'FF'} then begin
+ if IsWindow(WParam) then
+ supPartner := WParam;
+ end;
+ end;
+ end;
+ end
+ else if (Msg = WM_COPYDATA) then begin
+ case PCopyDataStruct(LParam)^.dwData of
+ ffsumDataMsg : supDataMsgReceived(WParam, PCopyDataStruct(LParam)^);
+ ffsumHangUp : supHangUpDetected(WParam);
+ end;
+ end
+ else if (Msg = WM_TIMER) then
+ cpTimerTick
+ else
+ Result := DefWindowProc(FNotifyWindow, Msg, WParam, LParam);
+ end;
+end;
+{--------}
+function TffSingleUserProtocol.supFindPartner(const aClientID : TffClientID;
+ const timeout : longInt): HWND;
+
+var
+ WaitUntil : Tffword32;
+ MsgResult : DWORD;
+ Msg : TMsg;
+ StartTime : DWORD; {!!.05}
+ WinError : TffWord32; {!!.05}
+begin
+ supPartner:=0;
+ PostMessage(HWND_BROADCAST, supPostMsgID, FNotifyWindow, ffsumCallServer);
+ WaitUntil := GetTickCount + DWORD(timeout);
+ StartTime := GetTickCount; {!!.05}
+ while (GetTickCount < WaitUntil) and (supPartner=0) do begin
+ if PeekMessage(Msg, FNotifyWindow, ffm_ServerReply,
+ ffm_ServerReply, PM_REMOVE) then begin
+ TranslateMessage(Msg);
+ DispatchMessage(Msg);
+{Begin !!.05}
+ end
+ else if GetTickCount - StartTime > ffc_ConnectRetryTimeout then begin
+ PostMessage(HWND_BROADCAST, supPostMsgID, FNotifyWindow, ffsumCallServer);
+ StartTime := GetTickCount;
+ end;
+{End !!.05}
+ if supPartner = 0 then
+ Breathe;
+ end;
+ Result := supPartner;
+ if Result <> 0 then begin
+ if LongBool(SendMessageTimeout(Result, supMsgID, aClientID, FNotifyWindow,
+ SMTO_ABORTIFHUNG or SMTO_BLOCK,
+ timeout, MsgResult)) then begin
+ if MsgResult <> ffsumCallServer{FF} then begin
+{Begin !!.05}
+ if LongBool(SendMessageTimeout(Result, supMsgID, aClientID, FNotifyWindow,
+ SMTO_ABORTIFHUNG or SMTO_BLOCK,
+ timeout, MsgResult)) then
+ if MsgResult <> ffsumCallServer{FF} then begin
+ WinError := GetLastError;
+ LogStrFmt('Error %d when finding SUP partner: %s',
+ [WinError, SysErrorMessage(WinError)]);
+ Result :=0;
+ end; { if }
+ end; { if }
+{End !!.05}
+ end
+ else
+ Result := 0;
+ end;
+end;
+{====================================================================}
+
+{$IFDEF KALog}
+initialization
+ KALog := TffEventLog.Create(nil);
+ KALog.FileName := ChangeFileExt(ParamStr(0), '') + 'KA.log';
+ KALog.Enabled := True;
+
+finalization
+ KALog.Free;
+{$ENDIF}
+
+end.
+
diff --git a/components/flashfiler/sourcelaz/ffllreq.pas b/components/flashfiler/sourcelaz/ffllreq.pas
new file mode 100644
index 000000000..9f799d26b
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffllreq.pas
@@ -0,0 +1,355 @@
+{*********************************************************}
+{* FlashFiler: TffRequest *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffllreq;
+
+interface
+
+uses
+ ffllbase,
+ fflllog;
+
+type
+
+ { This enumerated type tells a transport whether or not a reply is expected
+ for a request. Values:
+
+ ffrmReplyExpected - The requesting thread will be locked until the request
+ has been sent and a reply to the request has been received.
+
+ ffrmNoReplyExpected - The requesting thread does not expect a reply to the
+ request. The requesting thread will continue processing as
+ soon as the request has been submitted to the sending thread.
+
+ ffrmNoReplyWaitUntilSent - The requesting thread does not expect a reply.
+ The requesting thread will continue processing as soon as the request
+ has been sent to the remote server. }
+ TffReplyModeType = (ffrmReplyExpected, ffrmNoReplyExpected,
+ ffrmNoReplyWaitUntilSent);
+
+ { This class is used by TffThreadedTransport to manage requests sent to the
+ server. A request instance is placed in the transport's pending queue.
+ The transport's send thread retrieves the request from the queue.
+ If a reply is expected, the send thread puts the request "on hold" until a
+ reply is received. The reply is stored on the request via the SetReply
+ method and the request is awakened.
+
+ Note: An instance of this class stores the reply data received from the
+ server. When the instance is destroyed, it is responsible for freeing the
+ reply data.
+ }
+ TffRequest = class(TffObject)
+ private
+
+ FAborted : boolean;
+ { Flag set when an exception occurs during Self.WaitForReply. This is
+ typically raised due to a timeout. }
+
+ FBytesToGo : longInt;
+ { The number of bytes in the request data remaining to be sent.
+ If a request must be sent across multiple packets, this value is
+ incremented for each send. }
+
+ FClientID : TffClientID;
+ { The client submitting the request. }
+
+ FErrorCode : TffResult;
+ { The error code returned from the server. }
+
+ FEvent : TffEvent;
+ { Used to wait for a reply. }
+
+ FEventLog : TffBaseLog;
+ { For debugging: The event log to which events are written. }
+
+ FMsgID : longInt;
+ { The type of message being sent. }
+
+ FPadlock : TffPadlock;
+ { Can be used to control read/write access to the request. }
+
+ FReplyData : pointer;
+ { The reply data returned from the server. This is sized to hold
+ the entire reply, which may come across in several messages. }
+
+ FReplyDataLen : longInt;
+ { The total length of the reply data. }
+
+ FReplyMode : TffReplyModeType;
+ { Indicates whether or not the requesting thread expects a reply. }
+
+ FReplyMsgID : longInt;
+ { The message ID returned in the reply. Important because the
+ reply may be a multipart message. }
+
+ FReplyOffset : longInt;
+ {-In situations where multiple packets are received, this variable
+ is used to determine the offset into the FReplyData buffer in which
+ the next portion of data should be moved. }
+
+ FRequestData : pointer;
+ { The data being sent from client to server. }
+
+ FRequestDataLen : longInt;
+ { The length of the data being sent. }
+
+ FStartOffset : longInt;
+ { The position in the request data from which the next send will occur.
+ This variable is used only when a request must be sent across
+ multiple packets. }
+
+ FTimeout : longInt;
+ { The number of seconds in which the operation must complete. }
+
+ protected
+
+ procedure rqWriteString(const aMsg : string);
+ {-Use this method to write a string to the event log. }
+
+ public
+
+ constructor Create(clientID : TffClientID;
+ msgID : longint;
+ requestData : pointer;
+ requestDataLen : LongInt;
+ timeout : longInt;
+ const replyMode : TffReplyModeType); virtual;
+ { Creates a new request. }
+
+ destructor Destroy; override;
+
+ procedure AddToReply(replyData : pointer;
+ replyDataLen : longInt); virtual;
+ { If a reply is so big as to occupy multiple packets, the first
+ packet is moved to the reply using the SetReply method. Data from
+ subsequent packets is added to the reply using this method. }
+
+ procedure Lock;
+ { Use this method to have a thread obtain exclusive access to the
+ request. }
+
+ procedure SetReply(replyMsgID : longInt;
+ errorCode : TffResult;
+ replyData : pointer;
+ totalReplyLen : longInt;
+ replyDataLen : longInt); virtual;
+ { Used by the transport to set the reply data. The TffRequest takes
+ ownership of the memory or stream passed in replyData and will free
+ it when TffRequest.Destroy is executed (or if recycling of TffRequest
+ is implemented in the future. }
+
+ procedure Unlock;
+ { Use this method to have a thread release exclusive access to the
+ request. }
+
+ procedure WakeUpThread; virtual;
+ { This method is called by the transport when a reply has been received
+ from the server. Prior to calling this method, the reply will have
+ been placed on the client's message queue via the reply callback. }
+
+ procedure WaitForReply(const timeout : TffWord32); virtual;
+ { This method is called by the transport when it has placed a request
+ on its Unsent Request Queue. This method notifies the sender thread
+ that a request is ready. The calling thread is blocked in this
+ method until WakeUpThread is called.
+
+ Raises an exception if a timeout occurs or a failure occurs when the
+ wait is attempted.
+ }
+
+ property Aborted : boolean read FAborted;
+ { If set to True then Self.WaitForReply encountered an exception
+ (e.g., timeout). }
+
+ property BytesToGo : longInt read FBytesToGo write FBytesToGo;
+ { The number of bytes of request data remaining to be sent. }
+
+ property ClientID : TffClientID read FClientID;
+ { The client submitting the request. }
+
+ property ErrorCode : TffResult read FErrorCode write FErrorCode;
+ { The error code returned from the server. }
+
+ property EventLog : TffBaseLog read FEventLog write FEventLog;
+ { The event log to which debugging messages should be written. }
+
+ property MsgID : longInt read FMsgID;
+ { The type of message being sent. }
+
+ property ReplyData : pointer read FReplyData write FReplyData;
+ { The reply received from the server. Will be nil if a timeout or
+ some other failure occurs. }
+
+ property ReplyDataLen : longInt read FReplyDataLen write FReplyDataLen;
+ { The length of the reply. }
+
+ property ReplyMode : TffReplyModeType read FReplyMode;
+ { Indicates whether or not a reply is expected for this request. }
+
+ property ReplyMsgID : longInt read FReplyMsgID write FReplyMsgID;
+ { The message ID returned in the reply. Important because it
+ may be a multipart message. }
+
+ property RequestData : pointer read FRequestData;
+ { The buffer containing the data to be sent. }
+
+ property RequestDataLen : longInt read FRequestDataLen;
+ { The length of the request data. }
+
+ property StartOffset : longInt read FStartOffset write FStartOffset;
+ { The position within request data from which the next send is to
+ draw data. Used when the request is to be sent across multiple
+ packets. }
+
+ property Timeout : longInt read FTimeout;
+ { The number of seconds in which the operation must complete. }
+
+ end;
+
+implementation
+
+uses
+ SysUtils,
+ ffconst,
+ ffllexcp;
+
+{===TffBaseTransport=================================================}
+constructor TffRequest.Create(clientID : TffClientID;
+ msgID : longint;
+ requestData : pointer;
+ requestDataLen : LongInt;
+ timeout : longInt;
+ const replyMode : TffReplyModeType);
+begin
+ inherited Create;
+ FAborted := False;
+ FBytesToGo := requestDataLen;
+ FClientID := clientID;
+ FErrorCode := 0;
+ FEvent := TffEvent.Create;
+ FMsgID := msgID;
+ FPadlock := TffPadlock.Create;
+ FReplyData := nil;
+ FReplyDataLen := -1;
+ FReplyMode := replyMode;
+ FReplyMsgID := -1;
+ { Copy the request data. }
+ FRequestDataLen := requestDataLen;
+ if FRequestDataLen > 0 then begin
+ FFGetMem(FRequestData, FRequestDataLen);
+ Move(requestData^, FRequestData^, FRequestDataLen);
+ end else
+ FRequestData := nil;
+ FStartOffset := 0;
+ FTimeout := timeout;
+end;
+{--------}
+destructor TffRequest.Destroy;
+begin
+
+ { Make sure we can get exclusive access to this object. }
+ FPadlock.Lock;
+
+ FEvent.Free;
+ FPadlock.Free;
+ { We are responsible for the request and reply data. Free it.
+ Note: Assumes it was created using FFGetMem. }
+ if assigned(FRequestData) then
+ FFFreeMem(FRequestData, FRequestDataLen);
+ if assigned(FReplyData) then
+ FFFreeMem(FReplyData, FReplyDataLen);
+ inherited Destroy;
+end;
+{--------}
+procedure TffRequest.AddToReply(replyData : pointer;
+ replyDataLen : longInt);
+var
+ BytesToCopy : longInt;
+begin
+ { Move this chunk of data into the reply buffer. }
+ BytesToCopy := FFMinL(replyDataLen, FReplyDataLen - FReplyOffset);
+ Move(replyData^, PffBLOBArray(FReplyData)^[FReplyOffset], BytesToCopy);
+ inc(FReplyOffset, BytesToCopy);
+end;
+{--------}
+procedure TffRequest.Lock;
+begin
+ FPadlock.Lock;
+end;
+{--------}
+procedure TffRequest.rqWriteString(const aMsg : string);
+begin
+ if assigned(FEventLog) then
+ FEventLog.WriteString(aMsg);
+end;
+{--------}
+procedure TffRequest.SetReply(replyMsgID : longInt;
+ errorCode : TffResult;
+ replyData : pointer;
+ totalReplyLen : longInt;
+ replyDataLen : longInt);
+begin
+ FReplyMsgID := replyMsgID;
+ FErrorCode := errorCode;
+ FReplyDataLen := totalReplyLen;
+ { Obtain space to store the entire reply. }
+ FFGetMem(FReplyData, totalReplyLen);
+ { Move in the portion of the reply just received. }
+ Move(replyData^, FReplyData^, replyDataLen);
+ FReplyOffset := replyDataLen;
+end;
+{--------}
+procedure TffRequest.Unlock;
+begin
+ FPadlock.Unlock;
+end;
+{--------}
+procedure TffRequest.WakeUpThread;
+begin
+ FEvent.SignalEvent;
+end;
+{--------}
+procedure TffRequest.WaitForReply(const timeout : TffWord32);
+begin
+ try
+ FEvent.WaitFor(timeout);
+ except
+ on E:Exception do begin
+ if E is EffException then
+ ErrorCode := EffException(E).ErrorCode;
+ FReplyMsgID := FMsgID;
+ FAborted := True;
+ end;
+ end;
+end;
+{====================================================================}
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffllscst.inc b/components/flashfiler/sourcelaz/ffllscst.inc
new file mode 100644
index 000000000..fe37b7b39
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffllscst.inc
@@ -0,0 +1,46 @@
+{*********************************************************}
+{* FlashFiler: Server component error codes *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{Note: Actual string values are found in the resource scripts
+ FFLLSCST.STR - Server component error strings}
+
+{String constants}
+const
+ ffsce_NoErrorCode = $500;
+ ffsce_HasErrorCode = $501;
+ ffsce_NilPointer = $502;
+ ffsce_UnnamedInst = $503;
+ ffsce_InstNoCode = $504;
+ ffsce_MustBeInactive = $505;
+ ffsce_MustBeStarted = $506;
+ ffsce_MustBeListener = $507;
+ ffsce_MustBeSender = $508;
+ ffsce_MustHaveServerName = $509;
+ ffsce_ParameterRequired = $50A;
+
diff --git a/components/flashfiler/sourcelaz/ffllscst.rc b/components/flashfiler/sourcelaz/ffllscst.rc
new file mode 100644
index 000000000..d34281cc3
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffllscst.rc
@@ -0,0 +1,30 @@
+/*********************************************************
+ * FlashFiler: Server component error strings *
+ *********************************************************/
+
+/* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** */
+
+FF_SERVER_CMP_STRINGS RCDATA FFLLSCST.SRM
diff --git a/components/flashfiler/sourcelaz/ffllscst.res b/components/flashfiler/sourcelaz/ffllscst.res
new file mode 100644
index 000000000..7079baafd
Binary files /dev/null and b/components/flashfiler/sourcelaz/ffllscst.res differ
diff --git a/components/flashfiler/sourcelaz/ffllscst.srm b/components/flashfiler/sourcelaz/ffllscst.srm
new file mode 100644
index 000000000..60a098be7
Binary files /dev/null and b/components/flashfiler/sourcelaz/ffllscst.srm differ
diff --git a/components/flashfiler/sourcelaz/ffllscst.str b/components/flashfiler/sourcelaz/ffllscst.str
new file mode 100644
index 000000000..5473581ac
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffllscst.str
@@ -0,0 +1,42 @@
+;*********************************************************
+;* FlashFiler: Server component error strings *
+;*********************************************************
+
+;* ***** BEGIN LICENSE BLOCK *****
+;* Version: MPL 1.1
+;*
+;* The contents of this file are subject to the Mozilla Public License Version
+;* 1.1 (the "License"); you may not use this file except in compliance with
+;* the License. You may obtain a copy of the License at
+;* http://www.mozilla.org/MPL/
+;*
+;* Software distributed under the License is distributed on an "AS IS" basis,
+;* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+;* for the specific language governing rights and limitations under the
+;* License.
+;*
+;* The Original Code is TurboPower FlashFiler
+;*
+;* The Initial Developer of the Original Code is
+;* TurboPower Software
+;*
+;* Portions created by the Initial Developer are Copyright (C) 1996-2002
+;* the Initial Developer. All Rights Reserved.
+;*
+;* Contributor(s):
+;*
+;* ***** END LICENSE BLOCK *****
+
+#include "ffllscst.inc"
+
+ffsce_NoErrorCode, "FlashFiler: %s [no error code]"
+ffsce_HasErrorCode, "FlashFiler: %s [$%x/%d]"
+ffsce_NilPointer, ""
+ffsce_UnnamedInst, ""
+ffsce_InstNoCode, "FlashFiler: %s: %s [no error code]"
+ffsce_MustBeInactive, "This object must be inactive before performing this operation."
+ffsce_MustBeStarted, "This object must be started before performing this operation."
+ffsce_MustBeListener, "The transport must be in listening mode before performing this operation."
+ffsce_MustBeSender, "The transport must be in sending mode before performing this operation."
+ffsce_MustHaveServerName, "A server name must be specified for the transport."
+ffsce_ParameterRequired, "Parameter %s must be specified for %s."
diff --git a/components/flashfiler/sourcelaz/fflltemp.pas b/components/flashfiler/sourcelaz/fflltemp.pas
new file mode 100644
index 000000000..79eea56bf
--- /dev/null
+++ b/components/flashfiler/sourcelaz/fflltemp.pas
@@ -0,0 +1,828 @@
+{*********************************************************}
+{* FlashFiler: Temporary Storage classes *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit fflltemp;
+
+interface
+
+uses
+ Windows,
+ ffllbase;
+
+
+type
+ TffTempStorageClass = class of TffBaseTempStorage;
+ TffBaseTempStorage = class(TffObject)
+ protected
+
+ tsBlockSize : TffWord32;
+ {-Size of the blocks used by the temporary storage. }
+
+ tsNumBlocks : TffWord32;
+ {-The number of blocks that can be held. }
+
+ tsSize : TffWord32;
+ {-The size of the temporary storage instance, in bytes. }
+
+ function btsGetBlockCount : TffWord32; virtual;
+ {-Returns the total number of blocks that the temporary storage
+ instance can hold. }
+
+ function btsGetSize : TffWord32; virtual;
+ {-Returns the size, in bytes, of the temporary storage instance. }
+
+ public
+
+ { Methods }
+
+ constructor Create(configDir : TffPath; aSize : TffWord32;
+ blockSize : integer); virtual; abstract;
+ { Creates an instance of temporary storage. aSize is the size of the
+ storage space in bytes. Blocksize is the size of the blocks, in bytes,
+ to be allocated by temporary storage. }
+
+ function Full : boolean; virtual; abstract;
+ { Returns True if temporary storage is full otherwise returns False. }
+
+ function HasSpaceFor(const numBlocks : TffWord32) : boolean; virtual; abstract;
+ { Returns True if temporary storage has space for the specified number
+ of blocks. }
+
+ procedure ReadBlock(const aBlockNum : TffWord32; aBlock : PffBlock); virtual; abstract;
+ { Reads the block specified by aBlockNum from temporary storage
+ & copies the block's data into aBlock. The block in the memory map
+ file is unallocated and made available to another caller. }
+
+ procedure ReleaseBlock(const aBlockNum : TffWord32); virtual; abstract;
+ { Use this method to release a block previously stored via WriteBlock.
+ The space occupied by the block is made available. The data written
+ to the block is no longer accessible. }
+
+ function WriteBlock(aBlock : PffBlock) : TffWord32; virtual; abstract;
+ { Write a block to temporary stroage. aBlock is the block to be written.
+ Returns the block number to which the block was written. When
+ retrieving the block via ReadBlock, use the block number returned
+ by this function. }
+
+ {Properties}
+
+ property BlockCount : TffWord32 read btsGetBlockCount;
+ { The total number of blocks that can be held in temporary storage. }
+
+ property Size : TffWord32 read btsGetSize;
+ { The size of the temporary storage, in bytes. }
+
+ end;
+
+ { This class implements temporary storage using VirtualAlloc and VirtualFree.
+ It maintains an internal array denoting block availability. }
+ TffTempStorageVA = class(TffBaseTempStorage)
+ protected
+
+ mmArraySize : TffWord32;
+ {-Size of the mmBlocks & mmCommits arrays. }
+
+ mmAddress : PffByteArray;
+ {-Pointer to the allocated region. }
+
+ mmBlocks : PffByteArray;
+ {-Array of bits used to denote block availability. One bit per 64k block. }
+
+ mmCommits : PffByteArray;
+ {-Indicates which blocks in mmBlocks have been committed in virtual
+ memory. The bits in this array have a one-to-one correspondence to the
+ bits in the mmBlocks array. }
+
+ mmNextAvailBlock : TffWord32;
+ {-Position of the next available block in the bit array. This value
+ indicates a particular byte not a bit. }
+
+ mmPadLock : TffPadLock;
+ {-Controls access to the storage. }
+
+ mmUseCount : TffWord32;
+ {-Number of blocks used. Bounds: 0..tsNumBlocks }
+
+ { Protected methods }
+ procedure tsReleaseBlockPrim(const aBlockNum : TffWord32);
+
+ public
+
+ { Methods }
+
+ constructor Create(configDir : TffPath; aSize : TffWord32;
+ aBlockSize : integer); override;
+
+ destructor Destroy; override;
+
+ function Full : boolean; override;
+ { Returns True if temporary storage is full otherwise returns False. }
+
+ function HasSpaceFor(const numBlocks : TffWord32) : boolean; override;
+ { Returns True if temporary storage has space for the specified number
+ of blocks. }
+
+ procedure ReadBlock(const aBlockNum : TffWord32; aBlock : PffBlock); override;
+ { Reads the block specified by aBlockNum from the memory map file
+ and copies the block's data into aBlock. The block in the memory map
+ file is unallocated and made available to another caller. }
+
+ procedure ReleaseBlock(const aBlockNum : TffWord32); override;
+ { Use this method to release a block previously stored via WriteBlock.
+ The space occupied by the block is made available. The data written
+ to the block is no longer accessible. }
+
+ function WriteBlock(aBlock : PffBlock) : TffWord32; override;
+ { Write a block to the file. aBlock is the block to be written.
+ Returns the block number to which the block was written. When
+ retrieving the block via ReadBlock, use the block number returned
+ by this function. }
+
+ end;
+
+ { This class implements temporary storage using a memory mapped file. It
+ divides itself up into blocks that are 64k bytes in size and maintains
+ an internal array denoting block availability.
+
+ This class expects to create a file on the disk. It does not support
+ mapping to the Windows page file. }
+ TffTempStorageMM = class(TffBaseTempStorage)
+ protected
+ mmArraySize : TffWord32;
+ {-Size of the mmBlocks array. }
+
+ mmBlocks : PffByteArray;
+ {-Array of bits used to denote block availability. One bit per 64k block. }
+
+ mmFileHandle : THandle;
+ {-The handle to the file. }
+
+ mmFileName : PffShStr;
+ {-The path and name of the file. }
+
+ mmMapHandle : THandle;
+ {-The handle to the memory mapped file. }
+
+ mmNextAvailBlock : TffWord32;
+ {-Position of the next available block in the bit array. This value
+ indicates a particular byte not a bit. }
+
+ mmPadLock : TffPadLock;
+ {-Controls access to file. }
+
+ mmUseCount : TffWord32;
+ {-Number of blocks used. Bounds: 0..tsNumBlocks }
+
+ { Protected methods }
+ function mmGetFileName : string;
+ {-Returns the name of the memory mapped file. }
+
+ procedure mmOpenFile;
+ {-Creates & opens the memory mapped file. }
+
+ procedure mmReleaseBlockPrim(const aBlockNum : TffWord32);
+ {-Marks a block as available. }
+
+ public
+
+ { Methods }
+
+ constructor Create(configDir : TffPath; aSize : TffWord32;
+ aBlockSize : integer); override;
+
+ destructor Destroy; override;
+
+ function ActualSize : DWORD;
+ { Returns the actual size of the file. }
+
+ function Full : boolean; override;
+ { Returns True if temporary storage is full otherwise returns False. }
+
+ function HasSpaceFor(const numBlocks : TffWord32) : boolean; override;
+ { Returns True if temporary storage has space for the specified number
+ of blocks. }
+
+ procedure ReadBlock(const aBlockNum : TffWord32; aBlock : PffBlock); override;
+ { Reads the block specified by aBlockNum from the memory map file
+ and copies the block's data into aBlock. The block in the memory map
+ file is unallocated and made available to another caller. }
+
+ procedure ReleaseBlock(const aBlockNum : TffWord32); override;
+ { Use this method to release a block previously stored via WriteBlock.
+ The space occupied by the block is made available. The data written
+ to the block is no longer accessible. }
+
+ function WriteBlock(aBlock : PffBlock) : TffWord32; override;
+ { Write a block to the file. aBlock is the block to be written.
+ Returns the block number to which the block was written. When
+ retrieving the block via ReadBlock, use the block number returned
+ by this function. }
+
+ {Properties}
+
+ property BlockCount : TffWord32 read tsNumBlocks;
+ { The number of blocks available in the file. }
+
+ property Name : string read mmGetFileName;
+ { The path and name of the file. }
+
+ property Size : TffWord32 read tsSize;
+ { The size of the file. }
+
+ end;
+
+var
+ ffcTempStorageClass : TffTempStorageClass = TffTempStorageMM;
+ { Identifies which type of temporary storage is to be used. }
+
+implementation
+
+uses
+ SysUtils,
+ FFLLExcp,
+ FFSrBase,
+ {$IFDEF SecureTempStorage} {!!.06}
+ fftbcryp, {!!.06}
+ {$ENDIF} {!!.06}
+ FFConst;
+
+{$IFDEF SecureTempStorage} {!!.06}
+var {!!.06}
+ EncryptBuffer : PffByteArray; {for encryption} {!!.06}
+{$ENDIF} {!!.06}
+
+{===TffBaseTempStorage===============================================}
+function TffBaseTempStorage.btsGetBlockCount : TffWord32;
+begin
+ Result := tsNumBlocks;
+end;
+{--------}
+function TffBaseTempStorage.btsGetSize : TffWord32;
+begin
+ Result := tsSize;
+end;
+{====================================================================}
+
+{===TffTempStorageVA==================================================}
+constructor TffTempStorageVA.Create(configDir : TffPath; aSize : TffWord32;
+ aBlockSize : integer);
+var
+ ErrCode : DWORD;
+begin
+ tsBlockSize := aBlockSize;
+ mmNextAvailBlock := 0;
+ mmPadLock := TffPadLock.Create;
+ tsSize := aSize;
+ mmUseCount := 0;
+
+ { Allocate the virtual memory region. Memory is reserved but not
+ committed. }
+ mmAddress := VirtualAlloc(nil, tsSize, MEM_RESERVE or MEM_TOP_DOWN,
+ PAGE_READWRITE);
+ if not assigned(mmAddress) then begin
+ ErrCode := GetLastError;
+ raise EffException.CreateEx(ffStrResGeneral, fferrTmpStoreCreateFail,
+ [aSize, ErrCode, ErrCode,
+ SysErrorMessage(ErrCode)]);
+ end;
+
+ { Round up the storage size to the nearest 8 * 64k boundary. This makes
+ things easier. }
+ if tsSize mod (8 * ffcl_64k) <> 0 then begin
+ tsNumBlocks := tsSize div (8 * ffcl_64k);
+ tsSize := (tsNumBlocks + 1) * 8 * ffcl_64k;
+ end;
+
+ { Set up the block array. Array size is calculated as:
+ # blocks = div
+ # bytes = <# blocks> div 8. }
+ tsNumBlocks := tsSize div tsBlockSize;
+ mmArraySize := tsNumBlocks div 8;
+ FFGetMem(mmBlocks, mmArraySize);
+ FillChar(mmBlocks^, mmArraySize, 0);
+
+ FFGetMem(mmCommits, mmArraySize);
+ FillChar(mmCommits^, mmArraySize, 0);
+
+end;
+{--------}
+destructor TffTempStorageVA.Destroy;
+begin
+
+ mmPadLock.Free;
+
+ { Free the allocated memory. }
+ if assigned(mmAddress) then
+ VirtualFree(mmAddress, 0, MEM_RELEASE);
+
+ { Free the block & commit arrays. }
+ FFFreeMem(mmBlocks, mmArraySize);
+ FFFreeMem(mmCommits, mmArraySize);
+
+ inherited Destroy;
+end;
+{--------}
+function TffTempStorageVA.Full : boolean;
+begin
+ Result := (mmUseCount = tsNumBlocks);
+end;
+{--------}
+function TffTempStorageVA.HasSpaceFor(const numBlocks : TffWord32) : boolean;
+begin
+ Result := ((tsNumBlocks - mmUseCount) >= numBlocks);
+end;
+{--------}
+procedure TffTempStorageVA.ReadBlock(const aBlockNum : TffWord32; aBlock : PffBlock);
+var
+ BlockPtr : PffByteArray;
+begin
+
+ { Requirement: Block number must be less than upper block boundary (because
+ blocks are base zero). }
+ Assert(aBlockNum < tsNumBlocks);
+
+ mmPadLock.Lock;
+ try
+ { Calculate the location of the block. }
+ BlockPtr := @mmAddress^[aBlockNum * tsBlockSize];
+
+ { Move data from the file into the block. }
+ Move(BlockPtr^, aBlock^, tsBlockSize);
+
+ { Erase the block in the file. }
+ FillChar(BlockPtr^, tsBlockSize, 0);
+
+ { Mark the block as available. }
+ tsReleaseBlockPrim(aBlockNum);
+ finally
+ mmPadLock.Unlock; {!!.03}
+ end;
+
+end;
+{--------}
+procedure TffTempStorageVA.ReleaseBlock(const aBlockNum : TffWord32);
+begin
+ { Requirement: Block number must be less than upper block boundary (because
+ blocks are base zero). }
+ Assert(aBlockNum < tsNumBlocks);
+
+ mmPadLock.Lock;
+ try
+ { Mark the block as available. }
+ tsReleaseBlockPrim(aBlockNum);
+ finally
+ mmPadLock.Unlock; {!!.03}
+ end;
+
+end;
+{--------}
+procedure TffTempStorageVA.tsReleaseBlockPrim(const aBlockNum : TffWord32);
+var
+ BitIndex : Byte;
+ Index : TffWord32;
+begin
+ { Mark the block as available. First, find the position within the block
+ array. }
+ Index := aBlockNum div 8;
+
+ mmNextAvailBlock := Index;
+
+ { Now determine which bit to clear within that position. }
+ BitIndex := aBlockNum - (Index * 8);
+
+ { Clear the bit. }
+ FFClearBit(@mmBlocks^[Index], BitIndex);
+
+ { Decrement the usage count. }
+ dec(mmUseCount);
+
+end;
+{--------}
+function TffTempStorageVA.WriteBlock(aBlock : PffBlock) : TffWord32;
+var
+ AllBlocksChecked : boolean;
+ BitIndex : Byte;
+ BlockPtr : PffByteArray;
+ Index, StartPoint : TffWord32;
+begin
+
+ Result := ffc_W32NoValue;
+ BitIndex := 0;
+
+ mmPadLock.Lock;
+ try
+ { Find an available block. We will be scanning through the entire block
+ array so find our starting point & mark it as our ending point. }
+ Index := mmNextAvailBlock;
+ StartPoint := Index;
+ AllBlocksChecked := False;
+
+ repeat
+ { Is there a block available in this byte? }
+ if mmBlocks^[Index] < $FF then begin
+ { Determine which bit is set. }
+ for BitIndex := 0 to 7 do
+ if not FFIsBitSet(@mmBlocks^[Index], BitIndex) then begin
+ Result := (Index * 8) + BitIndex;
+ break;
+ end;
+ end
+ else begin
+ { Move to the next position. }
+ inc(Index);
+ { Have we reached our start point? }
+ AllBlocksChecked := (Index = StartPoint);
+ if (not AllBlocksChecked) and (Index = mmArraySize) then begin
+ Index := 0;
+ AllBlocksChecked := (Index = StartPoint);
+ { Catches case where StartPoint = 0. }
+ end;
+ end;
+ until (Result <> ffc_W32NoValue) or AllBlocksChecked;
+
+ { Was a free block found? }
+ if Result <> ffc_W32NoValue then begin
+ { Yes. Reset high water mark. }
+ mmNextAvailBlock := Index;
+
+ { Calculate the pointer to the block. }
+ BlockPtr := @mmAddress^[Result * tsBlockSize];
+
+ { Has that memory been committed? }
+ if not FFIsBitSet(@mmCommits^[Index], BitIndex) then
+ { No. Commit the memory. }
+ VirtualAlloc(BlockPtr, tsBlockSize, MEM_COMMIT, PAGE_READWRITE);
+
+ { Write the block to the file's block. }
+ Move(aBlock^, BlockPtr^, tsBlockSize);
+
+ { Mark the block as unavailable. }
+ FFSetBit(@mmBlocks^[Index], BitIndex);
+ FFSetBit(@mmCommits^[Index], BitIndex);
+
+ inc(mmUseCount);
+ end
+ else
+ raise EffException.CreateEx(ffStrResGeneral, fferrTmpStoreFull, [tsSize]);
+
+ finally
+ mmPadLock.Unlock;
+ end;
+
+end;
+{====================================================================}
+
+{===TffTempStorageMM=================================================}
+constructor TffTempStorageMM.Create(configDir : TffPath; aSize : TffWord32;
+ aBlockSize : integer);
+begin
+ tsBlockSize := aBlockSize;
+ mmFileHandle := 0;
+ mmMapHandle := 0;
+ mmNextAvailBlock := 0;
+ mmPadLock := TffPadLock.Create;
+ tsSize := aSize;
+ mmUseCount := 0;
+
+ { Build the filename of the temporary storage file. }
+ mmFileName := FFShStrAlloc(
+ FFExpandFileName(
+ FFMakeFullFileName(configDir, IntToStr(Longint(Self)) +
+ '.TMP')));
+
+ { The file won't be opened until it is needed. }
+
+ { Round up the storage size to the nearest 8 * 64k boundary. This makes
+ things easier. }
+ if tsSize mod (8 * ffcl_64k) <> 0 then begin
+ tsNumBlocks := tsSize div (8 * ffcl_64k);
+ tsSize := (tsNumBlocks + 1) * 8 * ffcl_64k;
+ end;
+
+ { Set up the block array. Array size is calculated as:
+ # blocks = div
+ # bytes = <# blocks> div 8. }
+ tsNumBlocks := tsSize div tsBlockSize;
+ mmArraySize := tsNumBlocks div 8;
+ FFGetMem(mmBlocks, mmArraySize);
+ FillChar(mmBlocks^, mmArraySize, 0);
+
+end;
+{--------}
+destructor TffTempStorageMM.Destroy;
+begin
+
+ mmPadLock.Free;
+
+ { Close the mem map file if necessary. }
+ if mmMapHandle <> 0 then
+ CloseHandle(mmMapHandle);
+
+ { Close the file handle if necessary. }
+ if mmFileHandle <> 0 then
+ CloseHandle(mmFileHandle);
+
+ { Free the block array. }
+ FFFreeMem(mmBlocks, mmArraySize);
+
+ { Delete the temporary file. }
+ if FFFileExists(mmFileName^) then
+ FFDeleteFile(mmFileName^);
+
+ { Deallocate the filename. }
+ FFShStrFree(mmFileName);
+
+ inherited Destroy;
+end;
+{--------}
+function TffTempStorageMM.ActualSize : DWORD;
+begin
+ Result := GetFileSize(mmFileHandle, nil);
+end;
+{--------}
+function TffTempStorageMM.Full : boolean;
+begin
+ Result := (mmUseCount = tsNumBlocks);
+end;
+{--------}
+function TffTempStorageMM.HasSpaceFor(const numBlocks : TffWord32) : boolean;
+begin
+ Result := ((tsNumBlocks - mmUseCount) >= numBlocks);
+end;
+{--------}
+function TffTempStorageMM.mmGetFileName : string;
+begin
+ Result := mmFileName^;
+end;
+{--------}
+procedure TffTempStorageMM.mmOpenFile;
+var
+ ErrCode : DWORD;
+begin
+
+ { Create the temporary storage file. }
+ mmFileHandle := FFOpenFilePrim(@mmFileName^[1], omReadWrite, smExclusive,
+ False, True);
+ if mmFileHandle <> 0 then begin
+
+ mmMapHandle := CreateFileMapping(mmFileHandle, nil, PAGE_READWRITE,
+ 0, tsSize, nil);
+ if mmMapHandle = 0 then begin
+ { Raise exception. }
+ ErrCode := GetLastError;
+ raise EffException.CreateEx(ffStrResGeneral, fferrMapFileHandleFail,
+ [mmFileName^, tsSize, ErrCode, ErrCode,
+ SysErrorMessage(ErrCode)]);
+ end;
+
+ end
+ else begin
+ ErrCode := GetLastError;
+ raise EffException.CreateEx(ffStrResGeneral, fferrMapFileCreateFail,
+ [mmFileName^, tsSize, ErrCode, ErrCode,
+ SysErrorMessage(ErrCode)]);
+ end;
+
+end;
+{--------}
+procedure TffTempStorageMM.ReadBlock(const aBlockNum : TffWord32; aBlock : PffBlock);
+var
+ BlockPtr : PffByteArray;
+ ErrCode : DWORD;
+begin
+
+ { Requirement: Block number must be less than upper block boundary (because
+ blocks are base zero). }
+ Assert(aBlockNum < tsNumBlocks);
+
+ { Requirement: Something must have been written to the file. }
+ Assert(mmMapHandle <> 0, 'Temp storage is empty');
+
+ { Note: We don't verify that the block requested was actually written. }
+
+ mmPadLock.Lock;
+ try
+ { Assumption: Block was previously marked unavailable and data was written
+ to that block. }
+ BlockPtr := MapViewOfFile(mmMapHandle, FILE_MAP_WRITE,
+ 0, aBlockNum * tsBlockSize, tsBlockSize);
+ if BlockPtr = nil then begin
+ { Raise exception. }
+ ErrCode := GetLastError;
+ raise EffException.CreateEx(ffStrResGeneral, fferrMapFileViewFail,
+ ['ReadBlock', aBlockNum, mmGetFileName,
+ ErrCode, ErrCode, SysErrorMessage(ErrCode)]);
+ end;
+
+ {$IFDEF SecureTempStorage} {begin !!.06}
+ if (EncryptBuffer = nil) then
+ GetMem(EncryptBuffer, tsBlockSize);
+ Move(BlockPtr^, EncryptBuffer^, tsBlockSize);
+ FFDecodeBlockServer(EncryptBuffer, tsBlockSize, 0);
+
+ { Move data from the decrypted file into the block. }
+ Move(EncryptBuffer^, aBlock^, tsBlockSize);
+ {$ELSE}
+
+ { Move data from the file into the block. }
+ Move(BlockPtr^, aBlock^, tsBlockSize);
+ {$ENDIF} {end !!.06}
+
+ { Erase the block in the file. }
+ FillChar(BlockPtr^, tsBlockSize, 0);
+
+ { Unmap the view. }
+ UnmapViewOfFile(BlockPtr);
+
+ { Mark the block as available. }
+ mmReleaseBlockPrim(aBlockNum);
+
+ finally
+ mmPadLock.Unlock; {!!.03}
+ end;
+
+end;
+{--------}
+procedure TffTempStorageMM.ReleaseBlock(const aBlockNum : TffWord32);
+begin
+ { Requirement: Block number must be less than upper block boundary (because
+ blocks are base zero). }
+ Assert(aBlockNum < tsNumBlocks);
+
+ mmPadLock.Lock;
+ try
+ { Mark the block as available. }
+ mmReleaseBlockPrim(aBlockNum);
+ finally
+ mmPadLock.Unlock; {!!.03}
+ end;
+
+end;
+{--------}
+procedure TffTempStorageMM.mmReleaseBlockPrim(const aBlockNum : TffWord32);
+var
+ BitIndex : Byte;
+ Index : TffWord32;
+begin
+ { Mark the block as available. First, find the position within the block
+ array. }
+ Index := aBlockNum div 8;
+
+ mmNextAvailBlock := Index;
+
+ { Now determine which bit to clear within that position. }
+ BitIndex := aBlockNum - (Index * 8);
+
+ { Clear the bit. }
+ FFClearBit(@mmBlocks^[Index], BitIndex);
+
+ { Decrement the usage count. }
+ dec(mmUseCount);
+
+end;
+{--------}
+function TffTempStorageMM.WriteBlock(aBlock : PffBlock) : TffWord32;
+var
+ AllBlocksChecked : boolean;
+ BitIndex : Byte;
+ BlockPtr : PffByteArray;
+ ErrCode : DWORD;
+ Index, StartPoint : TffWord32;
+begin
+
+ Result := ffc_W32NoValue;
+ BitIndex := 0;
+
+ { Open the file if it has not already been opened. }
+ if mmMapHandle = 0 then
+ mmOpenFile;
+
+ mmPadLock.Lock;
+ try
+ { Find an available block. We will be scanning through the entire block
+ array so find our starting point & mark it as our ending point. }
+ Index := mmNextAvailBlock;
+ StartPoint := Index;
+ AllBlocksChecked := False;
+
+ repeat
+ { Is there a block available in this byte? }
+ if mmBlocks^[Index] < $FF then begin
+ { Determine which bit is set. }
+ for BitIndex := 0 to 7 do
+ if not FFIsBitSet(@mmBlocks^[Index], BitIndex) then begin
+ Result := (Index * 8) + BitIndex;
+ break;
+ end;
+ end
+ else begin
+ { Move to the next position. }
+ inc(Index);
+ { Have we reached our start point? }
+ AllBlocksChecked := (Index = StartPoint);
+ if (not AllBlocksChecked) and (Index = mmArraySize) then begin
+ Index := 0;
+ AllBlocksChecked := (Index = StartPoint);
+ { Catches case where StartPoint = 0. }
+ end;
+ end;
+ until (Result <> ffc_W32NoValue) or AllBlocksChecked;
+
+ { Was a free block found? }
+ if Result <> ffc_W32NoValue then begin
+ { Yes. Reset high water mark. }
+ mmNextAvailBlock := Index;
+
+ { Obtain a view on the available block. }
+ BlockPtr := MapViewOfFile(mmMapHandle, FILE_MAP_ALL_ACCESS,
+ 0, Result * tsBlockSize, tsBlockSize);
+
+ if BlockPtr = nil then begin
+ ErrCode := GetLastError;
+ raise EffException.CreateEx(ffStrResGeneral, fferrMapFileViewFail,
+ ['WriteBlock', Result * tsBlockSize,
+ mmGetFileName,
+ ErrCode, ErrCode, SysErrorMessage(ErrCode)]);
+ end;
+
+ {$IFDEF SecureTempStorage} {begin !!.06}
+ if (EncryptBuffer = nil) then
+ GetMem(EncryptBuffer, tsBlockSize);
+ Move(aBlock^, EncryptBuffer^, tsBlockSize);
+ FFCodeBlockServer(EncryptBuffer, tsBlockSize, 0);
+
+ { Write the encrypted block to the file's block. }
+ Move(EncryptBuffer^, BlockPtr^, tsBlockSize);
+ {$ELSE}
+
+ { Write the block to the file's block. }
+ Move(aBlock^, BlockPtr^, tsBlockSize);
+ {$ENDIF} {end !!.06}
+ { Release the view on the block. }
+ UnmapViewOfFile(BlockPtr);
+
+ { Mark the block as unavailable. }
+ FFSetBit(@mmBlocks^[Index], BitIndex);
+
+ inc(mmUseCount);
+
+ end else
+ raise EffException.CreateEx(ffStrResGeneral, fferrTmpStoreFull,
+ [tsSize]);
+ finally
+ mmPadLock.Unlock;
+ end;
+
+end;
+{====================================================================}
+
+
+{===Initialization/Finalization======================================}{begin !!.06}
+{$IFDEF SecureTempStorage}
+procedure FinalizeUnit;
+begin
+ if (EncryptBuffer <> nil) then
+ FreeMem(EncryptBuffer, 64*1024);
+end;
+{--------}
+procedure InitializeUnit;
+begin
+ EncryptBuffer := nil;
+end;
+{--------}
+initialization
+ InitializeUnit;
+
+finalization
+ FinalizeUnit;
+{$ENDIF} {end !!.06}
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffllthrd.pas b/components/flashfiler/sourcelaz/ffllthrd.pas
new file mode 100644
index 000000000..38d09e0eb
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffllthrd.pas
@@ -0,0 +1,766 @@
+{*********************************************************}
+{* FlashFiler: Server thread pool & thread classes *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffllthrd;
+
+interface
+
+uses
+ classes,
+ windows,
+ ffllBase, {!!.06}
+ ffllComp; {!!.06}
+
+type
+ { This is a type of procedure that may be passed to a thread pool for
+ processing. The thread pool grabs an available thread or instantiates
+ a new thread. It then passes the procedure to the thread and the thread
+ calls the procedure. aProcessCookie is whatever the calling object
+ wants it to be. }
+ TffThreadProcessEvent = procedure(const aProcessCookie: longInt) of object;
+
+ TffThreadPool = class; { forward declaration }
+
+ { This type of thread is useful for work that must occur on a periodic
+ basis. This thread frees itself when terminated. }
+ TffTimerThread = class(TffThread)
+ protected { private }
+
+ FFrequency : DWord;
+ {-The number of milliseconds between each firing of the timer event. }
+
+ FTimerEvent : TffThreadProcessEvent;
+ {-The routine that is called when the "timer" fires. }
+
+ FTimerEventCookie : longInt;
+ {-The cookie passed to the FProcessEvent. }
+
+ FDieEvent : TffEvent;
+ {-Event raised when a thread is to die. }
+
+ protected
+
+ procedure Execute; override;
+
+ public
+
+ constructor Create(const aFrequency : DWord;
+ aTimerEvent : TffThreadProcessEvent;
+ const aTimerEventCookie : longInt;
+ const createSuspended : boolean); virtual;
+ { Use this method to create an instance of the thread. Parameters:
+ - aFrequency is the number of milliseconds that must elapse before the
+ thread calls aProcessEvent.
+ - aTimerEvent is the method called when the timer fires.
+ - aTimerEventCookie is an optional value that is passed to aTimerEvent.
+ - CreateSuspended allows you to control when the thread starts.
+ If False then the thread starts immediately. If True then the thread
+ starts once you call the Resume method. }
+
+ destructor Destroy; override;
+
+ procedure DieDieDie;
+ { Use this method to terminate the timer thread. }
+
+ property Frequency : DWord
+ read FFrequency write FFrequency;
+ { The number of milliseconds between each firing of the timer event. }
+
+ end;
+
+ { This is the base class for threads associated with pools. The pool's
+ Process method grabs an available thread or creates a new instance of
+ this class. It then calls the TffPooledThread.Process method. }
+ TffPooledThread = class(TffThread)
+ protected { private }
+
+ FDieEvent : TffEvent;
+ {-Event raised when a thread is to die. }
+
+ FProcessCookie : longInt;
+ {-The cookie passed to the Process method. Used by the Execute
+ method. }
+
+ FProcessEvent : TffThreadProcessEvent;
+ {-The callback passed to the Process method. Used by the Execute
+ method. }
+
+ FThreadEventHandles: Array[0..1] of THandle;
+ {-When a thread is created, it pauses in its execute method until it
+ receives one of two events:
+
+ 1. Wake up and do some work.
+ 2. Wake up and terminate.
+
+ This array stores these two event handles. }
+
+ FThreadPool : TffThreadPool;
+ {-The parent thread pool. }
+
+ FWorkEvent : TffEvent;
+ {-Event raised when a thread is to do work. }
+
+ protected
+
+ procedure Execute; override;
+ { Calls the processEvent stored by the Process method.
+ Do not call this function directly. Instead, use the Process method. }
+
+ procedure ptReturnToPool;
+ {-Called by the execute method. When the thread has finished its work,
+ this method has the threadpool return this thread to the list of
+ inactive threads. If there are pending requests, the threadPool will
+ assign one to this thread instead of putting the thread back in the
+ inactive list. }
+
+ public
+
+ constructor Create(threadPool : TffThreadPool); virtual;
+ { Use this method to create the thread and associate it with a thread
+ pool. }
+
+ destructor Destroy; override;
+
+ procedure DieDieDie;
+ { Use this method to terminate the thread. }
+
+ procedure Process(aProcessEvent : TffThreadProcessEvent;
+ aProcessCookie: longInt);
+ { This method is called by the thread pool to perform work. It saves
+ the process event and cookie then raises an event informing the
+ thread it has work to do. }
+
+ published
+ end;
+
+ { This class is a generic mechanism for having work performed in a separate
+ thread. It maintains a pool of threads. It may be instructed to create
+ an initial number of threads upon startup and to never exceed a certain
+ number of threads within the pool. It maintains the status of each
+ thread, placing them in an active or inactive list.
+
+ Any type of object may have work performed through one of the pool's thread
+ by supplying a callback function and cookie (optional) to the pool's
+ ProcessThreaded method. }
+ TffThreadPool = class(TffLoggableComponent) {!!.06}
+ private
+
+ FActive : TffList;
+ {-List of acquired threads. When a thread becomes inactive it is moved
+ to FInactive. }
+
+ FInactive : TffList;
+ {-List of available threads. When a thread is acquired, it moves to the
+ FActive list. }
+
+ FInitialCount : integer;
+ {-The maximum number of threads that can be created by the pool. }
+
+ FInitialized : boolean;
+ {-Set to True when the initial threads have been created for the thread
+ pool. }
+
+ FMaxCount : integer;
+ {-The maximum number of threads to be created by the pool. }
+
+ FPendingQueue : TffThreadQueue;
+ {-Queue of pending requests. Requests wind up here when a thread
+ is not available to process the request. }
+
+ FLock : TffPadlock;
+ {-Controls access to the threads. }
+
+ FSkipInitial : Boolean;
+ {-Used by the EngineManager expert to keep the pool from creating threads
+ when InitialCount is set}
+
+ protected
+
+ function thpGetActiveCount : integer;
+ {-Return total # of active thread. }
+
+ function thpGetFreeCount : integer;
+ {-Return total # of free thread slots. In other words, the maximum
+ number of threads minus the total # of active and inactive threads. }
+
+ function thpGetInactiveCount : integer;
+ {-Return total # of inactive threads.}
+
+ function thpGetThreadFromPool : TffPooledThread;
+ {-Used to obtain a thread from the inactive pool. If no thread is
+ available then this method returns nil. If a thread is available,
+ the thread is moved from the inactive list to the active list. }
+
+ procedure thpPutInQueue(aProcessEvent : TffThreadProcessEvent;
+ aProcessCookie: longInt);
+ {-Used to place a request in queue when a thread is not available to
+ process the request. The request will be picked out of the queue by
+ the next free thread. }
+
+ procedure thpReturnThreadToPool(aThread : TffPooledThread);
+ {-Called by a thread when it has finished processing. If any requests
+ are in queue then this method has the newly-available thread process
+ the request. Otherwise, this method moves the thread from the active
+ list to the inactive list. }
+
+ procedure thpSetInitialCount(const aCount : integer);
+ {-Called when the initial thread count is set. }
+
+ procedure thpSetMaxCount(const aCount : integer);
+ {-Called when the max thread count is set. }
+
+ property SkipInitial : Boolean
+ read FSkipInitial write FSkipInitial;
+ {-Used by the EngineManager expert to keep the pool from creating threads
+ when InitialCount is set}
+
+ public
+
+ constructor Create(aOwner : TComponent); override;
+
+ destructor Destroy; override;
+
+ procedure Flush(NumToRetain : integer);
+ { Use this method to flush inactive threads from the pool. NumToRetain
+ is the number of inactive threads to retain in the pool. Active threads
+ are unaffected by this method. }
+
+ procedure ProcessThreaded(aProcessEvent : TffThreadProcessEvent;
+ aProcessCookie: longInt);
+ { Use this method to have a worker thread process a message. The worker
+ thread calls the specified process event, passing it the specified
+ process cookie. If a worker thread is not immediately available, this
+ method will add the message to an internal queue. The next thread that
+ becomes available will pick up the request from the queue and process
+ the request. }
+
+ property ActiveCount : integer read thpGetActiveCount;
+ { The total number of active threads. }
+
+ property FreeCount : integer read thpGetFreeCount;
+ { The total number of thread slots that are unfilled. Usually
+ calculated as MaxCount - ActiveCount - InactiveCount. }
+
+ property InactiveCount : integer read thpGetInactiveCount;
+ { The total number of inactive threads. Does not include free thread
+ slots that do not contain a thread. }
+
+ published
+
+ property InitialCount : integer
+ read FInitialCount write thpSetInitialCount default 5;
+ { The initial number of threads to be preloaded by the pool. }
+
+ property MaxCount : integer
+ read FMaxCount write thpSetMaxCount default 16;
+ { The maximum number of threads that can be created by the pool. }
+
+ end;
+
+ { This type is used to store pending requests in the TffThreadPool. }
+ TffThreadRequestItem = class(TffSelfListItem)
+ protected
+ FProcessCookie : longInt;
+ FProcessEvent : TffThreadProcessEvent;
+ public
+ constructor Create(anEvent : TffThreadProcessEvent;
+ aCookie : longInt);
+
+ property ProcessCookie : longInt read FProcessCookie;
+ property ProcessEvent : TffThreadProcessEvent read FProcessEvent;
+ end;
+
+implementation
+
+uses
+ sysUtils, {!!.06}
+// ffllcomp, {Deleted !!.06}
+ ffllexcp;
+
+{$I ffconst.inc}
+{$I ffllscst.inc}
+
+{===TffTimerThread===================================================}
+constructor TffTimerThread.Create(const aFrequency : DWord;
+ aTimerEvent : TffThreadProcessEvent;
+ const aTimerEventCookie : longInt;
+ const createSuspended : boolean);
+begin
+ { Requirement: aTimerEvent must be assigned. }
+ if not assigned(aTimerEvent) then
+ RaiseSCErrorCodeFmt(ffsce_ParameterRequired,
+ ['aTimerEvent', ClassName + '.constructor']);
+
+ { Make sure important variables set before the thread is actually started in
+ the inherited Create. }
+ FDieEvent := TffEvent.Create;
+ FFrequency := aFrequency;
+ FTimerEvent := aTimerEvent;
+ FTimerEventCookie := aTimerEventCookie;
+ FreeOnTerminate := False;
+
+ inherited Create(createSuspended);
+
+end;
+{--------}
+destructor TffTimerThread.Destroy;
+begin
+ FDieEvent.Free;
+ inherited Destroy;
+end;
+{--------}
+procedure TffTimerThread.DieDieDie;
+begin
+ Terminate;
+ FDieEvent.SignalEvent;
+end;
+{--------}
+procedure TffTimerThread.Execute;
+var
+ aResult : DWORD;
+begin
+
+ if Terminated then exit;
+
+ repeat
+ aResult := FDieEvent.WaitForQuietly(FFrequency);
+ if aResult = WAIT_TIMEOUT then
+ FTimerEvent(FTimerEventCookie)
+ else
+ Terminate;
+ until Terminated;
+end;
+{====================================================================}
+
+{===TffPooledThread==================================================}
+constructor TffPooledThread.Create(threadPool : TffThreadPool);
+ { Use this method to create the thread and associate it with a thread
+ pool. }
+begin
+ inherited Create(False);
+ FDieEvent := TffEvent.Create;
+ FProcessCookie := -1;
+ FProcessEvent := nil;
+ FThreadPool := threadPool;
+ FWorkEvent := TffEvent.Create;
+ FThreadEventHandles[0] := FWorkEvent.Handle;
+ FThreadEventHandles[1] := FDieEvent.Handle;
+ FreeOnTerminate := False; { Freed in TffThreadpool.destroy }
+end;
+{--------}
+destructor TffPooledThread.Destroy;
+begin
+ FDieEvent.Free;
+ FWorkEvent.Free;
+ inherited Destroy;
+end;
+{--------}
+procedure TffPooledThread.DieDieDie;
+begin
+ Terminate;
+ FDieEvent.SignalEvent;
+end;
+{--------}
+procedure TffPooledThread.Execute;
+var
+ WaitResult : DWORD;
+begin
+
+ repeat
+ { Wait for something to do or until we are killed. }
+ WaitResult := WaitForMultipleObjects(2, @FThreadEventHandles,
+ false, ffcl_INFINITE); {!!.06}
+ if (WaitResult = WAIT_OBJECT_0) then begin
+ { Thread has work to do. }
+{Begin !!.06}
+ try
+ if assigned(FProcessEvent) then
+ FProcessEvent(FProcessCookie);
+ except
+ on E:Exception do
+ FThreadPool.lcLog('Exception caught in TffPooledThread.Execute: ' +
+ E.Message);
+ end;
+{End !!.06}
+ if not Terminated then
+ ptReturnToPool;
+ end;
+ until Terminated;
+
+end;
+{--------}
+procedure TffPooledThread.Process(aProcessEvent : TffThreadProcessEvent;
+ aProcessCookie: longInt);
+ { This method is called by the thread pool to perform work. It saves
+ the process event and cookie then resumes the thread. }
+begin
+ FProcessEvent := aProcessEvent;
+ FProcessCookie := aProcessCookie;
+ FWorkEvent.SignalEvent;
+end;
+{--------}
+procedure TffPooledThread.ptReturnToPool;
+begin
+ FThreadPool.thpReturnThreadToPool(Self);
+end;
+{====================================================================}
+
+{===TffThreadPool====================================================}
+constructor TffThreadPool.Create(aOwner : TComponent);
+begin
+ inherited Create(aOwner);
+ FLock := TffPadlock.Create;
+ FActive := TffList.Create;
+ FActive.Sorted := False;
+ FInactive := TffList.Create;
+ FInactive.Sorted := False;
+ FInitialCount := 5;
+ FInitialized := False;
+ FMaxCount := 16;
+ FPendingQueue := TffThreadQueue.Create;
+ FSkipInitial := False;
+end;
+{--------}
+destructor TffThreadPool.Destroy;
+var
+ anIndex : longInt;
+ aThread : TffPooledThread;
+ HandleList : TffHandleList; { list of thread handles }
+ PHandleArray : pointer;
+begin
+ FFNotifyDependents(ffn_Destroy); {!!.11}
+ FLock.Lock;
+ try
+ HandleList := TffHandleList.Create;
+ try
+ if assigned(FActive) then begin
+ { Allocate memory for the array of thread handles. }
+ HandleList.Capacity := FActive.Count;
+ for anIndex := pred(FActive.Count) downto 0 do begin
+ aThread := TffPooledThread(TffIntListItem(FActive[anIndex]).KeyAsInt);
+ HandleList.Append(aThread.Handle);
+ aThread.DieDieDie;
+ end;
+ end;
+
+ if assigned(FInactive) then begin
+ { Add more memory as needed to array of thread handles. }
+ HandleList.Capacity := HandleList.Capacity + FInactive.Count;
+ for anIndex := pred(FInactive.Count) downto 0 do begin
+ aThread := TffPooledThread(TffIntListItem(FInactive[anIndex]).KeyAsInt);
+ HandleList.Append(aThread.Handle);
+ aThread.DieDieDie;
+ end;
+ end;
+
+ { Wait for the threads to terminate. }
+ PHandleArray := HandleList.InternalAddress;
+ WaitForMultipleObjects(HandleList.Count, pHandleArray, true, 2000);
+ { SPW - 7/3/2000 - Note: I tried using the MsgWaitForMultipleObjects (as shown
+ below) but after awhile it would wait the entire 5 seconds even though all
+ threads had terminated. Using WaitForMultipleObjects does not appear to
+ have that kind of problem.
+ MsgWaitForMultipleObjects(HandleIndex, pHandleArray^, true,
+ 2000, QS_ALLINPUT); }
+ finally
+ { Explicitly remove the handles so that they are not closed before the
+ thread has had a chance to close the handle. }
+ HandleList.RemoveAll;
+ HandleList.Free;
+ end;
+
+ { Free the threads. }
+ if assigned(FActive) then
+ for anIndex := pred(FActive.Count) downto 0 do
+ TffPooledThread(TffIntListItem(FActive[anIndex]).KeyAsInt).Free;
+
+ if assigned(FInactive) then
+ for anIndex := pred(FInactive.Count) downto 0 do
+ TffPooledThread(TffIntListItem(FInactive[anIndex]).KeyAsInt).Free;
+
+ FPendingQueue.Free;
+
+ finally
+ FActive.Free;
+ FInactive.Free;
+ FLock.Unlock;
+ FLock.Free;
+ end;
+
+ inherited Destroy;
+end;
+{--------}
+procedure TffThreadPool.Flush(NumToRetain : integer);
+var
+ anIndex : integer;
+ aThread : TffPooledThread;
+begin
+ FLock.Lock;
+ try
+ for anIndex := pred(FInactive.Count) downto NumToRetain do begin
+ aThread := TffPooledThread(TffIntListItem(FInactive[anIndex]).KeyAsInt);
+ aThread.DieDieDie;
+ FInactive.DeleteAt(anIndex);
+ end;
+ finally
+ FLock.Unlock;
+ end;
+end;
+{--------}
+procedure TffThreadPool.ProcessThreaded(aProcessEvent : TffThreadProcessEvent;
+ aProcessCookie: longInt);
+var
+ aThread : TffPooledThread;
+begin
+ { Get an available thread. }
+ aThread := thpGetThreadFromPool;
+
+ { If one is available then have it process the request. }
+ if assigned(aThread) then
+ aThread.Process(aProcessEvent, aProcessCookie)
+ else
+ { Otherwise put the request in queue for processing by
+ the next free thread. }
+ thpPutInQueue(aProcessEvent, aProcessCookie);
+end;
+{--------}
+function TffThreadPool.thpGetActiveCount : integer;
+begin
+ FLock.Lock;
+ try
+ Result := FActive.Count;
+ finally
+ FLock.Unlock;
+ end;
+end;
+{--------}
+function TffThreadPool.thpGetFreeCount : integer;
+begin
+ { free count := max - (active count + inactive count) }
+
+ { Note there is a small chance for inaccuracy. It is totally
+ possible that a new thread is activated in between our getting
+ the active threads count and getting the inactive threads count.
+
+ Just in case this question is in your mind, we should only lock
+ one list at a time. Otherwise we run the risk of deadlock. }
+ FLock.Lock;
+ try
+ Result := FMaxCount - FActive.Count - FInactive.Count;
+ finally
+ FLock.Unlock;
+ end;
+end;
+{--------}
+function TffThreadPool.thpGetInactiveCount : integer;
+begin
+ FLock.Lock;
+ try
+ Result := FInactive.Count;
+ finally
+ FLock.Unlock;
+ end;
+end;
+{--------}
+function TffThreadPool.thpGetThreadFromPool : TffPooledThread;
+var
+ aListItem : TffIntListItem;
+ anIndex : longInt;
+begin
+ Result := nil;
+ aListItem := nil;
+ FLock.Lock;
+ try
+ { Is an inactive thread available? }
+ anIndex := pred(FInactive.Count);
+ if anIndex >= 0 then begin
+ { Yes. Grab the last one and remove it from the inactive list. }
+ aListItem := TffIntListItem(FInactive[anIndex]);
+ FInactive.RemoveAt(anIndex);
+ Result := TffPooledThread(aListItem.KeyAsInt);
+ end;
+
+ { If we didn't have an inactive thread, see if we can add a new thread.
+ Note: We do this outside the above try..finally block because GetFreeCount
+ must obtain read access to both thread lists. }
+ if not assigned(Result) then
+ if thpGetFreeCount > 0 then begin
+ Result := TffPooledThread.Create(Self);
+ aListItem := TffIntListItem.Create(longInt(Result));
+ end;
+
+ { Did we obtain a thread? }
+ if assigned(aListItem) then
+ { Yes. Add it to the active list. }
+ FActive.Insert(aListItem);
+ finally
+ FLock.Unlock;
+ end;
+
+
+end;
+{--------}
+procedure TffThreadPool.thpPutInQueue(aProcessEvent : TffThreadProcessEvent;
+ aProcessCookie: longInt);
+var
+ anItem : TffThreadRequestItem;
+begin
+ anItem := TffThreadRequestItem.Create(aProcessEvent, aProcessCookie);
+ with FPendingQueue.BeginWrite do
+ try
+ Enqueue(anItem);
+ finally
+ EndWrite;
+ end;
+end;
+{--------}
+procedure TffThreadPool.thpReturnThreadToPool(aThread : TffPooledThread);
+var
+ aCookie: longInt;
+ anEvent : TffThreadProcessEvent;
+ anItem : TffThreadRequestItem;
+ aListItem : TffIntListItem;
+ PendingRequest : boolean;
+begin
+ anEvent := nil;
+ aCookie := -1;
+
+ { Any pending requests? Note that we are assuming some minor risk here.
+ The pending queue should only have something in it if all threads
+ were busy. We can afford to check the queue's count without worrying
+ about thread-safeness because somebody will pick up the count sooner
+ or later. }
+ PendingRequest := False;
+ if FPendingQueue.Count > 0 then
+ with FPendingQueue.BeginWrite do
+ try
+ PendingRequest := (Count > 0);
+ { If we have a pending request then get it. }
+ if PendingRequest then begin
+ anItem := TffThreadRequestItem(FPendingQueue.Dequeue);
+ anEvent := anItem.ProcessEvent;
+ aCookie := anItem.ProcessCookie;
+ anItem.Free;
+ end;
+ finally
+ EndWrite;
+ end;
+
+ { If we had a pending request then handle it. }
+ if PendingRequest then
+ aThread.Process(anEvent, aCookie)
+ else begin
+ { Otherwise move this thread to the inactive threads list. }
+ FLock.Lock;
+ try
+ aListItem := TffIntListItem(FActive[FActive.Index(longInt(aThread))]);
+ FActive.Remove(longInt(aThread));
+ FInactive.Insert(aListItem);
+ finally
+ FLock.Unlock;
+ end;
+ end;
+end;
+{--------}
+procedure TffThreadPool.thpSetInitialCount(const aCount : integer);
+var
+ anIndex : integer;
+ anItem : TffIntListItem;
+ aThread : TffPooledThread;
+begin
+ if not (csDesigning in ComponentState) and (not FInitialized) and
+ (not FSkipInitial) then begin
+ FLock.Lock;
+ try
+ { Create the initial set of threads. }
+ for anIndex := 1 to aCount do begin
+ aThread := TffPooledThread.Create(Self);
+ anItem := TffIntListItem.Create(longInt(aThread));
+ FInactive.Insert(anItem);
+ end;
+ finally
+ FLock.Unlock;
+ end;
+ FInitialized := True;
+ end;
+ FInitialCount := aCount;
+end;
+{--------}
+procedure TffThreadPool.thpSetMaxCount(const aCount : integer);
+var
+ anIndex : integer;
+ aThread : TffPooledThread;
+ currCount : integer;
+ delCount : integer;
+begin
+ if not (csDesigning in ComponentState) and (not FSkipInitial) then begin
+ { If the maximum is now lower than our initial count then get rid
+ of some threads. }
+ currCount := FMaxCount - thpGetFreeCount;
+ if currCount > aCount then begin
+ { Figure out how many threads need to be deleted. }
+ delCount := currCount - aCount;
+ FLock.Lock;
+ try
+ for anIndex := 1 to delCount do
+ { We have to check the count. It is possible we need to
+ delete more threads than are in the inactive list. Because
+ we have the inactive list locked, any active threads that finish
+ can't add themselves back to the inactive list. So we will delete
+ what we can. }
+ if FInactive.Count > 0 then begin
+ aThread := TffPooledThread(TffIntListItem(FInactive[0]).KeyAsInt);
+ aThread.DieDieDie;
+ FInactive.DeleteAt(0);
+ end
+ else
+ break;
+ finally
+ FLock.Unlock;
+ end;
+ end;
+ end;
+ FMaxCount := aCount;
+end;
+
+{====================================================================}
+
+{===TffThreadRequestItem=============================================}
+constructor TffThreadRequestItem.Create(anEvent : TffThreadProcessEvent;
+ aCookie : longInt);
+begin
+ inherited Create;
+ FProcessEvent := anEvent;
+ FProcessCookie := aCookie;
+end;
+{====================================================================}
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffllunc.pas b/components/flashfiler/sourcelaz/ffllunc.pas
new file mode 100644
index 000000000..0458e6e78
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffllunc.pas
@@ -0,0 +1,150 @@
+{*********************************************************}
+{* FlashFiler: Conversion of drive:path to UNC names *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffllunc;
+
+interface
+
+uses
+ Windows,
+ Messages,
+ SysUtils,
+ ffllbase;
+
+function FFExpandUNCFileName(const FN : TffFullFileName) : TffFullFileName;
+
+implementation
+
+{===Win32 Helper routines============================================}
+function GetUniversalNameNT(const EFN : TffFullFileName) : TffFullFileName;
+var
+ BufSize : DWORD;
+ EFNZ : TffStringZ;
+ Buffer : array [0..1023] of byte;
+begin
+ FFStrPCopy(EFNZ, EFN);
+ BufSize := sizeof(Buffer);
+ if WNetGetUniversalName(EFNZ, UNIVERSAL_NAME_INFO_LEVEL,
+ @Buffer, BufSize) = NO_ERROR then
+ Result := FFStrPasLimit(PUniversalNameInfo(@Buffer).lpUniversalName,
+ pred(sizeof(TffFullFileName)))
+ else
+ Result := EFN;
+end;
+{--------}
+function GetUniversalName95(const EFN : TffFullFileName;
+ var UNC : TffFullFileName) : boolean;
+type
+ PNetResArray = ^TNetResArray;
+ TNetResArray = array [0..127] of TNetResource;
+var
+ chLocal : AnsiChar;
+ hEnum : THandle;
+ dwResult : DWORD;
+ cbBuffer : DWORD;
+ NetResource : PNetResArray;
+ dwSize : DWORD;
+ cEntries : DWORD;
+ i : integer;
+begin
+ {Note: according to Microsoft's article Q131416, the Windows 95
+ version of WNetGetUniversalName is broken, hence the funny
+ code (a pretty direct translation of MS's workaround using
+ length byte strings and try..finallys)}
+ Result := false;
+ // cursory validation
+ if (length(EFN) < 3) then
+ Exit;
+ // get the local drive letter
+ chLocal := UpCase(EFN[1]);
+ // more cursory validation
+ if (chLocal < 'A') or (chLocal > 'Z') or
+ (EFN[2] <> ':') or (EFN[3] <> '\' ) then
+ Exit;
+ {open a network enumeration}
+ if (WNetOpenEnum(RESOURCE_CONNECTED, RESOURCETYPE_DISK,
+ 0, nil, hEnum) <> NO_ERROR) then
+ Exit;
+ try
+ // start with a reasonable buffer size
+ cbBuffer := 50 * sizeof(TNetResource);
+ GetMem(NetResource, cbBuffer);
+ try
+ while true do begin
+ dwSize := cbBuffer;
+ cEntries := $7FFFFFFF;
+ dwResult := WNetEnumResource(hEnum, cEntries, NetResource, dwSize);
+ if (dwResult = ERROR_MORE_DATA) then begin
+ // the buffer was too small, enlarge
+ cbBuffer := dwSize;
+ ReallocMem(NetResource, cbBuffer);
+ continue;
+ end;
+ if (dwResult <> NO_ERROR) then
+ Exit;
+ // search for the specified drive letter
+ for i := 0 to pred(cEntries) do
+ with NetResource^[i] do
+ if (lpLocalName <> nil) and
+ (chLocal = UpCase(lpLocalName[0])) then begin
+ // match
+ Result := true;
+ // build a UNC name
+ UNC := FFStrPasLimit(lpRemoteName, pred(sizeof(TffFullFileName)));
+ FFShStrConcat(UNC, Copy(EFN, 3, 255));
+ Exit;
+ end;
+ end;
+ finally
+ FreeMem(NetResource, cbBuffer);
+ end;{try..finally}
+ finally
+ WNetCloseEnum(hEnum);
+ end;{try..finally}
+end;
+{--------}
+function GetUniversalName(const EFN : TffFullFileName) : TffFullFileName;
+begin
+ if (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) then begin
+ if not GetUniversalName95(EFN, Result) then
+ Result := EFN;
+ end
+ else
+ Result := GetUniversalNameNT(EFN);
+end;
+{====================================================================}
+
+function FFExpandUNCFileName(const FN : TffFullFileName) : TffFullFileName;
+begin
+ Result := GetUniversalName(FFExpandFileName(FN));
+end;
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffllwsck.pas b/components/flashfiler/sourcelaz/ffllwsck.pas
new file mode 100644
index 000000000..f1f08c035
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffllwsck.pas
@@ -0,0 +1,1383 @@
+{*********************************************************}
+{* FlashFiler: Low-level Winsock implementation *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+{$IFDEF CBuilder3}
+(*$HPPEMIT '' *)
+(*$HPPEMIT '#undef h_addr' *)
+(*$HPPEMIT '' *)
+{$ENDIF}
+
+{ Use the following DEFINE to force loading of Winsock 1 }
+{.$DEFINE ForceWinSock1}
+
+unit ffllwsck;
+
+interface
+
+uses
+ Classes,
+ Windows,
+ Messages,
+ SysUtils,
+ ffconst,
+ ffllwsct,
+ ffllbase,
+ ffsrmgr,
+ ffllexcp;
+
+{$R ffwscnst.res}
+
+const
+ ffwscEventComplete = WM_USER + $0FF1;
+
+{===Standard Winsock constants===}
+const
+ Fd_SETSIZE = 64;
+
+ IocPARM_MASK = $7F;
+ Ioc_VOID = $20000000;
+ Ioc_OUT = $40000000;
+ Ioc_IN = $80000000;
+ Ioc_INOUT = (Ioc_IN or Ioc_OUT);
+
+ { Protocols }
+
+ IpPROTO_IP = 0;
+ IpPROTO_ICMP = 1;
+ IpPROTO_GGP = 2;
+ IpPROTO_TCP = 6;
+ IpPROTO_PUP = 12;
+ IpPROTO_UDP = 17;
+ IpPROTO_IDP = 22;
+ IpPROTO_ND = 77;
+
+ IpPROTO_RAW = 255;
+ IpPROTO_MAX = 256;
+
+ { Port/socket numbers: network standard functions}
+
+ IpPORT_ECHO = 7;
+ IpPORT_DISCARD = 9;
+ IpPORT_SYSTAT = 11;
+ IpPORT_DAYTIME = 13;
+ IpPORT_NETSTAT = 15;
+ IpPORT_FTP = 21;
+ IpPORT_TELNET = 23;
+ IpPORT_SMTP = 25;
+ IpPORT_TIMESERVER = 37;
+ IpPORT_NAMESERVER = 42;
+ IpPORT_WHOIS = 43;
+ IpPORT_MTP = 57;
+
+ { Port/socket numbers: host specific functions }
+
+ IpPORT_TFTP = 69;
+ IpPORT_RJE = 77;
+ IpPORT_FINGER = 79;
+ IpPORT_TTYLINK = 87;
+ IpPORT_SUPDUP = 95;
+
+ { UNIX TCP sockets }
+
+ IpPORT_EXECSERVER = 512;
+ IpPORT_LOGINSERVER = 513;
+ IpPORT_CMDSERVER = 514;
+ IpPORT_EFSSERVER = 520;
+
+ { UNIX UDP sockets }
+
+ IpPORT_BIFFUDP = 512;
+ IpPORT_WHOSERVER = 513;
+ IpPORT_ROUTESERVER = 520;
+
+ { Ports < IPPORT_RESERVED are reserved for privileged processes (e.g. root). }
+
+ IpPORT_RESERVED = 1024;
+
+ { Link numbers }
+
+ ImpLINK_IP = 155;
+ ImpLINK_LOWEXPER = 156;
+ ImpLINK_HIGHEXPER = 158;
+
+ { Get # bytes to read }
+ FIoNREAD = Ioc_OUT or ((longint(SizeOf(longint)) and IocPARM_MASK) shl 16) or
+ (longint(Byte('f')) shl 8) or 127;
+
+ { Set/Clear non-blocking i/o }
+ FIoNBIO = Ioc_IN or((longint(SizeOf(longint)) and IocPARM_MASK) shl 16) or
+ (longint(Byte('f')) shl 8) or 126;
+
+ { Set/Clear async i/o }
+ FIoASYNC = Ioc_IN or ((longint(SizeOf(longint)) and IocPARM_MASK) shl 16) or
+ (longint(Byte('f')) shl 8) or 125;
+
+ InAddr_ANY = $00000000;
+ InAddr_LOOPBACK = $7F000001;
+ InAddr_BROADCAST = $FFFFFFFF;
+ InAddr_NONE = $FFFFFFFF;
+
+ WsaDESCRIPTION_LEN = 256;
+ WsaSYS_STATUS_LEN = 128;
+ WsaProtocolLen = 255;
+ WsaMaxProtocolChain = 7;
+
+ { Options for use with (get/set)sockopt at the IP level. }
+
+ Ip_OPTIONS = 1;
+ Ip_MULTICAST_IF = 2; { set/get IP multicast interface }
+ Ip_MULTICAST_TTL = 3; { set/get IP multicast timetolive }
+ Ip_MULTICAST_LOOP = 4; { set/get IP multicast loopback }
+ Ip_ADD_MEMBERSHIP = 5; { add an IP group membership }
+ Ip_DROP_MEMBERSHIP = 6; { drop an IP group membership }
+
+ Ip_DEFAULT_MULTICAST_TTL = 1; { normally limit m'casts to 1 hop }
+ Ip_DEFAULT_MULTICAST_LOOP = 1; { normally hear sends if a member }
+ Ip_MAX_MEMBERSHIPS = 20; { per socket; must fit in one mbuf }
+
+ Ipx_ADDRESS = $4007; { querying IPX info }
+
+ Invalid_SOCKET = -1;
+ Socket_ERROR = -1;
+
+ { Types }
+
+ Sock_STREAM = 1; { stream socket }
+ Sock_DGRAM = 2; { datagram socket }
+ Sock_RAW = 3; { raw-protocol interface }
+ Sock_RDM = 4; { reliably-delivered message }
+ Sock_SEQPACKET = 5; { sequenced packet stream }
+
+ { Option flags per-socket. }
+
+ So_DEBUG = $0001; { turn on debugging info recording }
+ So_ACCEPTCONN = $0002; { socket has had listen() }
+ So_REUSEADDR = $0004; { allow local address reuse }
+ So_KEEPALIVE = $0008; { keep connections alive }
+ So_DONTROUTE = $0010; { just use interface addresses }
+ So_BROADCAST = $0020; { permit sending of broadcast msgs }
+ So_USELOOPBACK = $0040; { bypass hardware when possible }
+ So_LINGER = $0080; { linger on close if data present }
+ So_OOBINLINE = $0100; { leave received OOB data in line }
+
+ So_DONTLINGER = $FF7F;
+
+ { Additional options. }
+
+ So_SNDBUF = $1001; { send buffer size }
+ So_RCVBUF = $1002; { receive buffer size }
+ So_SNDLOWAT = $1003; { send low-water mark }
+ So_RCVLOWAT = $1004; { receive low-water mark }
+ So_SNDTIMEO = $1005; { send timeout }
+ So_RCVTIMEO = $1006; { receive timeout }
+ So_ERROR = $1007; { get error status and clear }
+ So_TYPE = $1008; { get socket type }
+
+ { Options for connect and disconnect data and options. Used only by
+ non-TCP/IP transports such as DECNet, OSI TP4, etc. }
+
+ So_CONNDATA = $7000;
+ So_CONNOPT = $7001;
+ So_DISCDATA = $7002;
+ So_DISCOPT = $7003;
+ So_CONNDATALEN = $7004;
+ So_CONNOPTLEN = $7005;
+ So_DISCDATALEN = $7006;
+ So_DISCOPTLEN = $7007;
+
+ { Option for opening sockets for synchronous access. }
+
+ So_OPENTYPE = $7008;
+
+ So_SYNCHRONOUS_ALERT = $10;
+ So_SYNCHRONOUS_NONALERT = $20;
+
+ { Other NT-specific options. }
+
+ So_MAXDG = $7009;
+ So_MAXPATHDG = $700A;
+
+ { TCP options. }
+
+ TCP_NoDELAY = $0001;
+ TCP_BsdURGENT = $7000;
+
+ { Address families. }
+
+ Af_UNSPEC = 0; { unspecified }
+ Af_UNIX = 1; { local to host (pipes, portals) }
+ Af_INET = 2; { internetwork: UDP, TCP, etc. }
+ Af_IMPLINK = 3; { arpanet imp addresses }
+ Af_PUP = 4; { pup protocols: e.g. BSP }
+ Af_CHAOS = 5; { mit CHAOS protocols }
+ Af_IPX = 6; { IPX and SPX }
+ Af_NS = 6; { XEROX NS protocols }
+ Af_ISO = 7; { ISO protocols }
+ Af_OSI = Af_ISO; { OSI is ISO }
+ Af_ECMA = 8; { european computer manufacturers }
+ Af_DATAKIT = 9; { datakit protocols }
+ Af_CCITT = 10; { CCITT protocols, X.25 etc }
+ Af_SNA = 11; { IBM SNA }
+ Af_DECnet = 12; { DECnet }
+ Af_DLI = 13; { Direct data link interface }
+ Af_LAT = 14; { LAT }
+ Af_HYLINK = 15; { NSC Hyperchannel }
+ Af_APPLETALK = 16; { AppleTalk }
+ Af_NETBIOS = 17; { NetBios-style addresses }
+ Af_VOICEVIEW = 18; { VoiceView }
+ Af_MAX = 19;
+
+ { Protocol families, same as address families for now. }
+
+ Pf_UNSPEC = Af_UNSPEC;
+ Pf_UNIX = Af_UNIX;
+ Pf_INET = Af_INET;
+ Pf_IMPLINK = Af_IMPLINK;
+ Pf_PUP = Af_PUP;
+ Pf_CHAOS = Af_CHAOS;
+ Pf_NS = Af_NS;
+ Pf_IPX = Af_IPX;
+ Pf_ISO = Af_ISO;
+ Pf_OSI = Af_OSI;
+ Pf_ECMA = Af_ECMA;
+ Pf_DATAKIT = Af_DATAKIT;
+ Pf_CCITT = Af_CCITT;
+ Pf_SNA = Af_SNA;
+ Pf_DECnet = Af_DECnet;
+ Pf_DLI = Af_DLI;
+ Pf_LAT = Af_LAT;
+ Pf_HYLINK = Af_HYLINK;
+ Pf_APPLETALK = Af_APPLETALK;
+ Pf_VOICEVIEW = Af_VOICEVIEW;
+
+ Pf_MAX = Af_MAX;
+
+ { Level number for (get/set)sockopt() to apply to socket itself. }
+
+ Sol_SOCKET = $FFFF; {options for socket level }
+
+ { Maximum queue length specifiable by listen. }
+
+ SoMAXCONN = 5;
+
+ Msg_OOB = $1; {process out-of-band data }
+ Msg_PEEK = $2; {peek at incoming message }
+ Msg_DONTROUTE = $4; {send without using routing tables }
+
+ Msg_MAXIOVLEN = 16;
+
+ Msg_PARTIAL = $8000; {partial send or recv for message xport }
+
+ { Define constant based on rfc883, used by gethostbyxxxx() calls. }
+
+ MaxGETHOSTSTRUCT = 1024;
+
+ { Define flags to be used with the WSAAsyncSelect() call. }
+
+ Fd_READ = $01;
+ Fd_WRITE = $02;
+ Fd_OOB = $04;
+ Fd_ACCEPT = $08;
+ Fd_CONNECT = $10;
+ Fd_CLOSE = $20;
+
+ { Protocols for IPX/SPX }
+
+ NSPROTO_IPX = 1000;
+ NSPROTO_SPX = 1256;
+ NSPROTO_SPXII = 1257;
+
+type
+ EffWinsockException = class(EffCommsException)
+ public
+ constructor CreateTranslate(aErrorCode : integer;
+ aDummy : pointer);
+ end;
+
+{===FF Winsock types===}
+type
+ TffWinsockFamily = ( {the Winsock family types we support}
+ wfTCP, {..TCP/IP}
+ wfIPX); {..IPX/SPX}
+
+ TffWinsockFamilies = set of TffWinsockFamily;
+
+ { The following record type is used to track Winsock versions supported
+ by this module. }
+ TffWinsockVerRec = record
+ VerNum : Word;
+ ModuleName : array[0..12] of AnsiChar;
+ end;
+
+ TffwsWinsockVersion = (ffwvNone, ffwvWinSock1, ffwvWinSock2);
+ { Identifies the winsock version we have loaded in FFWSInstalled. }
+
+
+{===Standard Winsock types===}
+type
+ TffwsSocket = integer; {a Winsock socket}
+
+ PffwsFDSet = ^TffwsFDSet;
+ TffwsFDSet = packed record {an array of sockets}
+ fd_count : integer;
+ fd_array : array [0..pred(FD_SETSIZE)] of TffwsSocket;
+ end;
+
+ PffwsTimeVal = ^TffwsTimeVal;
+ TffwsTimeVal = packed record {a time value}
+ tv_sec : longint;
+ tv_usec : longint;
+ end;
+
+ PffwsHostEnt = ^TffwsHostEnt;
+ TffwsHostEnt = packed record {host entity}
+ h_name : PAnsiChar;
+ h_aliases : ^PAnsiChar;
+ h_addrtype: smallint;
+ h_length : smallint;
+ case byte of
+ 0: (h_addr_list: ^PAnsiChar);
+ 1: (h_Addr : ^PAnsiChar)
+ end;
+
+ PffwsNetEnt = ^TffwsNetEnt;
+ TffwsNetEnt = packed record {network entity}
+ n_name : PAnsiChar;
+ n_aliases : ^PAnsiChar;
+ n_addrtype: smallint;
+ n_net : longint;
+ end;
+
+ PffwsServEnt = ^TffwsServEnt;
+ TffwsServEnt = packed record {server entity}
+ s_name : PAnsiChar;
+ s_aliases: ^PAnsiChar;
+ s_port : smallint;
+ s_proto : PAnsiChar;
+ end;
+
+ PffwsProtoEnt = ^TffwsProtoEnt;
+ TffwsProtoEnt = packed record {protocol entity}
+ p_name : PAnsiChar;
+ p_aliases: ^PAnsiChar;
+ p_proto : smallint;
+ end;
+
+ PffwsInAddr = ^TffwsInAddr;
+ TffwsInAddr = TffWord32;
+
+ PffwsSockAddrIn = ^TffwsSockAddrIn;
+ TffwsSockAddrIn = packed record
+ sin_family: word;
+ sin_port : word;
+ sin_addr : TffwsInAddr;
+ sin_zero : array [0..7] of AnsiChar;
+ end;
+
+ PffwsIPXAddr = ^TffwsIPXAddr;
+ TffwsIPXAddr = array [0..5] of byte;
+
+ PffwsIPXNetNum = ^TffwsIPXNetNum;
+ TffwsIPXNetNum = array [0..3] of byte;
+
+ PffwsSockAddrIPX = ^TffwsSockAddrIPX;
+ TffwsSockAddrIPX = packed record
+ sipx_family : word;
+ sipx_netnum : TffwsIPXNetNum;
+ sipx_nodenum : TffwsIPXAddr;
+ sipx_socket : word;
+ end;
+
+ { Structure used by kernel to store most addresses. }
+ PffwsSockAddr = ^TffwsSockAddr;
+ TffwsSockAddr = record
+ case integer of
+ 0 : (TCP : TffwsSockAddrIn);
+ 1 : (IPX : TffwsSockAddrIPX);
+ end;
+
+ PffWSAData = ^TffWSAData;
+ TffWSAData = packed record
+ wVersion : word;
+ wHighVersion : word;
+ szDescription : array [0..WSADESCRIPTION_LEN] of AnsiChar;
+ szSystemStatus: array [0..WSASYS_STATUS_LEN] of AnsiChar;
+ iMaxSockets : word;
+ iMaxUdpDg : word;
+ lpVendorInfo : PAnsiChar;
+ end;
+
+ { Structure used by kernel to pass protocol information in raw sockets. }
+ PffwsSockProto = ^TffwsSockProto;
+ TffwsSockProto = packed record
+ sp_family : word;
+ sp_protocol : word;
+ end;
+
+ { Structure used for manipulating linger option. }
+ PffwsLinger = ^TffwsLinger;
+ TffwsLinger = packed record
+ l_onoff : word;
+ l_linger : word;
+ end;
+
+ {structure for querying IPX address info (from NWLINK.H)}
+ PffwsIPXAddrInfo = ^TffwsIPXAddrInfo;
+ TffwsIPXAddrInfo = packed record
+ adapternum : integer; {input: 0-based adapter number}
+ netnum : TffwsIPXNetNum; {output: IPX network number}
+ nodenum : TffwsIPXAddr; {output: IPX node address}
+ wan : boolean; {output: TRUE = adapter is on a wan link}
+ status : boolean; {output: TRUE = wan link is up (or adapter is not wan)}
+ maxpkt : integer; {output: max packet size, not including IPX header}
+ linkspeed : longint; {output: link speed in 100 bytes/sec (i.e. 96 == 9600)}
+ end;
+
+ TffwsProtocolChain = packed record
+ chainLen: Integer; { The length of the chain:
+ 0 -> layered protocol,
+ 1 -> base protocol,
+ > 1 -> protocol chain }
+ chainEntries: Array[0..WsaMaxProtocolChain - 1] of DWORD;
+ end;
+
+ { Structure for retrieving protocol information. }
+ PffwsProtocolInfo = ^TffwsProtocolInfo;
+ TffwsProtocolInfo = packed record
+ dwServiceFlags1: DWORD;
+ dwServiceFlags2: DWORD;
+ dwServiceFlags3: DWORD;
+ dwServiceFlags4: DWORD;
+ dwProviderFlags: DWORD;
+ ProviderId: TGUID;
+ dwCatalogEntryId: DWORD;
+ ProtocolChain: TffwsProtocolChain;
+ iVersion: Integer;
+ iAddressFamily: Integer;
+ iMaxSockAddr: Integer;
+ iMinSockAddr: Integer;
+ iSocketType: Integer;
+ iProtocol: Integer;
+ iProtocolMaxOffset: Integer;
+ iNetworkByteOrder: Integer;
+ iSecurityScheme: Integer;
+ dwMessageSize: DWORD;
+ dwProviderReserved: DWORD;
+ szProtocol: Array[0..WsaProtocolLen] of AnsiChar;
+ end;
+
+ { Socket function types }
+ tffwsrAccept =
+ function(S : TffwsSocket; var Addr : TffwsSockAddr; var Addrlen : integer) : TffwsSocket
+ stdcall;
+ tffwsrBind =
+ function(S : TffwsSocket; var Addr : TffwsSockAddr; NameLen : integer) : integer
+ stdcall;
+ tffwsrCloseSocket =
+ function(S : TffwsSocket) : integer
+ stdcall;
+ tffwsrConnect =
+ function(S : TffwsSocket; var Name : TffwsSockAddr; NameLen : integer) : integer
+ stdcall;
+ tffwsrEnumProtocols =
+ function( Protocols : PInteger; aBuffer : PffwsProtocolInfo;
+ var BufferLength : DWORD ) : Integer; stdcall;
+ tffwsrIOCtlSocket =
+ function(S : TffwsSocket; Cmd : longint; var Arg : longint) : integer
+ stdcall;
+ tffwsrGetPeerName =
+ function(S : TffwsSocket; var Name : TffwsSockAddr; var NameLen : integer): integer
+ stdcall;
+ tffwsrGetSockName =
+ function(S : TffwsSocket; var Name : TffwsSockAddr; var NameLen : integer): integer
+ stdcall;
+ tffwsrGetSockOpt =
+ function(S : TffwsSocket; Level, OptName : integer;
+ var OptVal; var OptLen: integer): integer
+ stdcall;
+ tffwsrhtonl =
+ function(HostLong : longint) : longint
+ stdcall;
+ tffwsrhtons =
+ function(HostShort : word) : word
+ stdcall;
+ tffwsrINet_Addr =
+ function(Cp : PAnsiChar) : dword {!!.11}
+ stdcall;
+ tffwsrINet_NtoA =
+ function(InAddr : TffwsInAddr) : PAnsiChar
+ stdcall;
+ tffwsrListen =
+ function(S : TffwsSocket; Backlog : integer) : integer
+ stdcall;
+ tffwsrntohl =
+ function(NetLong : longint) : longint
+ stdcall;
+ tffwsrntohs =
+ function(NetShort : word) : word
+ stdcall;
+ tffwsrRecv =
+ function(S : TffwsSocket; var Buf; Len, Flags : integer) : integer
+ stdcall;
+ tffwsrRecvFrom =
+ function(S : TffwsSocket; var Buf; Len, Flags : integer;
+ var From: TffwsSockAddr; var FromLen : integer) : integer
+ stdcall;
+ tffwsrSelect =
+ function(Nfds : integer; Readfds, Writefds,
+ Exceptfds : PffwsFDSet; Timeout : PffwsTimeVal) : longint
+ stdcall;
+ tffwsrSend =
+ function(S : TffwsSocket; var Buf; Len, Flags : integer) : integer
+ stdcall;
+ tffwsrSendTo =
+ function(S : TffwsSocket; var Buf; Len, Flags : integer;
+ var AddrTo : TffwsSockAddr; ToLen : integer) : integer
+ stdcall;
+ tffwsrSetSockOpt =
+ function(S : TffwsSocket; Level, OptName : integer;
+ var OptVal; OptLen : integer) : integer
+ stdcall;
+ tffwsrShutdown =
+ function(S : TffwsSocket; How : integer) : integer
+ stdcall;
+ tffwsrSocket =
+ function(Af, Struct, Protocol : integer) : TffwsSocket
+ stdcall;
+ tffwsrGetHostByAddr =
+ function(var Addr; Len, Struct : integer): PffwsHostEnt
+ stdcall;
+ tffwsrGetHostByName =
+ function(Name : PAnsiChar) : PffwsHostEnt
+ stdcall;
+ tffwsrGetHostName =
+ function(Name : PAnsiChar; Len : integer): integer
+ stdcall;
+ tffwsrGetServByPort =
+ function(Port : integer; Proto : PAnsiChar) : PffwsServEnt
+ stdcall;
+ tffwsrGetServByName =
+ function(Name, Proto : PAnsiChar) : PffwsServEnt
+ stdcall;
+ tffwsrGetProtoByNumber =
+ function(Proto : integer) : PffwsProtoEnt
+ stdcall;
+ tffwsrGetProtoByName =
+ function(Name : PAnsiChar) : PffwsProtoEnt
+ stdcall;
+ tffwsrWSAStartup =
+ function(wVersionRequired : word; var WSData : TffWSAData) : integer
+ stdcall;
+ tffwsrWSACleanup =
+ function : integer
+ stdcall;
+ tffwsrWSASetLastError =
+ procedure(iError : integer)
+ stdcall;
+ tffwsrWSAGetLastError =
+ function : integer
+ stdcall;
+ tffwsrWSAIsBlocking =
+ function : BOOL
+ stdcall;
+ tffwsrWSAUnhookBlockingHook =
+ function : integer
+ stdcall;
+ tffwsrWSASetBlockingHook =
+ function(lpBlockFunc : TFarProc) : TFarProc
+ stdcall;
+ tffwsrWSACancelBlockingCall =
+ function : integer
+ stdcall;
+ tffwsrWSAAsyncGetServByName =
+ function(HWindow : HWnd; wMsg : integer;
+ Name, Proto, Buf : PAnsiChar; BufLen : integer) : THandle
+ stdcall;
+ tffwsrWSAAsyncGetServByPort =
+ function(HWindow : HWnd; wMsg, Port : integer;
+ Proto, Buf : PAnsiChar; BufLen : integer) : THandle
+ stdcall;
+ tffwsrWSAAsyncGetProtoByName =
+ function(HWindow : HWnd; wMsg : integer;
+ Name, Buf : PAnsiChar; BufLen : integer) : THandle
+ stdcall;
+ tffwsrWSAAsyncGetProtoByNumber =
+ function(HWindow : HWnd; wMsg : integer; Number : integer;
+ Buf : PAnsiChar; BufLen : integer) : THandle
+ stdcall;
+ tffwsrWSAAsyncGetHostByName =
+ function(HWindow : HWnd; wMsg : integer;
+ Name, Buf : PAnsiChar; BufLen : integer) : THandle
+ stdcall;
+ tffwsrWSAAsyncGetHostByAddr =
+ function(HWindow : HWnd; wMsg : integer; Addr : PAnsiChar;
+ Len, Struct : integer; Buf : PAnsiChar; BufLen : integer) : THandle
+ stdcall;
+ tffwsrWSACancelAsyncRequest =
+ function(hAsyncTaskHandle : THandle) : integer
+ stdcall;
+ tffwsrWSAAsyncSelect =
+ function(S : TffwsSocket; HWindow : HWnd; wMsg : integer; lEvent : longint) : integer
+ stdcall;
+
+type
+ PffWinsockRoutines = ^TffWinsockRoutines;
+ TffWinsockRoutines = record {record of Winsock function pointers}
+ accept : tffwsrAccept;
+ bind : tffwsrBind;
+ closesocket : tffwsrCloseSocket;
+ connect : tffwsrConnect;
+ ioctlsocket : tffwsrIOCtlSocket;
+ getpeername : tffwsrGetPeerName;
+ getsockname : tffwsrGetSockName;
+ getsockopt : tffwsrGetSockOpt;
+ htonl : tffwsrhtonl;
+ htons : tffwsrhtons;
+ inet_addr : tffwsrINet_Addr;
+ inet_ntoa : tffwsrINet_Ntoa;
+ listen : tffwsrListen;
+ ntohl : tffwsrntohl;
+ ntohs : tffwsrntohs;
+ recv : tffwsrRecv;
+ recvfrom : tffwsrRecvFrom;
+ select : tffwsrSelect;
+ send : tffwsrSend;
+ sendTo : tffwsrSendTo;
+ setsockopt : tffwsrSetSockOpt;
+ shutdown : tffwsrShutdown;
+ socket : tffwsrSocket;
+ gethostbyaddr : tffwsrGetHostByAddr;
+ gethostbyname : tffwsrGetHostByName;
+ gethostname : tffwsrGetHostName;
+ getservbyport : tffwsrGetServByPort;
+ getservbyname : tffwsrGetServByName;
+ getprotobynumber : tffwsrGetProtoByNumber;
+ getprotobyname : tffwsrGetProtoByName;
+ WSAStartup : tffwsrWSAStartup;
+ WSACleanup : tffwsrWSACleanup;
+ WSAEnumProtocols : tffwsrEnumProtocols;
+ WSASetLastError : tffwsrWSASetLastError;
+ WSAGetLastError : tffwsrWSAGetLastError;
+ WSAIsBlocking : tffwsrWSAIsBlocking;
+ WSAUnhookBlockingHook : tffwsrWSAUnhookBlockingHook;
+ WSASetBlockingHook : tffwsrWSASetBlockingHook;
+ WSACancelBlockingCall : tffwsrWSACancelBlockingCall;
+ WSAAsyncGetServByName : tffwsrWSAAsyncGetServByName;
+ WSAAsyncGetServByPort : tffwsrWSAAsyncGetServByPort;
+ WSAAsyncGetProtoByName : tffwsrWSAAsyncGetProtoByName;
+ WSAAsyncGetProtoByNumber : tffwsrWSAAsyncGetProtoByNumber;
+ WSAAsyncGetHostByName : tffwsrWSAAsyncGetHostByName;
+ WSAAsyncGetHostByAddr : tffwsrWSAAsyncGetHostByAddr;
+ WSACancelAsyncRequest : tffwsrWSACancelAsyncRequest;
+ WSAAsyncSelect : tffwsrWSAAsyncSelect;
+ end;
+
+var
+ WinsockRoutines : TffWinsockRoutines;
+ ffwsFamiliesInstalled : TffWinsockFamilies;
+
+function FFWSInstalled : boolean;
+ {-Returns true if Winsock is installed}
+
+function WSAMakeSyncReply(Buflen, Error : word) : longint;
+ {-Construct the response to a WSAAsyncGetXByY routine}
+function WSAMakeSelectReply(Event, Error : word) : longint;
+ {-Construct the response to WSAAsyncSelect}
+function WSAGetAsyncBuflen(lParam : longint) : integer;
+ {-Extract the buffer length from lParam in response to a WSAGetXByY}
+function WSAGetAsyncError(lParam : longint) : integer;
+ {-Extract the error from lParam in response to a WSAGetXByY}
+function WSAGetSelectEvent(lParam : longint) : integer;
+ {-Extract the event from lParam in response to a WSAAsyncSelect}
+function WSAGetSelectError(lParam : longint) : integer;
+ {-Extract the error from lParam in response to a WSAAsyncSelect}
+
+{===FlashFiler helper routines===}
+procedure FFWSAsyncSelect(aSocket : TffwsSocket;
+ aWindow : HWnd;
+ aEvent : longint);
+function FFWSCreateSocket(aAF, aStruct, aProtocol : integer) : TffwsSocket;
+function FFWSCvtAddrToStr(aAddr : TffwsInAddr) : TffNetName;
+function FFWSCvtIPXAddrToStr(const aNetNum : TffwsIPXNetNum;
+ const aAddr : TffwsIPXAddr) : TffNetName;
+function FFWSCvtStrToAddr(aStr : TffNetName; var aAddr : TffwsInAddr) : boolean;
+function FFWSCvtStrToIPXAddr(const aStr : TffNetName;
+ var aNetNum : TffwsIPXNetNum;
+ var aAddr : TffwsIPXAddr) : boolean;
+procedure FFWSDestroySocket(aSocket : TffwsSocket);
+function FFWSGetLocalHosts(aList : TStrings) : Boolean;
+function FFWSGetLocalHostByNum(const NIC : Integer;
+ var aNetName : TffNetName;
+ var aAddr : TffwsInAddr) : Boolean;
+function FFWSGetLocalIPXAddr(var aNetNum : TffwsIPXNetNum;
+ var aAddr : TffwsIPXAddr) : boolean;
+function FFWSGetRemoteHost(const aName : TffNetName;
+ var aNetName : TffNetName; var aAddr : TffwsInAddr) : boolean;
+function FFWSGetRemoteNameFromAddr(aAddr : TffwsInAddr) : TffNetName;
+procedure FFWSGetSocketOption(aSocket : TffwsSocket; aLevel, aOptName : integer;
+ var aOptValue; aOptValueLen : integer);
+procedure FFWSSetSocketOption(aSocket : TffwsSocket; aLevel, aOptName : integer;
+ var aOptValue; aOptValueLen : integer);
+
+const
+ ffcNumWinsockVersions = 2;
+ { Number of supported Winsock versions. }
+
+var
+ ffStrResWinsock : TffStringResource; {in FFWSCNST.RC}
+
+ { This array defines the Winsock versions supported by this module. }
+ ffWinsockVerArray : array[1..ffcNumWinsockVersions] of TffWinsockVerRec =
+ ((VerNum : $0101; ModuleName : 'wsock32.dll'), { WinSock 1 }
+ (VerNum : $0202; ModuleName : 'ws2_32.dll')); { WinSock 2 }
+
+
+implementation
+
+var
+ UnitInitializationDone : boolean;
+ ffwsLoadedWinsockVersion : TffwsWinsockVersion;
+ WSLibHandle : THandle;
+ LockFFWSInstalled : TRTLCriticalSection;
+
+{===EffWinsockException==============================================}
+constructor EffWinsockException.CreateTranslate(aErrorCode : integer;
+ aDummy : pointer);
+var
+ ErrorMsg : TffShStr;
+begin
+ ErrorMsg := ffStrResWinsock[aErrorCode];
+ inherited CreateEx(ffStrResGeneral, fferrWinsock, [aErrorCode, aErrorCode, ErrorMsg]);
+end;
+{===Macro expansion==================================================}
+function WSAMakeSyncReply(Buflen, Error : word) : longint;
+register;
+asm
+ movzx eax, ax
+ shl edx, 16
+ or eax, edx
+end;
+{--------}
+function WSAMakeSelectReply(Event, Error : word) : longint;
+register;
+asm
+ movzx eax, ax
+ shl edx, 16
+ or eax, edx
+end;
+{--------}
+function WSAGetAsyncBuflen(lParam : longint) : integer;
+register;
+asm
+ and eax, $0000FFFF
+end;
+{--------}
+function WSAGetAsyncError(lParam : longint) : integer;
+register;
+asm
+ shr eax, 16
+end;
+{--------}
+function WSAGetSelectEvent(lParam : longint) : integer;
+register;
+asm
+ and eax, $0000FFFF
+end;
+{--------}
+function WSAGetSelectError(lParam : longint) : integer;
+register;
+asm
+ shr eax, 16
+end;
+{====================================================================}
+
+
+{===Unit initialization/finalization=================================}
+function FFWSInstalled : boolean;
+const
+ ffcMaxProtoInfoRecords = 15;
+var
+ aBuffer : PChar;
+ pBuffer : PffwsProtocolInfo absolute aBuffer;
+ aCode : HFile;
+ aCount : integer;
+ aFile : TOFStruct;
+ anError : integer;
+ anIndex : integer;
+ anOffset : integer;
+ aProtocolInfo : PffwsProtocolInfo;
+ aSize : DWORD;
+ aVersion : integer;
+ WSData : TffWSAData;
+begin
+ EnterCriticalSection(LockFFWSInstalled);
+ try
+ Result := (ffwsLoadedWinsockVersion <> ffwvNone);
+
+ { If this routine has already been called, exit. }
+ if UnitInitializationDone then
+ Exit;
+ { No matter what happens next, we've initialized. }
+ UnitInitializationDone := true;
+ ffwsLoadedWinsockVersion := ffwvNone;
+ aVersion := 0;
+
+ { Load the Winsock DLL. Note that we try to load the most recent
+ Winsock version first. }
+ for anIndex := ffcNumWinsockVersions downto 1 do begin
+
+ {$IFDEF ForceWinSock1}
+ if anIndex <> 1 then Continue;
+ {$ENDIF}
+
+ { Check to see if the file exists before trying to load it }
+ aCode := OpenFile(ffWinsockVerArray[anIndex].ModuleName, aFile, OF_EXIST);
+ if aCode = HFILE_ERROR then Continue;
+
+ { If we get this far, we should have a good module -- load it }
+ WSLibHandle := LoadLibrary(ffWinsockVerArray[anIndex].ModuleName);
+ if WSLibHandle <> 0 then begin
+ aVersion := anIndex;
+ break;
+ end;
+
+ end;
+
+ if (WSLibHandle = 0) then
+ Exit;
+ {load and validate all pointers}
+ @WinsockRoutines.accept := GetProcAddress(WSLibHandle, 'accept');
+ if not Assigned(WinsockRoutines.accept) then Exit;
+
+ @WinsockRoutines.bind := GetProcAddress(WSLibHandle, 'bind');
+ if not Assigned(WinsockRoutines.bind) then Exit;
+
+ @WinsockRoutines.closesocket := GetProcAddress(WSLibHandle, 'closesocket');
+ if not Assigned(WinsockRoutines.closesocket) then Exit;
+
+ @WinsockRoutines.connect := GetProcAddress(WSLibHandle, 'connect');
+ if not Assigned(WinsockRoutines.connect) then Exit;
+
+ @WinsockRoutines.getpeername := GetProcAddress(WSLibHandle, 'getpeername');
+ if not Assigned(WinsockRoutines.getpeername) then Exit;
+
+ @WinsockRoutines.getsockname := GetProcAddress(WSLibHandle, 'getsockname');
+ if not Assigned(WinsockRoutines.getsockname) then Exit;
+
+ @WinsockRoutines.getsockopt := GetProcAddress(WSLibHandle, 'getsockopt');
+ if not Assigned(WinsockRoutines.getsockopt) then Exit;
+
+ @WinsockRoutines.htonl := GetProcAddress(WSLibHandle, 'htonl');
+ if not Assigned(WinsockRoutines.htonl) then Exit;
+
+ @WinsockRoutines.htons := GetProcAddress(WSLibHandle, 'htons');
+ if not Assigned(WinsockRoutines.htons) then Exit;
+
+ @WinsockRoutines.inet_addr := GetProcAddress(WSLibHandle, 'inet_addr');
+ if not Assigned(WinsockRoutines.inet_addr) then Exit;
+
+ @WinsockRoutines.inet_ntoa := GetProcAddress(WSLibHandle, 'inet_ntoa');
+ if not Assigned(WinsockRoutines.inet_ntoa) then Exit;
+
+ @WinsockRoutines.ioctlsocket := GetProcAddress(WSLibHandle, 'ioctlsocket');
+ if not Assigned(WinsockRoutines.ioctlsocket) then Exit;
+
+ @WinsockRoutines.listen := GetProcAddress(WSLibHandle, 'listen');
+ if not Assigned(WinsockRoutines.listen) then Exit;
+
+ @WinsockRoutines.ntohl := GetProcAddress(WSLibHandle, 'ntohl');
+ if not Assigned(WinsockRoutines.ntohl) then Exit;
+
+ @WinsockRoutines.ntohs := GetProcAddress(WSLibHandle, 'ntohs');
+ if not Assigned(WinsockRoutines.ntohs) then Exit;
+
+ @WinsockRoutines.recv := GetProcAddress(WSLibHandle, 'recv');
+ if not Assigned(WinsockRoutines.recv) then Exit;
+
+ @WinsockRoutines.recvfrom := GetProcAddress(WSLibHandle, 'recvfrom');
+ if not Assigned(WinsockRoutines.recvfrom) then Exit;
+
+ @WinsockRoutines.select := GetProcAddress(WSLibHandle, 'select');
+ if not Assigned(WinsockRoutines.select) then Exit;
+
+ @WinsockRoutines.send := GetProcAddress(WSLibHandle, 'send');
+ if not Assigned(WinsockRoutines.send) then Exit;
+
+ @WinsockRoutines.sendto := GetProcAddress(WSLibHandle, 'sendto');
+ if not Assigned(WinsockRoutines.sendto) then Exit;
+
+ @WinsockRoutines.setsockopt := GetProcAddress(WSLibHandle, 'setsockopt');
+ if not Assigned(WinsockRoutines.setsockopt) then Exit;
+
+ @WinsockRoutines.shutdown := GetProcAddress(WSLibHandle, 'shutdown');
+ if not Assigned(WinsockRoutines.shutdown) then Exit;
+
+ @WinsockRoutines.socket := GetProcAddress(WSLibHandle, 'socket');
+ if not Assigned(WinsockRoutines.socket) then Exit;
+
+ @WinsockRoutines.gethostbyaddr := GetProcAddress(WSLibHandle, 'gethostbyaddr');
+ if not Assigned(WinsockRoutines.gethostbyaddr) then Exit;
+
+ @WinsockRoutines.gethostbyname := GetProcAddress(WSLibHandle, 'gethostbyname');
+ if not Assigned(WinsockRoutines.gethostbyname) then Exit;
+
+ @WinsockRoutines.gethostname := GetProcAddress(WSLibHandle, 'gethostname');
+ if not Assigned(WinsockRoutines.gethostname) then Exit;
+
+ @WinsockRoutines.getservbyport := GetProcAddress(WSLibHandle, 'getservbyport');
+ if not Assigned(WinsockRoutines.getservbyport) then Exit;
+
+ @WinsockRoutines.getservbyname := GetProcAddress(WSLibHandle, 'getservbyname');
+ if not Assigned(WinsockRoutines.getservbyname) then Exit;
+
+ @WinsockRoutines.getprotobynumber := GetProcAddress(WSLibHandle, 'getprotobynumber');
+ if not Assigned(WinsockRoutines.getprotobynumber) then Exit;
+
+ @WinsockRoutines.getprotobyname := GetProcAddress(WSLibHandle, 'getprotobyname');
+ if not Assigned(WinsockRoutines.getprotobyname) then Exit;
+
+ @WinsockRoutines.WSAStartup := GetProcAddress(WSLibHandle, 'WSAStartup');
+ if not Assigned(WinsockRoutines.WSAStartup) then Exit;
+
+ @WinsockRoutines.WSACleanup := GetProcAddress(WSLibHandle, 'WSACleanup');
+ if not Assigned(WinsockRoutines.WSACleanup) then Exit;
+
+ if aVersion > 1 then begin
+ @WinsockRoutines.WSAEnumProtocols := GetProcAddress(WSLibHandle, 'WSAEnumProtocolsA');
+ if not Assigned(WinsockRoutines.WSAEnumProtocols) then Exit;
+ end;
+
+ @WinsockRoutines.WSASetLastError := GetProcAddress(WSLibHandle, 'WSASetLastError');
+ if not Assigned(WinsockRoutines.WSASetLastError) then Exit;
+
+ @WinsockRoutines.WSAGetLastError := GetProcAddress(WSLibHandle, 'WSAGetLastError');
+ if not Assigned(WinsockRoutines.WSAGetLastError) then Exit;
+
+ @WinsockRoutines.WSAIsBlocking := GetProcAddress(WSLibHandle, 'WSAIsBlocking');
+ if not Assigned(WinsockRoutines.WSAIsBlocking) then Exit;
+
+ @WinsockRoutines.WSAUnhookBlockingHook := GetProcAddress(WSLibHandle, 'WSAUnhookBlockingHook');
+ if not Assigned(WinsockRoutines.WSAUnhookBlockingHook) then Exit;
+
+ @WinsockRoutines.WSASetBlockingHook := GetProcAddress(WSLibHandle, 'WSASetBlockingHook');
+ if not Assigned(WinsockRoutines.WSASetBlockingHook) then Exit;
+
+ @WinsockRoutines.WSACancelBlockingCall := GetProcAddress(WSLibHandle, 'WSACancelBlockingCall');
+ if not Assigned(WinsockRoutines.WSACancelBlockingCall) then Exit;
+
+ @WinsockRoutines.WSAAsyncGetServByName := GetProcAddress(WSLibHandle, 'WSAAsyncGetServByName');
+ if not Assigned(WinsockRoutines.WSAAsyncGetServByName) then Exit;
+
+ @WinsockRoutines.WSAAsyncGetServByPort := GetProcAddress(WSLibHandle, 'WSAAsyncGetServByPort');
+ if not Assigned(WinsockRoutines.WSAAsyncGetServByPort) then Exit;
+
+ @WinsockRoutines.WSAAsyncGetProtoByName := GetProcAddress(WSLibHandle, 'WSAAsyncGetProtoByName');
+ if not Assigned(WinsockRoutines.WSAAsyncGetProtoByName) then Exit;
+
+ @WinsockRoutines.WSAAsyncGetProtoByNumber := GetProcAddress(WSLibHandle, 'WSAAsyncGetProtoByNumber');
+ if not Assigned(WinsockRoutines.WSAAsyncGetProtoByNumber) then Exit;
+
+ @WinsockRoutines.WSAAsyncGetHostByName := GetProcAddress(WSLibHandle, 'WSAAsyncGetHostByName');
+ if not Assigned(WinsockRoutines.WSAAsyncGetHostByName) then Exit;
+
+ @WinsockRoutines.WSAAsyncGetHostByAddr := GetProcAddress(WSLibHandle, 'WSAAsyncGetHostByAddr');
+ if not Assigned(WinsockRoutines.WSAAsyncGetHostByAddr) then Exit;
+
+ @WinsockRoutines.WSACancelAsyncRequest := GetProcAddress(WSLibHandle, 'WSACancelAsyncRequest');
+ if not Assigned(WinsockRoutines.WSACancelAsyncRequest) then Exit;
+
+ @WinsockRoutines.WSAAsyncSelect := GetProcAddress(WSLibHandle, 'WSAAsyncSelect');
+ if not Assigned(WinsockRoutines.WSAAsyncSelect) then Exit;
+
+ { If we got here then we have succeeded. }
+ if (WinsockRoutines.WSAStartup
+ (ffWinsockVerArray[aVersion].VerNum, WSData) = 0) then begin
+ ffwsLoadedWinsockVersion := TffwsWinsockVersion(aVersion);
+
+ { Determine which winsock families are installed. Allocate a buffer that
+ will hold several protocol records. }
+ if aVersion > 1 then begin
+ ffwsFamiliesInstalled := [];
+ { Allocate a buffer that we know is too small. }
+ aSize := sizeOf(TffwsProtocolInfo);
+ FFGetMem(aBuffer, 32);
+ try
+ Fillchar(aBuffer^, 32, 0);
+ aSize := 0;
+ aCount := WinsockRoutines.WSAEnumProtocols(nil, pBuffer, aSize);
+ if aCount < 0 then begin
+ anError := WinsockRoutines.WSAGetLastError;
+ if anError = WSAENOBUFS then begin
+ FFFreeMem(aBuffer, 32);
+ FFGetMem(aBuffer, aSize);
+ fillChar(aBuffer^, aSize, 0);
+ aCount := WinsockRoutines.WSAEnumProtocols(nil, pBuffer, aSize);
+ end;
+ end;
+ if aCount > 0 then begin
+ anOffset := 0;
+ for anIndex := 1 to aCount do begin
+ { Grab the record. }
+ aProtocolInfo := @(aBuffer[anOffset]);
+
+ { Is it a family we care about? }
+ case aProtocolInfo^.iAddressFamily of
+ Af_INET : include(ffwsFamiliesInstalled, wfTCP);
+ Af_IPX : include(ffwsFamiliesInstalled, wfIPX);
+ end; { case }
+
+ { Position to the next record. }
+ inc(anOffset, sizeOf(TffwsProtocolInfo));
+ end;
+ end;
+ finally
+ if aSize > 0 then
+ FFFreemem(aBuffer, aSize)
+ else
+ FFFreemem(aBuffer, 32);
+ end;
+ end
+ else begin
+ { Winsock 1: Assume all families supported. }
+ ffwsFamiliesInstalled := [wfTCP, wfIPX];
+ end;
+ end;
+
+ finally
+ LeaveCriticalSection(LockFFWSInstalled);
+ end;
+ Result := (ffwsLoadedWinsockVersion <> ffwvNone);
+end;
+{--------}
+procedure FinalizeUnit;
+begin
+ ffStrResWinsock.Free;
+ DeleteCriticalSection(LockFFWSInstalled);
+ if UnitInitializationDone then begin
+ if (WSLibHandle <> 0) then begin
+ if (ffwsLoadedWinsockVersion <> ffwvNone) then
+ WinsockRoutines.WSACleanUp;
+ FreeLibrary(WSLibHandle);
+ end;
+ end;
+end;
+{====================================================================}
+
+
+{===FlashFiler helper routines=======================================}
+procedure FFWSAsyncSelect(aSocket : TffwsSocket;
+ aWindow : HWnd;
+ aEvent : longint);
+var
+ Error : integer;
+begin
+ if (WinsockRoutines.WSAAsyncSelect(aSocket, aWindow,
+ ffwscEventComplete, aEvent) = SOCKET_ERROR) then begin
+ Error := WinsockRoutines.WSAGetLastError;
+ raise EffWinsockException.CreateTranslate(Error, nil);
+ end;
+end;
+{--------}
+function FFWSCreateSocket(aAF, aStruct, aProtocol : integer) : TffwsSocket;
+var
+ Error : integer;
+begin
+ Result := WinsockRoutines.socket(aAF, aStruct, aProtocol);
+ if (Result = INVALID_SOCKET) then begin
+ Error := WinsockRoutines.WSAGetLastError;
+ raise EffWinsockException.CreateTranslate(Error, nil);
+ end;
+end;
+{--------}
+function FFWSCvtAddrToStr(aAddr : TffwsInAddr) : TffNetName;
+begin
+ Result := FFStrPas(WinsockRoutines.inet_ntoa(aAddr));
+end;
+{--------}
+function FFWSCvtIPXAddrToStr(const aNetNum : TffwsIPXNetNum;
+ const aAddr : TffwsIPXAddr) : TffNetName;
+const
+ HexChars : string[16] = '0123456789ABCDEF';
+var
+ i, j : integer;
+begin
+{Begin !!.03}
+{$IFDEF IsDelphi}
+ Result[0] := chr((2 * sizeof(TffwsIPXNetNum)) +
+ 1 +
+ (2 * sizeof(TffwsIPXAddr)) +
+ 5);
+{$ELSE}
+ SetLength(Result, (2 * sizeof(TffwsIPXNetNum)) + 1 +
+ (2 * sizeof(TffwsIPXAddr)) + 5);
+{$ENDIF}
+{End !!.03}
+ j := 0;
+ for i := 0 to pred(sizeof(TffwsIPXNetNum)) do begin
+ Result[j+1] := HexChars[(aNetNum[i] shr 4) + 1];
+ Result[j+2] := HexChars[(aNetNum[i] and $F) + 1];
+ inc(j, 2);
+ end;
+ inc(j);
+ Result[j] := ':';
+ for i := 0 to pred(sizeof(TffwsIPXAddr)) do begin
+ if (i <> 0) then
+ Result[j] := '-';
+ Result[j+1] := HexChars[(aAddr[i] shr 4) + 1];
+ Result[j+2] := HexChars[(aAddr[i] and $F) + 1];
+ inc(j, 3);
+ end;
+end;
+{--------}
+function FFWSCvtStrToAddr(aStr : TffNetName; var aAddr : TffwsInAddr) : boolean;
+var
+ StrZ : TffStringZ;
+begin
+ FFStrPCopy(StrZ, aStr);
+ aAddr := TffWord32(WinsockRoutines.inet_addr(StrZ));
+ Result := (aAddr <> INADDR_NONE);
+end;
+{--------}
+function FFWSCvtStrToIPXAddr(const aStr : TffNetName;
+ var aNetNum : TffwsIPXNetNum;
+ var aAddr : TffwsIPXAddr) : boolean;
+var
+ i, j : integer;
+ Nibble : integer;
+ Ch : char;
+ DoUpper : boolean;
+ DoNetNum: boolean;
+begin
+ Nibble := 0;
+ Result := false;
+ j := 0;
+ DoNetNum := true;
+ DoUpper := true;
+ for i := 1 to length(aStr) do begin
+ Ch := upcase(aStr[i]);
+ if ('0' <= Ch) and (Ch <= '9') then
+ Nibble := ord(Ch) - ord('0')
+ else if ('A' <= Ch) and (Ch <= 'F') then
+ Nibble := ord(Ch) - ord('A') + 10
+ else if (Ch <> '-') and (Ch <> ':') then
+ Exit;
+ if (Ch = '-') or (Ch = ':') then begin
+ if DoNetNum then
+ j := 0;
+ DoNetNum := false;
+ DoUpper := true;
+ end
+ else
+ if DoUpper then begin
+ if DoNetNum then
+ aNetNum[j] := Nibble shl 4
+ else
+ aAddr[j] := Nibble shl 4;
+ DoUpper := false;
+ end
+ else begin
+ if DoNetNum then
+ aNetNum[j] := aNetNum[j] or Nibble
+ else
+ aAddr[j] := aAddr[j] or Nibble;
+ inc(j);
+ DoUpper := true;
+ end;
+ end;
+ Result := true;
+end;
+{--------}
+procedure FFWSDestroySocket(aSocket : TffwsSocket);
+begin
+ if (aSocket <> INVALID_SOCKET) then begin
+ WinsockRoutines.shutdown(aSocket, 2);
+ WinsockRoutines.closesocket(aSocket);
+ end;
+end;
+{--------}
+function FFWSGetLocalHosts(aList : TStrings) : Boolean;
+type
+ TaPInAddr = array [0..255] of PFFWord32;
+ PaPInAddr = ^TaPInAddr;
+var
+ ZStr : TffStringZ;
+ HostEnt : PffwsHostEnt;
+ IPAddress : TffNetName;
+ pptr : PaPInAddr;
+ Idx : Integer;
+
+begin
+ aList.BeginUpdate;
+ try
+ aList.Clear;
+ aList.Add('');
+ Result := False;
+ if (WinsockRoutines.gethostname(ZStr, SizeOf(ZStr)) = 0) then begin
+ HostEnt := WinsockRoutines.gethostbyname(ZStr);
+ if Assigned(HostEnt) then begin
+ pptr := PaPInAddr(HostEnt^.h_addr_list);
+ Idx := 0;
+ while Assigned(pptr^[Idx]) do begin
+ {pptr is assigned if any winsock based protocol is installed}
+ {When IPX/SPX is installed, and TCP/IP is an IP address still
+ is returned. We must filter this out.}
+ IPAddress := FFWSCvtAddrToStr(pptr^[Idx]^);
+ if IPAddress <> '127.0.0.1' then
+ aList.Add(Format('Adapter %D: %S', [Idx, IPAddress]));
+ Inc(Idx);
+ end;
+ Result := true;
+ end;
+ end;
+ finally
+ aList.EndUpdate;
+ end;
+end;
+{--------}
+function FFWSGetLocalHostByNum(const NIC : Integer;
+ var aNetName : TffNetName;
+ var aAddr : TffwsInAddr) : Boolean;
+type
+ TaPInAddr = array [0..255] of PffWord32;
+ PaPInAddr = ^TaPInAddr;
+var
+ ZStr : TffStringZ;
+ HostEnt : PffwsHostEnt;
+ pptr : PaPInAddr;
+begin
+ Result := False;
+ if (WinsockRoutines.gethostname(ZStr, SizeOf(ZStr)) = 0) then begin
+ HostEnt := WinsockRoutines.gethostbyname(ZStr);
+ if Assigned(HostEnt) then begin
+ pptr := PaPInAddr(HostEnt^.h_addr_list);
+ if NIC = -1 then begin
+ aNetName := FFStrPasLimit(HostEnt^.h_name, pred(sizeof(TffNetName)));
+ aAddr := InAddr_ANY;
+ Result := True;
+ end else begin
+ if Assigned(pptr^[NIC]) then begin
+ aNetName := FFStrPasLimit(HostEnt^.h_name, Pred(SizeOf(TffNetName)));
+ aAddr:= pptr^[NIC]^;
+ Result := True;
+ end;
+ end;
+ end;
+ end;
+end;
+{--------}
+function FFWSGetLocalIPXAddr(var aNetNum : TffwsIPXNetNum;
+ var aAddr : TffwsIPXAddr) : boolean;
+var
+ Addr : TffwsSockAddr;
+ IPXInfo : TffwsIPXAddrInfo;
+ S : TffwsSocket;
+begin
+ // Create IPX socket.
+ S := FFWSCreateSocket(AF_IPX, SOCK_DGRAM, NSPROTO_IPX);
+ // Socket must be bound prior to calling IPX_ADDRESS
+ FillChar(Addr, sizeof(Addr), 0);
+ Addr.IPX.sipx_family := AF_IPX;
+ WinsockRoutines.bind(S, Addr, sizeof(TffwsSockAddrIPX));
+ // Specify which adapter to check.
+ FillChar(IPXInfo, sizeof(IPXInfo), 0);
+ IPXInfo.adapternum := 0;
+ FFWSGetSocketOption(S, NSPROTO_IPX, IPX_ADDRESS, IPXInfo, sizeof(IPXInfo));
+ aNetNum := IPXInfo.netnum;
+ aAddr := IPXInfo.nodenum;
+ Result := true;
+ // Destroy IPX socket.
+ FFWSDestroySocket(S);
+end;
+{--------}
+function FFWSGetRemoteHost(const aName : TffNetName;
+ var aNetName : TffNetName; var aAddr : TffwsInAddr) : boolean;
+var
+ ZStr : TffStringZ;
+ HostEnt : PffwsHostEnt;
+begin
+ HostEnt := WinsockRoutines.gethostbyname(FFStrPCopy(ZStr, aName));
+ if (HostEnt = nil) then
+ Result := false
+ else begin
+ aAddr := PffwsInAddr((HostEnt^.h_addr)^)^;
+ aNetName := FFStrPasLimit(HostEnt^.h_name, pred(sizeof(TffNetName)));
+ Result := true;
+ end;
+end;
+{--------}
+function FFWSGetRemoteNameFromAddr(aAddr : TffwsInAddr) : TffNetName;
+var
+ HostEnt : PffwsHostEnt;
+begin
+ HostEnt := WinsockRoutines.gethostbyaddr(aAddr, sizeof(aAddr), PF_INET);
+ if (HostEnt = nil) then
+ Result := ''
+ else
+ Result := FFStrPasLimit(HostEnt^.h_name, pred(sizeof(TffNetName)));
+end;
+{--------}
+procedure FFWSGetSocketOption(aSocket : TffwsSocket; aLevel, aOptName : integer;
+ var aOptValue; aOptValueLen : integer);
+var
+ Error : integer;
+begin
+ Error := WinsockRoutines.getsockopt(aSocket, aLevel, aOptName, aOptValue, aOptValueLen);
+ if (Error = SOCKET_ERROR) then begin
+ Error := WinsockRoutines.WSAGetLastError;
+ raise EffWinsockException.CreateTranslate(Error, nil);
+ end;
+end;
+{--------}
+procedure FFWSSetSocketOption(aSocket : TffwsSocket; aLevel, aOptName : integer;
+ var aOptValue; aOptValueLen : integer);
+var
+ Error : integer;
+begin
+ Error := WinsockRoutines.setsockopt(aSocket, aLevel, aOptName, aOptValue, aOptValueLen);
+ if (Error = SOCKET_ERROR) then begin
+ Error := WinsockRoutines.WSAGetLastError;
+ raise EffWinsockException.CreateTranslate(Error, nil);
+ end;
+end;
+{====================================================================}
+
+
+initialization
+ UnitInitializationDone := false;
+ ffwsLoadedWinsockVersion := ffwvNone;
+ ffStrResWinsock := nil;
+ ffStrResWinsock := TffStringResource.Create(hInstance, 'FF_WINSOCK_ERROR_STRINGS');
+ InitializeCriticalSection(LockFFWSInstalled);
+
+finalization
+ FinalizeUnit;
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffllwsct.inc b/components/flashfiler/sourcelaz/ffllwsct.inc
new file mode 100644
index 000000000..a67160615
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffllwsct.inc
@@ -0,0 +1,107 @@
+{*********************************************************}
+{* FlashFiler: Winsock error string constants *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{===Winsock error codes===}
+const
+ WsaBASEERR = 10000;
+
+ { Windows Sockets definitions of regular Microsoft C error constants }
+ WsaEINTR = 10004;
+ WsaEBADF = 10009;
+ WsaEACCES = 10013;
+ WsaEFAULT = 10014;
+ WsaEINVAL = 10022;
+ WsaEMFILE = 10024;
+
+{ Windows Sockets definitions of regular Berkeley error constants }
+ WsaEWOULDBLOCK = 10035;
+ WsaEINPROGRESS = 10036;
+ WsaEALREADY = 10037;
+ WsaENOTSOCK = 10038;
+ WsaEDESTADDRREQ = 10039;
+ WsaEMSGSIZE = 10040;
+ WsaEPROTOTYPE = 10041;
+ WsaENOPROTOOPT = 10042;
+ WsaEPROTONOSUPPORT = 10043;
+ WsaESOCKTNOSUPPORT = 10044;
+ WsaEOPNOTSUPP = 10045;
+ WsaEPFNOSUPPORT = 10046;
+ WsaEAFNOSUPPORT = 10047;
+ WsaEADDRINUSE = 10048;
+ WsaEADDRNOTAVAIL = 10049;
+ WsaENETDOWN = 10050;
+ WsaENETUNREACH = 10051;
+ WsaENETRESET = 10052;
+ WsaECONNABORTED = 10053;
+ WsaECONNRESET = 10054;
+ WsaENOBUFS = 10055;
+ WsaEISCONN = 10056;
+ WsaENOTCONN = 10057;
+ WsaESHUTDOWN = 10058;
+ WsaETOOMANYREFS = 10059;
+ WsaETIMEDOUT = 10060;
+ WsaECONNREFUSED = 10061;
+ WsaELOOP = 10062;
+ WsaENAMETOOLONG = 10063;
+ WsaEHOSTDOWN = 10064;
+ WsaEHOSTUNREACH = 10065;
+ WsaENOTEMPTY = 10066;
+ WsaEPROCLIM = 10067;
+ WsaEUSERS = 10068;
+ WsaEDQUOT = 10069;
+ WsaESTALE = 10070;
+ WsaEREMOTE = 10071;
+
+ WsaEDISCON = 10101;
+
+ { Extended Windows Sockets error constant definitions }
+ WsaSYSNOTREADY = 10091;
+ WsaVERNOTSUPPORTED = 10092;
+ WsaNOTINITIALISED = 10093;
+
+ { Error return codes from gethostbyname() and gethostbyaddr() (when using the
+ resolver). Note that these errors are retrieved via WsaGetLastError() and
+ must therefore follow the rules for avoiding clashes with error numbers from
+ specific implementations or language run-time systems. For this reason the
+ codes are based at WsaBASEERR+1001. Note also that [Wsa]NO_ADDRESS is defined
+ only for compatibility purposes. }
+
+ { Authoritative Answer: Host not found }
+ WsaHOST_NOT_FOUND = 11001;
+
+ { Non-Authoritative: Host not found, or SERVERFAIL }
+ WsaTRY_AGAIN = 11002;
+
+ { Non recoverable errors, FORMERR, REFUSED, NOTIMP }
+ WsaNO_RECOVERY = 11003;
+
+ { Valid name, no data record of requested type }
+ WsaNO_DATA = 11004;
+
+
diff --git a/components/flashfiler/sourcelaz/ffllwsct.pas b/components/flashfiler/sourcelaz/ffllwsct.pas
new file mode 100644
index 000000000..d58a9bcfc
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffllwsct.pas
@@ -0,0 +1,86 @@
+{*********************************************************}
+{* FlashFiler: Winsock error string constants *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffllwsct;
+
+interface
+
+{$I ffllwsct.inc}
+
+{===Winsock error codes===}
+const
+ WsaNO_ADDRESS = WSANO_DATA;
+ Host_NOT_FOUND = WSAHOST_NOT_FOUND;
+ Try_AGAIN = WSATRY_AGAIN;
+ No_RECOVERY = WSANO_RECOVERY;
+ No_DATA = WSANO_DATA;
+ No_ADDRESS = WSANO_ADDRESS;
+ EWouldBLOCK = WSAEWOULDBLOCK;
+ EInPROGRESS = WSAEINPROGRESS;
+ EAlREADY = WSAEALREADY;
+ ENotSOCK = WSAENOTSOCK;
+ EDestADDRREQ = WSAEDESTADDRREQ;
+ EMsgSIZE = WSAEMSGSIZE;
+ EProtoTYPE = WSAEPROTOTYPE;
+ ENoPROTOOPT = WSAENOPROTOOPT;
+ EProtONOSUPPORT = WSAEPROTONOSUPPORT;
+ ESockTNOSUPPORT = WSAESOCKTNOSUPPORT;
+ EOpNOTSUPP = WSAEOPNOTSUPP;
+ EPfNOSUPPORT = WSAEPFNOSUPPORT;
+ EAfNOSUPPORT = WSAEAFNOSUPPORT;
+ EAddrINUSE = WSAEADDRINUSE;
+ EAddrNOTAVAIL = WSAEADDRNOTAVAIL;
+ ENetDOWN = WSAENETDOWN;
+ ENetUNREACH = WSAENETUNREACH;
+ ENetRESET = WSAENETRESET;
+ EConnABORTED = WSAECONNABORTED;
+ EConnRESET = WSAECONNRESET;
+ ENoBUFS = WSAENOBUFS;
+ EIsCONN = WSAEISCONN;
+ ENotCONN = WSAENOTCONN;
+ EShutDOWN = WSAESHUTDOWN;
+ ETooMANYREFS = WSAETOOMANYREFS;
+ ETimedOUT = WSAETIMEDOUT;
+ EConnREFUSED = WSAECONNREFUSED;
+ ELoop = WSAELOOP;
+ ENameTOOLONG = WSAENAMETOOLONG;
+ EHostDOWN = WSAEHOSTDOWN;
+ EHostUNREACH = WSAEHOSTUNREACH;
+ ENotEMPTY = WSAENOTEMPTY;
+ EProcLIM = WSAEPROCLIM;
+ EUsers = WSAEUSERS;
+ EDQuot = WSAEDQUOT;
+ EStale = WSAESTALE;
+ ERemote = WSAEREMOTE;
+
+implementation
+
+end.
diff --git a/components/flashfiler/sourcelaz/fflogdlg.dfm b/components/flashfiler/sourcelaz/fflogdlg.dfm
new file mode 100644
index 000000000..1186b300e
--- /dev/null
+++ b/components/flashfiler/sourcelaz/fflogdlg.dfm
@@ -0,0 +1,71 @@
+object FFLoginDialog: TFFLoginDialog
+ Left = 274
+ Top = 309
+ BorderStyle = bsDialog
+ Caption = 'FlashFiler Server Log On'
+ ClientHeight = 73
+ ClientWidth = 332
+ Color = clBtnFace
+ Font.Charset = DEFAULT_CHARSET
+ Font.Color = clWindowText
+ Font.Height = -11
+ Font.Name = 'MS Sans Serif'
+ Font.Style = []
+ FormStyle = fsStayOnTop
+ OldCreateOrder = True
+ Position = poScreenCenter
+ OnCreate = FormCreate
+ OnShow = FormShow
+ PixelsPerInch = 96
+ TextHeight = 13
+ object lblUserName: TLabel
+ Left = 15
+ Top = 15
+ Width = 57
+ Height = 13
+ Caption = '&User name: '
+ FocusControl = edtUserName
+ end
+ object lblPassword: TLabel
+ Left = 15
+ Top = 47
+ Width = 52
+ Height = 13
+ Caption = '&Password: '
+ FocusControl = edtPassword
+ end
+ object edtUserName: TEdit
+ Left = 79
+ Top = 11
+ Width = 154
+ Height = 21
+ TabOrder = 0
+ end
+ object edtPassword: TEdit
+ Left = 79
+ Top = 43
+ Width = 154
+ Height = 21
+ PasswordChar = '*'
+ TabOrder = 1
+ end
+ object btnOK: TButton
+ Left = 251
+ Top = 9
+ Width = 75
+ Height = 25
+ Caption = '&OK'
+ Default = True
+ TabOrder = 2
+ OnClick = btnOKClick
+ end
+ object btnCancel: TButton
+ Left = 251
+ Top = 41
+ Width = 75
+ Height = 25
+ Caption = 'Cancel'
+ ModalResult = 2
+ TabOrder = 3
+ end
+end
diff --git a/components/flashfiler/sourcelaz/fflogdlg.pas b/components/flashfiler/sourcelaz/fflogdlg.pas
new file mode 100644
index 000000000..fad91437a
--- /dev/null
+++ b/components/flashfiler/sourcelaz/fflogdlg.pas
@@ -0,0 +1,129 @@
+{*********************************************************}
+{* FlashFiler: Client Login Dialog *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit fflogdlg;
+
+interface
+
+uses
+ Windows,
+ Messages,
+ SysUtils,
+ Classes,
+ Graphics,
+ Controls,
+ Forms,
+ Dialogs,
+ StdCtrls,
+ ExtCtrls,
+ Buttons,
+ ffllbase;
+
+type
+ TFFLoginDialog = class(TForm)
+ lblUserName: TLabel;
+ edtUserName: TEdit;
+ edtPassword: TEdit;
+ lblPassword: TLabel;
+ btnOK: TButton;
+ btnCancel: TButton;
+ procedure btnOKClick(Sender: TObject);
+ procedure FormCreate(Sender: TObject);
+ procedure FormShow(Sender: TObject);
+ private
+ function GetPassowrd: string;
+ procedure SetPassword(const Value: string);
+ function GetUserName: string;
+ procedure SetUserName(const Value: string);
+ public
+ property UserName : string
+ read GetUserName
+ write SetUserName;
+ property Password : string
+ read GetPassowrd
+ write SetPassword;
+ end;
+
+var
+ FFLoginDialog: TFFLoginDialog;
+
+implementation
+
+{$R *.DFM}
+
+procedure TFFLoginDialog.btnOKClick(Sender: TObject);
+begin
+ if Length(edtUserName.Text) = 0 then begin
+ edtUserName.SetFocus;
+ MessageBeep(0);
+ Exit;
+ end;
+ if Length(edtPassword.Text ) = 0 then begin
+ edtPassword.SetFocus;
+ MessageBeep(0);
+ Exit;
+ end;
+ ModalResult := mrOK;
+end;
+{--------}
+function TFFLoginDialog.GetPassowrd: string;
+begin
+ Result := edtPassword.Text;
+end;
+{--------}
+function TFFLoginDialog.GetUserName: string;
+begin
+ Result := edtUserName.Text;
+end;
+{--------}
+procedure TFFLoginDialog.SetPassword(const Value: string);
+begin
+ edtPassword.Text := Value;
+end;
+{--------}
+procedure TFFLoginDialog.SetUserName(const Value: string);
+begin
+ edtUserName.Text := Value;
+end;
+{--------}
+procedure TFFLoginDialog.FormCreate(Sender: TObject);
+begin
+ edtUserName.MaxLength := ffcl_UserNameSize;
+ edtPassword.MaxLength := ffcl_GeneralNameSize;
+end;
+
+procedure TFFLoginDialog.FormShow(Sender: TObject);
+begin
+ if edtUserName.Text <> '' then
+ edtPassword.SetFocus;
+end;
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffnetmsg.pas b/components/flashfiler/sourcelaz/ffnetmsg.pas
new file mode 100644
index 000000000..335225db0
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffnetmsg.pas
@@ -0,0 +1,1215 @@
+{*********************************************************}
+{* FlashFiler: Network messaging types & constants *}
+{*********************************************************}
+
+(* ***** BEGIN LICENSE BLOCK *****
+ * Version: MPL 1.1
+ *
+ * The contents of this file are subject to the Mozilla Public License Version
+ * 1.1 (the "License"); you may not use this file except in compliance with
+ * the License. You may obtain a copy of the License at
+ * http://www.mozilla.org/MPL/
+ *
+ * Software distributed under the License is distributed on an "AS IS" basis,
+ * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
+ * for the specific language governing rights and limitations under the
+ * License.
+ *
+ * The Original Code is TurboPower FlashFiler
+ *
+ * The Initial Developer of the Original Code is
+ * TurboPower Software
+ *
+ * Portions created by the Initial Developer are Copyright (C) 1996-2002
+ * the Initial Developer. All Rights Reserved.
+ *
+ * Contributor(s):
+ *
+ * ***** END LICENSE BLOCK ***** *)
+
+{$I ffdefine.inc}
+
+unit ffnetmsg;
+
+interface
+
+uses
+ Windows,
+ Messages,
+ SysUtils,
+ ffllbase;
+
+{===Network message constants===}
+const
+ ffm_LostConnection = WM_USER + $0FF1;
+ ffm_StartTblReindex = WM_USER + $0FF2;
+ ffm_StartTblPack = WM_USER + $0FF3;
+ ffm_StartTblRestructure = WM_USER + $0FF4;
+ ffm_CopyData = WM_USER + $0FF5;
+ ffm_CallSingleUserServer = WM_USER + $0FF6;
+ ffm_KeepAlive = WM_USER + $0FF7;
+
+ ffmtRequest = 1; { Request sent from client to server }
+ ffmtReply = 2; { Reply sent from server to client }
+
+const
+ {general or non-BDE type}
+ ffnmDetachServer = $0002;
+ ffnmEndOfStream = $0003;
+ ffnmDetachServerJIC = $0004;
+ ffnmACK = $0005;
+ ffnmRequestServerName = $0006;
+ ffnmServerNameReply = $0007;
+ ffnmNewServerAdvert = $0008;
+ ffnmCheckSecureComms = $0009;
+ ffnmCheckConnection = $000A; {!!!!}
+ ffnmGetServerDateTime = $000C;
+ ffnmCallServer = $000D;
+ ffnmClientSetTimeout = $000E;
+ ffnmAttachServer = $000F;
+ ffnmGetServerSystemTime = $0010; {!!.10}
+ ffnmGetServerGUID = $0011; {!!.10}
+ ffnmGetServerID = $0012; {!!.10}
+
+ ffnmMultiPartMessage = $00FF;
+
+ {database related}
+ ffnmDatabaseOpen = $0100;
+ ffnmDatabaseClose = $0101;
+ ffnmDatabaseAliasList = $0102;
+ ffnmDatabaseTableList = $0103;
+ ffnmDatabaseAddAlias = $0104;
+ ffnmDatabaseOpenNoAlias = $0105;
+ ffnmDatabaseDeleteAlias = $0107;
+ ffnmDatabaseChgAliasPath = $0108;
+ ffnmDatabaseSetTimeout = $0109;
+ ffnmDatabaseGetFreeSpace = $010A;
+ ffnmDatabaseModifyAlias = $010B;
+ ffnmDatabaseGetAliasPath = $010C;
+ ffnmDatabaseTableExists = $010D;
+ ffnmDatabaseTableLockedExclusive = $010E;
+
+ {session related}
+ ffnmSessionAdd = $0200;
+ ffnmSessionClose = $0201;
+ ffnmSessionGetCurrent = $0202;
+ ffnmSessionSetCurrent = $0203;
+ ffnmSessionSetTimeout = $0204;
+ ffnmSessionCloseInactTbl = $0205; {!!.06}
+
+ {rebuild processes}
+ ffnmReindexTable = $0300;
+ ffnmPackTable = $0301;
+ ffnmRestructureTable = $0302;
+ ffnmGetRebuildStatus = $0303;
+
+ {transaction stuff}
+ ffnmStartTransaction = $0400;
+ ffnmEndTransaction = $0401;
+ ffnmStartTransactionWith = $0402; {!!.10}
+
+ {table stuff}
+ ffnmOpenTable = $0500;
+ ffnmAcqTableLock = $0510;
+ ffnmRelTableLock = $0511;
+ ffnmIsTableLocked = $0512;
+ ffnmGetTableDictionary = $0513;
+ ffnmBuildTable = $0514;
+ ffnmDeleteTable = $0515;
+ ffnmRenameTable = $0516;
+ ffnmGetTableRecCount = $0517;
+ ffnmEmptyTable = $0518;
+ ffnmAddIndex = $0519;
+ ffnmDropIndex = $051A;
+ ffnmSetTableAutoIncValue = $051B;
+ ffnmGetTableAutoIncValue = $051C;
+ ffnmGetTableRecCountAsync= $051D; {!!.10}
+ ffnmGetTableVersion = $051E; {!!.11}
+
+ {BLOB stuff}
+ ffnmCreateBLOB = $0600;
+ ffnmDeleteBLOB = $0601;
+ ffnmReadBLOB = $0602;
+ ffnmGetBLOBLength = $0603;
+ ffnmTruncateBLOB = $0604;
+ ffnmWriteBLOB = $0605;
+ ffnmAddFileBLOB = $0607;
+ ffnmFreeBLOB = $0608;
+ ffnmListBLOBFreeSpace = $0609; {!!.03}
+ ffnmListBLOBSegments = $060A; {!!.03}
+
+ {cursor stuff}
+ ffnmCursorSetToBegin = $0700;
+ ffnmCursorSetToEnd = $0701;
+ ffnmCursorClose = $0702;
+ ffnmCursorGetBookmark = $0703;
+ ffnmCursorSetToBookmark = $0704;
+ ffnmCursorSetToKey = $0705;
+ ffnmCursorSwitchToIndex = $0706;
+ ffnmCursorSetRange = $0707;
+ ffnmCursorResetRange = $0708;
+ ffnmCursorCompareBMs = $0709;
+ ffnmCursorClone = $070A;
+ ffnmCursorSetToCursor = $070B;
+ ffnmCursorSetFilter = $070C;
+ ffnmCursorOverrideFilter = $070D;
+ ffnmCursorRestoreFilter = $070E;
+ ffnmCursorSetTimeout = $070F;
+ ffnmCursorCopyRecords = $0710; {!!.02}
+ ffnmCursorDeleteRecords = $0711; {!!.06}
+
+ {record stuff}
+ ffnmRecordGet = $0800;
+ ffnmRecordGetNext = $0801;
+ ffnmRecordGetPrev = $0802;
+ ffnmRecordRelLock = $0803;
+ ffnmRecordDelete = $0804;
+ ffnmRecordInsert = $0805;
+ ffnmRecordModify = $0806;
+ ffnmRecordExtractKey = $0807;
+ ffnmRecordGetForKey = $0808;
+ ffnmRecordGetBatch = $0809;
+ ffnmRecordInsertBatch = $080A;
+ ffnmRecordGetForKey2 = $080C;
+ ffnmRecordDeleteBatch = $080D;
+ ffnmRecordIsLocked = $080E;
+
+ {SQL stuff}
+ ffnmSQLAlloc = $0900;
+ ffnmSQLExec = $0901;
+ ffnmSQLExecDirect = $0902;
+ ffnmSQLFree = $0903;
+ ffnmSQLPrepare = $0904;
+ ffnmSQLSetParams = $0905;
+
+ {Server Operations}
+ ffnmServerRestart = $0A00;
+ ffnmServerShutdown = $0A01;
+ ffnmServerStartup = $0A02;
+ ffnmServerStop = $0A03;
+
+ { Server Info }
+ ffnmServerIsReadOnly = $0B00;
+ ffnmServerStatistics = $0B01; {!!.10}
+ ffnmCmdHandlerStatistics = $0B02; {!!.10}
+ ffnmTransportStatistics = $0B03; {!!.10}
+
+ ffnmUser = $4000;
+
+{===Network message types===}
+type
+ PffnmHeader = ^TffnmHeader;
+ TffnmHeader = packed record {General message header}
+ nmhMsgID : longint; {..message identifier}
+ nmhMsgLen : longint; {..size of this message, incl. header}
+ nmhTotalSize: longint; {..total size of data over all messages}
+ nmhClientID : TffClientID;{..client ID (either from or to)}
+ nmhRequestID : longInt; {..client's requestID}
+ nmhErrorCode: TffResult; {..BDE error code, or 0 for success}
+ nmhTimeout : longInt; {..timeout in milliseconds}
+ nmhFirstPart: boolean; {..is this the 1st part of the message?}
+ nmhLastPart : boolean; {..is this the last part of the message?}
+ nmhDataType : TffNetMsgDataType; {..is message bytearray or stream?}
+ nmhMsgType : byte; {..is this a request or a reply? Declared as
+ byte so that you may create additional msg
+ types. }
+ nmhData : byte; {..data marker}
+ end;
+
+ PffsmHeader = ^TffsmHeader;
+ TffsmHeader = packed record {Sub-message header}
+ smhMsgID : longint; {..message identifier}
+ smhReplyLen : longint; {..size of this reply (header + data)}
+ smhErrorCode: TffWord16; {..BDE error code, or 0 for success}
+ smhDataType : TffNetMsgDataType; {..is message bytearray or stream?}
+ smhFiller : byte; {..filler}
+ smhData : byte; {..data marker}
+ end;
+
+const
+ ffc_NetMsgHeaderSize = sizeof(TffnmHeader) - sizeof(byte);
+ ffc_SubMsgHeaderSize = sizeof(TffsmHeader) - sizeof(byte);
+
+{NOTE: all message crackers are in two parts: the request data record
+ and the reply data record. If a message cracker has only a
+ request record, then all the data for the reply is contained in
+ the message header (and is generally just the error code).
+ Similarly if cracker only has a reply record then all the data
+ for the request is contained in the header (and is generally
+ the client ID and the message number). If neither is present,
+ the the data for the request and reply is entirely contained in
+ the message header.
+ }
+
+
+{===general or non-BDE type==========================================}
+type
+ {attach to server}
+ PffnmAttachServerReq = ^TffnmAttachServerReq;
+ TffnmAttachServerReq = packed record
+{Begin !!.03}
+{$IFDEF IsDelphi}
+ ClientName : TffNetName;
+{$ELSE}
+ ClientName : TffNetNameShr;
+{$ENDIF}
+{End !!.03}
+ UserID : TffName;
+ Timeout : longInt;
+ ClientVersion : longInt;
+ end;
+ PffnmAttachServerRpy = ^TffnmAttachServerRpy;
+ TffnmAttachServerRpy = packed record
+ ClientID : TffClientID;
+ VersionNumber : longint;
+ Code : longint;
+ LastMsgIntvl : longint;
+ KAIntvl : longint;
+ KARetries : longint;
+ IsSecure : boolean;
+ end;
+
+ {request server name - DATAGRAM ONLY}
+ PffnmRequestServerName = ^TffnmRequestServerName;
+ TffnmRequestServerName = packed record
+ MsgID : longint; {always ffnmRequestServerName}
+ end;
+
+ {server name reply - DATAGRAM ONLY}
+ PffnmServerNameReply = ^TffnmServerNameReply;
+ TffnmServerNameReply = packed record
+ MsgID : longint; {always ffnmServerNameReply}
+{Begin !!.03}
+{$IFDEF IsDelphi}
+ ServerLocalName : TffNetName;
+ ServerNetName : TffNetName;
+{$ELSE}
+ ServerLocalName : TffNetNameShr;
+ ServerNetName : TffNetNameShr;
+{$ENDIF}
+{End !!.03}
+ end;
+
+ PffnmGetServerDateTimeRpy = ^TffnmGetServerDateTimeRpy;
+ TffnmGetServerDateTimeRpy = packed record
+ ServerNow : TDateTime;
+ end;
+
+ PffnmGetServerSystemTimeRpy = ^TffnmGetServerSystemTimeRpy; {begin !!.10}
+ TffnmGetServerSystemTimeRpy = packed record
+ ServerNow : TSystemTime;
+ end;
+
+ PffnmGetServerGUIDRpy = ^TffnmGetServerGUIDRpy;
+ TffnmGetServerGUIDRpy = packed record
+ GUID : TGUID;
+ end;
+
+ PffnmGetServerIDRpy = ^TffnmGetServerIDRpy;
+ TffnmGetServerIDRpy = packed record
+ UniqueID : TGUID;
+ end; {end !!.10}
+
+ PffnmCallServerReq = ^TffnmCallServerReq;
+ TffnmCallServerReq = packed record
+{Begin !!.03}
+{$IFDEF IsDelphi}
+ ServerName : TffNetName;
+{$ELSE}
+ ServerName : TffNetNameShr;
+{$ENDIF}
+{End !!.03}
+ end;
+
+ PffnmCallServerRpy = ^TffnmCallServerRpy;
+ TffnmCallServerRpy = packed record
+ ClientID : TffClientID;
+ end;
+
+ { Set a client's timeout value.}
+ PffnmClientSetTimeoutReq = ^TffnmClientSetTimeoutReq;
+ TffnmClientSetTimeoutReq = packed record
+ Timeout : longInt;
+ end;
+ { Reply as an error in message header. }
+
+
+{===database related=================================================}
+type
+ {open database}
+ PffnmDatabaseOpenReq = ^TffnmDatabaseOpenReq;
+ TffnmDatabaseOpenReq = packed record
+ Alias : TffName;
+ OpenMode : TffOpenMode;
+ ShareMode : TffShareMode;
+ Timeout : longInt;
+ end;
+ PffnmDatabaseOpenRpy = ^TffnmDatabaseOpenRpy;
+ TffnmDatabaseOpenRpy = packed record
+ DatabaseID : TffDatabaseID;
+ end;
+
+ {close database (reply packet contained in header)}
+ PffnmDatabaseCloseReq = ^TffnmDatabaseCloseReq;
+ TffnmDatabaseCloseReq = packed record
+ DatabaseID : TffDatabaseID;
+ end;
+
+ {get list of tables in database (reply packet is a stream)}
+ PffnmDatabaseTableListReq = ^TffnmDatabaseTableListReq;
+ TffnmDatabaseTableListReq = packed record
+ DatabaseID : TffDatabaseID;
+ Mask : TffFileNameExt;
+ end;
+
+ {add new alias database}
+ PffnmDatabaseAddAliasReq = ^TffnmDatabaseAddAliasReq;
+ TffnmDatabaseAddAliasReq = packed record
+ Alias : TffName;
+ Path : TffPath;
+{Begin !!.11}
+ CheckDisk : Boolean;
+ end;
+ {reply as error in message header}
+ PffnmOldDatabaseAddAliasReq = ^TffnmOldDatabaseAddAliasReq;
+ TffnmOldDatabaseAddAliasReq = packed record
+ Alias : TffName;
+ Path : TffPath;
+ end;
+ { Used for backwards compatibility. }
+{End !!.11}
+
+ {open database without alias}
+ PffnmDatabaseOpenNoAliasReq = ^TffnmDatabaseOpenNoAliasReq;
+ TffnmDatabaseOpenNoAliasReq = packed record
+ Path : TffPath;
+ OpenMode : TffOpenMode;
+ ShareMode : TffShareMode;
+ Timeout : longInt;
+ end;
+ PffnmDatabaseOpenNoAliasRpy = ^TffnmDatabaseOpenNoAliasRpy;
+ TffnmDatabaseOpenNoAliasRpy = packed record
+ DatabaseID : TffDatabaseID;
+ end;
+
+ {delete an alias}
+ PffnmDatabaseDeleteAliasReq = ^TffnmDatabaseDeleteAliasReq;
+ TffnmDatabaseDeleteAliasReq = packed record
+ Alias : TffName;
+ end;
+ {reply as error in message header}
+
+ {retrieve the alias' path}
+ PffnmDatabaseGetAliasPathReq = ^TffnmDatabaseGetAliasPathReq;
+ TffnmDatabaseGetAliasPathReq = packed record
+ Alias : TffName;
+ end;
+ PffnmDatabaseGetAliasPathRpy = ^TffnmDatabaseGetAliasPathRpy;
+ TffnmDatabaseGetAliasPathRpy = packed record
+ Path : TffPath;
+ end;
+
+ PffnmDatabaseChgAliasPathReq = ^TffnmDatabaseChgAliasPathReq;
+ TffnmDatabaseChgAliasPathReq = packed record
+ Alias : TffName;
+ NewPath : TffPath;
+{Begin !!.11}
+ CheckDisk : Boolean;
+ end;
+ {reply as error in message header}
+ PffnmOldDatabaseChgAliasPathReq = ^TffnmOldDatabaseChgAliasPathReq;
+ TffnmOldDatabaseChgAliasPathReq = packed record
+ Alias : TffName;
+ NewPath : TffPath;
+ end;
+ { Used for backwards compatibility. }
+{End !!.11}
+
+ PffnmDatabaseSetTimeoutReq = ^TffnmDatabaseSetTimeoutReq;
+ TffnmDatabaseSetTimeoutReq = packed record
+ DatabaseID : TffDatabaseID;
+ Timeout : longInt;
+ end;
+ { Reply as error in message header. }
+
+ PffnmDatabaseGetFreeSpaceReq = ^TffnmDatabaseGetFreeSpaceReq;
+ TffnmDatabaseGetFreeSpaceReq = packed record
+ DatabaseID : TffDatabaseID;
+ end;
+
+ PffnmDatabaseGetFreeSpaceRpy = ^TffnmDatabaseGetFreeSpaceRpy;
+ TffnmDatabaseGetFreeSpaceRpy = packed record
+ FreeSpace : Longint;
+ end;
+
+ PffnmDatabaseModifyAliasReq = ^TffnmDatabaseModifyAliasReq;
+ TffnmDatabaseModifyAliasReq = packed record
+ ClientID : TffClientID;
+ Alias : TffName;
+ NewName : TffName;
+ NewPath : TffPath;
+{Begin !!.11}
+ CheckDisk : Boolean;
+ end;
+ {reply as error in message header}
+ PffnmOldDatabaseModifyAliasReq = ^TffnmOldDatabaseModifyAliasReq;
+ TffnmOldDatabaseModifyAliasReq = packed record
+ ClientID : TffClientID;
+ Alias : TffName;
+ NewName : TffName;
+ NewPath : TffPath;
+ end;
+ { Used for backwards compatibility. }
+{End !!.11}
+
+ PffnmDatabaseTableExistsReq = ^TffnmDatabaseTableExistsReq;
+ TffnmDatabaseTableExistsReq = packed record
+ DatabaseID : TffDatabaseID;
+ TableName : TffTableName;
+ end;
+ PffnmDatabaseTableExistsRpy = ^TffnmDatabaseTableExistsRpy;
+ TffnmDatabaseTableExistsRpy = packed record
+ Exists : Boolean;
+ end;
+
+ PffnmDatabaseTableLockedExclusiveReq = ^TffnmDatabaseTableLockedExclusiveReq;
+ TffnmDatabaseTableLockedExclusiveReq = packed record
+ DatabaseID : TffDatabaseID;
+ TableName : TffTableName;
+ end;
+ PffnmDatabaseTableLockedExclusiveRpy = ^TffnmDatabaseTableLockedExclusiveRpy;
+ TffnmDatabaseTableLockedExclusiveRpy = packed record
+ Locked : Boolean;
+ end;
+
+{===session related==================================================}
+type
+ {add session}
+ PffnmSessionAddReq = ^TffnmSessionAddReq;
+ TffnmSessionAddReq = packed record
+ Timeout : longInt;
+ end;
+ PffnmSessionAddRpy = ^TffnmSessionAddRpy;
+ TffnmSessionAddRpy = packed record
+ SessionID : TffSessionID;
+ end;
+
+ {close session (reply packet contained in header)}
+ PffnmSessionCloseReq = ^TffnmSessionCloseReq;
+ TffnmSessionCloseReq = packed record
+ SessionID : TffSessionID;
+ end;
+
+{Begin !!.06}
+ { Close unused tables }
+ PffnmSessionCloseInactiveTblReq = ^TffnmSessionCloseInactiveTblReq;
+ TffnmSessionCloseInactiveTblReq = packed record
+ SessionID : TffSessionID;
+ end;
+{End !!.06}
+
+ {get current session ID (request packet contained in header)}
+ PffnmSessionGetCurrentRpy = ^TffnmSessionGetCurrentRpy;
+ TffnmSessionGetCurrentRpy = packed record
+ SessionID : TffSessionID;
+ end;
+
+ {set current session ID (reply packet contained in header)}
+ PffnmSessionSetCurrentReq = ^TffnmSessionSetCurrentReq;
+ TffnmSessionSetCurrentReq = packed record
+ SessionID : TffSessionID;
+ end;
+
+ { Set session's timeout value. }
+ PffnmSessionSetTimeoutReq = ^TffnmSessionSetTimeoutReq;
+ TffnmSessionSetTimeoutReq = packed record
+ SessionID : TffSessionID;
+ Timeout : longInt;
+ end;
+ { Reply as error in message header. }
+
+
+{===rebuild processes================================================}
+type
+ {reindex table}
+ PffnmReindexTableReq = ^TffnmReindexTableReq;
+ TffnmReindexTableReq = packed record
+ DatabaseID : TffDatabaseID;
+ TableName : TffTableName;
+ IndexName : TffDictItemName;
+ IndexNumber: longint;
+ end;
+ PffnmReindexTableRpy = ^TffnmReindexTableRpy;
+ TffnmReindexTableRpy = packed record
+ RebuildID : longint;
+ end;
+
+ {pack table}
+ PffnmPackTableReq = ^TffnmPackTableReq;
+ TffnmPackTableReq = packed record
+ DatabaseID : TffDatabaseID;
+ TableName : TffTableName;
+ end;
+ PffnmPackTableRpy = ^TffnmPackTableRpy;
+ TffnmPackTableRpy = packed record
+ RebuildID : longint;
+ end;
+
+ {restructure table}
+ PffnmRestructureTableRpy = ^TffnmRestructureTableRpy;
+ TffnmRestructureTableRpy = packed record
+ RebuildID : longint;
+ end;
+
+ {get rebuild status}
+ PffnmGetRebuildStatusReq = ^TffnmGetRebuildStatusReq;
+ TffnmGetRebuildStatusReq = packed record
+ RebuildID : longint;
+ end;
+ PffnmGetRebuildStatusRpy = ^TffnmGetRebuildStatusRpy;
+ TffnmGetRebuildStatusRpy = packed record
+ Status : TffRebuildStatus;
+ IsPresent : boolean;
+ end;
+
+{===transaction stuff================================================}
+type
+ PffnmStartTransactionReq = ^TffnmStartTransactionReq;
+ TffnmStartTransactionReq = packed record
+ DatabaseID : TffDatabaseID;
+ FailSafe : boolean;
+ end;
+
+ PffnmEndTransactionReq = ^TffnmEndTransactionReq;
+ TffnmEndTransactionReq = packed record
+ DatabaseID : TffTransID;
+ ToBeCommitted : boolean;
+ end;
+
+{===table stuff======================================================}
+type
+ PffnmOpenTableReq = ^TffnmOpenTableReq;
+ TffnmOpenTableReq = packed record
+ DatabaseID : TffDatabaseID;
+ TableName : TffTableName;
+ IndexName : TffDictItemName;
+ IndexNumber: longint;
+ OpenMode : TffOpenMode;
+ ShareMode : TffShareMode;
+ Timeout : longInt;
+ end;
+ {open table replies with a stream}
+
+ PffnmAcqTableLockReq = ^TffnmAcqTableLockReq;
+ TffnmAcqTableLockReq = packed record
+ CursorID : TffCursorID;
+ LockType : TffLockType;
+ end;
+ {reply as error in message header}
+
+ PffnmRelTableLockReq = ^TffnmRelTableLockReq;
+ TffnmRelTableLockReq = packed record
+ CursorID : TffCursorID;
+ AllLocks : boolean;
+ LockType : TffLockType;
+ end;
+ {reply as error in message header}
+
+ PffnmIsTableLockedReq = ^TffnmIsTableLockedReq;
+ TffnmIsTableLockedReq = packed record
+ CursorID : TffCursorID;
+ LockType : TffLockType;
+ end;
+ PffnmIsTableLockedRpy = ^TffnmIsTableLockedRpy;
+ TffnmIsTableLockedRpy = packed record
+ IsLocked : boolean;
+ end;
+
+ PffnmGetTableDictionaryReq = ^TffnmGetTableDictionaryReq;
+ TffnmGetTableDictionaryReq = packed record
+ DatabaseID : TffDatabaseID;
+ TableName : TffTableName;
+ end;
+ {reply is a stream containing the dictionary}
+
+ PffnmDeleteTableReq = ^TffnmDeleteTableReq;
+ TffnmDeleteTableReq = packed record
+ DatabaseID : TffDatabaseID;
+ TableName : TffTableName;
+ end;
+ {reply as error in message header}
+
+ PffnmRenameTableReq = ^TffnmRenameTableReq;
+ TffnmrenameTableReq = packed record
+ DatabaseID : TffDatabaseID;
+ OldTableName : TffTableName;
+ NewTableName : TffTableName;
+ end;
+ {reply as error in message header}
+
+ PffnmGetTableRecCountReq = ^TffnmGetTableRecCountReq;
+ TffnmGetTableRecCountReq = packed record
+ CursorID : TffCursorID;
+ end;
+ PffnmGetTableRecCountRpy = ^TffnmGetTableRecCountRpy;
+ TffnmGetTableRecCountRpy = packed record
+ RecCount : longint;
+ end;
+
+{Begin !!.10}
+ PffnmGetTableRecCountAsyncReq = ^TffnmGetTableRecCountAsyncReq;
+ TffnmGetTableRecCountAsyncReq = packed record
+ CursorID : longint;
+ end;
+ PffnmGetTableRecCountAsyncRpy = ^TffnmGetTableRecCountAsyncRpy;
+ TffnmGetTableRecCountAsyncRpy = packed record
+ RebuildID : longint;
+ end;
+{End !!.10}
+
+ PffnmEmptyTableReq = ^TffnmEmptyTableReq;
+ TffnmEmptyTableReq = packed record
+ DatabaseID : TffDatabaseID;
+ CursorID : TffCursorID;
+ TableName : TffTableName;
+ end;
+ {reply as error in message header}
+
+ PffnmAddIndexReq = ^TffnmAddIndexReq;
+ TffnmAddIndexReq = packed record
+ DatabaseID : TffDatabaseID;
+ CursorID : TffCursorID;
+ TableName : TffTableName;
+ IndexDesc : TffIndexDescriptor;
+ end;
+ PffnmAddIndexRpy = ^TffnmAddIndexRpy;
+ TffnmAddIndexRpy = packed record
+ RebuildID : longint;
+ end;
+
+ PffnmDropIndexReq = ^TffnmDropIndexReq;
+ TffnmDropIndexReq = packed record
+ DatabaseID : TffDatabaseID;
+ CursorID : TffCursorID;
+ TableName : TffTableName;
+ IndexName : TffDictItemName;
+ IndexNumber: longint;
+ end;
+ {reply as error in message header}
+
+ PffnmSetTableAutoIncValueReq = ^TffnmSetTableAutoIncValueReq;
+ TffnmSetTableAutoIncValueReq = packed record
+ CursorID : TffCursorID;
+ AutoIncValue : TffWord32;
+ end;
+ {reply as error in message header}
+
+ PffnmGetTableAutoIncValueReq = ^TffnmGetTableAutoIncValueReq;
+ TffnmGetTableAutoIncValueReq = packed record
+ CursorID : TffCursorID;
+ end;
+ PffnmGetTableAutoIncValueRpy = ^TffnmGetTableAutoIncValueRpy;
+ TffnmGetTableAutoIncValueRpy = packed record
+ AutoIncValue : TffWord32;
+ end;
+
+{Begin !!.11}
+ { Get table version. }
+ PffnmGetTableVersionReq = ^TffnmGetTableVersionReq;
+ TffnmGetTableVersionReq = packed record
+ DatabaseID : TffDatabaseID;
+ TableName : TffTableName;
+ end;
+ PffnmGetTableVersionRpy = ^TffnmGetTableVersionRpy;
+ TffnmGetTableVersionRpy = packed record
+ Version : Longint;
+ end;
+{End !!.11}
+
+{===BLOB stuff=======================================================}
+type
+ PffnmCreateBLOBReq = ^TffnmCreateBLOBReq;
+ TffnmCreateBLOBReq = packed record
+ CursorID : TffCursorID;
+ end;
+ PffnmCreateBLOBRpy = ^TffnmCreateBLOBRpy;
+ TffnmCreateBLOBRpy = packed record
+ BLOBNr : TffInt64;
+ end;
+
+ PffnmDeleteBLOBReq = ^TffnmDeleteBLOBReq;
+ TffnmDeleteBLOBReq = packed record
+ CursorID : TffCursorID;
+ BLOBNr : TffInt64;
+ end;
+ {reply as error in message header}
+
+ PffnmGetBLOBLengthReq = ^TffnmGetBLOBLengthReq;
+ TffnmGetBLOBLengthReq = packed record
+ CursorID : TffCursorID;
+ BLOBNr : TffInt64;
+ end;
+ PffnmGetBLOBLengthRpy = ^TffnmGetBLOBLengthRpy;
+ TffnmGetBLOBLengthRpy = packed record
+ BLOBLength : longint;
+ end;
+
+ PffnmTruncateBLOBReq = ^TffnmTruncateBLOBReq;
+ TffnmTruncateBLOBReq = packed record
+ CursorID : TffCursorID;
+ BLOBNr : TffInt64;
+ BLOBLength : longint;
+ end;
+ {reply as error in message header}
+
+ PffnmReadBLOBReq = ^TffnmReadBLOBReq;
+ TffnmReadBLOBReq = packed record
+ CursorID : TffCursorID;
+ BLOBNr : TffInt64;
+ Offset : longint;
+ Len : longint;
+ end;
+ PffnmReadBLOBRpy = ^TffnmReadBLOBRpy;
+ TffnmReadBLOBRpy = packed record
+ BytesRead : TffWord32; {!!.06}
+ BLOB : TffVarMsgField;
+ end;
+
+ PffnmWriteBLOBReq = ^TffnmWriteBLOBReq;
+ TffnmWriteBLOBReq = packed record
+ CursorID : TffCursorID;
+ BLOBNr : TffInt64;
+ Offset : longint;
+ Len : longint;
+ BLOB : TffVarMsgField;
+ end;
+ {reply as error in message header}
+
+ PffnmFreeBLOBReq = ^TffnmFreeBLOBReq;
+ TffnmFreeBLOBReq = packed record
+ CursorID : longint;
+ BLOBNr : TffInt64;
+ ReadOnly : boolean;
+ end;
+ {reply as error in message header}
+
+ PffnmAddFileBLOBReq = ^TffnmAddFileBLOBReq;
+ TffnmAddFileBLOBReq = packed record
+ CursorID : TffCursorID;
+ FileName : TffFullFileName;
+ end;
+ PffnmAddFileBLOBRpy = ^TffnmAddFileBLOBRpy;
+ TffnmAddFileBLOBRpy = packed record
+ BLOBNr : TffInt64;
+ end;
+
+ {Begin !!.03}
+ {get list of free BLOB segments - reply is stream}
+ PffnmGetBLOBFreeSpaceReq = ^TffnmGetBLOBFreeSpaceReq;
+ TffnmGetBLOBFreeSpaceReq = packed record
+ CursorID : TffCursorID;
+ InMemory : Boolean;
+ end;
+
+ {get list of segments used by BLOB - reply is stream}
+ PffnmListBLOBSegmentsReq = ^TffnmListBLOBSegmentsReq;
+ TffnmListBLOBSegmentsReq = packed record
+ CursorID : TffCursorID;
+ BLOBNr : TffInt64;
+ end;
+ {End !!.03}
+
+{===Cursor stuff=====================================================}
+type
+ PffnmCursorSetToBeginReq = ^TffnmCursorSetToBeginReq;
+ TffnmCursorSetToBeginReq = packed record
+ CursorID : TffCursorID;
+ end;
+ {reply as error in message header}
+
+ PffnmCursorSetToEndReq = ^TffnmCursorSetToEndReq;
+ TffnmCursorSetToEndReq = packed record
+ CursorID : TffCursorID;
+ end;
+ {reply as error in message header}
+
+ PffnmCursorCloseReq = ^TffnmCursorCloseReq;
+ TffnmCursorCloseReq = packed record
+ CursorID : TffCursorID;
+ end;
+ {reply as error in message header}
+
+ PffnmCursorGetBookmarkReq = ^TffnmCursorGetBookmarkReq;
+ TffnmCursorGetBookmarkReq = packed record
+ CursorID : TffCursorID;
+ BookmarkSize : longint;
+ end;
+ {reply is a byte Array}
+
+ PffnmCursorSetToBookmarkReq = ^TffnmCursorSetToBookmarkReq;
+ TffnmCursorSetToBookmarkReq = packed record
+ CursorID : TffCursorID;
+ BookmarkSize : longint;
+ Bookmark : TffVarMsgField;
+ end;
+ {reply as error in message header}
+
+ PffnmCursorCompareBMsReq = ^TffnmCursorCompareBMsReq;
+ TffnmCursorCompareBMsReq = packed record
+ CursorID : TffCursorID;
+ BookmarkSize : longint;
+ Bookmark1 : TffVarMsgField;
+ Bookmark2 : TffVarMsgField;
+ end;
+ PffnmCursorCompareBMsRpy = ^TffnmCursorCompareBMsRpy;
+ TffnmCursorCompareBMsRpy = packed record
+ CompareResult : longint;
+ end;
+
+ PffnmCursorSetToKeyReq = ^TffnmCursorSetToKeyReq;
+ TffnmCursorSetToKeyReq = packed record
+ CursorID : TffCursorID;
+ Action : TffSearchKeyAction;
+ DirectKey : boolean;
+ FieldCount : longint;
+ PartialLen : longint;
+ KeyDataLen : longint;
+ KeyData : TffVarMsgField;
+ end;
+ {reply as error in message header}
+
+ PffnmCursorSwitchToIndexReq = ^TffnmCursorSwitchToIndexReq;
+ TffnmCursorSwitchToIndexReq = packed record
+ CursorID : TffCursorID;
+ IndexName : TffDictItemName;
+ IndexNumber: longint;
+ PosnOnRec : boolean;
+ end;
+ {reply as error in message header}
+
+ PffnmCursorResetRangeReq = ^TffnmCursorResetRangeReq;
+ TffnmCursorResetRangeReq = packed record
+ CursorID : TffCursorID;
+ end;
+ {reply as error in message header}
+
+ PffnmCursorSetRangeReq = ^TffnmCursorSetRangeReq;
+ TffnmCursorSetRangeReq = packed record
+ CursorID : TffCursorID;
+ DirectKey : boolean;
+ FieldCount1 : longint;
+ PartialLen1 : longint;
+ KeyLen1 : longint;
+ KeyIncl1 : boolean;
+ FieldCount2 : longint;
+ PartialLen2 : longint;
+ KeyLen2 : longint;
+ KeyIncl2 : boolean;
+ KeyData1 : TffVarMsgField; {key or record data depending on Direct Key}
+ KeyData2 : TffVarMsgField; {key or record data depending on Direct Key}
+ end;
+ {reply as an error in message header}
+
+ PffnmCursorCloneReq = ^TffnmCursorCloneReq;
+ TffnmCursorCloneReq = packed record
+ CursorID : TffCursorID;
+ OpenMode : TffOpenMode;
+ end;
+ PffnmCursorCloneRpy = ^TffnmCursorCloneRpy;
+ TffnmCursorCloneRpy = packed record
+ CursorID : TffCursorID;
+ end;
+
+ PffnmCursorSetToCursorReq = ^TffnmCursorSetToCursorReq;
+ TffnmCursorSetToCursorReq = packed record
+ DestCursorID : TffCursorID;
+ SrcCursorID : TffCursorID;
+ end;
+ {reply as an error in message header}
+
+ PffnmCursorSetFilterReq = ^TffnmCursorSetFilterReq;
+ TffnmCursorSetFilterReq = packed record
+ CursorID : TffCursorID;
+ Timeout : TffWord32;
+ ExprTree : TffVarMsgField;
+ end;
+
+ PffnmCursorOverrideFilterReq = ^TffnmCursorOverrideFilterReq;
+ TffnmCursorOverrideFilterReq = packed record
+ CursorID : longint;
+ Timeout : TffWord32;
+ ExprTree : TffVarMsgField;
+ end;
+
+ PffnmCursorRestoreFilterReq = ^TffnmCursorRestoreFilterReq;
+ TffnmCursorRestoreFilterReq = packed record
+ CursorID : longint;
+ end;
+
+ { Set a cursor's timeout value. }
+ PffnmCursorSetTimeoutReq = ^TffnmCursorSetTimeoutReq;
+ TffnmCursorSetTimeoutReq = packed record
+ CursorID : TffCursorID;
+ Timeout : longInt;
+ end;
+ { Reply as an error in message header. }
+
+{Begin !!.02}
+ { Copy records from one cursor to another. }
+ PffnmCursorCopyRecordsReq = ^TffnmCursorCopyRecordsReq;
+ TffnmCursorCopyRecordsReq = packed record
+ SrcCursorID : TffCursorID;
+ DestCursorID : TffCursorID;
+ CopyBLOBs : Boolean;
+ end;
+ { Reply as an error in message header. }
+{End !!.02}
+
+{Begin !!.06}
+ { Delete records from cursor. }
+ PffnmCursorDeleteRecordsReq = ^TffnmCursorDeleteRecordsReq;
+ TffnmCursorDeleteRecordsReq = packed record
+ CursorID : TffCursorID;
+ end;
+ { Reply as an error in message header. }
+{End !!.06}
+
+{===Record stuff=====================================================}
+type
+ PffnmRecordGetReq = ^TffnmRecordGetReq;
+ TffnmRecordGetReq = packed record
+ CursorID : TffCursorID;
+ RecLen : longint;
+ BookmarkSize : longint;
+ LockType : TffLockType;
+ end;
+ {reply is a byte Array}
+
+ PffnmRecordGetNextReq = ^TffnmRecordGetNextReq;
+ TffnmRecordGetNextReq = packed record
+ CursorID : TffCursorID;
+ RecLen : longint;
+ BookmarkSize : longint;
+ LockType : TffLockType;
+ end;
+ {reply is a byte Array}
+
+ PffnmRecordGetPrevReq = ^TffnmRecordGetPrevReq;
+ TffnmRecordGetPrevReq = packed record
+ CursorID : TffCursorID;
+ RecLen : longint;
+ BookmarkSize : longint;
+ LockType : TffLockType;
+ end;
+ {reply is a Byte Array}
+
+ PffnmRecordRelLockReq = ^TffnmRecordRelLockReq;
+ TffnmRecordRelLockReq = packed record
+ CursorID : TffCursorID;
+ AllLocks : Boolean;
+ end;
+ {reply as error in message header}
+
+ PffnmRecordDeleteReq = ^TffnmRecordDeleteReq;
+ TffnmRecordDeleteReq = packed record
+ CursorID : TffCursorID;
+ RecLen : longint; {if non 0, record is returned}
+ end;
+ {reply is a Byte Array}
+
+ PffnmRecordInsertReq = ^TffnmRecordInsertReq;
+ TffnmRecordInsertReq = packed record
+ CursorID : TffCursorID;
+ RecLen : longint;
+ BookmarkSize : longint;
+ LockType : TffLockType;
+ Data : TffVarMsgField;
+ end;
+ {reply as error in message header}
+
+ PffnmRecordModifyReq = ^TffnmRecordModifyReq;
+ TffnmRecordModifyReq = packed record
+ CursorID : TffCursorID;
+ RecLen : longint;
+ BookmarkSize : longint;
+ RelLock : Boolean;
+ Data : TffVarMsgField;
+ end;
+ {reply as error in message header}
+
+ PffnmRecordExtractKeyReq = ^TffnmRecordExtractKeyReq;
+ TffnmRecordExtractKeyReq = packed record
+ CursorID : TffCursorID;
+ KeyLen : longint;
+ ForCurrentRecord : boolean;
+ Data : TffVarMsgField;
+ end;
+ {reply is a byte array}
+
+ PffnmRecordGetForKeyReq = ^TffnmRecordGetForKeyReq;
+ TffnmRecordGetForKeyReq = packed record
+ CursorID : TffCursorID;
+ DirectKey : boolean;
+ FieldCount : longint;
+ PartialLen : longint;
+ RecLen : longint;
+ KeyDataLen : longint;
+ BookmarkSize : longint;
+ KeyData : TffVarMsgField;
+ end;
+ {reply is a byte array}
+
+ PffnmRecordGetForKeyReq2 = ^TffnmRecordGetForKeyReq2;
+ TffnmRecordGetForKeyReq2 = packed record
+ CursorID : longint;
+ DirectKey : boolean;
+ FieldCount : longint;
+ PartialLen : longint;
+ RecLen : longint;
+ KeyDataLen : longint;
+ BookmarkSize : longint;
+ FirstCall : Boolean;
+ KeyData : TffVarMsgField;
+ end;
+ {reply is a byte array}
+
+
+ PffnmRecordGetBatchReq = ^TffnmRecordGetBatchReq;
+ TffnmRecordGetBatchReq = packed record
+ CursorID : TffCursorID;
+ RecLen : longint;
+ RecCount : longint; {count of records requested}
+ {note: RecLen*RecCount < 64K}
+ end;
+ PffnmRecordGetBatchRpy = ^TffnmRecordGetBatchRpy;
+ TffnmRecordGetBatchRpy = packed record
+ RecCount : longint; {count of records read}
+ Error : TffResult; {Result of the last GetRecord call}
+ RecArray : TffVarMsgField; {place holder for array of records}
+ end;
+
+ PffnmRecordDeleteBatchReq = ^TffnmRecordDeleteBatchReq;
+ TffnmRecordDeleteBatchReq = packed record
+ CursorID : TffCursorID;
+ BMCount : Longint;
+ BMLen : Longint;
+ BMArray : TffVarMsgField;
+ end;
+ {reply as a longint array with BMCount elements}
+
+ PffnmRecordIsLockedReq = ^TffnmRecordIsLockedReq;
+ TffnmRecordIsLockedReq = packed record
+ CursorID : TffCursorID;
+ LockType : TffLockType;
+ end;
+ PffnmRecordIsLockedRpy = ^TffnmRecordIsLockedRpy;
+ TffnmRecordIsLockedRpy = packed record
+ IsLocked : Boolean;
+ end;
+
+ PffnmRecordInsertBatchReq = ^TffnmRecordInsertBatchReq;
+ TffnmRecordInsertBatchReq = packed record
+ CursorID : TffCursorID;
+ RecLen : longint;
+ RecCount : longint; {count of records requested}
+ {note: RecLen*RecCount < 64K}
+ RecArray : TffVarMsgField; {place holder for array of records}
+ end;
+ {reply is a longint array with RecCount elements}
+
+
+{===SQL stuff========================================================}
+type
+
+ PffnmSQLAllocReq = ^TffnmSQLAllocReq;
+ TffnmSQLAllocReq = packed record
+ DatabaseID : TffDatabaseID;
+ Timeout : longInt;
+ end;
+ PffnmSQLAllocRpy = ^TffnmSQLAllocRpy;
+ TffnmSQLAllocRpy = packed record
+ StmtID : TffSqlStmtID;
+ end;
+
+ PffnmSQLExecReq = ^TffnmSQLExecReq;
+ TffnmSQLExecReq = packed record
+ StmtID : TffSqlStmtID;
+ OpenMode : TffOpenMode;
+ end;
+ {Exec replies with a stream. If the execution succeeded, the first item in
+ the stream is the server's cursorID & the second item is the cursor's
+ data dictionary. If the execution failed, the first item in the stream is
+ the integer length of an error message. The second item in the stream is
+ the error message. }
+
+ PffnmSQLExecDirectReq = ^TffnmSQLExecDirectReq;
+ TffnmSQLExecDirectReq = packed record
+ DatabaseID : TffDatabaseID; {!!.03 - Start}
+ Timeout : longInt;
+ OpenMode : TffOpenMode;
+ Query : TffVarMsgField; {place holder for ZString query text}
+ end; {!!.03 - End}
+ {ExecDirect replies with a stream containing a cursorID,
+ a data dictionary, and an optional error message. If cursorID is zero then
+ no data dictionary. Error message is preceded by its length. If length is
+ zero then no error message. }
+
+ PffnmSQLFreeReq = ^TffnmSQLFreeReq;
+ TffnmSQLFreeReq = packed record
+ StmtID : TffSqlStmtID;
+ end;
+ {reply as error in message header}
+
+ PffnmSQLPrepareReq = ^TffnmSQLPrepareReq;
+ TffnmSQLPrepareReq = packed record
+ StmtID : TffSqlStmtID;
+ Query : TffVarMsgField; { place holder for ZString query text }
+ end;
+ {Prepare replies with an error code and a stream. If the error code is
+ DBIERR_NONE then the stream is empty. Otherwise the stream contains an
+ error message. The error message is preceded by its length. }
+
+ { Note: There is no data structure for SetParams. The parameters are
+ transmitted in stream format. }
+ {SetParams replies with an error code and a stream. If the error code is
+ DBIERR_NONE then the stream is empty. Otherwise the stream contains
+ an error message. The error message is preceded by its length. }
+
+
+{===Server Info stuff================================================}
+ { Server Info }
+ PffnmServerIsReadOnlyRpy = ^TffnmServerIsReadOnlyRpy;
+ TffnmServerIsReadOnlyRpy = packed record
+ IsReadOnly : boolean;
+ end;
+
+ PffnmServerStatisticsRpy = ^TffnmServerStatisticsRpy; {begin !!.10}
+ TffnmServerStatisticsRpy = packed record
+ Stats : TffServerStatistics;
+ end;
+
+ PffnmCmdHandlerStatisticsReq = ^TffnmCmdHandlerStatisticsReq;
+ TffnmCmdHandlerStatisticsReq = packed record
+ CmdHandlerIdx : Integer;
+ end;
+
+ PffnmCmdHandlerStatisticsRpy = ^TffnmCmdHandlerStatisticsRpy;
+ TffnmCmdHandlerStatisticsRpy = packed record
+ Stats : TffCommandHandlerStatistics;
+ end;
+
+ PffnmTransportStatisticsReq = ^TffnmTransportStatisticsReq;
+ TffnmTransportStatisticsReq = packed record
+ CmdHandlerIdx : Integer;
+ TransportIdx : Integer;
+ end;
+
+ PffnmTransportStatisticsRpy = ^TffnmTransportStatisticsRpy;
+ TffnmTransportStatisticsRpy = packed record
+ Stats : TffTransportStatistics;
+ end; {end !!.10}
+
+implementation
+
+
+end.
diff --git a/components/flashfiler/sourcelaz/ffsql.atg b/components/flashfiler/sourcelaz/ffsql.atg
new file mode 100644
index 000000000..315a5efd1
--- /dev/null
+++ b/components/flashfiler/sourcelaz/ffsql.atg
@@ -0,0 +1,1524 @@
+$B+ //Auto-increment build number (b)
+$C- //Generate Delphi test project (c)
+$E- //Generate a component registration unit (e)
+$R- //Save DFM as resource (r)
+$V+ //Generate version information (v)
+$Z- //Generate console app (z)
+
+// Not supported:
+// Bit strings
+// Time zones
+// OCTET_LENGTH function
+// COLLATE function
+// CONVERT function
+// UNION
+// CAST function
+// OVERLAPS condition
+
+// 2.10 extensive changes throughout
+
+COMPILER FFSQL
+
+DELPHI
+
+ USES (INTERFACE) FFSQLDef, FFSQLDB, Dialogs
+
+ PRIVATE
+ FRootNode : TFFSQLStatement;
+ FReservedWordList : TStringList;
+ FAllowReservedWordNames : boolean;
+
+ procedure Init;
+ procedure Final;
+ procedure InitReservedWordList;
+
+ function CheckSQLName(const SQLNameString : string) : string;
+ function IsColumnList : Boolean;
+ function Matches(n : integer) : Boolean;
+ function IsSymbol(n: integer): boolean; {mwr}
+
+ function IsParenNonJoinTableExp : Boolean;
+ function IsParenJoinTableExp: Boolean;
+ function IsParenTableExp: Boolean;
+ function IsNonJoinTableExp : Boolean;
+ function IsJoinTableExp: Boolean;
+ function IsTableExp: Boolean;
+ function IsTableRef: Boolean;
+
+ PUBLIC
+ property RootNode : TFFSqlStatement read FRootNode write FRootNode;
+ property AllowReservedWordNames : boolean read FAllowReservedWordNames write FAllowReservedWordNames;
+ CREATE
+ FRootNode := nil;
+ FReservedWordList := TStringList.Create;
+ FAllowReservedWordNames := True;
+ DESTROY
+ FReservedWordList.Free;
+ FReservedWordList := NIL;
+ ERRORS
+ 200 : Result := 'Text after end of valid sql statement';
+ 201 : Result := 'Nested aggregates are not allowed';
+ 202 : Result := 'Aggregates may not appear in a WHERE clause';
+ 203 : Result := 'Reserved word (' + data + ') not allowed';
+END_DELPHI
+
+(* Arbitrary Code *)
+
+procedure T-->Grammar<--.InitReservedWordList;
+begin
+ FReservedWordList.Add('ABS'); {!!.11}
+ FReservedWordList.Add('ALL');
+ FReservedWordList.Add('AND');
+ FReservedWordList.Add('ANY');
+ FReservedWordList.Add('AS');
+ FReservedWordList.Add('ASC');
+ FReservedWordList.Add('AVG');
+ FReservedWordList.Add('BETWEEN');
+ FReservedWordList.Add('BOTH');
+ FReservedWordList.Add('BY');
+ FReservedWordList.Add('CASE');
+ FReservedWordList.Add('CEILING'); {!!.11}
+ FReservedWordList.Add('CHARACTER_LENGTH');
+ FReservedWordList.Add('CHAR_LENGTH');
+ FReservedWordList.Add('COALESCE');
+ FReservedWordList.Add('COUNT');
+ FReservedWordList.Add('CROSS');
+ FReservedWordList.Add('CURRENT_DATE');
+ FReservedWordList.Add('CURRENT_TIME');
+ FReservedWordList.Add('CURRENT_TIMESTAMP');
+ FReservedWordList.Add('CURRENT_USER');
+ FReservedWordList.Add('DATE');
+ FReservedWordList.Add('DAY');
+ FReservedWordList.Add('DEFAULT');
+ FReservedWordList.Add('DELETE');
+ FReservedWordList.Add('DESC');
+ FReservedWordList.Add('DISTINCT');
+ FReservedWordList.Add('ELSE');
+ FReservedWordList.Add('END');
+ FReservedWordList.Add('EXP'); {!!.11}
+ FReservedWordList.Add('ESCAPE');
+ FReservedWordList.Add('EXISTS');
+ FReservedWordList.Add('EXTRACT');
+ FReservedWordList.Add('FALSE');
+ FReservedWordList.Add('FLOOR'); {!!.11}
+ FReservedWordList.Add('FOR');
+ FReservedWordList.Add('FROM');
+ FReservedWordList.Add('FULL');
+ FReservedWordList.Add('GROUP');
+ FReservedWordList.Add('HAVING');
+ FReservedWordList.Add('HOUR');
+ FReservedWordList.Add('IN');
+ FReservedWordList.Add('INNER');
+ FReservedWordList.Add('INSERT');
+ FReservedWordList.Add('INTERVAL');
+ FReservedWordList.Add('IS');
+ FReservedWordList.Add('JOIN');
+ FReservedWordList.Add('LEADING');
+ FReservedWordList.Add('LEFT');
+ FReservedWordList.Add('LIKE');
+ FReservedWordList.Add('LOG'); {!!.11}
+ FReservedWordList.Add('LOWER');
+ FReservedWordList.Add('MATCH');
+ FReservedWordList.Add('MAX');
+ FReservedWordList.Add('MIN');
+ FReservedWordList.Add('MINUTE');
+ FReservedWordList.Add('MONTH');
+ FReservedWordList.Add('NOINDEX');
+ FReservedWordList.Add('NOREDUCE');
+ FReservedWordList.Add('NOT');
+ FReservedWordList.Add('NULL');
+ FReservedWordList.Add('NULLIF');
+ FReservedWordList.Add('OR');
+ FReservedWordList.Add('ORDER');
+ FReservedWordList.Add('OUTER');
+ FReservedWordList.Add('PARTIAL');
+ FReservedWordList.Add('POSITION');
+ FReservedWordList.Add('POWER'); {!!.11}
+ FReservedWordList.Add('RAND'); {!!.11}
+ FReservedWordList.Add('RIGHT');
+ FReservedWordList.Add('ROUND'); {!!.11}
+ FReservedWordList.Add('SECOND');
+ FReservedWordList.Add('SELECT');
+ FReservedWordList.Add('SESSION_USER');
+ FReservedWordList.Add('SET');
+ FReservedWordList.Add('SOME');
+ FReservedWordList.Add('SUBSTRING');
+ FReservedWordList.Add('SUM');
+ FReservedWordList.Add('SYSTEM_USER');
+ FReservedWordList.Add('TABLE');
+ FReservedWordList.Add('THEN');
+ FReservedWordList.Add('TIME');
+ FReservedWordList.Add('TIMESTAMP');
+ FReservedWordList.Add('TO');
+ FReservedWordList.Add('TRAILING');
+ FReservedWordList.Add('TRIM');
+ FReservedWordList.Add('TRUE');
+ FReservedWordList.Add('UNIQUE');
+ FReservedWordList.Add('UNKNOWN');
+ FReservedWordList.Add('UPDATE');
+ FReservedWordList.Add('UPPER');
+ FReservedWordList.Add('USER');
+ FReservedWordList.Add('USING');
+ FReservedWordList.Add('VALUES');
+ FReservedWordList.Add('WHEN');
+ FReservedWordList.Add('WHERE');
+ FReservedWordList.Add('YEAR');
+ FReservedWordList.Sorted := TRUE;
+end;
+
+procedure T-->Grammar<--.Init;
+begin
+ fRootNode := TFFSqlStatement.Create;
+ fRootNode.UseIndex := True;
+ fRootNode.Reduce := True;
+ InitReservedWordList;
+end;
+
+procedure T-->Grammar<--.Final;
+begin
+ if successful and fRootNode.Reduce then
+ fRootNode.ReduceStrength;
+end;
+
+function T-->Grammar<--.CheckSQLName(const SQLNameString : string) : string;
+var
+ Idx : integer;
+begin
+ Result := copy(SQLNameString,2,length(SQLNameString) - 2);
+ if NOT fAllowReservedWordNames
+ AND fReservedWordList.Find(UpperCase(Result), Idx) then
+ SemError(203, Result);
+end;
+
+function T-->Grammar<--.IsSymbol(n : integer) : boolean;
+begin
+ if CurrentInputSymbol = n then
+ Result := True
+ else
+ Result := False;
+end;
+
+function T-->Grammar<--.Matches(n: integer): boolean;
+begin
+ Result := IsSymbol(n);
+ if Result then
+ Get;
+end; {Expect}
+
+function T-->Grammar<--.IsColumnList : boolean;
+var
+ BS: string;
+begin
+ Result := False;
+ BS := Bookmark;
+ try
+ if not Matches(_lparenSym) then exit;
+ if not Matches(identSym)
+ and not Matches(SQLNameStringSym) then exit;
+ while (fCurrentInputSymbol = _commaSym) do begin
+ Get;
+ if not Matches(identSym)
+ and not Matches(SQLNameStringSym) then exit;
+ end;
+ if not Matches(_rparenSym) then exit;
+ Result := True;
+ finally
+ GotoBookmark(BS);
+ end;
+end;
+
+function T-->Grammar<--.IsParenNonJoinTableExp : boolean;
+var
+ BS: string;
+begin
+ Result := False;
+ BS := Bookmark;
+ try
+ if not Matches(_lparenSym) then exit;
+ if not IsParenNonJoinTableExp
+ and not (fCurrentInputSymbol in [SELECTsym, TABLEsym, VALUESsym]) then
+ exit;
+ Result := True;
+ finally
+ GotoBookmark(BS);
+ end;
+end;
+
+function T-->Grammar<--.IsNonJoinTableExp : boolean;
+var
+ BS: string;
+begin
+ Result := False;
+ BS := Bookmark;
+ try
+ if not IsParenNonJoinTableExp
+ and not (fCurrentInputSymbol in [SELECTsym, TABLEsym, VALUESsym]) then
+ exit;
+ Result := True;
+ finally
+ GotoBookmark(BS);
+ end;
+end;
+
+function T-->Grammar<--.IsTableRef : boolean;
+begin
+ Result := False;
+ if (fCurrentInputSymbol = identSym) OR
+ (fCurrentInputSymbol = SQLNameStringSym) then begin
+ Get;
+ if (fCurrentInputSymbol = _pointSym) then begin
+ Get;
+ Get;
+ end;
+ Result := True;
+ end;
+end;
+
+function T-->Grammar<--.IsParenJoinTableExp : boolean;
+var
+ BS: string;
+begin
+ Result := False;
+ BS := Bookmark;
+ try
+ if not Matches(_lparenSym) then exit;
+ if not IsTableRef then exit;
+ if not (fCurrentInputSymbol in [CROSSSym, NATURALSym, INNERSym, LEFTSym, RIGHTSym, FULLSym, UNIONSym, JOINSym]) then
+ exit;
+ Result := True;
+ finally
+ GotoBookmark(BS);
+ end;
+end;
+
+function T-->Grammar<--.IsJoinTableExp : boolean;
+var
+ BS: string;
+begin
+ Result := False;
+ BS := Bookmark;
+ try
+ if not IsTableRef then exit;
+ if IsSymbol(ASSym) then
+ Get;
+ if IsSymbol(identSym) then
+ Get;
+ if not (fCurrentInputSymbol in [CROSSSym, NATURALSym, INNERSym, LEFTSym, RIGHTSym, FULLSym, UNIONSym, JOINSym]) then
+ exit;
+ Result := True;
+ finally
+ GotoBookmark(BS);
+ end;
+end;
+
+function T-->Grammar<--.IsParenTableExp : boolean;
+begin
+ Result := IsParenNonJoinTableExp or IsParenJoinTableExp;
+end;
+
+function T-->Grammar<--.IsTableExp : boolean;
+begin
+ Result := IsNonJoinTableExp or IsJoinTableExp or IsParenTableExp;
+end;
+
+(* End of Arbitrary Code *)
+
+IGNORE CASE
+
+CHARACTERS
+ eol = CHR(13) .
+ Special = '"' + "%&'()*+,-./:;<=>?|[]".
+ Digit = "0123456789" .
+ Letter = CHR(33)..CHR(255) - Special - Digit .
+ noQuote = ANY - "'" - eol .
+ noDblQuote = ANY - '"' - eol .
+
+TOKENS
+ ident = Letter { Letter | Digit }.
+ integer_ = Digit { Digit }.
+ float = [Digit { Digit }] "." Digit { Digit } .
+ SQLString = "'" { noQuote | "''" } "'" .
+ SQLNameString = '"' { noDblQuote } '"' .
+
+COMMENTS FROM "/*" TO "*/" NESTED
+COMMENTS FROM "--" TO eol
+COMMENTS FROM "//" TO eol
+
+IGNORE CHR(1)..CHR(32)
+
+PRODUCTIONS
+
+FFSQL (.
+ var TableExp: TffSqlTableExp;
+ var InsertSt: TffSqlINSERT;
+ var UpdateSt: TffSqlUPDATE;
+ var DeleteSt: TffSqlDELETE;
+ .)
+ = (. Init; .)
+ [ "NOINDEX" (. fRootNode.UseIndex := False .)
+ ]
+ [ "NOREDUCE" (. fRootNode.Reduce := False .)
+ ]
+
+ (
+ IF IsTableExp THEN
+ BEGIN
+ TableExp
+ (. fRootNode.TableExp := TableExp; .)
+ END
+ |
+ InsertStatement
+ (. fRootNode.Insert := InsertSt; .)
+ |
+ UpdateStatement
+ (. fRootNode.Update := UpdateSt; .)
+ |
+ DeleteStatement
+ (. fRootNode.Delete := DeleteSt; .)
+ )
+
+ [ ";" ]
+ (. if fCurrentInputSymbol <> EOFSYMB then
+ SynError(200);
+ Final; .)
+ .
+
+SelectStatement
+ (. var SelectionList : TFFSqlSelectionList;
+ var CondExp : TFFSqlCondExp;
+ var GroupColumnList : TFFSqlGroupColumnList;
+ var TableRefList : TFFSqlTableRefList;
+ var OrderList : TFFSqlOrderList; .)
+ =
+ "SELECT" (. Select := TFFSqlSELECT.Create(Parent); .)
+ ["ALL"
+ | "DISTINCT" (. Select.Distinct := True; .)
+ ]
+ ( SelectionList
+ (. Select.SelectionList := SelectionList; .)
+ )
+ "FROM" TableRefList
+ (. Select.TableRefList := TableRefList; .)
+ [ "WHERE"
+ (. Select.InWhere := True; .)
+ CondExp
+ (. Select.CondExpWhere := CondExp; .)
+ (. Select.InWhere := False; .)
+ ]
+ ["GROUP" "BY"
+ GroupColumnList
+ (. Select.GroupColumnList := GroupColumnList; .)
+ ]
+ ["HAVING" CondExp
+ (. Select.CondExpHaving := CondExp; .)
+ ]
+ ["ORDER" "BY" OrderList
+ (.Select.OrderList := OrderList; .)
+ ]
+ .
+
+InsertStatement
+ (. var aSQLName: string;
+ var InsertColumnList: TffSqlInsertColumnList;
+ var TableExp: TffSqlTableExp;
+ .)
+ =
+ "INSERT" "INTO" (. InsertSt := TFFSqlINSERT.Create(Parent); .)
+ SQLName (. InsertSt.TableName := aSQLName; .)
+ ( "DEFAULT" "VALUES" (. InsertSt.DefaultValues := True; .)
+ |
+ IF IsColumnList THEN
+ BEGIN
+ '('
+ InsertColumnList
+ (. InsertSt.InsertColumnList := InsertColumnList; .)
+ ')'
+ TableExp (. InsertSt.TableExp := TableExp; .)
+ END
+ |
+ TableExp (. InsertSt.TableExp := TableExp; .)
+ )
+ .
+
+TableExp
+ (. var NestedTableExp: TffSqlTableExp;
+ var JoinTableExp: TffSqlJoinTableExp;
+ var TmpJoinTableExp: TffSqlJoinTableExp;
+ var TmpTableExp: TffSqlTableExp;
+ var TableRef, TmpTableRef: TffSqlTableRef;
+ var NonJoinTableExp: TffSqlNonJoinTableExp; .)
+ = (. TableExp := TffSqlTableExp.Create(Parent); .)
+ (
+ IF IsJoinTableExp THEN
+ BEGIN
+ (. JoinTableExp := TffSqlJoinTableExp.Create(TableExp); .)
+ (. TableExp.JoinTableExp := JoinTableExp; .)
+
+ SimpleTableRefOrParenTableExp
+ (. JoinTableExp.TableRef1 := TableRef; .)
+
+ JoinTableExp
+
+ REPEAT
+ // If we get here we have more than two table expressions to join.
+ // Convert binary join just parsed to left leg of new binary join.
+ (. TmpJoinTableExp := JoinTableExp; .)
+ (. JoinTableExp := TffSqlJoinTableExp.Create(TableExp); .)
+ (. TableExp.JoinTableExp := JoinTableExp; .)
+ (. TmpTableRef := TffSqlTableRef.Create(JoinTableExp); .)
+ (. TmpTableExp := TffSqlTableExp.Create(TmpTableRef); .)
+ (. TmpJoinTableExp.Parent := TmpTableExp; .)
+ (. TmpTableExp.JoinTableExp := TmpJoinTableExp; .)
+ (. TmpTableRef.TableExp := TmpTableExp; .)
+ (. JoinTableExp.TableRef1 := TmpTableRef; .)
+ JoinTableExp
+ END_REPEAT
+ END
+
+ |
+ NonJoinTableExp
+ (. TableExp.NonJoinTableExp := NonJoinTableExp; .)
+ |
+ '('
+ TableExp
+ (. TableExp.NestedTableExp := NestedTableExp; .)
+ ')'
+ )
+ .
+
+JoinTableExp
+ (.
+ var TableRef: TffSqlTableRef;
+ var CondExp: TFFSqlCondExp;
+ var UsingList : TFFSqlUsingList;
+ .)
+ =
+ (
+ (
+ "CROSS" "JOIN" TableRef
+ (. JoinTableExp.JoinType := jtCross; .)
+ (. JoinTableExp.TableRef2 := TableRef; .)
+ | ["NATURAL" (. JoinTableExp.Natural := True; .) ]
+ (. JoinTableExp.JoinType := jtInner; .) // default
+ [ "INNER" |
+ "LEFT" ["OUTER"] (. JoinTableExp.JoinType := jtLeftOuter; .)|
+ "RIGHT" ["OUTER"] (. JoinTableExp.JoinType := jtRightOuter; .)|
+ "FULL" ["OUTER"] (. JoinTableExp.JoinType := jtFullOuter; .)|
+ "UNION" (. JoinTableExp.JoinType := jtUnion; .)
+ ]
+ "JOIN"
+ SimpleTableRefOrParenTableExp
+ (. JoinTableExp.TableRef2 := TableRef; .)
+ [ (
+ ("ON" CondExp
+ (. JoinTableExp.CondExp := CondExp; .)
+ )
+ | ("USING" "(" UsingList
+ ")" (. JoinTableExp.UsingList := UsingList; .)
+ )
+ )
+ ]
+ )
+ )
+ .
+
+UsingList
+ (. var UsingItem : TFFSqlUsingItem; .)
+ = (. UsingList := TFFSqlUsingList.Create(Parent); .)
+ UsingItem
+ (. UsingList.AddItem(UsingItem); .)
+ { "," UsingItem
+ (. UsingList.AddItem(UsingItem); .)
+ }
+ .
+
+UsingItem
+ (. var aSQLName: string; .)
+ = (. UsingItem := TFFSqlUsingItem.Create(Parent); .)
+ SQLName
+ (. UsingItem.ColumnName := aSQLName; .)
+ .
+
+NonJoinTableExp
+ (. var NonJoinTableTerm: TffSqlNonJoinTableTerm; .)
+ = (. NonJoinTableExp := TffSqlNonJoinTableExp.Create(Parent); .)
+ NonJoinTableTerm
+ (. NonJoinTableExp.NonJoinTableTerm := NonJoinTableTerm; .)
+ .
+
+NonJoinTableTerm
+ (. var NonJoinTablePrimary: TffSqlNonJoinTablePrimary; .)
+ = (. NonJoinTableTerm := TffSqlNonJoinTableTerm.Create(Parent); .)
+ NonJoinTablePrimary
+ (. NonJoinTableTerm.NonJoinTablePrimary := NonJoinTablePrimary; .)
+ .
+
+NonJoinTablePrimary
+ (. var ValueList: TffSqlValueList;
+ var NonJoinTableExp: TffSqlNonJoinTableExp;
+ var TableRef: TffSqlTableRef;
+ var SelectSt: TFFSqlSELECT; .)
+ =
+ (. NonJoinTablePrimary := TffSqlNonJoinTablePrimary.Create(Parent); .)
+ (
+ IF IsParenNonJoinTableExp THEN
+ BEGIN
+ "(" NonJoinTableExp
+ (. NonJoinTablePrimary.NonJoinTableExp := NonJoinTableExp; .)
+ ")"
+ END
+ |
+ SelectStatement (. NonJoinTablePrimary.SelectSt := SelectSt; .)
+ |
+ "TABLE" TableRef (. NonJoinTablePrimary.TableRef := TableRef; .)
+ |
+ TableConstructor (. NonJoinTablePrimary.ValueList := ValueList; .)
+ )
+ .
+
+TableConstructor
+ =
+ "VALUES" "(" ValueList ")"
+ .
+
+InsertColumnList
+ (. var InsertItem : TFFSqlInsertItem; .)
+ = (. InsertColumnList := TFFSqlInsertColumnList.Create(Parent); .)
+ InsertItem
+ (. InsertColumnList.AddItem(InsertItem); .)
+ { "," InsertItem
+ (. InsertColumnList.AddItem(InsertItem); .)
+ }
+ .
+
+InsertItem
+ (. var aSQLName: string; .)
+ = (. InsertItem := TFFSqlInsertItem.Create(Parent); .)
+ SQLName (. InsertItem.ColumnName := aSQLName; .)
+ .
+
+ValueList
+ (. var ValueItem : TFFSqlValueItem; .)
+ = (. ValueList := TFFSqlValueList.Create(Parent); .)
+ ValueItem
+ (. ValueList.AddItem(ValueItem); .)
+ { "," ValueItem
+ (. ValueList.AddItem(ValueItem); .)
+ }
+ .
+
+ValueItem
+ (.
+ var Simplex : TFFSqlSimpleExpression; .)
+ = (. ValueItem := TFFSqlValueItem.Create(Parent); .)
+ (
+ "DEFAULT" (. ValueItem.Default := True; .)
+ |
+ "NULL"
+ |
+ SimpleExpression (. ValueItem.Simplex := Simplex; .)
+ )
+ .
+
+
+DeleteStatement
+ (. var TableRef: TffSqlTableRef;
+ var CondExp: TFFSqlCondExp; .)
+ =
+ "DELETE" "FROM" (. DeleteSt := TFFSqlDELETE.Create(Parent); .)
+ SimpleTableRef (. DeleteSt.TableRef := TableRef; .)
+ [ "WHERE"
+ CondExp
+ (. DeleteSt.CondExpWhere := CondExp; .)
+ ]
+ .
+
+UpdateStatement
+ (. var TableRef: TffSqlTableRef;
+ var CondExp: TFFSqlCondExp;
+ var UpdateList: TFFSqlUpdateList; .)
+ =
+ "UPDATE" (. UpdateSt := TFFSqlUPDATE.Create(Parent); .)
+ SimpleTableRef (. UpdateSt.TableRef := TableRef; .)
+ "SET" UpdateList
+ (. UpdateSt.UpdateList := UpdateList; .)
+ [ "WHERE"
+ CondExp
+ (. UpdateSt.CondExpWhere := CondExp; .)
+ ]
+ .
+
+UpdateList
+ (. var UpdateItem : TFFSqlUpdateItem; .)
+ = (. UpdateList := TFFSqlUpdateList.Create(Parent); .)
+ UpdateItem
+ (. UpdateList.AddItem(UpdateItem); .)
+ { "," UpdateItem
+ (. UpdateList.AddItem(UpdateItem); .)
+ }
+ .
+
+UpdateItem
+ (. var Simplex : TFFSqlSimpleExpression;
+ var aSQLName : string; .)
+ = (. UpdateItem := TFFSqlUpdateItem.Create(Parent); .)
+ SQLName (. UpdateItem.ColumnName := aSQLName; .)
+ "="
+ ( "DEFAULT" (. UpdateItem.Default := True; .)
+ | "NULL"
+ | SimpleExpression (. UpdateItem.Simplex := Simplex; .)
+ )
+ .
+
+OrderList
+ (. var OrderItem : TFFSqlOrderItem; .)
+ = (. OrderList := TFFSqlOrderList.Create(Parent); .)
+ OrderItem
+ (. OrderList.AddOrderItem(OrderItem); .)
+ { "," OrderItem
+ (. OrderList.AddOrderItem(OrderItem); .)
+ }
+ .
+
+OrderItem
+ (. var OrderColumn : TFFSqlOrderColumn; .)
+ = (. OrderItem := TFFSqlOrderItem.Create(Parent); .)
+ ( OrderColumn
+ (. OrderItem.Column := OrderColumn; .)
+ | integer_ (. OrderItem.Index := LexString; .)
+ )
+ [ "ASC"
+ | "DESC" (. OrderItem.Descending := True; .)
+ ]
+ .
+
+OrderColumn
+ (. var
+ aSQLName : string; .)
+ =
+ (. Col := TFFSqlOrderColumn.Create(Parent);
+ aSQLName := ''; .)
+ ( SQLName
+
+ [ "." (. Col.TableName := aSQLName;
+ aSQLName := ''; .)
+ SQLName
+ ]
+ ) (. Col.FieldName := aSQLName; .)
+ .
+
+SelectionList
+ =
+ (. SelectionList := TFFSqlSelectionList.Create(Parent); .)
+ Selection
+ {"," Selection }
+ .
+
+Selection
+ (. var Selection : TFFSqlSelection;
+ var Exp : TFFSqlSimpleExpression;
+ var Term: TFFSqlTerm;
+ var Factor: TFFSqlFactor;
+ var FieldRef: TFFSqlFieldRef;
+ .)
+ = (. Selection := TFFSqlSelection.Create(SelectionList); .)
+
+ (
+ "*"
+ (.
+ Exp := TFFSqlSimpleExpression.Create(Selection);
+ Term := TFFSqlTerm.Create(Exp);
+ Factor := TFFSqlFactor.Create(Term);
+ FieldRef := TFFSqlFieldRef.Create(Factor);
+ Factor.FieldRef := FieldRef;
+ Term.AddFactor(Factor);
+ Exp.AddTerm(Term);
+ Selection.SimpleExpression := Exp;
+ .)
+ |
+ SimpleExpression
+ (. Selection.SimpleExpression := Exp; .)
+ [ ColumnAlias
+ ]
+ )
+ (. SelectionList.AddSelection(Selection); .)
+ .
+
+ColumnAlias
+ (. var Col : TFFSqlColumn;.) =
+ ["AS"]
+ Column
+ (. Selection.Column := Col; .)
+ .
+
+Aggregate
+ (. var SimpleExpression : TFFSqlSimpleExpression; .)
+ =
+ (. if Parent.OwnerSelect.InWhere then
+ SynError(202);
+ Aggregate := TFFSqlAggregate.Create(Parent); .)
+ (
+ ( ("COUNT" (. Aggregate.AgFunction := agCount; .)
+ "("
+ ("*" |
+ ["ALL" |
+ "DISTINCT" (. Aggregate.Distinct := True; .)
+ ]
+ SimpleExpression
+ (.Aggregate.SimpleExpression := SimpleExpression; .)
+ )
+ ")")
+ )
+ |(
+ ("MIN" (. Aggregate.AgFunction := agMin; .)
+ | "MAX" (. Aggregate.AgFunction := agMax; .)
+ | "SUM" (. Aggregate.AgFunction := agSum; .)
+ | "AVG" (. Aggregate.AgFunction := agAvg; .)
+ )
+ "("
+ ["ALL" |
+ "DISTINCT" (. Aggregate.Distinct := True; .)
+ ]
+ SimpleExpression
+ (. Aggregate.SimpleExpression := SimpleExpression;
+ if Aggregate.SimpleExpression.IsAggregateExpression then
+ SynError(201); .)
+ ")"
+ )
+ )
+
+ .
+
+FieldRef
+ (. var
+ aSQLName : string; .)
+ =
+ (. FieldRef := TFFSqlFieldRef.Create(Parent);
+ aSQLName := ''; .)
+ (
+ ( SQLName
+ [ "." (. FieldRef.TableName := aSQLName; .)
+ ( SQLName
+ | "*" (. aSQLName := ''; .)
+ )
+ ]
+ )
+ ) (. FieldRef.FieldName := aSQLName; .)
+ .
+
+GroupColumnList
+ (. var Col : TFFSqlGroupColumn; .)
+ = (. ColumnList := TFFSqlGroupColumnList.Create(Parent); .)
+ GroupColumn
+ (. ColumnList.AddColumn(Col); .)
+ { ","
+ GroupColumn
+ (. ColumnList.AddColumn(Col); .)
+ }
+ .
+
+
+Column
+ (. var ColumnName : string; .)
+ =
+ (. Col := TFFSqlColumn.Create(Parent); .)
+ // allow for quoted strings with spaces
+ SQLName (. Col.ColumnName := ColumnName; .)
+ .
+
+
+GroupColumn
+ (. var
+ aSQLName : string; .)
+ = (. Col := TFFSqlGroupColumn.Create(Parent);
+ aSQLName := ''; .)
+ ( SQLName
+
+ [ "." (. Col.TableName := aSQLName; .)
+ ( SQLName )
+ ]
+ ) (. Col.FieldName := aSQLName; .)
+ .
+
+CondExp
+ (. var CondTerm : TFFSqlCondTerm; .)
+ = (. CondExp := TFFSqlCondExp.Create(Parent); .)
+ CondTerm (. CondExp.AddCondTerm(CondTerm); .)
+ { "OR"
+ CondTerm (. CondExp.AddCondTerm(CondTerm); .)
+ }
+ .
+
+CondTerm
+ (. var CondFactor : TFFSqlCondFactor; .)
+ = (. CondTerm := TFFSqlCondTerm.Create(Parent); .)
+ CondFactor
+ (. CondTerm.AddCondFactor(CondFactor); .)
+ { "AND"
+ CondFactor
+ (. CondTerm.AddCondFactor(CondFactor); .)
+ }
+ .
+
+CondFactor
+ (. var CondPrimary : TFFSqlCondPrimary; .)
+ = (. CondFactor := TFFSqlCondFactor.Create(Parent); .)
+ ["NOT" (. CondFactor.UnaryNot := True; .)
+ ]
+ CondPrimary
+ (. CondFactor.CondPrimary := CondPrimary; .)
+ .
+
+CondPrimary
+ (. var SimpleExpression : TFFSqlSimpleExpression;
+ var RelOp : TFFSqlRelop;
+ var BetweenClause : TFFSqlBetweenClause;
+ var LikeClause : TFFSqlLikeClause;
+ var InClause : TFFSqlInClause;
+ var IsTest: TFFSqlIsTest;
+ var AllOrAny : TFFSqlAllOrAnyClause;
+ var ExistsClause : TFFSqlExistsClause;
+ var UniqueClause : TFFSqlUniqueClause;
+ var MatchClause : TFFSqlMatchClause; .)
+ = (. CondPrimary := TFFSqlCondPrimary.Create(Parent);
+ RelOp := roNone; .)
+ (
+ ExistsClause
+ (. CondPrimary.ExistsClause := ExistsClause; .)
+ |
+ UniqueClause
+ (. CondPrimary.UniqueClause := UniqueClause; .)
+ |
+ (
+ SimpleExpression
+ (. CondPrimary.SimpleExp1 := SimpleExpression; .)
+ [
+ (
+ ("=" (. RelOp := roEQ; .)
+ | "<=" (. RelOp := roLE; .)
+ | "<" (. RelOp := roL; .)
+ | ">" (. RelOp := roG; .)
+ | ">=" (. RelOp := roGE; .)
+ | "<>" (. RelOp := roNE; .)
+ ) (. CondPrimary.RelOp := RelOp; .)
+ (AllOrAnyClause
+ (. CondPrimary.AllOrAnyClause := AllOrAny; .)
+ | SimpleExpression
+ (. CondPrimary.SimpleExp2 := SimpleExpression; .)
+ )
+ | BetweenClause
+ (. CondPrimary.BetweenClause := BetweenClause; .)
+ | LikeClause
+ (. CondPrimary.LikeClause := LikeClause; .)
+ | InClause
+ (. CondPrimary.InClause := InClause; .)
+ | MatchClause
+ (. CondPrimary.MatchClause := MatchClause; .)
+ | "NOT"
+ (
+ BetweenClause
+ (. CondPrimary.BetweenClause := BetweenClause; .)
+ | LikeClause
+ (. CondPrimary.LikeClause := LikeClause; .)
+ | InClause
+ (. CondPrimary.InClause := InClause; .)
+ )
+ )
+ | IsTest
+ (. CondPrimary.IsTest := IsTest;
+ CondPrimary.RelOp := RoNone; .)
+ ]
+ )
+ )
+ .
+
+AllOrAnyClause
+ (. var Select : TFFSqlSelect; .)
+ = (. AllOrAny := TFFSqlAllOrAnyClause.Create(Parent); .)
+ ( "ALL" (. AllOrAny.All := True; .)
+ | "ANY" | "SOME" )
+
+ "("
+
+ SelectStatement
+ (. AllOrAny.SubQuery := Select; .)
+
+ ")"
+ .
+
+ExistsClause
+ (. var Select : TFFSqlSelect; .)
+ = (. Exists := TFFSqlExistsClause.Create(Parent); .)
+ "EXISTS"
+ "("
+ SelectStatement
+ (. Exists.SubQuery := Select; .)
+ ")"
+ .
+
+UniqueClause
+ //(. var Select : TFFSqlSelect; .)
+ (. var TableExp : TFFSqlTableExp; .)
+ = (. Unique := TFFSqlUniqueClause.Create(Parent); .)
+ "UNIQUE" "("
+ TableExp
+ (. Unique.SubQuery := TableExp; .)
+ ")"
+ .
+
+IsTest
+ =
+ "IS" (. IsTest := TFFSqlIsTest.Create(Parent); .)
+ ["NOT" (. IsTest.UnaryNot := True; .)
+ ] ("NULL" (. IsTest.IsOp := ioNull; .)
+ | "TRUE" (. IsTest.IsOp := ioTrue; .)
+ | "FALSE" (. IsTest.IsOp := ioFalse; .)
+ | "UNKNOWN" (. IsTest.IsOp := ioUnknown; .)
+ )
+ .
+
+BetweenClause
+ (. var SimpleExpression : TFFSqlSimpleExpression; .)
+ = (. BetweenClause := TFFSqlBetweenClause.Create(Parent);
+ BetweenClause.Negated := Negated; .)
+ "BETWEEN" SimpleExpression
+ (. BetweenClause.SimpleLow := SimpleExpression; .)
+ "AND" SimpleExpression
+ (. BetweenClause.SimpleHigh := SimpleExpression; .)
+ .
+
+LikeClause
+ (. var SimpleExpression : TFFSqlSimpleExpression; .)
+ = (. LikeClause := TFFSqlLikeClause.Create(Parent); .)
+ (. LikeClause.Negated := Negated; .)
+ "LIKE" SimpleExpression
+ (. LikeClause.SimpleExp := SimpleExpression; .)
+ ["ESCAPE" SimpleExpression
+ (. LikeClause.EscapeExp := SimpleExpression; .)
+ ]
+ ["IGNORE" "CASE" (. LikeClause.IgnoreCase := True; .) // !!.13
+ ]
+ .
+
+InClause
+ (. var SimpleExpressionList : TFFSqlSimpleExpressionList;
+ var Select : TFFSqlSelect; .)
+ //var TableExp : TFFSqlTableExp; .)
+ = (. InClause := TFFSqlInClause.Create(Parent); .)
+ (. InClause.Negated := Negated; .)
+ "IN" "("
+ (
+ SelectStatement
+ (. InClause.SubQuery := Select; .)
+ | SimpleExpressionList
+ (. Inclause.SimpleExpList := SimpleExpressionList; .)
+ )
+ ")"
+ .
+
+MatchClause
+ (. var Select : TFFSqlSelect; .)
+ = (. MatchClause := TFFSqlMatchClause.Create(Parent); .)
+ "MATCH"
+ ["UNIQUE" (. MatchClause.Unique := True; .)
+ ]
+ (. MatchClause.Option := moUnspec; .)
+ [ ("PARTIAL" (. MatchClause.Option := moPartial; .)
+ | "FULL" (. MatchClause.Option := moFull; .)
+ )
+ ]
+ "("
+ SelectStatement
+ (. MatchClause.SubQuery := Select; .)
+ ")"
+ .
+
+SimpleExpressionList
+ (. var SimpleExpression : TFFSqlSimpleExpression; .)
+ = (. SimpleExpressionList := TFFSqlSimpleExpressionList.Create(Parent); .)
+ SimpleExpression
+ (. SimpleExpressionList.AddExpression(SimpleExpression); .)
+ { ","
+ SimpleExpression
+ (. SimpleExpressionList.AddExpression(SimpleExpression); .)
+ }
+ .
+
+SimpleExpression
+ (. var Term : TFFSqlTerm;
+ var AO : TFFSqlAddOp; .)
+ = (. SimpleExpression := TFFSqlSimpleExpression.Create(Parent); .)
+ Term
+ (. SimpleExpression.AddTerm(Term); .)
+ {
+ ("+" (. AO := aoPlus; .)
+ |
+ "-" (. AO := aoMinus; .)
+ |
+ "||" (. AO := aoConcat; .)
+ )
+ Term
+ (. SimpleExpression.AddTerm(Term); .)
+ }
+ .
+
+Term
+ (. var Factor : TFFSqlFactor;
+ var MO : TFFSqlMulOp; .)
+ =
+ (. Term := TFFSqlTerm.Create(Parent);
+ Term.AddOp := AddOp; .)
+
+ Factor (. Term.AddFactor(Factor); .)
+ { ("*" (. MO := moMul; .)
+ | "/" (. MO := moDiv; .)
+ )
+ Factor (. Term.AddFactor(Factor); .)
+ }
+ .
+
+Factor
+ (. var FieldRef : TFFSqlFieldRef;
+ var CondExp : TFFSqlCondExp;
+ var Literal : TFFSqlLiteral;
+ var Param : TFFSqlParam;
+ var Select : TFFSqlSELECT;
+ var Agg : TFFSqlAggregate;
+ var Func : TFFSqlScalarFunc; .)
+ = (. Factor := TFFSqlFactor.Create(Parent);
+ Factor.MulOp := MulOp; .)
+ [ "-" (. Factor.UnaryMinus := True; .)
+ ]
+ (("("
+ (
+ CondExp (. Factor.CondExp := CondExp; .)
+ |
+ SelectStatement
+ (. Factor.SubQuery := Select; .)
+ )
+ ")"
+ )
+ | FieldRef
+ (. Factor.FieldRef := FieldRef; .)
+ | Literal
+ (. Factor.Literal := Literal; .)
+ | Param (. Factor.Param := Param; .)
+ | Aggregate
+ (. Factor.Aggregate := Agg; .)
+ | ScalarFunction
+ (. Factor.ScalarFunc := Func; .)
+ )
+ .
+
+ScalarFunction
+ (. var Exp : TFFSqlSimpleExpression;
+ var CaseExp : TFFSqlCaseExpression;
+ var CoalesceExp : TFFSqlCoalesceExpression; .)
+ = (. Func := TFFSqlScalarFunc.Create(Parent); .)
+ (
+ "CASE"
+ CaseExpression
+ (. Func.CaseExp := CaseExp; .)
+ (. Func.SQLFunction := sfCase; .)
+ | ("CHARACTER_LENGTH"
+ | "CHAR_LENGTH")
+ "(" SimpleExpression ")"
+ (. Func.SQLFunction := sfCharLen; .)
+ (. Func.Arg1 := Exp; .)
+ | "COALESCE"
+ CoalesceExpression
+ (. Func.CoalesceExp := CoalesceExp; .)
+ (. Func.SQLFunction := sfCoalesce; .)
+ | "CURRENT_DATE" (. Func.SQLFunction := sfCurrentDate; .)
+ | "CURRENT_TIME" (. Func.SQLFunction := sfCurrentTime; .)
+ | "CURRENT_TIMESTAMP" (. Func.SQLFunction := sfCurrentTimestamp; .)
+ | ("CURRENT_USER"
+ | "USER" ) (. Func.SQLFunction := sfCurrentUser; .)
+ | "LOWER" "(" SimpleExpression ")"
+ (. Func.SQLFunction := sfLower; .)
+ (. Func.Arg1 := Exp .)
+ | "UPPER"
+ "("
+ SimpleExpression ")"
+ (. Func.SQLFunction := sfUpper;
+ Func.Arg1 := Exp; .)
+ | "POSITION"
+ "("
+ SimpleExpression
+ (. Func.SQLFunction := sfPosition;
+ Func.Arg1 := Exp; .)
+ ("," | "IN" )
+
+ SimpleExpression
+ (. Func.Arg2 := Exp; .)
+ ")"
+ | "SESSION_USER" (. Func.SQLFunction := sfSessionUser; .)
+ | "SUBSTRING"
+ "("
+ SimpleExpression
+ (. Func.SQLFunction := sfSubstring;
+ Func.Arg1 := Exp; .)
+ "FROM"
+ SimpleExpression
+ (. Func.Arg2 := Exp; .)
+ [ "FOR"
+ SimpleExpression
+ (. Func.Arg3 := Exp; .)
+ ]
+ ")"
+
+ | "SYSTEM_USER" (. Func.SQLFunction := sfSystemUser; .)
+ | "TRIM" "(" (. Func.SQLFunction := sfTrim;
+ Func.LTB := ltbBoth; .)
+ ["LEADING" (. Func.LTB := ltbLeading; .)
+ |"TRAILING" (. Func.LTB := ltbTrailing; .)
+ | "BOTH"
+ ]
+ [SimpleExpression
+ (. Func.Arg1 := Exp; .)]
+ [ "FROM"
+ SimpleExpression
+ (. Func.Arg2 := Exp .)
+ ]
+ ")"
+ | "EXTRACT" "(" (. Func.SQLFunction := sfExtract; .)
+ ("YEAR" (. Func.xDef := iYear; .)
+ | "MONTH" (. Func.xDef := iMonth; .)
+ | "DAY" (. Func.xDef := iDay; .)
+ | "HOUR" (. Func.xDef := iHour; .)
+ | "MINUTE" (. Func.xDef := iMinute; .)
+ | "SECOND" (. Func.xDef := iSecond; .)
+ )
+ "FROM"
+ SimpleExpression
+ (. Func.Arg1 := Exp; .)
+ ")"
+ | "NULLIF" "(" (. Func.SQLFunction := sfNullIf; .)
+ SimpleExpression
+ (. Func.Arg1 := Exp; .)
+ "," SimpleExpression
+ (. Func.Arg2 := Exp; .)
+ ")"
+ | "ABS" "(" (. Func.SQLFunction := sfAbs; .)
+ SimpleExpression
+ (. Func.Arg1 := Exp; .)
+ ")"
+ | "CEILING" "(" (. Func.SQLFunction := sfCeil; .)
+ SimpleExpression
+ (. Func.Arg1 := Exp; .)
+ ")"
+ | "FLOOR" "(" (. Func.SQLFunction := sfFloor; .)
+ SimpleExpression
+ (. Func.Arg1 := Exp; .)
+ ")"
+ | "EXP" "(" (. Func.SQLFunction := sfExp; .)
+ SimpleExpression
+ (. Func.Arg1 := Exp; .)
+ ")"
+ | "LOG" "(" (. Func.SQLFunction := sfLog; .)
+ SimpleExpression
+ (. Func.Arg1 := Exp; .)
+ ")"
+ | "POWER" "(" (. Func.SQLFunction := sfPower; .)
+ SimpleExpression
+ (. Func.Arg1 := Exp; .)
+ "," SimpleExpression
+ (. Func.Arg2 := Exp; .)
+ ")"
+ | "RAND" (. Func.SQLFunction := sfRand; .)
+ | "ROUND" "(" (. Func.SQLFunction := sfRound; .)
+ SimpleExpression
+ (. Func.Arg1 := Exp; .)
+ ")"
+ )
+ .
+
+CoalesceExpression
+ (. var Exp : TFFSqlSimpleExpression; .)
+ = (. CoalesceExp := TFFSqlCoalesceExpression.Create(Parent); .)
+ "("
+ SimpleExpression
+ (. CoalesceExp.AddArg(Exp); .)
+ { "," SimpleExpression
+ (. CoalesceExp.AddArg(Exp); .)
+ }
+ ")"
+ .
+
+CaseExpression
+ (. var WhenClauseList : TFFSqlWhenClauseList;
+ var Exp : TFFSqlSimpleExpression; .)
+ =
+ (. CaseExp := TFFSqlCaseExpression.Create(Parent); .)
+ WhenClauseList
+ (. CaseExp.WhenClauseList := WhenClauseList; .)
+ ["ELSE"
+ ("NULL"
+ | SimpleExpression
+ (. CaseExp.ElseExp := Exp; .)
+ )
+ ]
+ "END"
+ .
+
+WhenClauseList
+ (. var WhenClause : TFFSqlWhenClause; .)
+ =
+ (. WhenClauseList := TFFSqlWhenClauseList.Create(Parent); .)
+ WhenClause
+ (. WhenClauseList.AddWhenClause(WhenClause); .)
+ { WhenClause
+ (. WhenClauseList.AddWhenClause(WhenClause); .) }
+ .
+
+WhenClause
+ (. var CondExp : TFFSqlCondExp;
+ Exp : TFFSqlSimpleExpression; .)
+ =
+ (. WhenClause := TFFSqlWhenClause.Create(Parent); .)
+ "WHEN" CondExp
+ (. WhenClause.WhenExp := CondExp; .)
+ "THEN"
+ ("NULL"
+ | SimpleExpression
+ (. WhenClause.ThenExp := Exp; .)
+ )
+ .
+
+Param